(* ***************************************************************** *)
(*                                                                   *)
(* Released: 2021/05/17.                                             *)
(* Due: 2021/05/21, 23:59:59, CST.                                   *)
(*                                                                   *)
(* 0. Read instructions carefully before start writing your answer.  *)
(*                                                                   *)
(* 1. You should not add any hypotheses in this assignment.          *)
(*    Necessary ones have been provided for you.                     *)
(*                                                                   *)
(* 2. In order to check whether you have finished all tasks or not,  *)
(*    just see whether all "Admitted" has been replaced.             *)
(*                                                                   *)
(* 3. You should submit this file (Assignment8.v) on CANVAS.         *)
(*                                                                   *)
(* 4. Only valid Coq files are accepted. In other words, please      *)
(*    make sure that your file does not generate a Coq error. A      *)
(*    way to check that is: click "compile buffer" for this file     *)
(*    and see whether an "Assignment9.vo" file is generated.         *)
(*                                                                   *)
(* 5. Do not copy and paste others' answer.                          *)
(*                                                                   *)
(* 6. Using any theorems and/or tactics provided by Coq's standard   *)
(*    library is allowed in this assignment, if not specified.       *)
(*                                                                   *)
(* 7. When you finish, answer the following question:                *)
(*                                                                   *)
(*      Who did you discuss with when finishing this                 *)
(*      assignment? Your answer to this question will                *)
(*      NOT affect your grade.                                       *)
(*      (* FILL IN YOUR ANSWER HERE AS COMMENT *)                    *)
(*                                                                   *)
(* ***************************************************************** *)

Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import PL.RTClosure PL.Imp.

(* ################################################################# *)
(** * Task 1: Mix typed expressions *)

Module Task1.
Local Open Scope Z.

(** This is our definition of mix typed expressions. In this task, you need to
    answer questions about their evaluation process and type checking results. *)

Definition var: Type := nat.

Definition state: Type := var -> Z.

Inductive mexp : Type :=
  | MNum (n : Z)
  | MId (X : var)
  | MPlus (a1 a2 : mexp)
  | MMinus (a1 a2 : mexp)
  | MMult (a1 a2 : mexp)
  | MTrue
  | MFalse
  | MEq (a1 a2 : mexp)
  | MLe (a1 a2 : mexp)
  | MNot (b : mexp)
  | MAnd (b1 b2 : mexp)
.

(** Here is some coercion and notations for pretty printing. *)

Declare Scope mexp.
Delimit Scope mexp with mexp.
Local Open Scope mexp.

Coercion MNum : Z >-> mexp.
Coercion MId : var >-> mexp.
Notation "x + y" := (MPlus x y) (at level 50, left associativity) : mexp.
Notation "x - y" := (MMinus x y) (at level 50, left associativity) : mexp.
Notation "x * y" := (MMult x y) (at level 40, left associativity) : mexp.
Notation "x <= y" := (MLe x y) (at level 70, no associativity) : mexp.
Notation "x == y" := (MEq x y) (at level 70, no associativity) : mexp.
Notation "x && y" := (MAnd x y) (at level 40, left associativity) : mexp.
Notation "'!' b" := (MNot b) (at level 39, right associativity) : mexp.
Notation "[ x ; .. ; y ]" := (@cons mexp x .. (@cons mexp y (@nil mexp)) ..).

Module Task1_Examples.

Parameter X: var.
Parameter S: var.

(** Suppose [X] and [S] are program variables and [st: state] satisfies:

    - [st X = 0]

    - [st S = 0].

    Please describe the evaluation process of

    - [S + (X == 0)]

    on [st] using a Coq list. Specifically, this Coq list must demonstrate the
    result of every step (see lecture notes: run time error 2) from the
    beginning to the end. The ending expression can be a evaluation result (an
    integer constant or a boolean constant) or a stuck state (no step can be
    taken since an error occurs).
*)

Definition my_answer_1: list mexp :=
  [ S + (X == 0);
    0 + (X == 0);
    0 + (0 == 0);
    0 + MTrue;
    0 + 1;
    1 ]
.

(** Suppose [X] and [S] are program variables and [st: state] satisfies:

    - [st X = 0]

    - [st S = 0].

    Please describe the evaluation process of

    - [S && (X == 0)]

    on [st] using a Coq list. Specifically, this Coq list must demonstrate the
    result of every step (see lecture notes: run time error 2) from the
    beginning to the end. The ending expression can be a evaluation result (an
    integer constant or a boolean constant) or a stuck state (no step can be
    taken since an error occurs).
*)

Definition my_answer_2: list mexp :=
  [ S && (X == 0);
    0 && (X == 0) ]
.

End Task1_Examples.

(** **** Exercise: 2 stars, standard *)

Parameter P: var.
Parameter X: var.

(** Suppose [P] and [X] are program variables and [st: state] satisfies:

    - [st P = 0]

    - [st X = 1].

    Please describe the evaluation process of

    - [(P == 0) && (X && (X + 1))]

    on [st] using a Coq list. Specifically, this Coq list must demonstrate the
    result of every step (see lecture notes: run time error 2) from the
    beginning to the end. The ending expression can be a evaluation result (an
    integer constant or a boolean constant) or a stuck state (no step can be
    taken since an error occurs).
*)

Definition my_answer_1_1: list mexp :=
  [ (P == 0) && (X && (X + 1));
    (0 == 0) && (X && (X + 1));
    MTrue && (X && (X + 1));
    X && (X + 1);
    1 && (X + 1) ]
.
(** [] *)

(** **** Exercise: 2 stars, standard *)

(** This time, consider a slightly different situation. Suppose [st: state]
    satisfies:

    - [st P = 1]

    - [st X = 1].

    Please describe the evaluation process of

    - [(P == 0) && (X && (X + 1))]

    on [st] using a Coq list. Specifically, this Coq list must demonstrate the
    result of every step (see lecture notes: run time error 2) from the
    beginning to the end. The ending expression can be a evaluation result (an
    integer constant or a boolean constant) or a stuck state (no step can be
    taken since an error occurs).
*)

Definition my_answer_1_2: list mexp :=
  [ (P == 0) && (X && (X + 1));
    (1 == 0) && (X && (X + 1));
    MFalse && (X && (X + 1));
    MFalse ]
.
(** [] *)

(** **** Exercise: 1 star, standard *)

(** Does [(P == 0) && (X && (X + 1))] type check?
    1. Yes. 2. No.
*)

Definition my_answer_1_3: Z := 2.
(** [] *)

(** **** Exercise: 1 star, standard *)

(** Does [(P == 0) && (P == 1) && (X && (X + 1))] type check?
    1. Yes. 2. No.
*)

Definition my_answer_1_4: Z := 2.
(** [] *)

Import ListNotations.

(** **** Exercise: 1 star, standard *)

(** Which of the following statements are correct about [mexp]'s small step
    semantics and type checking function?

    1. Its semantics is type safe since it has the progress property and
       the preservation property.

    2. Every legal expression (according the type checking function) can be
       evaluated safely to the end on any program state and the evaluation
       process will either end in an integer constant or a boolean constant.

    3. If an expression [m: mexp] can be safely evaluated on a state [st],
       then [m] must be a well-typed expression.

    4. If an expression [m: mexp] can be safely evaluated on any state [st],
       then [m] must be a well-typed expression.

    This is a multiple-choice problem. You should use an ascending Coq list to
    describe your answer, e.g. [1; 2; 3], [1; 3], [2]. *)

Definition my_answer_1_5: list Z := [1; 2].
(** [] *)

End Task1.

(* ################################################################# *)
(** * Task 2: Nondeterministic programs *)

Module Task2.

(** Consider the programming language with [CChoice] we discussed in class.
    Please determine whether sample programs satisfy one of the following
    properties or not. Here are the list of properties.

    - 1. The program has deterministic behavior and will terminate.

    - 2. The program has nondeterministic behavior but will always terminate.

    - 3. The program has deterministic behavior and will not terminate.

    - 4. It is possible for the program to terminate and also possible not to
         terminate . *)

(** **** Exercise: 1 star, standard *)

(** The program [c] is:
        [[
            CChoice (X ::= 1) (X ::= 2)
        ]]
    The initial state [st] satisfies:
        [[
            st Y = 0
        ]]
    for any program variable [Y]. Which property listed in the beginning of this
    task is true for executing [c] from [st] according to the denotational
    semantics? *)

Definition my_answer_2_1: Z := 2.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** **** Exercise: 1 star, standard *)

(** The program [c] is:
        [[
            CChoice (X ::= 1) (X ::= X + 1)
        ]]
    The initial state [st] satisfies:
        [[
            st Y = 0
        ]]
    for any program variable [Y]. Which property listed in the beginning of this
    task is true for executing [c] from [st] according to the small step
    semantics? *)

Definition my_answer_2_2: Z := 2.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** **** Exercise: 1 star, standard *)

(** The program [c] is:
        [[
            X ::= 1000;;
            While (! (X == 0)) Do
               CChoice (X ::= X - 1) (Skip)
            EndWhile
        ]]
    The initial state [st] satisfies:
        [[
            st Y = 0
        ]]
    for any program variable [Y]. Which property listed in the beginning of this
    task is true for executing [c] from [st] according to the small step
    semantics? *)

Definition my_answer_2_3: Z := 4.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

(** **** Exercise: 1 star, standard *)

(** The program [c] is:
        [[
            X ::= 1001;;
            While (! (X == 0)) Do
               CChoice (X ::= X - 2) (Skip)
            EndWhile
        ]]
    The initial state [st] satisfies:
        [[
            st Y = 0
        ]]
    for any program variable [Y]. Which property listed in the beginning of this
    task is true for executing [c] from [st] according to the denotational
    semantics? *)

Definition my_answer_2_4: Z := 3.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
(** [] *)

End Task2.

(* ################################################################# *)
(** * Task 3: Pointers and addresses *)

Module OptF.

Definition add {A: Type} (f g: A -> option Z): A -> option Z :=
  fun st =>
    match f st, g st with
    | Some v1, Some v2 => Some (v1 + v2)
    | _, _ => None
    end.

Definition sub {A: Type} (f g: A -> option Z): A -> option Z :=
  fun st =>
    match f st, g st with
    | Some v1, Some v2 => Some (v1 - v2)
    | _, _ => None
    end.

Definition mul {A: Type} (f g: A -> option Z): A -> option Z :=
  fun st =>
    match f st, g st with
    | Some v1, Some v2 => Some (v1 * v2)
    | _, _ => None
    end.

End OptF.

Module Task3.
Local Open Scope Z.

(** The following are the programming language we discussed in class. We paste
    its integer expression, its denotational semantics and its small step
    semantics. *)

Definition var: Type := nat.

Inductive aexp : Type :=
  | ANum (n : Z)
  | AId (X : var)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp)
  | ADeref (a1: aexp)
  | AAddr (a1: aexp).

Definition var2addr (X: var): Z := Z.of_nat X + 1.

Definition state: Type := Z -> option Z.

Fixpoint aevalR (a: aexp): state -> option Z :=
  match a with
  | ANum n => fun _ => Some n
  | AId X => fun st => st (var2addr X)
  | APlus a1 a2 => OptF.add (aevalR a1) (aevalR a2)
  | AMinus a1 a2  => OptF.sub (aevalR a1) (aevalR a2)
  | AMult a1 a2 => OptF.mul (aevalR a1) (aevalR a2)
  | ADeref a1 => fun st =>
                   match aevalR a1 st with
                   | Some n1 => st n1
                   | None => None
                   end
  | AAddr a1 => aevalL a1
  end
with aevalL (a: aexp): state -> option Z :=
  match a with
  | ANum n => fun _ => None
  | AId X => fun st => Some (var2addr X)
  | APlus a1 a2 => fun _ => None
  | AMinus a1 a2  => fun _ => None
  | AMult a1 a2 => fun _ => None
  | ADeref a1 => aevalR a1
  | AAddr a1 => fun _ => None
  end.

Inductive aexp_halt: aexp -> Prop :=
  | AH_num : forall n, aexp_halt (ANum n).

Inductive astepR : state -> aexp -> aexp -> Prop :=
  | ASR_Id : forall st X n,
      st (var2addr X) = Some n ->
      astepR st
        (AId X) (ANum n)

  | ASR_Plus1 : forall st a1 a1' a2,
      astepR st
        a1 a1' ->
      astepR st
        (APlus a1 a2) (APlus a1' a2)
  | ASR_Plus2 : forall st a1 a2 a2',
      aexp_halt a1 ->
      astepR st
        a2 a2' ->
      astepR st
        (APlus a1 a2) (APlus a1 a2')
  | ASR_Plus : forall st n1 n2,
      astepR st
        (APlus (ANum n1) (ANum n2)) (ANum (n1 + n2))

  | ASR_Minus1 : forall st a1 a1' a2,
      astepR st
        a1 a1' ->
      astepR st
        (AMinus a1 a2) (AMinus a1' a2)
  | ASR_Minus2 : forall st a1 a2 a2',
      aexp_halt a1 ->
      astepR st
        a2 a2' ->
      astepR st
        (AMinus a1 a2) (AMinus a1 a2')
  | ASR_Minus : forall st n1 n2,
      astepR st
        (AMinus (ANum n1) (ANum n2)) (ANum (n1 - n2))

  | ASR_Mult1 : forall st a1 a1' a2,
      astepR st
        a1 a1' ->
      astepR st
        (AMult a1 a2) (AMult a1' a2)
  | ASR_Mult2 : forall st a1 a2 a2',
      aexp_halt a1 ->
      astepR st
        a2 a2' ->
      astepR st
        (AMult a1 a2) (AMult a1 a2')
  | ASR_Mult : forall st n1 n2,
      astepR st
        (AMult (ANum n1) (ANum n2)) (ANum (n1 * n2))

  | ASR_DerefStep : forall st a1 a1',
      astepR st
        a1 a1' ->
      astepR st
        (ADeref a1) (ADeref a1')
  | ASR_Deref : forall st n n',
      st n = Some n' ->
      astepR st
        (ADeref (ANum n)) (ANum n')

  | ASR_AddrStep : forall st a1 a1',
      astepL st
        a1 a1' ->
      astepR st
        (AAddr a1) (AAddr a1')
  | ASR_Addr : forall st n,
      astepR st
        (AAddr (ADeref (ANum n))) (ANum n)
with astepL : state -> aexp -> aexp -> Prop :=
  | ASL_Id: forall st X,
      astepL st
        (AId X) (ADeref (ANum (var2addr X)))

  | ASL_DerefStep: forall st a1 a1',
      astepR st
        a1 a1' ->
      astepL st
        (ADeref a1) (ADeref a1')
.

(** Then, we can define multi-step relations like we did before. *)

Definition multi_astepR st := clos_refl_trans (astepR st).
Definition multi_astepL st := clos_refl_trans (astepL st).

(** The following tasks require you to show congruence properties of small step
    relations for [AAddr]. Remember that you can use [induction_n1],
    [induction_1n], [etransitivity_n1] and [etransitivity_1n] to automate your
    proof. *)

(** **** Exercise: 2 stars, standard (multi_congr_AAddr) *)
Lemma multi_congr_AAddr: forall st a a',
  multi_astepL st a a' ->
  multi_astepR st (AAddr a) (AAddr a').
Proof.
  intros.
  induction_1n H.
  + reflexivity.
  + etransitivity_1n.
    - constructor.
      exact H.
    - exact IHrt.
Qed.
(** [] *)

(** How to formally state the connection between the denotational semantics and
    the small step semantics? One direction should be:
        [[
           forall st a n,
             aevalR a st = Some n -> multi_astepR st a (ANum n)
        ]]
    and
        [[
           forall st a n,
             aevalL a st = Some n -> multi_astepL st a (ADeref (ANum n)).
        ]]
    We can prove these properties by induction over [a]. The next task requires
    you to prove the induction step for [AAddr]. *)

(** **** Exercise: 2 stars, standard (semantic_equiv_aexp_AAddr) *)
Lemma semantic_equiv_aexp_AAddr: forall st a
  (IH: forall n: Z, aevalL a st = Some n -> multi_astepL st a (ADeref (ANum n))),
  (forall n: Z, aevalR (AAddr a) st = Some n -> multi_astepR st (AAddr a) (ANum n)).
Proof.
  intros.
  simpl in H.
  specialize (IH n H).
  apply multi_congr_AAddr in IH.
  etransitivity_n1.
  + exact IH.
  + constructor.
Qed.
(** [] *)

End Task3.

(* 2021-05-17 20:13 *)


Require Types.Iso.
Require Fin.

Set Asymmetric Patterns.

(** A type family which is isomorphic to Fin.t, but defined in
    terms of simpler types by recursion, and is a little bit
    easier to work with. *)
Fixpoint Fin (n : nat) : Set := match n with
  | 0 => False
  | S n' => (True + Fin n')%type
  end.

(** Fin and Fin.t are isomorphic for every size. *)
Theorem finIso (n : nat) : Iso.T (Fin.t n) (Fin n).
Proof.
induction n.
- eapply Iso.Build_T.
  intros a. inversion a.
  intros b. inversion b.
-
refine (
{| Iso.to := fun x => (match x in Fin.t n'
  return (S n = n') -> Fin (S n) with
   | Fin.F1 _ => fun _ => inl I
   | Fin.FS n' x' => fun pf => inr (Iso.to IHn (eq_rect n' Fin.t x' _ (eq_sym (eq_add_S _ _ pf))))
   end) eq_refl
 ; Iso.from := fun x => match x with
   | inl I => Fin.F1
   | inr x' => Fin.FS (Iso.from IHn x')
   end
|}).
intros a.
Require Import Program.
dependent destruction a; simpl.
reflexivity. rewrite Iso.from_to. reflexivity.
intros b. destruct b. destruct t. reflexivity.
  simpl. rewrite Iso.to_from. reflexivity.
Grab Existential Variables.
intros bot. contradiction.
intros f0. inversion f0.
Defined.

Lemma botNull (A : Type) : Iso.T A (A + False).
Proof.
refine (
{| Iso.to   := inl
 ; Iso.from := fun x => match x with
    | inl x' => x'
    | inr bot => False_rect A bot
   end
|}).
reflexivity.
intros b. destruct b. reflexivity. contradiction.
Defined.

Fixpoint split (m : nat)
  : forall (n : nat), Fin.t (m + n) -> (Fin.t m + Fin.t n).
refine (
  match m return (forall (n : nat), Fin.t (m + n) -> (Fin.t m + Fin.t n)) with
  | 0 => fun _ => inr
  | S m' => fun n x => (match x as x0 in Fin.t k
    return forall (pf : k = (S m' + n)), (Fin.t (S m') + Fin.t n) with
    | Fin.F1 _ => fun pf => inl Fin.F1
    | Fin.FS n' x' => fun pf => _
    end) eq_refl
  end).
simpl in pf.
apply eq_add_S in pf.
rewrite pf in x'.
refine (match split m' n x' with
  | inl a => inl (Fin.FS a)
  | inr b => inr b
  end).
Defined.

Lemma splitL : forall {m n : nat} {x : Fin.t m},
  split m n (Fin.L n x) = inl x.
Proof.
intros m. induction m; intros n x.
- inversion x.
- dependent destruction x; simpl.
  + reflexivity.
  + rewrite (IHm n x). reflexivity.
Qed.

Lemma splitR : forall {m n : nat} {x : Fin.t n},
  split m n (Fin.R m x) = inr x.
Proof.
intros m. induction m; intros n x; simpl.
- reflexivity.
- rewrite (IHm n x). reflexivity.
Qed.

Lemma splitInj : forall {m n : nat} {x y : Fin.t (m + n)},
  split m n x = split m n y -> x = y.
Proof.
intros m; induction m; intros n x y Heq.
- inversion Heq. reflexivity.
- dependent destruction x; dependent destruction y.
  + reflexivity.
  + simpl in Heq. destruct (split m n y); inversion Heq.
  + simpl in Heq. destruct (split m n x); inversion Heq.
  + apply f_equal. simpl in Heq. apply IHm.
    destruct (split m n x) eqn:sx;
    destruct (split m n y) eqn:sy.
    apply f_equal.
    assert (forall (A B : Type) (x y : A), @inl A B x = @inl A B y -> x = y).
    intros A B x0 y0 Heqn. inversion Heqn. reflexivity.
    apply H in Heq. apply Fin.FS_inj in Heq. assumption.
    inversion Heq. inversion Heq. apply f_equal. injection Heq. trivial.
Qed.

Fixpoint splitMult (m : nat)
  : forall (n : nat), Fin.t (m * n) -> (Fin.t m * Fin.t n)
  := match m return (forall (n : nat), Fin.t (m * n) -> (Fin.t m * Fin.t n)) with
  | 0 => fun _ => Fin.case0 _
  | S m' => fun n x => match split n (m' * n) x with
    | inl a => (Fin.F1, a)
    | inr b => match splitMult m' n b with
      | (x, y) => (Fin.FS x, y)
      end
    end
  end.

Lemma finPlus : forall {m n : nat},
  Iso.T (Fin.t m + Fin.t n) (Fin.t (m + n)).
Proof.
intros m n.
refine (
{| Iso.to := fun x => match x with
   | inl a => Fin.L n a
   | inr b => Fin.R m b
   end
 ; Iso.from := split m n
|}).
intros. destruct a; simpl. induction m; simpl.
- inversion t.
Require Import Program.
- dependent destruction t; simpl.
  + reflexivity.
  + rewrite IHm. reflexivity.
- induction m; simpl. reflexivity. rewrite IHm. reflexivity.
- induction m; intros; simpl.
  + reflexivity.
  + dependent destruction b; simpl. reflexivity.
     pose proof (IHm b).
     destruct (split m n b) eqn:seqn;
     simpl; rewrite H; reflexivity.
Qed.

Lemma finMult : forall {m n : nat},
  Iso.T (Fin.t m * Fin.t n) (Fin.t (m * n)).
Proof.
intros m n.
refine (
{| Iso.to := fun x => match x with (a, b) => Fin.depair a b end
 ; Iso.from := splitMult m n
|}).
intros p. destruct p.
induction m; simpl.
- inversion t.
- dependent destruction t; simpl.
  + rewrite splitL. reflexivity.
  + rewrite splitR. rewrite (IHm t). reflexivity.

- induction m; intros b; simpl.
  + inversion b.
  + destruct (split n (m * n) b) eqn:seqn.
    * simpl. rewrite <- splitL in seqn.
      apply splitInj in seqn. symmetry. assumption.
    * pose proof (IHm t). assert (b = Fin.R n t).
      apply (@splitInj n (m * n)).
      rewrite seqn. symmetry. apply splitR.
      rewrite H0. simpl.
      destruct (splitMult m n t) eqn:smeqn.
      simpl. rewrite <- H. reflexivity.
Defined.

Fixpoint pow (b e : nat) : nat := match e with
  | 0 => 1
  | S e' => b * pow b e'
  end.

Theorem finPow : forall {e b : nat},
  Iso.T (Fin.t (pow b e)) (Fin.t e -> Fin.t b).
Proof.
intros e. induction e; intros n; simpl.
- eapply Iso.Trans. apply finIso. simpl. eapply Iso.Trans.
  eapply Iso.Sym. apply botNull. eapply Iso.Trans. Focus 2.
  eapply Iso.FuncCong. eapply Iso.Sym. apply finIso. apply Iso.Refl.
  simpl. apply Iso.Sym. apply Iso.FFunc.
- eapply Iso.Trans. eapply Iso.Sym. apply finMult.
  eapply Iso.Trans. Focus 2. eapply Iso.FuncCong.
  eapply Iso.Sym. apply finIso. apply Iso.Refl.
  simpl. eapply Iso.Trans. Focus 2. eapply Iso.Sym. eapply Iso.PlusFunc.
  apply Iso.TFunc. eapply Iso.Trans. eapply Iso.FuncCong.
  eapply Iso.Sym. apply finIso. apply Iso.Refl. eapply Iso.Sym.
  apply IHe. apply Iso.Refl.
Qed.

(** A universe of codes for finite types. *)
Inductive U : Set :=
  | U0    : U
  | U1    : U
  | UPlus : U -> U -> U
  | UTimes : U -> U -> U
  | UFunc : U -> U -> U
  | UFint : nat -> U
  | UFin : nat -> U.

(** The types which the codes of U represent. *)
Fixpoint ty (t : U) : Set := match t with
  | U0 => False
  | U1 => True
  | UPlus a b => (ty a + ty b)%type
  | UTimes a b => (ty a * ty b)%type
  | UFunc a b => ty a -> ty b
  | UFint n => Fin.t n
  | UFin n => Fin n
  end.

(** For every code for a finite type, we give its cardinality as
    a natural number. *)
Fixpoint Ucard (t : U) : nat := match t with
  | U0 => 0
  | U1 => 1
  | UPlus a b => Ucard a + Ucard b
  | UTimes a b => Ucard a * Ucard b
  | UFunc a b => pow (Ucard b) (Ucard a)
  | UFint n => n
  | UFin n => n
  end.

(** Each type in the finite universe is isomorphic to the Fin.t
    family whose size is determined by the cardinality function above. *)
Theorem finChar (t : U) : Iso.T (ty t) (Fin.t (Ucard t)).
Proof.
induction t; simpl.
- apply Iso.Sym. apply (finIso 0).
- apply Iso.Sym. apply (@Iso.Trans _ (Fin 1)). apply (finIso 1).
  apply Iso.Sym. apply botNull.
- eapply Iso.Trans. eapply Iso.PlusCong. eassumption.
  eassumption.
  apply finPlus.
- eapply Iso.Trans. eapply Iso.TimesCong; try eassumption.
  apply finMult.
- eapply Iso.Trans. eapply Iso.FuncCong; try eassumption.
  apply Iso.Sym. apply finPow.
- apply Iso.Refl.
- apply Iso.Sym. apply finIso.
Qed.

(** A type for evidence that a type is finite: a type is finite if
    any of the following hold:
    a) it is True
    b) it is False
    c) it is a sum of finite types
    d) it is isomorphic to a finite type

    This is not minimal. We could have replaced b) and c) with the condition
    e) it is the sum of True with a finite type
       (this is the analog of Successor)
    But this definition is simple so I like it.
*)

Inductive T : Type -> Type :=
  | F0 : T False
  | FS : forall {A}, T A -> T (True + A)
  | FIso : forall {A B}, T A -> Iso.T A B -> T B
.

Fixpoint card {A} (fin : T A) := match fin with
  | F0 => 0
  | FS _ n => S (card n)
  | FIso _ _ x iso => card x
  end.

Definition fin (n : nat) : T (Fin.t n).
Proof. eapply FIso. Focus 2. eapply Iso.Sym. eapply finIso.
induction n; simpl.
- apply F0.
- apply FS. assumption.
Qed.

Definition finU (A : U) : T (ty A).
Proof.
eapply FIso. Focus 2. eapply Iso.Sym. apply finChar.
apply fin.
Qed.

Definition iso {A : Type} (fin : T A) : Iso.T A (Fin.t (card fin)).
Proof.
induction fin.
-  apply (finChar U0).
- apply Iso.Sym. eapply Iso.Trans.
  apply finIso. simpl. apply Iso.PlusCong. apply Iso.Refl.
  eapply Iso.Trans. eapply Iso.Sym. apply finIso. apply Iso.Sym.
  assumption.
- eapply Iso.Trans. eapply Iso.Sym. eassumption.
  assumption.
Qed.

Definition true : T True := finU U1.

Definition plus {A B : Type} (fa : T A) (fb : T B) : T (A + B).
Proof.
eapply (@FIso (Fin.t (card fa + card fb))). apply (finU (UFint _)).
eapply Iso.Trans. eapply Iso.Sym. apply finPlus.
eapply Iso.PlusCong; eapply Iso.Sym; apply iso.
Qed.

Lemma finiteSig {A : Type} (fa : T A)
  : forall {B : A -> Type},
  (forall (x : A), T (B x))
  -> sigT (fun S => (T S * Iso.T (sigT B) S)%type).
Proof.
induction fa; intros b fb.
- exists False. split. constructor. apply Iso.FSig.
- pose proof (IHfa (fun x => b (inr x)) (fun x => fb (inr x))).
  destruct X. destruct p.
  exists (b (inl I) + x)%type. constructor. apply plus. apply fb.
  assumption.
  apply Iso.PlusSig. apply (@Iso.TSig (fun x => b (inl x))).
  assumption.
- pose (Iso.Sym t).
  pose proof (IHfa (fun x => b (Iso.from t0 x))
                   (fun x => fb (Iso.from t0 x))).
  destruct X. destruct p.
  exists x. split. assumption.
  eapply Iso.Trans. Focus 2. apply t2.
  apply Iso.sigmaProp.
Defined.

(** Sigma types are closed under finiteness. *)
Theorem Sig {A : Type} {B : A -> Type}
  : T A
  -> (forall (x : A), T (B x))
  -> T (sigT B).
Proof.
intros fA fB.
pose proof (finiteSig fA fB).
destruct X. destruct p.
eapply FIso. apply t.
apply Iso.Sym. assumption.
Defined.

(** Product types are closed under finiteness. *)
Theorem times {A B : Type} : T A -> T B -> T (A * B).
Proof.
intros fa fb.
eapply FIso. Focus 2. eapply Iso.Sym. eapply Iso.sigTimes.
apply Sig. assumption. apply (fun _ => fb).
Defined.

Lemma finiteMapped {A : Type} (fa : T A)
  : forall {B : Type}, T B -> sigT (fun S => (T S * Iso.T (A -> B) S)%type).
Proof.
induction fa.
- intros. exists True. apply (true, Iso.FFunc).
- intros B fb.
  destruct (IHfa B fb).
  exists (B * x)%type.
  destruct p.
  apply (times fb t , Iso.PlusFunc Iso.TFunc t0).
- intros B1 fb.
  destruct (IHfa B1 fb).
  destruct p.
  exists x.
  split.
  assumption.
  eapply Iso.Trans.
  eapply Iso.Sym.
  apply (Iso.FuncCong t (Iso.Refl B1)).
  assumption.
Defined.

(** Functions are closed under finiteness. *)
Theorem func {A B : Type} : T A -> T B -> T (A -> B).
Proof.
intros FA FB.
pose proof (finiteMapped FA FB).
destruct X.
destruct p.
eapply FIso.
eassumption.
apply Iso.Sym.
assumption.
Defined.

(** Any finite type has decidable equality. *)
Theorem eq_dec {A : Type} : T A -> forall a b : A, {a = b} + {a <> b}.
Proof.
intros finite.
induction finite; intros; try (decide equality).
- destruct a, b.
  + destruct t, t0. auto.
  + destruct t. right. congruence.
  + destruct t. right. congruence.
  + pose proof (IHfinite a a0). destruct H; [left | right]; congruence.
- eapply Iso.eq_dec; eassumption.
Qed.

Fixpoint elementsV {A} (fin : T A) : Vector.t A (card fin) :=
  match fin in T A' return Vector.t A' (card fin) with
  | F0 => Vector.nil False
  | FS _ n => Vector.cons _ (inl I) _ (Vector.map inr (elementsV n))
  | FIso _ _ x iso => let xs := elementsV x in
     Vector.map (Iso.to iso) xs
  end.

Theorem fin_dec_subset {A} (fin : T A) {P : A -> Prop}
  : (forall a, {P a} + {~ P a}) -> T (sig P).
Proof.
generalize dependent P. induction fin; intros P decP.
- eapply FIso. apply F0.
  eapply Iso.Trans. apply Iso.iso_true_subset.
  apply Iso.subsetSelf; firstorder.
- eapply FIso. 2: eapply Iso.Sym; apply Iso.subset_sum_distr.
  destruct (decP (inl I)).
  + eapply FIso. Focus 2.
    eapply Iso.PlusCong. apply (Iso.subsetSelf (fun _ => True)); intros; auto.
    destruct a. tauto. destruct p0, q. reflexivity.
    apply proof_irrelevance. apply Iso.Refl.
    eapply FIso. Focus 2. eapply Iso.PlusCong.
    apply Iso.iso_true_subset. apply Iso.Refl.
    apply FS. apply IHfin. intros. apply decP.
  + eapply FIso. Focus 2.
    eapply Iso.PlusCong. apply (Iso.subsetSelf (fun _ => False)); intros; auto.
    destruct a. tauto. contradiction. destruct b. congruence.
    apply Iso.Refl. eapply FIso. Focus 2. eapply Iso.PlusCong.
    apply Iso.iso_false_subset. apply Iso.Refl.
    eapply FIso. Focus 2.
    eapply Iso.Trans. Focus 2. apply Iso.PlusComm.
    apply botNull. apply IHfin. intros; apply decP.
- eapply FIso. apply (IHfin (fun a => P (Iso.to t a))).
  intros. apply decP. apply Iso.subset with t; firstorder.
  rewrite Iso.to_from. assumption. apply proof_irrelevance.
  apply proof_irrelevance.
Defined.


Fixpoint Fin n : Type :=
  match n with
  | 0 => Empty_set
  | S m => unit + Fin m
  end.

Fixpoint nat_of_Fin {n} : Fin n -> nat :=
  match n with
  | 0 => fun e =>
    match e with
    end
  | S m => fun i =>
    match i with
    | inl _ => 0
    | inr j => S (nat_of_Fin j)
    end
  end.

(* TODO: change option to have better names*)
Fixpoint avoid {n} : Fin (S n) -> Fin (S n) ->
  option (Fin n) :=
  match n with
  | 0 => fun _ _ => None
  | S m => fun i j  =>
    match i with
    | inl _ =>
      match j with
      | inl _ => None
      | inr j' => Some j'
      end
    | inr i' =>
      match j with
      | inl _ => Some (inl tt)
      | inr j' =>
        match avoid i' j' with
        | Some k => Some (inr k)
        | None => None
        end
      end
    end
  end.

Lemma avoid_refl : forall n (i : Fin (S n)),
  avoid i i = None.
Proof.
  induction n; intro.
  - reflexivity.
  - destruct i.
    + reflexivity.
    + simpl.
      rewrite IHn.
      reflexivity.
Qed.

Fixpoint shift {n} : Fin (S n) -> Fin n -> Fin (S n) :=
  match n with
  | 0 => fun _ e =>
    match e with
    end
  | S m => fun k i =>
    match k with
    | inl _ => inr i
    | inr k' =>
      match i with
      | inl _ => inl tt
      | inr i' => inr (shift k' i')
      end
    end
  end.

Lemma avoid_shift {n} (i : Fin (S n))
  (j : Fin n) : avoid i (shift i j) = Some j.
Proof.
  induction n.
  - destruct j.
  - simpl.
    destruct i.
    + reflexivity.
    + destruct j.
      * destruct u; reflexivity.
      * now rewrite IHn.
Qed.

Fixpoint Fin_of_nat {m} (n : nat) : Fin (n + S m) :=
  match n with
  | 0 => inl tt
  | S k => inr (Fin_of_nat k)
  end.


Require Import "misc".

Theorem sig_extract_ok :
  forall (A:Set) (P:A -> Prop) (y:sig P), P (sig_extract A P y).
  intros.
  destruct y.
  auto.
Defined.

Require Import ZArith.
Print lt_dec.
Open Scope Z_scope.

Parameter
  div_pair :
    forall a b:Z,
      0 < b ->
      {p : Z * Z | a = fst p * b + snd p  /\ 0 <= snd p < b}.

Definition div : forall a b:Z,
    0 < b -> Z * Z.
  intros.
  apply (div_pair a b).
  auto.
Defined.

Close Scope Z_scope.

Definition sig_rec_simple (A:Set) (P: A -> Prop) (B : Set) :
  (forall x, P x -> B) -> (sig P) -> B.
  intros.
  destruct H0.
  eauto.
Defined.

Definition eqdec (A : Set) := forall a b : A, {a = b} + {a <> b}.

Definition nat_eq_dec : eqdec nat.
  unfold eqdec.
  induction a,b;auto with arith.
Defined.

Definition nat_3_rect :
  forall P : nat -> Type,
    P O ->
      P 1 ->
        P 2 ->
          (forall n, P n -> P (S (S (S n)))) ->
            forall n, P n.
  intros.
  assert(3 > 0).
  omega.
  apply (nat_n_rect (exist _ 3 H));simpl.
  intros.
  do 4(
    destruct m;
    omega||auto).
  intros.
  rewrite plus_comm.
  simpl.
  auto.
Defined.

Definition nat_2_rect :
  forall P : nat -> Type,
    P O ->
      P 1 ->
        (forall n, P n -> P (S (S n))) ->
          forall n, P n.
  intros.
  assert(2 > 0).
  omega.
  apply(nat_n_rect (exist _ 2 H));simpl.
  intros.
  do 3(
    destruct m;
    (omega||auto)).
  intros.
  rewrite plus_comm.
  simpl.
  auto.
Defined.

Definition nat_4_rect :
  forall P : nat -> Type,
    P O ->
      P 1 ->
        P 2 ->
          P 3 ->
            (forall n, P n -> P (S(S (S (S n))))) ->
              forall n, P n.
  intros.
  assert(4 > 0).
  omega.
  apply (nat_n_rect (exist _ 4 H));simpl.
  intros.
  do 5(
    destruct m;
    omega||auto).
  intros.
  rewrite plus_comm.
  simpl.
  auto.
Defined.

Definition div3 (n : nat) : { r : nat | r * 3 <= n < r * 3 + 3 }.
  induction n using nat_3_rect;
  try(
    econstructor;
    instantiate( 1 := 0 );
    omega).
  destruct IHn.
  econstructor.
  instantiate( 1 := x + 1 ).
  omega.
Defined.

Fixpoint div2 (n:nat) : nat :=
  match n with
  | 0 => 0
  | 1 => 0
  | S (S p) => S (div2 p)
  end.

Definition mod2 (n : nat) : { m : nat | n = (div2 n) + m }.
  induction n using nat_2_rect.
  repeat econstructor.
  repeat econstructor.
  destruct IHn.
  simpl.
  eapply (exist _).
  instantiate( 1 := x + 1 ).
  omega.
Qed.

Fixpoint fib(n : nat) : nat :=
  match n with
  | O => 1
  | S n' =>
      match n' with
      | O => 1
      | S n'' => (fib n') + (fib n'')
      end
  end.

Fixpoint fib_pair (n:nat) : nat * nat :=
  match n with
  | O => (1, 1)
  | S p => match fib_pair p with
           | (x, y) => (y, x + y)
           end
  end.

Definition linear_fib (n:nat) := fst (fib_pair n).

Lemma fib_pair_correct : forall n:nat, fib_pair n = (fib n, fib (S n)).
  induction n.
  auto.
  simpl.
  rewrite IHn.
  f_equal.
  destruct n.
  auto.
  rewrite <- plus_assoc.
  f_equal.
  simpl.
  omega.
Qed.

Goal forall n, fib n = linear_fib n.
  unfold linear_fib.
  intros.
  rewrite fib_pair_correct.
  auto.
Qed.

Goal forall n, (sig_extract _ _ (div3 n)) <= n.
  intros.
  remember(div3 n).
  destruct s.
  simpl.
  omega.
Qed.

Theorem div3_3 : (sig_extract _ _ (div3 3)) = 1.
  unfold sig_extract.
  remember (div3 3).
  destruct s.
  repeat(omega||destruct x).
Qed.

Theorem div3_S : forall n, (sig_extract _ _ (div3 (S (S (S n))))) = S (sig_extract _ _ (div3 n)).
  intros.
  remember(div3 (S (S (S n)))).
  remember(div3 n).
  destruct s.
  destruct s0.
  induction n using nat_3_rect;
  simpl;
  omega.
Qed.

Definition mod3 (n : nat) : { m : nat | n = (sig_extract _ _ (div3 n)) + m }.
  induction n using nat_3_rect;
  try destruct IHn;
  repeat econstructor.
  rewrite div3_S.
  instantiate(1 := x + 2).
  omega.
Defined.

Definition div2_mod2 :
  forall n:nat, {q:nat & {r:nat | n = 2*q + r /\ r <= 1}}.
  intros.
  induction n using nat_2_rect.
  econstructor.
  econstructor.
  instantiate( 1 := 0 ).
  instantiate( 1 := 0 ).
  omega.
  econstructor.
  econstructor.
  instantiate( 1 := 1 ).
  instantiate( 1 := 0 ).
  omega.
  destruct IHn.
  destruct s.
  destruct a.
  econstructor.
  econstructor.
  instantiate( 1 := x0 ).
  instantiate( 1 := x + 1 ).
  omega.
Qed.

Fixpoint plus' (n m:nat){struct m} : nat :=
  match m with
  | O => n
  | S p => S (plus' n p)
  end.

Theorem plus'_O_n : forall n, plus' 0 n = n.
  intros.
  induction n;
  simpl;
  auto.
Qed.

Hint Resolve plus'_O_n.

Theorem plus'_assoc : forall n m p : nat, plus' n (plus' m p) = plus' (plus' n m) p.
  assert(forall n m, plus' (S m) n = S (plus' m n)).
  intros.
  induction n;
  simpl;
  auto.
  intros.
  induction m;
  simpl;
  auto.
  rewrite H.
  simpl.
  rewrite IHm.
  auto.
Qed.

Fixpoint plus'' (n m:nat) {struct m} : nat :=
  match m with 0 =>  n
      | S p => plus'' (S n) p
  end.

Theorem plus''_Sn_m m : forall n, plus'' (S n) m = S (plus'' n m).
  induction m.
  simpl;
  auto.
  intros.
  apply IHm.
Qed.

Hint Resolve plus''_Sn_m plus'_assoc.

Goal forall n m p : nat, plus'' n (plus'' m p) = plus'' (plus'' n m) p.
  assert(forall n m, plus'' n m = plus' n m).
  intros.
  induction m.
  auto.
  simpl.
  rewrite <- IHm.
  auto.
  intros.
  repeat rewrite H.
  auto.
Qed.


Require Import List Permutation Factorial Arith.
Require Import Lia Setoid.
Import ListNotations.

(* see also:
  - https://github.com/clucas26e4/List_Permutation
  - https://github.com/math-comp/math-comp/blob/master/mathcomp/ssreflect/seq.v#L4326
*)

(* TODO: remove when https://github.com/coq/coq/pull/17082 is released *)
Section flat_map.
Lemma concat_length A l:
  length (concat l) = list_sum (map (@length A) l).
Proof.
  induction l; [reflexivity|].
  simpl. rewrite app_length.
  f_equal. assumption.
Qed.

Lemma flat_map_length A B (f: A -> list B) l:
  length (flat_map f l) = list_sum (map (fun x => length (f x)) l).
Proof.
  rewrite flat_map_concat_map, concat_length, map_map. reflexivity.
Qed.

Corollary flat_map_constant_length A B c (f: A -> list B) l:
  (forall x, In x l -> length (f x) = c) -> length (flat_map f l) = (length l) * c.
Proof.
  intro H. rewrite flat_map_length.
  induction l; [reflexivity|].
  simpl. rewrite IHl, H.
  - reflexivity.
  - left. reflexivity.
  - intros x Hx. apply H. right. assumption.
Qed.

Lemma notin_app {A} a (l1 l2 : list A):
  ~ In a l1 -> ~ In a l2 -> ~ In a (l1 ++ l2).
Proof.
  intros H1 H2. induction l1 as [|b l1 IHl1].
  - exact H2.
  - cbn. intros [].
    + apply H1. subst a. apply in_eq.
    + apply not_in_cons in H1 as [].
      apply IHl1; assumption.
Qed.

Lemma NoDup_app [A] (l1 l2 : list A):
  NoDup l1 -> NoDup l2 -> (forall a, In a l1 -> ~ In a l2) ->
  NoDup (l1 ++ l2).
Proof.
  intros H1 H2 H. induction l1 as [|a l1 IHl1]; [assumption|].
  apply NoDup_cons_iff in H1 as [].
  cbn. constructor.
  - apply notin_app; [assumption|apply H, in_eq].
  - apply IHl1; [assumption|].
    intros. apply H. right. assumption.
Qed.

End flat_map.

Lemma In_singleton [A : Type] (x y : A):
  In x [y] <-> y = x.
Proof.
  split; intro H.
  - destruct H; [assumption | contradiction H].
  - subst y. constructor. reflexivity.
Qed.

Section factorials.
Fixpoint falling_fact n x :=
match n, x with
| 0, _ => 1
| _, 0 => 0
| S n', S x' => x * falling_fact n' x'
end.

Fixpoint rising_fact n x :=
match n with
| 0 => 1
| S n' => x * rising_fact n' (S x)
end.

Lemma falling_fact_fact n: falling_fact n n = fact n.
Proof.
  induction n; [reflexivity|simpl].
  rewrite IHn. reflexivity.
Qed.

Lemma rising_fact_S n x:
  rising_fact (S n) x = (x + n) * rising_fact n x.
Proof.
  revert x. induction n; intros x.
  - cbn. auto.
  - remember (S n) as m. (* to avoid zealous cbn *)
    cbn. rewrite IHn by auto.
    subst m. cbn. lia. (* ??? *)
Qed.

Lemma falling_raising_fact n x:
  n <= S x -> falling_fact n x = rising_fact n (S x-n).
Proof.
  revert x. induction n.
  - reflexivity.
  - intros x H%le_S_n. rewrite rising_fact_S. destruct x.
    + cbn. lia.
    + cbn [falling_fact]. rewrite IHn by assumption.
      replace (S (S x) - S n) with (S x - n) by lia.
      rewrite Nat.sub_add by assumption. reflexivity.
Qed.

Lemma rising_fact_fact n: rising_fact n 1 = fact n.
Proof.
  induction n; [ reflexivity | ].
  rewrite rising_fact_S, IHn; constructor.
Qed.
End factorials.

Section permutations.
Variable A : Type.
Implicit Type l : list A.

Definition insert_at i x l :=
  firstn i l ++ [x] ++ skipn i l.

Lemma Add_nil x l:
  Add x [] l <-> l = [x].
Proof.
  split; intro H.
  - remember [] as l'. destruct H.
    + reflexivity.
    + discriminate Heql'.
  - rewrite H. constructor.
Qed.

Lemma insert_at_length i x l:
  length (insert_at i x l) = S (length l).
Proof.
  unfold insert_at. autorewrite with list. cbn.
  enough (length (firstn i l) + length (skipn i l) = length l) by lia.
  rewrite <- app_length, firstn_skipn. reflexivity.
Qed.

Lemma insert_at_cons i x l a:
  insert_at (S i) x (a :: l) = a :: insert_at i x l.
Proof. cbn. f_equal. Qed.

Lemma Add_insert_at x l:
  forall l', Add x l l' <-> exists i, i <= length l /\ l' = insert_at i x l.
Proof.
  intro l'. split; intro H.
  - induction H.
    + exists 0. split; [apply Nat.le_0_l | reflexivity].
    + destruct IHAdd as [i [Hi ->]]. exists (S i). split.
      * cbn. apply le_n_S. assumption.
      * cbn. f_equal.
  - destruct H as [i [Hi H]].
    revert Hi H. revert l l'. induction i; intros l l' Hi H.
    + rewrite H. constructor.
    + destruct l.
      * exfalso. eapply Nat.nle_succ_0. exact Hi.
      * rewrite H, insert_at_cons. constructor.
        apply IHi; [ | reflexivity]. apply le_S_n. assumption.
Qed.

Definition additions x l :=
  map (fun i => insert_at i x l) (seq 0 (S (length l))).

Lemma in_additions x l l':
  In l' (additions x l) <-> exists i, i <= length l /\ l' = insert_at i x l.
Proof.
  split; intro H.
  - apply in_map_iff in H as [i [H0 H1]]. exists i.
    apply in_seq in H1 as [_ H1]. split.
    + apply le_S_n. exact H1.
    + symmetry. exact H0.
  - apply in_map_iff. destruct H as [i [H1 H0]].
    exists i. split.
    + symmetry. exact H0.
    + apply in_seq. split.
      * apply Nat.le_0_l.
      * apply le_n_S. exact H1.
Qed.

Corollary additions_spec x:
  forall (l l': list A), Add x l l' <-> In l' (additions x l).
Proof. intros l l'. rewrite Add_insert_at, in_additions. reflexivity. Qed.

Lemma seq_shift_n len start n:
  map (Nat.add n) (seq start len) = seq (n + start) len.
Proof.
  induction n.
  - now rewrite map_id.
  - cbn. now rewrite <- map_map, IHn, seq_shift.
Qed.

Lemma map_ext_seq {X} (f g: nat -> X) n start d:
  (forall j, start <= j < start + n -> f (d + j) = g j) ->
  map f (seq (start + d) n) = map g (seq start n).
Proof.
  intro H. rewrite Nat.add_comm, <- seq_shift_n.
  rewrite map_map. apply map_ext_in.
  intros j ?%in_seq. apply H. assumption.
Qed.

Lemma additions_cons x a l:
  additions x (a :: l) = (x::a::l)::map (cons a) (additions x l).
Proof.
  cbn. f_equal. f_equal. rewrite map_map.
  replace 2 with (1 + 1) by reflexivity.
  apply map_ext_seq. reflexivity.
Qed.

Lemma additions_length x l:
  length (additions x l) = S (length l).
Proof. unfold additions. now rewrite map_length, seq_length. Qed.

Fixpoint permutations l :=
match l with
| nil => [ nil ]
| x::l' => flat_map (additions x) (permutations l')
end.

Lemma permutations_refl l:
  In l (permutations l).
Proof.
  induction l; [now left|].
  cbn. apply in_flat_map. exists l.
  split; [assumption | now left].
Qed.

Lemma permutations_spec:
  forall l l', Permutation l l' <-> In l' (permutations l).
Proof.
  intros l l'. split; intro H.
  - revert H. revert l'. induction l; intros l' H.
    + apply Permutation_nil in H as ->. apply permutations_refl.
    + cbn. apply in_flat_map. symmetry in H.
      destruct (Permutation_vs_elt_inv nil _ _ H) as [l1 [l2 ->]].
      exists (l1 ++ l2); split.
      * apply IHl. apply Permutation_cons_app_inv with (a:=a).
        symmetry. assumption.
      * apply additions_spec, Add_app.
  - revert H. revert l'. induction l; intros l' H.
    + apply In_singleton in H as <-. constructor.
    + cbn in H. apply in_flat_map in H as [l'' [Hl'' H%additions_spec]].
      specialize (IHl _ Hl''). rewrite IHl. apply Permutation_Add. assumption.
Qed.

Theorem permutations_fact l:
  length (permutations l) = fact (length l).
Proof.
  induction l.
  - reflexivity.
  - cbn. rewrite flat_map_constant_length with (c := S (length l)); [lia|].
    intros x Hx%permutations_spec. rewrite additions_length.
    f_equal. apply Permutation_length. symmetry. assumption.
Qed.

Theorem permutations_NoDup l:
  NoDup l -> NoDup (permutations l).
Proof.
  intros H. induction H.
  - constructor; [apply in_nil|constructor].
  - cbn. rewrite flat_map_concat_map.
Abort.

End permutations.


From mathcomp Require Import all_ssreflect.

(* move/ の使用例 *)

(* move *)
Goal forall (P Q R : Prop),
    (P -> Q) -> (Q -> R) -> (P -> R).
Proof.
  move=> P Q R V1 V2.
  move/V1/V2.
  done.
Qed.

(* move *)
Goal forall (P Q R : Prop),
    (P -> Q) -> (Q -> R) -> (P -> R).
Proof.
  move=> P Q R V1 V2.
  move/V1/V2.
  done.
Qed.

Goal forall (P Q R : Prop),
    (P -> Q) -> (Q -> R) -> (P -> R).
Proof.
  move=> P Q R V1 V2 HP.
  move: (V1 HP).
  done.
Qed.

Goal forall (P Q R : Prop),
    (P -> Q) -> (Q -> R) -> (P -> R).
Proof.
  move=> P Q R V1 V2 HP.
  move/V1/V2 in HP.
  done.
Qed.

(* vanilla Coq *)
Goal forall (P Q R : Prop),
    (P -> Q) -> (Q -> R) -> (P -> R).
Proof.
  intros P Q R V1 V2 HP.
  apply V1,V2 in HP.
  exact HP.
Qed.


Require Export P03.

(** **** Exercise: 2 stars (hoare_asgn_example4)  *)
(** Translate this "decorated program" into a formal proof:
                   {{ True }} ->>
                   {{ 1 = 1 }}
    X ::= 1;;
                   {{ X = 1 }} ->>
                   {{ X = 1 /\ 2 = 2 }}
    Y ::= 2
                   {{ X = 1 /\ Y = 2 }}
*)

Example hoare_asgn_example4 :
  {{fun st => True}} (X ::= (ANum 1);; Y ::= (ANum 2))
  {{fun st => st X = 1 /\ st Y = 2}}.
Proof.
  apply hoare_seq with (Q:= (fun st => st X = 1)); unfold hoare_triple; intros.
  inversion H; subst. simpl. split.
  rewrite<-H0. reflexivity.
  reflexivity.
  unfold hoare_triple; intros.
  inversion H; subst. reflexivity.
Qed.


From Nominal Require Export Prelude.

(** *Group operations *)
Class Neutral A := neutral: A.
#[export] Hint Mode Neutral ! : typeclass_instances.
Notation ɛ := neutral.
Notation "ɛ@{ A }" := (@neutral A _) (only parsing): nominal_scope.

Class Operator A := op: A → A → A.
#[export] Hint Mode Operator ! : typeclass_instances.
#[export] Instance: Params (@op) 2 := {}.

Infix "+" := op: nominal_scope.
Notation "(+)" := op (only parsing): nominal_scope.
Notation "(+ x )" := (op x) (only parsing): nominal_scope.
Notation "( x +)" := (λ y, op y x) (only parsing): nominal_scope.

Class Inverse A := inv: A → A.
#[export] Hint Mode Inverse ! : typeclass_instances.
#[export] Instance: Params (@inv) 1 := {}.

Notation "- x" := (inv x): nominal_scope.
Notation "(-)" := inv (only parsing): nominal_scope.
Notation "x - y" := (x + (-y))%nom: nominal_scope.

Class Group (A : Type) `{Ntr: Neutral A, Opr: Operator A, Inv: Inverse A, Equiv A}: Prop := {
  grp_setoid :> Equivalence(≡@{A});
  grp_op_proper :> Proper ((≡@{A}) ⟹ (≡@{A}) ⟹ (≡@{A})) (+);
  grp_inv_proper :> Proper ((≡@{A}) ⟹ (≡@{A})) (-);

  grp_assoc : ∀ (x y z : A), x + (y + z) ≡@{A} (x + y) + z;

  grp_left_id : ∀ (x : A), ɛ@{A} + x ≡@{A} x;
  grp_right_id : ∀ (x : A), x + ɛ@{A} ≡@{A} x;

  grp_left_inv : ∀ (x : A), (-x) + x ≡@{A} ɛ@{A};
  grp_right_inv : ∀ (x : A), x - x ≡@{A} ɛ@{A};
}.
(* #[global] Hint Mode Group ! - - - -: typeclass_instances. *)

Arguments grp_assoc {_ _ _ _ _ Grp}: rename.
Arguments grp_left_id {_ _ _ _ _ Grp}: rename.
Arguments grp_right_id {_ _ _ _ _ Grp}: rename.
Arguments grp_left_inv {_ _ _ _ _ Grp}: rename.
Arguments grp_right_inv {_ _ _ _ _ Grp}: rename.
Arguments grp_op_proper {_ _ _ _ _ Grp}: rename.
Arguments grp_inv_proper {_ _ _ _ _ Grp}: rename.

Section Properties.
Context `{Group G}.

Lemma grp_inv_involutive (x: G): -(-x) ≡ x.
    Proof with auto.
      rewrite <-(grp_left_id x) at 2;
       rewrite <-grp_left_inv, <-grp_assoc, grp_left_inv, grp_right_id...
    Qed.

    Corollary grp_inv_neutral: -ɛ ≡@{G} ɛ.
    Proof with auto.
      rewrite <-grp_left_inv at 1; rewrite grp_right_id, grp_inv_involutive...
    Qed.

    Corollary grp_inv_inj (x y: G): x ≡ y → (-x) ≡ (-y).
    Proof. apply grp_inv_proper. Qed.

    Corollary grp_inj1 (x y z: G): x ≡ y → z + x ≡ z + y.
    Proof. intros HH; rewrite HH; auto. Qed.

    Corollary grp_inj (x y z: G): x + y ≡ x + z → y ≡ z.
    Proof. intros HH; apply grp_inj1 with (z := -x) in HH;
      rewrite !grp_assoc,grp_left_inv,!grp_left_id in HH; assumption.
    Qed.

    Lemma perm_op_inv (x y: G): -(x + y) ≡ -y - x.
    Proof.
      assert (L1: (x + y) + (-(x + y)) ≡ ɛ).
      { apply grp_right_inv. }
      assert (L2: x + y + (- y - x) ≡ x + (y - y) - x). { rewrite !grp_assoc; reflexivity. }
      assert (L3: (x + y) + (-y - x) ≡ ɛ).
      { rewrite L2, grp_right_inv, grp_right_id; apply grp_right_inv. } clear L2.
      apply grp_inj with (x := x + y); rewrite L1,L3; reflexivity.
    Qed.
End Properties.


Require Export D.

(* Subtask 1 *)

Theorem double_negation_excluded_middle : 이중부정 -> 배중률.
Proof.
  (* FILL IN HERE *)
  intros NNPP P. apply NNPP. intros Hc.
  eassert (~P) by (intros HP; destruct (Hc (@or_introl P (~P) HP))).
  destruct (Hc (@or_intror P (~P) H)).
Qed.

(* Natural Excluded Middle *)
Inductive nat_value :=
| Add : nat_value -> nat_value -> nat_value
| Mul : nat_value -> nat_value -> nat_value
| Var : nat -> nat_value
.

Inductive nat_prop :=
| And : nat_prop -> nat_prop -> nat_prop
| Or : nat_prop -> nat_prop -> nat_prop
| Implies : nat_prop -> nat_prop -> nat_prop
| Not : nat_prop -> nat_prop
| Forall : nat -> nat -> nat_prop -> nat_prop
| Exists : nat -> nat -> nat_prop -> nat_prop
| Eq : nat_value -> nat_value -> nat_prop
| Le : nat_value -> nat_value -> nat_prop
.

Fixpoint nv_to_nat (nv : nat_value) (env : nat -> nat) : nat :=
  match nv with
  | Add nv1 nv2 => (nv_to_nat nv1 env) + (nv_to_nat nv2 env)
  | Mul nv1 nv2 => (nv_to_nat nv1 env) * (nv_to_nat nv2 env)
  | Var v => env v
  end
.

Fixpoint np_to_prop (np : nat_prop) (env : nat -> nat) : Prop :=
  match np with
  | And np1 np2 => (np_to_prop np1 env) /\ (np_to_prop np2 env)
  | Or np1 np2 => (np_to_prop np1 env) \/ (np_to_prop np2 env)
  | Implies np1 np2 => (np_to_prop np1 env) -> (np_to_prop np2 env)
  | Not np' => ~(np_to_prop np' env)
  | Forall x l np' =>
    forall y, y < (env l) -> (np_to_prop np' (
      fun n => if Nat.eqb n x then y else env n
    ))
  | Exists x l np' =>
    exists y, y < (env l) /\ (np_to_prop np' (
      fun n => if Nat.eqb n x then y else env n
    ))
  | Eq nv1 nv2 => (nv_to_nat nv1 env) = (nv_to_nat nv2 env)
  | Le nv1 nv2 => (nv_to_nat nv1 env) <= (nv_to_nat nv2 env)
  end
.

Lemma excluded_middle_np : forall (np : nat_prop) (env : nat -> nat),
  (np_to_prop np env) \/ ~(np_to_prop np env).
Proof.
  induction np; intros.
  + destruct (IHnp1 env); destruct (IHnp2 env); try (
      right; simpl; intros [Hl Hr]; eauto; fail
    ). left. simpl; split; eauto.
  + destruct (IHnp1 env); destruct (IHnp2 env); try (
      left; simpl; eauto; fail
    ). right. simpl; intros [Hl | Hr]; eauto.
  + destruct (IHnp2 env); try (left; simpl; intros; eauto; fail).
    destruct (IHnp1 env).
    - right; simpl. intro Hc. destruct (H (Hc H0)).
    - left; simpl. intros. destruct (H0 H1).
  + destruct (IHnp env); eauto.
  + simpl. remember (env n0) as lim; clear Heqlim. induction lim.
    - left; intros. inv H.
    - specialize (IHnp (fun n0 => if Nat.eqb n0 n then lim else env n0)).
      destruct IHlim; destruct IHnp.
      * left; intros. inv H1; eauto.
      * right; intros Hc. apply H0; apply Hc; eauto.
      * right; intros Hc. apply H; intros. apply Hc; eauto.
      * right; intros Hc. apply H; intros. apply Hc; eauto.
  + simpl. remember (env n0) as lim; clear Heqlim. induction lim.
    - right; intros [y [Hy _]]. inv Hy.
    - specialize (IHnp (fun n0 => if Nat.eqb n0 n then lim else env n0)).
      destruct IHlim; destruct IHnp.
      * left. destruct H as [y [Hylt Heqy]]. exists y; split; eauto.
      * left. destruct H as [y [Hylt Heqy]]. exists y; split; eauto.
      * left. exists lim; eauto.
      * right. intros [y [Hylt Heqy]]. inv Hylt; eauto.
  + simpl.
    remember (nv_to_nat n env) as x. remember (nv_to_nat n0 env) as y.
    clear; destruct (Nat.eqb x y) eqn: EQ.
    - left. apply eqb_refl; eauto.
    - right. intros Hc. apply eqb_refl in Hc.
      rewrite Hc in EQ. inv EQ.
  + simpl.
    remember (nv_to_nat n env) as x. remember (nv_to_nat n0 env) as y.
    clear; destruct (Nat.leb x y) eqn: EQ.
    - left. apply leb_refl; eauto.
    - right. intros Hc. apply leb_refl in Hc.
      rewrite Hc in EQ. inv EQ.
Qed.

(* Subtask 2 *)

Theorem excluded_middle_square : 제곱수 는 극단적이야! .
Proof.
  (* FILL IN HERE *)
  intros x. unfold 제곱수.
  destruct (excluded_middle_np (
    Exists 2 1 (Eq (Mul (Var 2) (Var 2)) (Var 0))
  ) (fun n => match n with 0 => x | _ => S x end)); simpl in *;
  try destruct H as [y [Hylt Heqy]]; eauto.
  right. intros Hc. destruct Hc as [y Hy]. apply H; exists y; split; eauto.
  clear H. apply le_prog. subst. destruct y; eauto.
  replace (S y * S y) with (S y + y * S y) by simpl_arith.
  remember (S y) as x; remember (y * x) as z; clear.
  rewrite add_comm. induction z; simpl; eauto.
Qed.

(* Subtask 3 *)

Theorem excluded_middle_prime : 소수 는 극단적이야! .
Proof.
  (* FILL IN HERE *)
  intros x. unfold 소수. unfold divides.
  destruct (excluded_middle_np (
    And (Le (Var 2) (Var 0)) (Forall 1 0 (Implies (Le (Var 2) (Var 1)) (
      Not (Exists 3 0 (Eq (Var 0) (Mul (Var 1) (Var 3))))
    )))
  ) (fun n => match n with 0 => x | _ => 2 end)); simpl in *.
  + left. destruct H; split; eauto. intros x0 [Hx0gt Hx0lt].
    intros [x1 Heqx1]. specialize (H0 x0 Hx0lt Hx0gt). apply H0.
    exists x1; split; eauto. destruct x0; try destruct x0; try le_contra.
    destruct x1; try (subst; simpl_arith; inv Hx0lt; fail).
    subst. simpl_arith. repeat apply le_prog. clear.
    replace (x1 + x1 + x0 + x0 * x1) with (
      x1 + (x1 + x0 + x0 * x1)
    ) by simpl_arith. remember (x1 + x0 + x0 * x1) as z. clear.
    rewrite add_comm. induction z; simpl; eauto.
  + right. intros [Hxgt Heqx]. apply H. split; eauto. intros.
    specialize (Heqx y (conj H1 H0)). intros Hc. apply Heqx.
    destruct Hc as [y0 [Hy01 Hy02]]. eexists; eauto.
Qed.


Require Import ct07.

Lemma inserted_sorted : forall (a0 a : nat) (l' x : list nat),
  sorted (a0 :: l') -> sorted x -> permutation x (a :: l') -> a0 < a ->
  sorted (a0 :: x).
Proof.
intros; constructor; trivial.
- apply Sorted_extends in H.
  + assert (H3 : List.Forall (le a0) (a :: l')).
    constructor. apply Nat.lt_le_incl; assumption. assumption.
    assert (H4 : List.Forall (le a0) x).
    eapply Permutation_Forall. apply Permutation_sym; exact H1. trivial.
    destruct x; auto. constructor. apply Forall_inv in H4; auto.
  + unfold Relations_1.Transitive; apply le_trans.
Defined.


Set Implicit Arguments.
Set Strict Implicit.

Section PairWF.
  Variables T U : Type.
  Variable RT : T -> T -> Prop.
  Variable RU : U -> U -> Prop.

  Inductive R_pair : T * U -> T * U -> Prop :=
  | L : forall l l' r r',
    RT l l' -> R_pair (l,r) (l',r')
  | R : forall l r r',
    RU r r' -> R_pair (l,r) (l,r').

  Hypothesis wf_RT : well_founded RT.
  Hypothesis wf_RU : well_founded RU.

  Theorem wf_R_pair : well_founded R_pair.
  Proof.
    red. intro x.
    destruct x. generalize dependent u.
    apply (well_founded_ind wf_RT (fun t => forall u : U, Acc R_pair (t, u))) .
    do 2 intro.

    apply (well_founded_ind wf_RU (fun u => Acc R_pair (x,u))). intros.
    constructor. destruct y.
    remember (t0,u). remember (x,x0). inversion 1; subst;
    inversion H4; inversion H3; clear H4 H3; subst; eauto.
  Defined.
End PairWF.

Inductive R_nat : nat -> nat -> Prop :=
| R_S : forall n, R_nat n (S n).

Theorem wf_R_nat : well_founded R_nat.
Proof.
  red; induction a; constructor; intros.
    inversion H.
    inversion H; subst; auto.
Defined.

Fixpoint guard A (R : A -> A -> Prop) (n : nat) (wfR : well_founded R)
  {struct n}: well_founded R :=
  match n with
    | 0 => wfR
    | S n => fun x => Acc_intro x (fun y _ => guard n (guard n wfR) y)
  end.


Require Import Recdef Lia ZArith.

Import Pos.

(** [Plus] to 1, [Minus] to -1, [ShiftPlus k] to 3k + 1, [ShiftMinus k] to 3k - 1,
    a [ShiftZero k] to 3k. *)
Inductive Z3' : Type :=
| Plus       : Z3'
| Minus      : Z3'
| ShiftPlus  : Z3' -> Z3'
| ShiftMinus : Z3' -> Z3'
| ShiftZero  : Z3' -> Z3'.

Inductive Z3 : Type :=
| Zero    : Z3
| Nonzero : Z3' -> Z3.

Coercion Nonzero : Z3' >-> Z3.

Definition shiftMinus (n : Z3) : Z3 :=
match n with
| Zero => Minus
| Nonzero n' => ShiftMinus n'
end.

Definition shiftPlus (n : Z3) : Z3 :=
match n with
| Zero => Plus
| Nonzero n' => ShiftPlus n'
end.

Definition shiftZero (n : Z3) : Z3 :=
match n with
| Zero => Zero
| Nonzero n' => ShiftZero n'
end.

Function neg' (n : Z3') : Z3' :=
match n with
| Plus => Minus
| Minus => Plus
| ShiftPlus n' => ShiftMinus (neg' n')
| ShiftMinus n' => ShiftPlus (neg' n')
| ShiftZero n' => ShiftZero (neg' n')
end.

Definition neg (n : Z3) : Z3 :=
match n with
| Zero => Zero
| Nonzero n' => neg' n'
end.

Function succ' (n : Z3') : Z3 :=
match n with
| Plus => ShiftMinus Plus
| Minus => Zero
| ShiftPlus n' =>
  match succ' n' with
  | Zero => Minus
  | Nonzero n'' => ShiftMinus n''
  end
| ShiftMinus n' => ShiftZero n'
| ShiftZero n' => ShiftPlus n'
end.

Definition succ (n : Z3) : Z3 :=
match n with
| Zero => Plus
| Nonzero n' => succ' n'
end.

Definition pred' (n : Z3') : Z3 :=
  neg (succ' (neg' n)).

Definition pred (n : Z3) : Z3 :=
  neg (succ (neg n)).

Function add (n m : Z3') : Z3 :=
match n with
| Plus => succ m
| Minus => pred m
| ShiftPlus n' =>
  match m with
  | Plus => succ n
  | Minus => pred n
  | ShiftPlus m' => shiftMinus (succ (add n' m'))
  | ShiftMinus m' => shiftZero (add n' m')
  | ShiftZero m' => shiftPlus (add n' m')
  end
| ShiftMinus n' =>
  match m with
  | Plus => succ n
  | Minus => pred n
  | ShiftPlus m' => shiftZero (add n' m')
  | ShiftMinus m' => shiftPlus (pred (add n' m'))
  | ShiftZero m' => shiftMinus (add n' m')
  end
| ShiftZero n' =>
  match m with
  | Plus => shiftPlus n'
  | Minus => shiftMinus n'
  | ShiftPlus m' => shiftPlus (add n' m')
  | ShiftMinus m' => shiftMinus (add n' m')
  | ShiftZero m' => shiftZero (add n' m')
  end
end.

Function add' (n m : Z3) : Z3 :=
match n, m with
| Zero, _ => m
| _, Zero => n
| Nonzero n', Nonzero m' => add n' m'
end.

Definition mul2 (n : Z3) : Z3 :=
  add' n n.

Function fromPositive (p : positive) : Z3 :=
match p with
| xH => Plus
| xI p' => succ (mul2 (fromPositive p'))
| xO p' => mul2 (fromPositive p')
end.

Function fromZ (n : Z) : Z3 :=
match n with
| Z0 => Zero
| Zpos p => fromPositive p
| Zneg p => neg (fromPositive p)
end.

Fixpoint toZ' (n : Z3') : Z :=
match n with
| Plus => 1
| Minus => -1
| ShiftPlus n' => 1 + 3 * toZ' n'
| ShiftMinus n' => -1 + 3 * toZ' n'
| ShiftZero n' => 3 * toZ' n'
end.

