Require Export lc.tactics.
Import LCNotations.
Local Open Scope lc_scope.

(*** Formalization of Barendregt's Chapter 3 (REDUCTION). *)

(* ################################################################# *)
(** * Section 3.1 Notions of reduction *)

(** We start by defining *properties* of binary term relations.

    In our Ott generated definitions, a [relation] is defined as the type
    [tm -> tm -> Prop].

    Below, we'll use the metavariable [R] for relations, and if terms [t] and
    [u] are related by [R], then we will write that as [R t u].

    Because we are working with a locally nameless representation, if we have
    [R t u], we'll want to know that both [t] and [u] are locally closed. In
    other words, we have satisfied the [lc R] constraint.

 *)

(** ** Equivalence relation (and type classes) *)

(** This is a standard mathematical definitions. An *equivalence* relation is
    one that is reflexive, symmetric and transitive.  These definitions are
    similar to those in the the Coq standard library
    (https://coq.inria.fr/library/Coq.Classes.RelationClasses.html) but note
    that reflexivity is only required for *locally closed* terms.

    A type class is a form of record type that is determined by its parameter
    [R]. We expect that there will only be one meaningful way that a relation
    can be reflexive. Later on, we will create values of this record type for
    specific relations by supplying appropriate proofs. By declaring these
    records asw type classes, Coq can find these proofs automatically, just by
    knowing what relation we are working with.  *)

Class reflexive (R: relation) := {
  reflexivity : forall t : tm, lc_tm t -> R t t
}.
Class transitive (R: relation) := {
  transitivity : forall t1 t2 t3 : tm, R t1 t2 -> R t2 t3 -> R t1 t3
}.
Class symmetric (R: relation) := {
  symmetry : forall t1 t2 : tm, R t1 t2 -> R t2 t1
}.

Class equivalence (R : relation) : Prop := {
    equivalence_reflexive  :> reflexive R ;
    equivalence_symmetric  :> symmetric R ;
    equivalence_transitive :> transitive R
}.

(* ================================================================= *)

(** ** Compatible relation *)

(** Definition 3.1.1 (i)

   A *compatible* relation is one that is preserved by the constructors of the
   language definition. We might write this informally, using the three
   conditions.

       - (abs) R t u implies R \x.t \x.u

       - (app1) R t t' implies R (t u) (t' u)

       - (app2) R u u' implies R (t u) (t u')

   Because of our use of the locally nameless representation, we'll need to
   add lc_tm preconditions to `compatible_app1` and `compatible_app2`.

   Also, compatibility for the `abs` constructor is stated in the "exists-fresh"
   form. We need to be able to show that the relation holds for a single
   variable that is sufficiently fresh.

 *)

Class compatible (R: relation) := {

    compatible_abs :  forall x t u,
      x `notin` fv_tm t \u fv_tm u ->
      R (t ^ x)(u ^ x) -> R (abs t) (abs u) ;

    compatible_app1 : forall t t' u,
      R t t' -> lc_tm u -> R (app t u) (app t' u) ;

    compatible_app2 : forall t u u',
      lc_tm t -> R u u' -> R (app t u) (app t u')
  }.

