(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 8: Lambda Calculus and Simple Type Soundness
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap.

(* The last few chapters have focused on small programming languages that are
 * representative of the essence of the imperative languages.  We now turn to
 * lambda-calculus, the usual representative of functional languages. *)

Module Ulc.
  Inductive exp : Set :=
  | Var (x : var)
  | Abs (x : var) (body : exp)
  | App (e1 e2 : exp).

  Fixpoint subst (rep : exp) (x : var) (e : exp) : exp :=
    match e with
    | Var y => if string_dec y x then rep else Var y
    | Abs y e1 => Abs y (if y ==v x then e1 else subst rep x e1)
    | App e1 e2 => App (subst rep x e1) (subst rep x e2)
    end.

  (** * Big-step semantics *)

  Inductive eval : exp -> exp -> Prop :=
  | BigAbs : forall x e,
    eval (Abs x e) (Abs x e)
  | BigApp : forall e1 x e1' e2 v2 v,
    eval e1 (Abs x e1')
    -> eval e2 v2
    -> eval (subst v2 x e1') v
    -> eval (App e1 e2) v.

  Inductive value : exp -> Prop :=
  | Value : forall x e, value (Abs x e).

  Hint Constructors eval value.

  Theorem value_eval : forall v,
    value v
    -> eval v v.
  Proof.
    invert 1; eauto.
  Qed.

  Hint Resolve value_eval.

  Theorem eval_value : forall e v,
    eval e v
    -> value v.
  Proof.
    induct 1; eauto.
  Qed.

  Hint Resolve eval_value.

  (* Some notations, to let us write more normal-looking lambda terms *)
  Coercion Var : var >-> exp.
  Notation "\ x , e" := (Abs x e) (at level 50).
  Infix "@" := App (at level 49, left associativity).

  (* Believe it or not, this is a Turing-complete language!  Here's an example
   * nonterminating program. *)
  Example omega := (\"x", "x" @ "x") @ (\"x", "x" @ "x").

  (** * Church Numerals, everyone's favorite example of lambda terms in
      * action *)

  (* Here are two curious definitions. *)
  Definition zero := \"f", \"x", "x".
  Definition plus1 := \"n", \"f", \"x", "f" @ ("n" @ "f" @ "x").

  (* We can build up any natural number [n] as [plus1^n @ zero].  Let's prove
   * that, in fact, these definitions constitute a workable embedding of the
   * natural numbers in lambda-calculus. *)

  (* A term [plus^n @ zero] evaluates to something very close to what this
   * function returns. *)
  Fixpoint canonical' (n : nat) : exp :=
    match n with
    | O => "x"
    | S n' => "f" @ ((\"f", \"x", canonical' n') @ "f" @ "x")
    end.

  (* This missing piece is this wrapper. *)
  Definition canonical n := \"f", \"x", canonical' n.

  (* Let's formalize our definition of what it means to represent a number. *)
  Definition represents (e : exp) (n : nat) :=
    eval e (canonical n).

  (* Zero passes the test. *)
  Theorem zero_ok : represents zero 0.
  Proof.
    unfold zero, represents, canonical.
    simplify.
    econstructor.
  Qed.

  (* So does our successor operation. *)
  Theorem plus1_ok : forall e n, represents e n
                                 -> represents (plus1 @ e) (S n).
  Proof.
    unfold plus1, represents, canonical; simplify.
    econstructor.
    econstructor.
    eassumption.
    simplify.
    econstructor.
  Qed.

  (* What's basically going on here?  The representation of number [n] is [N]
   * such that, for any function [f]:
   *   N(f) = f^n
   * That is, we represent a number as its repeated-composition operator.
   * So, given a number, we can use it to repeat any operation.  In particular,
   * to implement addition, we can just repeat [plus1]! *)
  Definition add := \"n", \"m", "n" @ plus1 @ "m".

  (* Our addition works properly on this test case. *)
  Example add_1_2 : exists v,
      eval (add @ (plus1 @ zero) @ (plus1 @ (plus1 @ zero))) v
      /\ eval (plus1 @ (plus1 @ (plus1 @ zero))) v.
  Proof.
    eexists; propositional.
    repeat (econstructor; simplify).
    repeat econstructor.
  Qed.

  (* By the way: since [canonical'] doesn't mention variable "m", substituting
   * for "m" has no effect.  This fact will come in handy shortly. *)
  Lemma subst_m_canonical' : forall m n,
    subst m "m" (canonical' n) = canonical' n.
  Proof.
    induct n; simplify; equality.
  Qed.

  (* This inductive proof is the workhorse for the next result, so let's skip
   * ahead there. *)
  Lemma add_ok' : forall m n,
      eval
        (subst (\ "f", (\ "x", canonical' m)) "x"
               (subst (\ "n", (\ "f", (\ "x", "f" @ (("n" @ "f") @ "x")))) "f"
                      (canonical' n))) (canonical (n + m)).
  Proof.
    induct n; simplify.

    econstructor.

    econstructor.
    econstructor.
    econstructor.
    econstructor.
    econstructor.
    econstructor.
    simplify.
    econstructor.
    econstructor.
    simplify.
    eassumption.

    simplify.
    econstructor.
  Qed.

  (* [add] properly encodes the usual addition. *)
  Theorem add_ok : forall n ne m me,
      represents ne n
      -> represents me m
      -> represents (add @ ne @ me) (n + m).
  Proof.
    unfold represents; simplify.

    econstructor.
    econstructor.
    econstructor.
    eassumption.
    simplify.
    econstructor.
    eassumption.
    simplify.
    econstructor.
    econstructor.
    econstructor.
    econstructor.
    simplify.
    econstructor.
    econstructor.
    rewrite subst_m_canonical'.
    apply add_ok'.
  Qed.

  (* Let's repeat the same exercise for multiplication. *)

  Definition mult := \"n", \"m", "n" @ (add @ "m") @ zero.

  Example mult_1_2 : exists v,
      eval (mult @ (plus1 @ zero) @ (plus1 @ (plus1 @ zero))) v
      /\ eval (plus1 @ (plus1 @ zero)) v.
  Proof.
    eexists; propositional.
    repeat (econstructor; simplify).
    repeat econstructor.
  Qed.

  Lemma mult_ok' : forall m n,
      eval
        (subst (\ "f", (\ "x", "x")) "x"
               (subst
                  (\ "m",
                   ((\ "f", (\ "x", canonical' m)) @
                                                   (\ "n", (\ "f", (\ "x", "f" @ (("n" @ "f") @ "x"))))) @ "m")
                  "f" (canonical' n))) (canonical (n * m)).
  Proof.
    induct n; simplify.

    econstructor.

    econstructor.
    econstructor.
    econstructor.
    econstructor.
    econstructor.
    econstructor.
    simplify.
    econstructor.
    econstructor.
    simplify.
    eassumption.

    simplify.
    econstructor.
    econstructor.
    econstructor.
    econstructor.
    simplify.
    econstructor.
    econstructor.
    rewrite subst_m_canonical'.
    apply add_ok'. (* Note the recursive appeal to correctness of [add]. *)
  Qed.

  Theorem mult_ok : forall n ne m me,
      represents ne n
      -> represents me m
      -> represents (mult @ ne @ me) (n * m).
  Proof.
    unfold represents; simplify.

    econstructor.
    econstructor.
    econstructor.
    eassumption.
    simplify.
    econstructor.
    eassumption.
    simplify.
    econstructor.
    econstructor.
    econstructor.
    econstructor.
    econstructor.
    econstructor.
    simplify.
    econstructor.
    simplify.
    econstructor.
    econstructor.
    simplify.
    rewrite subst_m_canonical'.
    apply mult_ok'.
  Qed.

  (** * Small-step semantics with evaluation contexts *)

  Inductive context : Set :=
  | Hole : context
  | App1 : context -> exp -> context
  | App2 : exp -> context -> context.

  Inductive plug : context -> exp -> exp -> Prop :=
  | PlugHole : forall e,
    plug Hole e e
  | PlugApp1 : forall c e1 e2 e,
    plug c e1 e
    -> plug (App1 c e2) e1 (App e e2)
  | PlugApp2 : forall c e1 e2 e,
    value e1
    -> plug c e2 e
    -> plug (App2 e1 c) e2 (App e1 e).

  Inductive step : exp -> exp -> Prop :=
  | ContextBeta : forall c x e v e1 e2,
    value v
    -> plug c (App (Abs x e) v) e1
    -> plug c (subst v x e) e2
    -> step e1 e2.

  Hint Constructors plug step.

  (* Here we now go through a proof of equivalence between big- and small-step
   * semantics, though we won't spend any further commentary on it. *)

  Lemma step_eval'' : forall v c x e e1 e2 v0,
    value v
    -> plug c (App (Abs x e) v) e1
    -> plug c (subst v x e) e2
    -> eval e2 v0
    -> eval e1 v0.
  Proof.
    induct c; invert 2; invert 1; simplify; eauto.
    invert H0; eauto.
    invert H0; eauto.
  Qed.

  Hint Resolve step_eval''.

  Lemma step_eval' : forall e1 e2,
    step e1 e2
    -> forall v, eval e2 v
      -> eval e1 v.
  Proof.
    invert 1; simplify; eauto.
  Qed.

  Hint Resolve step_eval'.

  Theorem step_eval : forall e v,
    step^* e v
    -> value v
    -> eval e v.
  Proof.
    induct 1; eauto.
  Qed.

  Lemma plug_functional : forall C e e1,
      plug C e e1
      -> forall e2, plug C e e2
                    -> e1 = e2.
  Proof.
    induct 1; invert 1; simplify; try f_equal; eauto.
  Qed.

  Lemma plug_mirror : forall C e e', plug C e e'
    -> forall e1, exists e1', plug C e1 e1'.
  Proof.
    induct 1; simplify; eauto.

    specialize (IHplug e0); first_order; eauto.

    specialize (IHplug e0); first_order; eauto.
  Qed.

  Fixpoint compose (C1 C2 : context) : context :=
    match C2 with
    | Hole => C1
    | App1 C2' e => App1 (compose C1 C2') e
    | App2 v C2' => App2 v (compose C1 C2')
    end.

  Lemma compose_ok : forall C1 C2 e1 e2 e3,
      plug C1 e1 e2
      -> plug C2 e2 e3
      -> plug (compose C1 C2) e1 e3.
  Proof.
    induct 2; simplify; eauto.
  Qed.

  Hint Resolve compose_ok.

  Lemma step_plug : forall e1 e2,
    step e1 e2
    -> forall C e1' e2', plug C e1 e1'
                         -> plug C e2 e2'
                         -> step e1' e2'.
  Proof.
    invert 1; simplify; eauto.
  Qed.

  Lemma stepStar_plug : forall e1 e2,
    step^* e1 e2
    -> forall C e1' e2', plug C e1 e1'
                         -> plug C e2 e2'
                         -> step^* e1' e2'.
  Proof.
    induct 1; simplify.

    assert (e1' = e2') by (eapply plug_functional; eassumption).
    subst.
    constructor.

    assert (exists y', plug C y y') by eauto using plug_mirror.
    invert H3.
    eapply step_plug in H.
    econstructor.
    eassumption.
    eapply IHtrc.
    eassumption.
    assumption.
    eassumption.
    assumption.
  Qed.

  Hint Resolve stepStar_plug eval_value.

  Theorem eval_step : forall e v,
    eval e v
    -> step^* e v.
  Proof.
    induct 1; eauto.

    eapply trc_trans.
    eapply stepStar_plug with (e1 := e1) (e2 := Abs x e1') (C := App1 Hole e2); eauto.
    eapply trc_trans.
    eapply stepStar_plug with (e1 := e2) (e2 := v2) (C := App2 (Abs x e1') Hole); eauto.
    eauto.
  Qed.
End Ulc.

Module Stlc.
  Inductive exp : Set :=
  | Var (x : var)
  | Const (n : nat)
  | Plus (e1 e2 : exp)
  | Abs (x : var) (e1 : exp)
  | App (e1 e2 : exp).

  Inductive value : exp -> Prop :=
  | VConst : forall n, value (Const n)
  | VAbs : forall x e1, value (Abs x e1).

  Fixpoint subst (e1 : exp) (x : string) (e2 : exp) : exp :=
    match e2 with
      | Var y => if y ==v x then e1 else Var y
      | Const n => Const n
      | Plus e2' e2'' => Plus (subst e1 x e2') (subst e1 x e2'')
      | Abs y e2' => Abs y (if y ==v x then e2' else subst e1 x e2')
      | App e2' e2'' => App (subst e1 x e2') (subst e1 x e2'')
    end.

  Inductive context : Set :=
  | Hole : context
  | Plus1 : context -> exp -> context
  | Plus2 : exp -> context -> context
  | App1 : context -> exp -> context
  | App2 : exp -> context -> context.

  Inductive plug : context -> exp -> exp -> Prop :=
  | PlugHole : forall e, plug Hole e e
  | PlugPlus1 : forall e e' C e2,
    plug C e e'
    -> plug (Plus1 C e2) e (Plus e' e2)
  | PlugPlus2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (Plus2 v1 C) e (Plus v1 e')
  | PlugApp1 : forall e e' C e2,
    plug C e e'
    -> plug (App1 C e2) e (App e' e2)
  | PlugApp2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (App2 v1 C) e (App v1 e').

  Inductive step0 : exp -> exp -> Prop :=
  | Beta : forall x e v,
    value v
    -> step0 (App (Abs x e) v) (subst v x e)
  | Add : forall n1 n2,
    step0 (Plus (Const n1) (Const n2)) (Const (n1 + n2)).

  Inductive step : exp -> exp -> Prop :=
  | StepRule : forall C e1 e2 e1' e2',
    plug C e1 e1'
    -> plug C e2 e2'
    -> step0 e1 e2
    -> step e1' e2'.

  Definition trsys_of (e : exp) := {|
    Initial := {e};
    Step := step
  |}.

  Inductive type :=
  | Nat                  (* Numbers *)
  | Fun (dom ran : type) (* Functions *).

  Inductive hasty : fmap var type -> exp -> type -> Prop :=
  | HtVar : forall G x t,
    G $? x = Some t
    -> hasty G (Var x) t
  | HtConst : forall G n,
    hasty G (Const n) Nat
  | HtPlus : forall G e1 e2,
    hasty G e1 Nat
    -> hasty G e2 Nat
    -> hasty G (Plus e1 e2) Nat
  | HtAbs : forall G x e1 t1 t2,
    hasty (G $+ (x, t1)) e1 t2
    -> hasty G (Abs x e1) (Fun t1 t2)
  | HtApp : forall G e1 e2 t1 t2,
    hasty G e1 (Fun t1 t2)
    -> hasty G e2 t1
    -> hasty G (App e1 e2) t2.

  Hint Constructors value plug step0 step hasty.

  (* Some notation to make it more pleasant to write programs *)
  Infix "-->" := Fun (at level 60, right associativity).
  Coercion Const : nat >-> exp.
  Infix "^+^" := Plus (at level 50).
  Coercion Var : var >-> exp.
  Notation "\ x , e" := (Abs x e) (at level 51).
  Infix "@" := App (at level 49, left associativity).

  (* Some examples of typed programs *)

  Example one_plus_one : hasty $0 (1 ^+^ 1) Nat.
  Proof.
    repeat (econstructor; simplify).
  Qed.

  Example add : hasty $0 (\"n", \"m", "n" ^+^ "m") (Nat --> Nat --> Nat).
  Proof.
    repeat (econstructor; simplify).
  Qed.

  Example eleven : hasty $0 ((\"n", \"m", "n" ^+^ "m") @ 7 @ 4) Nat.
  Proof.
    repeat (econstructor; simplify).
  Qed.

  Example seven_the_long_way : hasty $0 ((\"x", "x") @ (\"x", "x") @ 7) Nat.
  Proof.
    repeat (econstructor; simplify).
  Qed.

  (** * Let's prove type soundness. *)

  Definition unstuck e := value e
    \/ (exists e' : exp, step e e').

  (* For class, we'll stick with this magic tactic, to save proving time. *)

  Ltac t0 := match goal with
             | [ H : ex _ |- _ ] => invert H
             | [ H : _ /\ _ |- _ ] => invert H
             | [ |- context[?x ==v ?y] ] => cases (x ==v y)
             | [ H : Some _ = Some _ |- _ ] => invert H

             | [ H : step _ _ |- _ ] => invert H
             | [ H : step0 _ _ |- _ ] => invert1 H
             | [ H : hasty _ ?e _, H' : value ?e |- _ ] => invert H'; invert H
             | [ H : hasty _ _ _ |- _ ] => invert1 H
             | [ H : plug _ _ _ |- _ ] => invert1 H
             end; subst.

  Ltac t := simplify; propositional; repeat (t0; simplify); try equality; eauto 6.

  Lemma progress : forall e t,
    hasty $0 e t
    -> value e
    \/ (exists e' : exp, step e e').
  Proof.
  Admitted.

  (* Replacing a typing context with an equal one has no effect (useful to guide
   * proof search as a hint). *)
  Lemma hasty_change : forall G e t,
    hasty G e t
    -> forall G', G' = G
      -> hasty G' e t.
  Proof.
    t.
  Qed.

  Hint Resolve hasty_change.

  Lemma preservation : forall e1 e2,
    step e1 e2
    -> forall t, hasty $0 e1 t
      -> hasty $0 e2 t.
  Proof.
  Admitted.

  Theorem safety : forall e t, hasty $0 e t
    -> invariantFor (trsys_of e) unstuck.
  Proof.
    simplify.

    (* Step 1: strengthen the invariant.  In particular, the typing relation is
     * exactly the right stronger invariant!  Our progress theorem proves the
     * required invariant inclusion. *)
    apply invariant_weaken with (invariant1 := fun e' => hasty $0 e' t).

    (* Step 2: apply invariant induction, whose induction step turns out to match
     * our preservation theorem exactly! *)
    apply invariant_induction; simplify.
    equality.

    eapply preservation.
    eassumption.
    assumption.

    simplify.
    eapply progress.
    eassumption.
  Qed.
End Stlc.


Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.

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

(**
Classical logic is somewhat surprising!
Prove that given two arbitrary propositions
a and b, either a implies b or the converse *)

Lemma CL_is_wrong_and_boolrefl_is_nice (A B : (*D*)bool(*D*)) :
  (A -> B) \/ (B -> A).
(*A*)Proof. case: A; case: B; by [left | right]. Qed.

(** Enrico is a lazy student.  When asked to reverse and filter
a list he comes up with the following ugly code. *)

Fixpoint filtrev T (p : pred T) (acc : seq T) (l : seq T) : seq T :=
  if l is x :: xs then
    if p x then filtrev p (x :: acc) xs
           else filtrev p       acc  xs
  else acc.

(**  The teacher asks him to prove that his ugly code is equivalent
 to the nicer code [[seq x <- rev l | p x]] he could have written
by reusing the seq library.

Such proof is not trivial:
  - [filtrev] has an accumulator, [rev] (at least apparently)
    does not.
  - which is the invariant linking the accumulator [acc] and [p]
    in the code of [filtrev]?  Depending on how you expose
    the accumulator on the right hand side of the goal,
    such invariant may need to be taken into account by the induction.

Relevant keywords for [Search] are: rev cons cat filter rcons
Hint: it is perfectly fine to state intermediate lemmas
*)

Lemma filterrev_ok T p (l : seq T) :
  filtrev p [::] l = [seq x <- rev l | p x ].
Proof.
(*X*)rewrite -[RHS]cats0; elim: l [::] => [|x l ihl] l' //=.
(*X*)by case: ifP => px; rewrite ihl rev_cons filter_rcons ?px ?cat_rcons.
(*A*)Qed.

(** Prove that if (s1 :|: s2) is disjoint from (s1 :|: s3) then
    s1 is empty *)
Lemma disjoint_setU2l (T : finType) (s1 s2 s3 : {set T}) :
   [disjoint s1 :|: s2 & s1 :|: s3] -> s1 = set0.
(*A*)Proof. by rewrite -setI_eq0 -setUIr setU_eq0 => /andP [/eqP]. Qed.

(** Prove the equivalence of these two sums.
    E.g. (n=8)
<<
    1 + 3 + 5 + 7 = 7-0 + 7-2 + 7-4 + 7-6
>>
*)
Lemma sum_odd n :
  ~~ odd n -> \sum_(i < n | odd i) i = \sum_(i < n | ~~ odd i) (n.-1 - i).
Proof.
(*X*)rewrite (reindex_inj rev_ord_inj) /= => /negPf n_oddF.
(*X*)by apply: eq_big => i; rewrite odd_sub ?n_oddF //; case: n i {n_oddF}.
(*A*)Qed.
(**

Now, some algebra.

*)
From mathcomp Require Import all_algebra.
From mathcomp Require Import algC zmodp.

Section AlgebraicHierarchy.
Section GaussIntegers.
Import GRing.Theory Num.Theory.
Local Open Scope ring_scope.
(**

We remind what Gauss integer are and recall some theory about it.

*)
Definition gaussInteger := [qualify a x | ('Re x \in Cint) && ('Im x \in Cint)].
Axiom Cint_GI : forall (x : algC), x \in Cint -> x \is a gaussInteger.
Axiom GI_subring : subring_closed gaussInteger.

Fact GI_key : pred_key gaussInteger. Proof. by []. Qed.
Canonical GI_keyed := KeyedQualifier GI_key.
Canonical GI_opprPred := OpprPred GI_subring.
Canonical GI_addrPred := AddrPred GI_subring.
Canonical GI_mulrPred := MulrPred GI_subring.
Canonical GI_zmodPred := ZmodPred GI_subring.
Canonical GI_semiringPred := SemiringPred GI_subring.
Canonical GI_smulrPred := SmulrPred GI_subring.
Canonical GI_subringPred := SubringPred GI_subring.

Record GI := GIof {algGI : algC; algGIP : algGI \is a gaussInteger }.
Hint Resolve algGIP.

Canonical GI_subType := [subType for algGI].
Definition GI_eqMixin := [eqMixin of GI by <:].
Canonical GI_eqType := EqType GI GI_eqMixin.
Definition GI_choiceMixin := [choiceMixin of GI by <:].
Canonical GI_choiceType := ChoiceType GI GI_choiceMixin.
Definition GI_countMixin := [countMixin of GI by <:].
Canonical GI_countType := CountType GI GI_countMixin.
Definition GI_zmodMixin := [zmodMixin of GI by <:].
Canonical GI_zmodType := ZmodType GI GI_zmodMixin.
Definition GI_ringMixin := [ringMixin of GI by <:].
Canonical GI_ringType := RingType GI GI_ringMixin.
Definition GI_comRingMixin := [comRingMixin of GI by <:].
Canonical GI_comRingType := ComRingType GI GI_comRingMixin.

Lemma conjGIE x : (x^* \is a gaussInteger) = (x \is a gaussInteger).
Proof. by rewrite ![_ \is a _]qualifE algRe_conj algIm_conj rpredN. Qed.

Fact conjGI_subproof (x : GI) : (val x)^* \is a gaussInteger.
Proof. by rewrite conjGIE. Qed.

Canonical conjGI x := GIof (conjGI_subproof x).

Definition gaussNorm (x : algC) := x * x^*.

Axiom gaussNormE : forall x, gaussNorm x = `|x| ^+ 2.
Axiom gaussNormCnat : forall (x : GI), gaussNorm (val x) \in Cnat.
(**

Prove these two facts. (Hint: conjugation is a morphism)

*)
Lemma gaussNorm1 : gaussNorm 1 = 1.
(*A*)Proof. by rewrite /gaussNorm rmorph1 mulr1. Qed.

Lemma gaussNormM : {morph gaussNorm : x y / x * y}.
(*A*)Proof. by move=> x y; rewrite /gaussNorm rmorphM mulrACA. Qed.
(**

** Question: Prove that GI euclidean for the stasm gaussNorm.

 - i.e. ∀ (a, b) ∈ GI × GI*, ∃ (q, r) ∈ GI² s.t. a = q b + r and φ(r) < φ(b)
 - Suggested strategy: sketch the proof on a paper first, don't let Coq
   divert you from your proofsketch
 - We first sketch the "paper proof" here and then do it in Coq:
  - take a / b = x + i y
  - take u the closest integer to x, and v the closest integer to y
  - satisfy the existential with q = u + i v and r = a - q b,
    which are both Gauss integers.
  - We want to show that |a - q b|² < |b|².
  - It suffices to show |a / b - q|² < 1
  - But |a / b - q|² = (u - x)² + (v - x)² ≤ ½² + ½² < 1
 - Now we give a Coq proof with holes, fill in the holes.
*)
Lemma euclideanGI (a b : GI) : b != 0 ->
  exists2 qr : GI * GI, a = qr.1 * b + qr.2
                      & (gaussNorm (val qr.2) < gaussNorm (val b)).
Proof.
move=> b_neq0.

(* Trivial preliminaries *)
have oneV2 : 1 = 2%:R^-1 + 2%:R^-1 :> algC.
  by rewrite -mulr2n -[_ *+ 2]mulr_natr mulVf ?pnatr_eq0.
have V2ge0 : 0 <= 2%:R^-1 :> algC by (*a*)rewrite invr_ge0 ler0n.
have V2real : (2%:R^-1 : algC) \is Num.real by (*a*)rewrite realE V2ge0.

(* Closest integer to x, when x is real *)
pose approx (x : algC) : int :=
  floorC x + (if `|x - (floorC x)%:~R| <= 2%:R^-1 then 0 else 1).
have approxP x : x \is Creal -> `|x - (approx x)%:~R| <= 2%:R^-1.
  rewrite /approx => x_real; have /andP [x_ge x_le] := floorC_itv x_real.
  have [] // := @real_lerP _  `|_ - (floorC _)%:~R| _;
    first by rewrite addr0.
  rewrite [`|_ - (_ + 1)%:~R|]distrC !ger0_norm ?subr_ge0 //=;
     last by rewrite ltrW.
  move=> Dx1_gtV2; rewrite real_lerNgt ?rpredB // ?Creal_Cint ?Cint_int //.
  apply/negP=> /ltr_add /(_ Dx1_gtV2); rewrite -oneV2 !addrA addrNK.
  by rewrite [_ + 1]addrC rmorphD /= addrK ltrr.
have approxP2 x (_ : x \is Creal) : `|x - (approx x)%:~R| ^+ 2 < 2%:R^-1.
  rewrite (@ler_lt_trans _ (2%:R^-1 ^+ 2)) // ?ler_expn2r ?qualifE ?approxP //.
  by rewrite exprVn -natrX ltf_pinv ?qualifE ?ltr_nat ?ltr0n.

(* Proper proof *)
pose u := 'Re (val a / val b); pose v := 'Im (val a / val b).
have qGI : (approx u)%:~R + algCi * (approx v)%:~R \is a gaussInteger.
  (* Hint: use qualifE, alg*_rect and lemmas about Creal, Cint and _%:~R *)
  (*a*)by rewrite qualifE /= algRe_rect ?algIm_rect // ?Creal_Cint ?Cint_int.
pose q := GIof qGI.
exists (q, a - q * b); first by rewrite addrC addrNK.
rewrite !gaussNormE /=.
rewrite -(@ltr_pmul2r _ (`|val b| ^-2)) ?invr_gt0 ?exprn_gt0 ?normr_gt0 //.
rewrite mulfV ?expf_eq0 /= ?normr_eq0 // -exprVn -exprMn.
rewrite -normfV -normrM mulrBl mulfK //.
suff uvP : `|u - (approx u)%:~R + 'i * (v - (approx v)%:~R)| ^+ 2 < 1.
  (* Hint: use algCrect and algebraic transformations *)
  (*a*)by rewrite [X in X - _]algCrect opprD addrACA -mulrBr.
set Du := _ - _; set Dv := _ - _.
have /andP [DuReal DvReal] : (Du \is Creal) && (Dv \is Creal).
(* Hint: use rpred*, Creal_*, normC2_rect, ream_normK and approxP2 *)
(*a*)  by rewrite ?rpredB ?Creal_Re ?Creal_Im ?Creal_Cint ?Cint_int.
(*X*)rewrite normC2_rect // oneV2.
(*X*)by rewrite ltr_add // -real_normK // approxP2 ?Creal_Re ?Creal_Im.
(*A*)Qed.

End GaussIntegers.
End AlgebraicHierarchy.

Section PolynomialsLagrange.

Open Scope ring_scope.
Import GRing.Theory Num.Theory.
(**

Definition and properties of lagrange polynomials.

Prove only one of the following lemmas
*)
Variables (n : nat) (x : algC ^ n).

Definition lagrange (i : 'I_n) : {poly algC} :=
  let p := \prod_(j < n | j != i) ('X - (x j)%:P) in (p.[x i]^-1)%:P * p.

Hypothesis n_gt0 : (0 < n)%N.
Hypothesis x_inj : injective x.

Lemma lagrangeE (i j : 'I_n) : (lagrange i).[x j] = (i == j)%:R.
Proof using x_inj.
(*X*)rewrite /lagrange hornerM hornerC; set p := (\prod_(_ < _ | _) _).
(*X*)have [<-|neq_ij] /= := altP eqP.
(*X*)  rewrite mulVf // horner_prod; apply/prodf_neq0 => k neq_ki.
(*X*)  by rewrite hornerXsubC subr_eq0 inj_eq // eq_sym.
(*X*)rewrite [X in _ * X]horner_prod (bigD1 j) 1?eq_sym //=.
(*X*)by rewrite hornerXsubC subrr mul0r mulr0.
(*A*)Qed.

Lemma size_lagrange i : size (lagrange i) = n.
Proof using n_gt0 x_inj.
(*X*)rewrite size_Cmul; last first.
(*X*)  suff : (lagrange i).[x i] != 0 by rewrite hornerE mulf_eq0 => /norP [].
(*X*)  by rewrite lagrangeE ?eqxx ?oner_eq0.
(*X*)rewrite size_prod /=; last first.
(*X*)  by move=> j neq_ji; rewrite polyXsubC_eq0.
(*X*)rewrite (eq_bigr (fun=> (2 * 1)%N)); last first.
(*X*)  by move=> j neq_ji; rewrite size_XsubC.
(*X*)rewrite -big_distrr /= sum1_card cardC1 card_ord /=.
(*X*)by case: (n) {i} n_gt0 => ?; rewrite mul2n -addnn -addSn addnK.
(*A*)Qed.

Lemma lagrange_free (lambda : 'rV_n):
  \sum_i (lambda 0 i)%:P * lagrange i = 0 -> lambda = 0.
Proof using x_inj.
(*X*)move=> eq_l; apply/rowP=> i; rewrite mxE.
(*X*)have /(congr1 (fun p => p.[x i])) := eq_l.
(*X*)rewrite horner_sum horner0 (bigD1 i) //= hornerE lagrangeE // eqxx mulr1.
(*X*)rewrite big1 ?addr0 // => j neq_ji.
(*X*)by rewrite hornerM lagrangeE // (negPf neq_ji) mulr0.
(*A*)Qed.

Lemma lagrange_gen (p : {poly algC}) :
   (size p <= n)%N -> p = \sum_i p.[x i]%:P * lagrange i.
Proof using n_gt0 x_inj.
(*X*)(* fancy proof using marix spaces *)
(*X*)move=> sp_le_n; pose L := \matrix_(i < n) @poly_rV _ n (lagrange i).
(*X*)suff /(congr1 rVpoly) : poly_rV p = \row_i p.[x i] *m L.
(*X*)  rewrite poly_rV_K // => {1}->; rewrite mulmx_sum_row raddf_sum /=.
(*X*)  apply: eq_bigr=> i _; rewrite linearZ /= mxE mul_polyC.
(*X*)  by rewrite rowK poly_rV_K ?size_lagrange.
(*X*)have /submxP [u puL]: (poly_rV p <= L)%MS.
(*X*)  rewrite (submx_trans (submx1 _)) // sub1mx row_full_unit -row_free_unit.
(*X*)  rewrite -kermx_eq0; apply/rowV0P => v /sub_kermxP.
(*X*)  move=> /(congr1 rVpoly); rewrite !raddf0 mulmx_sum_row raddf_sum /= => vL0.
(*X*)  rewrite [v]lagrange_free // -[RHS]vL0; apply: eq_bigr => i _.
(*X*)  by rewrite linearZ rowK mul_polyC /= poly_rV_K ?size_lagrange.
(*X*)rewrite puL; congr (_ *m _); apply/rowP=> i; rewrite mxE.
(*X*)have /(congr1 (fun v => (rVpoly v).[x i])) := puL.
(*X*)rewrite poly_rV_K // mulmx_sum_row raddf_sum /=.
(*X*)rewrite (bigD1 i) //= linearZ /= rowK poly_rV_K ?size_lagrange //.
(*X*)rewrite 2!hornerE lagrangeE eqxx mulr1 horner_sum big1 ?addr0 //.
(*X*)move=> j neq_ji; rewrite linearZ rowK /= ?poly_rV_K ?size_lagrange //.
(*X*)by rewrite hornerZ lagrangeE (negPf neq_ji) mulr0.

(*X*)Restart. (* shorter proof, direct *)

(*X*)move=> sp_le_n; apply/eqP; rewrite -subr_eq0; apply: contraTT isT.
(*X*)move=> /max_poly_roots - /(_ [seq x i | i <- enum 'I_n]).
(*X*)rewrite size_map size_enum_ord map_inj_uniq ?enum_uniq //.
(*X*)rewrite [(n < _)%N]negbTE; [apply=>//|rewrite -leqNgt].
(*X*)  apply/allP=> /= _ /imageP [/= i _ ->].
(*X*)  rewrite rootE !hornerE horner_sum (bigD1 i) //=.
(*X*)  rewrite hornerM hornerC lagrangeE // eqxx mulr1 opprD addNKr.
(*X*)  rewrite big1 ?oppr0 // => j neq_ji.
(*X*)  by rewrite hornerM lagrangeE // (negPf neq_ji) mulr0.
(*X*)rewrite (leq_trans (size_add _ _)) // size_opp geq_max sp_le_n /=.
(*X*)rewrite (leq_trans (size_sum _ _ _)) //; apply/bigmax_leqP=> j _.
(*X*)rewrite (leq_trans (size_mul_leq _ _)) // size_polyC size_lagrange //.
(*X*)by move: (n) n_gt0 (_ == _) => [] // ? _ [].
(*A*)Qed.

End PolynomialsLagrange.

Section PolynomialsTaylor.
(**
Taylor formula for polynomials

*)
Import GRing.Theory.
Open Scope ring_scope.
Variable R: idomainType.

(*X*)(* This is the strongest statement I could prove *)
(*X*)(* uses max_poly_roots and nderiv_taylor *)
(*X*)Lemma Taylor_formula_strong (p : {poly R}) (x : R) (rs : seq R) :
(*X*)  (size p <= size rs)%N -> uniq rs ->
(*X*)  p = \sum_ (i < size p) p^`N(i).[x] *: ('X - x%:P) ^+ i.
(*X*)Proof.
(*X*)move=> sprs /max_poly_roots prs; apply/eqP; rewrite -subr_eq0.
(*X*)apply: contraTT isT => /prs; rewrite [(_ < _)%N]negbTE; [apply|rewrite -leqNgt].
(*X*)  apply/allP=> y y_rs; rewrite rootE hornerD hornerN subr_eq0; apply/eqP.
(*X*)  rewrite -[y in X in p.[X]](addrNK x) [_ + x]addrC.
(*X*)  rewrite nderiv_taylor; last exact: mulrC.
(*X*)  by rewrite horner_sum; apply: eq_bigr=> i _; rewrite !(hornerE, horner_exp).
(*X*)rewrite (leq_trans (size_add _ _)) // geq_max sprs /= size_opp.
(*X*)rewrite (leq_trans (size_sum _ _ _)) //; apply/bigmax_leqP=> i _.
(*X*)rewrite (leq_trans (size_scale_leq _ _)) //.
(*X*)by rewrite size_exp_XsubC (leq_trans _ sprs).
(*X*)Qed.

(*X*)Lemma natr_injP (D : idomainType) :
(*X*)  (forall n, (n%:R == 0 :> D) = (n == 0)%N) <-> injective (@GRing.natmul D 1).
(*X*)Proof.
(*X*)split=> [natr_eq0 i j|natr_inj n]; last by rewrite -(inj_eq natr_inj).
(*X*)wlog: i j / (j <= i)%N => [hwlog|].
(*X*)  by have [/hwlog//|/ltnW/hwlog/(_ (esym _))/esym] := leqP j i.
(*X*)by move=> /subnK<- /eqP; rewrite -subr_eq0 natrD addrK natr_eq0 => /eqP->.
(*X*)Qed.

(*X*) (* This is the statement we ask the students to prove *)
Hypothesis charR_eq0 : [char R] =i pred0.
Lemma Taylor_formula (p : {poly R}) (x : R) :
  p = \sum_ (i < size p) p^`N(i).[x] *: ('X - x%:P) ^+ i.
(*X*)Proof. (* Proof using the stronger version *)
(*X*)apply: (@Taylor_formula_strong _ _ [seq i%:R | i <- iota 0 (size p)]).
(*X*)  by rewrite size_map size_iota.
(*X*)by rewrite map_inj_uniq ?iota_uniq //; apply/natr_injP/charf0P.
(*X*)
(*X*)Restart. (* Proof for the students *)
(*X*)
Proof.
wlog: p x / x = 0 => [hwlog|->]; rewrite ?subr0; last first.
(*X*)  transitivity (\poly_(i < size p) p^`N(i).[0]);
(*X*)    last by rewrite poly_def.
(*X*)  apply/polyP=> /= i; rewrite coef_poly.
(*X*)  have [i_small|i_big]:= ltnP; last by rewrite nth_default.
  (*a*)by rewrite horner_coef0 coef_nderivn addn0 binn mulr1n.
rewrite -[LHS](comp_polyXaddC_K _ x) -[RHS](comp_polyXaddC_K _ x).
congr (_ \Po _); rewrite [LHS](hwlog _ 0 erefl) ?subr0 [RHS]raddf_sum /=.
rewrite size_comp_poly2; last first.
  by rewrite -[x%:P as X in 'X + X]opprK -[- x%:P]raddfN /= size_XsubC.
(*X*)apply: eq_bigr => i _.
(*X*)have nderivn_compXD q (a : R) j :
(*X*)  (q \Po ('X + a%:P))^`N(j) = q^`N(j) \Po ('X + a%:P).
       have /charf0P/natr_injP natr_inj := charR_eq0.
(*X*)  apply: (@mulfI _ j`!%:R%:P).
(*X*)     rewrite polyC_eq0; have/charf0P -> := charR_eq0.
     (*a*)by rewrite -lt0n fact_gt0.
(*X*)  rewrite !mul_polyC !scaler_nat -rmorphMn /= -!nderivn_def.
  (*a*)by elim: j => //= j ->; rewrite deriv_comp !derivE addr0 mulr1.
(*X*)rewrite nderivn_compXD horner_comp !hornerE // linearZ rmorphX /=.
(*X*)rewrite -['X - x%:P]comp_polyX -[x%:P as X in 'X + X]opprK.
(*X*)by rewrite -[- x%:P]raddfN /= comp_polyXaddC_K.
(*A*)Qed.

End PolynomialsTaylor.

Section LinearAlgebra.
Import GRing.Theory Num.Theory.
Local Open Scope ring_scope.
(**

* Endomorphisms u such that Ker u ⊕ Im u = E.

The endomorphisms of a space E of finite dimension n, such that u o v
= 0 and v + u is invertible are exactly the endomorphisms such that
Ker u ⊕ Im u = E.

 - Assume u o v = 0 and v + u is invertible,
  - we have rank (v + u) = n
  - we have rank v + rank u = n and we have Im v ⊂ Ker u
  - Hence we have Im v = Ker u
  - We deduce that Ker u ⊕ Im u = Im v ⊕ Im u = E

*)
Variables (F : fieldType) (n' : nat).
Let n := n'.+1.

Lemma ex_6_13 (u : 'M[F]_n):
  reflect (exists2 v : 'M_n, v * u = 0 & v + u \is a GRing.unit)
          ((kermx u + u == 1)%MS && mxdirect (kermx u + u)).
Proof.
(* Hint: use mxrank* lemmas and search on addsmx, submx and eqmx
sometimes. Don't forget about mxdirect_addsP and sub_kermxP. *)
apply: (iffP idP) => [|[v vMu vDu]]; last first.
  have rkvDu: \rank (v + u)%R = n by (*a*)rewrite mxrank_unit.
  have /eqP rkvDrku : (\rank v + \rank u)%N == n.
    by rewrite eqn_leq; (*a*)rewrite mulmx0_rank_max //= -{1}rkvDu mxrank_add.
  have sub_v_ku : (v <= kermx u)%MS by (*a*)apply/sub_kermxP.
  have /eqmxP/eqmx_sym eq_vu: (v == kermx u)%MS.
    rewrite -(geq_leqif (mxrank_leqif_eq _)) //.
(*X*)    rewrite -(leq_add2r (\rank u)) rkvDrku.
    (*a*)by rewrite mxrank_ker subnK // rank_leq_row.
  rewrite submx1 sub1mx -col_leq_rank mxdirectEgeq /=.
  (* use adds_eqmx to lift eq_vu to a sum *)
(*X*)  rewrite eq_vu (adds_eqmx eq_vu (eqmx_refl _)).
  (* Warning: - (u + v)%R  is a sum of matrices
              - (u + v)%MS is a sum of spaces
     use addmx_sub_adds and mxrankS
     to compare the rank (u + v) with dim (Im u + Im v) *)
(*X*)  have /mxrankS leq_rk := addmx_sub_adds (submx_refl v) (submx_refl u).
  (* finish using hypothesis *)
  (*a*)by rewrite !(leq_trans _ leq_rk) //= ?rkvDu ?rkvDrku.
move=> /andP [/eqmxP kuDu_eq1 /mxdirect_addsP kvDu_direct].
pose v := proj_mx (kermx u) u; exists v.
  (*a*)by apply/sub_kermxP; rewrite -[X in (X <= _)%MS]mul1r proj_mx_sub.
rewrite -row_free_unit -kermx_eq0.
apply/negP => /negP /rowV0Pn [x /sub_kermxP]; rewrite mulmxDr.
move=> /(canRL (addrK _)); rewrite sub0r => eq_xv_Nxu.
apply/negP; rewrite negbK; apply/eqP.
have : (x *m v <= kermx u :&: u)%MS.
(* Hint: use sub_*, proj_mx*, eqmx_*, mxdirect_addsP, *)
  (*a*)by rewrite sub_capmx proj_mx_sub eq_xv_Nxu eqmx_opp submxMl.
(*X*)rewrite kvDu_direct ?submx0 // => /eqP xv_eq0.
(*X*)move/eqP : eq_xv_Nxu; rewrite xv_eq0 eq_sym oppr_eq0 => /eqP.
(*X*)by move=> /sub_kermxP x_in_keru; move: xv_eq0; rewrite proj_mx_id.
(*A*)Qed.

End LinearAlgebra.

(*X*)(*
(*X*)*** Local Variables: ***
(*X*)*** coq-prog-args: ("-emacs-U" "-R" "/Users/lrg/coq/math-comp/mathcomp" "mathcomp" "-I" "/Users/lrg/coq/math-comp/mathcomp" ) ***
(*X*)*** End: ***
(*X*)*)


(*begin hide*)
Require Import Bool Arith List CpdtTactics.
Set Implicit Arguments.
(*end hide*)

(** * Inductive Predicates

Curry-Howard correspondence states formal connection between
functional programs and mathematical proofs. The definitions of [True]
and [unit] help clarify:*)

Print unit.
(**
[[
Inductive unit : Set :=  tt : unit
]]
*)

Print True.
(**
[[
Inductive True : Prop :=  I : True
]]

Specifically, one is a type with a single value, and the other is a
proposition that always holds; the same induction principle can be
used for both. Substituting names gives the same definition, but the
type is the distinguisher: [T] of type [Set] is a type of programs,
while [T] of type [Prop] is a logical proposition. Understanding why
the distinction is made helps to avoid conflating programming and
proving.

Engineering-wise, not all functions of type [A->B] are equally
constructed, but all proofs of the proposition [P->Q] are (_proof
irrelevance_). We program by applying functional programming
techniques to dependent types, and prove by writing custom decision
procedures.

** Propositional Logic*)

Section Propositional.
  Variables P Q R : Prop.

(** The most basic propositional construct is [->], implies. It's built into
Coq as the function type constructor.

The trivial proof of [True]:*)

  Theorem obvious: True.
  Proof.
    apply I.
  Qed.

(** [apply] is a tactic allowing us to use a particular constructor of
the inductive predicate being established. A shortcut:*)

  Theorem obvious': True.
  Proof.
    constructor.
  Qed.

(** The predicate [False] is the Curry-Howard mirror of [Empty_set]: *)

  Print False.

(**
[[
Inductive False : Prop :=
]]

Doing case analysis on a proof of [False] has no cases:*)

  Theorem False_imp: False -> 2 + 2 = 5.
  Proof. destruct 1. Qed.

(** No proof of [False] can be constructed in a consistent contex.*)

  Theorem arith_neq: 2 + 2 = 5 -> 9 + 9 = 835.
  Proof. intro. elimtype False. crush. Qed.

(** Related is logical negation:*)

  Print not.
(**
[[
not = fun A : Prop => A -> False
     : Prop -> Prop

Argument scope is [type_scope]
]]

The syntax [~P] expands to [not P].
*)

  Theorem arith_neq': ~(2 + 2 = 5).
  Proof. unfold not. crush. Qed.

(** Conjunction:*)

  Print and.
(**
[[
Inductive and (A B : Prop) : Prop :=  conj : A -> B -> A /\ B

For conj: Arguments A, B are implicit
For and: Argument scopes are [type_scope type_scope]
For conj: Argument scopes are [type_scope type_scope _ _]
]]

[and] has a Curry-Howard equivalent [prod].

We can reason about conjunction with tactics; for example, through an
explicit proof of commutivity: *)

  Theorem and_comm: P /\ Q -> Q /\ P.
  Proof.
    destruct 1. split.
    assumption. assumption. (* for each case, conclusion is among hypotheses. *)
  Qed.

(** Disjunction occurs via [or]:*)

  Print or.

(**
[[
Inductive or (A B : Prop) : Prop :=
    or_introl : A -> A \/ B | or_intror : B -> A \/ B

For or_introl, when applied to less than 1 argument:
  Arguments A, B are implicit
For or_introl, when applied to 2 arguments:
  Argument A is implicit
For or_intror, when applied to less than 1 argument:
  Arguments A, B are implicit
For or_intror, when applied to 2 arguments:
  Argument B is implicit
For or: Argument scopes are [type_scope type_scope]
For or_introl: Argument scopes are [type_scope type_scope _]
For or_intror: Argument scopes are [type_scope type_scope _]
]]

There are two ways to prove a disunction: prove the first disjunct or prove the second. (The Curry-Howard analogue is the [sum] type.)
*)

  Theorem or_comm: P \/ Q -> Q \/ P.
  Proof.
    destruct 1.
    right; assumption. (*Prove disjunction by proving the right disjunct.*)
    left; assumption.
  Qed.

(** The [tauto] tactic is a complete decision procedure for
constructive propositional logic. [intuition] is a generalisation of
[tauto] proving everything it can through propositional
reasoning. Consider:*)

  Theorem arith_comm: forall ls1 ls2 : list nat,
          length ls1 = length ls2 \/ length ls1 + length ls2 = 6 ->
          length (ls1 ++ ls2) = 6 \/ length ls1 = length ls2.
  Proof.
    intuition.
    rewrite app_length.
    tauto.
  Qed.

(** Each of these theorems becomes universally quantified over the
propositional variables.*)

End Propositional.


Require Import Coq.Lists.List.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Classes.EquivDec.
Require Import Coq.omega.Omega.
Require Import Coq.Init.Nat.
Import Coq.Lists.List.ListNotations.

Require Import BWT.Lib.Permutation.
Require Import BWT.Lib.Sumbool.
Require Import BWT.Lib.List.
Require Import BWT.Lib.FindIndex.
Require Import BWT.Sorting.StablePerm.

Definition PermFun (n : nat) (p : list nat) : Prop :=
    NoDup p /\ forall i, In i p <-> i < n.

Remark PermFun_0 : forall p,
    PermFun 0 p <-> p = [].
Proof.
  split; intros Hp; [|subst p; split; [constructor|easy]].
  destruct p as [|i p]; [easy|].
  exfalso; apply (Nat.nlt_0_r i).
  apply Hp; left; easy.
Qed.

Remark PermFun_nil : forall n,
    PermFun n [] <-> n = 0.
Proof.
  split; intros Hp; [|subst n; split; [constructor|easy]].
  destruct n; [easy|].
  destruct Hp as [_ Hp].
  specialize (Hp 0); cbn in Hp.
  exfalso; apply Hp.
  apply Nat.lt_0_succ.
Qed.

Remark PermFun_S_nil : forall n,
    ~ PermFun (S n) [].
Proof.
  intros n c.
  remember (S n) as n'.
  apply PermFun_nil in c.
  subst; discriminate.
Qed.

Theorem PermFun_Permutation_seq : forall n p,
    PermFun n p <-> Permutation p (seq 0 n).
Proof.
  split.
  - intros [HND Hp].
    apply NoDup_Permutation; [easy|apply seq_NoDup|].
    intros i; specialize (Hp i).
    rewrite (in_seq n 0 i); cbn.
    intuition.
  - intros HP.
    split; [eapply Permutation_NoDup; [symmetry; eauto|apply seq_NoDup]|].
    split.
    + intros HIn. apply (in_seq n 0 i).
      eapply Permutation_in; eauto.
    + intros HB. eapply Permutation_in; [symmetry; apply HP|].
      apply in_seq. omega.
Qed.

Theorem PermFun_range : forall p i n,
    PermFun n p -> In i p -> i < n.
Proof. intros p i n [_ Hp]. apply Hp. Qed.

Theorem PermFun_length : forall p n,
    PermFun n p -> length p = n.
Proof.
  intros p n Hp.
  apply PermFun_Permutation_seq in Hp.
  apply Permutation_length in Hp.
  rewrite seq_length in Hp.
  easy.
Qed.

Section Image.
  Context {A : Type}.

  Definition image (p : list nat) i := nth i p 0.
  Definition preimage (p : list nat) i := findIndex i p.

  Variables (p : list nat) (n :nat).

  Hypothesis HP : PermFun n p.

  Lemma PermFun_i_exists : forall i,
      i < n -> Exists (equiv i) p.
  Proof.
    intros i HI.
    eapply Permutation_exists;
      [symmetry; apply PermFun_Permutation_seq with (n := n); easy|].
    apply Exists_exists.
    exists i. split; [|easy].
    apply in_seq; omega.
  Qed.

  Theorem preimage_image : forall i,
      i < n -> preimage p (image p i) = i.
  Proof.
    intros i HI.
    unfold image, preimage.
    rewrite findIndex_nth;
      [.. |apply HP |erewrite PermFun_length by apply HP]; easy.
  Qed.

  Theorem image_preimage : forall i,
      i < n -> image p (preimage p i) = i.
  Proof.
    intros i HI.
    unfold image, preimage.
    rewrite findIndex_correct by (eapply PermFun_i_exists; omega).
    reflexivity.
  Qed.

  Theorem image_inj : forall i j,
      i < n -> j < n -> image p i = image p j -> i = j.
  Proof.
    intros i j HI HJ HE.
    apply (NoDup_nth p 0); [|erewrite PermFun_length by apply HP..|]; [|easy..].
    apply HP.
  Qed.

  Theorem preimage_inj : forall i j,
      i < n -> j < n ->
      preimage p i = preimage p j -> i = j.
  Proof.
    intros i j HI HJ HE.
    unfold preimage in HE.
    apply f_equal with (f := fun x => nth x p 0) in HE.
    rewrite !findIndex_correct in HE by (eapply PermFun_i_exists; easy).
    easy.
  Qed.

  Theorem image_bound : forall i,
      i < n -> image p i < n.
  Proof.
    intros i HI.
    apply PermFun_range with (p := p); [easy|].
    apply nth_In.
    rewrite PermFun_length with (n := n) by easy.
    easy.
  Qed.

  Theorem preimage_bound : forall i,
      i < n -> preimage p i < n.
  Proof.
    intros i HI.
    rewrite <- PermFun_length with (p := p) by easy.
    apply findIndex_bounds.
    eapply PermFun_i_exists; easy.
  Qed.
End Image.

Section Apply.
  Context {A : Type}.

  Implicit Types (p : list nat) (l : list A).

  Definition apply p l : list A :=
    match l with
    | [] => []
    | d :: _ => map (fun i => nth i l d) p
    end.

  Theorem apply_def : forall p l d,
      PermFun (length l) p ->
      apply p l = map (fun i => nth i l d) p.
  Proof.
    intros p [|h t] d HP.
    - apply PermFun_0 in HP; subst; easy.
    - cbn [apply]. apply map_ext_in.
      intros; apply nth_indep.
      apply (PermFun_range p); easy.
  Qed.

  Theorem nth_preimage_apply : forall p i l d,
      PermFun (length l) p -> i < length l ->
      nth (preimage p i) (apply p l) d = nth i l d.
  Proof.
    intros p i l d HP HI.
    rewrite apply_def with (d := d) by easy.
    unfold preimage.
    assert (E : Exists (equiv i) p)
      by (eapply PermFun_i_exists; [apply HP|easy]).
    assert (In (findIndex i p) p). {
      eapply Permutation_in; [symmetry; apply PermFun_Permutation_seq; eauto|].
      apply in_seq.
      pose proof (findIndex_bounds i p E).
      erewrite PermFun_length in H by apply HP.
      omega.
    }
    rewrite nth_indep with (d := d) (d' := nth 0 l d)
      by (apply PermFun_range with (p := p);
          [erewrite map_length, PermFun_length|]; [apply HP..|easy]).
    rewrite map_nth with (f := (fun i0 : nat => nth i0 l d)).
    rewrite findIndex_correct by easy.
    reflexivity.
  Qed.

  Theorem nth_image_apply : forall p i l d,
      PermFun (length l) p -> i < length l ->
      nth (image p i) l d = nth i (apply p l) d.
  Proof.
    intros p i l d HP HI.
    rewrite <- preimage_image with (i := i) (p := p) (n := length l) at 2 by easy.
    rewrite nth_preimage_apply; [..|apply image_bound]; [|easy..].
    reflexivity.
  Qed.

  Theorem map_seq_id : forall l d,
      map (fun x : nat => nth x l d) (seq 0 (length l)) = l.
  Proof.
    induction l; intros d; [easy|].
    cbn [length seq map]; f_equal.
    rewrite <- seq_shift, map_map.
    apply IHl.
  Qed.

  Theorem apply_id : forall l,
      apply (seq 0 (length l)) l = l.
  Proof.
    destruct l; [easy|].
    apply map_seq_id with (d := a).
  Qed.

  Section RemPermFun.
    Definition rem_PermFun i := map (fun j => if lt_dec i j then pred j else j).

    Theorem rem_PermFun_0 : forall p n, PermFun n (0 :: p) -> rem_PermFun 0 p = map pred p.
    Proof.
      induction p; intros n HP; [easy|].
      unfold rem_PermFun. apply map_ext_in.
      intros x HIn.
      assert (1 <= x). {
        apply PermFun_Permutation_seq in HP.
        destruct n;
          [symmetry in HP; apply Permutation_nil in HP; inversion HP|cbn in HP].
        apply (in_seq n 1 x).
        eapply Permutation_in; [eapply Permutation_cons_inv; apply HP|easy].
      }
      destruct (lt_dec 0 x); omega.
    Qed.

    Theorem rem_PermFun_NoDup : forall p i,
        NoDup p -> ~ In i p -> NoDup (rem_PermFun i p).
    Proof.
      intros p i ND.
      induction ND; intros NIn; [constructor|].
      cbn. destruct (lt_dec i x) as [HLt | HGe].
      - rewrite not_in_cons in NIn.
        destruct NIn as [HNeq Nin].
        apply NoDup_cons; [|apply IHND; apply Nin].
        unfold rem_PermFun. rewrite in_map_iff.
        destruct x; [omega|cbn in *].
        intros [y [Hy HIn]].
        destruct (lt_dec i y).
        + destruct y; [omega|cbn in *].
          subst. contradiction.
        + subst.
          assert (i = x) by omega; subst.
          contradiction.
      - rewrite not_in_cons in NIn.
        destruct NIn as [HNeq Nin].
        apply NoDup_cons; [|apply IHND; apply Nin].
        unfold rem_PermFun. rewrite in_map_iff.
        intros [y [Hy HIn]].
        destruct (lt_dec i y).
        + destruct y; [omega|cbn in *].
          subst. omega.
        + subst. contradiction.
    Qed.

    Theorem rem_PermFun_preserve : forall p i n,
        PermFun (S n) (i :: p) ->
        PermFun n (rem_PermFun i p).
    Proof.
      intros p i n Hp.
      rewrite PermFun_Permutation_seq.
      pose proof (proj1 (PermFun_Permutation_seq (S n) (i :: p)) Hp) as P.
      apply NoDup_Permutation; [|apply seq_NoDup|].
      - symmetry in P; apply Permutation_NoDup in P; [|apply seq_NoDup].
        apply NoDup_cons_iff in P.
        apply rem_PermFun_NoDup; easy.
      - intro x; split; intros HIn.
        + apply in_seq; split; [omega|cbn].
          unfold rem_PermFun in HIn.
          apply in_map_iff in HIn.
          destruct HIn as [y [Hy HIn]].
          assert (y < S n)
            by (apply PermFun_range with (p := i :: p); [|right]; easy).
          assert (i < S n)
            by (apply PermFun_range with (p := i :: p); [|left]; easy).
          assert (y <> i). {
            intro c; subst. clear -HIn P.
            symmetry in P; apply Permutation_NoDup in P; [|apply seq_NoDup].
            apply NoDup_cons_iff in P.
            destruct P; contradiction.
          }
          destruct (Nat.eq_dec y n); [subst; rewrite if_true; omega|].
          destruct (lt_dec i y); omega.
        + unfold rem_PermFun; rewrite in_map_iff.
          destruct (Nat.eq_dec i n). {
            subst. apply seq_last_perm in P.
            exists x. rewrite if_false by (apply in_seq in HIn; omega).
            split; [easy|].
            eapply Permutation_in; [symmetry; apply P|easy..].
          }
          destruct (le_lt_dec i x).
          * exists (S x).
            rewrite if_true by omega.
            split; [easy|].
            eapply or_ind with (A := i = S x); [omega|intro H; exact H|].
            eapply Permutation_in with (l' := i :: p);
              [symmetry; apply P|].
            apply in_seq in HIn.
            apply in_seq. omega.
          * exists x.
            rewrite if_false by omega.
            split; [easy|].
            assert (x < n) by (apply in_seq in HIn; easy).
            eapply or_ind with (A := i = x); [omega|intro R; exact R|].
            eapply Permutation_in with (l' := i :: p);
              [symmetry; apply P|].
            apply in_seq in HIn.
            apply in_seq. omega.
    Qed.

    Theorem rem_PermFun_correct : forall l i p d,
        PermFun (length l) (i::p) ->
        apply (i::p) l = nth i l d :: apply (rem_PermFun i p) (rem_nth i l).
    Proof.
      intros.
      assert (length l > 0). {
        apply PermFun_length in H.
        cbn in H. destruct l; cbn in *; omega.
      }
      assert (~ In i p) by (apply NoDup_cons_iff; apply H).
      rewrite apply_def with (d := d) by easy.
      cbn [map]. f_equal.
      rewrite apply_def with (d := d)
        by (apply rem_PermFun_preserve;
            rewrite rem_nth_length
              by (apply PermFun_range with (p := i :: p); [easy|left; easy]);
            rewrite <- S_pred_pos by omega;
            easy).
      unfold rem_PermFun. rewrite map_map.
      apply map_ext_in.
      intros j HIn.
      assert (i <> j) by (intro c; subst; contradiction).
      destruct (lt_dec i j).
      - rewrite nth_ge_rem_nth by omega.
        destruct j; easy.
      - assert (i > j) by omega. rewrite nth_lt_rem_nth by easy; easy.
    Qed.
  End RemPermFun.

  Theorem apply_correct : forall p l,
      PermFun (length l) p -> Permutation (apply p l) l.
  Proof.
    intros p l.
    remember (length l) as n.
    revert p l Heqn.
    induction n as [|n IH]; intros p l HN HP.
    - symmetry in HN; apply length_zero_iff_nil in HN; subst.
      apply PermFun_0 in HP; subst.
      reflexivity.
    - destruct l as [|a l]; [inversion HN|].
      destruct p as [|i p]; [apply PermFun_S_nil in HP; contradiction|].
    rewrite rem_PermFun_correct with (d := a) by (rewrite <- HN; easy).
    assert (i < length (a :: l))
      by (apply PermFun_range with (p := i :: p); [rewrite <- HN|left]; easy).
    etransitivity;
      [apply perm_skip|symmetry; apply rem_nth_Perm; easy].
    apply IH; [|apply rem_PermFun_preserve; easy].
    rewrite rem_nth_length by easy. cbn in *; omega.
  Qed.

  Theorem apply_length : forall p l,
      PermFun (length l) p -> length (apply p l) = length l.
  Proof.
    intros.
    destruct l as [|d t] eqn:HL; [easy|rewrite <- HL in *; clear HL t].
    rewrite apply_def with (d := d) by easy.
    apply PermFun_length in H.
    rewrite map_length. easy.
  Qed.

  Theorem apply_map : forall p l f,
      PermFun (length l) p ->
      apply p (map f l) = map f (apply p l).
  Proof.
    intros p l f Hp.
    destruct l as [|d t] eqn:HL; [easy|]; rewrite <- HL in *; clear t HL.
    rewrite !apply_def with (d := d) by (rewrite ?map_length; easy).
    rewrite map_map.
    apply map_ext_in.
    intros x Hx.
    rewrite nth_indep with (d' := f d)
      by (rewrite map_length; eapply PermFun_range; [apply Hp|apply Hx]).
    rewrite map_nth. easy.
  Qed.
End Apply.

Section Compose.
  Implicit Types (p : list nat).

  Definition compose p2 p1 := apply p2 p1.

  Remark compose_length : forall n p1 p2,
      PermFun n p1 -> PermFun n p2 -> length (compose p1 p2) = n.
  Proof.
    intros n p1 p2 HP1 HP2.
    apply PermFun_length in HP2; subst.
    apply apply_length. easy.
  Qed.

  Remark compose_preserve : forall n p1 p2,
      PermFun n p1 -> PermFun n p2 ->
      PermFun n (compose p1 p2).
  Proof.
    intros n p1 p2 HP1 HP2.
    apply PermFun_Permutation_seq.
    transitivity p2; [|apply PermFun_Permutation_seq; easy].
    apply apply_correct.
    erewrite PermFun_length by apply HP2.
    easy.
  Qed.

  Theorem compose_id_l : forall p n,
      PermFun n p ->
      compose (seq 0 n) p = p.
  Proof.
    intros p n HP.
    apply PermFun_length in HP. subst.
    apply apply_id.
  Qed.

  Theorem compose_id_r : forall p n,
      PermFun n p ->
      compose p (seq 0 n) = p.
  Proof.
    intros p n HP.
    rewrite apply_def with (d := 0) by (rewrite seq_length; easy).
    rewrite <- map_id.
    apply map_ext_in.
    intros a HIn.
    apply seq_nth.
    eapply PermFun_range; [apply HP|easy].
  Qed.

  Theorem apply_combine {A B} : forall n p (l : list A) (r : list B),
      PermFun n p -> length l = n -> length r = n ->
      apply p (combine l r) = combine (apply p l) (apply p r).
  Proof.
    induction n; intros p l r HP HL HR.
    - apply PermFun_0 in HP.
      apply length_zero_iff_nil in HL.
      apply length_zero_iff_nil in HR.
      subst. reflexivity.
    - destruct p as [|i p]; [apply PermFun_S_nil in HP; contradiction|].
      destruct l as [|xl l]; [inversion HL|].
      destruct r as [|xr r]; [inversion HR|].
      rewrite rem_PermFun_correct with (d := (xl, xr))
        by (rewrite combine_length, HL, HR, Nat.min_id; easy).
      rewrite rem_PermFun_correct with (d := xl) by (rewrite HL; easy).
      rewrite rem_PermFun_correct with (d := xr) by (rewrite HR; easy).
      cbn [combine]; rewrite <- combine_nth by (rewrite HL, HR; easy).
      f_equal.
      rewrite <- IHn;
        [|apply rem_PermFun_preserve; easy|rewrite rem_nth_length; rewrite ?HL, ?HR..];
        [|easy| |easy|];
        [|apply PermFun_range with (p := i :: p); [|left]; easy..].
      rewrite <- rem_nth_combine; cbn [combine].
      reflexivity.
  Qed.

  Theorem compose_apply {A} : forall p1 p2 (l : list A),
      PermFun (length l) p1 -> PermFun (length l) p2 ->
      apply (compose p2 p1) l = apply p2 (apply p1 l).
  Proof.
    intros p1 p2 l HP1 HP2.
    destruct l as [|d t] eqn:HL; [easy|rewrite <- HL in *; clear t HL].
    remember (seq 0 (length l)) as I.
    remember (@combine nat A I l) as Z.
    assert (L: length Z = length l). {
      rewrite HeqZ, combine_length, HeqI, seq_length, Nat.min_id.
      easy.
    }
    assert (L1 : length p1 = length l) by (apply PermFun_length; easy).
    assert (L2 : length p2 = length l) by (apply PermFun_length; easy).
    assert (P1 : Permutation (apply p2 (apply p1 Z)) Z). {
      rewrite apply_correct; [|rewrite apply_length; rewrite L; easy].
      rewrite apply_correct; [reflexivity|rewrite L; easy].
    }
    assert (P2 : Permutation (apply (compose p2 p1) Z) Z). {
      rewrite apply_correct; [reflexivity|].
      rewrite L.
      apply compose_preserve; easy.
    }
    symmetry in P2; pose proof (Permutation_trans P1 P2) as P; clear P1 P2.
    rewrite HeqZ in P.
    rewrite !apply_combine with (n := length l) in P
      by (repeat (rewrite ?apply_length, ?L1,
                  ?HeqI, ?seq_length || apply compose_preserve); easy || omega).
    rewrite HeqI, !compose_id_r in P;
      [|apply compose_preserve|]; [|easy..].
    symmetry.
    apply (Permutation_combine_eq _ _ _ P);
      [repeat (rewrite ?apply_length, ?L1 || apply compose_preserve); easy..|].
    apply (compose_preserve (length l)); easy.
  Qed.
End Compose.

Section PermutationEx.
  Context {A : Type}.

  Implicit Type l : list A.

  Definition PermutationEx l l' : Prop :=
    exists p, PermFun (length l) p /\ apply p l = l'.

  Theorem PermutationEx_iff : forall l l',
      Permutation l l' <-> PermutationEx l l'.
  Proof.
    split;
      [|intros [p [Hp HA]]; subst; symmetry; apply apply_correct; easy].
    intros HP; induction HP.
    - exists []. split; [apply PermFun_0|]; easy.
    - destruct IHHP as [p [Hp HA]].
      exists (0 :: map S p). cbn [length apply]; split.
      + apply PermFun_Permutation_seq.
        cbn; apply perm_skip.
        rewrite <- seq_shift.
        apply Permutation_map.
        apply PermFun_Permutation_seq; easy.
      + cbn [map]. f_equal.
        rewrite apply_def with (d := x) in HA by easy.
        rewrite map_map. cbn. easy.
    - exists (1 :: 0 :: map (fun x => S (S x)) (seq 0 (length l))).
      split.
      + apply PermFun_Permutation_seq. cbn [length seq].
        rewrite <- map_map, !seq_shift.
        apply perm_swap.
      + cbn [apply map]; do 2 f_equal.
        rewrite map_map. cbn [nth].
        rewrite <- apply_def by (apply PermFun_Permutation_seq; reflexivity).
        apply apply_id.
    - destruct IHHP1 as [p1 [Hp1 HA1]].
      destruct IHHP2 as [p2 [Hp2 HA2]].
      assert (PermFun (length l) p2). {
        rewrite <- HA1 in Hp2.
        rewrite apply_length in Hp2 by easy.
        easy.
      }
      exists (compose p2 p1).
      split; [apply compose_preserve; easy|].
      rewrite compose_apply by easy.
      rewrite HA1, HA2.
      easy.
  Qed.
End PermutationEx.

Section Stable.
  Context {A} `{EqDec A}.

  Definition StablePermFun (l : list A) (p : list nat) :=
    PermFun (length l) p /\ forall i j d,
      nth i (apply p l) d === nth j (apply p l) d ->
      i < j < length l ->
      image p i < image p j.

  Definition StablePermFun_preimage (l : list A) (p : list nat) :=
    PermFun (length l) p /\ forall i j d,
      nth i l d === nth j l d ->
      i < j < length l ->
      preimage p i < preimage p j.

  Theorem StablePermFun_iff : forall l p,
      StablePermFun l p <-> StablePermFun_preimage l p.
  Proof.
    intros; split; (intros [HP HS]; split; [easy|]); intros i j d HE HIJ.
    - rewrite <- image_preimage with (i := i) (p := p) (n := length l) in HE
        by (omega || easy).
      rewrite <- image_preimage with (i := j) (p := p) (n := length l) in HE
        by (omega || easy).
      rewrite !nth_image_apply in HE by (try apply preimage_bound; omega || easy).
      apply Nat.nle_gt. intro c.
      destruct (le_lt_or_eq _ _ c) as [HLt|HEq];
        [|apply preimage_inj with (n := length l) in HEq; [omega|easy..|omega]].
      assert (c2 : ~ j < i) by omega. apply c2; clear c2.
      rewrite <- image_preimage with (i := i) (n := length l) (p := p)
        by (omega || easy).
      rewrite <- image_preimage with (i := j) (n := length l) (p := p)
        by (omega || easy).
      apply HS with (d := d); [easy|].
      split; [omega|].
      apply preimage_bound; [easy|omega].
    - rewrite <- preimage_image with (i := i) (p := p) (n := length l) in HE
        by (omega || easy).
      rewrite <- preimage_image with (i := j) (p := p) (n := length l) in HE
        by (omega || easy).
      rewrite !nth_preimage_apply in HE by (try apply image_bound; omega || easy).
      apply Nat.nle_gt. intro c.
      destruct (le_lt_or_eq _ _ c) as [HLt|HEq];
        [|apply image_inj with (n := length l) in HEq; [omega|easy..|omega]].
      assert (c2 : ~ j < i) by omega. apply c2; clear c2.
      rewrite <- preimage_image with (i := i) (n := length l) (p := p)
        by (omega || easy).
      rewrite <- preimage_image with (i := j) (n := length l) (p := p)
        by (omega || easy).
      apply HS with (d := d); [easy|].
      split; [omega|].
      apply image_bound; [easy|omega].
  Qed.

  Definition StablePermEx l l' :=
    exists p, StablePermFun l p /\ apply p l = l'.

  Theorem StablePermFun_nil : StablePermFun [] [].
  Proof.
    split; [apply PermFun_nil; easy|].
    intros i j d HE HIJ.
    cbn in HIJ. omega.
  Qed.

  Theorem StablePermFun_compose : forall p1 p2 l,
      StablePermFun l p1 -> StablePermFun (apply p1 l) p2 ->
      StablePermFun l (compose p2 p1).
  Proof.
    intros p1 p2 l [HP1 HS1] [HP2 HS2].
    rewrite apply_length in HP2 by easy.
    split; [apply compose_preserve; easy|].
    intros i j d HE HIJ.
    rewrite @apply_def with (d := 0)
      by (apply PermFun_length in HP1; rewrite HP1; easy).
    unfold image.
    rewrite nth_indep with (n := i) (d' := nth 0 p1 0)
      by (rewrite map_length; apply PermFun_length in HP2; omega).
    rewrite nth_indep with (n := j) (d' := nth 0 p1 0)
      by (rewrite map_length; apply PermFun_length in HP2; omega).
    rewrite !map_nth with (f := fun x => nth x p1 0).
    apply HS1 with (d := d).
    - rewrite compose_apply in HE by easy.
      rewrite @apply_def with (d := d) in HE
        by (rewrite apply_length; easy).
      rewrite nth_indep with (n := i) (d := d) (d' := nth j (apply p1 l) d) in HE
        by (rewrite map_length; apply PermFun_length in HP2; omega).
      rewrite !map_nth with (f := (fun i => nth i (apply p1 l) d)) in HE.
      rewrite nth_indep with (n := j) (d := d) (d' := nth j (apply p1 l) d) in HE
        by (rewrite map_length; apply PermFun_length in HP2; omega).
      rewrite !map_nth with (f := (fun i => nth i (apply p1 l) d)) in HE.
      rewrite !nth_indep with (d := 0) (d' := j)
        by (apply PermFun_length in HP2; omega).
      apply HE.
    - split; [|apply PermFun_range with (p := p2);
             [easy|apply nth_In; apply PermFun_length in HP2; omega]].
      apply HS2 with (d := d);
        [|rewrite apply_length; [omega|easy]].
      rewrite <- compose_apply by easy. easy.
  Qed.

  Theorem preimage_lt_rem_perm : forall p j i n,
      PermFun (S n) (i :: p) ->
      j < i -> preimage (rem_PermFun i p) j = pred (preimage (i :: p) j).
  Proof.
    intros p j i n HP HIJ.
    unfold preimage, rem_PermFun.
    cbn. rewrite if_false by (intro c; unfold equiv in c; omega).
    cbn.
    match goal with
    | |- context [findIndex ?j (map ?f ?l)] =>
      rewrite <- (findIndex_map f p)
    end; [|easy|fold (rem_PermFun i p)|].
    rewrite if_false by omega.
    easy.
    eapply rem_PermFun_preserve; apply HP.
    apply Exists_exists.
    exists j; split; [|easy].
    apply in_cons_neq with (y := i); [omega|].
    eapply Permutation_in; [symmetry; apply PermFun_Permutation_seq; apply HP|].
    apply in_seq.
    split; [omega|].
    transitivity i; [omega|].
    eapply PermFun_range; [apply HP|left]; easy.
  Qed.

  Theorem preimage_ge_rem_perm : forall p j i n,
      PermFun (S n) (i :: p) ->
      i <= j < n -> preimage (rem_PermFun i p) j = pred (preimage (i :: p) (S j)).
  Proof.
    intros p j i n HP HIJ.
    unfold preimage, rem_PermFun.
    cbn [findIndex]. rewrite if_false by (intro c; unfold equiv in c; omega).
    cbn.
    match goal with
    | |- context [findIndex ?j (map ?f ?l)] =>
      rewrite <- (findIndex_map f p)
    end; [|easy|fold (rem_PermFun i p)|].
    rewrite if_true by omega.
    easy.
    eapply rem_PermFun_preserve; apply HP.
    apply Exists_exists.
    exists (S j); split; [|easy].
    apply in_cons_neq with (y := i); [omega|].
    eapply Permutation_in; [symmetry; apply PermFun_Permutation_seq; apply HP|].
    apply in_seq. omega.
  Qed.

  Theorem rem_PermFun_preserve_Stable : forall p i l,
      i < length l ->
      StablePermFun l (i :: p) ->
      StablePermFun (rem_nth i l) (rem_PermFun i p).
  Proof.
    setoid_rewrite StablePermFun_iff.
    intros p k l HI [HP HS].
    split; [apply rem_PermFun_preserve; rewrite rem_nth_length; destruct l; easy|].
    intros i j d HE HIJ.
    assert (IK : preimage (k :: p) k = 0) by (cbn; rewrite if_true; easy).
    remember (length l) as n.
    destruct n; [apply PermFun_length in HP; omega|].
    rewrite rem_nth_length in HIJ by omega.
    destruct (le_lt_dec k i); [|destruct (le_lt_dec k j)].
    - assert (k <= j) by omega.
      rewrite !preimage_ge_rem_perm with (n := n) by (omega || easy).
      apply (Nat.pred_lt_mono (preimage (k :: p) (S i))).
      rewrite <- IK.
      intro c.
      apply preimage_inj with (n := S n) in c; (omega || easy).
      apply HS with (d := d); [|omega].
      rewrite !nth_ge_rem_nth in HE by omega.
      easy.
    - rewrite preimage_ge_rem_perm with (j := j) (n := n) by (omega || easy).
      rewrite preimage_lt_rem_perm with (j := i) (n := n) by (omega || easy).
      apply (Nat.pred_lt_mono (preimage (k :: p) i)).
      rewrite <- IK.
      intro c.
      apply preimage_inj with (n := S n) in c; (omega || easy).
      apply HS with (d := d); [|omega].
      rewrite @nth_ge_rem_nth with (j := j) in HE by omega.
      rewrite @nth_lt_rem_nth with (j := i) in HE by omega.
      easy.
    - rewrite !preimage_lt_rem_perm with (n := n) by easy.
      apply (Nat.pred_lt_mono (preimage (k :: p) i)).
      rewrite <- IK.
      intro c.
      apply preimage_inj with (n := S n) in c; (omega || easy).
      apply HS with (d := d); [|omega].
      rewrite !nth_lt_rem_nth in HE by omega.
      easy.
  Qed.

  Theorem StablePermEx_imp : forall l l',
      StablePerm l l' -> StablePermEx l l'.
  Proof.
    intros l l' HS.
    apply StablePermInd_iff in HS.
    induction HS.
    - exists []. split; [apply StablePermFun_nil|easy].
    - destruct IHHS as [p [HSP HA]].
      exists (0 :: map S p).
      destruct HSP as [HP HSP].
      split; [split|].
      + apply PermFun_Permutation_seq. cbn. apply perm_skip.
        rewrite <- seq_shift.
        apply Permutation_map.
        apply PermFun_Permutation_seq.
        easy.
      + intros i j d HE HIJ.
        pose proof (PermFun_length _ _ HP); cbn in HIJ.
        unfold image.
        rewrite !nth_indep with (d := 0) (d' := 1)
          by (cbn; rewrite map_length; omega).
        destruct i; destruct j; [omega| |omega|].
        * cbn [nth]. rewrite map_nth. omega.
        * cbn. rewrite !map_nth.
          apply lt_n_S.
          apply HSP with (d := d); [|omega].
          cbn [apply map] in HE.
          rewrite map_map in HE.
          cbn in HE.
          rewrite @apply_def with (d := x); easy.
      + cbn [apply map]; rewrite nth_first; cbn [hd].
        f_equal. rewrite <- HA.
        rewrite apply_def with (d := x) by easy.
        rewrite map_map. apply map_ext.
        easy.
    - exists (1 :: 0 :: map (fun x => S (S x)) (seq 0 (length l))).
      split; [split|].
      + apply PermFun_Permutation_seq. cbn [length seq].
        rewrite <- map_map, !seq_shift.
        apply perm_swap.
      + intros i j d HE HIJ.
        destruct i; destruct j;
          [omega|destruct j|omega|
           destruct i; destruct j; [omega| |omega|]];
          [exfalso; cbn in HE; contradiction
          |cbn in *;
           rewrite nth_indep with (d' := 2)
             by (rewrite map_length, seq_length; omega);
           rewrite map_nth with (d := 0);
           omega..
          |].
        cbn.
        rewrite !nth_indep with (d := 0) (d' := S (S 0))
          by (rewrite map_length, seq_length; cbn in *; omega).
        rewrite !map_nth with (d := 0).
        do 2 apply lt_n_S.
        rewrite !seq_nth by (cbn in *; omega).
        omega.
      + cbn [apply map]; rewrite nth_first; cbn [hd].
        do 2 f_equal. rewrite <- map_seq_id with (d := y).
        rewrite map_map. apply map_ext.
        easy.
    - destruct IHHS1 as [p1 [HSP1 HA1]].
      destruct IHHS2 as [p2 [HSP2 HA2]].
      exists (compose p2 p1).
      split; [apply StablePermFun_compose;
              [|rewrite <- HA1 in HSP2]; easy|].
      rewrite compose_apply, HA1, HA2
        by (destruct HSP1 as [HP1 _]; destruct HSP2 as [HP2 _];
            rewrite <- HA1, apply_length in HP2 by easy; easy).
      reflexivity.
  Qed.

  Theorem apply_correct_stable : forall p l,
      StablePermFun l p -> StablePerm (apply p l) l.
  Proof.
    intros p l.
    remember (length l) as n.
    revert p l Heqn.
    induction n as [|n IH]; intros p l HL [HP HS].
    - symmetry in HL; apply length_zero_iff_nil in HL; subst.
      apply PermFun_0 in HP; subst.
      reflexivity.
    - destruct l as [|a l]; [inversion HL|].
      destruct p as [|i p]; [apply PermFun_S_nil in HP; contradiction|].
      rewrite rem_PermFun_correct with (d := a) by easy.
      assert (forall k, k < i -> nth i (a :: l) a =/= nth k (a::l) a). {
        intros k HK.
        assert (k < length (a :: l)). {
          transitivity i; [easy|].
          apply PermFun_range with (p := i :: p); [|left]; easy.
        }
        specialize (HS 0 (preimage (i::p) k) a).
        rewrite nth_preimage_apply in HS by easy.
        cbn [apply map] in HS; rewrite !nth_first in HS; cbn [hd] in HS.
        rewrite image_preimage with (n := length (a :: l)) in HS by easy.
        assert (L: 0 < preimage (i :: p) k < length (a :: l)). {
          destruct (Nat.eq_dec (preimage (i :: p) k) 0).
          - subst. unfold preimage in e.
            apply f_equal with (f := fun x => nth x (i :: p) 0) in e.
            rewrite findIndex_correct in e. cbn in e.
            omega.
            apply PermFun_i_exists with (n := length (a :: l)); [easy|].
            transitivity i; [easy|].
            apply PermFun_range with (p := i :: p); [|left]; easy.
          - split; [omega|].
            unfold preimage.
            erewrite <- PermFun_length by apply HP.
            apply findIndex_bounds.
            apply PermFun_i_exists with (n := length (a :: l)); [easy|].
            transitivity i; [easy|].
            apply PermFun_range with (p := i :: p); [|left]; easy.
        }
        intro c.
        specialize (HS c L).
        cbn in HS.
        omega.
      }
      transitivity (nth i (a :: l) a :: rem_nth i (a :: l)).
      apply StablePerm_skip.
      apply IH.
      rewrite rem_nth_length;
        [cbn in *; omega|eapply PermFun_range; [apply HP|left; easy]].
      apply rem_PermFun_preserve_Stable;
        [eapply PermFun_range; [apply HP|left; easy]|easy].
      symmetry. apply rem_nth_StablePerm;
                  [eapply PermFun_range; [apply HP|left; easy]|easy].
  Qed.

  Theorem StablePermEx_iff : forall l l',
       StablePerm l l' <-> StablePermEx l l'.
  Proof.
    split.
    - apply StablePermEx_imp.
    - intros [p []].
      subst l'.
      symmetry; apply apply_correct_stable.
      easy.
  Qed.
End Stable.


Require Import Equations.Equations.
Require Import Arith Lia.

(** Formalized Solution for the following riddle *)

(* You’re facing your friend, Caryn, in a “candy-off,” which works as follows: There’s a pile of 100 caramels and one peppermint patty.
You and Caryn will go back and forth taking at least one and no more than five caramels from the candy pile in each turn. The person
who removes the last caramel will also get the peppermint patty. And you love peppermint patties.

Suppose Caryn lets you decide who goes first. Who should you choose in order to make sure you win the peppermint patty?

*)

(*** Preliminaries *)
(*We need some facts about division with remainder *)

Definition iffT (X Y : Type) : Type := (X -> Y) * (Y -> X).
Notation "X <=> Y" := (iffT X Y) (at level 95, no associativity).

Definition DIV y x :
  sigT(fun a => sigT (fun b => x = a * y + b /\ (0 < y -> b < y)  )).
Proof.
  destruct y as [|y].
  exists 0, x. repeat split. lia.
  induction x as [|x IH].
  - exists 0, 0. repeat split. tauto.
  - destruct IH as (a&b&H).
    destruct (Nat.eq_dec b y).
    + exists (S a), 0. repeat split; lia.
    + exists a, (S b). repeat split; lia.
Defined.

(* D y x gives the number of times y can be substracted from x *)
Definition D y x := projT1 (DIV y x).
(* M y x gives the remainder of x after division by y *)
Definition M y x := projT1 (projT2 (DIV y x)).

Fact Factor y x : x = (D y x)*y + M y x.
Proof.
  apply (projT2 (projT2 (DIV _ _))).
Qed.

Fact M_bound y x : 0 < y -> M y x < y.
Proof.
  apply (projT2 (projT2 (DIV _ _))).
Qed.

Section Uniqueness.

  Variables y : nat.

  Lemma Fac_unique a1 b1 a2 b2 : b1 < y -> b2 < y ->
    a1*y + b1 = a2*y + b2 -> a1 = a2 /\ b1 = b2.
  Proof.
    intros.
    destruct (Nat.lt_trichotomy a1 a2) as [ |[]]; nia.
  Qed.

  Theorem unique x a b : b < y ->
    x = a*y + b <-> a = D y x /\ b = M y x.
  Proof.
    split.
    - rewrite (Factor y x) at 1. intros.
      specialize (M_bound y x) as ?.
      apply Fac_unique; lia.
    - intros [-> ->]. apply Factor.
  Qed.

  Corollary Fac_eq a b : b < y ->
      a = D y (a*y + b) /\ b = M y (a*y + b).
  Proof.
    intros. now apply (unique _).
  Qed.

End Uniqueness.

Lemma M_for_multiple : forall y x, M y x = 0 <=> { k & x = k*y }.
Proof.
  split.
  - intros H. exists (D y x). rewrite plus_n_O. rewrite <- H. apply Factor.
  - intros [k ->]. destruct y. cbn. lia.
    assert (0 < S y) as [? H]%(Fac_eq _ k) by lia. now rewrite <- plus_n_O in H.
Qed.

Lemma non_div y x z : 0 < x -> M y x = 0 -> 0 < z < y -> M y (x - z) <> 0.
Proof.
  intros Hx [k ->]%M_for_multiple Hz [l Hl]%M_for_multiple.
  apply Nat.lt_0_mul' in Hx. destruct Hx.
  enough (k * y + 0 = l * y + z) as G%Fac_unique; destruct k; lia.
Qed.

Lemma complete_ind (P : nat -> Type) :
  (forall x, (forall y, y < x -> P y) -> P x) -> forall x, P x.
Proof.
  intros H x. apply H.
  induction x.
  - intros y. now intros F % PeanoNat.Nat.nlt_0_r.
  - intros y Hy. apply H.
    intros z Hz. apply IHx. lia.
Qed.

(*** Riddle Solution *)
Section Riddle.

  (* The pile has *) Variable N : nat. (* patties in it *)
  (* And there are two players *)
  Inductive player := Caryn | Me.
  (* Who must remove at least 1 and less than*) Variable t : nat. (* patties every turn. *)

  Definition switch p := match p with
                         | Caryn => Me
                         | Me => Caryn end.

  (* A player looks at how many patties there are left and removes 1,...,5 of them. So his choices can be modeled as a function with bounded output possibilities *)
  Definition choice := { f : nat -> nat | forall k, 0 < f k < 6}.
  Variable CarynChoice : choice.

  (* This calculates the winner of the game given the choices c m, the starting height N of the stack and starting player p *)
  Equations Game (N : nat) (p : player) (c m : choice) : player by wf N :=
    Game O p c m := switch p;
    Game N Caryn c m := Game (N - (proj1_sig c) N) Me c m;
    Game N Me c m := Game (N - (proj1_sig m) N) Caryn c m.
  Next Obligation.
    destruct c as [f Hf]. cbn. destruct (f (S n)) eqn:Bot.
    specialize (Hf (S n)). all : lia.
  Defined.
  Next Obligation.
    destruct m as [f Hf]. cbn. destruct (f (S n)) eqn:Bot.
    specialize (Hf (S n)). all : lia.
  Defined.

  (* This specifies my choice on every turn: I will always take a number of patties such that the height becomes divisible my 6 again. *)
  Lemma MyChoice : choice.
  Proof.
    exists (fun k => if nat_eqdec (M 6 k) O then 1 else M 6 k).
    intros k. destruct (nat_eqdec (M 6 k) O).
    - lia.
    - split. lia. apply M_bound. lia.
  Defined.

  Definition myChoice := proj1_sig MyChoice.

  Lemma MyChoiceSpec n : M 6 n <> 0 -> myChoice n = M 6 n.
  Proof.
    unfold myChoice. cbn. now destruct (nat_eqdec (M 6 n) O).
  Qed.

  (* This gives the winner of the game between me and Caryn *)
  Definition Winner N First := Game N First CarynChoice MyChoice.

  Theorem WinChoice :
    (M 6 N = 0 -> Winner N Caryn = Me) /\ (M 6 N <> 0 -> Winner N Me = Me).
  Proof.
    pattern N. revert N. apply complete_ind. intros N IH.
    destruct (nat_eqdec (M 6 N) O) as [H|H].
    - split. 2 : tauto. intros _.
      destruct N. now simp Game.
      specialize (proj2_sig CarynChoice (S n)) as Rules.
      unfold Winner; simp Game. apply IH.
      lia. apply non_div; lia.
    - split. tauto. intros _. destruct N.
      + cbn in H. congruence.
      + unfold Winner. simp Game.
        fold myChoice. rewrite (MyChoiceSpec _ H).
        rewrite (Factor 6 (S n) ) at 1. rewrite Nat.add_sub. apply IH.
        rewrite (Factor 6 (S n) ) at 2. lia.
        rewrite (plus_n_O (_*_) ). symmetry. apply Fac_eq; lia.
  Qed.

  (* From the above we immediately get that it is always possible to choose the starting player so that I can win  *)
  Corollary Winable :
    exists p : player, Winner N p = Me.
  Proof.
    destruct (nat_eqdec (M 6 N) O);
    [exists Caryn | exists Me]; now apply WinChoice.
  Qed.

End Riddle.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith List Permutation.

Require Import list_utils.
Require Import formula.

Set Implicit Arguments.

(** Hilbert rules for the implicational fragment of intuitionistic logic *)

Section Hilbert.

  Reserved Notation "'|--' x" (at level 70, no associativity).

  (* Łukasiewicz axiom system for the positive implicational calculus *)

  Inductive HI_proof : Form -> Set :=
    | in_HI_K  : forall A B,   |-- A %> B %> A
    | in_HI_S  : forall A B C, |-- (A %> B %> C) %> (A %> B) %> (A %> C)
    | in_HI_MP : forall A B,   |-- A %> B -> |-- A -> |-- B
  where "|-- A" := (HI_proof A).

  (* This is the I combinator : W = S K K *)

  Fact HI_I A : |-- A %> A.
  Proof.
    exact (in_HI_MP (in_HI_MP (in_HI_S _ _ _) (in_HI_K _ _)) (in_HI_K _ A)).
  Qed.

  (* This is the W combinator : W = S S (S K) *)

  Fact HI_W A B : |-- (A %> A %> B) %> (A %> B).
  Proof.
    exact (in_HI_MP (in_HI_MP (in_HI_S _ _ _) (in_HI_S _ _ _))
                    (in_HI_MP (in_HI_S _ _ _) (in_HI_K _ _))).
  Qed.

  (* This is the B combinator : B = S (K S) K *)

  Fact HI_B A B C : |-- (B %> C) %> (A %> B) %> A %> C.
  Proof.
    exact (in_HI_MP (in_HI_MP (in_HI_S _ _ _)
                       (in_HI_MP (in_HI_K _ _) (in_HI_S _ _ _)))
                    (in_HI_K _ _)).
  Qed.

  Fact HI_KK A B C : |-- C %> A %> B %> A.
  Proof.
    apply in_HI_MP with (1 := in_HI_K _ _), in_HI_K.
  Qed.

  (* This is the C combinator : C = S (S (K B) S) (K K) *)

  Fact HI_C A B C : |-- (A %> B %> C) %> (B %> A %> C).
  Proof.
    exact (in_HI_MP
             (in_HI_MP (in_HI_S _ _ _)
                       (in_HI_MP (in_HI_MP (in_HI_S _ _ _)
                                 (in_HI_MP (in_HI_K _ _) (HI_B _ _ _))) (in_HI_S _ _ _)))
             (HI_KK _ _ _)).
  Qed.

  Fact HI_SI A B : |-- ((A %> B) %> A) %> (A %> B) %> B.
  Proof.
    apply in_HI_MP with (1 := in_HI_S _ _ _), HI_I.
  Qed.

  Fact HI_KSI A B C : |-- C %> ((A %> B) %> A) %> (A %> B) %> B.
  Proof.
    apply in_HI_MP with (1 := in_HI_K _ _), HI_SI.
  Qed.

  Fact HI_S_KSI A B : |-- (A %> (A %> B) %> A) %> A %> (A %> B) %> B.
  Proof.
    apply in_HI_MP with (1 := in_HI_S _ _ _), HI_KSI.
  Qed.

  Fact HI_app A B : |-- A %> (A %> B) %> B.
  Proof.
    apply in_HI_MP with (1 := HI_S_KSI _ _), in_HI_K.
  Qed.

  (* Another proof *)

  Fact HI_cntr A B : |-- (A %> A %> B) %> (A %> B).
  Proof.
    apply in_HI_MP with (1 := in_HI_S A (A %> B) B), HI_app.
  Qed.

  Fact HI_KS A B C D : |-- D %> (A %> B %> C) %> (A %> B) %> (A %> C).
  Proof.
    apply in_HI_MP with (1 := in_HI_K _ _), in_HI_S.
  Qed.

  Fact HI_S_KS A B C D : |-- (D %> A %> B %> C) %> D %> (A %> B) %> A %> C.
  Proof.
    apply in_HI_MP with (1 := in_HI_S _ _ _), HI_KS.
  Qed.

  Fact HI_tran A B C : |-- (A %> B) %> (B %> C) %> A %> C.
  Proof.
    apply in_HI_MP with (1 := HI_C _ _ _), HI_B.
  Qed.

  Lemma HI_list_Form_to_Form_HI_proof l a b :
      |-- a %> b -> |-- l %%> a -> |-- l %%> b.
  Proof.
    revert a b; induction l as [ | c l IHl ]; intros a b H1 H2.
    apply in_HI_MP with (2 := H2), H1.
    revert H2; simpl.
    apply IHl, in_HI_MP with (2 := H1), HI_B.
  Qed.

  Lemma HI_list_MP l a b :
      |-- l%%> a %> b -> |-- l %%> a -> |-- l %%> b.
  Proof.
    revert a b; induction l as [ | x l IHl ]; intros a b.
    apply in_HI_MP.
    simpl; intros H; apply IHl.
    revert H; apply HI_list_Form_to_Form_HI_proof, in_HI_S.
  Qed.

  (** This one needs Permutation_rect (decidability of @eq is required)
      to compute an actual permutation from the knowledge that there
      exists one *)

  Lemma HI_proof_perm l m a : l ~p m -> |-- l %%> a -> |-- m %%> a.
  Proof.
    intros H; revert a.
    apply Permutation_rect with (1 := Form_eq_dec) (6 := H);
      clear l m H; try (intros; simpl; auto; fail).

    intros ? ? ? ?; simpl; apply HI_list_Form_to_Form_HI_proof, HI_C.
  Qed.

  Fact HI_proof_contract th a x : |-- (a::a::th) %%> x -> |-- (a::th) %%> x.
  Proof. simpl; apply HI_list_Form_to_Form_HI_proof, HI_W. Qed.

  Fact HI_proof_weak th a x : |-- th %%> x -> |-- (a::th) %%> x.
  Proof. simpl; apply HI_list_Form_to_Form_HI_proof, in_HI_K. Qed.

  Fact HI_proof_weakening th x : |-- x -> |-- th %%> x.
  Proof.
    intros; induction th as [ | a th IH ].
    simpl; trivial.
    apply HI_proof_weak; trivial.
  Qed.

  (** This one needs list_contract_rect (decidability of @eq _ is required)
      to compute an actual contraction sequence from the knowledge that there
      exists one *)

  Lemma HI_proof_list_contract ga de x :
          list_contract Form_eq_dec ga de -> |-- ga %%> x -> |-- de %%> x.
  Proof.
    intros H; revert x.
    apply list_contract_one_rect with (eqX_dec := Form_eq_dec)
                                      (4 := H); clear ga de H.

    intros ? ? ? ?; apply HI_proof_perm; auto.
    intros ? ? ?; apply HI_proof_contract.
    intros; auto.
  Qed.

End Hilbert.


Require Import Coq.Arith.Minus.

(** Redefinition of simple arithmetic *)

(* The definitions already present in the standard library are very complicated and take ages to quote *)

Theorem le_0_n : forall n, 0 <= n.
Proof.
  intro n. induction n.
  - apply le_n.
  - apply le_S. exact IHn.
Qed.

Theorem lt_0_succ : forall n, 0 < S n.
Proof.
  intro n. induction n.
  - now apply le_n.
  - apply le_S. exact IHn.
Qed.

Theorem pos_ge_0 : forall n, S n <= 0 -> False.
Proof.
  intros n H. inversion H.
Qed.

Theorem le_S_n : forall n m, S n <= S m -> n <= m.
Proof.
  intros n m. revert n. induction m.
  - intros n H. inversion H.
    + apply le_n.
    + apply pos_ge_0 in H1. destruct H1.
  - intros n H. inversion H.
    + apply le_n.
    + apply IHm in H1. apply le_S. exact H1.
Qed.

Theorem le_n_S : forall n m, n <= m -> S n <= S m.
Proof.
  intros n m. revert n. induction m.
  - intros n H. inversion H. apply le_n.
  - intros n H. inversion H.
    + apply le_n.
    + apply le_S. now apply IHm.
Qed.

Theorem add_0_r : forall n, n + 0 = n.
Proof.
  intro n. induction n.
  - reflexivity.
  - simpl. rewrite IHn. reflexivity.
Qed.

Theorem add_S : forall n m : nat, n + S m = S (n + m).
Proof.
  intro n. induction n.
  - intro m. reflexivity.
  - intro m. simpl. rewrite IHn. reflexivity.
Qed.

Theorem add_comm : forall n m : nat, n + m = m + n.
Proof.
  intro n. induction n.
  - intro m. rewrite (add_0_r m). reflexivity.
  - intro m. simpl. rewrite IHn. rewrite add_S. reflexivity.
Qed.

Theorem le_plus_n : forall n m p, p + n <= p + m -> n <= m.
Proof.
  intros n m. induction p.
  - intro H. exact H.
  - intro H. simpl in H. apply le_S_n in H. exact (IHp H).
Qed.

Definition le_imp_eq_lt : forall n m : nat, n <= m -> (n = m) + (n < m).
  intro n. induction n.
  - intros m H. destruct m.
    + left. reflexivity.
    + right. apply lt_0_succ.
  - intros m H. destruct m.
    + apply pos_ge_0 in H. destruct H.
    + destruct (IHn m).
      * now apply le_S_n.
      * rewrite e. left. reflexivity.
      * right. now apply le_n_S.
Defined.

Definition lt_eq_lt_dec :  forall n m : nat, {n < m} + {n = m} + {m < n}.
  intros n m. induction m.
  - assert (0 <= n). apply le_0_n. apply le_imp_eq_lt in H. destruct H.
    + left. now right.
    + now right.
  - destruct IHm as [[H | H] | H].
    + left. left. now apply le_S.
    + rewrite H. left. left. now apply le_n.
    + apply le_imp_eq_lt in H. destruct H.
      * left. right. now rewrite e.
      * right. exact l.
Defined.

Definition le_lt_dec : forall n m : nat, {n <= m} + {m < n}.
  intros n m. destruct (lt_eq_lt_dec n m) as [[H | H] | H].
  - left. apply le_S_n. apply le_S. exact H.
  - left. rewrite H. apply le_n.
  - right. exact H.
Defined.

Definition lt_eq_lt_dec' :  forall n m : nat, {n < m} + {n = m} + {m < n}.
  intros n m. induction n.
  - assert (0 <= m). apply le_0_n. apply le_imp_eq_lt in H. destruct H.
    + left. now right.
    + left. now left.
  - destruct IHn as [[H | H] | H].
    + apply le_imp_eq_lt in H. destruct H.
      * left. right. exact e.
      * left. left. exact l.
    + rewrite H. right. now apply le_n.
    + right. now apply le_S.
Defined.

Definition lt_eq_eq_lt_dec (m n : nat) : {m < n} + {m = n} + {m = S n} + {m > S n}.
Proof.
  destruct (lt_eq_lt_dec m n) as [[H | H] | H].
  - left. left. now left.
  - left. left. now right.
  - apply le_imp_eq_lt in H. destruct H.
    + left. now right.
    + right. exact l.
Defined.

Theorem le_trans : forall n m p, n <= m -> m <= p -> n <= p.
Proof.
  intros n m p. revert n m. induction p.
  - destruct m.
    + trivial.
    + intros H H'. apply pos_ge_0 in H'. destruct H'.
  - intros n m H. destruct m, n.
    + intro H'. apply le_0_n.
    + apply pos_ge_0 in H. destruct H.
    + intro H'. apply le_0_n.
    + intro H'. apply le_S_n in H. apply le_S_n in H'. apply le_n_S.
      eapply IHp. apply H. exact H'.
Qed.

Theorem sub_add_S {a b c : nat} : S b <= a -> a - S b + S c = a - b + c.
Proof.
  revert c. induction b.
  - intros c H. destruct a.
    + inversion H.
    + simpl. rewrite <- Minus.minus_n_O. apply add_S.
  - intros c H. destruct a.
    + inversion H.
    + simpl. apply eq_add_S.
      change (S (a - S b + S c)) with (S (a - S b) + S c). erewrite Minus.minus_Sn_m.
      change (S (a - b + c)) with (S (a - b) + c). erewrite Minus.minus_Sn_m.
      apply IHb.
      * apply le_S_n. eapply le_trans. exact H. apply le_S. apply le_n.
      * apply le_S_n. apply le_S_n. eapply le_trans. exact H. apply le_S. apply le_n.
      * now apply le_S_n.
Qed.

Theorem sub_sub {a b c : nat} : b <= a -> c <= b -> a - (b - c) = a - b + c.
Proof.
  revert c. induction b.
  - intros c Hb Hc. inversion Hc. easy.
  - intros c Hb Hc. destruct c.
    + simpl. easy.
    + simpl. erewrite IHb.
      * symmetry. apply sub_add_S. exact Hb.
      * apply le_S_n. eapply le_trans. exact Hb. apply le_S. apply le_n.
      * apply le_S_n. exact Hc.
Qed.