Definition toZ (n : Z3) : Z :=
match n with
| Zero => 0
| Nonzero n' => toZ' n'
end.

Function mul (n m : Z3') : Z3 :=
match n with
| Plus          => m
| Minus         => neg' m
| ShiftPlus n'  => add' m (shiftZero (mul n' m))
| ShiftMinus n' => add' (neg' m) (shiftZero (mul n' m))
| ShiftZero n'  => shiftZero (mul n' m)
end.

Lemma neg'_neg' :
  forall n : Z3', neg' (neg' n) = n.
Proof.
  induction n as [| | n' | n' | n']; cbn; congruence.
Qed.

Lemma neg_neg :
  forall n : Z3, neg (neg n) = n.
Proof.
  destruct n; cbn.
  - reflexivity.
  - f_equal. apply neg'_neg'.
Qed.

Lemma toZ_succ' :
  forall n : Z3', toZ (succ' n) = (1 + toZ' n)%Z.
Proof.
  induction n as [| | n' | n' | n']; cbn [succ' toZ toZ']; try lia.
  destruct (succ' n'); cbn [toZ toZ'] in *; lia.
Qed.

Lemma toZ_succ :
  forall n : Z3, toZ (succ n) = (1 + toZ n)%Z.
Proof.
  destruct n as [| n'].
  - reflexivity.
  - apply toZ_succ'.
Qed.

Lemma toZ_neg :
  forall n : Z3, toZ (neg n) = (- toZ n)%Z.
Proof.
  destruct n as [| n]; cbn.
  - reflexivity.
  - induction n as [| | n' | n' | n']; cbn [neg' toZ']; lia.
Qed.

Lemma toZ_pred :
  forall n : Z3, toZ (pred n) = (-1 + toZ n)%Z.
Proof.
  unfold pred.
  intro n.
  rewrite toZ_neg, toZ_succ, toZ_neg. lia.
Qed.

Lemma toZ_shiftMinus :
  forall n : Z3, toZ (shiftMinus n) = (-1 + 3 * toZ n)%Z.
Proof.
  destruct n as [| n']; reflexivity.
Qed.

Lemma toZ_shiftPlus :
  forall n : Z3, toZ (shiftPlus n) = (1 + 3 * toZ n)%Z.
Proof.
  destruct n as [| n']; reflexivity.
Qed.

Lemma toZ_shiftZero :
  forall n : Z3, toZ (shiftZero n) = (3 * toZ n)%Z.
Proof.
  destruct n as [| n']; reflexivity.
Qed.

Lemma toZ_add :
  forall n m : Z3', toZ (add n m) = (toZ' n + toZ' m)%Z.
Proof.
  intros.
  functional induction add n m;
  rewrite ?toZ_shiftMinus, ?toZ_shiftPlus, ?toZ_shiftZero, ?toZ_succ, ?toZ_pred
  ; cbn [toZ' toZ]; lia.
Qed.

Lemma toZ_add' :
  forall n m : Z3, toZ (add' n m) = (toZ n + toZ m)%Z.
Proof.
  destruct n as [| n'], m as [| m']; cbn [toZ add'].
  - reflexivity.
  - reflexivity.
  - lia.
  - rewrite toZ_add. reflexivity.
Qed.

Lemma toZ_mul2 :
  forall n : Z3, toZ (mul2 n) = (2 * toZ n)%Z.
Proof.
  unfold mul2.
  intros.
  rewrite toZ_add'.
  lia.
Qed.

Lemma toZ_fromPositive :
  forall p : positive, toZ (fromPositive p) = Zpos p.
Proof.
  induction p as [p' | p' |]; cbn.
  - rewrite toZ_succ, toZ_mul2, IHp'. reflexivity.
  - rewrite toZ_mul2, IHp'. reflexivity.
  - reflexivity.
Qed.

Lemma toZ_fromZ :
  forall n : Z, toZ (fromZ n) = n.
Proof.
  induction n as [| n' | n']; cbn.
  - reflexivity.
  - apply toZ_fromPositive.
  - rewrite toZ_neg, toZ_fromPositive. lia.
Qed.

Lemma toZ'_inv_Zero :
  forall n : Z3', (toZ' n = 0)%Z -> False.
Proof.
  induction n as [| | n' | n' | n']; cbn [toZ']; intros; try lia.
Qed.

Lemma toZ'_inv_Plus :
  forall n : Z3', (toZ' n = 1)%Z -> n = Plus.
Proof.
  induction n as [| | n' | n' | n']; cbn [toZ']; intros H; try lia.
  - reflexivity.
  - assert (toZ' n' = 0%Z) by lia. apply toZ'_inv_Zero in H0. contradiction.
Qed.

Lemma toZ'_inv_Minus:
  forall n : Z3', (toZ' n = -1)%Z -> n = Minus.
Proof.
  induction n as [| | n' | n' | n']; cbn [toZ']; intros; try lia.
  - reflexivity.
  - assert (toZ' n' = 0%Z) by lia. apply toZ'_inv_Zero in H0. contradiction.
Qed.

Lemma toZ_Zero :
  forall n : Z3, (toZ n = 0)%Z -> n = Zero.
Proof.
  destruct n as [| n]; cbn.
  - reflexivity.
  - intro H. apply toZ'_inv_Zero in H. contradiction.
Qed.

Lemma toZ'_inj :
  forall n m : Z3', toZ' n = toZ' m -> n = m.
Proof.
  induction n as [| | n' | n' | n']; cbn [toZ']; intros; try lia.
  - symmetry in H. apply toZ'_inv_Plus in H. congruence.
  - symmetry in H. apply toZ'_inv_Minus in H. congruence.
  - destruct m; cbn [toZ'] in *; try lia.
    + assert (toZ' n' = 0%Z) by lia. apply toZ'_inv_Zero in H0. contradiction.
    + f_equal. apply IHn'. lia.
  - destruct m; cbn [toZ'] in *; try lia.
    + assert (toZ' n' = 0%Z) by lia. apply toZ'_inv_Zero in H0. contradiction.
    + f_equal. apply IHn'. lia.
  - destruct m; cbn [toZ'] in *; try lia.
    f_equal. apply IHn'. lia.
Qed.

Lemma toZ_inj :
  forall n m : Z3, toZ n = toZ m -> n = m.
Proof.
  destruct n as [| n], m as [| m]; cbn; intros.
  - reflexivity.
  - symmetry in H. apply toZ'_inv_Zero in H. contradiction.
  - apply toZ'_inv_Zero in H. contradiction.
  - apply toZ'_inj in H. inversion H. reflexivity.
Qed.

Lemma fromZ_toZ :
  forall n : Z3, fromZ (toZ n) = n.
Proof.
  intros.
  apply toZ_inj, toZ_fromZ.
Qed.

Lemma add_Plus_r :
  forall k : Z3', add k Plus = succ k.
Proof.
  destruct k; cbn; reflexivity.
Qed.

Lemma add_Minus_r :
  forall k : Z3', add k Minus = pred k.
Proof.
  destruct k; cbn; rewrite ?neg'_neg'; reflexivity.
Qed.

Lemma add_comm :
  forall k1 k2 : Z3',
    add k1 k2 = add k2 k1.
Proof.
  intros k1 k2; functional induction add k1 k2
  ; cbn; rewrite ?IHz; try reflexivity.
  - rewrite add_Plus_r; reflexivity.
  - rewrite add_Minus_r; reflexivity.
  - rewrite neg'_neg'; reflexivity.
Restart.
  intros k1 k2.
  rewrite <- fromZ_toZ, toZ_add, <- Z.add_comm, <- toZ_add, fromZ_toZ.
  reflexivity.
Qed.

Lemma add'_comm :
  forall k1 k2 : Z3,
    add' k1 k2 = add' k2 k1.
Proof.
  intros k1 k2.
  rewrite <- fromZ_toZ, toZ_add', <- Z.add_comm, <- toZ_add', fromZ_toZ.
  reflexivity.
Qed.

Lemma add_assoc :
  forall k1 k2 k3 : Z3',
    add' (add' k1 k2) k3 = add' k1 (add' k2 k3).
Proof.
  intros k1 k2 k3.
  rewrite <- fromZ_toZ, !toZ_add', <- Z.add_assoc, <- !toZ_add', fromZ_toZ at 1.
  reflexivity.
Qed.


Require Import Undecidability.Shared.Libs.PSL.Base Lia.
(* Nats smaller than n *)

Fixpoint natsLess n : list nat :=
  match n with
    0 => []
  | S n => n :: natsLess n
  end.

Lemma natsLess_in_iff n m:
  n el natsLess m <-> n < m.
Proof.
  induction m in n|-*;cbn. lia.
  split.
  -intuition. destruct n;intuition. apply IHm in H0. lia.
  -intros. decide (m=n). intuition. right. apply IHm. lia.
Qed.

Lemma natsLess_S n :
  natsLess (S n) = map S (natsLess n)++[0].
Proof.
  induction n;cbn in *;congruence.
Qed.

(* Sum *)

Fixpoint sumn (A:list nat) :=
  match A with
    [] => 0
  | a::A => a + sumn A
  end.

Lemma sumn_app A B : sumn (A++B) = sumn A + sumn B.
Proof.
  induction A;cbn;lia.
Qed.

Hint Rewrite sumn_app : list.

Lemma length_concat X (A : list (list X)) :
  length (concat A) = sumn (map (@length _) A).
  induction A;cbn. reflexivity. autorewrite with list in *. lia.
Qed.

Lemma sumn_rev A :
  sumn A = sumn (rev A).
Proof.
  enough (H:forall B, sumn A + sumn B = sumn (rev A++B)).
  {specialize (H []). cbn in H. autorewrite with list in H. cbn in H. lia. }
  induction A as [|a A];intros B. reflexivity.
  cbn in *. specialize (IHA (a::B)). autorewrite with list in *. cbn in *. lia.
Qed.

Lemma sumn_map_natsLess f n :
  sumn (map f (natsLess n)) = sumn (map (fun i => f (n - (1 + i))) (natsLess n)).
Proof.
  rewrite sumn_rev. f_equal.
  rewrite <- map_rev.
  rewrite <- map_map with (g:=f) (f:= fun i => (n - (1+i))).
  f_equal.
  induction n;intros;autorewrite with list in *. reflexivity.
  rewrite natsLess_S at 2. cbn. rewrite map_app. cbn.
  rewrite map_map. cbn in IHn.
  rewrite IHn. rewrite <- minus_n_O. reflexivity.
Qed.

Lemma sumn_map_add X f g (l:list X) :
  sumn (map (fun x => f x + g x) l) = sumn (map f l) + sumn (map g l).
Proof.
  induction l;cbn;nia.
Qed.
Lemma sumn_map_mult_c_r X f c (l:list X) :
  sumn (map (fun x => f x *c) l) = sumn (map f l)*c.
Proof.
  induction l;cbn;nia.
Qed.
Lemma sumn_map_c X c (l:list X) :
  sumn (map (fun _ => c) l) = length l * c.
Proof.
  induction l;cbn;nia.
Qed.

Lemma sumn_le_in n xs: n el xs -> n <= sumn xs.
Proof.
  induction xs. easy. intros [ | ]. now cbn;nia.
  cbn;etransitivity. apply IHxs. easy. nia.
Qed.

Lemma sumn_concat xs: sumn (concat xs) = sumn (map sumn xs).
Proof.
  induction xs;cbn. easy. etransitivity. apply sumn_app. nia.
Qed.

Lemma sumn_repeat c n: sumn (repeat c n) = c * n.
Proof.
  induction n;cbn. all:nia.
Qed.

Definition maxl := fold_right max 0.
Lemma maxl_leq n l: n el l -> n <= maxl l.
Proof.
  induction l;cbn.
  -easy.
  -intros [->|]. all:apply Nat.max_case_strong;try intuition Lia.lia.
Qed.

Lemma maxl_leq_l c l :
  (forall n, n el l -> n <= c) -> maxl l <= c.
Proof.
  induction l;cbn. Lia.lia.
  intros H. eapply Nat.max_lub_iff;split. all:eauto.
Qed.

Lemma maxl_app l l': maxl (l++l') = max (maxl l) (maxl l').
Proof.
  induction l;cbn;Lia.lia.
Qed.

Lemma maxl_rev l: maxl (rev l) = maxl l.
Proof.
  unfold maxl. rewrite fold_left_rev_right. rewrite fold_symmetric. 2,3:now intros;Lia.lia.
  induction l;cbn;try Lia.lia.
Qed.


(* Ethereum instructions that deal with signed ints: SDIV SMOD SIGNEXTEND SLT SGT SAR *)

From Coq Require Import NArith ZArith Lia.

Require Import UInt.
Require Import Arith2.

Local Open Scope Z_scope.

Definition sint (width: N) := bound_int (- 2 ^ (Z.of_N width - 1))
                                         (  2 ^ (Z.of_N width - 1)).

Definition Z_of_sint {width: N} (z: sint width): Z := Z_of_bound_int z.

Local Lemma uint_of_sint_pos_spec {width : N}
                             (a: sint width)
                             (p: positive)
                             (E: Z_of_sint a = Z.pos p):
  (N.pos p < 2 ^ width)%N.
Proof.
assert (B := bound_int_upper a).
unfold Z_of_sint in E. rewrite E in B.
clear E a.
apply N2Z.inj_lt.
rewrite N2Z.inj_pow.
cbn.
apply (Z.lt_trans _ _ _ B).
apply Z.pow_lt_mono_r. { now rewrite<- Z.ltb_lt. }
{ apply N2Z.is_nonneg. }
apply Z.lt_pred_l.
Qed.

Local Lemma uint_of_sint_neg_spec {width : N}
                            (a: sint width)
                            (p: positive)
                            (E: Z_of_sint a = Z.neg p):
  (2 ^ width - N.pos p < 2 ^ width)%N.
Proof.
assert (B := bound_int_lower a). unfold Z_of_sint in E.
rewrite E in B. clear E a.
apply N.sub_lt. 2:{ now apply N_ne_0_gt_0. }
apply N2Z.inj_le.
rewrite N2Z.inj_pow.
cbn.
rewrite Z.opp_le_mono in B.
cbn in B. rewrite Z.opp_involutive in B.
apply (Z.le_trans _ _ _ B).
apply Z.pow_le_mono_r. { now rewrite<- Z.ltb_lt. }
apply Z.lt_le_incl.
apply Z.lt_pred_l.
Qed.

(** Convert an uint to a sint in a usual way:
    split the range of uints in half and
    map the higher half into the negatives.
 *)

Definition uint_of_sint {width: N} (a: sint width)
: uint width
:= let z := Z_of_sint a in
   match z as z' return z = z' -> _ with
   | Z0 => fun _ => uint_0 width
   | Zpos p => fun E => uint_of_N (Npos p) (uint_of_sint_pos_spec a p E)
   | Zneg p => fun E => uint_of_N (2^width - Npos p)%N (uint_of_sint_neg_spec a p E)
   end eq_refl.       (* I don't like this ^ subtraction in N but it's too late *)

Lemma Z_of_uint_of_sint {width: N} (a: sint width):
  Z_of_uint (uint_of_sint a) =
    let z := Z_of_sint a in
    match z with
    | Z0 | Zpos _ => z
    | Zneg p => (z + 2^(Z.of_N width))%Z
    end.
Proof.
unfold Z_of_uint.
unfold uint_of_sint.
remember (fun p (E : Z_of_sint a = Z.pos p) => uint_of_N (N.pos p) (uint_of_sint_pos_spec a p E))
  as branch_pos.
remember (fun p (E : Z_of_sint a = Z.neg p) =>
   uint_of_N (2 ^ width - N.pos p) (uint_of_sint_neg_spec a p E))
  as branch_neg.
assert(PosOk: forall p E, Z_of_bound_int (branch_pos p E) = Zpos p).
{ intros. subst. trivial. }
assert(NegOk: forall p E, Z_of_bound_int (branch_neg p E) = Zneg p + 2^(Z.of_N width)).
{
  intros. subst. cbn. clear PosOk.
  assert (P: 0 < 2 ^ Z.of_N width). { apply Z_0_lt_pow2. apply N2Z.is_nonneg. }
  remember (2 ^ Z.of_N width) as m.
  destruct m. { now apply Z.lt_irrefl in P. }
  2:{ exfalso. rewrite<- Z.ltb_lt in P. cbn in P. discriminate. }
  clear P.
  unfold Z_of_sint in E.
  rewrite<- Pos2Z.add_pos_neg.
  rewrite Heqm. clear Heqm.
  assert (U := bound_int_lower a).
  assert (Q: (N.pos p <= 2 ^ width)%N).
  {
    rewrite E in U.
    rewrite<- (Pos2Z.opp_pos p) in U.
    rewrite<- Z.opp_le_mono in U.
    rewrite N2Z.inj_le.
    rewrite N2Z.inj_pow. cbn.
    apply (Z.le_trans _ _ _ U).
    apply Z.pow_le_mono_r. { now rewrite<- Z.ltb_lt. }
    apply Z.le_pred_l.
  }
  rewrite N2Z.inj_sub; try assumption.
  rewrite N2Z.inj_pow. cbn.
  rewrite<- (Pos2Z.opp_pos p). rewrite Z.add_opp_r. trivial.
}
clear Heqbranch_pos Heqbranch_neg.
destruct (Z_of_sint a); easy.
Qed.

Local Lemma sint_of_uint_high {width: positive}
                               (z: Z)
                               (H : (Z.ones (Zpos width - 1) <? z) = true)
                               (U: z < 2 ^ Zpos width):
  - 2 ^ (Zpos width - 1) <= z - 2 ^ Zpos width < 2 ^ (Zpos width - 1).
Proof.
rewrite Z.ones_equiv in H.
rewrite Z.ltb_lt in H.
rewrite Z.lt_pred_le in H.
replace (2 ^ Zpos width) with (2 ^ (Z.succ (Z.pred (Zpos width)))) in *.
2:{ f_equal. now rewrite Z.succ_pred. }
replace (Z.pred (Zpos width)) with (Zpos width - 1)%Z in *. 2:{ trivial. }
rewrite Z.pow_succ_r in *; lia.
Qed.

Local Lemma sint_of_uint_low {width: positive}
                              (z: Z)
                              (L: (Z.ones (Z.pos width - 1) <? z) = false)
                              (NN: 0 <= z):
  - 2 ^ (Z.pos width - 1) <= z < 2 ^ (Z.pos width - 1).
Proof.
rewrite Z.ones_equiv in L.
rewrite Z.ltb_ge in L.
rewrite<- Z.lt_le_pred in L.
split; try assumption.
refine (Z.le_trans _ _ _ _ NN).
rewrite Z.opp_nonpos_nonneg.
apply Z.pow_nonneg.
rewrite<- Z.leb_le. trivial.
Qed.

Definition sint_of_uint {width: positive} (a: uint (Npos width))
: sint (Npos width)
:= let z := Z_of_uint a in
   (if (Z.ones (Zpos width - 1) <? z)%Z as b return _ = b -> _
     then fun H => bound_int_of_Z_conj (z - 2^(Zpos width))
                                        (sint_of_uint_high z H (bound_int_upper a))
     else fun L => bound_int_of_Z_conj z
                                        (sint_of_uint_low z L (bound_int_lower a)))
       eq_refl.

(* Same but without proofs: *)
Lemma Z_of_sint_of_uint {width: positive} (a: uint (Npos width)):
  Z_of_sint (sint_of_uint a) =
   let z := Z_of_uint a in
   if (Z.ones (Zpos width - 1) <? z)%Z
     then z - 2 ^ (Zpos width)
     else z.
Proof.
unfold sint_of_uint.
(* TODO: write a tactic for this: *)
remember (fun H : (Z.ones (Z.pos width - 1) <? Z_of_uint a) = true =>
     bound_int_of_Z_conj (Z_of_uint a - 2 ^ Z.pos width)
       (sint_of_uint_high (Z_of_uint a) H (bound_int_upper a)))
  as high_branch.
remember (fun L : (Z.ones (Z.pos width - 1) <? Z_of_uint a) = false =>
     bound_int_of_Z_conj (Z_of_uint a) (sint_of_uint_low (Z_of_uint a) L (bound_int_lower a)))
  as low_branch.
assert(HighOk: forall H, Z_of_bound_int (high_branch H) = Z_of_uint a - 2 ^ Z.pos width).
{ intro. subst. trivial. }
assert(LowOk: forall L, Z_of_bound_int (low_branch L) = Z_of_uint a).
{ intro. subst. trivial. }
clear Heqhigh_branch Heqlow_branch.
destruct (Z.ones (Z.pos width - 1) <? Z_of_uint a).
{ apply (HighOk eq_refl). }
{ apply (LowOk eq_refl). }
Qed.

Example sint_of_uint_example:
  Z_of_sint (sint_of_uint (uint_not (uint_0 8))) = -1%Z.
Proof. trivial. Qed.

Lemma Z_pow2_pos_pred (p: positive):
  2 ^ Z.pos p = 2 * 2 ^ (Z.pos p - 1).
Proof.
replace (2 ^ Z.pos p) with (2 ^ Z.succ (Z.pos p - 1)).
{ apply Z.pow_succ_r. lia. }
f_equal. lia.
Qed.

Lemma sint_of_uint_of_sint {width: positive} (s: sint (Npos width)):
  sint_of_uint (uint_of_sint s) = s.
Proof.
apply bound_int_irrel.
replace (Z_of_bound_int (sint_of_uint (uint_of_sint s)))
  with (Z_of_sint (sint_of_uint (uint_of_sint s))) by trivial.
rewrite Z_of_sint_of_uint.
rewrite Z_of_uint_of_sint.
rewrite Z.ones_equiv.
assert(LB := bound_int_lower s).
assert(UB := bound_int_upper s).
replace (Z.of_N (N.pos width)) with (Z.pos width) in * by trivial.
unfold Z_of_sint.
remember (Z_of_bound_int s) as z. clear Heqz s. subst.
assert (K: 0 <= Z.pred (2 ^ (Z.pos width - 1))).
{
  apply Zlt_0_le_0_pred.
  apply Z_0_lt_pow2.
  lia.
}
destruct z. { rewrite<- Z.ltb_ge in K. now rewrite K. }
{
  assert (M: Z.pos p <= Z.pred (2 ^ (Z.pos width - 1))).
  {
    replace (Z.of_N (N.pos width)) with (Z.pos width) in UB by trivial.
    lia.
  }
  rewrite<- Z.ltb_ge in M. rewrite M. trivial.
}
assert (M: Z.pred (2 ^ (Z.pos width - 1)) < Z.neg p + 2 ^ Z.of_N (N.pos width)).
{
  replace (Z.of_N (N.pos width)) with (Z.pos width) in * by trivial.
  rewrite (Z_pow2_pos_pred width). lia.
}
rewrite<- Z.ltb_lt in M. rewrite M.
replace (Z.of_N (N.pos width)) with (Z.pos width) in * by trivial.
lia.
Qed.

Lemma uint_of_sint_of_uint {width: positive} (u: uint (Npos width)):
  uint_of_sint (sint_of_uint u) = u.
Proof.
apply bound_int_irrel.
replace (Z_of_bound_int (uint_of_sint (sint_of_uint u)))
   with (Z_of_uint (uint_of_sint (sint_of_uint u))) by trivial.
rewrite Z_of_uint_of_sint. rewrite Z_of_sint_of_uint.
assert(LB := bound_int_lower u).
assert(UB := bound_int_upper u).
replace (Z_of_uint u) with (Z_of_bound_int u) by trivial.
remember (Z_of_bound_int u) as z. clear Heqz u.
replace (Z.of_N (N.pos width)) with (Z.pos width) in * by trivial.
rewrite Z.ones_equiv. rewrite (Z_pow2_pos_pred width) in *.
remember (2 ^ (Z.pos width - 1)) as m.
assert(M: 0 < m). { subst. apply Z_0_lt_pow2. lia. }
cbn. clear Heqm.
remember (Z.pred m <? z) as f. symmetry in Heqf.
destruct m; try lia.
destruct f; remember (z - Z.pos p~0) as y; destruct y; try lia.
destruct z; lia.
Qed.

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

Lemma sint_minus_1_lower (width: positive):
  (- 2 ^ (Z.of_N (N.pos width) - 1)) <= -1.
Proof.
apply Zlt_succ_le.
apply Z.opp_neg_pos.
apply Z_0_lt_pow2.
lia.
Qed.

Lemma sint_0_lower (width: positive):
  (- 2 ^ (Z.of_N (N.pos width) - 1)) <= 0.
Proof.
apply (Z.le_trans _ _ _ (sint_minus_1_lower _)).
rewrite<- Z.leb_le. trivial.
Qed.

Lemma sint_0_upper (width: positive):
  0 < 2 ^ (Z.of_N (N.pos width) - 1).
Proof.
apply Z_0_lt_pow2.
lia.
Qed.

Lemma sint_minus_1_upper (width: positive):
  -1 < 2 ^ (Z.of_N (N.pos width) - 1).
Proof.
refine (Z.lt_trans _ _ _ _ (sint_0_upper _)).
rewrite<- Z.ltb_lt. trivial.
Qed.

Definition sint_0 (width: positive)
: sint (Npos width)
:= bound_int_of_Z 0%Z (sint_0_lower width) (sint_0_upper width).

Definition sint_minus_1 (width: positive)
: sint (Npos width)
:= bound_int_of_Z (-1)%Z (sint_minus_1_lower width) (sint_minus_1_upper width).

Definition sint_lowest (width: positive)
: sint (Npos width)
:= bound_int_of_Z (- 2 ^ (Z.of_N (Npos width) - 1))
                  (Z.le_refl _)
                  (Z.le_lt_trans _ _ _ (sint_0_lower width) (sint_0_upper width)).

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

Definition sdiv (a b: Z) := Z.sgn a * Z.sgn b * (Z.abs a / Z.abs b).

Lemma sdiv_0_r (a: Z):
  sdiv a 0 = 0.
Proof.
unfold sdiv. cbn. rewrite Z.mul_0_r. rewrite Z.mul_0_l. trivial.
Qed.

Lemma sdiv_1_r (a: Z):
  sdiv a 1 = a.
Proof.
unfold sdiv. cbn. rewrite Z.mul_1_r. rewrite Z.div_1_r.
now destruct a.
Qed.

Lemma abs_sdiv (a b: Z):
  Z.abs (sdiv a b) = Z.abs a / Z.abs b.
Proof.
unfold sdiv.
rewrite<- Z.mul_assoc.
rewrite Z_abs_sgn.
rewrite Z_abs_sgn.
remember (Z.abs a / Z.abs b) as q.
assert(Q: 0 <= q). { subst. apply Z_div_nonneg; apply Z.abs_nonneg. }
destruct a, b; try easy; now apply Z.abs_eq.
Qed.

Lemma abs_sdiv_le (a b: Z):
  Z.abs (sdiv a b) <= Z.abs a.
Proof.
rewrite abs_sdiv.
apply Z2N.inj_le; try apply Z_div_nonneg; try rewrite Z2N.inj_div; try apply Z.abs_nonneg.
apply N_div_le.
Qed.

Lemma abs_sdiv_lt (a b: Z)
                  (A: 0 < Z.abs a)
                  (B: 1 < Z.abs b):
  Z.abs (sdiv a b) < Z.abs a.
Proof.
rewrite abs_sdiv. now apply Z.div_lt.
Qed.

Lemma sint_sdiv_bound {width: positive} (a b: sint (Npos width))
      (E: ((Z_of_sint a =? Z_of_sint (sint_lowest width)) && (Z_of_sint b =? -1))%bool = false):
  - 2 ^ (Z.of_N (N.pos width) - 1) <= sdiv (Z_of_sint a) (Z_of_sint b) < 2 ^ (Z.of_N (N.pos width) - 1).
Proof.
assert(AL := bound_int_lower a).
assert(AU := bound_int_upper a).
assert(BL := bound_int_lower b).
assert(BU := bound_int_upper b).
unfold Z_of_sint in *.
remember (Z_of_bound_int a) as n. clear Heqn.
remember (Z_of_bound_int b) as m. clear Heqm.
apply Bool.andb_false_elim in E.
destruct E as [NotLowest | NotMinusOne].
{
  rewrite Z.eqb_neq in NotLowest.
  replace (Z_of_bound_int (sint_lowest width))
    with (- 2 ^ (Z.of_N (N.pos width) - 1))
    in NotLowest by trivial.
  assert(NL: - 2 ^ (Z.of_N (N.pos width) - 1) < n) by lia. clear AL.
  enough (- 2 ^ (Z.of_N (N.pos width) - 1) < sdiv n m < 2 ^ (Z.of_N (N.pos width) - 1)) by lia.
  rewrite<- Z.abs_lt. rewrite abs_sdiv.
  apply (Z.le_lt_trans _ _ _ (Z_abs_div_le _ _)).
  lia.
}
rewrite Z.eqb_neq in NotMinusOne.
assert(MZ: m = 0 \/ 0 < Z.abs m). { lia. }
case MZ; intro; subst. { rewrite sdiv_0_r. apply (bound_int_both (sint_0 width)). }
assert(NZ: n = 0 \/ 0 < Z.abs n). { lia. }
case NZ; intro; subst. { apply (bound_int_both (sint_0 width)). }
assert(M1: m = 1 \/ 1 < Z.abs m). { lia. }
case M1; intro; subst. { rewrite sdiv_1_r. tauto. }
enough (- 2 ^ (Z.of_N (N.pos width) - 1) < sdiv n m < 2 ^ (Z.of_N (N.pos width) - 1)) by lia.
rewrite<- Z.abs_lt. rewrite abs_sdiv.
refine (Z.lt_le_trans _ _ _ (Z.div_lt _ _ _ _) _); try lia.
Qed.

Definition sint_sdiv {width: positive} (a b: sint (Npos width))
: sint (Npos width)
:= (if ((Z_of_sint a =? Z_of_sint (sint_lowest width)) && (Z_of_sint b =? -1))%bool
      as over return _ = over -> _
      then fun _ => a
      else fun E => bound_int_of_Z_conj (sdiv (Z_of_sint a) (Z_of_sint b))
                                         (sint_sdiv_bound a b E))
      eq_refl.

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

(* This is Ethereum's smod: the sign of b is ignored. *)
Definition smod (a b: Z) := Z.sgn a * (Z.abs a mod Z.abs b).
Lemma smod_0_r (a: Z):
  smod a 0 = 0.
Proof.
unfold smod. cbn. rewrite Zmod_0_r. now rewrite Z.mul_0_r.
Qed.

Lemma sint_smod_bound {width: positive} (a b: sint (Npos width)):
  - 2 ^ (Z.of_N (N.pos width) - 1) <= smod (Z_of_sint a) (Z_of_sint b) < 2 ^ (Z.of_N (N.pos width) - 1).
Proof.
assert(AL := bound_int_lower a).
assert(AU := bound_int_upper a).
assert(BL := bound_int_lower b).
assert(BU := bound_int_upper b).
unfold Z_of_sint in *.
remember (Z_of_bound_int a) as n. clear Heqn.
remember (Z_of_bound_int b) as m. clear Heqm.
assert(M: m = 0 \/ 0 < Z.abs m) by lia.
case M; intro MZ. { subst. rewrite smod_0_r. apply (bound_int_both (sint_0 width)). }
clear M.
unfold smod.
assert (B := Z.mod_pos_bound (Z.abs n) (Z.abs m) MZ).
enough(- 2 ^ (Z.of_N (N.pos width) - 1) < Z.sgn n * (Z.abs n mod Z.abs m) < 2 ^ (Z.of_N (N.pos width) - 1)) by lia.
apply Z.abs_lt. rewrite Z_abs_sgn.
enough (Z.abs (Z.abs n mod Z.abs m) < 2 ^ (Z.of_N (N.pos width) - 1)) by now destruct n.
lia.
Qed.

Definition sint_smod {width: positive} (a b: sint (Npos width))
: sint (Npos width)
:= bound_int_of_Z_conj (smod (Z_of_sint a) (Z_of_sint b))
                       (sint_smod_bound a b).


(* -*- mode: coq; mode: visual-line -*- *)
Require Import Basics Types.
Require Export Basics.Nat.
Require Export HoTT.DProp.

Local Unset Elimination Schemes.

Scheme nat_ind := Induction for nat Sort Type.
Scheme nat_rect := Induction for nat Sort Type.
Scheme nat_rec := Minimality for nat Sort Type.

(** * Theorems about the natural numbers *)

(** Many of these definitions and proofs have been ported from the coq stdlib. *)

(** We want to close the trunc_scope so that notations from there don't conflict here. *)
Local Close Scope trunc_scope.
Local Open Scope nat_scope.

(** ** Basic operations on naturals *)

(** It is common to call [S] [succ] so we add it as a parsing only notation. *)
Notation succ := S (only parsing).

(** The predecessor of a natural number. *)
Definition pred n : nat :=
  match n with
  | 0 => n
  | S n' => n'
  end.

(** Addition of natural numbers *)
Fixpoint add n m : nat :=
  match n with
  | 0 => m
  | S n' => S (add n' m)
  end.

Notation "n + m" := (add n m) : nat_scope.

Definition double n : nat := n + n.

Fixpoint mul n m : nat :=
  match n with
  | 0 => 0
  | S n' => m + (mul n' m)
  end.

Notation "n * m" := (mul n m) : nat_scope.

(** Truncated subtraction: [n - m] is [0] if [n <= m] *)
Fixpoint sub n m : nat :=
  match n, m with
  | S n' , S m' => sub n' m'
  | _ , _ => n
  end.

Notation "n - m" := (sub n m) : nat_scope.

(** ** Minimum, maximum *)

Fixpoint max n m :=
  match n, m with
  | 0 , _ => m
  | S n' , 0 => n'.+1
  | S n' , S m' => (max n' m').+1
  end.

Fixpoint min n m :=
  match n, m with
  | 0 , _ => 0
  | S n' , 0 => 0
  | S n' , S m' => S (min n' m')
  end.

(** ** Power *)

Fixpoint pow n m :=
  match m with
  | 0 => 1
  | S m' => n * (pow n m')
  end.

(** ** Euclidean division *)

(** This division is linear and tail-recursive. In [divmod], [y] is the predecessor of the actual divisor, and [u] is [y] sub the real remainder. *)

Fixpoint divmod x y q u : nat * nat :=
  match x with
  | 0 => (q , u)
  | S x' =>
    match u with
    | 0 => divmod x' y (S q) y
    | S u' => divmod x' y q u'
    end
  end.

Definition div x y : nat :=
  match y with
    | 0 => y
    | S y' => fst (divmod x y' 0 y')
  end.

Definition modulo x y : nat :=
  match y with
    | 0 => y
    | S y' => y' - snd (divmod x y' 0 y')
  end.

Infix "/" := div : nat_scope.
Infix "mod" := modulo : nat_scope.

(** ** Greatest common divisor *)

(** We use Euclid algorithm, which is normally not structural, but Coq is now clever enough to accept this (behind modulo there is a subtraction, which now preserves being a subterm) *)

Fixpoint gcd a b :=
  match a with
  | O => b
  | S a' => gcd (b mod a'.+1) a'.+1
  end.

(** ** Square *)

Definition square n : nat := n * n.

(** ** Square root *)

(** The following square root function is linear (and tail-recursive).
  With Peano representation, we can't do better. For faster algorithm,
  see Psqrt/Zsqrt/Nsqrt...

  We search the square root of n = k + p^2 + (q - r)
  with q = 2p and 0<=r<=q. We start with p=q=r=0, hence
  looking for the square root of n = k. Then we progressively
  decrease k and r. When k = S k' and r=0, it means we can use (S p)
  as new sqrt candidate, since (S k')+p^2+2p = k'+(S p)^2.
  When k reaches 0, we have found the biggest p^2 square contained
  in n, hence the square root of n is p.
*)

Fixpoint sqrt_iter k p q r : nat :=
  match k with
  | O => p
  | S k' =>
    match r with
    | O => sqrt_iter k' p.+1 q.+2 q.+2
    | S r' => sqrt_iter k' p q r'
    end
  end.

Definition sqrt n : nat := sqrt_iter n 0 0 0.

(** ** Log2 *)

(** This base-2 logarithm is linear and tail-recursive.

  In [log2_iter], we maintain the logarithm [p] of the counter [q],
  while [r] is the distance between [q] and the next power of 2,
  more precisely [q + S r = 2^(S p)] and [r<2^p]. At each
  recursive call, [q] goes up while [r] goes down. When [r]
  is 0, we know that [q] has almost reached a power of 2,
  and we increase [p] at the next call, while resetting [r]
  to [q].

  Graphically (numbers are [q], stars are [r]) :

<<
                    10
                  9
                8
              7   *
            6       *
          5           ...
        4
      3   *
    2       *
  1   *       *
0   *   *       *
>>

  We stop when [k], the global downward counter reaches 0.
  At that moment, [q] is the number we're considering (since
  [k+q] is invariant), and [p] its logarithm.
*)

Fixpoint log2_iter k p q r : nat :=
  match k with
  | O    => p
  | S k' =>
    match r with
    | O => log2_iter k' (S p) (S q) q
    | S r' => log2_iter k' p (S q) r'
    end
  end.

Definition log2 n : nat := log2_iter (pred n) 0 1 0.

(** ** Iterator on natural numbers *)

Definition iter (n : nat) {A} (f : A -> A) (x : A) : A :=
  nat_rec A x (fun _ => f) n.

Local Definition ap_S := @ap _ _ S.
Local Definition ap_nat := @ap nat.
#[export] Hint Resolve ap_S : core.
#[export] Hint Resolve ap_nat : core.

Theorem pred_Sn : forall n:nat, n = pred (S n).
Proof.
  auto.
Defined.

(** Injectivity of successor *)

Definition path_nat_S n m (H : S n = S m) : n = m := ap pred H.
#[export] Hint Immediate path_nat_S : core.

Theorem not_eq_S : forall n m:nat, n <> m -> S n <> S m.
Proof.
  auto.
Defined.
#[export] Hint Resolve not_eq_S : core.

(** TODO: keep or remove? *)
Definition IsSucc (n: nat) : Type :=
  match n with
  | O => False
  | S p => True
  end.

(** Zero is not the successor of a number *)

Theorem not_eq_O_S : forall n:nat, 0 <> S n.
Proof.
  discriminate.
Defined.
#[export] Hint Resolve not_eq_O_S : core.

Theorem not_eq_n_Sn : forall n:nat, n <> S n.
Proof.
  induction n; auto.
Defined.
#[export] Hint Resolve not_eq_n_Sn : core.

Local Definition ap011_add := @ap011 _ _ _ add.
Local Definition ap011_nat := @ap011 nat nat.
#[export] Hint Resolve ap011_add : core.
#[export] Hint Resolve ap011_nat : core.

Lemma add_n_O : forall (n : nat), n = n + 0.
Proof.
  induction n; simpl; auto.
Defined.
#[export] Hint Resolve add_n_O : core.

Lemma add_O_n : forall (n : nat), 0 + n = n.
Proof.
  auto.
Defined.

Lemma add_n_Sm : forall n m:nat, S (n + m) = n + S m.
Proof.
  intros n m; induction n; simpl; auto.
Defined.
#[export] Hint Resolve add_n_Sm: core.

Lemma add_Sn_m : forall n m:nat, S n + m = S (n + m).
Proof.
  auto.
Defined.

(** Multiplication *)

Local Definition ap011_mul := @ap011 _ _ _  mul.
#[export] Hint Resolve ap011_mul : core.

Lemma mul_n_O : forall n:nat, 0 = n * 0.
Proof.
  induction n; simpl; auto.
Defined.
#[export] Hint Resolve mul_n_O : core.

Lemma mul_n_Sm : forall n m:nat, n * m + n = n * S m.
Proof.
  intros; induction n as [| p H]; simpl; auto.
  destruct H; rewrite <- add_n_Sm; apply ap.
  pattern m at 1 3; elim m; simpl; auto.
Defined.
#[export] Hint Resolve mul_n_Sm: core.

(** Standard associated names *)

Notation mul_0_r_reverse := mul_n_O (only parsing).
Notation mul_succ_r_reverse := mul_n_Sm (only parsing).

(** ** Equality of natural numbers *)

(** *** Boolean equality and its properties *)

Fixpoint code_nat (m n : nat) {struct m} : DHProp :=
  match m, n with
  | 0, 0 => True
  | m'.+1, n'.+1 => code_nat m' n'
  | _, _ => False
  end.

Infix "=n" := code_nat : nat_scope.

Fixpoint idcode_nat {n} : (n =n n) :=
  match n as n return (n =n n) with
  | 0 => tt
  | S n' => @idcode_nat n'
  end.

Fixpoint path_nat {n m} : (n =n m) -> (n = m) :=
  match m as m, n as n return (n =n m) -> (n = m) with
  | 0, 0 => fun _ => idpath
  | m'.+1, n'.+1 => fun H : (n' =n m') => ap S (path_nat H)
  | _, _ => fun H => match H with end
  end.

Global Instance isequiv_path_nat {n m} : IsEquiv (@path_nat n m).
Proof.
  refine (isequiv_adjointify
            (@path_nat n m)
            (fun H => transport (fun m' => (n =n m')) H idcode_nat)
            _ _).
  { intros []; simpl.
    induction n; simpl; trivial.
    by destruct (IHn^)%path. }
  { intro. apply path_ishprop. }
Defined.

Definition equiv_path_nat {n m} : (n =n m) <~> (n = m)
  := Build_Equiv _ _ (@path_nat n m) _.

(** Thus [nat] has decidable paths *)
Global Instance decidable_paths_nat : DecidablePaths nat
  := fun n m => decidable_equiv _ (@path_nat n m) _.

(** And is therefore a HSet *)
Global Instance hset_nat : IsHSet nat := _.

(** ** Inequality of natural numbers *)

Inductive leq (n : nat) : nat -> Type :=
| leq_n : leq n n
| leq_S : forall m, leq n m -> leq n (S m).

Scheme leq_ind := Induction for leq Sort Type.
Scheme leq_rect := Induction for leq Sort Type.
Scheme leq_rec := Minimality for leq Sort Type.

Notation "n <= m" := (leq n m) : nat_scope.
#[export] Hint Constructors leq : core.

Existing Class leq.
Global Existing Instances leq_n leq_S.

Notation leq_refl := leq_n (only parsing).
Global Instance reflexive_leq : Reflexive leq := leq_n.

Lemma leq_trans {x y z} : x <= y -> y <= z -> x <= z.
Proof.
  induction 2; auto.
Defined.

Global Instance transitive_leq : Transitive leq := @leq_trans.

Lemma leq_n_pred n m : leq n m -> leq (pred n) (pred m).
Proof.
  induction 1; auto.
  destruct m; simpl; auto.
Defined.

Lemma leq_S_n : forall n m, n.+1 <= m.+1 -> n <= m.
Proof.
  intros n m.
  apply leq_n_pred.
Defined.

Lemma leq_S_n' n m : n <= m -> n.+1 <= m.+1.
Proof.
  induction 1; auto.
Defined.
Global Existing Instance leq_S_n' | 100.

Lemma not_leq_Sn_n n : ~ (n.+1 <= n).
Proof.
  induction n.
  { intro p.
    inversion p. }
  intros p.
  by apply IHn, leq_S_n.
Defined.

(** A general form for injectivity of this constructor *)
Definition leq_n_inj_gen n k (p : n <= k) (r : n = k) : p = r # leq_n n.
Proof.
  induction p.
  + assert (c : idpath = r) by apply path_ishprop.
    destruct c.
    reflexivity.
  + destruct r^.
    contradiction (not_leq_Sn_n _ p).
Defined.

(** Which we specialise to this lemma *)
Definition leq_n_inj n (p : n <= n) : p = leq_n n
  := leq_n_inj_gen n n p idpath.

Fixpoint leq_S_inj_gen n m k (p : n <= k) (q : n <= m) (r : m.+1 = k)
  : p = r # leq_S n m q.
Proof.
  revert m q r.
  induction p.
  + intros k p r.
    destruct r.
    contradiction (not_leq_Sn_n _ p).
  + intros m' q r.
    pose (r' := path_nat_S _ _ r).
    destruct r'.
    assert (t : idpath = r) by apply path_ishprop.
    destruct t.
    cbn. apply ap.
    destruct q.
    1:  apply leq_n_inj.
    apply (leq_S_inj_gen n m _ p q idpath).
Defined.

Definition leq_S_inj n m (p : n <= m.+1) (q : n <= m) : p = leq_S n m q
  := leq_S_inj_gen n m m.+1 p q idpath.

Global Instance ishprop_leq n m : IsHProp (n <= m).
Proof.
  apply hprop_allpath.
  intros p q; revert p.
  induction q.
  + intros y.
    rapply leq_n_inj.
  + intros y.
    rapply leq_S_inj.
Defined.

Global Instance leq_0_n n : 0 <= n | 10.
Proof.
  induction n; auto.
Defined.

Lemma not_leq_Sn_0 n : ~ (n.+1 <= 0).
Proof.
  intros p.
  apply (fun x => leq_trans x (leq_0_n n)) in p.
  contradiction (not_leq_Sn_n _ p).
Defined.

Definition equiv_leq_S_n n m : n.+1 <= m.+1 <~> n <= m.
Proof.
  srapply equiv_iff_hprop.
  apply leq_S_n.
Defined.

Global Instance decidable_leq n m : Decidable (n <= m).
Proof.
  revert n.
  induction m; intros n.
  - destruct n.
    + left; exact _.
    + right; apply not_leq_Sn_0.
  - destruct n.
    + left; exact _.
    + rapply decidable_equiv'.
      symmetry.
      apply equiv_leq_S_n.
Defined.

Fixpoint leq_add n m : n <= (m + n).
Proof.
  destruct m.
  1: apply leq_n.
  apply leq_S, leq_add.
Defined.

Lemma equiv_leq_add n m
  : leq n m <~> exists k, k + n = m.
Proof.
  srapply equiv_iff_hprop.
  { apply hprop_allpath.
    intros [x p] [y q].
    apply path_sigma_hprop.
    simpl.
    revert m p q.
    induction n.
    { intros m p q.
      rewrite <- add_n_O in p,q.
      exact (p @ q^). }
    intros m p q.
    rewrite <- add_n_Sm in p,q.
    destruct m.
    { inversion p. }
    apply path_nat_S in p, q.
    by apply (IHn m). }
  { intros p.
    induction p.
    + exists 0.
      reflexivity.
    + exists IHp.1.+1.
      apply ap_S, IHp.2. }
  intros [k p].
  destruct p.
  apply leq_add.
Defined.

(** We define the less-than relation [lt] in terms of [leq] *)
Definition lt n m : Type0 := leq (S n) m.

(** We declare it as an existing class so typeclass search is performed on its goals. *)
Existing Class lt.
#[export] Hint Unfold lt : core typeclass_instances.
Infix "<" := lt : nat_scope.
(** We add a typeclass instance for unfolding the definition so lemmas about [leq] can be used. *)
Global Instance lt_is_leq n m : leq n.+1 m -> lt n m | 100 := idmap.

(** We should also give them their various typeclass instances *)
Global Instance transitive_lt : Transitive lt.
Proof.
  hnf; unfold lt in *.
  intros x y z p q.
  rapply leq_trans.
Defined.

Global Instance decidable_lt n m : Decidable (lt n m) := _.

Definition ge n m := leq m n.
Existing Class ge.
#[export] Hint Unfold ge : core typeclass_instances.
Infix ">=" := ge : nat_scope.
Global Instance ge_is_leq n m : leq m n -> ge n m | 100 := idmap.

Global Instance reflexive_ge : Reflexive ge := leq_n.
Global Instance transitive_ge : Transitive ge := fun x y z p q => leq_trans q p.
Global Instance decidable_ge n m : Decidable (ge n m) := _.

Definition gt n m := lt m n.
Existing Class gt.
#[export] Hint Unfold gt : core typeclass_instances.
Infix ">" := gt : nat_scope.
Global Instance gt_is_leq n m : leq m.+1 n -> gt n m | 100 := idmap.

Global Instance transitive_gt : Transitive gt
  := fun x y z p q => transitive_lt _ _ _ q p.
Global Instance decidable_gt n m : Decidable (gt n m) := _.

Notation "x <= y <= z" := (x <= y /\ y <= z) : nat_scope.
Notation "x <= y < z"  := (x <= y /\  y < z) : nat_scope.
Notation "x < y < z"   := (x < y  /\  y < z) : nat_scope.
Notation "x < y <= z"  := (x < y  /\ y <= z) : nat_scope.

(** Principle of double induction *)

Theorem nat_double_ind (R : nat -> nat -> Type)
  (H1 : forall n, R 0 n) (H2 : forall n, R (S n) 0)
  (H3 : forall n m, R n m -> R (S n) (S m))
  : forall n m:nat, R n m.
Proof.
  induction n; auto.
  destruct m; auto.
Defined.

(** Maximum and minimum : definitions and specifications *)

Lemma max_n_n n : max n n = n.
Proof.
  induction n; cbn; auto.
Defined.
#[export] Hint Resolve max_n_n : core.

Lemma max_Sn_n n : max (S n) n = S n.
Proof.
  induction n; cbn; auto.
Defined.
#[export] Hint Resolve max_Sn_n : core.

Lemma max_comm n m : max n m = max m n.
Proof.
  revert m; induction n; destruct m; cbn; auto.
Defined.

Lemma max_0_n n : max 0 n = n.
Proof.
  auto.
Defined.
#[export] Hint Resolve max_0_n : core.

Lemma max_n_0 n : max n 0 = n.
Proof.
  by rewrite max_comm.
Defined.
#[export] Hint Resolve max_n_0 : core.

Theorem max_l : forall n m, m <= n -> max n m = n.
Proof.
  intros n m; revert n; induction m; auto.
  intros [] p.
  1: inversion p.
  cbn; by apply ap_S, IHm, leq_S_n.
Defined.

Theorem max_r : forall n m : nat, n <= m -> max n m = m.
Proof.
  intros; rewrite max_comm; by apply max_l.
Defined.

Lemma min_comm : forall n m, min n m = min m n.
Proof.
  induction n; destruct m; cbn; auto.
Defined.

Theorem min_l : forall n m : nat, n <= m -> min n m = n.
Proof.
  intros n m; revert m; induction n; auto.
  intros [] p.
  1: inversion p.
  cbn; by apply ap_S, IHn, leq_S_n.
Defined.

Theorem min_r : forall n m : nat, m <= n -> min n m = m.
Proof.
  intros; rewrite min_comm; by apply min_l.
Defined.

(** [n]th iteration of the function [f] *)

Fixpoint nat_iter (n:nat) {A} (f:A->A) (x:A) : A :=
  match n with
    | O => x
    | S n' => f (nat_iter n' f x)
  end.

Lemma nat_iter_succ_r n {A} (f:A->A) (x:A) :
  nat_iter (S n) f x = nat_iter n f (f x).
Proof.
  induction n; intros; simpl; rewrite <- ?IHn; trivial.
Defined.

Theorem nat_iter_add :
  forall (n m:nat) {A} (f:A -> A) (x:A),
    nat_iter (n + m) f x = nat_iter n f (nat_iter m f x).
Proof.
  induction n; intros; simpl; rewrite ?IHn; trivial.
Defined.

(** Preservation of invariants : if [f : A -> A] preserves the invariant [Inv], then the iterates of [f] also preserve it. *)

Theorem nat_iter_invariant (n : nat) {A} (f : A -> A) (P : A -> Type)
  : (forall x, P x -> P (f x)) -> forall x, P x -> P (nat_iter n f x).
Proof.
  revert n A f P.
  induction n; simpl; trivial.
  intros A f P Hf x Hx.
  apply Hf, IHn; trivial.
Defined.

(** ** Arithmetic *)

Lemma nat_add_n_O : forall n:nat, n = n + 0.
Proof.
  induction n.
  - reflexivity.
  - simpl; apply ap; assumption.
Defined.

Lemma nat_add_n_Sm : forall n m:nat, (n + m).+1 = n + m.+1.
Proof.
  intros n m; induction n; simpl.
  - reflexivity.
  - apply ap; assumption.
Defined.

Definition nat_add_comm (n m : nat) : n + m = m + n.
Proof.
  revert m; induction n as [|n IH]; intros m; simpl.
  - refine (nat_add_n_O m).
  - transitivity (m + n).+1.
    + apply ap, IH.
    + apply nat_add_n_Sm.
Defined.

(** ** Exponentiation *)

Fixpoint nat_exp (n m : nat) : nat
  := match m with
       | 0 => 1
       | S m => nat_exp n m * n
     end.

(** ** Factorials *)

Fixpoint factorial (n : nat) : nat
  := match n with
       | 0 => 1
       | S n => S n * factorial n
     end.

(** ** Natural number ordering *)

(** ** Theorems about natural number ordering *)

Lemma leq_antisym {x y} : x <= y -> y <= x -> x = y.
Proof.
  intros p q.
  destruct p.
  1: reflexivity.
  destruct x; [inversion q|].
  apply leq_S_n in q.
  pose (r := leq_trans p q).
  by apply not_leq_Sn_n in r.
Defined.

Definition not_lt_n_n n : ~ (n < n) := not_leq_Sn_n n.

Definition leq_1_Sn {n} : 1 <= n.+1 := leq_S_n' 0 n (leq_0_n _).

Fixpoint leq_dichot {m} {n} : (m <= n) + (m > n).
Proof.
  induction m, n.
  - left; reflexivity.
  - left; apply leq_0_n.
  - right; unfold lt; apply leq_1_Sn.
  - assert ((m <= n) + (n < m)) as X by apply leq_dichot.
    induction X as [leqmn|ltnm].
    + left; apply leq_S_n'; assumption.
    + right; apply leq_S_n'; assumption.
Defined.

Lemma not_lt_n_0 n : ~ (n < 0).
Proof.
  apply not_leq_Sn_0.
Defined.