(** In the case when the relation is reflexive and transitive, we can use the
    two separate properties for application at once. The notation `{_} marks
    type class arguments to this lemma. When we apply the lemma, Coq will
    search for the values automatically. *)

Lemma compatible_app {R} `{lc R} `{reflexive R} `{transitive R} `{compatible R} :
  forall t u t' u',
  R t t' -> R u u' -> R (app t u) (app t' u').
Proof.
  (* WORKINCLASS *)
  intros.
  eapply transitivity with (t2 := (app t' u)).
  eapply compatible_app1; eauto with lngen.
  eapply compatible_app2; eauto with lngen.
Qed. (* /WORKINCLASS *)

(* ================================================================= *)

(** Definition 3.1.1 (ii) a *congruence* relation (also called an equality) is
   a compatible equivalence relation. *)
Class congruence R := {
  congruence_equivalence :> equivalence R ;
  congruence_compatible  :> compatible R
}.

(** Definition 3.1.1 (iii) a *reduction* relation is reflexive, transitive and
  compatible. *)
Class reduction R := {
  reduction_reflexive  :> reflexive R ;
  reduction_transitive :> transitive R ;
  reduction_compatible :> compatible R
}.

(** We'll jump ahead a bit in the chapter and also define the following three
    substitution properties for binary term relations.

    In general, we expect the first property to always hold for any binary
    term relation. If two terms are related, then they should still be
    related after substitution.

    However, the second and third may or may not be true.  (For example, the
    second is not true for primitive "beta" reduction.)  *)

(** Definition 3.1.14 *)
Definition subst1 (R : relation) :=
  forall t t' x u, lc_tm u ->
    R t t' -> R (t [ x ~> u ]) (t' [ x ~> u ]) .
Definition subst2 (R : relation) :=
  forall x t u u', lc_tm t ->
    R u u' -> R (t [ x ~> u ]) (t [ x ~> u' ]).
Definition subst3 (R : relation) :=
  forall x t t' u u',
    R t t' -> R u u' -> R (t [ x ~> u ]) ( t' [ x ~> u' ]).

(** We'll also make a class for relations that satisfy the first substitution
    property. *)
Class substitutive (R : relation) := {
    subst : subst1 R
}.

(** Finally, we'll say that a relation S is a closure of relation R if it
    includes everything that is related by R (and possibly more things.
 *)
Class closure (R S : relation) := {
    embed : forall t u, R t u -> S t u
  }.

(* ================================================================= *)

(** ** Definition 3.1.4 and 3.1.5

   Next, We will diverge slightly from Barendregt and use a general definition
   for reflexive-transitive closure and symmetric-transitive closure instead
   of layering them on top of compatible closure.

   Take a moment to look at the following inductive definitions that appear in
   the Ott file. These definitions are a way of taking a relation and forcing
   it to be compatible, reflexive, and transitive.  *)

Print compatible_closure.
Print refl_trans_closure.
Print sym_trans_closure.

(** Below are some names for specific closures of R. Below, we will call an
    arbitrary [R] a "reduction" and imagine it as a step or transition
    rule. i.e. if we have [R t u] then we say "[t] reduces to [u] via [R]".  *)

(** Allow exactly one R-reduction, anywhere inside the term. *)
Definition one_step_R_reduction (R : relation) := compatible_closure R.

(** Allow a sequence of arbitrarily many one step R-reductions *)
Definition R_reduction (R : relation) := refl_trans_closure (compatible_closure R).

(** Generate congruence relation from R-reduction, by forcing it
    to also be symmetric. *)
Definition R_convertibility (R : relation) := sym_trans_closure (R_reduction R).

(** We will also specialize the latter definitions to the [beta] relation *)

Definition beta_reduction := R_reduction beta.
Definition beta_convertibility := R_convertibility beta.

(** Note: beta_convertibility is almost the same as beta_equivalence. However,
    beta_equivalence is defined directly as the reflexive, symmtric,
    transitive, compatible closure of beta_reduction, which is not quite the
    same as the above proof. Both definitions do relate the same terms, but
    beta_equivalence derivations are less structured than beta_conversion.

    If each of the \ and / below are beta_reductions, then a
    beta_convertibility proof looks like:

            t t1 t2 ...  t3 u \ / \ / \ / \ / t' t1' ...  u' *)

(* ================================================================= *)

(** We'll want to show that beta_reduction and beta_convertibility have the
    properties listed above. We can do so by proving those properties about
    the closure operations and asking Coq to glue these results together
    via type class resolution.

 *)

(** ** Properties of the compatible closure operation *)

#[local]
Instance lc_compatible_closure {R} `{lc R} : lc (compatible_closure R).
Proof.
  split.
  - intros a b CC. induction CC; eauto using lc1.
  - intros a b CC. induction CC; eauto using lc2.
Qed.

#[local]
Instance closure_compatible_closure {R} : closure R (compatible_closure R).
Proof. constructor. intros; eauto using cc_rel. Qed.

(** *** Exercise [subst1_compatible closure] *)

(** This is a standard substitution lemma *)
#[local]
Instance subst1_compatible_closure R { SR : substitutive R } : substitutive (compatible_closure R).
Proof.
(* ADMITTED *)
  constructor. intros t t' x u LCu CC.
  induction CC.
  - eapply cc_rel; eauto. apply subst; eauto.
  - pick fresh y and apply cc_abs. fold subst_tm.
    spec y.
    autorewrite with lngen in H0; auto.
  - eapply cc_app1; eauto with lngen.
  - eapply cc_app2; eauto with lngen.
Qed. (* /ADMITTED *)

(** Due to the use of co-finite quantification in our definition of
    compatible_closure (in the Ott file), we need the underlying relation to
    be substitutive.  Showing this result is similiar to proving an
    "exists-fresh" lemma *)

#[local]
Instance compatible_compatible_closure {R} `{substitutive R} : compatible (compatible_closure R).
Proof.
    (* WORKINCLASS *)
  split;  intros; eauto.
  have SS: substitutive (compatible_closure R) by typeclasses eauto.
  pick fresh y and apply cc_abs.
  rewrite (subst_tm_intro x t); auto.
  rewrite (subst_tm_intro x u); auto.
  eapply subst; eauto.
Qed. (* /WORKINCLASS *)

(** ** Properties of refl_trans_closure operation **)

(** *** Exercise [lc_refl_trans_closure] *)

#[local]
Instance lc_refl_trans_closure {R} `{lc R} : lc (refl_trans_closure R).
Proof. (* ADMITTED *)
  split.
  - induction 1; eauto using lc1.
  - induction 1; eauto using lc2.
Qed. (* /ADMITTED *)

#[local]
Instance closure_refl_trans_closure {R} : closure R (refl_trans_closure R).
Proof. constructor. intros; eauto using rt_rel. Qed.

#[local]
Instance reflexive_refl_trans_closure {R}: reflexive (refl_trans_closure R).
Proof. constructor. intros. eauto using rt_refl with lngen. Qed.

#[local]
Instance transitive_refl_trans_closure {R} : transitive (refl_trans_closure R).
Proof. constructor. intros. eauto using rt_trans with lngen. Qed.

#[local]
Instance subst1_refl_trans_closure {R} `{substitutive R} : substitutive (refl_trans_closure R).
Proof.
  constructor. unfold subst1.
  intros t t' x u LC RTC.
  induction RTC; eauto using subst with lngen.
Qed.

#[local]
Instance compatible_refl_trans_closure {R} `{compatible R} :
  compatible (refl_trans_closure R).
Proof.
  (* WORKINCLASS *)
  split;  intros x t u H1 H0; eauto.
  + dependent induction H0.
    - (* rt_rel *)
      eapply rt_rel.
      eapply (compatible_abs x); eauto.
    - (* rt_refl *)
      autorewrite with lngen in x. subst.
      eapply reflexivity; eauto with lngen.
    - (* rt_trans *)
      eapply transitivity with (t2 := abs (close x t2)).
      eapply IHrefl_trans_closure1 with (x := x); auto;
      autorewrite with lngen; auto.
      eapply IHrefl_trans_closure2 with (x:= x); auto;
      autorewrite with lngen; auto.
  + dependent induction H1; eauto using compatible_app1.
  + dependent induction H0; eauto using compatible_app2.
Qed. (* /WORKINCLASS *)

(** ** Properties of sym_trans_closure: it preserves local closure,
substitutivity and compatibility *)

(** *** Exercise [lc_sym_trans_closure] *)
#[local]
Instance lc_sym_trans_closure {R} `{lc R} : lc (sym_trans_closure R).
Proof.  (* ADMITTED *)
  have LC:forall a b, sym_trans_closure R a b -> lc_tm a /\ lc_tm b.
  { intros a b STC. induction STC; split.
    all: try destruct IHSTC.
    all: try destruct IHSTC1.
    all: try destruct IHSTC2.
    all: eauto with lngen.
  }
  split.
  intros; edestruct LC; eauto.
  intros; edestruct LC; eauto.
Qed. (* /ADMITTED *)

#[local]
Instance closure_sym_trans_closure {R} : closure R (sym_trans_closure R).
Proof. constructor. intros; eauto using st_rel. Qed.

#[local]
Instance symmetric_sym_trans_closure {R} : symmetric (sym_trans_closure R).
Proof. constructor. intros. eauto using st_sym with lngen. Qed.

#[local]
Instance transitive_sym_trans_closure {R} : transitive (sym_trans_closure R).
Proof. constructor. intros. eauto using st_trans with lngen. Qed.

#[local]
Instance reflexive_sym_trans_closure {R} `{reflexive R} :
  reflexive (sym_trans_closure R).
Proof. constructor. intros. apply embed. apply reflexivity. auto. Qed.

#[local]
Instance subst1_sym_trans_closure {R} {SR : substitutive R} : substitutive (sym_trans_closure R).
Proof.
  constructor. unfold subst1. intros t t' x u LCu STC.
  induction STC.
  - eapply embed; eauto using subst.
  - eapply symmetry; eauto.
  - eapply transitivity with (t2 := t2 [x ~> u]); eauto.
Qed.

(** *** Exercise [compatible_sym_trans_closure] *)

#[local]
Instance compatible_sym_trans_closure {R} {CR: compatible R} : compatible (sym_trans_closure R).
Proof.
  (* ADMITTED *)
  constructor.
  + intros.
    dependent induction H0.
    - eapply embed; eauto.
      eapply compatible_abs; eauto.
    - eapply symmetry; eauto.
    - eapply transitivity with (t2 := (abs (close x t2))).
      eapply IHsym_trans_closure1; eauto.
      autorewrite with lngen; auto.
      autorewrite with lngen; auto.
      eapply IHsym_trans_closure2; eauto.
      autorewrite with lngen; auto.
      autorewrite with lngen; auto.
 + intros.
   dependent induction H.
   - eapply embed; eauto.
     eapply compatible_app1; eauto.
   - eapply symmetry; eauto.
   - eapply transitivity with (t2 := app t2 u); eauto.
 + intros. dependent induction H0.
   - eapply embed; eauto.
     eapply compatible_app2; eauto.
   - eapply symmetry; eauto.
   - eapply transitivity with (t2 := app t t2); eauto.
Qed. (* /ADMITTED *)

(* ================================================================= *)

(** Now let's put everything together and show properties of R-reduction and R-convertibility. *)

(** ** Lemma 3.1.6

   Our definition of the R_reduction operation produces a reduction relation
   and R_convertibility produces a congruence relation.

*)

#[local]
Instance reduction_R_reduction R `{substitutive R} : reduction (R_reduction R).
Proof.
  split; typeclasses eauto.
Qed.

#[local]
Instance congruence_R_convertibility {R} `{substitutive R}: congruence (R_convertibility R).
Proof.
  split.
  - split; typeclasses eauto.
  - typeclasses eauto.
Qed.

(** ** Remark 3.1.7 *)

Lemma subst2_R_reduction R `{lc R}`{substitutive R}: subst2 (R_reduction R).
Proof.
  (* WORKINCLASS *)
  unfold subst2.
  intros x t u u' LCt Red.
  have LC: lc (refl_trans_closure (compatible_closure R)). { typeclasses eauto. }
  have CC: compatible (refl_trans_closure (compatible_closure R)). { typeclasses eauto. }
  (* induction on the "syntax" of the term *)
  induction LCt; simpl; eauto.
  + (* var *)
    destruct_var_eq.
    auto.
    eapply reflexivity; auto.
  + (* abs *)
    pick fresh y. spec y.
    eapply compatible_abs with (x:=y).
    autorewrite with lngen. auto.
    rewrite_subst_open_hyp; eauto with lngen.
  + (* app *)
    eapply compatible_app; eauto.
Qed. (* /WORKINCLASS *)

(* ================================================================= *)

(** The next part defines what it means for a term to be a normal
    form [nf] according to some reduction relation R.
  *)

(** ** Definition 3.1.8 *)

(** (i) A term t is a R-redex if there exists u, such that R t u *)
Print redex.

(** (ii) A term t is R-normal-form if no subterm contains an R-redex *)
Print nf.

(** (iii) A term u is a R-nf-of t if u is an R-nf and t is R-convertible to u. *)
Definition R_nf_of R u t := nf R u /\ R_convertibility R t u.

(** ** Lemma 3.1.10  (i) *)

(** Normal forms do not single-step *)

Lemma nf_normal R : forall t,
  nf R t -> not (redex (compatible_closure R) t).
Proof.
  intros t nft.
  induction nft.
  all: intros h; inversion h; subst.
  all: match goal with [H0 : compatible_closure ?R ?x ?u |- _ ] => inversion H0; subst end; eauto.
  pick fresh x. spec x. eauto.
Qed.

(** ** Lemma 3.1.10  (ii) *)

(** Normal forms only reduce to themselves *)

Lemma nf_noreduction {R} : forall t,  nf R t -> forall u, R_reduction R t u -> t = u /\ nf R u.
Proof.
  intros.
  unfold R_reduction in H0.
  dependent induction H0.
  - apply nf_normal in H.
    apply False_ind. apply H.
    exists u. auto.
  - auto.
  - destruct (IHrefl_trans_closure1 R); auto. subst.
    destruct (IHrefl_trans_closure2 R); auto.
Qed.

(* ================================================================= *)

(** ** Definition 3.1.11 *)

Definition diamond_property (R : relation) :=
  forall t t1 t2, R t t1 -> R t t2 -> exists t3, R t1 t3 /\ R t2 t3.

Definition church_rosser (R : relation) := diamond_property (R_reduction R).

(** ** Theorem 3.1.12 *)

(** R-compatible terms R-reduce to a common term *)

Theorem convertibility_reduction_diamond {R} `{lc R} (CR: church_rosser R) :
  forall t u, R_convertibility R t u -> exists z, R_reduction R t z /\ R_reduction R u z.
Proof.
  intros t u Rconv.
  have lcRR: lc (R_reduction R). { typeclasses eauto. }
  unfold R_convertibility in *.
  dependent induction Rconv.
  - exists u. split; unfold R_reduction. auto. eapply reflexivity. eapply lc2; eauto.
  - edestruct (IHRconv R) as [z [Ruz Rtz]]; eauto.
  - edestruct (IHRconv1 R) as [z1 [Rt1z1 Rt2z1]]; eauto.
    edestruct (IHRconv2 R) as [z2 [Rt2z2 Rt3z2]]; eauto.
    unfold church_rosser, diamond_property in CR.
    destruct (CR _ _ _ Rt2z1 Rt2z2) as [z3 [Rz1z3 Rz2z3]]; eauto.
    (*      t1     t2    t3
               z1     z2
                   z3           *)
    exists z3. split.
    eapply transitivity with (t2:= z1); eauto.
    eapply transitivity with (t2:= z2); eauto.
Qed.

(** ** Corollary 3.1.13 *)
Lemma nf_reduce R `{lc R} (CR: church_rosser R) : forall u t, R_nf_of R u t -> R_reduction R t u.
Proof.
  intros u t.
  unfold R_nf_of.
  intros [NF RC].
  destruct (convertibility_reduction_diamond CR _ _ RC) as [z[Rtz Rzu]].
  edestruct (nf_noreduction _ NF _ Rzu). subst.
  auto.
Qed.

(** ** Proposition 3.1.15 *)

#[local]
Instance subst1_R_reduction {R} `{substitutive R} : substitutive (R_reduction R).
Proof.
  typeclasses eauto.
Qed.

#[local]
Lemma subst1_R_convertibility {R} `{substitutive R} : substitutive (R_convertibility R).
Proof.
  typeclasses eauto.
Qed.

(** ** Proposition 3.1.16 *)

(** *** Exercise [subst1_beta] *)

#[local]
Instance subst1_beta : substitutive beta.
Proof. (* ADMITTED *)
  constructor. intros t t' x u LCu Beta.
  inversion Beta. subst.
  simpl.
  autorewrite with lngen; auto.
  eapply beta_reduct; eauto with lngen.
  pick fresh y. eapply (lc_abs_exists y).
  inversion H. spec y.
  apply subst_tm_lc_tm with (t2 := u) (x1 := x) in H2; auto.
  autorewrite with lngen in H2; auto.
Qed. (* /ADMITTED *)

#[local]
Instance lc_beta : lc beta.
Proof.
  econstructor.
  - intros. inversion H; auto.
  - intros. inversion H; subst; auto.
    eauto with lngen.
Qed.

(* ################################################################# *)
(** * Section 3.2 Beta reduction *)

(** This section studies the relation [beta_reduction] more closely and shows
    that it is Church-Rosser using a proof that Barendregt attributes to
    Tait and Martin-Lof.

   We won't show that beta_reduction satisfies the diamond property directly. Instead
   we will define another relation, called "parallel reduction", and derive this
   property from the lemma below and the following two facts:

      - parallel reduction satisfies the diamond property

      - beta_reduction is the transitive closure of parallel reduction

   *)

(** ** Lemma 3.2.2 *)
(** If a relation has the diamond property, then so does its transitive closure.

Barendregt's proof is "A simple diagram chase suggested by figure 3.4". See
if you can figure out how to translate that figure to a (nested) induction.
*)

(** *** Exercise [diamond_property_trans_closure] *)

Lemma diamond_property_trans_closure {R} : diamond_property R -> diamond_property (trans_closure R).
Proof.
  intros DR.
  unfold diamond_property in *.
  intros t t1 t2 TC1.
  move: t2.
  (* ADMITTED *)
  induction TC1; intros t2' TC2.
  - have lemma: forall u,  R t u -> exists t3, trans_closure R u t3 /\ R t2' t3.
    { clear u H.
    induction TC2; intros u0 H1.
    + edestruct (DR t u u0) as [u1 [R1 R2]]; eauto.
    + destruct (IHTC2_1 DR _ H1) as [u2 [R1 R2]].
      edestruct (IHTC2_2 DR) as [e3 [R3 R4]]. eauto. eauto.
    }
    edestruct lemma; eauto.
    exists x. split_hyp. split; eauto.
  - destruct (IHTC1_1 DR ltac:(eauto)) as [u2 [R1 R2]]; eauto.
    edestruct (IHTC1_2 DR) as [u3 [R3 R4]]. eauto.
    exists u3. split. eauto. eapply t_trans with (t2 := u2); eauto.
Qed. (* /ADMITTED *)

(* ================================================================= *)

(** ** Definition 3.2.3 is often called parallel reduction. *)

Print parallel.

(** Properties of parallel reduction *)

#[local]
Instance lc_parallel : lc parallel.
Proof.
  have: forall a b, parallel a b -> lc_tm a /\ lc_tm b.
  { intros a b P. induction P; split; split_hyp; eauto.
  eapply lc_abs_open; eauto.
  pick fresh x. repeat spec x. split_hyp. eapply lc_abs_exists; eauto.
  pick fresh x. repeat spec x. split_hyp. eapply lc_abs_exists; eauto. }
  intros h.
  split;  intros a b h1; edestruct h; eauto.
Qed.

#[local]
Instance parallel_reflexive : reflexive parallel.
Proof.
  constructor. intros t LC.
  induction LC; eauto.
   Unshelve. exact empty.
Qed.

#[local]
Instance subst1_parallel : substitutive parallel.
Proof.
  constructor. unfold subst1.
  intros t t' x u LCu Ptt'.
  induction Ptt'; simpl.
  - (* beta *)
    autorewrite with lngen; auto.
  - (* var *)
    destruct_var_eq;
    eauto using reflexivity.
  - (* abs *)
    pick fresh y and apply p_abs.
    spec y.
    rewrite_subst_open_hyp.
  - (* app *)
    eauto.
Qed.

#[local]
Instance compatible_parallel : compatible parallel.
Proof.
  split.
  + intros x t u Fr P.
    pick fresh y and apply p_abs.
    rewrite (subst_tm_intro x t); auto.
    rewrite (subst_tm_intro x u); auto.
    eapply subst; eauto.
  + intros. eauto using reflexivity.
  + intros. eauto using reflexivity.
Qed.

(** ** Lemma 3.2.4

   Parallel reduction satisfies the second and third substitution properties.
   This is a key part of the Church-Rosser proof.
 *)

(** This is done inline. But we have already identified this property for
   relations, so we'll prove it separately first. *)
Lemma subst2_parallel : subst2 parallel.
Proof.
  unfold subst2.
  intros x t u u' LC P.
  induction LC; simpl.
  - (* var *)
    destruct_var_eq; auto.
  - (* abs *)
    pick fresh y and apply p_abs.
    spec y.
    rewrite_subst_open_hyp.
    eapply lc1; eauto.
    eapply lc2; eauto.
  - (* app *)
    eauto.
Qed.

(** Parallel reduction is *not* transitive. So we need to prove this by induction. *)
Lemma subst3_parallel : subst3 parallel.
Proof.
  unfold subst3.
  intros x t t' u u' Ptt' Puu'.
  have LCu : lc_tm u. { eapply lc1; eauto. }
  have LCu' : lc_tm u'. { eapply lc2; eauto. }
  induction Ptt'; simpl.
  - (* beta *)
    autorewrite with lngen; auto.
  - (* var *)
    destruct_var_eq; auto.
  - (* abs *)
    pick fresh y and apply p_abs.
    spec y.
    rewrite_subst_open_hyp.
  - (* app *)
    eauto.
Qed.

(** A corollary of the above lets us reason about parallel reduction for opened terms. *)
Corollary parallel_open : forall x t t' u u',
  x `notin` fv_tm t
  -> x `notin` fv_tm t'
  -> parallel (t ^ x) (t' ^ x)
  -> parallel u u'
  -> parallel (open t u) (open t' u').
Proof.
  intros x t t' u u' F1 F2 H0 P41.
  move: (subst3_parallel x _ _ _ _ H0 P41) => h.
  repeat rewrite subst_tm_open_tm_wrt_tm in h; eauto.
  eapply lc1; eauto with lngen.
  eapply lc2; eauto with lngen.
  repeat rewrite subst_eq_var in h.
  repeat rewrite subst_tm_fresh_eq in h; auto.
Qed.

(* ================================================================= *)

(** ** Lemma 3.2.6 *)

(** The first of our two key lemmas: parallel reduction satisfies
the diamond property. *)

Lemma diamond_property_parallel : diamond_property parallel.
Proof.
  (* WORKINCLASS *)
  unfold diamond_property.
  intros t t1 t2 H1 H2.
  move: t2 H2. (* make IH stronger *)
  induction H1;
    intros t2 H2; inversion H2; subst.
  - (* beta / beta *)
    destruct (IHparallel1 _ H1) as [t3' [P31 P32]].
    inversion P31. subst.
    inversion P32. subst.
    destruct (IHparallel2 _ H4) as [t4' [P41 P42]].
    pick fresh x. spec x.
    exists (open t'1 t4').
    split; eauto using parallel_open.
  - (* beta / app *)
    destruct (IHparallel1 _ H1) as [t2 [P1 P2]].
    inversion P1. subst.
    destruct (IHparallel2 _ H4) as [t3 [P3 P4]].
    pick fresh x. spec x.
    exists (open t'1 t3).
    split; eauto using parallel_open.
  - (* var / var *)
    exists (var_f x). split; auto.
  - (* abs / abs *)
    pick fresh x. repeat spec x.
    destruct (H0 _ H3) as [t3 [P1 P2]].
    exists (abs (close x t3)).
    split.
    eapply (compatible_abs x);
    autorewrite with lngen; auto.
    eapply (compatible_abs x);
    autorewrite with lngen; auto.
  - (* app / beta *)
    destruct (IHparallel1 _ H1) as [t2 [P1 P2]].
    inversion P2. subst.
    destruct (IHparallel2 _ H4) as [t3 [P3 P4]].
    pick fresh x. spec x.
    exists (open t'1 t3).
    split; eauto using parallel_open.
  - (* app / app *)
    destruct (IHparallel1 _ H1) as [t2 [P1 P2]].
    destruct (IHparallel2 _ H4) as [t3 [P3 P4]].
    exists (app t2 t3).
    split; auto.
Qed. (* /WORKINCLASS *)

(* ================================================================= *)

(** This next part talks about relations between relations. To make this
    a bit easier to work with, we'll introduce some notation for when
    one relation implies another and when one relation is equivalent to
    another
*)

Module RelationNotation.
  Notation "R1 [<=] R2" := (forall t u, R1 t u -> R2 t u).
  Notation "R1 [=] R2" := (forall t u, R1 t u <-> R2 t u).
End RelationNotation.
Import RelationNotation.

(** ** Lemma 3.2.7 *)

(** Lemma 3.2.7 states that

               beta_reduction = trans_closure parallel

   To prove this lemma, Barendregt notes that

           refl_closure (compatible_closure beta) [<=] parallel [<=] beta_reduction

   He then says:

      Since beta_reduction is the transitive closure of the first, then it is also
      the transitive closure of parallel reduction.

  This proof is captured in then next four lemmas.

*)

Lemma refl_compatible_sub_parallel : refl_closure (compatible_closure beta) [<=] parallel.
Proof.
  intros t u H. dependent induction H.
  - dependent induction H.
    + inversion H. eapply p_beta; eauto using reflexivity.
    + pick fresh x. spec x. eapply (compatible_abs x); eauto.
    + eapply compatible_app1; eauto using reflexivity.
    + eapply compatible_app2; eauto using reflexivity.
  - eapply reflexivity; auto.
Qed.

(** *** Exercise [parallel_sub_beta_reduction] *)

Lemma parallel_sub_beta_reduction : parallel [<=] beta_reduction.
Proof. (* ADMITTED *)
  intros.
  induction H; unfold beta_reduction in *; unfold R_reduction in *.
  - apply transitivity with (t2:= app (abs t') u').
    eapply compatible_app; eauto.
    eapply embed.
    eapply embed.
    eapply beta_reduct; eauto using lc1, lc2.
  - eauto.
  - pick fresh x. spec x.
    eapply (compatible_abs x); eauto.
  - eapply compatible_app; eauto.
Qed. (* /ADMITTED *)

Lemma beta_reduction_trans_refl_cc : beta_reduction [=] trans_closure (refl_closure (compatible_closure beta)).
Proof.
  unfold beta_reduction, R_reduction in *.
  split; intros h; dependent induction h; eauto.
  inversion H. eauto. eapply reflexivity. auto.
Qed.

Lemma  beta_reduction_is_trans_closure_parallel :
   beta_reduction [=] trans_closure parallel.
Proof.
  intros.
  split.
  - rewrite beta_reduction_trans_refl_cc.
    (* relies on R1 [<=] R2 implies trans_closure R1 [<=] trans_closure R2
       where R1 is refl_closure (cc beta) and R2 is parallel reduction
     *)
    intros h.
    dependent induction h.
    eapply t_rel.
    eapply refl_compatible_sub_parallel. auto.
    eapply t_trans; eauto.
  - intros h.
    (* relies on R1 [<=] R2 implies trans_closure R1 [<=] trans_closure R2
       where R1 is parallel reduction and R2 is beta_reduction.
       Also observe: trans_closure (beta_reduction) [=] beta_reduction *)
    dependent induction h.
    eapply parallel_sub_beta_reduction; auto.
    eapply transitivity; eauto.
Qed.

(** To use this result, we also need to show that the diamond
    property respects relational equivalence. This is mostly a matter
    of unfolding definitions. *)

Lemma diamond_respects : forall R1 R2,
  R1 [=] R2 ->
  diamond_property R1 ->
  diamond_property R2.
Proof.
  intros R1 R2 rr.
  unfold diamond_property.
  intros db t1 t2 t3 T1 T2.
  rewrite <- rr in T1.
  rewrite <- rr in T2.
  destruct (db t1 t2 t3 T1 T2) as [t4 [b1 b2]].
  exists t4.
  rewrite -> rr in b1.
  rewrite -> rr in b2.
  split; auto.
Qed.

(* ================================================================= *)

(** * Lemma 3.2.8 (Church-Rosser Theorem) *)

Lemma church_rosser_beta : church_rosser beta.
Proof.
  unfold church_rosser.
  fold beta_reduction.
  eapply diamond_respects.
  symmetry.
  eapply beta_reduction_is_trans_closure_parallel.
  apply diamond_property_trans_closure.
  apply diamond_property_parallel.
Qed.

(* ================================================================= *)

(** ** Corollary 3.2.9 (i) *)

Lemma nf_reduce_beta : forall u t, R_nf_of beta u t -> beta_reduction t u.
Proof.
  intros. eapply nf_reduce; eauto.
  typeclasses eauto.
  eapply church_rosser_beta.
Qed.

(** ** Corollary 3.2.9 (ii) *)

Lemma nf_unique_beta : forall u1 u2 t, R_nf_of beta u1 t -> R_nf_of beta u2 t -> u1 = u2.
Proof.
  intros u1 u2 t h1 h2.
  move: (nf_reduce_beta _ _ h1) => r1.
  move: (nf_reduce_beta _ _ h2) => r2.
  destruct h1 as [h1 h1'].
  destruct h2 as [h2 h2'].
  move: (church_rosser_beta _ _ _ r1 r2) => [v [r1' r2']].
  apply nf_noreduction in r1'; auto. destruct r1' as [eq nfv1]. subst.
  apply nf_noreduction in r2'; auto. destruct r2' as [eq nfv2]. subst.
  auto.
Qed.

Lemma joinability t u (H : beta_convertibility t u) :
  exists v, beta_reduction t v /\ beta_reduction u v.
Proof.
  apply convertibility_reduction_diamond.
  apply church_rosser_beta.
  auto.
Qed.

(** ** Main result: different normal forms are not beta convertible. *)

Lemma consistency : forall t u, nf beta t -> nf beta u -> t <> u -> not (beta_convertibility t u).
Proof.
  intros.
  intros h.
  move: (joinability _ _ h) => [v [rtv ruv]].
  move: (nf_noreduction _ H _ rtv) => [EQ nfv].
  move: (nf_noreduction _ H0 _ ruv) => [EQ' nfv'].
  rewrite <- EQ' in EQ.
  contradiction.
Qed.

(** For completness, we will exhibit two different normal forms. *)

(* " \x. \y. x" *)
Definition church_true := abs (abs (var_b 1)).

(* " \x. \y. y" *)
Definition church_false := abs (abs (var_b 0)).

Lemma nf_true : nf beta church_true.
Proof.
  pick fresh x and apply nf_abs.
  pick fresh y and apply nf_abs.
  apply nf_var.
  intro h; inversion h; inversion H.
  intro h; inversion h; inversion H.
  intro h; inversion h; inversion H.
Qed.

Lemma nf_false : nf beta church_false.
Proof.
  pick fresh x and apply nf_abs.
  pick fresh y and apply nf_abs.
  apply nf_var.
  intro h; inversion h; inversion H.
  intro h; inversion h; inversion H.
  intro h; inversion h; inversion H.
Qed.

Lemma not_convertible_true_false : not (beta_convertibility church_true church_false).
Proof.
  apply consistency.
  apply nf_true.
  apply nf_false.
  intro h. inversion h.
Qed.


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.lemma_collinearorder.
Require Import ProofCheckingEuclid.lemma_s_n_col_ncol.
Require Import ProofCheckingEuclid.lemma_s_ncol_n_col.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_NCorder :
	forall A B C,
	nCol A B C ->
	nCol B A C /\ nCol B C A /\ nCol C A B /\ nCol A C B /\ nCol C B A.
Proof.
	intros A B C.
	intros nCol_A_B_C.

	pose proof (lemma_s_ncol_n_col _ _ _ nCol_A_B_C) as n_Col_A_B_C.

	assert (~ Col B A C) as n_Col_B_A_C.
	{
		intros Col_B_A_C.
		pose proof (lemma_collinearorder _ _ _ Col_B_A_C) as (Col_A_B_C & _).
		contradict Col_A_B_C.
		exact n_Col_A_B_C.
	}
	pose proof (lemma_s_n_col_ncol _ _ _ n_Col_B_A_C) as nCol_B_A_C.

	assert (~ Col B C A) as n_Col_B_C_A.
	{
		intros Col_B_C_A.
		pose proof (lemma_collinearorder _ _ _ Col_B_C_A) as (_ & _ & Col_A_B_C & _).
		contradict Col_A_B_C.
		exact n_Col_A_B_C.
	}
	pose proof (lemma_s_n_col_ncol _ _ _ n_Col_B_C_A) as nCol_B_C_A.

	assert (~ Col C A B) as n_Col_C_A_B.
	{
		intros Col_C_A_B.
		pose proof (lemma_collinearorder _ _ _ Col_C_A_B) as (_ & Col_A_B_C & _ ).
		contradict Col_A_B_C.
		exact n_Col_A_B_C.
	}
	pose proof (lemma_s_n_col_ncol _ _ _ n_Col_C_A_B) as nCol_C_A_B.

	assert (~ Col A C B) as n_Col_A_C_B.
	{
		intros Col_A_C_B.
		pose proof (lemma_collinearorder _ _ _ Col_A_C_B) as (_ & _ & _ & Col_A_B_C & _).
		contradict Col_A_B_C.
		exact n_Col_A_B_C.
	}
	pose proof (lemma_s_n_col_ncol _ _ _ n_Col_A_C_B) as nCol_A_C_B.

	assert (~ Col C B A) as n_Col_C_B_A.
	{
		intros Col_C_B_A.
		pose proof (lemma_collinearorder _ _ _ Col_C_B_A) as (_ & _ & _ & _ & Col_A_B_C).
		contradict Col_A_B_C.
		exact n_Col_A_B_C.
	}
	pose proof (lemma_s_n_col_ncol _ _ _ n_Col_C_B_A) as nCol_C_B_A.

	split.
	exact nCol_B_A_C.
	split.
	exact nCol_B_C_A.
	split.
	exact nCol_C_A_B.
	split.
	exact nCol_A_C_B.
	exact nCol_C_B_A.
Qed.

End Euclid.


(** * POrderNat.v : Partial order of nat *)

From Babel Require Import TerminalDogma
                          ExtraDogma.Extensionality.

From Coq Require Import Relations Classical Arith.

From Babel Require Export NaiveSet POrderFacility.

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

Module NatLePoset.

Lemma poset_mixin : Poset.class_of nat.
Proof.
    refine (@Poset.Mixin _ le _).
    constructor.
    move => x. by apply Nat.le_refl.
    move => x y z. by apply Nat.le_trans.
    move => x y. by apply Nat.le_antisymm.
Defined.

Canonical poset_type := Poset nat poset_mixin.

Lemma nat_subset_chainMixin (A : 𝒫(nat)) :
    Chain.mixin_of A.
Proof.
    rewrite /Chain.mixin_of => x Hx y Hy //=.
    by apply Nat.le_ge_cases.
Defined.

(** every subset of nat is a chain *)
Canonical nat_subset_chain (A : 𝒫(nat)) := Chain _ (@nat_subset_chainMixin A).

Module CanonicalStruct.

Canonical poset_type.
Canonical nat_subset_chain.

End CanonicalStruct.

End NatLePoset.


From Coq Require Import Reals List Arith Lia Lra.
From Coquelicot Require Import Coquelicot.
From CoqE2EAI Require Import matrix_extensions.
Import ListNotations.
Import MatrixNotations.

Open Scope colvec_scope.
Open Scope matrix_scope.
Open Scope R_scope.
Open Scope list_scope.

Section Polehydra.

(** * Basic convex polyhedra theory

Convex polyhedron is a set that arises from a series of
linear constraints and describes set of solutions to
a linear inequalities system. We allow only non-strict
inequalities
*)

(** A linear constraint c * _ <= b *)
Inductive LinearConstraint (dim: nat) : Type :=
| Constraint (c: colvec dim) (b:R).

(**
A predicate that a certain point x satisfies a
linear constraint, meaning c*x <= b, where c and b
are from the definition of linear constraint
*)
Definition satisfies_lc {dim: nat} (x: colvec dim) (l: LinearConstraint dim): Prop :=
match l with
| Constraint c b => (c * x)%v <= b
end.

(* Direct evaluation of linear constraint as a function *)
Definition lc_eval {dim: nat} (x: colvec dim) (l: LinearConstraint dim): bool :=
match l with
| Constraint c b => if Rle_dec (dot c x) b then true else false
end.

Theorem lc_eval_correct:
    forall dim (x: colvec dim) l,
        (lc_eval x l = true <-> satisfies_lc x l).
Proof.
    intros dim x l.
    induction l.
    unfold lc_eval.
    unfold satisfies_lc.
    destruct Rle_dec.
    split.
    - intros Htaut. apply r.
    - intros Hdot. reflexivity.
    split.
    - discriminate.
    - intros Hwrong. contradiction.
Qed.

(** A convex polyhedron is described by a set of linear constraints *)
Inductive ConvexPolyhedron (dim: nat) : Type :=
| Polyhedron (constraints: list (LinearConstraint dim)).

(**
A predicate for membership inside of convex polyhedra
x is in the polyhedron <=> x satisfies all linear constraints of the polyherdron
*)
Definition in_convex_polyhedron {dim: nat} (x: colvec dim) (p: ConvexPolyhedron dim) :=
match p with
| Polyhedron lcs =>
    forall constraint, In constraint lcs ->
    satisfies_lc x constraint
end.

Fixpoint polyhedron_eval_helper {dim: nat} (l: list (LinearConstraint dim)) (x: colvec dim): bool :=
match l with
| nil => true
| lc :: next => andb (lc_eval x lc) (polyhedron_eval_helper next x)
end.

(**
Direct evaluation of polyhedron membership as a function into bool
*)
Definition polyhedron_eval {dim: nat} (x: colvec dim) (p: ConvexPolyhedron dim): bool :=
match p with
| Polyhedron constraints => polyhedron_eval_helper constraints x
end.

Theorem polyhedron_eval_correct:
    forall dim (x: colvec dim) p,
        polyhedron_eval x p = true <-> in_convex_polyhedron x p.
Proof.
    intros dim x p.
    induction p.
    unfold polyhedron_eval.
    induction constraints.
    * simpl. split. contradiction. reflexivity.
    split. unfold polyhedron_eval_helper. unfold in_convex_polyhedron.
    {
        intros H constraint HIn.
        unfold In in HIn.
        apply andb_prop in H. destruct H.
        destruct HIn.
        * rewrite <- H1.
          apply lc_eval_correct in H.
          apply H.
        * unfold in_convex_polyhedron in IHconstraints.
          apply IHconstraints.
          apply H0. apply H1.
    }
    {
        intros H.
        unfold polyhedron_eval_helper.
        apply andb_true_intro.
        split.
        * apply lc_eval_correct.
          unfold in_convex_polyhedron in H.
          apply H. compute. left. reflexivity.
        * apply IHconstraints.
          unfold in_convex_polyhedron.
          intros constraint HIn.
          unfold in_convex_polyhedron in H.
          apply H. unfold In. right. apply HIn.
    }
Qed.

(**
Construction of intersection of two polyhedra
*)
Definition polyhedra_intersect {dim: nat} (p1 p2: ConvexPolyhedron dim) :=
    match p1 with
    | Polyhedron l1 =>
        match p2 with
        | Polyhedron l2 =>
            Polyhedron dim (l1 ++ l2)
        end
    end.

Theorem polyhedra_intersect_correct:
    forall dim (x: colvec dim) p1 p2,
        in_convex_polyhedron x p1 /\ in_convex_polyhedron x p2 ->
        in_convex_polyhedron x (polyhedra_intersect p1 p2).
Proof.
    intros dim x p1 p2 Hinboth.
    induction p1. induction p2.
    unfold in_convex_polyhedron.
    unfold polyhedra_intersect.
    intros constraint Hin.
    unfold in_convex_polyhedron in Hinboth.
    destruct Hinboth.
    specialize (H constraint).
    specialize (H0 constraint).
    apply in_app_or in Hin.
    destruct Hin.
    - apply (H H1).
    - apply (H0 H1).
Qed.

End Polehydra.

(** * Constructive piecewise affine functions *)
Section PiecewiseLinear.

(**
PWAF Axiom

For all polehydra pairs (p1 p2) \in body of PWAF f
holds that if p1 and p2 intersect, the corresponding
affine functions are the same, formally: for all
x, such that x \in p1 and x\in p2 holds that

A_1 * x + b_1 = A_2 * x + b_2

where A_i, b_i are affine function parameters
associated with p_i

This guarantees that the output of PWAF is unique
*)
Definition pwaf_univalence
    {in_dim out_dim: nat}
    (l: list (ConvexPolyhedron in_dim * ((matrix out_dim in_dim) * colvec out_dim)))
    :=
    ForallPairs (
        fun e1 e2 =>
            let p1 := fst e1 in
            let p2 := fst e2 in
                forall x,
                    in_convex_polyhedron x p1 /\ in_convex_polyhedron x p2 ->
                    let M1 := fst (snd e1) in
                    let b1 := snd (snd e1) in
                    let M2 := fst (snd e2) in
                    let b2 := snd (snd e2) in
                    ((M1 * x) + b1 = (M2 * x) + b2)%M
    ) l.

(**
Piecewise affine function (PWAF)

A function is affine if it can be expressed as
f(x) = A*x + b
where A is a matrix and b is a vector.

PWAF is defined by multiple polyhedra with an affine
function attached to them. To compute f(x), the value of
PWAF f on input x, one needs to find
a polyhedron to which x belongs and compute f(x)
using affine function.

Members:
- body: list of polyhedra with an associated linear function
- prop: PWAF univalence property

Hypothesis: this is a class of functions that can be
defined using a SMT solver.
*)
Record PWAF (in_dim out_dim: nat): Type := mkPLF {
    body: list (ConvexPolyhedron in_dim * ((matrix out_dim in_dim) * colvec out_dim));
    prop: pwaf_univalence body;
}.

(**
Useful invariant of pwaf_univalence:
if pwaf_univalence holds for a list, it holds for tail of that list as well
*)
Lemma pwaf_univalence_inv:
    forall in_dim out_dim h t,
    pwaf_univalence (in_dim:=in_dim) (out_dim:=out_dim) (h :: t) -> pwaf_univalence t.
Proof.
    intros in_dim out_dim h t Hax.
    unfold pwaf_univalence.
    unfold ForallPairs.
    intros a b HaIn HbIn x Hinpolyh.
    unfold pwaf_univalence in Hax.
    assert (ax1 := Hax).
    unfold ForallPairs in ax1.
    specialize (ax1 a b).
    specialize (ax1 (in_cons h a t HaIn)).
    specialize (ax1 (in_cons h b t HbIn)).
    specialize (ax1 x Hinpolyh).
    apply ax1.
Qed.

(**
A point x is in domain of PWAF f, if it has
a polehydron in body of f

Note that PWAF is not total, it is not required
for polyhedra to cover entire R^n
*)
Definition in_pwaf_domain {in_dim out_dim: nat}
    (f: PWAF in_dim out_dim)
    (x: colvec in_dim) :=
        exists body_el,
            (In body_el (body in_dim out_dim f))
                /\ in_convex_polyhedron x (fst body_el).

(**
A predicate that describes the value of TCPLF-SO f
f(x) = f_x for a TCPLF-SO f
*)
Definition is_pwaf_value {in_dim out_dim: nat}
    (f: PWAF in_dim out_dim)
    (x: colvec in_dim)
    (f_x: colvec out_dim) :=
    in_pwaf_domain f x ->
    exists body_el,
        In body_el (body in_dim out_dim f) /\
            let p := fst body_el in
            let c := fst (snd body_el) in
            let b := snd (snd body_el) in
            in_convex_polyhedron x p /\ Mplus (Mmult c x) b = f_x.

Fixpoint pwaf_eval_helper
    {in_dim out_dim: nat}
    (body: list (ConvexPolyhedron in_dim * ((matrix (T:=R) out_dim in_dim) * colvec out_dim)))
    (x: colvec in_dim)
    :=
    match body with
    | nil => None
    | body_el :: next =>
        match body_el with
        | (polyh, affine_f) =>
            match polyhedron_eval x polyh with
            | true => Some affine_f
            | false => pwaf_eval_helper next x
            end
        end
    end.

Lemma pwaf_eval_helper_some_in_domain:
    forall in_dim out_dim (f: PWAF in_dim out_dim) x,
        in_pwaf_domain f x ->
        exists (body_el: (ConvexPolyhedron in_dim * _)),
            pwaf_eval_helper (body in_dim out_dim f) x = Some (snd body_el).
Proof.
    intros in_dim out_dim f x Hdomain.
    induction f.
    induction body0.
    * destruct Hdomain.
      simpl in H. destruct H. contradiction.
    * simpl. induction a. induction b.
      remember (polyhedron_eval x a) as polyh_eval.
      induction polyh_eval.
      - exists ((a, (a0, b))). reflexivity.
      - specialize (IHbody0 (pwaf_univalence_inv in_dim out_dim (a,(a0,b)) body0 prop0)).
        apply IHbody0.
        unfold in_pwaf_domain.
        destruct Hdomain.
        exists (x0).
        destruct H.
        pose proof (in_inv H) as Hinv.
        destruct Hinv.
        - induction x0. induction b0.
          simpl in H0.
          apply polyhedron_eval_correct in H0.
          apply pair_equal_spec in H1.
          destruct H1.
          apply pair_equal_spec in H2.
          destruct H2.
          rewrite H1 in Heqpolyh_eval.
          rewrite H0 in Heqpolyh_eval.
          discriminate.
        - split.
          * apply H1.
          * apply H0.
Qed.

(**
Function that directly computes the value of
PWAF or outputs None if x is not in the domain
*)
Definition pwaf_eval {in_dim out_dim: nat}
    (f: PWAF in_dim out_dim)
    (x: colvec in_dim) : option (colvec out_dim)
    :=
    match pwaf_eval_helper (body in_dim out_dim f) x with
    | None => None
    | Some (M,b) => Some (Mplus (Mmult M x) b)
    end.

Theorem pwaf_eval_correct :
    forall in_dim out_dim (f: PWAF in_dim out_dim) x f_x,
        pwaf_eval f x = Some f_x <->
        (in_pwaf_domain f x /\ is_pwaf_value f x f_x).
Proof.
    intros in_dim out_dim f x f_x.
    unfold pwaf_eval.
    unfold is_pwaf_value.
    induction f.
    induction body0.
    * split.
      - intros Hhelper.
        unfold pwaf_eval_helper in Hhelper.
        simpl in Hhelper. discriminate.
      - intros Hvalue.
        destruct Hvalue as [Hdomain Hvalue].
        unfold in_pwaf_domain in Hdomain.
        destruct Hdomain.
        unfold In in H. simpl in H. destruct H. contradiction H.
    * induction a. induction b.
      remember (polyhedron_eval x a) as p_eval.
      induction p_eval.
      {
        split.
        - intros Hhelper.
          split.
          - unfold in_pwaf_domain.
            exists (a, (a0, b)).
            split.
            * apply in_eq.
            * symmetry in Heqp_eval.
              rewrite polyhedron_eval_correct in Heqp_eval.
              simpl. apply Heqp_eval.
          - exists (a, (a0, b)).
            split.
            * simpl. left. reflexivity.
            split.
            * symmetry in Heqp_eval.
                rewrite polyhedron_eval_correct in Heqp_eval.
                simpl. apply Heqp_eval.
            * simpl. unfold pwaf_eval_helper in Hhelper.
                simpl in Hhelper.
                rewrite <- Heqp_eval in Hhelper.
                inversion Hhelper. reflexivity.
        - intros Hinpwafdom.
          destruct Hinpwafdom as [Hdomain Hinpwafdom].
          specialize (Hinpwafdom Hdomain).
          unfold pwaf_eval_helper. simpl.
          rewrite <- Heqp_eval.
          destruct Hinpwafdom.
          destruct H. destruct H0.
          rewrite <- H1. simpl.
          unfold pwaf_univalence in prop0.
          unfold ForallPairs in prop0.
          assert (ax0_1 := prop0).
          specialize (ax0_1 (a, (a0, b)) x0 (in_eq _ _) H x).
          simpl in ax0_1. f_equal.
          apply ax0_1.
          split.
          * symmetry in Heqp_eval.
            apply polyhedron_eval_correct in Heqp_eval.
            apply Heqp_eval.
          * apply H0.
      }
      {
        assert (ax0_1:=prop0).
        apply pwaf_univalence_inv in ax0_1.
        specialize (IHbody0 ax0_1).
        unfold pwaf_eval_helper. simpl.
        rewrite <- Heqp_eval.
        fold (pwaf_eval_helper body0 x).
        destruct IHbody0.
        split.
        - intros Heval.
          specialize (H Heval).
          destruct H.
          specialize (H1 H).
          destruct H1.
          split.
          * exists x0.
            split.
            right. apply H1. apply H1.
          * exists x0.
            split.
            right. apply H1. apply H1.
        - intros Hexists.
          destruct Hexists as [Hdomain Hexists].
          specialize (Hexists Hdomain).
          destruct Hexists.
          destruct H1. destruct H2.
          destruct H1.
          * rewrite <- H1 in H2.
            apply polyhedron_eval_correct in H2.
            simpl in H2.
            rewrite H2 in Heqp_eval. discriminate.
          * apply H0.
            split.
            * unfold in_pwaf_domain.
              exists x0. split.
              - apply H1.
              - apply H2.
            * intros Hdomain2.
              unfold in_pwaf_domain in Hdomain2.
              destruct Hdomain2.
              exists x1.
              split. apply H4.
              split. apply H4.
              rewrite <- H3.
              unfold pwaf_univalence in ax0_1.
              unfold ForallPairs in ax0_1.
              apply ax0_1.
              apply H4.
              apply H1.
              split.
              apply H4.
              apply H2.
      }
Qed.

(**
A PWAF representation g of a real function f is a PWAF
that is equal to f everywhwere: for all x f(x) = g(x)
*)
Definition pwaf_representation {in_dim out_dim: nat}
    (f: colvec in_dim -> colvec out_dim)
    (g: PWAF in_dim out_dim) :=
    forall x, is_pwaf_value g x (f x).

(**
A function is piecewise linear if there is a PWAF representations
*)
Definition is_piecewise_linear {in_dim out_dim: nat} (f: colvec in_dim -> colvec out_dim) :=
    exists pwaf,
        pwaf_representation f pwaf.

(**
PWAF is total if the function is defined on all inputs in R^n
*)
Definition is_total {in_dim out_dim: nat} (f: PWAF in_dim out_dim) :=
    forall (x: colvec in_dim), in_pwaf_domain f x.

(**
A TPWAF is a total PWAF
*)
Definition TPWAF (in_dim out_dim: nat) :=
    { f: PWAF in_dim out_dim | is_total f }.

End PiecewiseLinear.

(** * Example proof of piecewise linearity via construction

We prove that a simple ReLU function f([x1, x2]) = [ReLU(2 * x1 + x2), x2] is
piecewise linear by constructing a corresponding TCPLF-SO
using definition from section PiecewiseLinear
*)

Section PiecewiseLinearExample.

(**
Naive/direct defintion of the example simple ReLU function

f([x1, x2]) = [ReLU(2*x1 + x2), x2]
*)
Definition simpleReLU (x: colvec 2) :=
    let c := mk_colvec 2 (
        fun i =>
            match i with
            | 0 => 2
            | 1 => 1
            | _ => 0
            end
        ) in
    let sum := dot c x in
    let relu_result := if Rle_dec sum 0 then 0 else sum in
    mk_colvec 2 (
        fun i =>
            match i with
            | 0 => relu_result
            | 1 => coeff_colvec 0 x 1
            | _ => 0
            end
    ).

(**
Construction of TCPLF for simple ReLU finction example

TCPLF consists of:
- A polyhedron for 2 * x1 + x2 <= 0
- A polyhedron for 2 * x1 + x2 >= 0
- Proofs of axioms
*)

Definition c_vector := mk_colvec 2 (
    fun i =>
        match i with
        | 0 => 2
        | 1 => 1
        | _ => 0
        end
).
Definition minus_c_vector := scalar_mult (Ropp 1) c_vector.

Definition lincon1 := Constraint 2 c_vector 0.
Definition lincon2 := Constraint 2 minus_c_vector 0.

(** Polyhedron for 2 * x1 + x2 <= 0 *)
Definition polyhedra1 := Polyhedron 2 [lincon1].

(** Polyhedron for 2 * x1 + x2 >= 0 which is equivalent to
    - 2 * x1 - x2 <= 0 *)
Definition polyhedra2 := Polyhedron 2 [lincon2].
Definition polyhedra_simpleReLU := [polyhedra1; polyhedra2].

(**
Function body for TCPLF-SO of simple ReLU

Polyhedron 1 -> [0, x2]
Polyhedron 2 -> [2 * x1 + x2, x2]
*)
Definition matrix1 :=
    mk_matrix 2 2 (
        fun i j =>
            match i, j with
            | 0, 0 => 0
            | 0, 1 => 0
            | 1, 0 => 0
            | 1, 1 => 1
            | _, _ => 0
            end
    ).

Definition matrix2 :=
    mk_matrix 2 2 (
        fun i j =>
            match i, j with
            | 0, 0 => 2
            | 0, 1 => 1
            | 1, 0 => 0
            | 1, 1 => 1
            | _, _ => 0
            end
    ).

Definition simpleReLU_body := [
    (polyhedra1, (matrix1, null_vector 2)); (polyhedra2, (matrix2, null_vector 2))
].

(**
Lemma: two polyhedra intersect at exactly 2*x1 + x2 = 0

Proof requires inference in hypothesis of intersection to
arrive at 2 * x1 + x2 <= 0 and 2 * x1 + x2 >= 0 which is then
proven using Rle_anitsym
*)
Lemma simpleReLU_polyhedra_intersection:
    forall x,
        in_convex_polyhedron x polyhedra1 /\ in_convex_polyhedron x polyhedra2 ->
        dot c_vector x = 0.
Proof.
    intros x. simpl.
    unfold satisfies_lc.
    intros H. destruct H.
    specialize (H lincon1). specialize (H0 lincon2).
    unfold lincon1 in H. unfold lincon2 in H0.
    assert (forall dim (c: LinearConstraint dim), c = c \/ False). {
        intros dim c. left. reflexivity.
    }
    specialize (H1 2%nat lincon1) as H11.
    specialize (H1 2%nat lincon2) as H12.
    apply H in H11. apply H0 in H12.
    unfold minus_c_vector in H12.
    rewrite dot_scalar_mult in H12.
    apply Ropp_le_ge_contravar in H12.
    rewrite Ropp_0 in H12.
    rewrite Ropp_mult_distr_l in H12.
    rewrite Ropp_involutive in H12.
    rewrite Rmult_1_l in H12.
    apply Rge_le in H12.
    apply (Rle_antisym _ _ H11) in H12.
    apply H12.
Qed.

(**
Theorem: univalence holds for simple ReLU. This means
that for two polyhedra of simple ReLU, the function is uniquely
defined at their intersection

Proof: we first destruct the goal sufficiently to create a proof
goal for each polyhedra pair and then show for each pair that
the function is the same using simple_ReLU_polyhedra_intersection
lemma
*)
Theorem simpleReLU_prop:
    pwaf_univalence simpleReLU_body.
Proof.
    unfold pwaf_univalence.
    unfold ForallPairs.
    intros a b.
    unfold In. simpl.
    intros Ha Hb x Hintersect.
    assert (Hmain:
        in_convex_polyhedron x polyhedra1 /\ in_convex_polyhedron x polyhedra2 ->
            Mplus (Mmult matrix1 x) (null_vector 2) =
            Mplus (Mmult matrix2 x) (null_vector 2)). {
        intros Hinboth.
        repeat rewrite Mplus_null_vector.
        repeat rewrite Mmult_dot_split.
        unfold mk_colvec.
        apply mk_matrix_ext.
        intros i j Hi Hj.
        induction i.
        * assert (Hequal: mk_matrix 2 1 (fun i _ : nat => coeff_mat 0 matrix2 0 i) = c_vector). {
            unfold c_vector. unfold mk_colvec.
            unfold matrix2. reflexivity.
            }
            rewrite Hequal.
            rewrite simpleReLU_polyhedra_intersection.
            unfold dot. unfold Mmult.
            rewrite coeff_mat_bij. unfold sum_n.
            assert (Hzero: forall n m, sum_n_m (fun _ => zero) n m = 0). {
            intros n m.
            rewrite (sum_n_m_const_zero n m).
            reflexivity.
            }
            rewrite <- (Hzero 0%nat 1%nat) at 1.
            apply sum_n_m_ext_loc.
            intros n Hn.
            unfold transpose.
            rewrite coeff_mat_bij.
            unfold coeff_colvec.
            rewrite coeff_mat_bij.
            unfold matrix1.
            rewrite coeff_mat_bij.
            induction n.
            - rewrite Rmult_0_l. reflexivity.
            - induction n. rewrite Rmult_0_l. reflexivity.
            rewrite Rmult_0_l. reflexivity.
            lia. lia. lia. lia. lia. lia. lia. lia.
            apply Hinboth.
        * unfold matrix1. unfold matrix2. compute. reflexivity.
    }
    destruct Ha. destruct Hb.
    * unfold Mplus. unfold mk_colvec. apply mk_matrix_ext.
      intros i j Hi Hj.
      rewrite <- H. rewrite <- H0. simpl. reflexivity.
    * destruct H0.
      - rewrite <- H. rewrite <- H0. simpl.
        apply Hmain.
        rewrite <- H in Hintersect.
        rewrite <- H0 in Hintersect.
        simpl in Hintersect.
        apply Hintersect.
      - contradiction.
    * destruct H. destruct Hb.
      {
        rewrite <- H. rewrite <- H0. simpl.
        symmetry. apply Hmain.
        rewrite <- H in Hintersect.
        rewrite <- H0 in Hintersect.
        destruct Hintersect. split. apply H2. apply H1.
      }
      destruct H0.
      {
        rewrite <- H. rewrite <- H0. simpl.
        reflexivity.
      }
      - contradiction.
    - contradiction.
Qed.

(**
PWAF for simple ReLU
*)
Definition simpleReLU_PWAF := mkPLF 2 2 simpleReLU_body simpleReLU_prop.

(**
Theorem: naive definition of simple ReLU example, simpleReLU,
is represented by PWAF and hence piecewise linear

Proof: mostly utilizes Rle_dec (x <= y) \/ ~ (x <= y) to
arrive at four cases for each possible polyhedra and if-statement result
of the naive definition where we then show either contradiction or
equality of function values
*)
Theorem simpleReLU_piecewise_linear:
    is_piecewise_linear simpleReLU.
Proof.
    unfold is_piecewise_linear.
    exists simpleReLU_PWAF.
    unfold pwaf_representation.
    intros x.
    unfold is_pwaf_value.
    destruct (Rle_dec (dot c_vector x) 0).
    * exists (polyhedra1, (matrix1, null_vector 2)).
      split.
      * simpl. left. reflexivity.
      * split.
        - unfold in_convex_polyhedron.
          simpl.
          intros constraint Hconstraint.
          destruct Hconstraint.
          rewrite <- H0.
          unfold satisfies_lc. simpl.
          apply r. contradiction.
        - rewrite Mplus_null_vector.
          rewrite Mmult_dot_split.
          unfold simpleReLU.
          fold c_vector.
          destruct (Rle_dec (dot c_vector x) 0).
          unfold mk_colvec.
          apply mk_matrix_ext.
          intros i j Hi Hj.
          induction i.
          rewrite dot_null_vector. reflexivity.
          induction i.
          * unfold dot.
            unfold Mmult.
            rewrite coeff_mat_bij.
            unfold sum_n. unfold sum_n_m.
            unfold Iter.iter_nat. simpl.
            unfold transpose. unfold coeff_colvec.
            unfold matrix1.
            repeat rewrite coeff_mat_bij.
            rewrite Rmult_0_l. rewrite Rplus_0_l.
            rewrite Rmult_1_l. rewrite Rplus_0_r.
            unfold coeff_colvec.
            reflexivity.
            lia. lia. lia. lia. lia. lia. lia. lia.
            lia. lia. lia. lia. lia. lia. lia. contradiction.
    * exists (polyhedra2, (matrix2, null_vector 2)).
      split.
      * simpl. right. left. reflexivity.
      * apply Rnot_le_gt in n.
        split.
        - unfold in_convex_polyhedron.
          intros constraint Hconstraint.
          destruct Hconstraint.
          rewrite <- H0.
          unfold satisfies_lc. unfold lincon2.
          unfold minus_c_vector.
          rewrite dot_scalar_mult.
          rewrite <- Ropp_mult_distr_l.
          rewrite Rmult_1_l.
          rewrite <- Ropp_0.
          apply Ropp_le_contravar.
          apply Rlt_le. apply n.
          contradiction.
        - rewrite Mplus_null_vector.
          rewrite Mmult_dot_split.
          unfold simpleReLU.
          fold c_vector.
          destruct (Rle_dec (dot c_vector x) 0).
          apply Rle_not_gt in r. contradiction.
          unfold mk_colvec. apply mk_matrix_ext.
          intros i j Hi Hj.
          induction i.
          reflexivity.
          induction i.
          * unfold dot. unfold Mmult.
          rewrite coeff_mat_bij.
          unfold sum_n. unfold sum_n_m. unfold Iter.iter_nat.
          simpl.
          unfold transpose. unfold coeff_colvec.
          unfold matrix1.
          repeat rewrite coeff_mat_bij.
          rewrite Rmult_0_l. rewrite Rplus_0_l.
          rewrite Rmult_1_l. rewrite Rplus_0_r.
          unfold coeff_colvec.
          reflexivity.
          lia. lia. lia. lia. lia. lia.
          lia. lia. lia. lia. lia.
Qed.

(**
Lemma: for all [x1, x2], 2 * x1 + x2 <= 0 or 2 * x1 + x2 >= 0

Proof: By specializing Rle_or_lt that tells that for real numbers
holds (x <= y) or (y < x), we arrive that either 2 * x1 + x2 <= 0 or
0 <= 2 * x1 + x2 that correspond to constraints of simple ReLU polyhedra
*)
Lemma simpleReLU_full_R_split:
    forall x,
        satisfies_lc x lincon1 \/ satisfies_lc x lincon2.
Proof.
    intros x.
    unfold satisfies_lc.
    simpl.
    unfold minus_c_vector.
    rewrite dot_scalar_mult.
    rewrite <- Ropp_0 at 2.
    rewrite <- Ropp_mult_distr_l.
    rewrite Rmult_1_l.
    pose proof (Rle_or_lt (dot c_vector x) 0) as H.
    destruct H.
    * left. apply H.
    * right. apply Ropp_ge_le_contravar. apply Rle_ge. apply Rlt_le. apply H.
Qed.

(**
Theorem: simple ReLU is a total function

Proof: follows mostly from the simple_ReLU_full_R_split lemma,
we just need to show what polyhedron contains constraint needed
*)
Theorem simpleReLU_total:
    is_total simpleReLU_PWAF.
Proof.
    unfold is_total.
    unfold in_pwaf_domain.
    intros x.
    pose proof (simpleReLU_full_R_split x).
    destruct H.
    - exists (polyhedra1, (matrix1, null_vector 2)). split.
      * simpl. left. reflexivity.
      * unfold in_convex_polyhedron. simpl.
        intros constraint Hconstraint.
        destruct Hconstraint.
        rewrite <- H0. apply H.
        contradiction.
    - exists (polyhedra2, (matrix2, null_vector 2)). split.
      * simpl. right. left. reflexivity.
      * unfold in_convex_polyhedron. simpl.
        intros constraint Hconstraint.
        destruct Hconstraint.
        rewrite <- H0. apply H.
        contradiction.
Qed.

Definition simpleReLU_TPWAF: TPWAF 2 2 :=
    exist _ simpleReLU_PWAF simpleReLU_total.

End PiecewiseLinearExample.


Require Import Logic.Eqdep.
Require Export Relations.Relation_Definitions.
Require Export Wellfounded.
Require Import Lists.SetoidList.
Require Import Arith.
Require Import Omega.
Require Import Utf8.

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

Section relations.

Variable A : Type.

(* Inverse relation *)
Definition inv (R : relation A) : relation A := fun x y => R y x.

(* Strict subrelation *)
Definition strict (R : relation A) : relation A :=
  fun x y => R x y /\ x <> y.

Definition ascending_chain (R : relation A)
  := well_founded (strict (inv R)).

End relations.

Section SymProduct.

Variable A : Type.
Variable B : Type.
Variable leA : relation A.
Variable leB : relation B.

Inductive symprod : relation (A * B) :=
  | left_sym :
    forall x x', leA x x' ->
                 forall y, symprod (x, y) (x', y)
  | right_sym :
    forall y y', leB y y' ->
                 forall x, symprod (x, y) (x, y').

Variable leA_wf : well_founded leA.
Variable leB_wf : well_founded leB.

Lemma symprod_wf : well_founded symprod.
Proof.
intros [a b].
revert b.
apply Acc_ind with (R:=leA) (x:=a); auto; clear a.
intros a _ Ha b.
apply Acc_ind with (R:=leB) (x:=b); auto; clear b.
intros b _ Hb.
apply Acc_intro; intros [x y] Hxy.
inversion Hxy; subst; now firstorder.
Qed.

End SymProduct.

Section LexProduct.

Variable A : Type.
Variable B : Type.
Variable leA : relation A.
Variable leB : relation B.

Inductive lexprod : relation (A * B) :=
  | left_lex :
    forall x x' y y',
      leA x x' -> lexprod (x,y) (x',y')
  | right_lex :
    forall x y y',
      leB y y' -> lexprod (x,y) (x,y').

Variable leA_wf : well_founded leA.
Variable leB_wf : well_founded leB.

Lemma lexprod_wf : well_founded lexprod.
Proof.
intros [a b].
assert (Ha : Acc leA a) by auto.
revert b.
apply Acc_ind with (R:=leA) (x:=a); auto; clear dependent a.
intros a _ Ha b.
apply Acc_ind with (R:=leB) (x:=b); auto; clear b.
intros b _ Hb.
apply Acc_intro; intros [x y] Hxy.
inversion Hxy; subst; now firstorder.
Qed.

End LexProduct.

Section vector_defs.

Variable A : Type.

Inductive vector : nat -> Type :=
| vec_nil : vector 0
| vec_cons : forall n, A -> vector n -> vector (S n).

Definition eq_vec := eq_dep nat vector.

Fixpoint vector_of (l : list A) : {n : nat & vector n} :=
  match l with
    | nil => existT _ 0 vec_nil
    | cons h t =>
        let (n,l) := vector_of t in
          existT _ (S n) (vec_cons h l)
  end.

Fixpoint list_of n (v : vector n) : list A :=
  match v with
    | vec_nil => nil
    | vec_cons _ h t => cons h (list_of t)
  end.

Lemma len_vector_of (l : list A) :
  projT1 (vector_of l) = length l.
Proof.
induction l as [| h t IH]; auto.
simpl. destruct (vector_of t) as [n v]; simpl; simpl in IH.
now rewrite IH.
Qed.

Definition head' n (v : vector n) :=
  match v in vector x return lt 0 x -> A with
    | vec_nil =>
        fun H : lt O O => (False_rect A (lt_irrefl O H))
    | vec_cons n' h _ =>
        fun H : lt 0 (S n') => h
  end.

Definition head n (v : vector (S n)) :=
  head' (n:=S n) v (lt_O_Sn n).

Definition tail n (v : vector n) :=
  match v in vector x return vector (pred x) with
    | vec_nil => vec_nil
    | vec_cons _ _ v' => v'
  end.

Fixpoint nth_aux n (v : vector n) i :
  lt i n -> A :=
  match v, i with
    | vec_nil, _ => fun (H : i < 0) => False_rect A (lt_n_0 i H)
    | vec_cons n' h _, 0 => fun (H : 0 < S n') => h
    | vec_cons n' _ t, S i' =>
        fun (H : S i' < S n') => @nth_aux n' t i' (lt_S_n _ _ H)
  end.

Definition nth n (v : vector n) (i : {i | i < n}) :=
  nth_aux v (proj2_sig i).

Lemma empty_dep n (v : vector n) :
  n = O -> @eq_vec n v 0 vec_nil.
Proof.
intros e.
dependent inversion v.
- easy.
- now subst.
Qed.
Hint Resolve empty_dep.

Lemma empty (v : vector O) : v = vec_nil.
Proof.
apply (eq_dep_eq nat vector O).
now apply empty_dep.
Qed.
Hint Resolve empty.

Lemma non_empty_dep n (v : vector (S n)) :
  {h : A & {t : vector n |
            @eq_vec (S n) v (S n) (vec_cons h t)}}.
Proof.
dependent inversion_clear v with
  (fun n' (v: vector n') =>
     {a : A & {v' : vector n |
               @eq_vec n' v (S n) (vec_cons a v')}}).
now exists a, v0.
Qed.

Lemma non_empty n (v :vector (S n)) :
  {a : A & {t : vector n | v = vec_cons a t}}.
Proof.
assert (H := non_empty_dep v).
destruct H as [h [t H]].
exists h, t. now apply eq_dep_eq.
Qed.

Lemma split_vec n (v : vector (S n)) :
  v = vec_cons (head v) (tail v).
Proof.
destruct (non_empty v) as [h [t H]].
now subst.
Qed.

Lemma nth_0_is_head n (v : vector (S n)) :
  head v = nth v (exist _ 0 (lt_0_Sn n)).
Proof.
now rewrite (split_vec v).
Qed.

Lemma nth_irrel n (v : vector n) i (H H' : i < n) :
  nth_aux v H = nth_aux v H'.
Proof.
revert i H H'.
induction n as [| n IHn].
- easy.
- rewrite (split_vec v).
  destruct i as [| i]; auto.
  intros H H'.
  now simpl.
Qed.

Lemma nth_cons n (v : vector n) a i H (Hi : i > 0) :
  exists H',
    @nth_aux _ (vec_cons a v) i H = @nth_aux _ v (i-1) H'.
Proof.
destruct i; [easy |].
simpl in H. simpl.
revert H. rewrite <- minus_n_O.
intros H.
assert (H' : i < n) by omega.
exists H'. now apply nth_irrel.
Qed.

End vector_defs.

Section search.

Variable A : Type.

Fixpoint has n (v : vector A n) a : Prop :=
  match v with
    | vec_nil => False
    | vec_cons n' h t => h = a \/ has t a
  end.

Lemma has_nil a : ~ has (vec_nil A) a.
Proof.
easy.
Qed.

Lemma has_cons a n h (t : vector A n) :
  a <> h -> has (vec_cons h t) a -> has t a.
Proof.
simpl. intros ne H. now destruct H; try congruence.
Qed.

Lemma InA_has l a :
  InA eq a l ->
  let (_, v) := vector_of l in has v a.
Proof.
induction l as [| h t IH].
- easy.
- intros H.
  inversion H; subst.
  + simpl.
    destruct (vector_of t) as [nt vt].
    now left.
  + simpl.
    destruct (vector_of t) as [nt vt].
    now right; auto.
Qed.

Variable eq_dec : forall a a' : A, {a = a'} + {a <> a'}.

Fixpoint find'_aux n (v : vector A n) a count :=
  match v return has v a -> nat with
    | vec_nil =>
        fun H : has (vec_nil A) a => False_rect nat (has_nil H)
    | vec_cons n' h t =>
        fun H : has (vec_cons h t) a =>
          match eq_dec a h with
            | left _ => count
            | right ne =>
                @find'_aux n' t a (S count) (has_cons ne H)
          end
  end.

Definition find' n (v : vector A n) a := @find'_aux n v a 0.

Lemma find'_aux_irrel n (v : vector A n) a c (H1 H2 : has v a) :
  find'_aux c H1 = find'_aux c H2.
Proof.
revert c H1 H2.
induction v as [| n' h t IH].
- intros c H1 H2. now elim (has_nil H1).
- intros c H1 H2.
  unfold find'. unfold find' in IH.
  simpl.
  now destruct (eq_dec a h).
Qed.

Lemma find'_aux_shift n (v : vector A n) a c (H : has v a) :
  find'_aux c H = find'_aux 0 H + c.
Proof.
revert c.
induction v as [| n' h t IH].
- now elim (has_nil H).
- intros c. simpl.
  destruct (eq_dec a h); auto.
  rewrite IH with (c:=S c).
  rewrite IH with (c:=1).
  omega.
Qed.

Lemma find'_irrel n (v : vector A n) a (H1 H2 : has v a) :
  find' H1 = find' H2.
Proof.
unfold find'.
now apply find'_aux_irrel.
Qed.

Lemma find'_cons_0 n (v : vector A n) a H :
  @find' _ (vec_cons a v) a H = 0.
Proof.
unfold find', find'_aux. simpl.
now destruct (eq_dec a a); congruence.
Qed.

Lemma find'_cons_1 n (v : vector A n) h a Hcons H (Ha : a <> h) :
  @find' _ (vec_cons h v) a Hcons = S (@find' _ v a H).
Proof.
unfold find'. simpl.
destruct (eq_dec a h) as [e | ne]; [easy |].
rewrite find'_aux_shift.
rewrite find'_aux_irrel with (H2:=H).
omega.
Qed.

Lemma find'_cons_1_bis n (v : vector A n) h a H (Ha : a <> h) :
  exists H', @find' _ (vec_cons h v) a H = @find' _ v a H' + 1.
Proof.
unfold find'. simpl.
destruct (eq_dec a h) as [e | ne]; [easy |].
rewrite find'_aux_shift.
now eauto.
Qed.

Lemma find'_cons_2 n (v : vector A n) h a H (Ha : a <> h) :
  @find' _ (vec_cons h v) a H > 0.
Proof.
destruct (find'_cons_1_bis H Ha) as [H' e].
rewrite e; now auto with arith.
Qed.

Lemma find'_aux_le n (v : vector A n) a (H : has v a) c :
  find'_aux c H < n + c.
Proof.
revert c.
induction v as [| n' h t IH].
- now elim (has_nil H).
- simpl.
  destruct (eq_dec a h).
  + now auto with arith.
  + simpl. intros c.
    now rewrite plus_n_Sm.
Qed.

Lemma find'_le n (v : vector A n) a (H : has v a) : find' H < n.
Proof.
unfold find.
rewrite <- (plus_0_r n).
now apply find'_aux_le.
Qed.

Definition find n (v : vector A n) a (H : has v a) : {i | i < n}.
exists (find' H).
now apply find'_le.
Defined.

Lemma nth_aux_find n (v : vector A n) a (Ha : has v a) H :
    @nth_aux A _ v (find' Ha) H = a.
Proof.
induction v as [| n' h t IH].
- now elim (has_nil Ha).
- destruct (eq_dec a h) as [e | ne] eqn:E; [subst h |].
  + destruct (@find' _ (@vec_cons A _ a t) a Ha) eqn:Habs; auto.
    now rewrite find'_cons_0 in Habs.
  + destruct (@find' (S n') (@vec_cons A n' h t) a Ha) eqn:Hcons.
    * assert (Htmp := find'_cons_2 Ha ne).
      now rewrite Hcons in Htmp.
    * destruct (nth_cons t h H) as [H' e]; auto with arith.
      rewrite e; clear e.
      revert H'. simpl. rewrite <- (minus_n_O n).
      intros H'.
      assert (Htmp := find'_cons_1 Ha (has_cons ne Ha) ne).
      rewrite Htmp in Hcons; clear Htmp.
      inversion Hcons as [H0]; clear Hcons.
      now subst n.
Qed.

Lemma nth_find n (v : vector A n) a (Ha : has v a) :
    @nth A _ v (find Ha) = a.
Proof.
unfold nth, find. simpl.
now apply nth_aux_find.
Qed.

End search.

Section map.

Variables A B : Type.

Fixpoint map n (v : vector A n) (f : A -> B) : vector B n :=
  match v with
    | vec_nil => vec_nil B
    | vec_cons n' h t => vec_cons (f h) (map t f)
  end.

Lemma nth_map n (v : vector A n) (f : A -> B) :
  forall i : {i | i < n},
    nth (map v f) i = f (nth v i).
Proof.
intros i.
induction v.
- now elim i.
- destruct i as [i Hi].
  revert Hi. destruct i as [| i]; auto.
  intros Hi.
  simpl.
  apply (IHv (exist _ i (lt_S_n _ _ Hi))).
Qed.

Lemma map_nth n (va : vector A n) (vb : vector B n) (f : A -> B) :
  (forall i : {i | i < n}, f (nth va i) = nth vb i) ->
  map va f = vb.
Proof.
induction va.
- now rewrite (empty vb).
- intros H.
  rewrite (split_vec vb).
  simpl.
  f_equal.
  + specialize H with (exist _ 0 (lt_0_Sn _)).
    unfold nth in H. simpl in H.
    now rewrite nth_0_is_head.
  + eapply IHva.
    intros [i Hi].
    rewrite (split_vec vb) in H.
    specialize H with (exist _ (S i) (lt_n_S _ _ Hi)).
    unfold nth in H. simpl in H.
    unfold nth. simpl.
    rewrite (nth_irrel va)
            with (H':=lt_S_n i n (lt_n_S i n Hi)).
    now rewrite (nth_irrel (tail vb))
            with (H':=lt_S_n i n (lt_n_S i n Hi)).
Qed.

End map.

Section orderings.

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

Variable leA : relation A.
Variable leA_wf : well_founded leA.

(* Pointwise ordering on vectors *)
Inductive lp_vector : forall n, relation (vector A n) :=
| lp_nil : @lp_vector 0 (vec_nil A) (vec_nil A)
| lp_cons :
    forall a a' n v v',
      leA a a' ->
      @lp_vector n v v' ->
      @lp_vector (S n) (vec_cons a v) (vec_cons a' v').

Lemma lp_vector_nth n (v w : vector A n) :
  (forall i : {i | i < n}, leA (nth v i) (nth w i)) ->
  lp_vector v w.
Proof.
induction v.
- intros _. rewrite (empty w).
  now apply lp_nil.
- intros H.
  rewrite (split_vec w).
  apply lp_cons.
  + specialize H with (exist _ 0 (lt_0_Sn _)).
    unfold nth in H. simpl in H.
    now rewrite nth_0_is_head.
  + apply IHv.
    intros [i Hi].
    rewrite (split_vec w) in H.
    specialize H with (exist _ (S i) (lt_n_S _ _ Hi)).
    unfold nth in H. simpl in H.
    unfold nth. simpl.
    rewrite (nth_irrel v)
            with (H':=lt_S_n i n (lt_n_S i n Hi)).
    now rewrite (nth_irrel (tail w))
            with (H':=lt_S_n i n (lt_n_S i n Hi)).
Qed.

(* Lexicographical ordering on vectors *)
Inductive lex_vector : forall n, relation (vector A n) :=
| lex_vector_left :
    forall a a' n v v',
      leA a a' ->
      @lex_vector (S n) (vec_cons a v) (vec_cons a' v')
| lex_vector_right :
    forall a n v v',
      @lex_vector n v v' ->
      @lex_vector (S n) (vec_cons a v) (vec_cons a v').

Lemma lex_vector_Acc_step n :
  (forall v, Acc (@lex_vector n) v) ->
  forall a v,
    Acc (@lex_vector (S n)) (vec_cons a v).
Proof.
intros Hn a.
apply Acc_ind with (R := leA) (x:=a); auto; clear a.
intros a _ Ha.
intros v.
apply Acc_ind with (R := lex_vector (n:=n)) (x:=v); auto; clear v.
intros v _ Hv.
constructor.
intros w Hw. inversion Hw; subst.
- apply inj_pair2 in H0.
  apply inj_pair2 in H3.
  now subst; auto.
- apply inj_pair2 in H0.
  apply inj_pair2 in H3.
  now subst; auto.
Qed.

Lemma lex_vector_0_wf : well_founded (@lex_vector 0).
Proof.
intros v.
dependent inversion v.
constructor.
intros w Hw.
now inversion Hw.
Qed.

Lemma lex_vector_wf_step n :
  well_founded (@lex_vector n) ->
  well_founded (@lex_vector (S n)).
Proof.
intros H.
intros v.
dependent inversion v as [| ? a v']; subst.
constructor.
intros w Hw.
dependent inversion w as [| ? b w']; subst.
now apply lex_vector_Acc_step.
Qed.

Theorem lex_vector_wf n : well_founded (@lex_vector n).
Proof.
induction n as [| n IHn].
- now apply lex_vector_0_wf.
- now apply lex_vector_wf_step.
Qed.

End orderings.

Section lp_ascending.

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

Variable leA : relation A.

Lemma lp_vector_to_lex_vector_inv n (v v' : vector A n) :
  strict (inv (lp_vector leA (n:=n))) v v' ->
  lex_vector (strict (inv leA)) v v'.
Proof.
induction v.
- rewrite (empty v').
  intros H. inversion H. now firstorder.
- rewrite (split_vec v').
  intros H.
  destruct H as [H Hconsv].
  case (eq_dec a (head v')) as [e | ne].
  + rewrite <- e.
    apply lex_vector_right.
    apply IHv; clear IHv.
    rewrite <- e in Hconsv.
    unfold inv in *.
    split.
    * inversion H; subst.
      apply inj_pair2 in H2.
      apply inj_pair2 in H5.
      now subst.
    * intros Hv. now subst; auto.
  + apply lex_vector_left.
    split; auto.
    unfold inv in *.
    now inversion H; subst.
Qed.

Lemma asc_lp_vector n :
  ascending_chain leA ->
  ascending_chain (lp_vector leA (n:=n)).
Proof.
unfold ascending_chain.
intros H.
apply wf_incl with (@lex_vector A (strict (inv leA)) n).
- unfold inclusion. now apply lp_vector_to_lex_vector_inv.
- now apply lex_vector_wf.
Qed.

End lp_ascending.


Require Export Lci.
Require Export misc.
Require Export Arith.
Require Export groups.
Require Export rings.
Require Export ZArith.
Require Import Omega.

(* Addition on Z, (Z, +) is a group *)

Definition IdZ (x : Z) := True.

Theorem Z_group : is_group Z IdZ Zplus 0%Z Zopp.
Proof.
split.
red in |- *; trivial.
split.
red in |- *; auto with zarith.
split; red in |- *.
split; auto with zarith.
unfold IdZ in |- *; trivial.
split; auto with zarith.
Qed.

(* Multiplication on Z, (Z, +, *, 0, 1) is a unitary commutative ring *)

Theorem Z_ring : is_ring Z IdZ Zplus Zmult 0%Z Zopp.
Proof.
unfold is_ring in |- *.
split.
red in |- *; auto with zarith.
split. exact Z_group.
split. unfold intern in |- *. intros. exact I.
split; red in |- *; auto with zarith.
Qed.

Theorem Z_unitary_commutative_ring :
 is_unitary_commutative_ring Z IdZ Zplus Zmult 0%Z 1%Z Zopp.
Proof.
unfold is_unitary_commutative_ring in |- *.
split. exact Z_ring.
split.
red in |- *; auto with zarith.
split.
unfold IdZ in |- *; trivial.
split; auto with zarith.
Qed.

(* Z is an integral domain *)

Theorem integrityZ : integrity Z Zmult 0%Z.
Proof.
unfold integrity in |- *.
intros a b; elim a.
(* OZ *)
intros; left; reflexivity.
(* pos n *)
intros; right.
generalize H; clear H; simpl in |- *; case b; intros; inversion H; trivial.
(* neg n *)
intros; right.
generalize H; clear H; simpl in |- *; case b; intros; inversion H; trivial.
Qed.

Lemma inversibleZ :
 forall x : Z, inversible Z Zmult 1%Z x -> x = 1%Z \/ x = (-1)%Z.
Proof.
unfold inversible in |- *.
intros.
inversion_clear H.
inversion_clear H0.
clear H1.
generalize H; clear H.
(* [x>0] *)
elim (Z_lt_ge_dec 0 x); intros.
left.
elim (Z_le_lt_eq_dec 1 x); auto with zarith; intros.
cut (1 > x0)%Z; intros.
absurd (0 < x0)%Z; intros; auto with zarith.
apply Zgt_lt.
apply Zmult_gt_0_reg_l with x; auto with zarith.
apply Zmult_gt_reg_r with x; auto with zarith.
rewrite Zmult_1_l; rewrite Zmult_comm; auto with zarith.
(*[x<0] *)
elim (Z_le_lt_eq_dec x 0); auto with zarith; intros.
clear b.
right.
elim (Z_le_lt_eq_dec 1 (- x)); auto with zarith; intros.
cut (1 > - x0)%Z; intros.
absurd (0 < - x0)%Z; intros; auto with zarith.
apply Zgt_lt.
apply Zmult_gt_0_reg_l with (- x)%Z; auto with zarith.
rewrite Zopp_mult_distr_l_reverse; rewrite <- Zopp_mult_distr_r;
 auto with zarith.
apply Zmult_gt_reg_r with (- x)%Z; auto with zarith.
rewrite Zmult_1_l; rewrite Zmult_comm.
rewrite Zopp_mult_distr_l_reverse; rewrite <- Zopp_mult_distr_r;
 auto with zarith.
(* [x=0] *)
rewrite b0 in H; simpl in H; inversion H.
Qed.


Require Import Arith Omega Coq.Logic.Classical List.

Section minExists.
  Context {P : nat -> Prop}.
  Lemma leastOrNone x :
    (exists x, P x /\ forall y, y < x -> ~ P y) \/
                                                forall y, y <= x -> ~ P y.
  Proof.
    induction x.
    destruct (classic (P 0)) as [P0 | notP0].
    left; exists 0; constructor; [intuition | intros; omega].
    right; intros y le; assert (yEq0: y = 0) by omega; rewrite yEq0 in *; intuition.
    destruct IHx as [ex | notEx].
    left; assumption.
    destruct (classic (P (S x))) as [PSx | notPSx].
    left; exists (S x); constructor; [assumption | intros y lt; assert (y <= x) by omega; firstorder].
    right; intros; assert (opts: y <= x \/ y = S x) by omega. destruct opts; [firstorder | congruence].
  Qed.

  Theorem minExists (ex: exists x, P x) : (exists x, P x /\ forall y, y < x -> ~ P y).
  Proof.
    destruct ex as [x Px].
    pose proof (leastOrNone x) as exOrNot.
    destruct exOrNot.
    assumption.
    assert (eq: x <= x) by omega.
    firstorder.
  Qed.

  Theorem minExistsPower {x} (Px: P x): (exists y, y <= x /\ P y /\ forall z, z < y -> ~ P z).
  Proof.
    assert (ex: exists x, P x) by firstorder.
    pose proof (minExists ex) as exMin.
    clear ex.
    destruct exMin as [t rest].
    destruct rest as [Pt notBelow].
    exists t.
    intuition.
    destruct (classic (t <= x)).
    assumption.
    assert (x < t) by omega.
    firstorder.
  Qed.
End minExists.

Section maxExists.
  Context {P: nat -> Prop}.
  Theorem maxExists {max} (exPx: exists x, x <= max /\ P x): exists x, x <= max /\ P x /\ forall y, S x <= y <= max -> ~ P y.
  Proof.
    destruct exPx as [x rest].
    destruct rest as [xLeMax Px].
    pose (fun x => P (max - x)) as Q.
    pose (max - x) as diff.
    assert (xEq: max - (max - x) = x) by omega.
    assert (Qdiff: Q diff) by (unfold Q; unfold diff; rewrite xEq in *; intuition).
    assert (exQdiff: exists d, Q d) by (exists diff; intuition).
    pose proof (minExists exQdiff) as qMin.
    destruct qMin as [y rest].
    destruct rest as [leDiff noLower].
    exists (max - y).
    constructor.
    omega.
    constructor.
    auto.
    intros y0 complx.
    assert (lt: max - y0 < y) by omega.
    unfold Q in noLower.
    specialize (noLower (max - y0) lt).
    assert (eq: max - (max - y0) = y0) by (assert (e: y0 <= max) by omega; generalize e; clear; intuition).
    rewrite eq in noLower.
    intuition.
  Qed.

  Theorem maxExists' {maxi} (exPx: exists x, x < maxi /\ P x): exists x, x < maxi /\ P x /\ forall y, x < y < maxi -> ~ P y.
  Proof.
    destruct exPx as [x [contra Px]].
    destruct maxi.
    omega.
    assert (exPx': exists x, x <= maxi /\ P x) by (exists x; constructor; [omega | intuition]).
    pose proof (maxExists exPx') as this.
    destruct this as [x' [cond1 [Px' forally]]].
    exists x'.
    constructor.
    omega.
    constructor.
    intuition.
    intros y cond.
    assert (S x' <= y <= maxi) by omega.
    firstorder.
  Qed.

  Theorem maxExistsPower {max x} (xLeMax: x <= max) (Px: P x) : (exists y, x <= y <= max /\ P y /\ forall z, S y <= z <= max -> ~ P z).
  Proof.
    assert (exX: exists x, x <= max /\ P x) by firstorder.
    pose proof (maxExists exX) as maxExX.
    destruct maxExX as [t rest].
    destruct rest as [tLeMax rest].
    destruct rest as [Pt noLower].
    exists t.
    destruct (classic (x <= t)) as [xLeT | xGtT].
    firstorder.
    assert (hyp: S t <= x <= max) by omega.
    firstorder.
  Qed.
End maxExists.

Section Induction.
  Context {P: nat -> Type}.
  Hypothesis case_0: P 0.
  Hypothesis case_n: forall {t}, (forall ti, ti <= t -> P ti) -> P (S t).

  Theorem ind t: P t.
  Proof.
    assert (q0: forall ti, ti <= 0 -> P ti) by
        (intros ti ti_le_0; assert (rew: ti = 0) by omega; rewrite rew; assumption).
    assert (qIHt: forall t, (forall ti, ti <= t -> P ti) -> (forall ti, ti <= S t -> P ti)).
    intros t0 lt_t0.
    specialize (case_n t0 lt_t0).
    intros ti ti_le_S_t0.
    pose proof (le_lt_eq_dec ti (S t0) ti_le_S_t0) as options.
    destruct options as  [hyp|new].
    firstorder.
    rewrite new.
    assumption.
    assert (Hyp: forall t, (forall ti, ti <= t -> P ti)) by (
                                                            induction t0; firstorder).
    specialize (Hyp t t).
    assert (fct: t <= t) by omega.
    firstorder.
  Qed.
End Induction.

    Theorem listNeq: forall {A} (x: A) l, x :: l <> l.
      unfold not; intros A x l eq.
      assert (H: length (x :: l) = length l) by (f_equal; assumption).
      unfold length in *.
      remember ((fix length (l : list A) : nat :=
            match l with
            | nil => 0
            | _ :: l' => S (length l')
            end) l) as y.
      generalize H; clear.
      intros neq.

      assert (H: S y <> y) by auto.
      firstorder.
    Qed.

    Theorem listCond1: forall {A} (l: list A), l <> nil -> length l = S (length (tl l)).
    Proof.
      intros A l lgd.
      unfold tl.
      destruct l.
      firstorder.
      unfold length.
      reflexivity.
    Qed.

    Theorem listCond2: forall {A} (l: list A), l <> nil -> length l = S (length (removelast l)).
    Proof.
      intros A l lgd.
      induction l.
      firstorder.
      destruct l.
      unfold length.
      reflexivity.
      unfold length in *.
      f_equal.
      assert (H: removelast (a :: a0 :: l) = a :: removelast (a0 :: l)) by
          (
            unfold removelast;
            reflexivity).
      rewrite H; clear H.
      assert (H: a0 :: l <> nil) by discriminate.
      specialize (IHl H).
      assumption.
    Qed.

    Theorem notInRemove: forall {A} (a: A) l, In a (removelast l) -> In a l.
    Proof.
      intros A a l inl.
      induction l.
      unfold removelast in *; simpl in *.
      assumption.
      unfold removelast in inl.
      destruct l.
      unfold In in *.
      firstorder.
      unfold In in inl.
      destruct inl.
      unfold In.
      left.
      assumption.
      specialize (IHl H).
      unfold In.
      right.
      assumption.
    Qed.

    Theorem notInTail: forall {A} (a: A) l, In a (tl l) -> In a l.
    Proof.
      intros A a l inl.
      destruct l.
      unfold tl in inl; assumption.
      unfold tl in inl.
      unfold In.
      right.
      assumption.
    Qed.

    Theorem eachProd: forall {A B} {a b: A} {c d: B}, (a, c) = (b, d) -> a = b /\ c = d.
    Proof.
      intros A B a b c d eq.
      injection eq.
      auto.
    Qed.

    Theorem combNil: forall {A} B (l : list A), combine l (@nil B) = nil.
    Proof.
      intros A B l.
      destruct l; unfold combine; reflexivity.
    Qed.

    Theorem removeCombine: forall {A B} (l1: list A) (l2: list B),
                             removelast (combine l1 l2) = combine (removelast l1)
                                                                  (removelast l2).
    Proof.
      intros A B l1.
      induction l1.
      intros l2.
      reflexivity.
      intros l2.
      destruct l2.
      simpl.
      pose proof (combNil B match l1 with
           | nil => nil
           | _ :: _ => a :: removelast l1
           end) as sth.
      rewrite sth.
      reflexivity.
      unfold combine.
      fold (combine l1 l2).
      fold (combine (removelast (a::l1)) (removelast (b::l2))).
      unfold removelast.
      fold (removelast (a :: l1)).
      fold (removelast (b :: l2)).
      fold (removelast (combine l1 l2)).
      destruct l1.
      reflexivity.
      destruct l2.
      reflexivity.
      assert (H: combine (a0::l1) (b0::l2) <> nil).
      unfold not; intros.
      unfold combine in H.
      discriminate.
      remember (combine (a0::l1) (b0::l2)) as  comb.
      destruct comb.
      firstorder.
      rewrite Heqcomb.
      clear Heqcomb p comb H.
      specialize (IHl1 (b0::l2)).
      rewrite IHl1.
      reflexivity.
    Qed.

    Theorem lenEqLastCombine: forall {A B} (a: A) (la: list A) (da: A), la <> nil ->
                                     a = last la da ->
                                     forall (b: B) (lb: list B) (db: B),
                                       length la = length lb -> b = last lb db ->
                                       In (a, b) (combine la lb).
    Proof.
      intros A B a la da lanil lasta.
      induction la.
      firstorder.
      intros b lb db lenEq lastb.
      destruct lb.
      unfold length in lenEq.
      discriminate.
      unfold length in lenEq.
      injection lenEq.
      clear lenEq; intros lenEq.
      destruct la.
      destruct lb.
      unfold last in lasta.
      unfold last in lastb.
      rewrite lasta; rewrite lastb.
      unfold In; unfold combine; simpl.
      left; reflexivity.
      discriminate.
      destruct lb.
      discriminate.
      assert (H: a1 :: la <> nil) by discriminate.
      specialize (IHla H lasta b (b1 :: lb) db lenEq lastb).
      unfold combine; unfold In.
      right.
      apply IHla.
    Qed.

    Theorem eqLen: forall {A B} (la: list A) (lb: list B), length la = length lb ->
                                                           length (removelast la) =
                                                           length (removelast lb).
    Proof.
      intros A B la.
      induction la.
      intros lb cond.
      destruct lb.
      reflexivity.
      unfold length in cond.
      discriminate.
      intros lb cond.
      destruct la.
      destruct lb.
      unfold removelast.
      reflexivity.
      unfold length in cond.
      assert (sim: 1 = S (length lb)) by (apply cond).
      injection sim.
      clear sim cond; intros sim.
      destruct lb.
      reflexivity.
      unfold length in sim.
      discriminate.
      destruct lb.
      simpl in cond.
      discriminate.
      injection cond as cond2.
      specialize (IHla lb cond2).
      destruct lb.
      unfold length in cond2.
      discriminate.
      unfold removelast.
      unfold length.
      f_equal.
      assumption.
    Qed.

    Theorem listShift: forall {A l n} (a dmy: A),
                         nth n l dmy = nth (S n) (a :: l) dmy.
    Proof.
      intros A l n a dmy.
      unfold nth.
      reflexivity.
    Qed.

    Theorem inComb: forall {A B a b} {la: list A} {lb: list B}, In (a, b) (combine la lb)
                                                                -> In b lb.
    Proof.
      intros A B a b la.
      induction la.
      intros lb inComb.
      simpl in inComb.
      firstorder.
      intros lb inComb.
      destruct lb.
      pose proof (combNil B (a0::la)) as stf.
      rewrite stf in inComb.
      simpl in inComb.
      firstorder.
      simpl in inComb.
      simpl.
      destruct inComb.
      left.
      injection H; firstorder.
      right.
      specialize (IHla lb H).
      firstorder.
    Qed.

    Theorem listEq: forall {A} {l: list A} dmy {n},
                      n < length (removelast l) -> nth n (removelast l) dmy =
                                                   nth n l dmy.
    Proof.
      intros A l dmy.
      induction l.
      intros n n_lt.
      simpl in n_lt.
      assert False by omega; firstorder.
      intros n n_lt.
      destruct l.
      simpl in n_lt.
      assert False by omega; firstorder.
      destruct n.
      reflexivity.
      assert (H: n < length (removelast (a0 :: l))).
      unfold removelast in n_lt.
      unfold length in n_lt.
      fold (removelast (a0 :: l)) in n_lt.
      fold (length (removelast (a0 :: l))) in n_lt.
      omega.
      unfold removelast.
      fold (removelast (a0 :: l)).
      unfold nth.
      fold (nth n (removelast (a0 :: l)) dmy).
      fold (nth n (a0 :: l) dmy).
      firstorder.
    Qed.

    Theorem listNoShift: forall {l},
                           (forall n, n < length l -> forall i, i < n -> nth n l 0 <
                                                                         nth i l 0) ->
                           forall {n}, n < length (removelast l) ->
                                       forall {i}, i < n -> nth n (removelast l) 0 <
                                                            nth i (removelast l) 0.
    Proof.
      intros l cond n n_lt i i_lt.
      pose proof (listEq 0 n_lt) as n1.
      assert (i_lt': i < length (removelast l)) by omega.
      pose proof (listEq 0 i_lt') as i1.
      rewrite n1; rewrite i1.
      destruct l.
      simpl in n_lt.
      assert False by omega; firstorder.
      assert (n0 :: l <> nil) by discriminate.
      pose proof (listCond2 (n0::l) H).
      assert (n < length (n0 :: l)) by omega.
      specialize (cond n H1 i i_lt).
      assumption.
    Qed.

    Theorem lastCombine: forall {A B} {la: list A} da {lb: list B} db,
                           length la = length lb -> last la da = fst (last (combine la lb) (da, db)).
    Proof.
      intros A B la da.
      induction la.
      intros lb db eqLen.
      reflexivity.
      intros lb db eqLen.
      destruct lb.
      unfold length in eqLen.
      discriminate.
      simpl.
      destruct la.
      reflexivity.
      destruct lb.
      simpl in *.
      assert False by omega; firstorder.
      simpl.
      unfold length in eqLen.
      fold (length (a0 :: la)) in eqLen.
      fold (length (b0 :: lb)) in eqLen.
      assert (H: length (a0 :: la) = length (b0 :: lb)) by auto.
      specialize (IHla (b0 :: lb) db H).
      assumption.
    Qed.

    Theorem lastIn: forall {A} {la: list A} da, la <> nil -> In (last la da) la.
    Proof.
      intros A la da notNil.
      induction la.
      firstorder.
      destruct la.
      unfold last.
      simpl.
      left.
      reflexivity.
      unfold In.
      fold (In (last (a :: a0 :: la) da) (a0 :: la)).
      right.
      assert (a0 :: la <> nil) by discriminate.
      specialize (IHla H).
      assumption.
    Qed.

    Theorem last_nth: forall {A} (la: list A) da, nth (length la - 1) la da =
                                                  last la da.
    Proof.
      intros A la da.
      induction la.
      reflexivity.
      simpl.
      destruct la.
      reflexivity.
      unfold length.
      fold (length la).
      remember (S (length la) - 0) as contra.
      destruct contra.
      omega.
      assert (S (length la) - 0 = length (a0 :: la)) by (unfold length; omega).
      assert (length (a0 :: la) - 1 = contra) by omega.
      rewrite <- H0.
      assumption.
    Qed.

    Theorem in_nth: forall {A} {la: list A} {a} da, In a la -> exists i, i < length la /\
                                                                         nth i la da = a.
    Proof.
      intros A la a da ina.
      induction la.
      unfold In in ina.
      firstorder.
      unfold In in ina.
      destruct ina.
      exists 0.
      constructor.
      unfold length.
      omega.
      unfold nth.
      assumption.
      specialize (IHla H).
      destruct IHla as [i [i_lt nth_a]].
      exists (S i).
      constructor.
      simpl.
      omega.
      simpl.
      assumption.
    Qed.

    Theorem lastInRemove: forall {A} {la: list A} {da}, In (last la da) (removelast la) ->
                                                        exists i, i < length la - 1 /\
                                                                  nth i la da = last la da.
    Proof.
      intros A la da isIn.
      induction la.
      simpl in isIn.
      firstorder.
      destruct la.
      simpl in isIn.
      firstorder.
      simpl in isIn.
      destruct isIn.
      destruct la.
      exists 0.
      constructor.
      simpl.
      omega.
      simpl.
      assumption.
      exists 0.
      constructor.
      simpl.
      omega.
      simpl.
      assumption.
      specialize (IHla H).
      destruct IHla as [i [c1 c2]].
      exists (S i).
      constructor.
      simpl in c1.
      simpl.
      omega.
      simpl.
      assumption.
    Qed.

    Theorem eqComb: forall {A B} {la: list A} da {lb: list B} db i,
                      length la = length lb -> nth i (combine la lb) (da, db) =
                                               (nth i la da, nth i lb db).
    Proof.
      intros A B la da.
      induction la.
      intros lb db i eq_len.
      destruct lb.
      simpl.
      destruct i; reflexivity.
      unfold length in eq_len; discriminate.
      intros lb db i eq_len.
      destruct lb.
      unfold length in eq_len; discriminate.
      unfold length in eq_len.
      injection eq_len as gd1; clear eq_len; fold (length la) in gd1. fold (length lb) in gd1.
      unfold combine.
      fold (combine la lb).
      destruct i.
      reflexivity.
      unfold nth.
      fold (nth i (combine la lb) (da, db)).
      fold (nth i la da).
      fold (nth i lb db).
      apply (IHla lb db i gd1).
    Qed.

    Theorem combLength: forall {A B} {la: list A} {lb: list B},
                          length la = length lb -> length la = length (combine la lb).
    Proof.
      intros A B la.
      induction la.
      intros lb.
      intros len.
      reflexivity.
      destruct lb.
      intros len.
      simpl in len.
      discriminate.
      intros len.
      simpl in len.
      injection len as len'.
      simpl.
      specialize (IHla lb len').
      f_equal; assumption.
    Qed.

Theorem lastCombineDist: forall {A B} (la : list A) da (lb : list B) db,
                           length la = length lb ->
                           last (combine la lb) (da, db) = (last la da, last lb db).
Proof.
  intros A B la da.
  induction la.
  intros lb db lenEq.
  destruct lb.
  reflexivity.
  unfold length in lenEq.
  discriminate.
  intros lb db lenEq.
  destruct lb.
  unfold length in lenEq; discriminate.
  simpl in lenEq.
  injection lenEq as l'.
  clear lenEq.
  specialize (IHla lb db l').
  simpl.
  destruct la.
  simpl.
  destruct lb.
  reflexivity.
  unfold length in l'; discriminate.
  destruct lb.
  unfold length in l'; discriminate.
  simpl.
  assumption.
Qed.

Theorem inNotInRemove: forall {A} {a} {la: list A} da , In a la -> ~ In a (removelast la) ->
                                                        last la da = a.
Proof.
  intros A a la da isIn notIn.
  induction la.
  simpl in isIn.
  intuition.
  destruct la.
  simpl in *.
  destruct isIn; intuition.
  simpl in *.
  destruct isIn.
  firstorder.
  specialize (IHla H).
  assert (notIn': ~ In a match la with
                         | nil => nil
                         | _ :: _ => a1 :: removelast la
                       end) by firstorder.
  apply (IHla notIn').
Qed.


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Auxiliary lemmas for lists.
*)

Require Import List.
Import ListNotations.
Require Import Psatz.
Require Import ssreflect ssrbool ssrfun.

Section Facts.

(* induction principle wrt. a decreasing measure f *)
(* example: elim /(measure_ind length) : l. *)
Lemma measure_ind {X : Type} (f : X -> nat) (P : X -> Prop) :
  (forall x, (forall y, f y < f x -> P y) -> P x) -> forall (x : X), P x.
Proof.
  apply : well_founded_ind.
  apply : Wf_nat.well_founded_lt_compat. move => *. by eassumption.
Qed.
Arguments measure_ind {X}.

End Facts.

Section ForallNorm.

Variable T : Type.
Variable P : T -> Prop.

Lemma Forall_nilP : Forall P [] <-> True.
Proof. by constructor. Qed.

Lemma Forall_consP {a A} : Forall P (a :: A) <-> P a /\ Forall P A.
Proof.
  constructor.
    move=> H. by inversion H.
  move=> [? ?]. by constructor.
Qed.

Lemma Forall_singletonP {a} : Forall P [a] <-> P a.
Proof. rewrite Forall_consP Forall_nilP. by tauto. Qed.

Lemma Forall_appP {A B}: Forall P (A ++ B) <-> Forall P A /\ Forall P B.
Proof.
  elim: A.
    constructor; by [|case].
  move=> ? ? IH /=. rewrite ? Forall_consP ? IH.
  by tauto.
Qed.

(* usage rewrite ? Forall_norm *)
Definition Forall_norm := (@Forall_appP, @Forall_singletonP, @Forall_consP, @Forall_nilP).

End ForallNorm.

Section ListFacts.

(* any list is empty or has a last element *)
Lemma nil_or_ex_last {T: Type} (A: list T) : A = [] \/ exists B a, A = B ++ [a].
Proof.
  elim: A.
    by left.
  move=> a A. case.
    move=> ->. right. by exists [], a.
  move=> [B [b ->]]. right. by exists (a :: B), b.
Qed.

(* induction wrt the last element of a list *)
Lemma list_last_ind (X: Type) (P : list X -> Prop) :
  P [] ->
  (forall a A, P A -> P (A ++ [a])) ->
  forall (A : list X), P A.
Proof.
  move=> H1 H2. elim /(measure_ind (@length X)).
  move=> A IH. case: (nil_or_ex_last A).
    by move=> ->.
  move=> [B [a ?]]. subst A. apply: H2. apply: IH.
  rewrite app_length /length. by lia.
Qed.

Arguments list_last_ind [X].

Lemma incl_consP {X: Type} {a: X} {A B} : incl (a :: A) B <-> (In a B /\ incl A B).
Proof.
  by rewrite /incl - ? Forall_forall ?Forall_norm.
Qed.

End ListFacts.