Require Import List.
Require Import Nat.
Require Import Bool.
Require Export Coq.Arith.Compare_dec.
Require Import Coq.Arith.Lt.
Require Import Coq.Arith.PeanoNat.
Require Import Lia.
Import ListNotations.

Lemma eqb_reflect : forall x y, reflect (x = y) (x =? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.eqb_eq.
Qed.

Lemma ltb_reflect : forall x y, reflect (x < y) (x <? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.ltb_lt.
Qed.

Lemma leb_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.leb_le.
Qed.

Ltac bdestruct X :=
  let H := fresh in let e := fresh "e" in
   evar (e: Prop);
   assert (H: reflect e X); subst e;
    [eauto with bdestruct
    | destruct H as [H|H];
       [ | try first [apply not_lt in H | apply not_le in H]]].
#[export]
Hint Resolve ltb_reflect leb_reflect eqb_reflect : bdestruct.

Lemma eq_list {A} : forall (a : A) (l1 l2 : list A),
  a :: l1 = a :: l2 -> l1 = l2.
Proof.
  intros.
  inversion H. reflexivity.
Qed.

(** * Insertion

Inserting a number into a list will guarantee the number appears exactly once.
*)
Fixpoint insert (i : nat) (l : list nat) :=
  match l with
  | [] => [i]
  | h :: t => if i <? h then i :: h :: t
              else if i =? h then l
              else h :: insert i t
  end.

Lemma insert_lt : forall (n h : nat) (t : list nat),
  n < h -> insert n (h :: t) = n :: h :: t.
Proof.
  intros.
  apply Nat.ltb_lt in H as H1.
  unfold insert. rewrite H1. reflexivity.
Qed.

Lemma insert_eq : forall (n h : nat) (t : list nat),
  n = h -> insert n (h :: t) = h :: t.
Proof.
  intros.
  apply Nat.eqb_eq in H as H1.
  unfold insert.
  destruct (ltb_reflect n h).
  contradict l. Nat.order.
  rewrite H1. reflexivity.
Qed.

Lemma insert_gt : forall (n h : nat) (t : list nat),
  n > h -> insert n (h :: t) = h :: (insert n t).
Proof.
  intros.
  apply Nat.ltb_lt in H as H1.
  unfold insert.
  destruct (ltb_reflect n h).
  contradict l. apply le_not_lt. lia.
  destruct (eqb_reflect n h).
  contradict e. lia. reflexivity.
Qed.

Theorem insert_inv : forall (n : nat) (l : list nat),
  In n (insert n l).
Proof.
  intros.
  induction l.
  - (* Base case: l = [] *)
    unfold insert; unfold In. auto.
  - (* Inductive case: l = a::l *)
    assert (n = a \/ n > a \/ n < a). lia.
    inversion H.
  -- (* Subcase: n = a *)
    rewrite <- H0. apply Nat.eqb_eq in H0 as H1. unfold insert.
    destruct (ltb_reflect n n). apply (in_eq n (n :: l)).
    rewrite <- H0 in H1. rewrite H1. apply (in_eq n l).
  -- inversion H0.
  --- (* Subcase: n > a *)
      apply (insert_gt n a l) in H1 as H2. rewrite H2.
      apply (in_cons a n (insert n l)). assumption.
  --- (* Subcase: n < a *)
      apply (insert_lt n a l) in H1 as H2. rewrite H2.
      apply (in_eq n (a :: l)).
Qed.

Theorem insert_preserves_elts : forall (e n : nat) (l : list nat),
  In e l -> In e (insert n l).
Proof.
  intros. induction l.
  - contradict H.
  - (* Inductive case: l = a :: l *)
    assert (e = a \/ e <> a). lia. inversion H0.
    + (* Case: e = a *)
      assert (n = a \/ n < a \/ n > a). lia. inversion H2.
      ++ apply (insert_eq n a l) in H3. rewrite H3. assumption.
      ++ inversion H3.
      +++ (* Subcase: n = a *)
          apply (insert_lt n a l) in H4 as H5. rewrite H5. rewrite <- H1.
          unfold In. auto.
      +++ (* Subcase n < a *)
          apply (insert_gt n a l) in H4 as H5. rewrite H5. rewrite <- H1.
          apply (in_eq e (insert n l)).
    + (* Case: e <> a *)
      assert (n = a \/ n < a \/ n > a). lia. inversion H2.
    ++ (* Subcase: a = n *)
       apply (insert_eq n a l) in H3 as H4. rewrite H4. assumption.
    ++ inversion H3.
    +++ (* Subcase: n < a *)
        apply (insert_lt n a l) in H4 as H5. rewrite H5.
        assert (e = n \/ e <> n). lia. inversion H6.
        rewrite H7. apply (in_eq n (a::l)).
        unfold In. simpl; auto.
    +++ (* Subcase: n > a *)
        apply (insert_gt n a l) in H4 as H5. rewrite H5.
        assert (e = n \/ e <> n). lia. inversion H6.
        rewrite H7. apply (in_cons a n (insert n l)). apply (insert_inv n l).
        apply (in_cons a e (insert n l)).
        inversion H. apply eq_sym in H8. contradict H8. assumption.
         apply IHl. assumption.
Qed.

Theorem insert_nonempty : forall (n : nat) (l : list nat),
  [] <> (insert n l).
Proof. intros. induction l.
  - unfold insert. apply nil_cons.
  - assert (n < a \/ n = a \/ n > a). lia. inversion H.
  + apply (insert_lt n a l) in H0 as H1. rewrite H1. discriminate.
  + inversion H0.
  ++ apply (insert_eq n a l) in H1 as H2. rewrite H2. discriminate.
  ++ apply (insert_gt n a l) in H1 as H2. rewrite H2. discriminate.
Qed.

(** Now we have an inductive way to specify if our set of [nat]
is sorted or not. *)
Inductive sorted : list nat -> Prop :=
| sorted_nil :
    sorted []
| sorted_1 : forall x,
    sorted [x]
| sorted_cons : forall x y l,
    x < y -> sorted (y :: l) -> sorted (x :: y :: l).

Theorem sorted_tl : forall (n : nat) (l : list nat),
  sorted (n :: l) -> sorted l.
Proof.
  intros. induction l.
  - apply sorted_nil.
  - inversion H. assumption.
Qed.

Lemma sorted_head : forall (n a : nat) (l : list nat),
  sorted (a :: l) -> Some a = hd_error (insert n (a :: l)) \/ Some n = hd_error (insert n (a :: l)).
Proof.
  intros.
  assert (a < n \/ n = a \/ a > n). lia. inversion H0.
  - (* Case 1: a < n *)
    apply (insert_gt n a l) in H1. left. rewrite H1. unfold hd_error. reflexivity.
  - inversion H1.
  + (* Case 2: a = n *)
    apply (insert_eq n a l) in H2. left. rewrite H2. unfold hd_error. reflexivity.
  + (* Case 3: a > n *)
    apply (insert_lt n a l) in H2. right. rewrite H2. unfold hd_error. reflexivity.
Qed.

Lemma sorted_head_ge : forall (n a : nat) (l : list nat),
  sorted (a :: l) -> n >= a -> Some a = hd_error (insert n (a :: l)).
Proof.
  intros. assert (n = a \/ n > a). lia. inversion H1.
  - (* Case: a = n *)
    apply (insert_eq n a l) in H2. rewrite H2. unfold hd_error; reflexivity.
  - (* Case: n > a *)
    apply (insert_gt n a l) in H2. rewrite H2. unfold hd_error; reflexivity.
Qed.

(*
Lemma sorted_tail : forall (n : nat) (l l0 : list nat),
  sorted l -> n :: l0 = insert n l -> (~(In n l) -> l0 = l).
Proof.
  intros. inversion H.
  destruct l as [|a tl].
  - (* Case: l = [] *)
  unfold insert in H0; injection H0; auto.
  - (* Case: l = a::tl *)
  (* Goal: l0 = a :: tl *)
  inversion H as [|b|b tl']. (* sorted (a :: tl) can be considerd in two
  subcases: tl=[] and sorted_cons : a < b -> sorted (b::tl') -> sorted(a::b::tl').
  The sorted_nil case isn't possible. *)
  + (* Subcase: l = a::[] *)
  rewrite <- H3 in H; rewrite <- H3 in H0; rewrite <- H3 in H1.

  - (* Subcase: l = a::b::tl' *)
  apply sorted_tl in H as IH.
  apply IHtl in IH.
  inversion H.
  + (* Subcase: tl = []; goal becomes l0 = [a] *)
  rewrite <- H4 in H0.

  inversion H0.
  assert (sorted []) as IH. apply sorted_nil.
  apply IHtl in IH.

  apply IHtl in H1.
  assert(In n (insert n tl)).

  assert (a < n \/ n = a \/ a > n). lia.
  inversion H1.
  - apply (insert_gt n a l) in H2 as H3.
    assert (n :: l0 = a :: insert n l). { rewrite <- H3; rewrite <- H0; reflexivity. }
Admitted.

Lemma sorted_insert_sorted_tl : forall (n : nat) (l : list nat),
  sorted (insert n l) -> sorted l.
Proof.
  intros. induction l.
  - apply sorted_nil.
  - (* Inductive case: l = a :: l *)
    assert (n < a \/ n = a \/ n > a). lia. inversion H0.
  + (* Subcase: n < a *)
    apply (insert_lt n a l) in H1 as H2. rewrite H2 in H.
    apply (sorted_cons n a l) in H1. apply sorted_tl in H1 as H3. assumption.
    apply sorted_tl in H. assumption.
  + inversion H1.
  ++ (* Subcase: n = a *)
     apply (insert_eq n a l) in H2 as H3. rewrite H3 in H. assumption.
  ++ (* Subcase: n > a *)
     apply (insert_gt n a l) in H2 as H3. rewrite H3 in H.
     apply sorted_tl in H as IH. apply IHl in IH.
     inversion IH. apply sorted_1. rewrite <- H4 in H.
     assert (x < n \/ x = n \/ x > n). lia. inversion H5.
     (* Sub-subcases [sorted [a; x]]. *)
     * (* Sub-subcase: x < n *)
       apply (insert_gt n x []) in H6 as H7. rewrite H7 in H. unfold insert in H.
       inversion H. apply (sorted_cons a x []) in H10 as H13. assumption.
       apply sorted_1.
     * inversion H6.
     ** (* Sub-subcase: x = n *) apply eq_sym in H7.
        apply (insert_eq n x []) in H7 as H8. rewrite H8 in H. assumption.
     ** (* Sub-subcase: x > n *)
        assert (a < x). lia.
        apply (sorted_cons a x []) in H8. assumption. apply sorted_1.
     (* Subcases to prove [sorted (a :: x :: y :: l0)] *)
     * apply (sorted_cons x y l0) in H4 as H4a. inversion H. contradict H9.
       apply (insert_nonempty n l).
       assert (Some y0 = hd_error (insert n l)). { rewrite <- H8. unfold hd_error; reflexivity. }
       assert (x = y0 \/ n = y0). { apply (sorted_head n x (y :: l0)) in H4a as H4b.
       rewrite H6 in H4b. rewrite <- H11 in H4b. inversion H4b.
       left. injection H12. auto.
       right. injection H12. auto. }
       inversion H12.
     ** (* insert n l = x :: (stuff) *)
       rewrite <- H13 in H8; rewrite <- H13 in H10; rewrite <- H13 in H9.
       apply (sorted_cons a x (y :: l0)) in H9. apply H9. apply H4a.
     ** (* insert n l = n :: l *)
       rewrite <- H13 in H8; rewrite <- H13 in H10; rewrite <- H13 in H9.
       inversion H8. unfold insert in H15. rewrite <- H6 in H15.
       apply (sorted_cons a n (y :: l0)) in H9. apply H9.
        sorted (a :: n :: y :: l0)
       rewrite H6 in H4b.
        apply (insert_lt n x []) in H7 as H8. rewrite H8 in H.
     unfold insert in H.

     induction l. apply sorted_1.
     inversion IH. rewrite <- H6 in IH.
Admitted.
*)

Lemma sorted_split : forall (l1 l2 : list nat),
  sorted (l1 ++ l2) -> sorted l1 /\ sorted l2.
Proof. intros. induction l1.
  - rewrite (app_nil_l l2) in H; split. apply sorted_nil. apply H.
  - rewrite <- (app_comm_cons l1 l2 a) in H. apply sorted_tl in H as H1.
    apply IHl1 in H1. split. destruct l1.
  -- apply sorted_1.
  -- inversion H. assert (sorted (n :: l1)). apply H1. apply sorted_tl in H6 as H7.
     apply (sorted_cons a n l1). assumption. assumption.
  -- apply H1.
Qed.

Lemma sorted_head_min : forall (n k : nat) (l : list nat),
  sorted (n :: l) -> In k l -> n < k.
Proof.
  intros. induction l.
  - contradict H0.
  - apply (sorted_tl n (a::l)) in H as IH. destruct l.
  -- unfold In in H0. inversion H. destruct H0. apply eq_sym in H0. rewrite H0. assumption.
     contradict H0.
  -- inversion H. inversion H5. clear H6 H7 H9 H1 H2 H4.
     assert (n < n0). { rewrite <- H8. assumption. }
     inversion H0. apply eq_sym in H2. rewrite H2. assumption.
     apply (sorted_cons n n0 l) in H1. apply IHl in H1 as IH1. assumption. assumption.
     assumption.
Qed.

(*
Lemma sorted_split_ends : forall (l1 l2 : list nat),
  sorted (l1 ++ l2) ->
  (forall (a b : nat), In a l1 /\ In b l2 -> a < b).
Admitted.
Proof. intros. induction l1.
  - apply proj1 in H0. contradict H0.
  - apply proj1 in H0 as H1; apply proj2 in H0 as H2.
    destruct l1.
 -- (* Subcase: l1 = [] *) apply sorted_tl in H as IH.
    unfold app in IHl1; unfold app in H. assert (a0 = a). { unfold In in H1. intuition. }
    rewrite H3 in H; rewrite H3 in H1; rewrite H3 in H0.
    apply (sorted_head b a l2) in H. apply IHl1 in IH. assumption. assumption.
 -- (* Subcase: l1 = n :: l1 *)
    rewrite <- (app_comm_cons (n :: l1) l2 a0) in H.
    apply sorted_tl in H as IH.
    assert (a = a0 \/ a <> a0). { lia. }
    inversion H3.
  + (* a = a0 *) rewrite <- H4 in H; rewrite <- H4 in H1.
    apply (sorted_head a b ((n :: l1) ++ l2)) in H.
    assumption. apply (in_or_app (n :: l1) l2 b). auto.
  + (* a <> a0 *)
    assert (In a (n :: l1)). { inversion H1. apply eq_sym in H5.
      contradict H5. assumption. assumption.
    }
    apply IHl1 in IH. assumption. split. assumption. assumption.
Qed.

Lemma insert_split : forall (n : nat) (l1 l2 : list nat),
  sorted (l1 ++ n::l2) -> (l1 ++ n::l2) = insert n (l1 ++ n::l2).
Admitted.
*)

(*

Theorem insert_existing_sorted : forall (n : nat) (l : list nat),
  sorted l -> In n l -> l = insert n l.
Proof.
  intros.
  apply in_split in H0 as H1. destruct H1. destruct H1.
  rewrite H1 in H.
  apply insert_split in H.
  rewrite <- H1 in H. apply H.
Qed.
*)

Lemma sorted_in_inv : forall (n h : nat) (tl : list nat),
  sorted(h :: tl) -> In n (h::tl) -> h=n \/ (In n tl).
Proof.
  intros. apply in_inv in H0. trivial.
Qed.

Lemma sorted_surgery : forall ( a b : nat) (tl : list nat),
  sorted (a :: b :: tl) -> sorted (a :: tl).
Proof.
  intros. inversion H. apply sorted_tl in H4 as H5.
  destruct tl.
  - apply sorted_1.
  - inversion H4.
    assert (a < n). { Nat.order. }
    apply (sorted_cons a n tl) in H11. assumption. assumption.
Qed.

Lemma sorted_in_tl : forall (n h : nat) (tl : list nat),
  sorted (h :: tl) -> In n tl -> h < n.
Proof.
  intros. induction tl.
  - (* Base case: tl = [] *)
    contradict H0.
  - (* Inductive case: tl = a::tl *)
    inversion H.
(*
  -- (* Case: sorted_1 *)
    contradict H0. rewrite <- H3. apply in_nil.
*)
  -- (* Case: sorted_cons where [h < y] and [tl = y::l] *)
    rewrite <- H2 in H0. apply in_inv in H0 as H6.
    case H6.
  + (* Subcase: [n = y] *)
    intro. rewrite H7 in H2. rewrite <- H2 in H3. assumption.
  + (* Subcase: [In n l] *)
    intro. apply sorted_surgery in H as IH. apply IHtl in IH.
    apply IH. assumption.
Qed.

Theorem insert_existing_sorted : forall (n : nat) (l : list nat),
  sorted l -> In n l -> l = insert n l.
Proof.
  intros.
  induction l as [|h tl].
  - contradict H0.
  - inversion H.
  + rewrite <- H3 in H0; rewrite <- H3 in H.
    assert (h = n). { unfold In in H0. intuition. }
    rewrite H1; rewrite H1 in H0; rewrite H1 in H.
    assert (n = n). reflexivity.
    apply (insert_eq n n []) in H4. symmetry. assumption.
  + (* Subcase sorted_cons : tl=y::l, h < y, sorted(y :: l) *)
    apply in_inv in H0. case H0.
  ++ (* Case of [In h n::tl] when [h = n] *)
    intro. rewrite H5. rewrite (insert_eq n n (y::l)). reflexivity. reflexivity.
  ++ (* Case of [In h n::tl] when [In h tl] *)
    intro. (* apply sorted_tl in H as IH. apply IHtl in IH. *)
    rewrite <- H2 in H5. apply in_inv in H5. case H5.
    (* Since [tl = y::l], we do this again! *)
  +++ intro.  rewrite H6; rewrite H6 in H5; rewrite H6 in H2; rewrite H6 in H3; rewrite H6 in H4.
    rewrite (insert_gt n h (n :: l)).
    rewrite (insert_eq n n l). reflexivity. reflexivity. assumption.
  +++ (* Last case: In n l -> h :: y :: l = insert n (h :: y :: l) *)
    intro. (* INDUCTION SAVES US, AT LONG LAST! *)
    apply sorted_tl in H as IH. apply IHtl in IH.
    rewrite H2. apply (sorted_in_tl n h tl) in H as IH1.
    apply (insert_gt n h tl) in IH1. rewrite <- IH in IH1. auto.
    rewrite <- H2. simpl; auto.
    rewrite <- H2. simpl; auto.
Qed.

Lemma eq_lists_eq_len {A} : forall (l1 l2 : list A),
  l1 = l2 -> length l1 = length l2.
Proof.
  intros.
  rewrite H. reflexivity.
Qed.

(*
Theorem insert_nondecreasing : forall (n : nat) (l : list nat),
  sorted l -> length l <= length (insert n l).
Proof.
  intros.
  assert (In n l \/ ~In n l).
  2: { inversion H0.
  - apply (insert_existing_sorted n l) in H as H2.
    apply eq_lists_eq_len in H2 as H3. Nat.order. assumption.
  -
  assumption.

Admitted.

*)

Lemma in_singleton_eq : forall {A} (a x : A),
  In a [x] -> a = x.
Proof. intros. unfold In in H. intuition. Qed.

Theorem insert_singleton_invert : forall (n x : nat) (l : list nat),
  [x] = (insert n l) -> l = [] \/ l = [n].
Proof.
  intros.
  assert (sorted [x]). apply sorted_1.
  rewrite H in H0.
  assert (In n [x]). { rewrite H. apply (insert_inv n l). }
  apply  (in_singleton_eq n x) in H1. rewrite <- H1 in H.
  clear H1.
  induction l as [|n0 l0].
  - (* Case: l = [] *) left; reflexivity.
  - (* Case: l = n0::l0 *)
    assert (n < n0 \/ n = n0 \/ n > n0). lia.
  -- destruct H1.
  + (* Subcase: n < n0 *)
    apply (insert_lt n n0 l0) in H1. rewrite H1 in H; rewrite H1 in H0.
    inversion H0; right; discriminate.
  + destruct H1.
  ++ (* Subcase: n = n0 *)
    apply (insert_eq n n0 l0) in H1. rewrite H1 in H; rewrite H1 in H0.
    right; symmetry. apply H.
  ++ (* Subcase: n > n0 *)
    apply  (insert_gt n n0 l0) in H1 as H2. rewrite H2 in H; rewrite H2 in H0.
    inversion H0.
  +++ (* Sub-subcase (sorted_1) : l0 = [] *)
    right. rewrite <- H5 in H.
    contradict H5. apply (insert_nonempty n l0).
  +++ (* Sub-subcase (sorted_cons) [sorted (insert n (n0 :: l0))] becomes :
         n0 < y -> sorted( y :: l) -> sorted(n0 :: y :: l)*)
      rewrite <- H4 in H; rewrite <- H4 in H2. left. discriminate.
Qed.

Require Import Coq.Classes.RelationClasses.

Theorem nat_comparison : forall (a b : nat),
  a < b \/ a = b \/ a > b.
Proof.
  intros. lia.
Qed.

Lemma gt_to_not_ltb : forall (n a : nat),
  n > a -> Nat.ltb n a = false.
Proof. intros.
  bdestruct (n <? a); simpl.
  contradict H0. lia. reflexivity.
Qed.

Lemma gt_to_not_eqb : forall (n a : nat),
  n > a -> Nat.eqb n a = false.
Proof. intros.
  bdestruct (n =? a); simpl.
  contradict H0. lia. reflexivity.
Qed.

Lemma invert_insert_sorted : forall (n a n0 : nat) (l l0 : list nat),
  sorted (a :: l) -> insert n (a :: l) = a :: n0 :: l0 ->
  a < n0.
Proof.
  intros.
  assert (a > n \/ a = n \/ a < n). lia.
  generalize dependent l0.
  induction l.
  - intros. destruct H1.
  -- (* Subcase: a > n *)
    apply (insert_lt n a []) in H1 as H2. rewrite H2 in H0.
    contradict H0. injection. intros. lia.
  -- destruct H1.
  --- (* Subcase: a = n *) apply eq_sym in H1.
    apply (insert_eq n a []) in H1 as H2. rewrite H2 in H0.
    contradict H0. injection. discriminate.
  --- (* Subcase: a < n *)
    apply (insert_gt n a []) in H1 as H2. rewrite H2 in H0.
    unfold insert in H0. injection H0. intros. rewrite H4 in H1. assumption.
 - (* Inductive case: l = a0::l *)
  destruct H1.
  -- intros. apply Nat.ltb_lt in H0 as H2. unfold insert in H1.
    rewrite H2 in H1. contradict H1. injection.
    intros. rewrite <- H3 in H1. injection H1. intro. lia.
  -- destruct H0.
  + (* Subcase: a = n *) intros. apply eq_sym in H0.
    apply (insert_eq n a (a0::l)) in H0 as H3.
    rewrite H3 in H1. injection H1. intros.
    rewrite H4 in H. inversion H. assumption.
  + (* Subase: a < n *) intros.
    apply (sorted_surgery a a0 l) in H as IH.
    apply (insert_gt n a (a0 :: l)) in H0 as H2.
    assert (a0 < n \/ a0 = n \/ a0 > n). lia.
    destruct H3.
  ++ (* a0 < n *)
    apply (insert_gt n a0 l) in H3 as H4.
    apply (insert_gt n a (a0 :: l)) in H0 as H5.
    rewrite H4 in H2. rewrite H2 in H1. injection H1.
    intros. rewrite H7 in H. inversion H. assumption.
  ++ destruct H3.
  * (* Case a0 = n *) apply eq_sym in H3.
    apply (insert_eq n a0 l) in H3 as H4.
    rewrite H4 in H2. rewrite H2 in H1. injection H1. intros.
    inversion H. rewrite H6 in H9. assumption.
  * (* Case a0 > n *)
    apply (insert_lt n a0 l) in H3 as H4.
    assert (insert n (a :: a0 :: l) = a :: insert n (a0 :: l)). assumption.
    rewrite H4 in H2.
    rewrite H4 in H5. rewrite H1 in H5. injection H5. intros. rewrite H7. assumption.
Qed.

Theorem insert_preserves_sorted : forall (n : nat) (l : list nat),
  sorted l -> sorted (insert n l).
Proof.
  intros.
  induction l.
  - unfold insert. apply sorted_1.
  - apply sorted_tl in H as H1. apply IHl in H1.
    assert (n < a \/ n = a \/ n > a). lia.
    inversion H0.
  -- (*  Case: n < a *)
     apply (insert_lt n a l) in H2 as H3. rewrite H3.
     apply sorted_cons. assumption. assumption.
  -- (* Case: n = a *)
     inversion H2. apply (insert_eq n a l) in H3 as H4. rewrite H4.
     assumption.
     (* Case: n > a *)
     apply (insert_gt n a l) in H3 as H4. rewrite H4. destruct (insert n l).
  + apply sorted_1.
  + clear H0; clear H2.
    apply sorted_tl in H1 as H5.
    assert (n < n0 \/ n = n0 \/ n > n0). lia. inversion H0.
    (* case: n < n0 *)
  ++ apply sorted_cons. rewrite <- H2. assumption. assumption.
  ++ (* case: n = n0 *)
     inversion H2. apply sorted_cons. rewrite <- H6. assumption. assumption.
     (* case: n > n0 *)
     clear H2 H0.
     inversion H4. apply gt_to_not_ltb in H3 as H8.
     rewrite H8. rewrite H8 in H2. clear H8; apply gt_to_not_eqb in H3 as H8.
     rewrite H8; rewrite H8 in H2.
     apply (invert_insert_sorted n a n0 l l0) in H4 as H7.
     apply eq_list in H2. rewrite H2. apply sorted_cons. assumption.
     assumption. assumption.
Qed.

(*
Theorem insert_preserves_sorted2 : forall (n : nat) (l : list nat),
  sorted l -> sorted (insert n l).
Proof.
  intros.
  induction l.
  - unfold insert. apply sorted_1.
  - apply sorted_tl in H as H1. apply IHl in H1.
    assert (n < a \/ n = a \/ n > a). lia.
    inversion H0.
  -- apply (insert_lt n a l) in H2 as H3. rewrite H3.
     apply sorted_cons. assumption. assumption.
  -- inversion H2.
  --- apply (insert_eq n a l) in H3 as H4. rewrite H4. assumption.
  --- apply (insert_gt n a l) in H3 as H4. rewrite H4.
      destruct (insert n l). apply sorted_1.
      set (ln := insert n l). inversion H4. auto; simpl.
  + apply sorted_1.
  + assert (n = n0 \/ n <> n0). lia. inversion H5.
  ++ apply sorted_cons. rewrite <- H6. assumption. rewrite <- H6.
  +  unfold insert in ln. unfold ln. apply sorted_cons.
    assumption. apply sorted_1.
  +

      destruct l.
  + unfold insert. apply sorted_cons. assumption. apply sorted_1.
  +
      set (ln := insert n l). destruct l. auto.
      apply (sorted_cons a n l) in H3.
      apply (sorted_tl a (insert n l)) in H1 as H5.
      apply sorted_tl with (n := a) (l := insert n l) in H1 as H5.
      apply (sorted_cons a n l) in H3.
Admitted.
*)

(*
Theorem insert_preserves_sorted : forall (n : nat) (l : list nat),
  sorted l -> sorted (insert n l).
Proof.
  intros.
  induction l.
  - unfold insert. apply sorted_1.
  - apply sorted_tl in H as H1. apply IHl in H1.
    assert (n < a \/ n = a \/ n > a). lia.
    inversion H0.
  -- apply (insert_lt n a l) in H2 as H3. rewrite H3.
     apply sorted_cons. assumption. assumption.
  -- inversion H2.
  --- apply (insert_eq n a l) in H3 as H4. rewrite H4. assumption.
  --- apply (insert_gt n a l) in H3 as H4. rewrite H4.
      apply (sorted_cons a n l) in H3.

  -- contradict H2. apply insert_nonempty.
  -- apply (insert_singleton_invert n x l) in H2. rewrite H2.
     assert (n < a \/ n = a \/ n > a). lia.
     inversion H0.
  --- apply (insert_lt n a []) in H3 as H4. rewrite H4.
      apply sorted_cons. assumption. apply sorted_1.
  --- inversion H3. apply (insert_eq n a []) in H4 as H5. rewrite H5.
      apply sorted_1.
      apply (insert_gt n a []) in H4 as H5. rewrite H5. unfold insert.
      apply sorted_cons. assumption. apply sorted_1.
  -- auto.
  --- auto.
*)

Lemma insert_different : forall (a n : nat) (l : list nat),
  sorted (a :: l) -> a <> n ->
  (n < a -> sorted (n :: a :: l)) /\ (a < n -> sorted (a :: insert n l)).
  (*
Proof.
  intros. split.
  - intro H1. apply sorted_cons. assumption. assumption.
  - intro H1. apply (insert_gt n a l) in H1 as H2. rewrite <- H2.

 apply sorted_tl in H as H2. destruct l.
  -- unfold insert. apply sorted_cons. assumption. apply sorted_1.
  -- apply (sorted_cons a n (n0 :: l)) in H1. inversion H1.
     unfold insert.
  assert (a < n \/ n > a).
  2: { split. }
*)
Admitted.

(*
Theorem insert_if_present :
  forall (n : nat) (l : list nat),
  sorted l -> In n l -> insert n l = l.
Proof.
  intros. induction l.
  - unfold In in H. contradiction.
  - bdestruct (n =? a).
  -- unfold insert.
     assert (~ n < a). { lia. } (* intuition. *)
     assert (Nat.ltb n a = false). { apply Nat.nlt_ge in H2 as H3.
      unfold Nat.ltb. apply leb_correct_conv. intuition.
     }
     rewrite H3. apply (Nat.eqb_eq n a) in H1. rewrite H1. reflexivity.
  -- apply List.in_inv in H0 as H2.
     assert (List.In n l).  {  firstorder. contradict H0. auto. }
     apply sorted_tl in H as H4.
     apply IHl in H3 as IHl2. discriminate. intuition.
  --- symmetry in H5. contradict H5. auto.
  --- auto.
     assert (a < n).
     2: { intuition. apply Nat.ltb_lt in H5 as H6. unfold insert. apply H6.
  --- unfold insert. apply Nat.eqb_eq in H5.
 simpl. auto.
 apply (ltb_reflect n a) in H1. auto.
 rewrite H0. rewrite <- H0.
Lemma insert_different : forall (a n : nat) (l : list nat),
  sorted (a :: l) -> a <> n ->
  sorted (n :: a :: l) \/ sorted (a :: insert n l).

*)

Fixpoint insert_merge (l1 l2 : list nat) :=
match l1 with
| [] => l2
| a::tl => insert_merge tl (insert a l2)
end.

Theorem insert_merge_sorted : forall (l1 l2 : list nat),
  sorted l1 -> sorted l2 -> sorted (insert_merge l1 l2).
Proof.
  intros. generalize dependent l2.
  induction l1.
  - (* Base case: l1 = nil *)
    intros. unfold insert_merge; auto.
  - (* Inductive case: l1 = a::l1 *)
    intros.
    assert (forall l2 : list nat, sorted l2 -> sorted (insert_merge l1 l2)). {
      apply IHl1. apply sorted_tl in H. assumption.
    }
    assert (sorted (insert a l2)). {
    apply insert_preserves_sorted. assumption.
    }
    assert (insert_merge (a :: l1) l2 = insert_merge l1 (insert a l2)). {
      unfold insert. simpl; auto.
    }
    rewrite H3.
    apply H1 in H2. assumption.
Qed.

Theorem insert_merge_sorted2 : forall (l1 l2 : list nat),
  sorted l2 -> sorted (insert_merge l1 l2).
Proof.
  intros. generalize dependent l2.
  induction l1.
  - (* Base case: l1 = nil *)
    intros. unfold insert_merge; auto.
  - (* Inductive case: l1 = a::l1 *)
    intros.
    assert (forall l2 : list nat, sorted l2 -> sorted (insert_merge l1 l2)). {
      apply IHl1.
    }
    assert (sorted (insert a l2)). {
    apply insert_preserves_sorted. assumption.
    }
    assert (insert_merge (a :: l1) l2 = insert_merge l1 (insert a l2)). {
      unfold insert. simpl; auto.
    }
    rewrite H2. apply H0.
    apply insert_preserves_sorted. assumption.
Qed.

Theorem insert_merge_idempotent : forall (l1 l2 : list nat),
  sorted l2 -> incl l1 l2 -> l2 = insert_merge l1 l2.
Proof.
  intros.
  induction l1.
  - simpl; auto.
  - apply incl_cons_inv in H0 as H1. destruct H1.
    assert (insert_merge (a :: l1) l2 = insert_merge l1 (insert a l2)). {
      simpl; auto.
    }
    assert(l2 = insert a l2). { apply insert_existing_sorted. assumption. assumption. }
    rewrite H3. rewrite <- H4.
    apply IHl1.
    assumption.
Qed.

Lemma insert_merge_idem_right : forall l,
  insert_merge l [] = l.
Admitted.

(** * Fresh Number

The other important function we want to implement concerns,
given a list [l : list nat], find the first natural number
*not* in the list.
*)

Fixpoint first_new (n : nat) (l : list nat) : nat :=
match l with
| (h::tl)%list => if Nat.eqb h n then first_new (S n) tl else first_new n tl
| []%list => n
end.

Lemma first_new_eq {l n} :
  first_new n (n::l) = first_new (S n) l.
Proof.
  intros.
  assert (Nat.eqb n n = true). apply Nat.eqb_eq; reflexivity.
  unfold first_new; rewrite H. reflexivity.
Qed.

Require Import Coq.Arith.EqNat.

Lemma neq_is_neqb {a b} :
  a <> b -> Nat.eqb a b = false.
Admitted.

Lemma first_new_not_eq {l a n} :
  a <> n -> first_new n (a::l) = first_new n l.
Proof.
  intros.
  assert (Nat.eqb a n = false). apply neq_is_neqb; assumption.
  unfold first_new. rewrite H0. simpl; auto.
Qed.

Require Import Coq.Lists.ListDec.

Theorem first_new_nondecreasing {l n} :
  n <= first_new n l.
Proof.
  generalize dependent n. induction l.
  - simpl; auto.
  - intros.
    assert({a = n} + {a <> n}). decide equality.
    destruct H.
    + (* Case: a = n *) rewrite e.
      assert (first_new n (n::l) = first_new (S n) l). apply first_new_eq.
      rewrite H.
      assert (n < S n). lia.
      assert (S n <= first_new (S n) l). apply IHl.
      lia.
    + (* Case: a <> n *)
      apply (@first_new_not_eq l a n) in n0. rewrite n0.
      apply IHl.
Qed.

Theorem first_new_lt {l x n} :
  sorted (x :: l) -> n < x -> first_new n (x::l) = n.
Proof. intros.
  induction l.
  - assert (x <> n). lia.
    apply (@first_new_not_eq [] x n) in H1.
    rewrite H1. unfold first_new. reflexivity.
  - assert (sorted (x :: l)). { apply sorted_surgery in H. assumption. }
    apply IHl in H1 as H2.
    assert (x <> n). lia.
    apply (@first_new_not_eq l x n) in H3 as H4.
    inversion H. clear H5 H8 H6.
    assert (a <> n). lia.
    apply (@first_new_not_eq l a n) in H5 as H6.
    assert (first_new n (x :: a :: l) = first_new n (a :: l)). {
      apply (@first_new_not_eq (a::l) x n). assumption.
    }
    rewrite H8. rewrite H6. rewrite <- H4. assumption.
Qed.

Lemma first_new_not_in_lt {l l0 a n} :
  l = a::l0 -> sorted (l) -> n < a -> ~In (first_new n l) l.
Proof. intros.
  assert (first_new n (a::l0) = n). {
    apply (@first_new_lt l0 a n). rewrite <- H. assumption. assumption.
  }
  rewrite H. rewrite H2. rewrite <- H. generalize dependent a.
  generalize dependent l0.
  induction H0.
  - intros; apply in_nil.
  - intros; apply not_in_cons. split. inversion H. lia. apply in_nil.
  - intros.
    assert (sorted (x :: y :: l)). { apply (sorted_cons x y l). assumption.
      assumption.
    }
    apply not_in_cons. split.
    + inversion H1. lia.
    + apply (IHsorted l y).
      reflexivity. inversion H1. lia.
      apply first_new_lt. assumption. inversion H1. lia.
Qed.

Lemma first_new_not_in_gt {l x y n} :
  forall (IHsorted : forall n : nat, ~ In (first_new n (y :: l)) (y :: l)),
  sorted (y :: l) -> x < n -> x < y -> ~ In (first_new n (x :: y :: l)) (x :: y :: l).
Proof.
  intros.
  apply not_in_cons. split.
  - assert(n <= first_new n (x :: y :: l)). { apply first_new_nondecreasing. }
    lia.
  - assert(x <> n). lia.
    apply (@first_new_not_eq (y::l) x n) in H2.
    rewrite H2. apply IHsorted.
Qed.

Theorem first_new_not_in {l n} :
  sorted l -> ~ In (first_new n l) l.
Proof.
  intros. generalize dependent n.
  induction H.
  - (* Base case: sorted_nil. *) simpl; auto.
  - (* Base case: sorted_1. *) intros. assert ({x = n} + {x <> n}). decide equality. destruct H.
   + (* If x = n *) rewrite e.
     assert (first_new n [n] = first_new (S n) []). apply first_new_eq.
     rewrite H. unfold first_new.
     apply not_in_cons. simpl; auto.
   + (* If x <> n *)
     apply (@first_new_not_eq [] x n) in n0 as H.
     rewrite H. unfold first_new.
     apply not_in_cons. simpl; auto.
  - (* Inductive case (sorted_cons): x < y && sorted (y::l0) && l = x::y::l0 *)
    intros.
    assert ({x < n} + {x = n} + {n < x}). apply lt_eq_lt_dec. destruct H1. destruct s.
 -- (* x < n *)
    apply (@first_new_not_in_gt l x y n IHsorted). assumption.
    assert (x <> n). lia. assumption. assumption.
 -- (* x = n *) rewrite e.
     assert (first_new n (n :: y :: l) = first_new (S n) (y :: l)). apply first_new_eq.
     rewrite H1.
     apply not_in_cons.
     assert (S n <> n). lia.
     assert (S n <= first_new (S n) (y :: l)). apply first_new_nondecreasing.
     split. lia. apply IHsorted.
 -- (* x > n *)
    apply (@first_new_not_in_lt (x :: y :: l) (y :: l) x n).
    reflexivity. apply sorted_cons. assumption. assumption. assumption.
Qed.

Theorem insert_merge_list_fold_sorted : forall (A : Type) (f : A -> list nat) (l : list A) (init : list nat),
  sorted init -> sorted (List.fold_left (fun l' => fun (a : A) => insert_merge (f a) l') l init%list).
Proof.
  intros. generalize dependent init.
  induction l.
  - simpl; auto.
  - intros.
    assert((fold_left (fun (l' : list nat) (a0 : A) => insert_merge (f a0) l') (a :: l) init)
          = (fold_left (fun (l' : list nat) (a0 : A) => insert_merge (f a0) l') l (insert_merge (f a) init))). {
      simpl; auto.
    } rewrite H0.
    assert (sorted (insert_merge (f a) init)). {
      apply insert_merge_sorted2. assumption.
    }
    apply IHl in H1 as IH. apply IH.
Qed.

Theorem insert_merge_list_fold_sorted2 : forall (A : Type) (f : A -> list nat -> list nat) (l : list A) (init : list nat),
  sorted init -> sorted (List.fold_left (fun l' => fun (a : A) => insert_merge (f a l') l') l init%list).
Proof.
  intros. generalize dependent init.
  induction l.
  - simpl; auto.
  - intros.
    assert((fold_left (fun (l' : list nat) (a0 : A) => insert_merge (f a0 l') l') (a :: l) init)
          = (fold_left (fun (l' : list nat) (a0 : A) => insert_merge (f a0 l') l') l (insert_merge (f a init) init))). {
      simpl; auto.
    } rewrite H0.
    assert (sorted (insert_merge (f a init) init)). {
      apply insert_merge_sorted2. assumption.
    }
    apply IHl in H1 as IH. apply IH.
Qed.

Require Export Coq.Vectors.VectorSpec.

Theorem insert_merge_vector_fold_sorted {n} : forall (A : Type) (f : A -> list nat) (v : Vector.t A n) (init : list nat),
  sorted init -> sorted (Vector.fold_left (fun l' => fun (a : A) => insert_merge (f a) l') init v).
Proof.
  intros.
  assert(Vector.fold_left (fun l' => fun (a : A) => insert_merge (f a) l') init v
          = List.fold_left (fun l' => fun (a : A) => insert_merge (f a) l') (Vector.to_list v) init).
  { apply to_list_fold_left. }
  rewrite H0.
  apply insert_merge_list_fold_sorted.
  assumption.
Qed.

Theorem insert_merge_vector_fold_sorted2 {n} : forall (A : Type) (f : A -> list nat -> list nat) (v : Vector.t A n) (init : list nat),
  sorted init -> sorted (Vector.fold_left (fun l' => fun (a : A) => insert_merge (f a l') l') init v).
Proof.
  intros.
  assert(Vector.fold_left (fun l' => fun (a : A) => insert_merge (f a l') l') init v
          = List.fold_left (fun l' => fun (a : A) => insert_merge (f a l') l') (Vector.to_list v) init).
  { apply to_list_fold_left. }
  rewrite H0.
  apply insert_merge_list_fold_sorted2.
  assumption.
Qed.

Require Import Nat.
Require Import Coq.Arith.PeanoNat.

Lemma first_new_cons {l n} :
  first_new n (n :: l) = first_new (S n) l.
Proof.
  assert(n = n). reflexivity.
  apply Nat.eqb_eq in H as H1.
  simpl; auto. rewrite H1. reflexivity.
Qed.

Lemma neq_neqb : forall (n k : nat),
  n <> k <-> Nat.eqb n k = false.
Proof. intros. revert n.
  induction k as [|k IHk]; intro n; destruct n; simpl; rewrite ?IHk; split; try easy.
  - intros. assert (n <> k). red; auto. apply IHk in H0. assumption.
  - intros. apply IHk in H. red; auto.
Qed.

Lemma first_new_distinct {l a n} :
  a <> n -> first_new n (a :: l) = first_new n l.
Proof.
  intros.
  apply neq_neqb in H as H1.
  simpl; auto. rewrite H1.
  reflexivity.
Qed.

Lemma fresh_new_step {l n k} :
  first_new n l = first_new n (k::l) \/ first_new (S n) l = first_new n (k::l).
Proof.
  assert({k = n} + {k <> n}). decide equality. destruct H.
  - right. rewrite e. symmetry. apply first_new_cons.
  - left. apply (@first_new_distinct l k n) in n0. symmetry; assumption.
Qed.

(*
Lemma first_new_nondecreasing {l n} :
  n <= first_new n l.
Proof. generalize dependent n.
  induction l.
  - simpl; auto.
  - intros. assert ({a = n} + {a <> n}). decide equality.
    destruct H.
  -- rewrite e.
     assert (first_new n (n :: l) = first_new (S n) l).
     apply first_new_cons. rewrite H.
     assert (S n <= first_new (S n) l). apply (@IHl (S n)).
     intuition.
  -- assert(first_new n l = first_new n (a :: l)). symmetry. apply (@first_new_distinct l a n).
     assumption. rewrite <- H.
     apply IHl.
Qed.
*)

Lemma fresh_succ_nonzero {l n} :
  0 < first_new (S n) l.
Proof.
  intros. generalize dependent n. induction l.
  - simpl; auto. apply Nat.lt_0_succ.
  - intros. destruct (@fresh_new_step l (S n) a).
  + rewrite <- H. apply IHl.
  + rewrite <- H. apply (IHl (S n)).
Qed.

(*
Lemma first_new_cons_inv {l n a} :
  a = n <-> first_new n (a :: l) = first_new (S n) l.
Proof.
  assert ({a = n} + {a <> n}). decide equality. destruct H.
  - split.
  -- rewrite e. intros. apply first_new_cons.
  -- intros; assumption.
  - split. contradiction. intros. inversion H.
    assert (Nat.eqb a n  = false). { apply neq_neqb. assumption. }
    rewrite H0 in H1.
  split.
  - intros. rewrite H. apply first_new_cons.
  - intros. inversion H.
  assert(n = n). reflexivity.
  apply Nat.eqb_eq in H as H1.
  simpl; auto. rewrite H1. reflexivity.
Qed.
*)
Require Import Coq.Arith.Compare.

Lemma first_new_on_different_args {l m n} :
  m <= n -> first_new m l <= first_new n l.
Proof.
  intros. generalize dependent m. generalize dependent n.
  induction l.
  - simpl; auto.
  - intros.
    assert ({n = a} + {n <> a}). decide equality. destruct H0.
  + assert (first_new n (n :: l) = first_new (S n) l). apply first_new_cons.
    assert ({m = a} + {m <> a}). decide equality. destruct H1.
  ++ rewrite e0; rewrite <- e. reflexivity.
  ++ (* m <> a && n = a *)
    assert (first_new m (a :: l) = first_new m l). {
    apply (@first_new_distinct l a m); intuition.
    }
    rewrite H1.
    assert (n <= first_new n (a :: l)). { apply first_new_nondecreasing. }
    rewrite <- e; rewrite H0. apply IHl. intuition.
  + (* n <> a *)
    assert (first_new n (a :: l) = first_new n l). { apply (@first_new_distinct l a n); intuition. }
    assert ({m = a} + {m <> a}). decide equality. destruct H1.
  ++ (* n <> a && m = a *)
     assert (first_new m (a :: l) = first_new (S m) l). {
       rewrite <- e; apply first_new_cons.
     }
     assert (S m <= n \/ m = n). { apply le_le_S_eq in H. assumption. }
     destruct H2.
 +++ (* S m <= n *)
     rewrite H0. rewrite H1. apply IHl. intuition.
 +++ rewrite H2. reflexivity.
 ++ assert (first_new m (a :: l) = first_new m l). { apply (@first_new_distinct l a m); intuition. }
    rewrite H1; rewrite H0. apply IHl. assumption.
Qed.

(** * Segments -- range of integers
At present, it seems like I will need to use a consecutive,
finite sequence of natural numbers. I defined it as a
fixpoint, then proved a number of useful theorems about it.
*)
Fixpoint nat_range_list (n : nat) : list nat :=
match n with
| 0 => []%list
| S n' => ((nat_range_list n') ++ [n'])%list
end.

Lemma test_works2 :
  [0;1;2]%list = nat_range_list 3.
Proof. unfold nat_range_list.
  simpl; auto.
Qed.

Lemma nat_range_list_ind :
  forall (n : nat),
  nat_range_list (S n) = ((nat_range_list n) ++ [n])%list.
Proof.
  intros. induction n.
  - unfold nat_range_list; simpl; auto.
  - unfold nat_range_list; simpl; auto.
Qed.

Require Import Lia.

Theorem nat_range_list_length :
  forall (n : nat), length (nat_range_list n) = n.
Proof.
  intros. induction n.
  - unfold nat_range_list; simpl; auto.
  - assert (nat_range_list (S n) = ((nat_range_list n) ++ [n])%list). {
      apply nat_range_list_ind.
    }
    rewrite H.
    assert (length (nat_range_list n ++ [n]) = (length (nat_range_list n)) + (length [n]%list)). {
      apply List.app_length.
    }
    rewrite H0. rewrite IHn. unfold length. lia.
Qed.

Lemma nth_cons :
  forall {A} (n : nat) (l : list A) (a default : A),
  nth (S n) (a::l) default = nth n l default.
Proof. intros.
  induction l.
  - unfold nth; simpl; auto.
  - unfold nth; simpl; auto.
Qed.

Lemma last_nth :
  forall {A} (n n' : nat) (l : list A) (default : A),
  S n' = n -> n = length l -> List.nth n' l default = List.last l default.
Proof.
  intros. generalize dependent n'. generalize dependent n. induction l.
  - intros. unfold length in H0. rewrite H0 in H. contradict H. unfold length; simpl; auto.
  - intros. destruct l.
  + unfold length in H0. rewrite H0 in H.
    assert (n' = 0). lia.
    rewrite H1. unfold nth; unfold last; simpl; auto.
  + set (n'' := length l).
    assert (S n'' = length (a0 :: l)). { unfold length; simpl; auto; lia. }
    assert (S (S n'') = length (a :: a0 :: l)). { unfold length; simpl; auto; lia. }

    assert (S (S n'') = n). { lia. }
    assert (S n'' = n'). { lia. }
    assert (n' = length (a0 :: l)). lia.
    rewrite <- H4.
    assert(last (a :: a0 :: l) default = last (a0 :: l) default). {
      simpl; auto.
    }
    rewrite H6.
    assert (nth (S n'') (a :: a0 :: l) default = nth n'' (a0 :: l) default). {
      simpl; auto.
    }
    rewrite H7.
    apply (IHl n'). assumption. assumption.
Qed.

Lemma nat_range_list_incl_end :
  forall (n : nat),
  List.incl (nat_range_list n) (nat_range_list (S n)).
Proof.
  intros.
  induction n.
  - unfold nat_range_list; simpl; auto. unfold incl; simpl; auto.
  - set (m := S n).
    assert (nat_range_list m = (nat_range_list n ++ [n])%list). {
      unfold nat_range_list; unfold m; simpl; auto.
    }
    assert (nat_range_list (S m) = (nat_range_list m ++ [m])%list). {
      unfold nat_range_list; unfold m; simpl; auto.
    }
    assert (nat_range_list (S m) = (nat_range_list n ++ [n; m])%list). {
      rewrite H0.
      rewrite H. symmetry. apply (List.app_assoc (nat_range_list n) ([n]%list) ([m]%list)).
    }
    rewrite H1. rewrite H.
    assert (incl [n]%list [n; m]%list). { unfold incl; simpl; auto.
      intros. destruct H2. left; simpl; auto. simpl; auto.
    }
    apply List.incl_app_app; simpl; auto.
    apply List.incl_refl.
Qed.

Theorem nat_range_list_incl :
  forall (m n : nat),
  m < n -> List.incl (nat_range_list m) (nat_range_list n).
Proof.
  intros. generalize dependent m.
  induction n.
  - intros. contradict H; lia.
  - intros.
    assert (incl (nat_range_list n) (nat_range_list (S n))). {
      apply nat_range_list_incl_end.
    }
    assert ({m = n} + {m <> n}). decide equality.
    destruct H1.
  + rewrite e. assumption.
  + assert (m < n). { lia. }
    assert (incl (nat_range_list m) (nat_range_list n)). {
      apply IHn. assumption.
    }
    apply (@incl_tran nat (nat_range_list m) (nat_range_list n) (nat_range_list (S n))).
    assumption.
    assumption.
Qed.

Theorem nat_range_list_firstn :
  forall (m n : nat),
  m < n -> List.firstn m (nat_range_list n) = nat_range_list m.
Proof.
  intros. generalize dependent m.
  induction n.
  - intros. contradict H; lia.
  - intros.
    assert({m = n} + {m <> n}). decide equality.
    assert(nat_range_list (S n) = (nat_range_list n ++ [n])%list). {
      unfold nat_range_list; simpl; auto.
    }
    destruct H0.
  + rewrite e. rewrite H1.
    set (l := nat_range_list n).
    assert (n = length l). { symmetry. apply nat_range_list_length. }
    assert (firstn (length l + 0) (l ++ [n])%list = l). {
      assert (firstn 0 [n]%list = List.nil). { simpl; auto. }
      assert (l = (l ++ (firstn 0 [n]%list))%list). { simpl; auto. symmetry. apply app_nil_r. }
      set (l2 := firstn (length l + 0) (l ++ [n])%list).
      rewrite H3. unfold l2.
      apply (@firstn_app_2 nat 0 l ([n])%list).
    }
    assert (length l + 0 = length l). { simpl; auto. }
    rewrite H3 in H2. rewrite <- H0 in H2. assumption.
  + assert (m < n) as IH. lia.
    apply IHn in IH.
    destruct m as [| m'].
 ++ (* m = 0 *)
    apply firstn_O.
 ++ (* m = S m' *)
    set (l := skipn (S m') (nat_range_list n)).
    assert (nat_range_list n = (nat_range_list (S m') ++ l)%list). {
      symmetry. rewrite <- IH. unfold l.
      apply (@firstn_skipn nat (S m') (nat_range_list n)).
    }
    assert (nat_range_list (S n) = ((nat_range_list (S m') ++ l) ++ [n])%list). {
      rewrite <- H0. rewrite H1. reflexivity.
    }
    rewrite H2.
    assert (((nat_range_list (S m') ++ l) ++ [n])%list
            = (nat_range_list (S m') ++ (l ++ [n]))%list). {
      symmetry. apply app_assoc.
    }
    rewrite H3.
    set (l' := (l ++ [n])%list).
    assert (length (nat_range_list (S m')) = S m'). {
      apply nat_range_list_length.
    }
    assert (firstn (length (nat_range_list (S m')) + 0) (nat_range_list (S m') ++ l')%list =
            ((nat_range_list (S m')) ++ firstn 0 l')%list). {
      apply (@firstn_app_2 nat 0).
    }
    rewrite H4 in H5.
    assert ((nat_range_list (S m') ++ firstn 0 l')%list = nat_range_list (S m')). {
      assert (firstn 0 l' = []%list). simpl; auto.
      rewrite H6.
      apply app_nil_r.
    } rewrite H6 in H5.
    assert (firstn (S m' + 0)
       (nat_range_list (S m') ++ l') = firstn (S m')
       (nat_range_list (S m') ++ l')). { assert(S m' + 0 = S m').
       simpl; auto. rewrite H7. reflexivity.
    }
    rewrite H7 in H5. assumption.
Qed.

Theorem nat_range_list_entry :
  forall (k n : nat),
  k < n -> nth k (nat_range_list n) (S n) = k.
Proof.
  intros. generalize dependent k.
  induction n as [|n'].
  - intros. contradict H. lia.
  - intros. set (n := S n').
    assert (nat_range_list n = (nat_range_list n' ++ [n'])%list). {
      simpl; auto.
    }
    assert ({k = n'} + {k <> n'}). decide equality.
    destruct H1.
  + (* Case: k = n' *)
    assert (nth k (nat_range_list (S k)) (S (S k)) = last (nat_range_list (S k)) (S (S k))). {
      apply (@last_nth nat n k). lia.
      rewrite e. unfold n. symmetry.
      apply nat_range_list_length.
    } unfold n. rewrite <- e.
    rewrite H1.
    unfold n in H0.
    rewrite <- e in H0.
    rewrite H0.
    apply last_last.
  + assert (k < n'). lia.
    assert (length (nat_range_list n') = n'). {
      apply nat_range_list_length.
    }
    apply IHn' in H1 as IH.
    rewrite H0.
    assert (nth k (nat_range_list n' ++ [n'])%list (S n') = nth k (nat_range_list n') (S n')). {
      apply app_nth1 with (d := (S n')). rewrite H2. assumption.
    }
    assert (nth k (nat_range_list n' ++ [n']) (S n) = nth k (nat_range_list n' ++ [n']) (S n')). {
      apply nth_indep.
      assert (length (nat_range_list n') + 1 = length (nat_range_list n' ++ [n'])). {
        symmetry. apply app_length.
      }
      lia.
    } rewrite H4.
    rewrite H3. rewrite IH. reflexivity.
Qed.

Definition rev_nat_range_list (n : nat) : list nat :=
  List.rev (nat_range_list n).

Example ex_rev_nat_range_list_4 :
  rev_nat_range_list 4 = [3;2;1;0]%list.
Proof.
  simpl; auto.
Qed.

Theorem rev_nat_range_list_length : forall (n : nat),
  length (rev_nat_range_list n) = n.
Proof.
  intros.
  unfold rev_nat_range_list.
  assert (length (rev (nat_range_list n)) = length (nat_range_list n)). {
    apply (rev_length (nat_range_list n)).
  }
  rewrite H.
  apply nat_range_list_length.
Qed.
(*
  Lemma rev_nth : forall l d n, n < length l ->
    nth n (rev l) d = nth (length l - S n) l d.
nat_range_list_entry
     : forall k n : nat,
       k < n -> nth k (nat_range_list n) (S n) = k
nth k (rev_nat_range_list n) d
= nth (n - k) (nat_range_list n) d
= (n - k)
*)

Theorem rev_nat_range_list_entry :
  forall (k n : nat),
  k < n -> nth k (rev_nat_range_list n) (S n) = (n - S k).
Proof.
  intros. unfold rev_nat_range_list.
  assert (length (nat_range_list n) = n). { apply nat_range_list_length. }
  assert (nth k (rev (nat_range_list n)) (S n)
          = nth (length (nat_range_list n) - S k) (nat_range_list n) (S n)). {
    apply (@rev_nth nat (nat_range_list n) (S n) k).
    rewrite H0. assumption.
  } rewrite H0 in H1.
  assert (nth (n - S k) (nat_range_list n) (S n) = (n - S k)). {
    apply nat_range_list_entry. lia.
  } rewrite H1. rewrite H2.
  reflexivity.
Qed.

(* Coq thinks [Vector.of_list (rev_nat_range_list n)] is a [Vector]
of size [length (rev_nat_range_list n)]. So we have to explicitly
spell it out for Coq. *)

Require Fin List.
Require Import VectorDef PeanoNat Eqdep_dec.
Import VectorNotations EqNotations.
Fixpoint rev_nat_range_vector (n : nat) : Vector.t nat n :=
match n with
| 0 => []
| S n' => (n') :: (rev_nat_range_vector n')
end.

Lemma rev_nat_range_vector_last :
  forall (n' : nat),
  Vector.last (rev_nat_range_vector (S n')) = 0.
Proof.
  intros. induction n'.
  - unfold rev_nat_range_vector. simpl; auto.
  - assert((rev_nat_range_vector (S (S n')))
            = Vector.cons nat (S n') (S n') (rev_nat_range_vector (S n'))). {
      simpl; auto.
    }
    rewrite H.
    assert (Vector.last (Vector.cons nat (S n') (S n') (rev_nat_range_vector (S n')))
            = Vector.last (rev_nat_range_vector (S n'))). {
      simpl; auto.
    }
    rewrite H0. apply IHn'.
Qed.

Example rev_nat_range_vector_0 :
  rev_nat_range_vector 0 = [].
Proof. simpl; auto. Qed.

Example rev_nat_range_vector_1 :
  rev_nat_range_vector 1 = [0].
Proof. simpl; auto. Qed.

Example rev_nat_range_vector_2 :
  rev_nat_range_vector 2 = [1;0].
Proof. simpl; auto. Qed.

Lemma rev_nat_range_vector_hd :
  forall (n' : nat),
  Vector.hd (rev_nat_range_vector (S n')) = n'.
Proof.
  intros. unfold rev_nat_range_vector. simpl; auto.
Qed.

Lemma rev_nat_range_vector_tl :
  forall (n' : nat),
  Vector.tl (rev_nat_range_vector (S (S n'))) = rev_nat_range_vector (S n').
Proof.
  intros. unfold rev_nat_range_vector. simpl; auto.
Qed.

(* These next two lemmas are true, but I am too stupid to understand
Coq's inner workings to prove them. *)
Lemma rev_nat_range_vector_entry_base_case :
  forall (k : nat) (H : k < 1),
  nth_order (rev_nat_range_vector 1) H = 1 - S k.
Admitted.

Lemma rev_nat_range_vector_entry_inductive_case_subtlety :
  forall (k n : nat) (H : k < S (S n)) (e : k = S n) (H0 : S n < S (S n)),
  nth_order (rev_nat_range_vector (S (S n))) H
  = nth_order (rev_nat_range_vector (S (S n))) H0.
Admitted.

Theorem rev_nat_range_vector_entry :
  forall (k n : nat) (H : k < S n),
  nth_order (rev_nat_range_vector (S n)) H = (S n - S k).
Proof.
  intros.
  generalize dependent k. induction n.
  - intros. apply rev_nat_range_vector_entry_base_case.
  - intros. assert({k = S n} + {k <> S n}). decide equality. destruct H0.
    + assert (S n < S (S n)) as H0. lia.
      assert (nth_order (rev_nat_range_vector (S (S n))) H
              = nth_order (rev_nat_range_vector (S (S n))) H0). {
        apply rev_nat_range_vector_entry_inductive_case_subtlety. assumption.
      }
      rewrite H1. rewrite e.
      assert (last (rev_nat_range_vector (S (S n))) = 0). {
        apply rev_nat_range_vector_last.
      }
      assert (nth_order (rev_nat_range_vector (S (S n))) H0 = last (rev_nat_range_vector (S (S n)))). {
        apply (@nth_order_last nat (S n) (rev_nat_range_vector (S (S n)))).
      }
      rewrite H3; rewrite H2; lia.
    + destruct k as [|k'].
  ++ (* k = 0 *)
     apply nth_order_hd.
  ++ (* k = S k' *)
     set (k := S k'). assert (k' < S n). lia.
     assert (nth_order (rev_nat_range_vector (S n)) H0 = S n - S k') as IH. {
        apply (IHn k' H0).
     }
     assert (S (S n) - S k = S n - S k'). lia. rewrite H1.
     rewrite <- IH. symmetry.
     assert (Vector.tl (rev_nat_range_vector (S (S n))) = rev_nat_range_vector (S n)). {
       apply rev_nat_range_vector_tl.
     }
     rewrite <- H2.
     apply (@nth_order_tl nat (S n) k' (rev_nat_range_vector (S (S n)))).
Qed.


(** Definition of the ordered setoid of ordinal numbers, together with
    proofs that it is indeed an ordered setoid under the given relations.
    That is:
    - Ord.eq (==) is an equivalence relation;
    - Ord.lt (<) is an ==-compatible strict ordering relation;
    - Ord.le (≤) is a partial ordering relation w.r.t. ==;
    - < is a subrelation of ≤.

    Some desirable properties (such as totality) require excluded middle,
    and are deferred to the OrdClassical module.

    Implementation note:
    A rather more elegant mutually recursive definition of < and ≤ is
    possible, and was originally to be used here:
    - ssup f ≤ y when, for all a:A, f(a) < y;
    - x < ssup g when, for some b:B, x ≤ g(b).
      However, Coq does not accept these as fixpoint definitions since
    they descend on different parameters. It does accept them as
    inductive definitions, but this would require them to be redefined
    inside the Ord module, which causes annoying notational issues.
    We have instead included proofs of the above properties for our
    definitions, as lemmata le_lt and lt_le respectively.
*)

From Ordinal Require Import CommonHeader WellOrderClass Notations.

Require Arith_base.

Generalizable All Variables.

Open Scope Ord_scope.

(** An ordinal is represented by the image of a (possibly empty) function
    with codomain the ordinals. Conceptually it 'is' the least ordinal
    greater than every element of the function's range. *)

Inductive Ord := Ord_ssup `(x: A → Ord).

Module Ord <: EqLtLe' <: StrOrder.

  Definition t := Ord.
  Notation ssup := Ord_ssup.

  Definition src (o: Ord) := let (A, _) := o in A.

  Definition src_map (o: Ord) : src o → Ord :=
    match o with ssup f => f end.

  Fixpoint le o o': Prop :=
    ∀ a: src o, ∃ a': src o',le (src_map o a) (src_map o' a').

  Fixpoint lt o o': Prop :=
    ∃ a': src o', ∀ a: src o, lt (src_map o a) (src_map o' a').

  Definition ge := flip le.
  Definition gt := flip lt.
  Definition eq := relation_conjunction le ge.

  #[export] Hint Unfold ge gt relation_conjunction flip: core.

  Include EqLtLeNotation.
  Infix "≤" := le.
  Infix "≥" := ge.
  Notation "x =/= y" := (x ~= y).

  Section Reduction_Lemmata.

    Lemma le_le `(x: A → Ord) `(y: B → Ord):
      (∀ a, ∃ b, x a ≤ y b) ↔ ssup x ≤ ssup y.
    Proof. reflexivity. Qed.

    Lemma lt_lt `(x: A → Ord) `(y: B → Ord):
      (∃ b, ∀ a, x a < y b) ↔ ssup x < ssup y.
    Proof. reflexivity. Qed.

    Fixpoint le_lt (o: Ord): ∀ [A] (x: A → Ord), (∀ a, x a < o) ↔ ssup x ≤ o.
    Proof.
      destruct o as [A' x'].
      split.
      intros hyp a; specialize (hyp a).
      simpl in a, hyp |- *. destruct (x a).
      destruct hyp as [a' hyp]. exists a'.
      apply le_lt. auto.
    Qed.

    Fixpoint lt_le (o: Ord): ∀ [A] (x: A → Ord), (∃ a, o ≤ x a) ↔ o < ssup x.
    Proof.
      destruct o as [A' x'].
      split.
      intros [a hyp]. exists a.
      simpl in hyp |- *. destruct (x a).
      intro. apply lt_le, hyp.
    Qed.

    Lemma eq_le `(x: A → Ord) `(y: B → Ord):
      (∀ a, ∃ b, x a ≤ y b) → (∀ b, ∃ a, y b ≤ x a) → (ssup x == ssup y)%Ω.
    Proof @conj _ _.

    Lemma eq_eq `(x: A → Ord) `(y: B → Ord):
      (∀ a, ∃ b, x a == y b) → (∀ b, ∃ a, y b == x a) → (ssup x == ssup y)%Ω.
    Proof. firstorder. Qed.

  End Reduction_Lemmata.

  Section Order_Properties.

    Open Scope equiv_scope.

    #[export] Instance lt_sub_le: subrelation lt le.
    Proof.
      unfold subrelation; fix Fix 1.
      destruct x, y, 1; eexists; eauto.
    Qed.

    #[export] Instance eq_sub_le: subrelation eq le.
    Proof λ x y H, proj1 H.

    #[export] Instance le_preorder: PreOrder le.
    Proof.
      split; autounfold.
      fix Fix 1.
      - destruct x; intro a; now exists a.
      - destruct x, y, z; intros H1 H2 a.
        edestruct H1, H2. eauto.
    Qed.

    #[export] Instance ge_preorder: PreOrder ge | 2 :=
      flip_PreOrder _.

    #[export] Instance lt_strorder: StrictOrder lt.
    Proof.
      split; autounfold.
      fix Fix 1.
      - destruct x, 1; firstorder.
      - destruct x, y, z, 1, 1.
        eexists; eauto.
    Qed.

    #[export] Instance gt_strorder: StrictOrder gt | 2 :=
      flip_StrictOrder _.

    #[export] Instance eq_equiv: Equivalence eq.
    Proof.
      firstorder using le_preorder.
    Qed.

    #[export] Instance le_partial_order: PartialOrder eq le.
    Proof.
      now_show (eq === relation_conjunction le (flip le)).
      reflexivity.
    Qed.

    #[export] Instance ge_partial_order: PartialOrder eq ge | 2 :=
      PartialOrder_inverse _.

    #[export] Instance lt_le_compat: Proper (le --> le ++> impl) lt.
    Proof.
      autounfold. fix Fix 1.
      intros [A x] [B y] Le [A' x'] [B' y'] Le'.
      unfold flip; simpl in *.
      intros (a', Lt). specialize (Le' a') as (b', Le').
      exists b'. intro b. specialize (Le b) as (a, Le).
      specialize (Lt a).
      eapply Fix; eassumption.
    Qed.

    #[export] Instance lt_compat: Proper (eq ==> eq ==> iff) lt.
    Proof.
      apply (proper_sym_impl_iff_2 _ _).
      firstorder using lt_le_compat.
    Qed.

    #[export] Instance lt_wf: well_founded lt.
    Proof.
      intro x. enough (∀ (y: Ord) (H: y ≤ x), Acc lt y).
      { apply H; reflexivity. }
      induction x as [A f IH], y as [B g].
      intro; constructor; intros z H'.
      apply lt_le in H'. destruct H' as [b H'].
      specialize (H b) as [a H].
      apply (IH a). etransitivity; eassumption.
    Qed.

    #[export] Instance lt_ext: Extensional eq lt.
    Proof.
      enough (WeaklyExtensional eq lt) by exact _.
      intros x y H; split.
      induction x as [A f IH], y as [B g]. simpl.
      intro x. apply lt_le, H, le_lt; reflexivity.
    Qed.

    #[export] Instance lt_wo: WellOrder eq lt := { }.

    #[export] Instance pointwise_eq_sub_le [A]:
    subrelation (pointwise_relation A eq) (pointwise_relation A le) := _.

    #[export] Instance pointwise_lt_sub_le [A]:
    subrelation (pointwise_relation A lt) (pointwise_relation A le) := _.

    #[export] Instance unary_covariant_is_proper (op: Ord → Ord):
      Proper (le ==> le) op → Proper (eq ==> eq) op.
    Proof. firstorder. Qed.

    #[export] Instance binop_covariant_proper (op: Ord → Ord → Ord):
      Proper (le ==> le ==> le) op → Proper (eq ==> eq ==> eq) op.
    Proof. firstorder. Qed.

    #[export] Instance pointwise_covariant_is_proper [A] (op: (A → Ord) → Ord):
      Proper (pointwise_relation A le ==> le) op →
      Proper (pointwise_relation A eq ==> eq) op.
    Proof.
      intros covariant x y E. pose proof (E' := symmetry E).
      apply pointwise_eq_sub_le in E, E'.
      split; auto.
    Qed.

  End Order_Properties.

  Section Strict_Supremum.

    Variable A: Type.

    #[export]
    Instance ssup_covariance: Proper (pointwise_relation A le ++> le) ssup.
    Proof. firstorder. Qed.

    #[export]
    Instance ssup_compat: Proper (pointwise_relation A eq ==> eq) ssup := _.

    Property ssup_gt (x: A → Ord): ∀ a, x a < ssup x.
    Proof.
      apply le_lt; reflexivity.
    Qed.

    Property ssup_minimality (x: A → Ord): ∀ s, (∀ a: A, x a < s) ↔ ssup x ≤ s.
    Proof.
      intro; apply le_lt.
    Qed.

    Property ssup_ge (x: A → Ord): ∀ a, x a ≤ ssup x.
    Proof.
      intro; apply lt_sub_le, ssup_gt.
    Qed.

    Lemma compose_le `(x: B → Ord) (f: A → B): ssup (x ∘ f) ≤ ssup x.
    Proof.
      intro a; exists (f a). reflexivity.
    Qed.

  End Strict_Supremum.

  Section Propriety.

    Variable Q: ∀ A, (A → Ord) → Prop.
    Let P (o: Ord) := Q (src_map o).

    Hypothesis proper: Proper (eq ==> iff) P.

    #[export]
    Instance proper_is_pointwise_proper A:
      Proper (pointwise_relation A eq ==> iff) (@Q A).
    Proof.
      intros x y H.
      now apply ssup_compat, proper in H.
    Qed.

    Theorem source_irrelevance (o: Ord):
      ∀ A (f: A → Ord), ssup f == o → Q f → P o.
    Proof.
      intros A f Eq. now rewrite <- Eq.
    Qed.

    Theorem source_irrelevance_inv (o: Ord):
      P o → ∀ A (f: A → Ord), ssup f == o → Q f.
    Proof.
      intros H A f Eq. now rewrite <- Eq in H.
    Qed.

  End Propriety.

  Section Zero.

    Definition zero: Ord := ssup (Empty_set_rect _).

    Property zero_le: ∀ x: Ord, zero ≤ x.
    Proof λ x, Empty_set_ind _.

    Definition zero_unique z: (∀ x, z ≤ x) -> z == zero.
    Proof λ h, conj (h zero) (zero_le z).

    Property le_zero_is_zero x: x ≤ zero -> x == zero.
    Proof λ h, conj h (zero_le x).

    Property nlt_zero: ∀ w, ¬(w  < zero).
    Proof.
      intros [] []; contradiction.
    Qed.

    Definition lt_zero_exfalso {P: Ord -> Type} w: w < zero → P w :=
      λ h, False_rect (P w) (nlt_zero w h).

    Property ssup_empty_is_zero w: ¬inhabited (src w) ↔ w == zero.
    Proof.
      destruct w as (A, x); simpl. split.
      - intro N. apply le_zero_is_zero, le_lt.
        intro a; now contradict N.
      - intros [H _] [a]. now destruct (H a).
    Qed.

    Property ssup_inhabited_is_positive w: inhabited (src w) ↔ w > zero.
    Proof.
      split; intros [a].
      - exists a; intros [].
      - auto.
    Qed.

    Property ssup_nonempty_is_nonzero w: ¬¬inhabited (src w) ↔ w ~= zero.
    Proof.
      split. intros H H'.
      apply (ssup_empty_is_zero w) in H'.
      contradiction.
    Qed.

  End Zero.

  #[export] Hint Resolve zero_le: ord.
  #[export] Hint Resolve zero_unique: ord.
  #[export] Hint Resolve le_zero_is_zero: ord.
  #[export] Hint Resolve nlt_zero: ord.
  #[export] Hint Resolve <- ssup_empty_is_zero: ord.
  #[export] Hint Resolve <- ssup_inhabited_is_positive: ord.
  #[export] Hint Resolve <- ssup_nonempty_is_nonzero: ord.

  Section Successor.
    (** The successor operation and its basic properties. *)

    Definition succ (o: Ord): Ord := ssup (λ _:unit, o).

    #[export]
    Instance succ_strict_covariance: Proper (lt ++> lt) succ.
    Proof.
      repeat intro; simpl; repeat elim_quantifiers.
      assumption.
    Qed.

    #[export]
    Instance succ_covariance: Proper (le ==> le) succ.
    Proof.
      unfold succ; solve_proper.
    Qed.

    #[export]
    Instance succ_compat: Proper (eq ==> eq) succ := _.

    Property succ_gt o: o < succ o.
    Proof.
      apply -> lt_le. exists tt; reflexivity.
    Qed.

    Property succ_minimality o: ∀ s, o < s ↔ succ o ≤ s.
    Proof.
      split; intros.
      - apply -> le_lt; auto.
      - apply <- le_lt in H; auto using tt.
    Qed.

    Property succ_ge o: o ≤ succ o.
    Proof.
      apply lt_sub_le, succ_gt.
    Qed.

    Property le_iff_lt_succ x y: x ≤ y ↔ x < succ y.
    Proof.
      intros; split; intro H.
      - apply -> lt_le; repeat constructor; assumption.
      - apply <- lt_le in H; destruct H; assumption.
    Qed.

    Property succ_lt_inv x y: succ x < succ y → x < y.
    Proof.
      intros; now apply succ_minimality, le_iff_lt_succ.
    Qed.

    Property succ_le_inv: ∀ x y, succ x ≤ succ y → x ≤ y.
    Proof.
      intros; now apply le_iff_lt_succ, succ_minimality.
    Qed.

    Property succ_inj: ∀ x y, succ x == succ y → x == y.
    Proof.
      destruct 1; split; now apply succ_le_inv.
    Qed.

  End Successor.

  #[export] Hint Resolve -> succ_minimality: ord.
  #[export] Hint Rewrite <- succ_gt: ord.
  #[export] Hint Rewrite <- succ_minimality: ord.

  Section Limit_and_Successor_Ordinals.

    Definition Is_successor (o: Ord) := ∃ p, succ p == o.

    Definition Is_limit (o: Ord) := ∀ p, p < o → succ p < o.

    #[export]
    Instance: Proper (eq ==> iff) Is_successor.
    Proof.
      unfold Is_successor; solve_proper.
    Qed.

    #[export]
    Instance: Proper (eq ==> iff) Is_limit.
    Proof.
      unfold Is_limit; solve_proper.
    Qed.

    (** Constructively we cannot prove every ordinal is either a
     successor or a limit ordinal, but we can prove the following. *)

    Fact limit_nand_successor (o: Ord): ¬(Is_limit o ∧ Is_successor o).
    Proof.
      intros [H [p H']]. rewrite <- H' in H. clear dependent o.
      pose proof (H'' := succ_gt p).
      specialize (H p H''). contradict H. apply irreflexivity.
    Qed.

    Fact not_successor_is_limit (o: Ord) : ¬Is_successor o → Is_limit o.
    Proof.
      intros H p L.
      assert (Hp: succ p =/= o) by firstorder.
      give_up.
    Abort.
    (* Is this even true constructively? *)

    (** An ordinal is a successor iff every map into the ordinals
    specifying it has a maximal element, iff any map does so. *)

    Lemma successor_max (o: Ord):
      Is_successor o →
      ∀ `(x: A → Ord), ssup x == o → ∃ μ: A, ∀ a: A, x μ ≥ x a.
    Proof.
      intros [o' s] I x Eq.
      rewrite <- Eq in s; clear dependent o.
      specialize (proj1 s tt) as [i s1];
      specialize (proj2 s i) as [[] s2];
      pose proof (Eq' := conj s1 s2: o' == x i); clear s1 s2.
      rewrite -> Eq' in s.
      exists i. firstorder.
    Qed.

    Lemma max_successor (o: Ord) `(x: A → Ord) (Eq: ssup x == o):
      (∃ μ: A, ∀ a: A, x μ ≥ x a) → Is_successor o.
    Proof.
      intros [μ M]. exists (x μ).
      rewrite <- Eq; clear dependent o.
      split.
      - intros []; exists μ; reflexivity.
      - intro a; exists tt; apply M.
    Qed.

  End Limit_and_Successor_Ordinals.

  Section From_WF.
    (** Mapping of other sets with well-founded relations into the ordinals *)

    Context `{Rwf: well_founded A R}.
    Local Infix "≺" := R (at level 70).

    Let fwf (a: A) (ih: ∀ x: A, x ≺ a → Ord): Ord :=
        @ssup {y | y ≺ a} (sig_apply ih).

    Definition from_wf := Fix _ fwf : A → Ord.

    Local Lemma fwf_ext (a: A) (f g: ∀ y, y ≺ a → Ord) :
      (∀ (y:A) (p: y ≺ a), f y p == g y p) -> fwf f == fwf g.
    Proof.
      intro H. apply eq_eq.
      intro y; exists y. destruct y.
      2: symmetry.
      apply H.
    Qed.

    Local Lemma fwf_inv (x: A):
      ∀ (r s: Acc R x), Fix_F _ fwf r == Fix_F _ fwf s.
    Proof.
      induction (Rwf x); intros.
      rewrite <-! Fix_F_eq.
      apply fwf_ext.
      auto.
    Qed.

    Property from_wf_eq a:
      from_wf a == ssup (λ y: {y | y ≺ a}, from_wf (proj1_sig y)).
    Proof.
      change (ssup _) with (fwf (λ y (_: y ≺ a), from_wf y)).
      unfold from_wf, Fix. rewrite <- Fix_F_eq.
      apply fwf_ext. intros. apply fwf_inv.
    Qed.

    Global Instance from_wf_strict_covariance: Proper (R ==> lt) from_wf.
    Proof.
      intros x y p. rewrite -> (from_wf_eq y).
      exact (ssup_gt _ (exist _ x p)).
    Qed.

    Context `{equivA: Equivalence A eqA}.
    Context {R_compat: Proper (eqA ==> eqA ==> iff) R}.
    Local Infix "≃" := eqA (at level 70).

    Global Instance from_wf_compat: Proper (eqA ==> eq) from_wf.
    Proof.
      intros x y e. rewrite ->! from_wf_eq.
      apply eq_eq.
      intros [z r].
      pose (r' := r).
      apply (R_compat (reflexivity z) e) in r'.
      exists (exist _ z r'). reflexivity.
    Qed.

    Context {Rtrans: Transitive R}.

    Local Coercion sig_of_sig2 : sig2 >-> sig.

    Property lt_from_wf (x: Ord) (a: A): x < from_wf a → ∃ a': A, x == from_wf a'.
    Proof.
    Abort.

    Context {Rwext: WeaklyExtensional eqA R}.

    Property from_wf_inj: ∀ x y, from_wf x == from_wf y → x ≃ y.
    Proof.
      induction y as [y IH] using well_founded_ind. intro Eq.
      apply weak_extensionality. intro t; split.
    Abort.

  End From_WF.

  Section From_Nat.
    (** Mapping of the natural numbers into the finite ordinals. We could
    just use from_wf, but we instead define a simpler function and then
    show that it is equivalent. *)

    Fixpoint from_nat (n: nat): Ord :=
      match n with
      | 0 => zero
      | S n' => succ (from_nat n')
      end.

    Local Lemma from_wf_nat_covariance:
      Proper (Peano.le ==> le) (from_wf (R := Peano.lt)).
    Proof.
      intros m n h.
      apply Arith.Compare_dec.le_lt_eq_dec in h; destruct h.
      - apply lt_sub_le, from_wf_strict_covariance. assumption.
      - destruct e. reflexivity.
    Qed.

    Proposition from_wf_is_from_nat:
      pointwise_relation _ eq (from_wf (R := Peano.lt)) from_nat.
    Proof.
      intro n; induction n.
      cbn [from_nat]. rewrite -> from_wf_eq.
      - apply ssup_empty_is_zero. firstorder with arith.
      - rewrite <- IHn; clear IHn. split.
        + simpl. intros [m l]; exists tt.
          apply from_wf_nat_covariance; auto with arith.
        + intro. assert (l: (n < S n)%nat) by auto.
          now exists (exist _ n l).
    Qed.
    (*
    Lemma from_nat_src (n: nat): (0 < n)%nat → unit = src (from_nat n) :> Type.
    Proof.
      intro H. rewrite <- (Arith.PeanoNat.Nat.succ_pred_pos _ H). reflexivity.
    Qed.

    Lemma from_nat_src_0 (n: nat): ∅ = src (from_nat 0) :> Type.
    Proof.
      reflexivity.
    Qed.*)

    #[export]
    Instance from_nat_compat: Proper (Logic.eq ==> eq) from_nat := _.

    #[export]
    Instance from_nat_strict_covariace: Proper (Peano.lt ==> lt) from_nat.
    Proof.
      repeat intro.
      rewrite <- from_wf_is_from_nat.
      apply from_wf_strict_covariance, H.
    Qed.

    #[export]
    Instance from_nat_covariance: Proper (Peano.le ==> le) from_nat.
    Proof.
      intros m n m_le_n.
      induction m, n as [n | m | m n IH] using nat_double_ind.
      - (* 0, n *) apply zero_le.
      - (* S m, 0 *) exfalso. inversion m_le_n.
      - (* S m, S n *)
        simpl; repeat elim_quantifiers.
        apply IH. auto with arith.
    Qed.

    Property from_nat_le_inv m n: from_nat m ≤ from_nat n → (m <= n)%nat.
    Proof.
      induction m, n as [n | m | m n IH] using nat_double_ind.
      simpl; intro H; repeat elim_quantifiers.
      auto with arith.
    Qed.

    Property from_nat_inj m n: from_nat m == from_nat n → m = n.
      intros [H₁ H₂].
      apply from_nat_le_inv in H₁, H₂.
      auto with arith.
    Qed.

  End From_Nat.

  Section Supremum.
    (** The supremum, or join, of an indexed family of ordinals.
        Conceptually we join all their sources into a sigma-type and
        take the strict supremum of the corresponding join of their
        source maps.
        *)

    Open Scope equiv_scope.

    Section Def.

      Context `(x: A → Ord).

      Let J: Type := { a: A & src (x a) }.

      Let Jmap: J → Ord := λ j, let (a, b) := j in src_map (x a) b.

      Definition sup: Ord := ssup Jmap.

      Property sup_ge: ∀ a: A, x a ≤ sup.
      Proof.
        intro a. destruct (x a) as [B y] eqn: E.
        intro b.
        exists (existT _ a (eq_rect _ _ b _ (symmetry E))).
        unfold sup; simpl. rewrite -> E. reflexivity.
      Qed.

      Property sup_minimality: ∀ s, (forall a, x a ≤ s) → sup ≤ s.
      Proof.
        intros s H. destruct s eqn: E.
        apply le_lt.
        intros [a b]. rewrite <- (H a).
        simpl. destruct (x a). apply ssup_gt.
      Qed.

      Property sup_uniqueness:
      ∀ s, (∀ a, x a ≤ s) → (∀ s', (∀ a, x a ≤ s') → s ≤ s') → sup == s.
      Proof.
        split.
        - apply sup_minimality; auto.
        - apply H0, sup_ge.
      Qed.

      Property sup_maximum: ∀ a:A, (∀ b:A, x b ≤ x a) → x a == sup.
      Proof.
        intros. split.
        - apply sup_ge.
        - apply sup_minimality; assumption.
      Qed.

    End Def.

    #[export]
    Instance sup_covariance {A}: Proper (pointwise_relation A le ==> le) sup.
    Proof λ x y H,
          sup_minimality x (sup y) (transitivity H (sup_ge y)).

    #[export]
    Instance sup_compat {A}: Proper (pointwise_relation A eq ==> eq) sup := _.

    Property sup_le_ssup [A]: pointwise_relation _ le (@sup A) (@ssup A).
    Proof.
      intro x. apply sup_minimality, ssup_ge.
    Qed.

    Proposition ssup_is_sup_succ [A] (x: A → Ord): ssup x == sup (succ ∘ x).
    Proof.
      split; simpl.
      - intro a; exists (existT _ a tt). reflexivity.
      - intros [a []]; exists a. reflexivity.
    Qed.

    Proposition succ_sup [A] (x: A → Ord): sup x < ssup x ↔ succ (sup x) == ssup x.
    Proof.
      split.
      + split.
        - apply le_lt; trivial.
        - cbn. intro a; exists tt; apply sup_ge.
      + intro H; rewrite <- H; apply succ_gt.
    Qed.

    Proposition sup_empty_is_zero [A] (x: A → Ord): ¬inhabited A → sup x == zero.
    Proof.
      intro N; apply le_zero_is_zero.
      intros [a]; now contradict N.
    Qed.

    Remark sup_const_le x [A]: sup (const x : A → Ord) ≤ x.
    Proof.
      apply sup_minimality; reflexivity.
    Qed.

    Remark sup_const_eq x [A]: inhabited A → sup (const x : A → Ord) == x.
    Proof.
      split. 1: apply sup_const_le.
      destruct H as [a].
      change x with (const x a) at 2. apply sup_ge.
    Qed.

  End Supremum.

  Section Pairwise_Maximum.

    Definition max (x y: Ord): Ord := ssup (sum_rect _ (src_map x) (src_map y)).
    Local Notation "[ f , g ]" := (sum_rect _ f g).

    Property max_ge x y: x ≤ max x y ∧ y ≤ max x y.
    Proof.
      destruct x, y. split. intro a.
      1: exists (inl a). 2: exists (inr a).
      reflexivity.
    Qed.

    Definition max_ge_L x y := proj1 (max_ge x y): x ≤ max x y.
    Definition max_ge_R x y := proj2 (max_ge x y): y ≤ max x y.

    Property max_minimality x y: ∀ z, x ≤ z → y ≤ z → max x y ≤ z.
    Proof.
      destruct x, y, z; simpl.
      intros H1 H2 p. destruct p as [a | a].
      1: destruct (H1 a). 2: destruct (H2 a).
      eexists; eassumption.
    Qed.

    Corollary max_uniqueness x y: ∀ m,
      x ≤ m → y ≤ m → (∀ z, x ≤ z → y ≤ z → m ≤ z) → max x y == m.
    Proof.
      split.
      - apply max_minimality; assumption.
      - apply H1; apply max_ge.
    Qed.

    Proposition max_is_sup x y: max x y == sup (λ b:bool, if b then x else y).
    Proof.
      split.
      - apply max_minimality.
        + exact (sup_ge _ true).
        + exact (sup_ge _ false).
      - apply sup_minimality.
        intro b; case b. apply max_ge.
    Qed.

    #[export]
    Instance max_covariance: Proper (le ++> le ++> le) max.
    Proof.
      intros [A f] [B g] Le [A' f'] [B' g'] Le'.
      intro x; destruct x as [a | a].
      - destruct (Le a) as [x]; now exists (inl x).
      - destruct (Le' a) as [x]; now exists (inr x).
    Qed.

    #[export]
    Instance max_compat: Proper (eq ==> eq ==> eq) max := _.

    Property max_idempotence x: max x x == x.
    Proof.
      destruct x as [A f]; apply eq_eq.
      - intros [a | a]; now exists a.
      - intro a; now exists (inl a).
    Qed.

    Property max_sym x y: max x y == max y x.
    Proof.
      apply eq_eq. intros [a | a].
      1, 3: exists (inr a). 3, 4: exists (inl a).
      reflexivity.
    Qed.

    Property max_eq_L x y: x ≥ y ↔ max x y == x.
    Proof.
      split.
      - split.
        + rewrite <- H; apply max_idempotence.
        + apply max_ge.
      - intro H; rewrite <- H; apply max_ge.
    Qed.

    Property max_eq_R x y: x ≤ y ↔ max x y == y.
    Proof.
      rewrite max_sym. apply max_eq_L.
    Qed.

  End Pairwise_Maximum.

  Section Pairwise_Minimum.

    Fixpoint min (x y: Ord): Ord :=
      ssup (λ p: src x × src y, min (src_map x (fst p)) (src_map y (snd p))).

    Fixpoint min_le (x y: Ord): min x y ≤ x ∧ min x y ≤ y.
    Proof.
      destruct x, y; split; intros [a b].
      1: exists a. 2: exists b.
      apply min_le.
    Qed.

    Definition min_le_L x y := proj1 (min_le x y) : min x y ≤ x.
    Definition min_le_R x y := proj2 (min_le x y) : min x y ≤ y.

    Fixpoint min_maximality x y: ∀ z, z ≤ x → z ≤ y → z ≤ min x y.
    Proof.
      destruct x as [A x], y as [B y], z as [C z]. cbn.
      intros H1 H2 c.
      specialize (H1 c) as [a H1]; specialize (H2 c) as [b H2].
      exists (a, b). now_show (z c ≤ min (x a) (y b)).
      now apply min_maximality.
    Qed.

    Corollary min_uniqueness x y: ∀ m,
      m ≤ x → m ≤ y → (∀ z, z ≤ x → z ≤ y → z ≤ m) → min x y == m.
    Proof.
      split.
      - apply H1; apply min_le.
      - apply min_maximality; assumption.
    Qed.

    #[export]
    Instance min_covariance: Proper (le ++> le ++> le) min.
    Proof.
      intros [A f] [B g] Le [A' f'] [B' g'] Le'. simpl.
      intros (a, a').
      specialize (Le a) as (b, Le); fold le in Le.
      specialize (Le' a') as (b', Le'); fold le in Le'.
      exists (b, b'); cbn in *.
      apply min_maximality.
      1: rewrite <- Le. 2: rewrite <- Le'.
      apply min_le.
    Qed.

    #[export]
    Instance min_compat: Proper (eq ==> eq ==> eq) min := _.

  End Pairwise_Minimum.

End Ord.

#[global] Bind Scope Ord_scope with Ord Ord.t.

#[global] Infix "≤" := Ord.le: Ord_scope.
#[global] Infix "≥" := Ord.ge: Ord_scope.
#[global] Infix "<" := Ord.lt: Ord_scope.
#[global] Infix ">" := Ord.gt: Ord_scope.
#[global] Infix "==" := Ord.eq: Ord_scope.
#[global] Notation "x =/= y" := (not (Ord.eq x y)): Ord_scope.

#[global] Notation "x == y == z" := (and (Ord.eq x y) (Ord.eq y z)): Ord_scope.
#[global] Notation "x < y < z" := (and (Ord.lt x y) (Ord.lt y z)): Ord_scope.
#[global] Notation "x ≤ y ≤ z" := (and (Ord.le x y) (Ord.le y z)): Ord_scope.
#[global] Notation "x ≤ y < z" := (and (Ord.le x y) (Ord.lt y z)): Ord_scope.
#[global] Notation "x < y ≤ z" := (and (Ord.lt x y) (Ord.le y z)): Ord_scope.
#[global] Notation "x < y == z" := (and (Ord.lt x y) (Ord.eq y z)): Ord_scope.
#[global] Notation "x == y < z" := (and (Ord.eq x y) (Ord.lt y z)): Ord_scope.
#[global] Notation "x ≤ y == z" := (and (Ord.le x y) (Ord.eq y z)): Ord_scope.
#[global] Notation "x == y ≤ z" := (and (Ord.eq x y) (Ord.le y z)): Ord_scope.

#[export] Instance Ord_eq_rewrite: RewriteRelation Ord.eq | 0 := {}.
#[export] Instance Ord_lt_rewrite: RewriteRelation Ord.lt | 1 := {}.
#[export] Instance Ord_le_rewrite: RewriteRelation Ord.le | 1 := {}.
#[export] Instance Ord_gt_rewrite: RewriteRelation Ord.lt | 2 := {}.
#[export] Instance Ord_ge_rewrite: RewriteRelation Ord.ge | 2 := {}.


(* Source : https://erikmd.github.io/tryjscoq/tapfa/tad.v *)

Require Import List. Import ListNotations.
Set Implicit Arguments.

Module Type Monoide.
  Parameter T : Type.           (* une sorte *)
  Parameter un : T.             (* une constante *)
  Parameter prod : T -> T -> T. (* une opération *)

  Axiom assoc : forall x y z:T, prod x (prod y z) = prod (prod x y) z.
  Axiom neutre_g : forall x, prod un x = x.
  Axiom neutre_d : forall x, prod x un = x.
End Monoide.

Module MonoList <: Monoide. (* vérification sans masquage *)
  Definition T := list nat.
  Definition un : T := [].
  Definition prod (x y : T) := x ++ y.
  Lemma assoc : forall x y z:T, prod x (prod y z) = prod (prod x y) z.
  Proof. apply app_assoc. Qed.
  Lemma neutre_g : forall x, prod un x = x.
  Proof. reflexivity. Qed.
  Lemma neutre_d : forall x, prod x un = x.
  Proof. induction x; auto. simpl. rewrite IHx. reflexivity. Qed.
End MonoList.

Module Use (M : Monoide).
  Theorem unicite : forall u : M.T, (forall x, M.prod x u = x) -> u = M.un.
  Proof.
  intros u Hu.
  rewrite <-(Hu M.un).
  rewrite M.neutre_g.
  reflexivity.
  Qed.
End Use.

Module Inst := Use(MonoList).
Check Inst.unicite.
(* : forall u : MonoList.T, (forall x : MonoList.T, MonoList.prod x u = x) -> u = MonoList.un *)

Print MonoList.un.
(* MonoList.un = [] : MonoList.T *)
Print MonoList.T.
(* MonoList.T = list nat : Set *)

Module Type Pile.
  Parameter Elem: Type.
  Parameter P: Type.

  Parameter vide: P.
  Parameter push: Elem -> P -> P.
  Parameter estVide: P -> bool.
  Parameter pop: P -> P.
  Parameter top: P -> option Elem.

  Axiom estVide_vide: estVide vide = true.
  Axiom estVide_push: forall p e, estVide (push e p) = false.
  Axiom top_vide: top vide = None.
  Axiom top_push: forall p e, top (push e p) = Some e.
  Axiom pop_vide: pop vide = vide.
  Axiom pop_push: forall p e, pop (push e p) = p.
End Pile.

Module Pile_Liste <: Pile.
  Definition Elem := nat.
  Definition P := list nat.
  Definition vide : P := [].
  Definition push (e: Elem) (p: P) := e :: p.
  Definition estVide (p: P) :=
    match p with [] => true | _ => false end.
  Definition top (p: P) :=
    match p with [] => None | x :: _ => Some x end.
  Definition pop (p: P) :=
    match p with [] => [] | _ :: l => l end.

  Lemma estVide_vide: estVide vide = true.
  Proof.
  Admitted.

  Lemma estVide_push: forall p e, estVide (push e p) = false.
  Proof.
  Admitted.

  Lemma top_vide: top vide = None.
  Proof.
  Admitted.

  Lemma top_push: forall p e, top (push e p) = Some e.
  Proof.
  Admitted.

  Lemma pop_vide: pop vide = vide.
  Proof.
  Admitted.

  Lemma pop_push: forall p e, pop (push e p) = p.
  Proof.
  Admitted.
End Pile_Liste.

Module Pile_QListe <: Pile.
  Definition Elem := nat.
  Definition P := list nat.
  Definition vide : P := [].
  Definition push (e: Elem) (p: P) := p ++ [e].
  Definition estVide (p: P) :=
    match p with [] => true | _ => false end.
  Fixpoint top (p: P) :=
    match p with
    | [] => None
    | [e] => Some e
    | x :: l => top l
    end.
  Fixpoint pop (p: P) :=
    match p with
    | [] => []
    | [e] => []
    | x :: l => x :: pop l
    end.

  Lemma estVide_vide: estVide vide = true.
  Proof.
  Admitted.

  Lemma estVide_push: forall p e, estVide (push e p) = false.
  Proof.
  Admitted.

  Lemma top_vide: top vide = None.
  Proof.
  Admitted.

  Lemma top_push: forall p e, top (push e p) = Some e.
  Proof.
  Admitted.

  Lemma pop_vide: pop vide = vide.
  Proof.
  Admitted.

  Lemma pop_push: forall p e, pop (push e p) = p.
  Proof.
  Admitted.

End Pile_QListe.


Require Import Lia.

Inductive tree : Type :=
| o : tree
| T : tree -> tree -> tree.

Fixpoint branches (t : tree) :=
match t with
| o => 0
| T t1 t2 => 1 + (branches t1) + (branches t2)
end.

Fixpoint normal (T : tree) : Prop :=
match T with
| o => True
| T o t => normal t
| _ => False
end.

Inductive Eq : tree -> tree -> Prop :=
| EqRef : forall t, Eq t t
| EqSym : forall s t, Eq s t -> Eq t s
| EqTran : forall x y z, Eq x y -> Eq y z -> Eq x z
| EqAsso : forall t1 t2 t3, Eq ( T (T t1 t2) t3 ) (T t1 (T t2 t3) )
| EqT : forall t1 t2 s1 s2, Eq t1 s1 -> Eq t2 s2 -> Eq (T t1 t2) (T s1 s2).

Require Import Setoid Morphisms.

Instance : Equivalence Eq.
Proof.
  split.
  intros t. exact (EqRef t).
  intros s t H. apply EqSym; auto.
  intros x y z H1 H2. exact (EqTran x y z H1 H2).
Defined.

Instance T_congruent :
  Proper (Eq ==> Eq ==> Eq) T.
Proof.
  intros t s Eq t' s' Eq'. apply EqT; auto.
Qed.

Instance branch_congruent :
  Proper (Eq ==> (@eq nat)) branches.
Proof.
  intros t s H. induction H; cbn; lia.
Qed.

Lemma free_leaf t :
  t <> o -> (exists t', Eq t (T o t') ).
Proof.
  intros noLeaf. induction t. now exists o.
  destruct t1.
  - now exists t2.
  - assert (T t1_1 t1_2 <> o) as H by discriminate.
    destruct (IHt1 H) as [t' H']. exists (T t' t2).
    now rewrite H', EqAsso.
Qed.

Lemma ex_iff {X} (P Q : X -> Prop) :
  (forall x, P x <-> Q x) -> (exists x, P x) <-> (exists x, Q x).
Proof.
  firstorder.
Qed.

Theorem pre_normalization : forall (n: nat)(t : tree),
  branches t < n -> exists t', normal t'  /\ Eq t t'.
Proof.
  induction n. destruct t; cbn; lia.
  destruct t; intro Bran. exists o; cbn; split. auto. apply EqRef.
  cbn in Bran. destruct t1.
  - assert (branches t2 < n) as H by lia.
    destruct (IHn _ H) as [s [? E]].
    exists (T o s). split; cbn; try tauto.
    rewrite E; apply EqRef.
  - assert (T t1_1 t1_2 <> o) as  Triv by discriminate.
    destruct ( free_leaf (T t1_1 t1_2) Triv ) as [t1 N1].
    eapply (ex_iff (fun x => normal x /\ Eq (T (T o t1) t2) x)).
    { intros x. now rewrite N1. }
    assert (branches t2 < S n) as H by lia.
    rewrite N1 in Bran; cbn in Bran.
    assert (S (branches t1 + branches t2) < n) as H' by lia.
    change (branches (T t1 t2) < n) in H'.
    destruct (IHn _ H') as [s [? E]].
    exists (T o s). split; cbn; try tauto.
    now rewrite EqAsso, E.
Qed.

Corollary normalization : forall t, exists t', normal t' /\ Eq t t'.
Proof.
  intros t. apply (pre_normalization ( S(branches t)) ). lia.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_collinearright.
Require Export GeoCoq.Elements.OriginalProofs.lemma_rightreverse.
Require Export GeoCoq.Elements.OriginalProofs.lemma_altitudebisectsbase.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_droppedperpendicularunique :
   forall A J M P,
   Per A M P -> Per A J P -> Col A M J ->
   eq M J.
Proof.
intros.
assert (~ neq M J).
 {
 intro.
 assert (neq J M) by (conclude lemma_inequalitysymmetric).
 let Tf:=fresh in
 assert (Tf:exists E, (BetS M J E /\ Cong J E M J)) by (conclude lemma_extension);destruct Tf as [E];spliter.
 assert (neq M E) by (forward_using lemma_betweennotequal).
 let Tf:=fresh in
 assert (Tf:exists F, (BetS J M F /\ Cong M F M E)) by (conclude lemma_extension);destruct Tf as [F];spliter.
 assert (BetS E J M) by (conclude axiom_betweennesssymmetry).
 assert (BetS E J F) by (conclude lemma_3_7b).
 assert (BetS F J E) by (conclude axiom_betweennesssymmetry).
 assert (BetS E M F) by (conclude lemma_3_7a).
 assert (neq J F) by (forward_using lemma_betweennotequal).
 assert (neq F J) by (conclude lemma_inequalitysymmetric).
 assert (Col J M F) by (conclude_def Col ).
 assert (Col M J F) by (forward_using lemma_collinearorder).
 assert (Col M J A) by (forward_using lemma_collinearorder).
 assert (neq J M) by (forward_using lemma_betweennotequal).
 assert (neq M J) by (conclude lemma_inequalitysymmetric).
 assert (Col J F A) by (conclude lemma_collinear4).
 assert (Col A J F) by (forward_using lemma_collinearorder).
 assert (Per F J P) by (conclude lemma_collinearright).
 assert (Col J M F) by (conclude_def Col ).
 assert (Col J M A) by (forward_using lemma_collinearorder).
 assert (Col M F A) by (conclude lemma_collinear4).
 assert (Col A M F) by (forward_using lemma_collinearorder).
 assert (neq M F) by (forward_using lemma_betweennotequal).
 assert (neq F M) by (conclude lemma_inequalitysymmetric).
 assert (Per F M P) by (conclude lemma_collinearright).
 assert (Cong F M M E) by (forward_using lemma_congruenceflip).
 assert (Per F M P) by (conclude lemma_collinearright).
 assert (BetS F M E) by (conclude axiom_betweennesssymmetry).
 assert (Cong F P E P) by (conclude lemma_rightreverse).
 assert (Midpoint F J E) by (conclude lemma_altitudebisectsbase).
 assert (BetS F M E) by (conclude axiom_betweennesssymmetry).
 assert (Cong F M M E) by (forward_using lemma_congruenceflip).
 assert (Midpoint F M E) by (conclude_def Midpoint ).
 assert (eq J M) by (conclude lemma_midpointunique).
 contradict.
 }
close.
Qed.

End Euclid.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.

(* Why3 comment *)
(* abs is replaced with (ZArith.BinInt.Z.abs x) by the coq driver *)

(* Why3 goal *)
Lemma abs_def : forall (x:Z), ((0%Z <= x)%Z ->
  ((ZArith.BinInt.Z.abs x) = x)) /\ ((~ (0%Z <= x)%Z) ->
  ((ZArith.BinInt.Z.abs x) = (-x)%Z)).
intros x.
split ; intros H.
now apply Zabs_eq.
apply Zabs_non_eq.
apply Znot_gt_le.
contradict H.
apply Zlt_le_weak.
now apply Zgt_lt.
Qed.

(* Why3 goal *)
Lemma Abs_le : forall (x:Z) (y:Z), ((ZArith.BinInt.Z.abs x) <= y)%Z <->
  (((-y)%Z <= x)%Z /\ (x <= y)%Z).
intros x y.
zify.
omega.
Qed.

(* Why3 goal *)
Lemma Abs_pos : forall (x:Z), (0%Z <= (ZArith.BinInt.Z.abs x))%Z.
exact Zabs_pos.
Qed.


(** Calculation of an abstract machine for the call-by-name lambda
calculus. The resulting abstract machine (almost) coincides with the
Krivine machine. The relation to the Krivine machine is explained
below. *)

Require Import List.
Require Import ListIndex.
Require Import Tactics.

(** * Syntax *)

Inductive Expr : Set :=
| Var : nat -> Expr
| Abs : Expr -> Expr
| App : Expr -> Expr -> Expr.

(** * Semantics *)

(** We start with the evaluator for this language, which is taken from
Ager et al. "A functional correspondence between evaluators and
abstract machines" (we use Haskell syntax to describe the evaluator):
<<
type Env   = [Thunk]
data Thunk = Thunk (() -> Value)
data Value = Clo (Thunk -> Value)

eval :: Expr -> Env -> Value
eval (Var i)   e = case e !! i of
                     Thunk t -> t ()
eval (Abs x)   e = Clo (\t -> eval x (t : e))
eval (App x y) e = case eval x e of
                     Clo f -> f (Thunk (\_ -> eval y e))
>>
After defunctionalisation and translation into relational form we
obtain the semantics below.  *)

Inductive Thunk : Set  :=
  | thunk : Expr -> list Thunk -> Thunk.

Definition Env : Set := list Thunk.

Inductive Value : Set :=
| Clo : Expr -> Env -> Value.

Reserved Notation "x ⇓[ e ] y" (at level 80, no associativity).

Inductive eval : Expr -> Env -> Value -> Prop :=
| eval_var e e' x i v : nth e i = Some (thunk x e') -> x ⇓[e'] v -> Var i ⇓[e] v
| eval_abs e x : Abs x ⇓[e] Clo x e
| eval_app e e' x x' v y  : x ⇓[e] Clo x' e' -> x' ⇓[thunk y e :: e'] v -> App x y ⇓[e] v
where "x ⇓[ e ] y" := (eval x e y).

(** * Abstract machine *)

Inductive CONT : Set :=
| APP : Expr -> Env -> CONT -> CONT
| HALT : CONT
.

Inductive Conf : Set :=
| eval'' : Expr -> Env -> CONT -> Conf
| apply : CONT -> Value -> Conf.

Notation "⟨ x , e , c ⟩" := (eval'' x e c).
Notation "⟪ c , v ⟫" := (apply c v).

Reserved Notation "x ==> y" (at level 80, no associativity).
Inductive AM : Conf -> Conf -> Prop :=
| am_var i e c x e' : nth e i = Some (thunk x e') -> ⟨Var i, e, c⟩ ==> ⟨x, e', c⟩
| am_abs x e c : ⟨Abs x, e, c⟩ ==> ⟪c, Clo x e⟫
| am_app x y e c : ⟨App x y, e, c⟩ ==> ⟨x, e, APP y e c⟩
| am_APP y e c x' e' : ⟪APP y e c, Clo x' e'⟫ ==> ⟨x', thunk y e::e', c⟩
where "x ==> y" := (AM x y).

(** The only difference between the above machine and the Krivine
machine is that the former produces via the rule [am_abs] a state of
the form [⟪...⟫], which is then immediately consumed by the rule
[am_APP]. These two rules [am_abs] and [am_APP] can therefore be fused
into a single rule. The resulting machine is exactly coincides with
the Krivine machine. *)

(** * Calculation *)

(** Boilerplate to import calculation tactics *)

Module AM <: Preorder.
Definition Conf := Conf.
Definition VM := AM.
End AM.
Module AMCalc := Calculation AM.
Import AMCalc.

(** Specification of the abstract machine *)

Theorem spec x e r c : x ⇓[e] r -> ⟨x, e, c⟩ =>> ⟪c, r⟫.

(** Setup the induction proof *)

Proof.
  intros.
  generalize dependent c.
  induction H;intros.

(** Calculation of the abstract machine *)

(** - [Var i ⇓[e] v] *)

  begin
    ⟪c, v ⟫.
  <<= {apply IHeval}
    ⟨x, e', c ⟩.
  <== {apply am_var}
    ⟨Var i, e, c⟩.
  [].

(** - [Abs x ⇓[e] Clo x e] *)

  begin
    ⟪c, Clo x e⟫.
  <== { apply am_abs }
    ⟨Abs x, e, c⟩.
  [].

(** - [App x y ⇓[e] w] *)

  begin
    ⟪c, v⟫.
  <<= { apply IHeval2 }
    ⟨x', (thunk y e::e'), c⟩.
  <== { apply am_APP }
    ⟪APP y e c, Clo x' e'⟫.
  <<= {apply IHeval1}
    ⟨x, e, APP y e c⟩.
  <== {apply am_app}
    ⟨App x y, e, c⟩.
  [].
Qed.

(** * Soundness *)

Lemma determ_am : determ AM.
  intros C c1 c2 V. induction V; intro V'; inversion V'; subst; congruence.
Qed.

Definition terminates (p : Expr) : Prop := exists r, p ⇓[nil] r.

Theorem sound x C : terminates x -> ⟨x, nil, HALT⟩ =>>! C ->
                          exists r, C = ⟪HALT, r⟫ /\ x ⇓[nil] r.
Proof.
  unfold terminates. intros. destruct H as [r T].

  pose (spec x nil r HALT) as H'. exists r. split. pose (determ_trc determ_am) as D.
  unfold determ in D. eapply D. eassumption. split. eauto. intro. destruct H.
  inversion H. assumption.
Qed.


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

Require Import Orders Rbase Rbasic_fun ROrderedType GenericMinMax.

(** * Maximum and Minimum of two real numbers *)

Local Open Scope R_scope.

(** The functions [Rmax] and [Rmin] implement indeed
    a maximum and a minimum *)

Lemma Rmax_l : forall x y, y<=x -> Rmax x y = x.
Proof.
 unfold Rmax. intros.
 destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
  unfold Rle in *; intuition.
Qed.

Lemma Rmax_r : forall x y, x<=y -> Rmax x y = y.
Proof.
 unfold Rmax. intros.
 destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
  unfold Rle in *; intuition.
Qed.

Lemma Rmin_l : forall x y, x<=y -> Rmin x y = x.
Proof.
 unfold Rmin. intros.
 destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
  unfold Rle in *; intuition.
Qed.

Lemma Rmin_r : forall x y, y<=x -> Rmin x y = y.
Proof.
 unfold Rmin. intros.
 destruct Rle_dec as [H'|H']; [| apply Rnot_le_lt in H' ];
  unfold Rle in *; intuition.
Qed.

Module RHasMinMax <: HasMinMax R_as_OT.
 Definition max := Rmax.
 Definition min := Rmin.
 Definition max_l := Rmax_l.
 Definition max_r := Rmax_r.
 Definition min_l := Rmin_l.
 Definition min_r := Rmin_r.
End RHasMinMax.

Module R.

(** We obtain hence all the generic properties of max and min. *)

Include UsualMinMaxProperties R_as_OT RHasMinMax.

(** * Properties specific to the [R] domain *)

(** Compatibilities (consequences of monotonicity) *)

Lemma plus_max_distr_l : forall n m p, Rmax (p + n) (p + m) = p + Rmax n m.
Proof.
 intros. apply max_monotone.
 intros x y. apply Rplus_le_compat_l.
Qed.

Lemma plus_max_distr_r : forall n m p, Rmax (n + p) (m + p) = Rmax n m + p.
Proof.
 intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p).
 apply plus_max_distr_l.
Qed.

Lemma plus_min_distr_l : forall n m p, Rmin (p + n) (p + m) = p + Rmin n m.
Proof.
 intros. apply min_monotone.
 intros x y. apply Rplus_le_compat_l.
Qed.

Lemma plus_min_distr_r : forall n m p, Rmin (n + p) (m + p) = Rmin n m + p.
Proof.
 intros. rewrite (Rplus_comm n p), (Rplus_comm m p), (Rplus_comm _ p).
 apply plus_min_distr_l.
Qed.

(** Anti-monotonicity swaps the role of [min] and [max] *)

Lemma opp_max_distr : forall n m : R, -(Rmax n m) = Rmin (- n) (- m).
Proof.
 intros. symmetry. apply min_max_antimonotone.
 do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto.
Qed.

Lemma opp_min_distr : forall n m : R, - (Rmin n m) = Rmax (- n) (- m).
Proof.
 intros. symmetry. apply max_min_antimonotone.
 do 3 red. intros; apply Rge_le. apply Ropp_le_ge_contravar; auto.
Qed.

Lemma minus_max_distr_l : forall n m p, Rmax (p - n) (p - m) = p - Rmin n m.
Proof.
 unfold Rminus. intros. rewrite opp_min_distr. apply plus_max_distr_l.
Qed.

Lemma minus_max_distr_r : forall n m p, Rmax (n - p) (m - p) = Rmax n m - p.
Proof.
 unfold Rminus. intros. apply plus_max_distr_r.
Qed.

Lemma minus_min_distr_l : forall n m p, Rmin (p - n) (p - m) = p - Rmax n m.
Proof.
 unfold Rminus. intros. rewrite opp_max_distr. apply plus_min_distr_l.
Qed.

Lemma minus_min_distr_r : forall n m p, Rmin (n - p) (m - p) = Rmin n m - p.
Proof.
 unfold Rminus. intros. apply plus_min_distr_r.
Qed.

End R.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (x : natural) (lf2 : natural) (y : natural) (lf1 : natural)
  : natural := plus (Succ y) Zero.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.ZUtil.Notations.
Require Import Crypto.Util.LetIn.
Local Open Scope Z_scope.

Module Z.
  Definition pow2_mod n i := (n &' (Z.ones i)).

  Definition zselect (cond zero_case nonzero_case : Z) :=
    if cond =? 0 then zero_case else nonzero_case.

  Definition add_modulo x y modulus :=
    if (modulus <=? x + y) then (x + y) - modulus else (x + y).

  Definition get_carry (bitwidth : Z) (v : Z) : Z * Z
    := (v mod 2^bitwidth, v / 2^bitwidth).
  Definition add_with_carry (c : Z) (x y : Z) : Z
    := c + x + y.
  Definition add_with_get_carry (bitwidth : Z) (c : Z) (x y : Z) : Z * Z
    := get_carry bitwidth (add_with_carry c x y).
  Definition add_get_carry (bitwidth : Z) (x y : Z) : Z * Z
    := add_with_get_carry bitwidth 0 x y.

  Definition get_borrow (bitwidth : Z) (v : Z) : Z * Z
    := let '(v, c) := get_carry bitwidth v in
       (v, -c).
  Definition sub_with_borrow (c : Z) (x y : Z) : Z
    := add_with_carry (-c) x (-y).
  Definition sub_with_get_borrow (bitwidth : Z) (c : Z) (x y : Z) : Z * Z
    := get_borrow bitwidth (sub_with_borrow c x y).
  Definition sub_get_borrow (bitwidth : Z) (x y : Z) : Z * Z
    := sub_with_get_borrow bitwidth 0 x y.

  (* splits at [bound], not [2^bitwidth]; wrapper to make add_getcarry
  work if input is not known to be a power of 2 *)
  Definition add_get_carry_full (bound : Z) (x y : Z) : Z * Z
    := if 2 ^ (Z.log2 bound) =? bound
       then add_get_carry (Z.log2 bound) x y
       else ((x + y) mod bound, (x + y) / bound).
  Definition add_with_get_carry_full (bound : Z) (c x y : Z) : Z * Z
    := if 2 ^ (Z.log2 bound) =? bound
       then add_with_get_carry (Z.log2 bound) c x y
       else ((c + x + y) mod bound, (c + x + y) / bound).
  Definition sub_get_borrow_full (bound : Z) (x y : Z) : Z * Z
    := if 2 ^ (Z.log2 bound) =? bound
       then sub_get_borrow (Z.log2 bound) x y
       else ((x - y) mod bound, -((x - y) / bound)).
  Definition sub_with_get_borrow_full (bound : Z) (c x y : Z) : Z * Z
    := if 2 ^ (Z.log2 bound) =? bound
       then sub_with_get_borrow (Z.log2 bound) c x y
       else ((x - y - c) mod bound, -((x - y - c) / bound)).

  Definition mul_split_at_bitwidth (bitwidth : Z) (x y : Z) : Z * Z
    := dlet xy := x * y in
        (match bitwidth with
         | Z.pos _ | Z0 => xy &' Z.ones bitwidth
         | Z.neg _ => xy mod 2^bitwidth
         end,
         match bitwidth with
         | Z.pos _ | Z0 => xy >> bitwidth
         | Z.neg _ => xy / 2^bitwidth
         end).
  Definition mul_split (s x y : Z) : Z * Z
    := if s =? 2^Z.log2 s
       then mul_split_at_bitwidth (Z.log2 s) x y
       else ((x * y) mod s, (x * y) / s).
End Z.