Require Export List Setoid Morphisms SetoidList Sorted.
Require Export Orders OrdersFacts.
Require Export Bool Arith Lia.
Import ListNotations.

Lemma app_nil {A} (l l' : list A) : l ++ l' = [] <-> l = [] /\ l' = [].
Proof.
Admitted.

(** Cartesian product *)

Definition product {A B} (l : list A) (l' : list B) : list (A * B) :=
 List.flat_map (fun e => map (pair e) l') l.

Lemma product_ok {A B} (l : list A) (l' : list B) x y :
  List.In (x, y) (product l l') <-> List.In x l /\ List.In y l'.
Proof.
Admitted.

Lemma product_length {A B} (l:list A)(l':list B) :
  length (product l l') = length l * length l'.
Proof.
Admitted.

(** Equivalence of lists *)

Definition eqlist {A} (l l' : list A) := forall n,
  List.In n l <-> List.In n l'.

(** For rewriting with eqlist : *)
Global Instance : forall A, Equivalence (@eqlist A).
Proof. firstorder. Qed.
Global Instance : forall {A}, Proper (eq ==> eqlist ==> eqlist) (@cons A).
Proof. intros A a a' <-. firstorder. Qed.
Global Instance : forall {A}, Proper (eqlist ==> eqlist ==> eqlist) (@app A).
Proof.
 intros A l1 l1' H1 l2 l2' H2 x.
 rewrite !in_app_iff. now rewrite (H1 x), (H2 x).
Qed.
Global Instance : forall {A B}, Proper (eq ==> eqlist ==> eqlist) (@map A B).
Proof.
 intros A B f f' <- l l' H x. rewrite !in_map_iff.
 split; intros (y & E & IN); exists y; split; auto; now apply H.
Qed.

Lemma eqlist_nil {A} (l : list A) : eqlist l [] -> l = [].
Proof.
Admitted.

Lemma eqlist_comm {A} (l l' : list A) : eqlist l l' -> eqlist l' l.
Proof.
Admitted.

Lemma eqlist_undup {A} (a:A) l l' :
 eqlist (a::l) l' -> In a l -> eqlist l l'.
Proof.
Admitted.

Lemma eqlist_uncons {A} (a:A) l l' :
 eqlist (a::l) (a::l') -> ~In a l -> ~In a l' -> eqlist l l'.
Proof.
Admitted.

(** [Incl] : inclusion of lists.

    For this predicate, the positions are important : a list is included
    in another if we can obtain the second one by putting some more
    elements in the first one. *)

Inductive Incl {A} : list A -> list A -> Prop :=
| InclNil : Incl [] []
| InclSkip x l l' : Incl l l' -> Incl l (x::l')
| InclSame x l l' : Incl l l' -> Incl (x::l) (x::l').
Global Hint Constructors Incl : core.

Lemma Incl_nil {A} (l:list A) : Incl [] l.
Proof.
Admitted.
Global Hint Resolve Incl_nil : core.

Lemma Incl_len {A} (l l' : list A) : Incl l l' -> length l <= length l'.
Proof.
Admitted.

Global Instance Incl_PreOrder {A} : PreOrder (@Incl A).
Proof.
 split.
 - red. intro l. induction l; auto.
 - red. intros l1 l2 l3 H12 H23. revert l1 H12.
   induction H23; intros; auto. inversion H12; subst; auto.
Qed.

Global Instance Incl_Order {A} : PartialOrder eq (@Incl A).
Proof.
 intros l l'; split.
 - now intros <-.
 - intros (H,H'). red in H'.
   induction H.
   + inversion H'; subst; auto.
   + apply Incl_len in H; apply Incl_len in H'. simpl in *. lia.
   + f_equal. inversion H'; subst; auto.
     apply Incl_len in H; apply Incl_len in H2. simpl in *. lia.
Qed.

Lemma Incl_Forall {A}(P:A->Prop) l l' :
  Incl l l' -> Forall P l' -> Forall P l.
Proof.
 induction 1; auto; inversion 1; subst; auto.
Qed.

Lemma Incl_singleton {A} (a:A) l : In a l -> Incl [a] l.
Proof.
Admitted.

(** [sublists] generates all lists included in a first one *)

Fixpoint sublists {A} (l : list A) :=
  match l with
  | [] => [[]]
  | a :: l' =>
    let s := sublists l' in
    s ++ List.map (cons a) s
  end.

Lemma sublists_spec {A} (l l' :list A) :
 In l' (sublists l) <-> Incl l' l.
Proof.
Admitted.

Lemma sublists_length {A} (l:list A) :
 length (sublists l) = 2^length l.
Proof.
Admitted.

(** [Subset] : another inclusion predicate, but this time we ignore
   the positions and the repetitions. It is enough for all elements
   of the left list to appear at least somewhere in the right list. *)

Definition Subset {A} (l l' : list A) :=
  forall n, List.In n l -> List.In n l'.

Lemma subset_notin {A} (l l' : list A) a :
 Subset l (a::l') -> ~In a l -> Subset l l'.
Proof.
Admitted.

Lemma subset_nil {A} (l : list A) : Subset l [] -> l = [].
Proof.
Admitted.

Lemma incl_subset {A} (l l':list A) : Incl l l' -> Subset l l'.
Proof.
Admitted.

(** A tricky lemma : a subset without duplicates has a smaller length.
    See Coq standard library for [NoDup]. This proof might be done
    via [List.in_split]. *)

Lemma subset_nodup_length {A} (l l' : list A) :
 Subset l l' -> NoDup l -> length l <= length l'.
Proof.
Admitted.

(** More on [Incl] and [Subset] in RegOrder.v, where we will be able to
    test whether two list elements are equal or not. *)

Lemma existsb_forall {A} (f:A -> bool) l :
 existsb f l = false <-> forall x, In x l -> f x = false.
Proof.
Admitted.

(** Being in a list, modulo an equivalence [R] *)

Section SomeEquivalence.
Context {A}(R:A->A->Prop){HR:Equivalence R}.

Definition InModulo a l := exists a', R a a' /\ In a' l.

Global Instance : Proper (R ==> eqlist ==> iff) InModulo.
Proof.
 intros x x' Hx l l' Hl. unfold InModulo; split;
 intros (a' & IN & E); exists a'; split; eauto; firstorder.
Qed.

(** Equivalence with another such definition (from Coq stdlib) *)

Lemma InModulo_InA a l : InModulo a l <-> InA R a l.
Proof.
 symmetry. apply InA_alt.
Qed.

(** Similar to [subset_nodup_length], but here elements are taken up
    to the equivalence R. See Coq stdlib for [NoDupA]. *)

Lemma subset_nodupA_length l l' :
 (forall x, In x l -> InModulo x l') -> NoDupA R l ->
 length l <= length l'.
Proof using HR.
Admitted.

(** Removing redundancy with respect to some decidable equivalence.
    Quadratic complexity. *)

Variable (f:A->A->bool).
Variable (Hf:forall a b, f a b = true <-> R a b).

Fixpoint removedup l :=
  match l with
  | [] => []
  | x::l =>
    let l' := removedup l in
    if existsb (f x) l' then l' else x::l'
  end.

Lemma removedup_nodup l : NoDupA R (removedup l).
Proof using Hf.
Admitted.

Lemma removedup_incl l : Incl (removedup l) l.
Proof using f.
Admitted.

Lemma removedup_in l x : In x l -> InModulo x (removedup l).
Proof using Hf HR.
Admitted.

End SomeEquivalence.


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

Require Import BinPos BinNat.

Local Open Scope N_scope.

Definition NPgeb (a:N)(b:positive) :=
  match a with
   | 0 => false
   | Npos na => match Pcompare na b Eq with Lt => false | _ => true end
  end.

Local Notation "a >=? b" := (NPgeb a b) (at level 70).

Fixpoint Pdiv_eucl (a b:positive) : N * N :=
  match a with
    | xH =>
       match b with xH => (1, 0) | _ => (0, 1) end
    | xO a' =>
       let (q, r) := Pdiv_eucl a' b in
       let r' := 2 * r in
        if r' >=? b then (2 * q + 1, r' - Npos b)
        else (2 * q, r')
    | xI a' =>
       let (q, r) := Pdiv_eucl a' b in
       let r' := 2 * r + 1 in
        if r' >=? b then (2 * q + 1, r' - Npos b)
        else  (2 * q, r')
  end.

Definition Ndiv_eucl (a b:N) : N * N :=
  match a, b with
   | 0,  _ => (0, 0)
   | _, 0  => (0, a)
   | Npos na, Npos nb => Pdiv_eucl na nb
  end.

Definition Ndiv a b := fst (Ndiv_eucl a b).
Definition Nmod a b := snd (Ndiv_eucl a b).

Infix "/" := Ndiv : N_scope.
Infix "mod" := Nmod (at level 40, no associativity) : N_scope.

(** Auxiliary Results about [NPgeb] *)

Lemma NPgeb_ge : forall a b, NPgeb a b = true -> a >= Npos b.
Proof.
 destruct a; simpl; intros.
 discriminate.
 unfold Nge, Ncompare. now destruct Pcompare.
Qed.

Lemma NPgeb_lt : forall a b, NPgeb a b = false -> a < Npos b.
Proof.
 destruct a; simpl; intros. red; auto.
 unfold Nlt, Ncompare. now destruct Pcompare.
Qed.

Theorem NPgeb_correct: forall (a:N)(b:positive),
  if NPgeb a b then a = a - Npos b + Npos b else True.
Proof.
  destruct a as [|a]; simpl; intros b; auto.
  generalize (Pcompare_Eq_eq a b).
  case_eq (Pcompare a b Eq); intros; auto.
  rewrite H0; auto.
  now rewrite Pminus_mask_diag.
  destruct (Pminus_mask_Gt a b H) as [d [H2 [H3 _]]].
  rewrite H2. rewrite <- H3.
  simpl; f_equal; apply Pplus_comm.
Qed.

Lemma NPgeb_ineq0 : forall a p, a < Npos p -> NPgeb (2*a) p = true ->
 2*a - Npos p < Npos p.
Proof.
intros a p LT GE.
apply Nplus_lt_cancel_l with (Npos p).
rewrite Nplus_comm.
generalize (NPgeb_correct (2*a) p). rewrite GE. intros <-.
rewrite <- (Nmult_1_l (Npos p)). rewrite <- Nmult_plus_distr_r.
destruct a; auto.
Qed.

Lemma NPgeb_ineq1 : forall a p, a < Npos p -> NPgeb (2*a+1) p = true ->
  (2*a+1) - Npos p < Npos p.
Proof.
intros a p LT GE.
apply Nplus_lt_cancel_l with (Npos p).
rewrite Nplus_comm.
generalize (NPgeb_correct (2*a+1) p). rewrite GE. intros <-.
rewrite <- (Nmult_1_l (Npos p)). rewrite <- Nmult_plus_distr_r.
destruct a; auto.
red; simpl. apply Pcompare_eq_Lt; auto.
Qed.

(* Proofs of specifications for these euclidean divisions. *)

Theorem Pdiv_eucl_correct: forall a b,
  let (q,r) := Pdiv_eucl a b in Npos a = q * Npos b + r.
Proof.
  induction a; cbv beta iota delta [Pdiv_eucl]; fold Pdiv_eucl; cbv zeta.
  intros b; generalize (IHa b); case Pdiv_eucl.
    intros q1 r1 Hq1.
    assert (Npos a~1 = 2*q1*Npos b + (2*r1+1))
     by now rewrite Nplus_assoc, <- Nmult_assoc, <- Nmult_plus_distr_l, <- Hq1.
    generalize (NPgeb_correct (2 * r1 + 1) b); case NPgeb; intros H'; auto.
    rewrite Nmult_plus_distr_r, Nmult_1_l.
    rewrite <- Nplus_assoc, (Nplus_comm (Npos b)), <- H'; auto.
  intros b; generalize (IHa b); case Pdiv_eucl.
    intros q1 r1 Hq1.
    assert (Npos a~0 = 2*q1*Npos b + 2*r1)
     by now rewrite <- Nmult_assoc, <- Nmult_plus_distr_l, <- Hq1.
    generalize (NPgeb_correct (2 * r1) b); case NPgeb; intros H'; auto.
    rewrite Nmult_plus_distr_r, Nmult_1_l.
    rewrite <- Nplus_assoc, (Nplus_comm (Npos b)), <- H'; auto.
  destruct b; auto.
Qed.

Theorem Ndiv_eucl_correct: forall a b,
  let (q,r) := Ndiv_eucl a b in a = b * q + r.
Proof.
  destruct a as [|a]; destruct b as [|b]; simpl; auto.
  generalize (Pdiv_eucl_correct a b); case Pdiv_eucl; intros q r.
  destruct q. simpl; auto. rewrite Nmult_comm. intro EQ; exact EQ.
Qed.

Theorem Ndiv_mod_eq : forall a b,
  a = b * (a/b) + (a mod b).
Proof.
  intros; generalize (Ndiv_eucl_correct a b).
  unfold Ndiv, Nmod; destruct Ndiv_eucl; simpl; auto.
Qed.

Theorem Pdiv_eucl_remainder : forall a b:positive,
  snd (Pdiv_eucl a b) < Npos b.
Proof.
  induction a; cbv beta iota delta [Pdiv_eucl]; fold Pdiv_eucl; cbv zeta.
  intros b; generalize (IHa b); case Pdiv_eucl.
    intros q1 r1 Hr1; simpl in Hr1.
    case_eq (NPgeb (2*r1+1) b); intros; unfold snd.
    apply NPgeb_ineq1; auto.
    apply NPgeb_lt; auto.
  intros b; generalize (IHa b); case Pdiv_eucl.
    intros q1 r1 Hr1; simpl in Hr1.
    case_eq (NPgeb (2*r1) b); intros; unfold snd.
    apply NPgeb_ineq0; auto.
    apply NPgeb_lt; auto.
  destruct b; simpl; reflexivity.
Qed.

Theorem Nmod_lt : forall (a b:N), b<>0 -> a mod b < b.
Proof.
  destruct b as [ |b]; intro H; try solve [elim H;auto].
  destruct a as [ |a]; try solve [compute;auto]; unfold Nmod, Ndiv_eucl.
  generalize (Pdiv_eucl_remainder a b); destruct Pdiv_eucl; simpl; auto.
Qed.


(* (c) Copyright Microsoft Corporation and Inria. You may distribute   *)
(* under the terms of either the CeCILL-B License or the CeCILL        *)
(* version 2 License, as specified in the README file.                 *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq bigops fintype.
Require Import div prime choice.

(****************************************************************************)
(* This files contains the definition  of:                                  *)
(*   bin m n        ==  binomial coeficients, i.e. m choose n               *)
(*                                                                          *)
(* In additions to the properties of this function, wilson and pascal are   *)
(* two examples of how to manipulate expressions with bigops.               *)
(****************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** Factorial lemma **)
Lemma fact0 : fact 0 = 1.
Proof. by done. Qed.

Lemma factS : forall n, fact n.+1  = n.+1 * fact n.
Proof. by done. Qed.

Lemma fact_prod n : fact n = \prod_(1 <= i < n.+1) i.
Proof.
elim=> [|n Hrec] //; first by rewrite big_nil.
by apply sym_equal; rewrite factS Hrec // !big_add1 big_nat_recr /= mulnC.
Qed.

Theorem wilson : forall p, p > 1 -> prime p = (p %| (fact p.-1).+1).
Proof.
have dFact: forall p, 0 < p -> fact p.-1 = \prod_(0 <= i < p | i != 0) i.
  move=> p Hp; rewrite -big_filter fact_prod; symmetry; apply: congr_big=> //.
  rewrite /index_iota subn1 -[p]prednK //=; apply/all_filterP.
  by rewrite all_predC has_pred1 mem_iota.
move=> p lt1p; have p_gt0 := ltnW lt1p.
apply/idP/idP=> [pr_p | dv_pF]; last first.
  apply/primeP; split=> // d dv_dp; have: d <= p by exact: dvdn_leq.
  rewrite orbC leq_eqVlt; case/orP=> [-> // | ltdp].
  have:= dvdn_trans dv_dp dv_pF; rewrite dFact // big_mkord.
  rewrite (bigD1 (Ordinal ltdp)) /=; last by rewrite -lt0n (dvdn_gt0 p_gt0).
  by rewrite orbC -addn1 dvdn_addr ?dvdn_mulr // dvdn1 => ->.
pose Fp1 := Ordinal lt1p; pose Fp0 := Ordinal p_gt0.
have ltp1p: p.-1 < p by [rewrite prednK]; pose Fpn1 := Ordinal ltp1p.
case eqF1n1: (Fp1 == Fpn1); first by rewrite -{1}[p]prednK -1?((1 =P p.-1) _).
have toFpP: _ %% p < p by move=> m; rewrite ltn_mod.
pose toFp := Ordinal (toFpP _).
pose mFp (i j : 'I_p) := toFp (i * j).
have Fp_mod: forall i : 'I_p, i %% p = i by move=> i; exact: modn_small.
have mFpA: associative mFp.
  by move=> i j k; apply: val_inj; rewrite /= modn_mulml modn_mulmr mulnA.
have mFpC: commutative mFp by move=> i j; apply: val_inj; rewrite /= mulnC.
have mFp1: left_id Fp1 mFp by move=> i; apply: val_inj; rewrite /= mul1n.
have mFp1r: right_id Fp1 mFp by move=> i; apply: val_inj; rewrite /= muln1.
pose mFpLaw := Monoid.Law mFpA mFp1 mFp1r.
pose mFpM := Monoid.operator (@Monoid.ComLaw _ _ mFpLaw mFpC).
pose vFp (i : 'I_p) := toFp (egcdn i p).1.
have vFpV: forall i, i != Fp0 -> mFp (vFp i) i = Fp1.
  move=> i; rewrite -val_eqE /= -lt0n => i_gt0; apply: val_inj => /=.
  rewrite modn_mulml; case: egcdnP => //= _ km -> _; rewrite {km}modn_addl_mul.
  suff: coprime i p by move/eqnP->; rewrite modn_small.
  rewrite coprime_sym prime_coprime //; apply/negP; move/(dvdn_leq i_gt0).
  by rewrite leqNgt ltn_ord.
have vFp0: forall i, i != Fp0 -> vFp i != Fp0.
  move=> i; move/vFpV=> inv_i; apply/eqP=> vFp0.
  by have:= congr1 val inv_i; rewrite vFp0 /= mod0n.
have vFpK: {in predC1 Fp0, involutive vFp}.
  by move=> i n0i; rewrite /= -[vFp _]mFp1r -(vFpV _ n0i) mFpA vFpV (vFp0, mFp1).
have le_pmFp: (_ : 'I_p) <= p + _.
  by move=> *; apply: leq_trans (ltnW _) (leq_addr _ _).
have eqFp : forall i j : 'I_p, (i == j) = (p %| p + i - j).
  by move=> i j; rewrite -eqn_mod_dvd ?(modn_addl, Fp_mod).
have vFpId: forall i, (vFp i == i :> nat) = xpred2 Fp1 Fpn1 i.
  move=> i; symmetry; case: (i =P Fp0) => [->{i}|]; last move/eqP=> ni0.
    by rewrite /= -!val_eqE /= -{2}[p]prednK //= modn_small //= -(subnKC lt1p).
  rewrite 2!eqFp -euclid //= -[_ - p.-1]subSS prednK //.
  have lt0i: 0 < i by rewrite lt0n.
  rewrite -addnS addKn -addn_subA // muln_addl -{2}(addn1 i) -subn_sqr.
  rewrite addn_subA ?leq_sqr // mulnS -addnA -mulnn -muln_addl.
  rewrite -(subnK (le_pmFp (vFp i) i)) muln_addl addnCA.
  rewrite -[1 ^ 2]/(Fp1 : nat) -addn_subA // dvdn_addl.
    by rewrite euclid // -eqFp eq_sym orbC /dvdn Fp_mod eqn0Ngt lt0i.
  by rewrite -eqn_mod_dvd // Fp_mod modn_addl -(vFpV _ ni0) eqxx.
suffices [mod_fact]: toFp (fact p.-1) = Fpn1.
  by rewrite /dvdn -addn1 -modn_addml mod_fact addn1 prednK // modnn.
rewrite dFact // (@big_morph _ _ _ Fp1 _ mFpM toFp) //; first last.
- by apply: val_inj; rewrite /= modn_small.
- by move=> i j; apply: val_inj; rewrite /= modn_mul2m.
rewrite big_mkord (eq_bigr id) => [|i _]; last by apply: val_inj => /=.
pose ltv i := vFp i < i; rewrite (bigID ltv) -/mFpM [mFpM _ _]mFpC.
rewrite (bigD1 Fp1) -/mFpM; last by rewrite [ltv _]ltn_neqAle vFpId.
rewrite [mFpM _ _]mFp1 (bigD1 Fpn1) -?mFpA -/mFpM; last first.
  rewrite -lt0n -ltnS prednK // lt1p.
  by rewrite [ltv _]ltn_neqAle vFpId eqxx orbT eq_sym eqF1n1.
rewrite (reindex_onto vFp vFp) -/mFpM => [|i]; last by do 3!case/andP; auto.
rewrite (eq_bigl (xpredD1 ltv Fp0)) => [|i]; last first.
  rewrite andbC -!andbA -2!negb_or -vFpId orbC -leq_eqVlt.
  rewrite andbA -ltnNge; symmetry; case: eqP => [->|].
    by case: eqP => // ->; rewrite !andbF.
  by move/eqP=> ni0; rewrite vFpK //eqxx vFp0.
rewrite -{2}[mFp]/mFpM -[mFpM _ _]big_split -/mFpM.
by rewrite big1 ?mFp1r //= => i; case/andP; auto.
Qed.

(** Binomial *)

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

Definition bin := nosimpl bin_rec.

Lemma binE : bin = bin_rec. Proof. by []. Qed.

Lemma bin0 : forall n, bin n 0 = 1.
Proof. by elim. Qed.

Lemma binS : forall m n,  bin m.+1 n.+1 = bin m n.+1 + bin m n.
Proof. by []. Qed.

Lemma bin_small : forall m n, m < n -> bin m n = 0.
Proof. by elim=> [|m IHm] [|n] // lt_m_n; rewrite binS !IHm // ltnW. Qed.

Lemma binn : forall n, bin n n = 1.
Proof. by elim=> [|n IHn] //; rewrite binS bin_small. Qed.

Lemma bin_gt0 : forall m n, (0 < bin m n) = (n <= m).
Proof.
by elim=> [|m IHm] [|n] //; rewrite binS addn_gt0 !IHm orbC ltn_neqAle andKb.
Qed.

Lemma bin_fact : forall m n,
  n <= m -> bin m n * (fact n * fact (m - n)) = fact m.
Proof.
move=> m n Hm; rewrite -{1 3}(subnKC Hm) {Hm}.
elim: n {m}(m - n) => [m | n IHn]; first by rewrite bin0 !mul1n.
elim=> [|m IHm]; first by rewrite addn0 binn mul1n muln1.
rewrite {1}addnS binS muln_addl -2!{1}(mulnCA m.+1) {}IHm addSnnS.
by rewrite -(mulnA n.+1) mulnCA {}IHn addnC -muln_addl.
Qed.

Lemma bin_sub : forall n m, n <= m -> bin m n = bin m (m - n).
Proof.
move=> n m le_n_m.
apply/eqP; rewrite -(eqn_pmul2r (fact_gt0 (m - n))) -(eqn_pmul2r (fact_gt0 n)).
by rewrite {1}mulnAC -!mulnA -{6}(subKn le_n_m) !bin_fact ?leq_subr.
Qed.

Theorem pascal : forall a b n,
  (a + b) ^ n = \sum_(i < n.+1) (bin n i * (a ^ (n - i) * b ^ i)).
Proof.
move=> a b; elim=> [|n IHn]; first by rewrite big_ord_recl big_ord0.
rewrite big_ord_recr big_ord_recl /= expnS {}IHn muln_addl !big_distrr.
rewrite big_ord_recl big_ord_recr /= !bin0 !binn !subn0 !subnn !mul1n !muln1.
rewrite -!expnS addnA; congr (_ + _); rewrite -addnA -big_split; congr (_ + _).
apply: eq_bigr => i _ /=; rewrite 2!(mulnCA b) (mulnCA a) (mulnA a) -!expnS.
by rewrite -leq_subS ?ltn_ord // -muln_addl -binS.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool ssrint eqtype ssrnat seq choice fintype rat finfun.
From mathcomp Require Import bigop ssralg div ssrnum ssrint.
From mathcomp Require Import fingroup finset.
From mathcomp Require Import cyclic zmodp.

Inductive Perm {A : Type} : list A -> list A -> Type :=
| perm_nil: Perm nil nil
| perm_skip x l l' : Perm l l' -> Perm (x::l) (x::l')
| perm_swap x y l : Perm (y::x::l) (x::y::l)
| perm_trans l l' l'' :
    Perm l l' -> Perm l' l'' -> Perm l l''.

Lemma Perm_refl {A} (xs : list A) : Perm xs xs.
  induction xs.
  apply perm_nil.
  apply perm_skip; done.
Defined.

Hint Resolve Perm_refl.

Lemma Perm_sym {A} (xs ys : list A) : Perm xs ys -> Perm ys xs.
  elim.
  done.
  intros; apply perm_skip.
  apply X.
  intros; apply perm_swap.
  intros; eapply perm_trans.
  apply X0.
  done.
Defined.

Lemma Perm_rcons {A} (xs : list A) x : Perm (x :: xs) (rcons xs x).
  induction xs.
  simpl.
  done.
  simpl.
  eapply perm_trans.
  apply perm_swap.
  apply perm_skip.
  done.
Defined.

Lemma Perm_cats0 {A} (xs : list A) : Perm xs (xs ++ nil).
  induction xs.
  done.
  simpl; apply perm_skip.
  apply IHxs.
Defined.

Lemma Perm_middle {A} (xs ys : list A) x : Perm (x :: xs ++ ys) (xs ++ (x :: ys)).
  induction xs.
  simpl.
  done.
  simpl.
  eapply perm_trans.
  apply perm_swap.
  apply perm_skip.
  apply IHxs.
Defined.

Fixpoint rot_rcons {A} (n : nat) (xs : list A) :=
  match n, xs with
    | 0, _ => xs
    | S n, (x :: xs) => rot_rcons n (rcons xs x)
    | _, _ => xs
                end.

Lemma Perm_rot {A} n (xs : list A) : Perm xs (rot_rcons n xs).
  move: xs; induction n.
  simpl.
  done.
  simpl.
  induction xs.
  done.
  eapply perm_trans.
  apply Perm_rcons.
  apply IHn.
Defined.

Lemma Perm_cat_sym {A} (xs ys : list A) : Perm (xs ++ ys) (ys ++ xs).
  move: ys; induction xs.
  simpl.
  induction ys.
  done.
  simpl.
  apply perm_skip.
  apply IHys.
  intro; apply Perm_sym.
  move: (Perm_middle ys xs a) => h.
  apply Perm_sym in h.
  eapply perm_trans.
  apply h.
  have -> : (a :: xs) ++ ys = a :: xs ++ ys by done.
  apply perm_skip.
  apply Perm_sym; apply IHxs.
Defined.

Fixpoint Perm_size {A} {xs ys : list A} (H : Perm xs ys) {struct H} :=
  match H with
    | perm_nil => 0
    | perm_skip _ _ _ pf => S (Perm_size pf)
    | perm_swap _ _ pf => 0
    | perm_trans _ _ _ pf1 pf2 => S (Perm_size pf1 + Perm_size pf2)
                                    end.

(* split the sequence in two; the nth element will be the head of the second list *)
Fixpoint seq_split {A} (n : nat) (xs : seq A) : seq A * seq A :=
  match n, xs with
    | 0, xs => (nil, xs)
    | (S n), (x :: xs) => let p := seq_split n xs in (x :: p.1, p.2)
    | (S n), nil => (nil, nil)
                      end.

Lemma seq_splitE  {A} n (xs : seq A) : (seq_split n xs).1 ++ (seq_split n xs).2 = xs.
  move: xs; induction n.
  done.
  induction 0.
  done.
  simpl.
  rewrite -{3}(IHn xs) //=.
Defined.

Lemma Perm_cat2l {A} (l l0 l1 : list A) :
  Perm l0 l1 -> Perm (l ++ l0) (l ++ l1).
  intro; induction l.
  simpl.
  apply X.
  simpl; apply perm_skip.
  apply IHl.
Defined.

(*
Lemma perm_eq_swap {A : eqType} from to (xs : list A) : perm_eq xs (swap from to xs).
  rewrite /swap.
  remember (seq_split from xs) as p1; destruct p1.
  destruct l0.
  done.
  move: (seq_splitE from xs) => <-.
  rewrite -Heqp1 //=.
  destruct (from <= to).
  remember (seq_split (to - from) l0) as p2; destruct p2.
  move: (seq_splitE (to - from) l0) => <-.
  rewrite -Heqp2 //=.
  rewrite perm_cat2l.
  have -> : s :: l1 ++ l2 = [:: s] ++ l1 ++ l2 by done.
  rewrite perm_catCA; done.

  remember (seq_split to l) as p2; destruct p2.
  move: (seq_splitE to l) => <-.
  rewrite -Heqp2 //=.
  rewrite -catA.
  rewrite perm_cat2l.
  have -> : l2 ++ s :: l0 = l2 ++ [:: s] ++ l0 by done.
  rewrite perm_catCA; done.
Qed.
*)

Definition swap {A} (from to : nat) (xs : list A) : list A :=
  match (seq_split from xs) with
  | (tl, (x :: hd)) =>
    if from <= to then
    match (seq_split (to - from) hd) with
      | (hd0, hd1) => tl ++ hd0 ++ [:: x] ++ hd1
                         end
    else
      match (seq_split to tl) with
      | (tl0, tl1) => tl0 ++ [:: x] ++ tl1 ++ hd
      end
  | _ => xs
           end.

Lemma Perm_swap {A} from to (xs : list A) : Perm xs (swap from to xs).
  rewrite /swap.
  remember (seq_split from xs) as p1; destruct p1.
  destruct l0.
  done.
  move: (seq_splitE from xs) => <-.
  rewrite -Heqp1 //=.
  destruct (from <= to).
  remember (seq_split (to - from) l0) as p2; destruct p2.
  move: (seq_splitE (to - from) l0) => <-.
  rewrite -Heqp2 //=.
  apply Perm_cat2l.
  apply Perm_middle.

  remember (seq_split to l) as p2; destruct p2.
  move: (seq_splitE to l) => <-.
  rewrite -Heqp2 //=.
  clear.
  induction l1.
  simpl.
  apply Perm_sym.
  apply Perm_middle.
  simpl.
  apply perm_skip.
  apply IHl1.
Defined.

Lemma Perm_swap_irrel {A} from to (xs : list A) : Perm xs (swap from to xs).
  apply Perm_swap.
Qed.

Lemma Perm_map {A B} (f : A -> B) (xs ys : list A)  :
  Perm xs ys -> Perm (map f xs) (map f ys).
  elim.
  simpl.
  done.
  simpl.
  intros.
  apply perm_skip.
  apply X.
  intros; simpl.
  apply perm_swap.
  intros; simpl in *.
  eapply perm_trans.
  apply X.
  apply X0.
Defined.

Lemma Perm_mem {A : eqType} (xs ys : seq A) :
  Perm xs ys -> forall x, (x \in xs) = (x \in ys).
  intro.
  induction X.
  done.
  intro; rewrite !in_cons.
  destruct (eqVneq x0 x).
  subst.
  rewrite eq_refl //=.
  rewrite (negbTE i) //=.
  intros; simpl; rewrite !in_cons //=.
  destruct (x0 == y); destruct (x0 == x); destruct (x0 \in l); done.
  intros.
  rewrite -IHX2 //=.
Qed.

Fixpoint ofind {A} (xs : seq A) (f : A -> bool) : option nat :=
  match xs with
    | nil => None
    | x :: xs' =>
      if f x then Some 0%N else
        match ofind xs' f with
          | Some n => Some (S n)
          | None => None
        end
          end.

Fixpoint ofind_val {A} (xs : seq A) (f : A -> bool) : option A :=
  match xs with
    | nil => None
    | x :: xs' =>
      if f x then Some x else
        match ofind_val xs' f with
          | Some x => Some x
          | None => None
        end
          end.

Fixpoint prefix {A : eqType} (xs ys : seq A) : bool :=
  match xs with
    | nil => true
    | x :: xs' =>
      match ys with
      | nil => false
      | y :: ys' =>
        if x == y then prefix xs' ys' else false
      end
        end.

Lemma prefixP {A : eqType} (xs ys : seq A) : prefix xs ys -> {zs | ys = xs ++ zs}.
  move: ys.
  induction xs.
  simpl.
  intros; exists ys; done.
  induction ys.
  done.
  simpl.
  destruct (eqVneq a a0).
  subst.
  rewrite eq_refl.
  intro h; destruct (IHxs _ h).
  subst.
  exists x.
  done.
  rewrite (negbTE i).
  done.
Defined.

Lemma prefix_cat {A : eqType} (xs ys : seq A) : prefix xs (xs ++ ys).
  induction xs.
  done.
  simpl.
  rewrite eq_refl.
  done.
Defined.

Fixpoint extract_right_cat {A : eqType} (xs ys : seq A) : option (seq A) :=
  match xs, ys with
  | nil, nil => Some nil
  | (x :: xs), nil => None
  | nil, y :: ys => Some (y :: ys)
  | (x :: xs), (y :: ys) =>
    if x == y then
      extract_right_cat xs ys
    else
      None
  end.

Lemma extract_right_catP {A : eqType} (xs ys : seq A) zs :
  extract_right_cat xs ys = Some zs ->
  ys = xs ++ zs.
  move: ys; induction xs.
  induction ys.
  simpl.
  intro H; injection H; done.
  simpl.
  intro H; injection H; done.
  induction ys.
  simpl.
  done.
  simpl.
  destruct (eqVneq a a0).
  subst.
  rewrite eq_refl.
  move/IHxs.
  move => ->; done.
  rewrite (negbTE i).
  done.
Qed.

Definition extract_cons {A : eqType} (a : A) (xs : seq A) : option (seq A).
  destruct xs.
  apply None.
  apply (if a == s then Some xs else None).
Defined.

Lemma extract_consP {A : eqType} (a : A) xs ys :
  extract_cons a xs = Some ys -> xs = a :: ys.
  induction xs.
  done.
  simpl.
  destruct (eqVneq a a0).
  destruct e.
  rewrite eq_refl.
  intro h; injection h.
  move => ->.
  done.
  rewrite (negbTE i); done.
Qed.

Definition extract_right_cons_cat {A : eqType} (h : A) (xs ys : seq A) : option (seq A) :=
  match extract_cons h ys with
    | None => None
    | Some ys' =>
      extract_right_cat xs ys'
                        end.

Lemma extract_right_cons_catP {A : eqType} (h : A) xs ys zs :
  extract_right_cons_cat h xs ys = Some zs ->
  ys = h :: xs ++ zs.
  rewrite /extract_right_cons_cat.
  remember (extract_cons h ys) as o; destruct o; symmetry in Heqo.
  apply extract_consP in Heqo.
  rewrite Heqo.
  move/extract_right_catP.
  move => ->.
  done.
  done.
Qed.

Lemma orP_sumbool {b1 b2 : bool} : (b1 || b2) -> {b1} + {b2}.
  destruct b1.
  intro; apply left; apply is_true_true.
  destruct b2.
  intros; apply right; apply is_true_true.
  done.
Qed.

Lemma Perm_rem_cat_l {A : eqType} (xs ys : seq A) x : x \in ys ->
                                                            Perm (xs ++ ys) ((x :: xs) ++ (rem x ys)).
  move: x ys.
  induction xs.
  simpl.
  induction ys.
  done.
  simpl.
  destruct (eqVneq a x).
  subst.
  rewrite eq_refl.
  intros; apply Perm_refl.
  rewrite (negbTE i).
  intros.
  eapply perm_trans; last first.
  apply Perm_sym.
  apply perm_swap.
  apply perm_skip.
  apply IHys.
  rewrite in_cons in H.
  rewrite eq_sym (negbTE i) in H; done.
  intros; simpl.
  eapply perm_trans; last first.
  apply perm_swap.
  apply perm_skip.
  apply IHxs.
  done.
Qed.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Meta_theory.Parallel_postulates.tarski_s_euclid_remove_degenerated_cases.
Require Import GeoCoq.Tarski_dev.Ch12_parallel.

Section SPP_tarski.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma impossible_case_5 : forall P Q R S T U I,
  BetS P T Q ->
  BetS R T S ->
  BetS Q U R ->
  ~ Col P Q S ->
  ~ Col P R U ->
  Par P R Q S ->
  Par P S Q R ->
  Bet S Q I ->
  Bet U I P ->
  False.
Proof.
intros P Q R S T U I HPTQ HRTS HQUR HNC HNC' HPar1 HPar2 HSQI HPUI.
apply BetSEq in HPTQ; apply BetSEq in HRTS; apply BetSEq in HQUR.
assert (HTS : TS Q S P U) by (assert_diffs; spliter; assert_cols; repeat split;
                                     Col; try (exists I; Col; Between); intro; apply HNC'; ColR).
apply l9_9 in HTS; apply HTS.
apply one_side_transitivity with R.

  {
  apply l12_6; apply par_not_col_strict with P; Col; Par.
  }

  {
  assert (HQS : Q <> S) by (assert_diffs; assumption).
  assert (HQSQ : Col Q S Q) by Col.
  assert (HRUQ : Col R U Q) by (spliter; assert_cols; Col).
  rewrite (l9_19 Q S R U Q HQSQ HRUQ).
  split; spliter; try (intro; apply HNC; assert_cols; ColR); repeat split; Between.
  }
Qed.

Lemma impossible_case_6 : forall P Q R S T U I,
  BetS P T Q ->
  BetS R T S ->
  BetS Q U R ->
  ~ Col P Q S ->
  ~ Col P R U ->
  Par P R Q S ->
  Par P S Q R ->
  Bet S Q I ->
  Bet I P U ->
  False.
Proof.
intros P Q R S T U I HPTQ HRTS HQUR HNC HNC' HPar1 HPar2 HSQI HPUI.
apply BetSEq in HPTQ; apply BetSEq in HRTS; apply BetSEq in HQUR.
apply between_symmetry in HPUI.
destruct (inner_pasch S U I Q P HSQI HPUI) as [J [HBet1 HBet2]].
assert (HParS : Par_strict P S Q U).
  {
  apply par_not_col_strict with R.

    {
    spliter; assert_cols.
    apply par_col_par with R; Par.
    ColR.
    }

    {
    spliter; assert_cols; ColR.
    }

    {
    intro; apply HNC.
    spliter; assert_cols; ColR.
    }
  }
apply HParS; exists J; assert_cols; Col.
Qed.

Lemma impossible_case_7 : forall P Q R S T U I,
  BetS P T Q ->
  BetS R T S ->
  BetS Q U R ->
  ~ Col P Q S ->
  ~ Col P R U ->
  Par P R Q S ->
  Par P S Q R ->
  Col P U I ->
  Bet Q I S ->
  False.
Proof.
intros P Q R S T U I HPTQ HRTS HQUR HNC HNC' HPar1 HPar2 HPUI HSQI.
apply BetSEq in HPTQ; apply BetSEq in HRTS; apply BetSEq in HQUR.
elim (eq_dec_points I S); intro HIS; treat_equalities.

  {
  assert (HParS : Par_strict Q R P I) by (apply par_not_col_strict with P; Col; Par; unfold BetS in *;
                                          spliter; assert_cols; intro; apply HNC'; ColR).
  apply HParS; exists U; spliter; assert_cols; Col.
  }

  {
  assert (HTS : TS P U Q S) by (assert_diffs; spliter; assert_cols; repeat split;
                                       Col; try (exists I; Col; Between); intro; apply HNC; ColR).
  apply l9_9 in HTS; apply HTS.
  exists R; split.

    {
    spliter; assert_diffs; assert_cols.
    split; try (intro; apply HNC; ColR).
    split; try (intro; apply HNC; ColR).
    exists U; Col; Between.
    }

    {
    destruct HPTQ as [HPTQ HDiff1].
    destruct HQUR as [HQUR HDiff2].
    apply between_symmetry in HQUR.
    destruct (inner_pasch R P Q U T HQUR HPTQ) as [J [HPJU HRJT]].
    assert (HRJS : Bet R J S) by (spliter; eBetween).
    spliter; assert_diffs; assert_cols.
    split; try (intro; apply HNC; ColR).
    split; try (intro; apply HNC; ColR).
    exists J; split; Col; Between.
    }
  }
Qed.

Lemma impossible_case_8 : forall P Q R S T U I,
  BetS P T Q ->
  BetS R T S ->
  BetS Q U R ->
  ~ Col P Q S ->
  ~ Col P R U ->
  Par P R Q S ->
  Par P S Q R ->
  Col P U I ->
  Bet I S Q ->
  False.
Proof.
intros P Q R S T U I HPTQ HRTS HQUR HNC HNC' HPar1 HPar2 HPUI HSQI.
apply BetSEq in HPTQ; apply BetSEq in HRTS; apply BetSEq in HQUR.
elim HPUI; clear HPUI; intro HPUI.

  {
  assert (H : Par_strict P S Q R) by (apply par_not_col_strict with Q; Col; Par; unfold BetS in *;
                                      spliter; assert_cols; intro; apply HNC'; ColR); apply H.
  apply between_symmetry in HSQI.
  destruct (inner_pasch P Q I U S HPUI HSQI) as [J [HQJU HPJS]]; exists J.
  spliter; assert_diffs; assert_cols; split; Col; ColR.
  }

  {
  elim HPUI; clear HPUI; intro HPUI.

    {
    assert (H : Par_strict P S Q R) by (apply par_not_col_strict with Q; Col; Par; unfold BetS in *;
                                        spliter; assert_cols; intro; apply HNC'; ColR); apply H.
    apply between_symmetry in HSQI.
    destruct (outer_pasch U Q I P S HPUI HSQI) as [J [HQJU HPSJ]]; exists J.
    spliter; assert_diffs; assert_cols; split; Col; ColR.
    }

    {
    assert (H : Par_strict P R Q S) by (apply par_not_col_strict with Q; Col; Par; unfold BetS in *;
                                        spliter; assert_cols; intro; apply HNC'; ColR); apply H.
    destruct HQUR as [HQUR HDiff].
    destruct (outer_pasch Q I U R P HQUR HPUI) as [J [HQJI HRPJ]]; exists J.
    spliter; assert_diffs; assert_cols; split; Col.
    elim (eq_dec_points Q I); intro HQI; treat_equalities; Col; ColR.
    }
  }
Qed.

Lemma strong_parallel_postulate_implies_tarski_s_euclid_aux :
  strong_parallel_postulate ->
  (forall A B C D T,
   A <> B ->
   A <> C ->
   A <> D ->
   A <> T ->
   B <> C ->
   B <> D ->
   B <> T ->
   C <> D ->
   C <> T ->
   D <> T ->
   ~ Col A B C ->
   Bet A D T ->
   Bet B D C ->
   exists B', exists B'', exists MB, exists X, Bet A B X /\ Par_strict B C T X /\
   BetS B MB T /\ BetS B' MB B'' /\
   Cong B MB T MB /\ Cong B' MB B'' MB /\
   Col B B' D /\ Bet B'' T X /\
   B <> B' /\ B'' <> T).
Proof.
intros HSPP A B C D T HAB HAC HAD HAT HBC HBD HBT HCD HCT HDT HABC HADT HBDC.
destruct (symmetric_point_construction D B) as [B' HB'].
destruct (midpoint_distinct_2 B D B' HBD HB') as [HB'D HBB'].
destruct HB' as [HBDB' HCong1].
apply between_symmetry in HADT.
apply between_symmetry in HBDB'.
destruct (outer_pasch T B' D A B HADT HBDB') as [B''' [HTB'''B' HABB''']].
destruct (midpoint_existence B T) as [MB HMB].
destruct (midpoint_distinct_1 MB B T HBT HMB) as [HBMB HMBT].
destruct HMB as [HBMBT HCong2].
destruct (symmetric_point_construction B' MB) as [B'' HB''].
assert (HB'MB : MB <> B').
  {
  assert (H : ~ Col B' D MB) by (intro; apply HABC; assert_cols; ColR).
  intro; treat_equalities; apply H; Col.
  }
destruct (midpoint_distinct_2 MB B' B'' HB'MB HB'') as [HB'B'' HB''MB].
destruct HB'' as [HB'MBB'' HCong3].
assert (H1 : BetS B MB T) by (repeat split; Between).
assert (H2 : BetS B' MB B'') by (repeat split; Between).
assert (HB'T : B' <> T).
  {
  assert (H : ~ Col B B' T) by (intro; apply HABC; assert_cols; ColR).
  intro; treat_equalities; apply H; Col.
  }
assert (HB'B''' : B' <> B''').
  {
  assert (H : ~ Col A B B') by (intro; apply HABC; assert_cols; ColR).
  intro; treat_equalities; apply H; Col.
  }
assert (HB'''T : B''' <> T).
  {
  assert (H : ~ Col A B T) by (intro; apply HABC; assert_cols; ColR).
  intro; treat_equalities; apply H; Col.
  }
assert (H3 : BetS T B''' B') by (repeat split; Between).
assert (H4 : ~ Col B T B'') by (intro; apply HABC; assert_cols; ColR).
assert (H5 : Cong B MB T MB) by Cong.
assert (H6 : Cong B' MB B'' MB) by Cong.
destruct (HSPP B T B' B'' MB B''') as [X [HBetS HX]];
Col; Cop; try (intro; apply H4; assert_diffs; assert_cols; ColR).
assert (HNC : ~ Col B B' B''') by (intro; assert_diffs; assert_cols; apply H4; ColR).
assert (HPar1 : Par B B' T B'') by (unfold BetS in *; spliter; apply l12_17 with MB; try split; Col).
assert (HPar2 : Par B B'' T B')
  by (unfold BetS in *; spliter; assert_diffs; apply l12_17 with MB; try split; Between; Cong).
elim HBetS; clear HBetS; intro HBetS.

  {
  elim HX; clear HX; intro HX.

    {
    assert (H : BetS B'' T X).
      {
      repeat split; try (intro; treat_equalities); Col.
      apply H4; assert_diffs; assert_cols; ColR.
      }
    clear HBetS; rename H into HBetS.
    assert (H : BetS B B''' X).
      {
      repeat split; try (intro; treat_equalities); Col; unfold BetS in *; spliter;
      apply H4; assert_diffs; assert_cols; ColR.
      }
    clear HX; rename H into HX.
    apply BetSEq in HBetS; destruct HBetS as [HB''TX [HB''T [HB''X HBTX]]].
    exists B'; exists B''; exists MB; exists X.
    split; unfold BetS in HX; spliter; eBetween.
    assert (HPar : Par B' B B'' T) by (apply l12_17 with MB; try split; Between; Cong).
    assert (HPar' : Par B C B'' T)
      by (apply par_symmetry; apply par_col_par with B'; Par; assert_cols; ColR).
    split.

      {
      apply par_not_col_strict with T; Col.

        {
        apply par_col_par with B''; Par.
        assert_cols; ColR.
        }

        {
        intro; apply HABC; assert_cols; ColR.
        }
      }

      {
      repeat (split; try assumption); unfold BetS in *; spliter; assert_cols; Col.
      }
    }

    {
    elim HX; clear HX; intro HX.

      {
      exfalso; apply impossible_case_5 with B T B' B'' MB B''' X; spliter; assumption.
      }

      {
      exfalso; apply impossible_case_6 with B T B' B'' MB B''' X; spliter; assumption.
      }
    }
  }

  {
  elim HBetS; clear HBetS; intro HBetS.

    {
    exfalso; apply impossible_case_7 with B T B' B'' MB B''' X; spliter; assumption.
    }

    {
    exfalso; apply impossible_case_8 with B T B' B'' MB B''' X; spliter; assumption.
    }
  }

Qed.

Lemma strong_parallel_postulate_implies_tarski_s_euclid :
  strong_parallel_postulate ->
  tarski_s_parallel_postulate.
Proof.
unfold tarski_s_parallel_postulate.
intro HSPP; apply tarski_s_euclid_remove_degenerated_cases.
intros A B C D T HAB HAC HAD HAT HBC HBD HBT HCD HCT HDT HABC HADT HBDC.
destruct (strong_parallel_postulate_implies_tarski_s_euclid_aux HSPP A B C D T)
as [B' [B'' [MB [X [HABX [HPar' [HBet1 [HBet2 [HCong1 [HCong2 [HBB'D [HB''TX [HBB' HB''T]]]]]]]]]]]]];
destruct (strong_parallel_postulate_implies_tarski_s_euclid_aux HSPP A C B D T)
as [C' [C'' [MC [Y [HACY [HPar [HBet3 [HBet4 [HCong3 [HCong4 [HCC'D [HC''TY [HCC' HC''T]]]]]]]]]]]]];
Between; Col.
clear HBet3; clear HBet4; clear HCong3; clear HCong4;
clear MC; clear HC''TY; clear HC''T; clear HPar'.
exists X; exists Y; repeat split; try assumption.
elim (col_dec X T Y); intro HXTY.

  {
  apply between_symmetry in HACY.
  assert (HU := outer_pasch Y B C A D HACY HBDC); destruct HU as [U [HYUB HADU]].
  apply between_symmetry in HABX.
  assert (HV := outer_pasch X Y B A U HABX HYUB); destruct HV as [V [HXVY HAUV]].
  assert (HAX : A <> X) by (intro; treat_equalities; Col).
  assert (HAY : A <> Y) by (intro; treat_equalities; Col).
  assert (HAXY : ~ Col A X Y) by (intro; assert_cols; apply HABC; ColR).
  assert (HAU : A <> U) by (intro; treat_equalities; Col).
  assert (HEq : T = V) by (assert_cols; apply l6_21 with X Y A D; Col; ColR); subst; assumption.
  }

  {
  assert (HNC : ~ Col T B'' Y) by (intro; apply HXTY; unfold BetS in *; spliter; assert_cols; ColR).
  assert (HCop : Coplanar T B B'' Y).
    {
    apply coplanar_pseudo_trans with A B C; assert_cols; Cop.

      {
      exists D; assert_cols; Col5.
      }

      {
      assert (HABD : ~ Col D A B) by (intro; assert_cols; apply HABC; ColR).
      apply coplanar_trans_1 with D; [Cop..|].
      apply ts__coplanar.
      apply l9_8_2 with X.

        {
        assert (HAX : A <> X) by (intro; treat_equalities; apply HABC; Col).
        split; try (intro; assert_cols; apply HABC; ColR).
        split; try (intro; assert_cols; apply HABC; ColR).
        exists T; split; Col; Between.
        }

        {
        apply invert_one_side.
        assert (HADA : Col A D A) by Col.
        assert (HXBA : Col X B A) by (assert_cols; Col).
        rewrite (l9_19 A D X B A HADA HXBA).
        assert (HAX : A <> X) by (intro; treat_equalities; apply HABC; Col).
        split; try (intro; assert_cols; apply HABC; ColR); split; auto.
        }
      }
    }
  destruct (HSPP T B B'' B' MB Y) as [I [HCol1 HCol2]]; Cong;
  try (unfold BetS in *; spliter; repeat (split; try Between)).
  exfalso; apply HPar; exists I; split; Col.
  elim (eq_dec_points I B); intro HBI; subst; Col.
  unfold BetS in *; spliter; assert_cols; ColR.
  }
Qed.

End SPP_tarski.


Require Import Lists.List.
Require Import Coq.Arith.PeanoNat.

Require Import Top.FinSet.Distinct.
Require Import Top.FinSet.Remove.

(**

  * Injections between lists

 *)
Section lists.
  Variables A B : Type.
  Variable f : A -> B.
  Variable aa : list A.

  Definition inj_on_list : Prop :=
    forall a a', In a aa -> In a' aa -> f a = f a' -> a = a'.

  Variable bb : list B.

  Definition is_list_map : Prop :=
    forall a, In a aa -> In (f a) bb.

  Definition surj_on_list : Prop :=
    forall b, In b bb -> In b (map f aa).

End lists.

Arguments inj_on_list {A B} f aa.
Arguments is_list_map {A B} f aa bb.
Arguments surj_on_list {A B} f aa bb.

Lemma inj_on_list_uncons {A B : Type} {f : A -> B} {a aa}
  : inj_on_list f (a :: aa) -> inj_on_list f aa.
Proof.
  unfold inj_on_list; auto with datatypes.
Qed.

Lemma is_list_map_uncons {A B : Type} {f : A -> B} {a aa bb}
      (decB : forall x y : B, {x = y} + {x <> y})
  : is_list_map f (a :: aa) bb ->
    ~ In a aa ->
    inj_on_list f (a :: aa) ->
    is_list_map f aa (remove decB (f a) bb).
Proof.
  unfold is_list_map.
  intros lmH notH injH a' inH.
  apply in_remove; auto with datatypes.
  unfold inj_on_list in injH.
  intro feqH.
  rewrite (injH a' a (in_cons a a' aa inH) (in_eq a aa) feqH) in inH.
  contradiction.
Qed.

Lemma list_map_cons_first_in_tgt {A B : Type} {f : A -> B} {a aa bb}
  : is_list_map f (a :: aa) bb -> In (f a) bb.
Proof.
  auto using (in_eq  a aa).
Qed.

Lemma distinct_inj_induct
      {A B : Type} {f : A -> B} {aa bb}
      (decB : forall x y : B, {x = y} + {x <> y})
      P
  : (forall bb, P nil bb) ->
    (forall a aa bb, distinct aa ->
                     distinct bb ->
                     ~ In a aa ->
                     is_list_map f (a :: aa) bb ->
                     P aa (remove decB (f a) bb) ->
                     P (a :: aa) bb) ->
    distinct aa ->
    distinct bb ->
    is_list_map f aa bb ->
    inj_on_list f aa ->
    P aa bb.
Proof.
  intros nilH stepH; revert bb.
  induction aa as [ | a aa IH ]; auto.
  intros bb distaH distbH lmH injH.
  destruct distaH as [ norepaH distaH ].
  specialize (IH (remove decB (f a) bb) distaH
                 (distinct_remove decB (f a) distbH)
                 (is_list_map_uncons decB lmH norepaH injH)
                 (inj_on_list_uncons injH)).
  auto.
Qed.

Lemma inj_on_list_length
      {A B : Type} {f : A -> B} (aa : list A) (bb : list B)
      (decB : forall x y : B, {x = y} + {x <> y})
  : distinct aa ->
    distinct bb ->
    is_list_map f aa bb ->
    inj_on_list f aa ->
    length aa <= length bb.
Proof.
  apply (distinct_inj_induct decB (fun aa bb => length aa <= length bb));
    auto using le_0_n.
  clear aa bb; intros a aa bb distaH distbH norepaH lmH lenH.
  rewrite (length_distinct_remove_in
             decB distbH (list_map_cons_first_in_tgt lmH)).
  simpl; auto using le_n_S.
Qed.

Lemma surj_on_list_nil {A B : Type} (f : A -> B) (l : list A)
  : surj_on_list f l nil.
Proof.
  unfold surj_on_list; intros; contradiction.
Qed.

(*

  Now we want to show how to get a surjection from an injection. If I
  have an injective map between two equal length lists (with no
  duplicates) then it follows that the map is actually surjective.

*)
Lemma inj_on_eql_list_is_surj
      {A B : Type} {f : A -> B}
      (aa : list A) (bb : list B)
      (decB : forall x y : B, {x = y} + {x <> y})
  : distinct aa -> distinct bb ->
    is_list_map f aa bb ->
    inj_on_list f aa ->
    length aa = length bb ->
    surj_on_list f aa bb.
Proof.
  apply (distinct_inj_induct
           decB
           (fun aa bb => length aa = length bb -> surj_on_list f aa bb));
    clear aa bb.
  - intros bb lenH.
    enough (bbH : bb = nil); try (rewrite bbH; auto using surj_on_list_nil).
    apply length_zero_iff_nil; auto.
  - intros a aa bb distaH distbH norepaH lmH stepH lenH.
    rewrite (length_distinct_remove_in
               decB distbH (list_map_cons_first_in_tgt lmH)) in lenH.
    simpl in lenH.
    specialize (stepH (eq_add_S _ _ lenH)); clear lenH.
    intros b inH; unfold surj_on_list in stepH; specialize (stepH b).
    rewrite map_cons.
    destruct (decB b (f a)) as [ -> | neH ].
    + apply in_eq.
    + apply in_cons; apply stepH.
      apply (in_remove decB inH neH).
Qed.


(* Software Foundations *)
(* Exercice 1 star, not_both_true_and_false *)

Theorem not_both_true_and_false: forall P: Prop, ~(P /\ ~ P).
Proof.
    intros.
    unfold not.
    intros.
    inversion H.
    apply H1 in H0.
    apply H0.
Qed.


Require Import Arith.Arith.
Require Import Bool.Bool.
Require Export Coq.Strings.String.
Require Import Logic.FunctionalExtensionality.
Require Import Lists.List.
Require Import Relations String.
Import ListNotations.

Module Maps.
  Definition eqb_string (x y : string) : bool :=
    if string_dec x y then true else false.

  Theorem eqb_string_refl : forall s : string, true = eqb_string s s.
  Proof.
    intros s. unfold eqb_string.
    destruct (string_dec s s) as [Hs_eq | Hs_not_eq].
    - reflexivity.
    - destruct Hs_not_eq. reflexivity.
  Qed.

  Theorem eqb_string_true_iff : forall x y : string,
    eqb_string x y = true <-> x = y.
  Proof.
    intros x y.
    unfold eqb_string.
    destruct (string_dec x y) as [Hs_eq | Hs_not_eq].
    - rewrite Hs_eq. split. reflexivity. reflexivity.
    - split.
      + intros contra. discriminate contra.
      + intros H. exfalso. apply Hs_not_eq. apply H.
  Qed.

  Theorem eqb_string_false_iff : forall x y : string,
    eqb_string x y = false <-> x <> y.
  Proof.
    intros x y. rewrite <- eqb_string_true_iff.
    rewrite not_true_iff_false. reflexivity. Qed.

  (** This corollary follows just by rewriting: *)

  Theorem false_eqb_string : forall x y : string,
    x <> y -> eqb_string x y = false.
  Proof.
    intros x y. rewrite eqb_string_false_iff.
    intros H. apply H. Qed.

  Definition total_map (A : Type) := string -> A.

  Definition t_empty {A : Type} (v : A) : total_map A :=
  (fun _ => v).

  Definition t_update {A : Type} (m : total_map A)
                    (x : string) (v : A) :=
  fun x' => if eqb_string x x' then v else m x'.

  Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).

  Notation "x '!->' v ';' m" := (t_update m x v)
                                (at level 100, v at next level, right associativity).

  Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
    (_ !-> v) x = v.
  Proof ltac:(reflexivity).

  Lemma t_update_eq : forall (A : Type) (m : total_map A) x v,
    (x !-> v ; m) x = v.
  Proof.
    intros. unfold t_update.
    rewrite <- eqb_string_refl; auto.
  Qed.

  Theorem t_update_neq : forall (A : Type) (m : total_map A) x1 x2 v,
    x1 <> x2 ->
    (x1 !-> v ; m) x2 = m x2.
  Proof with auto.
    intros **. unfold t_update.
    rewrite false_eqb_string...
  Qed.

  Lemma t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
  (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
  Proof.
    intros. unfold t_update.
    extensionality y.
    destruct (eqb_string x y); auto.
  Qed.

  Lemma eqb_stringP : forall x y : string,
    reflect (x = y) (eqb_string x y).
  Proof with auto.
    intros. destruct (eqb_string x y) eqn:X;
    constructor;
    [ apply eqb_string_true_iff
    | apply eqb_string_false_iff ]...
  Qed.

  Theorem t_update_same : forall (A : Type)
      (m : total_map A) x,
    (x !-> m x ; m) = m.
  Proof.
    intros. unfold t_update. extensionality y.
    destruct (eqb_stringP x y) as [<- |]; auto.
  Qed.

  Theorem t_update_permute : forall (A : Type)
      (m : total_map A) v1 v2 x1 x2,
      x2 <> x1 ->
    (x1 !-> v1 ; x2 !-> v2 ; m)
    =
    (x2 !-> v2 ; x1 !-> v1 ; m).
  Proof with auto.
    intros. unfold t_update. extensionality y.
    destruct (eqb_stringP x1 y) as [<-|];
    [rewrite false_eqb_string|]...
  Qed.

  Definition partial_map (A : Type) := total_map (option A).

  Definition empty {A : Type} : partial_map A :=
    t_empty None.

  Definition update {A : Type} (m : partial_map A)
            (x : string) (v : A) :=
    (x !-> Some v ; m).

  (** We introduce a similar notation for partial maps: *)
  Notation "x '|->' v ';' m" := (update m x v)
    (at level 100, v at next level, right associativity).

  (** We can also hide the last case when it is empty. *)
  Notation "x '|->' v" := (update empty x v)
    (at level 100).

  Lemma apply_empty : forall (A : Type) (x : string),
    @empty A x = None.
  Proof.
    intros. unfold empty. rewrite t_apply_empty.
    reflexivity.
  Qed.

  Lemma update_eq : forall (A : Type) (m : partial_map A) x v,
    (x |-> v ; m) x = Some v.
  Proof.
    intros. unfold update. rewrite t_update_eq.
    reflexivity.
  Qed.

  Theorem update_neq : forall (A : Type) (m : partial_map A) x1 x2 v,
    x2 <> x1 ->
    (x2 |-> v ; m) x1 = m x1.
  Proof.
    intros A m x1 x2 v H.
    unfold update. rewrite t_update_neq. reflexivity.
    apply H. Qed.

  Lemma update_shadow : forall (A : Type) (m : partial_map A) x v1 v2,
    (x |-> v2 ; x |-> v1 ; m) = (x |-> v2 ; m).
  Proof.
    intros A m x v1 v2. unfold update. rewrite t_update_shadow.
    reflexivity.
  Qed.

  Theorem update_same : forall (A : Type) (m : partial_map A) x v,
    m x = Some v ->
    (x |-> v ; m) = m.
  Proof.
    intros A m x v H. unfold update. rewrite <- H.
    apply t_update_same.
  Qed.

  Theorem update_permute : forall (A : Type) (m : partial_map A)
                                  x1 x2 v1 v2,
    x2 <> x1 ->
    (x1 |-> v1 ; x2 |-> v2 ; m) = (x2 |-> v2 ; x1 |-> v1 ; m).
  Proof.
    intros A m x1 x2 v1 v2. unfold update.
    apply t_update_permute.
  Qed.

  Definition inclusion {A : Type} (m m' : partial_map A) :=
  forall x v, m x = Some v -> m' x = Some v.

  (** We then show that map update preserves map inclusion, that is: *)

  Lemma inclusion_update : forall (A : Type) (m m' : partial_map A)
                                  (x : string) (vx : A),
    inclusion m m' ->
    inclusion (x |-> vx ; m) (x |-> vx ; m').
  Proof.
    unfold inclusion.
    intros A m m' x vx H.
    intros y vy.
    destruct (eqb_stringP x y) as [Hxy | Hxy].
    - rewrite Hxy.
      rewrite update_eq. rewrite update_eq. intro H1. apply H1.
    - rewrite update_neq. rewrite update_neq.
      + apply H.
      + apply Hxy.
      + apply Hxy.
  Qed.

  Corollary inclusion_empty :
      forall (X: Type) (m: partial_map X),
    inclusion empty m.
  Proof ltac:(inversion 1).

  Hint Resolve inclusion_empty : core.

End    Maps.

Import Maps.
Ltac inv H := inversion H; subst; clear H.
Create HintDb stlcabDB.

Inductive multi {X : Type} (R : relation X) : relation X :=
  | multi_refl : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

Inductive ty : Type :=
  | Ty_Bool  : ty
  | Ty_Arrow : ty -> ty -> ty.

Inductive tm : Type :=
  | tm_var   : string -> tm
  | tm_app   : tm -> tm -> tm
  | tm_abs   : string -> ty -> tm -> tm
  | tm_true  : tm
  | tm_false : tm
  | tm_if    : tm -> tm -> tm -> tm.

Declare Custom Entry stlc.
Notation "<{ e }>" := e (e custom stlc at level 99).
Notation "( x )" := x (in custom stlc, x at level 99).
Notation "x" := x (in custom stlc at level 0, x constr at level 0).
Notation "S -> T" := (Ty_Arrow S T) (in custom stlc at level 50, right associativity).
Notation "x y" := (tm_app x y) (in custom stlc at level 1, left associativity).
Notation "\ x : t , y" :=
  (tm_abs x t y) (in custom stlc at level 90, x at level 99,
                     t custom stlc at level 99,
                     y custom stlc at level 99,
                     left associativity).
Coercion tm_var : string >-> tm.

Notation "'Bool'" := Ty_Bool (in custom stlc at level 0).
Notation "'if' x 'then' y 'else' z" :=
  (tm_if x y z) (in custom stlc at level 89,
                    x custom stlc at level 99,
                    y custom stlc at level 99,
                    z custom stlc at level 99,
                    left associativity).
Notation "'true'"  := true (at level 1).
Notation "'true'"  := tm_true (in custom stlc at level 0).
Notation "'false'"  := false (at level 1).
Notation "'false'"  := tm_false (in custom stlc at level 0).

(* ################################################################# *)
(** * Operational Semantics *)

(** To define the small-step semantics of STLC terms, we begin,
    as always, by defining the set of values.  Next, we define the
    critical notions of _free variables_ and _substitution_, which are
    used in the reduction rule for application expressions.  And
    finally we give the small-step relation itself. *)

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

Inductive value : tm -> Prop :=
  | v_abs   : forall x T2 t1, value <{\x:T2, t1}>
  | v_true  : value <{true}>
  | v_false : value <{false}>.

Hint Constructors value : core.

Reserved Notation "'[' x ':=' s ']' t" (in custom stlc at level 20, x constr).

(* This is not capture avoiding!

      (x := z) λz.x ==> λz.z

   [TAPL]
   we've turned the constant function λz.x into the identity function!
   Again, this occurred only because we happened to choose z as the
   name of the bound variable in the constant function, so something
   is clearly still wrong. *)
(* Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
  match t with
  | tm_var y                  => if eqb_string x y then s else t
  | <{\y:T, t1}>              => if eqb_string x y
                                 then t else <{\y:T, [x:=s] t1}>
  | <{t1 t2}>                 => <{([x:=s] t1) ([x:=s] t2)}>
  | <{true}>                  => <{true}>
  | <{false}>                 => <{false}>
  | <{if t1 then t2 else t3}> => <{if ([x:=s] t1) then ([x:=s] t2) else ([x:=s] t3)}>
  end

where "'[' x ':=' s ']' t" := (subst x s t) (in custom stlc). *)

Inductive appears_free_in (x : string) : tm -> Prop :=
  | afi_var : appears_free_in x <{x}>
  | afi_app1 : forall t1 t2,
      appears_free_in x t1 ->
      appears_free_in x <{t1 t2}>
  | afi_app2 : forall t1 t2,
      appears_free_in x t2 ->
      appears_free_in x <{t1 t2}>
  | afi_abs : forall y T1 t1,
      y <> x ->
      appears_free_in x t1 ->
      appears_free_in x <{\y:T1, t1}>
  | afi_if1 : forall t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x <{if t1 then t2 else t3}>
  | afi_if2 : forall t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x <{if t1 then t2 else t3}>
  | afi_if3 : forall t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x <{if t1 then t2 else t3}>.
Hint Constructors appears_free_in : core.

Reserved Notation "t '-->' t'" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T2 t1 v2,
         value v2 ->
         <{(\x:T2, t1) v2}> --> <{ [x:=v2]t1 }>
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         <{t1 t2}> --> <{t1' t2}>
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         <{v1 t2}> --> <{v1  t2'}>
  | ST_IfTrue : forall t1 t2,
      <{if true then t1 else t2}> --> t1
  | ST_IfFalse : forall t1 t2,
      <{if false then t1 else t2}> --> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 --> t1' ->
      <{if t1 then t2 else t3}> --> <{if t1' then t2 else t3}>

where "t '-->' t'" := (step t t').

Hint Constructors step : core.

Notation multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).
(* ################################################################# *)
(** * Typing *)

(** Next we consider the typing relation of the STLC. *)

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

(** _Question_: What is the type of the term "[x y]"?

    _Answer_: It depends on the types of [x] and [y]!

    I.e., in order to assign a type to a term, we need to know
    what assumptions we should make about the types of its free
    variables.

    This leads us to a three-place _typing judgment_, informally
    written [Gamma |- t \in T], where [Gamma] is a
    "typing context" -- a mapping from variables to their types. *)

(** Following the usual notation for partial maps, we write [(X |->
    T, Gamma)] for "update the partial function [Gamma] so that it
    maps [x] to [T]." *)

Definition context := partial_map ty.

(* ================================================================= *)
(** ** Typing Relation *)

Reserved Notation "Gamma '|-' t '\in' T"
            (at level 101,
             t custom stlc, T custom stlc at level 0).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall G x T1
      (IH: G x = Some T1),
      G |- x \in T1
  | T_Abs : forall G x T1 T2 t1
      (IH: x |-> T2 ; G |- t1 \in T1),
      G |- \x:T2, t1 \in (T2 -> T1)
  | T_App : forall T1 T2 G t1 t2
      (IH1: G |- t1 \in (T2 -> T1))
      (IH2: G |- t2 \in T2),
      G |- t1 t2 \in T1
  | T_True : forall G,
       G |- true \in Bool
  | T_False : forall G,
       G |- false \in Bool
  | T_If : forall t1 t2 t3 T1 G
       (IH1: G |- t1 \in Bool)
       (IH2: G |- t2 \in T1)
       (IH3: G |- t3 \in T1),
       G |- if t1 then t2 else t3 \in T1

where "G '|-' t '\in' T" := (has_type G t T).

Hint Constructors has_type : core.

Theorem t__unique_typ : forall t G T T'
    (tT: G |- t \in T) (tT': G |- t \in T'),
  T = T'.
Proof with eauto.
  induction t; intros.
  all: inv tT; inv tT'...
  - rewrite IH0 in IH. injection IH...
  - rewrite (IHt2 _ _ _ IH3 IH2) in IH0.
    pose proof (IHt1 _ _ _ IH1 IH0). inv H...
  - rewrite (IHt _ _ _ IH IH0)...
Qed.

Theorem v_val_Bool__tof : forall v G
    (valv: value v)
    (vBool: G |- v \in Bool),
  v = <{true}> \/ v = <{false}>.
Proof with eauto.
  intros. inv valv...
  inv vBool.
Qed.

(* Theorem value__closed : forall v G T
    (valv: value v)
    (vT: G |- v \in T),
  empty |- v \in T.
Proof with eauto.
  induction 2;
  try solve [inv valv]...

  econstructor. clear - vT.
  inv vT...
  + econstructor. erewrite <- update_shadow ...
  update_shadow
  inv vT.
  - inv valv.
  -
Qed. *)

Theorem progress : forall t T
    (twt: empty |- t \in T),
  value t \/ exists t', t --> t'.
Proof with eauto.
  remember empty as G.
  induction 1...
  - rewrite HeqG in IH. inv IH.
  - rename IHtwt1 into IH1, IHtwt2 into IH2.
    specialize (IH1 HeqG). specialize (IH2 HeqG).
    right. destruct IH1; [destruct IH2 |].
    + inv H; [ eexists; econstructor| |]...
      all: inv twt1.
    + destruct H0. eexists; eapply ST_App2...
    + destruct H.  eexists; eapply ST_App1...
  - rename IHtwt1 into IH1, IHtwt2 into IH2,
           IHtwt3 into IH3. specialize (IH1 HeqG).
    specialize (IH2 HeqG). specialize (IH3 HeqG).
    right. destruct IH1;
    [ inv H; [inv twt1| |]
    | destruct H]; eexists; econstructor ...
Qed.

Lemma weakening : forall G G' t T
    (INCL: inclusion G G')
    (H: G |- t \in T),
  G' |- t \in T.
Proof with eauto.
  intros **. generalize dependent G'.
  induction H;
  try solve [econstructor; try apply INCL; auto];
  intros.

  econstructor. eapply IHhas_type. intros ? **.
  destruct (eqb_stringP x x0) as [<-|].
  - now rewrite update_eq in *.
  - rewrite update_neq in *...
Qed.

Lemma weakening_empty : forall G t T,
    empty |- t \in T  ->
  G |- t \in T.
Proof with auto.
  intros. eapply weakening...
Qed.

Lemma substitution_preserves_typing : forall G x U t v T,
    x |-> U ; G |- t \in T ->
    empty |- v \in U ->
  G |- [x:=v]t \in T.
Proof with eauto.
  intros *; revert G x U v T.
  induction t; intros **; simpl; inv H...
  - destruct (eqb_stringP x s) as [<-|].
    + rewrite update_eq in IH.
      injection IH as ->.
      apply weakening_empty...
    + econstructor. rewrite update_neq in IH...
  - destruct (eqb_stringP x s) as [<-|]; econstructor.
    + rewrite update_shadow in IH...
    + eapply IHt... rewrite update_permute...
Qed.

Lemma substitution_of_open_tm_preserves_typing :
    forall G x U t v T,
    x |-> U ; G |- t \in T ->
    G |- v \in U ->
  G |- [x:=v]t \in T.
Proof with eauto.
  intros *; revert G x U v T.
  induction t; intros **; simpl; inv H...
  - destruct (eqb_stringP x s) as [<-|].
    + rewrite update_eq in IH.
      injection IH as ->...
    + econstructor. rewrite update_neq in IH...
  - destruct (eqb_stringP x s) as [<-|]; econstructor.
    + rewrite update_shadow in IH...
    + eapply IHt... rewrite update_permute...
    admit.
Admitted.

Ltac niceIH :=
  try rename IHhas_type into IH;
  try rename IHhas_type1 into IH1;
  try rename IHhas_type2 into IH2;
  try rename IHhas_type3 into IH3.
(* Goal forall G x U t v T,
    x |-> U ; G |- t \in T ->
    empty |- v \in U ->
  G |- [x:=v]t \in T.
Proof with eauto.
  intros.
  remember (x |-> U; G) as G'.
  revert dependent v. revert dependent G.
  revert x U.
  induction H... all: intros * -> **;
  try rename IHhas_type into IH;
  try rename IHhas_type1 into IH1;
  try rename IHhas_type2 into IH2;
  try rename IHhas_type3 into IH3.
  - destruct (eqb_stringP x x0) as [<-|]; simpl;
    [ rewrite <- eqb_string_refl
    | rewrite false_eqb_string ]...
    + rewrite update_eq in IH.
      injection IH as <-. apply weakening_empty...
    + rewrite update_neq in IH...
  - specialize (IH _ eq_refl).

Qed. *)

Theorem preservation : forall t t' T,
    empty |- t \in T  ->
    t --> t'  ->
  empty |- t' \in T.
Proof with eauto.
  remember empty as G.
  intros * ?; revert t'. induction H; intros;
  try solve [inv H| inv H0|inv H2;eauto]; niceIH.
  inv HeqG. specialize (IH2 eq_refl).
  specialize (IH1 eq_refl).

  inv H1; try solve [econstructor;eauto].
  inv H. eapply substitution_preserves_typing...
Qed.

Theorem preservation_strong : forall t t' T G,
    G |- t \in T  ->
    t --> t'  ->
  G |- t' \in T.
Proof with eauto.
  intros * ?; revert t'. induction H; intros;
  try solve [inv H| inv H0|inv H2;eauto]; niceIH.

  inv H1; try solve [econstructor;eauto].
  inv H. eapply substitution_of_open_tm_preserves_typing...
Qed.

Require Import List Nat.
Definition ident := nat.

(* deBruijn index *)
Definition dbi := nat.

Inductive ty : Type :=
  | Bool
  | Arrow : ty -> ty -> ty.

(* Inductive binding : Type := VarBind : ty -> binding. *)
Definition context := list (ident * ty).
Definition add_binding ctx x bind : context := (x,bind)::ctx.

Fixpoint get_binding (ctx:context) i :=
  match ctx with
  | (x,T) :: tl => if Nat.eqb x i
                   then Some T
                   else get_binding tl i
  | _ => None
  end.

Definition getTypeFromContext ctx i :=
  match get_binding ctx i with
  | Some ty => ty
  | _ => Bool
  end.

Notation "x ;; T ∈ G" := (get_binding G x = Some T) (at level 1, T at next level).

Inductive tm : Type :=
  | ttrue
  | tfalse
  | ITE : tm -> tm -> tm -> tm
  | var : nat -> tm
  | abs : ident -> ty -> tm -> tm
  | app : tm -> tm -> tm.

Fixpoint size t :=
  match t with
  | ttrue | tfalse | var _ => 1
  | abs _ _ t => 1 + size t
  | app t1 t2 => 1 + size t1 + size t2
  | ITE t1 t2 t3 => 1 + size t1 + size t2 + size t3
  end.

Fixpoint binders acc t : Prop :=
  match t with
  | var k => if <
  end

Notation "'If' c 'Then' u 'Else' v" :=
  (ITE c u v)
  (at level 200).

Inductive val : tm -> Prop :=
  | vtrue : val ttrue
  | vfalse : val tfalse
  | vabs : forall x T body,
    val (abs x T body).

Inductive type_of : context -> tm -> ty -> Prop :=
  | tttrue : forall G, type_of G ttrue Bool
  | ttfalse : forall G, type_of G tfalse Bool
  | tif : forall G t1 t2 t3 T
      (t1ht: type_of G t1 Bool)
      (t2ht: type_of G t2 T)
      (t3ht: type_of G t3 T),
    type_of G (ITE t1 t2 t3) T
  | tvar : forall G x T,
      (x ;; T ∈ G) ->
    type_of G (var x) T
  | tabs : forall G x body Tx Tb
      (H: type_of (add_binding G x Tx) body Tb),
    type_of G (abs x Tx body) (Arrow Tx Tb)
  | tapp : forall G t1 t2 T2 T
      (t1ht: type_of G t1 (Arrow T2 T))
      (t2ht: type_of G t2 T2),
    type_of G (app t1 t2) T.

Notation "G |- t ;; T" := (type_of G t T) (at level 1, t at next level).

#[export] Hint Resolve vtrue vfalse vabs
tttrue ttfalse tif tvar tabs tapp : stlcabDB.

Fixpoint shift d c t :=
  match t with
  | var k => if k <? c then t else var (k + d)
  | abs x T body => abs x T (shift d (S c) body)
  | app t1 t2 => app (shift d c t1) (shift d c t2)
  | ITE t1 t2 t3 => ITE (shift d c t1) (shift d c t2) (shift d c t3)
  | _ => t
  end.

Definition dshift d t := shift d 0 t.

Fixpoint subst_by_in (j: dbi) (s t: tm) : tm :=
  match t with
  | var k => if k =? j then s else t
  | abs x T body => abs x T (subst_by_in (S j) (dshift 1 s) body)
  | app t1 t2 => app (subst_by_in j s t1) (subst_by_in j s t2)
  | ITE t1 t2 t3 => ITE (subst_by_in j s t1) (subst_by_in j s t2) (subst_by_in j s t3)
  | _ => t
  end.

Inductive step : tm -> tm -> Prop :=
  | eiftrue : forall t2 t3,
      step (If ttrue Then t2 Else t3) t2
  | eiffalse : forall t2 t3,
      step (If tfalse Then t2 Else t3) t3
  | eif : forall t t' t2 t3
        (IH: step t t'),
      step (If t Then t2 Else t3) (If t' Then t2 Else t3)
  | eapp1 : forall t t' targ
        (IH: step t t'),
      step (app t targ) (app t' targ)
  | eapp2 : forall v t t'
        (IHv: val v)
        (IH: step t t'),
      step (app v t) (app v t')
  | eappabs : forall x T body v,
      step (app (abs x T body) v) (subst_by_in 0 v body).

Notation "a --> b" := (step a b) (at level 5).

Inductive stepstar : tm -> tm -> Prop :=
  | zerosteps : forall t, stepstar t t
  | oneormoresteps : forall t1 t2 t3,
      step t1 t2 -> stepstar t2 t3 -> stepstar t1 t3.
Notation "a -->* b" := (stepstar a b) (at level 5).
#[export] Hint Resolve zerosteps
eiftrue eiffalse: stlcabDB.

Theorem t__unique_typ : forall t G T T'
  (tT: G |- t ;; T) (tT': G |- t ;; T'), T = T'.
Proof with eauto.
  induction t; intros.
  all: inv tT; inv tT'...
  - rewrite H1 in H2. injection H2...
  - rewrite (IHt _ _ _ H4 H5)...
  - rewrite (IHt2 _ _ _ t2ht t2ht0) in t1ht.
    pose proof (IHt1 _ _ _ t1ht t1ht0).
    inversion H...
Qed.

Theorem v_val_Bool__tof : forall v G
    (valv: val v)
    (vBool: G |- v ;; Bool),
  v = ttrue \/ v = tfalse.
Proof with eauto.
  intros. inv valv...
  inv vBool.
Qed.

Theorem Progress : forall G t
    (twt: exists T, G |- t ;; T),
  val t \/ exists t', t --> t'.
Proof with eauto with stlcabDB.
  intros * [T tWT].
  induction tWT...
  - admit.
  -
Qed.

  Theorem Preservation

Definition in_ctx (x:nat) (T:typ) ctx :=
  nth_error ctx x  = Some T.

Inductive has_typ : tcontext -> tm -> typ -> Prop :=
  |


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 4: Semantics via Interpreters
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap.

(* We begin with a return to our arithmetic language from BasicSyntax,
 * adding subtraction*, which will come in handy later.
 * *: good pun, right? *)
Inductive arith : Set :=
| Const (n : nat)
| Var (x : var)
| Plus (e1 e2 : arith)
| Minus (e1 e2 : arith)
| Times (e1 e2 : arith).

Example ex1 := Const 42.
Example ex2 := Plus (Var "y") (Times (Var "x") (Const 3)).

(* The above definition only explains what programs *look like*.
 * We also care about what they *mean*.
 * The natural meaning of an expression is the number it evaluates to.
 * Actually, it's not quite that simple.
 * We need to consider the meaning to be a function over a valuation
 * to the variables, which in turn is itself a finite map from variable
 * names to numbers.  We use the book library's [fmap] type family. *)
Definition valuation := fmap var nat.
(* That is, the domain is [var] (a synonym for [string]) and the codomain/range
 * is [nat]. *)

(* The interpreter is a fairly innocuous-looking recursive function. *)
Fixpoint interp (e : arith) (v : valuation) : nat :=
  match e with
  | Const n => n
  | Var x =>
    (* Note use of infix operator to look up a key in a finite map. *)
    match v $? x with
    | None => 0 (* goofy default value! *)
    | Some n => n
    end
  | Plus e1 e2 => interp e1 v + interp e2 v
  | Minus e1 e2 => interp e1 v - interp e2 v
                   (* For anyone who's wondering: this [-] sticks at 0,
                    * if we would otherwise underflow. *)
  | Times e1 e2 => interp e1 v * interp e2 v
  end.

(* Here's an example valuation, using an infix operator for map extension. *)
Definition valuation0 : valuation :=
  $0 $+ ("x", 17) $+ ("y", 3).

(* Unfortunately, we can't execute code based on finite maps, since, for
 * convenience, they use uncomputable features.  The reason is that we need a
 * comparison function, a hash function, etc., to do computable finite-map
 * implementation, and such things are impossible to compute automatically for
 * all types in Coq.  However, we can still prove theorems about execution of
 * finite-map programs, and the [simplify] tactic knows how to reduce the
 * key constructions. *)
Theorem interp_ex1 : interp ex1 valuation0 = 42.
Proof.
  simplify.
  equality.
Qed.

Theorem interp_ex2 : interp ex2 valuation0 = 54.
Proof.
  unfold valuation0.
  simplify.
  equality.
Qed.

(* Here's the silly transformation we defined last time. *)
Fixpoint commuter (e : arith) : arith :=
  match e with
  | Const _ => e
  | Var _ => e
  | Plus e1 e2 => Plus (commuter e2) (commuter e1)
  | Minus e1 e2 => Minus (commuter e1) (commuter e2)
                   (* ^-- NB: didn't change the operand order here! *)
  | Times e1 e2 => Times (commuter e2) (commuter e1)
  end.

(* Instead of proving various odds-and-ends properties about it,
 * let's show what we *really* care about: it preserves the
 * *meanings* of expressions! *)
Theorem commuter_ok : forall v e, interp (commuter e) v = interp e v.
Proof.
  induct e; simplify.

  equality.

  equality.

  linear_arithmetic.

  equality.

  rewrite IHe1, IHe2.
  ring.
Qed.
(* Well, that's a relief! ;-) *)

(* Let's also revisit substitution. *)
Fixpoint substitute (inThis : arith) (replaceThis : var) (withThis : arith) : arith :=
  match inThis with
  | Const _ => inThis
  | Var x => if x ==v replaceThis then withThis else inThis
  | Plus e1 e2 => Plus (substitute e1 replaceThis withThis) (substitute e2 replaceThis withThis)
  | Minus e1 e2 => Minus (substitute e1 replaceThis withThis) (substitute e2 replaceThis withThis)
  | Times e1 e2 => Times (substitute e1 replaceThis withThis) (substitute e2 replaceThis withThis)
  end.

Theorem substitute_ok : forall v replaceThis withThis inThis,
  interp (substitute inThis replaceThis withThis) v
  = interp inThis (v $+ (replaceThis, interp withThis v)).
Proof.
  induct inThis; simplify; try equality.

  (* One case left after our basic heuristic:
   * the variable case, naturally! *)
  cases (x ==v replaceThis); simplify; equality.
Qed.
(* Great; we seem to have gotten that one right, too. *)

(* Let's also define a pared-down version of the expression-simplification
 * functions from last chapter. *)
Fixpoint doSomeArithmetic (e : arith) : arith :=
  match e with
  | Const _ => e
  | Var _ => e
  | Plus (Const n1) (Const n2) => Const (n1 + n2)
  | Plus e1 e2 => Plus (doSomeArithmetic e1) (doSomeArithmetic e2)
  | Minus e1 e2 => Minus (doSomeArithmetic e1) (doSomeArithmetic e2)
  | Times (Const n1) (Const n2) => Const (n1 * n2)
  | Times e1 e2 => Times (doSomeArithmetic e1) (doSomeArithmetic e2)
  end.

Theorem doSomeArithmetic_ok : forall e v, interp (doSomeArithmetic e) v = interp e v.
Proof.
  induct e; simplify; try equality.

  cases e1; simplify; try equality.
  cases e2; simplify; equality.

  cases e1; simplify; try equality.
  cases e2; simplify; equality.
Qed.

(* Of course, we're going to get bored if we confine ourselves to arithmetic
 * expressions for the rest of our journey.  Let's get a bit fancier and define
 * a *stack machine*, related to postfix calculators that some of you may have
 * experienced. *)
Inductive instruction :=
| PushConst (n : nat)
| PushVar (x : var)
| Add
| Subtract
| Multiply.

(* What does it all mean?  An interpreter tells us unambiguously! *)
Definition run1 (i : instruction) (v : valuation) (stack : list nat) : list nat :=
  match i with
  | PushConst n => n :: stack
  | PushVar x => (match v $? x with
                  | None => 0
                  | Some n => n
                  end) :: stack
  | Add =>
    match stack with
    | arg2 :: arg1 :: stack' => arg1 + arg2 :: stack'
    | _ => stack (* arbitrary behavior in erroneous case (stack underflow) *)
    end
  | Subtract =>
    match stack with
    | arg2 :: arg1 :: stack' => arg1 - arg2 :: stack'
    | _ => stack (* arbitrary behavior in erroneous case *)
    end
  | Multiply =>
    match stack with
    | arg2 :: arg1 :: stack' => arg1 * arg2 :: stack'
    | _ => stack (* arbitrary behavior in erroneous case *)
    end
  end.

(* That function explained how to run one instruction.
 * Here's how to run several of them. *)
Fixpoint run (is : list instruction) (v : valuation) (stack : list nat) : list nat :=
  match is with
  | nil => stack
  | i :: is' => run is' v (run1 i v stack)
  end.

(* Instead of writing fiddly stack programs ourselves, let's *compile*
 * arithmetic expressions into equivalent stack programs. *)
Fixpoint compile (e : arith) : list instruction :=
  match e with
  | Const n => PushConst n :: nil
  | Var x => PushVar x :: nil
  | Plus e1 e2 => compile e1 ++ compile e2 ++ Add :: nil
  | Minus e1 e2 => compile e1 ++ compile e2 ++ Subtract :: nil
  | Times e1 e2 => compile e1 ++ compile e2 ++ Multiply :: nil
  end.

(* Now, of course, we should prove our compiler correct.
 * Skip down to the next theorem to see the overall correctness statement.
 * It turns out that we need to strengthen the induction hypothesis with a
 * lemma, to push the proof through. *)
Lemma compile_ok' : forall e v is stack,
    run (compile e ++ is) v stack = run is v (interp e v :: stack).
Proof.
  induct e; simplify.

  equality.

  equality.

  (* Here we want to use associativity of [++], to get the conclusion to match
   * an induction hypothesis.  Let's ask Coq to search its library for lemmas
   * that would justify such a rewrite, giving a pattern with wildcards, to
   * specify the essential structure that the rewrite should match. *)
  Search ((_ ++ _) ++ _).
  (* Ah, we see just the one! *)
  rewrite app_assoc_reverse.
  rewrite IHe1.
  rewrite app_assoc_reverse.
  rewrite IHe2.
  simplify.
  equality.

  rewrite app_assoc_reverse.
  rewrite IHe1.
  rewrite app_assoc_reverse.
  rewrite IHe2.
  simplify.
  equality.

  rewrite app_assoc_reverse.
  rewrite IHe1.
  rewrite app_assoc_reverse.
  rewrite IHe2.
  simplify.
  equality.
Qed.

(* The overall theorem follows as a simple corollary. *)
Theorem compile_ok : forall e v, run (compile e) v nil = interp e v :: nil.
Proof.
  simplify.

  (* To match the form of our lemma, we need to replace [compile e] with
   * [compile e ++ nil], adding a "pointless" concatenation of the empty list.
   * [Search] again helps us find a library lemma. *)
  Search (_ ++ nil).
  rewrite (app_nil_end (compile e)).
  (* Note that we can use [rewrite] with explicit values of the first few
   * quantified variables of a lemma.  Otherwise, [rewrite] picks an
   * unhelpful place to rewrite.  (Try it and see!) *)

  apply compile_ok'.
  (* Direct appeal to a previously proved lemma *)
Qed.

(* Let's get a bit fancier, moving toward the level of general-purpose
 * imperative languages.  Here's a language of commands, building on the
 * language of expressions we have defined. *)
Inductive cmd :=
| Skip
| Assign (x : var) (e : arith)
| Sequence (c1 c2 : cmd)
| Repeat (e : arith) (body : cmd).

(* That last constructor is for repeating a body command some number of
 * times.  Note that we sneakily avoid constructs that could introduce
 * nontermination, since Coq only accepts terminating programs, and we want to
 * write an interpreter for commands.
 * In contrast to our last one, this interpreter *transforms valuations*.
 * We use a helper function for self-composing a function some number of
 * times. *)

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

Fixpoint exec (c : cmd) (v : valuation) : valuation :=
  match c with
  | Skip => v
  | Assign x e => v $+ (x, interp e v)
  | Sequence c1 c2 => exec c2 (exec c1 v)
  | Repeat e body => selfCompose (exec body) (interp e v) v
  end.

(* Let's define some programs and prove that they operate in certain ways. *)

Example factorial_ugly :=
  Sequence
    (Assign "output" (Const 1))
    (Repeat (Var "input")
            (Sequence
               (Assign "output" (Times (Var "output") (Var "input")))
               (Assign "input" (Minus (Var "input") (Const 1))))).

(* Ouch; that code is hard to read.  Let's introduce some notations to make the
 * concrete syntax more palatable.  We won't explain the general mechanisms on
 * display here, but see the Coq manual for details, or try to reverse-engineer
 * them from our examples. *)
Coercion Const : nat >-> arith.
Coercion Var : var >-> arith.
(*Declare Scope arith_scope.*)
Infix "+" := Plus : arith_scope.
Infix "-" := Minus : arith_scope.
Infix "*" := Times : arith_scope.
Delimit Scope arith_scope with arith.
Notation "x <- e" := (Assign x e%arith) (at level 75).
Infix ";" := Sequence (at level 76).
Notation "'repeat' e 'doing' body 'done'" := (Repeat e%arith body) (at level 75).

(* OK, let's try that program again. *)
Example factorial :=
  "output" <- 1;
  repeat "input" doing
    "output" <- "output" * "input";
    "input" <- "input" - 1
  done.

(* Now we prove that it really computes factorial.
 * First, a reference implementation as a functional program. *)
Fixpoint fact (n : nat) : nat :=
  match n with
  | O => 1
  | S n' => n * fact n'
  end.

(* To prove that [factorial] is correct, the real action is in a lemma, to be
 * proved by induction, showing that the loop works correctly.  So, let's first
 * assign a name to the loop body alone. *)
Definition factorial_body :=
  "output" <- "output" * "input";
  "input" <- "input" - 1.

(* Now for that lemma: self-composition of the body's semantics produces the
 * expected changes in the valuation.
 * Note that here we're careful to put the quantified variable [input] *first*,
 * because the variables coming after it will need to *change* in the course of
 * the induction.  Try switching the order to see what goes wrong if we put
 * [input] later. *)
Lemma factorial_ok' : forall input output v,
  v $? "input" = Some input
  -> v $? "output" = Some output
  -> selfCompose (exec factorial_body) input v
     = v $+ ("input", 0) $+ ("output", output * fact input).
Proof.
  induct input; simplify.

  maps_equal.
  (* [maps_equal]: prove that two finite maps are equal by considering all
   *   the relevant cases for mappings of different keys. *)

  rewrite H0.
  f_equal.
  linear_arithmetic.

  trivial.
  (* [trivial]: Coq maintains a database of simple proof steps, such as proving
   *   a fact by direct appeal to a matching hypothesis.  [trivial] asks to try
   *   all such simple steps. *)

  rewrite H, H0.
  (* Note the two arguments to one [rewrite]! *)
  rewrite (IHinput (output * S input)).
  (* Note the careful choice of a quantifier instantiation for the IH! *)
  maps_equal.
  f_equal; ring.
  simplify; f_equal; linear_arithmetic.
  simplify; equality.
Qed.

(* Finally, we have the natural correctness condition for factorial as a whole
 * program. *)
Theorem factorial_ok : forall v input,
  v $? "input" = Some input
  -> exec factorial v $? "output" = Some (fact input).
Proof.
  simplify.
  rewrite H.
  rewrite (factorial_ok' input 1); simplify.
  f_equal; linear_arithmetic.
  trivial.
  trivial.
Qed.

(* One last example: let's try to do loop unrolling, for constant iteration
 * counts.  That is, we can duplicate the loop body instead of using an explicit
 * loop. *)

Fixpoint seqself (c : cmd) (n : nat) : cmd :=
  match n with
  | O => Skip
  | S n' => Sequence c (seqself c n')
  end.

Fixpoint unroll (c : cmd) : cmd :=
  match c with
  | Skip => c
  | Assign _ _ => c
  | Sequence c1 c2 => Sequence (unroll c1) (unroll c2)
  | Repeat (Const n) c1 => seqself (unroll c1) n
  (* ^-- the crucial case! *)
  | Repeat e c1 => Repeat e (unroll c1)
  end.

(* This obvious-sounding fact will come in handy: self-composition gives the
 * same result, when passed two functions that map equal inputs to equal
 * outputs. *)
Lemma selfCompose_extensional : forall {A} (f g : A -> A) n x,
  (forall y, f y = g y)
  -> selfCompose f n x = selfCompose g n x.
Proof.
  induct n; simplify; try equality.

  rewrite H.
  apply IHn.
  trivial.
Qed.

(* Crucial lemma: [seqself] is acting just like [selfCompose], in a suitable
 * sense. *)
Lemma seqself_ok : forall c n v,
  exec (seqself c n) v = selfCompose (exec c) n v.
Proof.
  induct n; simplify; equality.
Qed.

(* The two lemmas we just proved are the main ingredients to prove the natural
 * correctness condition for [unroll]. *)
Theorem unroll_ok : forall c v, exec (unroll c) v = exec c v.
Proof.
  induct c; simplify; try equality.

  cases e; simplify; try equality.

  rewrite seqself_ok.
  apply selfCompose_extensional.
  trivial.

  apply selfCompose_extensional.
  trivial.

  apply selfCompose_extensional.
  trivial.

  apply selfCompose_extensional.
  trivial.

  apply selfCompose_extensional.
  trivial.
Qed.


(** * The calculus of (co)inductive constructions *)

(** ** Abstraction *)

(** The calculus used in Coq is based on the calculus of constructions (CoC)
    %[%#[#Coquand, Huet, '88#]#%]% with the addition of several later extensions
    such as an infinite hierarchy of types %[%#[#Luo, '89#]#%]%, inductively
    defined data types %[%#[#Pfenning, Paulin-Morhing, '88#]#%]% and
    co-inductively defined data types %[%#[#Giménez, 95#]#%]%.

    The CoC is a higher-order typed lambda calculus. It sits at the
    top of the "Lambda cube", as it allows all 4 forms of abstraction.

    The first type of abstraction is simply lambda-abstraction,
    i.e. values depending on values.*)

Definition add_two := fun (x : nat) => x + 2.

Check add_two.

(** Another type of abstraction is polymorphism, with which we can
    define values depending on types. *)

Definition id := fun (A : Type) (x : A) => x.

Check id.

(** Type operators offer a third form of abstraction, which allows
    defining types that depend on types. *)

Definition arrow := fun (A B : Type) => A -> B.

Check arrow.

(** The last form of abstraction is dependent types, or types whose
    definition depends on values. *)

Definition arrow_n :=
  fun (A : Type) =>
    fix F (n : nat) :=
    match n with
    | 0 => A
    | S n' => arrow A (F n')
    end.

Compute (arrow_n bool 3).

Check arrow_n.

(* begin hide *)
Import Nat.
(* end hide *)

(** ** Terms and types *)

(** In fact, in the CoC there is no real distinction between values and
    types.

    - At the lowest level, there are concrete values (e.g. [O], [true]...)
      and programs ([add], [negb]...)

    - The types of these terms ([nat], [bool], [nat -> nat -> nat], [bool -> bool]...) are
      also terms themselves. This means that they can be passed as
      arguments to functions and be used in the definition of a type. It
      also means that they have a type themselves. *)

(** We can keep checking the types upward. *)

Check 0.

Check nat.

Check Set.

Check Type.

(** This last answer should be surprising. It is known that this kind
    of typing results in an inconsistent system, for reasons similar
    to Russell's paradox in naive set theory (this is called Girard's
    paradox and is not quite as easy to exhibit as Russell's).

    Coq actually hides some technical details when it comes to printing
    [Type]. These can be reactivated. *)

Set Printing Universes.

Check Set.

Check Type.

(** We now see that [Type] actually stands for an infinite hierarchy of
    types, thus preventing Girard's paradox. Each occurrence of [Type] is
    called a universe. Conveniently, any universe of rank <<i>> also has
    rank <<j>> for any <<j > i>> (so, for example, [Set] has the type [Type@{i}] for
    any <<i>>). *)

Unset Printing Universes.

(** ** Terms in the CoC *)

(** Let us take a look at the different ways to form terms. *)

(** First we fix some constants. *)
Axiom A : Set.

Axiom B : Set.

(** We can form terms by lambda abstraction. *)
Definition lambda := fun (x : A) => B.

(** This next construct is called product. This becomes a bit
    confusing later when we'll add inductively defined data types and
    the more common notion of product type. *)
Definition product := forall (x : A), B.

(** We fix another constant of the proper type to form a term by
    application. *)
Axiom a : A.

Definition application := lambda a.

(** Note that [A -> B] is actually equivalent to [forall (_ : A), B]. *)

(** In this definition, the second lambda is dependent on [P]. Observe
    the type. *)

Check fun (P : Set) (x : P) => x.

(** In this second definition, [P] is not used in the second
    lambda. This results in a simpler type, using [->] instead of
    [forall]. *)

Check fun (P : Set) (x : A) => x.

(** These rules (constant, abstraction, product, application) are the
    only ones on which to build terms in the original calculus of
    constructions. *)

(** ** Inductively defined types *)

(** While it is possible to define a higher-order logic with only
    these rules, the addition of inductively defined data types is a
    useful feature. *)

(** Here is an example of an inductive data type. *)

Inductive vector (T : Type) : nat -> Type :=
| vnil : vector T 0
| vcons : forall n, T -> vector T n -> vector T (S n).

(** There is a slight difference between the two arguments of the type
    [vector A n]: The argument [A] has the same value in the return type
    of all the constructors. This is sometimes called an "inductive
    parameter". The value of the second argument varies across
    different constructors: [O] for [vnil], [S n] for [vcons]. This is
    sometimes called a "real argument".

    An inductive parameter can be turned into a real argument:

[[
Inductive vector : Type -> nat -> Type :=
| vnil : forall T, vector T 0
| vcons : forall n T, T -> vector T n -> vector T (S n).
]]

    But a real argument cannot in general be replaced by an inductive
    parameter. *)

(** Values from inductively defined data types can be manipulated by
    pattern matching. *)

Fixpoint vapp (A : Type) (n m : nat) (v1 : vector A n) (v2 : vector A m) : vector A (n + m) :=
  match v1 with
  | vnil _ => v2
  | vcons _ _ x v' => vcons _ _ x (vapp _ _ _ v' v2)
  end.

(** ** Programs and proofs *)

(** For a more eloquent presentation of the Curry-Howard
    correspondence, see %[%#[#Wadler, 15%]%#]#. *)

(** [x : T] is usually understood as "[x] has type [T]", but it can also be
    understood as "[x] is a proof of [T]". *)

(** [A -> B] is the type of functions from [A] to [B] but also reads as "[A]
    implies [B]". Indeed, a proof of [A -> B] must be a program that takes
    a proof of [A] as input and produce a proof of [B] as output. *)

(** Logical connectives (other than [forall]/[->]) can be defined
    inductively. *)

(** Conjunction corresponds to product type (using the usual
    definition of product here). *)
Inductive and (A B : Prop) : Prop :=
| conj : A -> B -> and A B.

Arguments conj {_ _} _ _.

(** Disjunction corresponds to sum. *)
Inductive or (A B : Prop) : Prop :=
| disj_l : A -> or A B
| disj_r : B -> or A B.

Arguments disj_l {_ _} _.
Arguments disj_r {_ _} _.

(** [False] is the empty type, the type for which there exists no
    inhabitant/proof. *)
Inductive False :=.

(** For [True], any inhabited type will do, so the unit type is as good as any. *)
Inductive True :=
| unit : True.

(** ** Tactics and proof terms *)

(** So far we have written terms only when we needed functions, and
    used tactics to build proofs. But tactics are just a convenient
    mechanism to build terms. We can write proof terms directly (or
    more unusually, use tactics to build a function over small
    types).*)

Lemma and_comm (A B : Prop) : and A B -> and B A.
Proof.
  (* We must provide a term of type [A /\ B -> B /\ A], it seems that
     this term should be a function with one argument of type [A /\ B],
     although we don't really know what the body the function is going
     to look like. The tactic [intro] builds that lambda-abstraction for
     us, leaving a hole where the body of the function is. *)
  intros.
  Show Proof.
  (* We now have an element of type [A /\ B] in the context (the
     argument of the lambda abstraction, and we must build a term of
     type [B /\ A]. One way to construct this term is to pattern-match
     something in context, and later provide a term of type [A /\ B] for
     every match. [destruct H] creates this pattern matching over [H],
     leaving a hole in each branch. *)
  destruct H.
  (* The type [and A B] of [H] has only one constructor with two
     arguments of type [A] and [B]. Therefore, we are now in a context with
     two terms [H : A] and [H0 : B]. *)
  Show Proof.
  (* There is only one constructor for the type [and B A], so we apply
     it. After that we have to fill two holes, corresponding to the
     two arguments of the constructor. *)
  apply conj.
  Show Proof.
  (* For the next two holes, we have terms of the needed type in
     context, so we can use them directly using [exact]. *)
  - exact H0.
  - exact H.
Qed.

Print and_comm.

(** The tactic [refine] is a more general version of [exact]. Instead of a
    fully-formed term, it lets us put a term with holes (of course the
    type of this term must unify with the expected type of the
    hole). We can fill each hole later.

    This script emulates the action of the previous tactics, using
    only refine. *)
Lemma and_comm' (A B : Prop) : and A B -> and B A.
Proof.
  refine (fun H => _).
  refine (match H with conj H H0 => _ end).
  refine (conj _ _).
  - refine H0. (* without holes, this is identical to 'exact H0'*)
  - refine H.
Qed.

(** ** Equality *)

(** Here is the definition of the equality [Prop].

[[
Inductive eq (T : Type) (x : T) : T -> Prop :=
| eq_refl : eq T x x.
]]

    This definition says that [eq T x y] holds only if [x] and [y] are
    equivalent terms. On the meta-level, two terms are considered
    equivalent if they have identical normal forms.

    For example [0 + (0 + (0 + n))] is equivalent to [n]. However [n + 0] does
    not normalize to [n], so it is not considered equivalent. *)

(** ** Inductive proofs *)

(** Proofs by induction correspond naturally to recursive functions. *)

(** Let us write an induction proof, separating the two steps. *)
Definition base_case : forall (n m : nat), 0 + n + m = 0 + (n + m) :=
  fun (n m : nat) => eq_refl.

(** Proofs involving equational reasoning are not fun to write by
    hand, let's use tactics for now. *)
Lemma ind_step : forall (n m p : nat), n + m + p = n + (m + p) -> S n + m + p = S n + (m + p).
Proof.
  intros. simpl. rewrite <- H. apply eq_refl.
Qed.

Lemma add_assoc : forall (n m p : nat), n + m + p = n + (m + p).
Proof.
  intros. induction n as [| n'].
  - exact (base_case m p).
  - exact (ind_step n' m p IHn').
Qed.

Definition add_assoc' : forall (n m p : nat), n + m + p = n + (m + p) :=
  fix F (n m p : nat) :=
    match n with
    | O => base_case m p
    | S n' => ind_step n' m p (F n' m p)
    end.

(** If you print the proof term created by the script, you will see
    that [induction] actually applies [nat_ind], the induction principle
    generated at the same time as [nat] was declared, rather than
    building a recursive function from the ground up. *)

Print add_assoc.

(** But it is important to note that [nat_ind] is not an axiom, just a
    simple function that we could define ourselves, if Coq didn't do
    it automatically (actually, [nat_ind] is defined with [nat_rect], so
    let us print that instead). *)

Print nat_rect.

(** Every inductively defined type has its associated induction
    principle. *)

(** We mentioned equality reasoning earlier. Equality reasoning is
    based on the induction generated from the [eq] type. *)

Print eq_rect.

(** Here are some useful lemmas/functions if you want to write
    equational proofs. *)
Print eq_ind.
Print eq_sym.
Print eq_ind_r.

(** However, be advised that the resulting proof terms are not particularly
    pretty. *)
Print ind_step.

(** ** Prop vs Set *)

(** We found the lowest universe by checking the type of [Set]. There is
    another native sort which lives in [Type@{0}], named [Prop]. Although
    [Prop] and [Set] share the same universe, there are some important
    differences between the two.

    Prop is often described as the type of proof-irrelevant
    propositions. What this means is that for a given proposition of
    type [Prop] (e.g. [forall (P Q : Prop), P /\ Q -> Q /\ P]), we don't
    really care about specific elements of this type (different
    proofs). The existence or non-existence of a proof matters, but
    the specifics of a given proof can usually be ignored.

    In contrast, for types in [Set] (so-called small types, such as
    [bool], [nat -> nat -> nat]...), we tend to care about the specifics of
    the elements that implement the type: [true] is different from
    [false], [mult] from [add]....

    This distinction is useful when using the code extraction feature
    of Coq: Objects in [Set] can be extracted to OCaml/Haskell/Scheme
    while elements of [Prop] are left aside.

    One important difference is that [Prop] is impredicative. Concretely,
    this means that a term formed by quantification over [Prop] can
    itself be in [Prop]. *)

Check forall (P Q : Prop), ((P -> Q) -> P) -> P.

(** On the other hand, a term quantifying over [Set] has to live in the
    next universe. *)

Check forall (P Q : Set), ((P -> Q) -> P) -> P.

(** ** Elimination and impredicativity *)

(** An impredicative universe seems more expressive, but it comes with
    its own risks. Unrestricted impredicativity leads to
    inconsistency, therefore Coq must put some restrictions on
    elimination (pattern matching) over [Prop]. *)

Inductive ex {T : Type} (P : T -> Prop) : Prop :=
  ex_intro : forall (t : T), P t -> ex P.

(** [exists (x : T), P]      [ex T (fun x => P x)] *)

(** The following definition is forbidden because it attempts to
    eliminate a term whose type is [Prop] in the higher context [Type].

[[
Definition witness_prop {T : Type} {P : T -> Prop} (H : ex P) : T :=
  match H with
  | ex_intro _ t _ => t
  end.
]]

    However, it is possible to eliminate a proof to produce a proof.

    The next [Prop] describes types that are inhabited (have at least
    one element). *)

Inductive inhabited (T : Type) : Prop :=
  inhabits : T -> inhabited T.

(** The next lemma indicates that if we have a proof of some
    existentially quantified property over a type [T], this type must be
    inhabited. *)

(** The proof can be constructed by elimination on the proof [destruct
    H]. *)

Lemma exists_inhabited : forall (T : Type) (P : T -> Prop),
    ex P -> inhabited T.
Proof.
  intros. destruct H. apply inhabits. exact t.
Qed.

(** Or equivalently, here is the proof term, which pattern-matches the
    proof. *)

Definition exists_inhabited' : forall (T : Type) (P : T -> Prop), ex P -> inhabited T :=
  fun (T : Type) (P : T -> Prop) (H : ex P) =>
    match H with
    | ex_intro _ t _ => inhabits _ t
    end.

(** Let us now define a type that is very similar to [ex], except that
    it doesn't live in [Prop].

    Instead of being a proof that some element verifies a property [P],
    an element of type [sig P] is usually understood as being the set
    of elements that verifies [P]. *)

Inductive sig {T : Type} (P : T -> Prop) : Type :=
  sig_intro : forall (t : T), P t -> sig P.

(** The following function, similar to [witness], extracts a member from
    a type [sig P]. The definition can pattern-match [S] without
    restriction since [sig P] is not in [Prop]. *)

Definition member {T : Type} {P : T -> Prop} (S : sig P) : T :=
  match S with
  | sig_intro _ t _ => t
  end.


(* La librairie strandard est décrite ici

   https://coq.inria.fr/distrib/current/stdlib/

*)

Require Import List. (* Voir https://coq.inria.fr/distrib/current/stdlib/Coq.Lists.List.html *)

Reserved Notation "x '~p' y" (at level 70, no associativity).

Section list_perm.

  Variable X : Type.

  Inductive perm : list X -> list X -> Prop :=

    | perm_nil   :                    nil ~p nil

    | perm_cons  : forall x l1 l2,     l1 ~p l2
                               ->   x::l1 ~p x::l2

    | perm_swap  : forall x y l,  x::y::l ~p y::x::l

    | perm_trans : forall l1 l2 l3,    l1 ~p l2
                               ->      l2 ~p l3
                               ->      l1 ~p l3

  where "x '~p' y " := (perm x y).

  Fact perm_refl l : l ~p l.
  Proof.
  Admitted.

  Fact perm_length l1 l2 : l1 ~p l2 -> length l1 = length l2.
  Proof.
    intros H.
    induction H as [
                   | x l1 l2 H1 IH1
                   | x y l
                   | l1 l2 l3 H1 IH1 H2 IH2
                   ].
  Admitted.

  Fact perm_sym l1 l2 : l1 ~p l2 -> l2 ~p l1.
  Proof.
  Admitted.

  Fact perm_middle x l r : x::l++r ~p l++x::r.
  Proof.
    induction l as [ | y l IHl ]; simpl.
  Admitted.

  Let perm_app_left l r1 r2 : r1 ~p r2 -> l++r1 ~p l++r2.
  Proof.
    intros H.
    induction l; simpl.
  Admitted.

  Fact perm_app l1 l2 r1 r2 : l1 ~p l2 -> r1 ~p r2 -> l1++r1 ~p l2++r2.
  Proof.
    intros H; revert H r1 r2.
    intros H.
    induction H as [
                   | x l1 l2 H1 IH1
                   | x y l
                   | l1 l2 l3 H1 IH1 H2 IH2
                   ].
  Admitted.

  (* incl est défini dans la librairie standard, fichier List.v *)

  Print incl.

  Fact perm_incl l m : l ~p m -> incl l m.
  Proof.
    intros H.
    induction H as [
                   | x l1 l2 H1 IH1
                   | x y l
                   | l1 l2 l3 H1 IH1 H2 IH2
                   ]; simpl; auto.
  Admitted.

End list_perm.

Infix "~p" := (perm _) (at level 70, no associativity).