Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e256m189_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Annexes.perp_bisect.

Section thales_converse_postulate_weak_triangle_circumscription_principle.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma thales_converse_postulate__weak_triangle_circumscription_principle :
  thales_converse_postulate -> weak_triangle_circumscription_principle.
Proof.
intros HP A B C A1 A2 B1 B2 HNC HPer HPerpB1 HPerpB2 HCop1 HCop2 HCop3 HCop4.
destruct (midpoint_existence A B) as [M HM]; exists M;
assert (H := HP A B C M HNC HM HPer); split;
[apply cong_cop2_perp_bisect_col with B C|
 apply cong_cop2_perp_bisect_col with A C]; Cong;
[| |destruct HM as [_ HM]; apply cong_transitivity with M A; Cong| |];
apply coplanar_perm_3, col2_cop__cop with A B; assert_diffs; Col; Cop.
Qed.

End thales_converse_postulate_weak_triangle_circumscription_principle.


(* author: Dimitur Krustev *)
(* (re-)started: 20150503 *)

(* Finite Test Sets for a Class of Simple Programs on Binary Trees *)

Require Import List Arith.
Require Import Eqdep Eqdep_dec.
Require Fin.

(* Some utility definitions/lemmas missing from Coq's stdlib: *)

Definition optBind {X Y} (o: option X) (f: X -> option Y) : option Y :=
  match o with
  | None => None
  | Some x => f x
  end.

Definition option_eq_dec {X} (X_eq_dec: forall x y: X, {x = y} + {x <> y}) :
  forall x y: option X, {x = y} + {x <> y}.
  decide equality.
Defined.

Lemma optBind_optBind: forall A B C (f1: A -> option B) (f2: B -> option C) x,
  optBind (optBind x f1) f2 = optBind x (fun y => optBind (f1 y) f2).
Proof.
  destruct x; auto.
Qed.

Lemma optBind_option_map: forall X Y Z (f: X -> Y) (o: option X) (g: Y -> option Z),
  optBind (option_map f o) g = optBind o (fun x => g (f x)).
Proof.
  destruct o; auto.
Qed.

Lemma option_map_optBind: forall X Y Z (f: Y -> Z) (o: option X) (g: X -> option Y),
  option_map f (optBind o g) = optBind o (fun x => option_map f (g x)).
Proof.
  destruct o; auto.
Qed.

Lemma optBind_extEq: forall X Y (f g: X -> option Y) x,
  (forall x, f x = g x) -> optBind x f = optBind x g.
Proof.
  destruct x; auto. intros. simpl. auto.
Qed.

(*
Lemma optBind_neq_funEq: forall X Y (o1 o2: option X) (f: X -> option Y),
  optBind o1 f <> optBind o2 f -> o1 <> o2.
Proof.
  destruct o1; destruct o2; simpl; congruence.
Qed.
*)

(* *** *)

(*
Definition finTryCast {n} (i: Fin.t n) : forall m, option (Fin.t m).
  induction i.
  - destruct m.
    + exact None.
    + exact (Some Fin.F1).
  - destruct m.
    + exact None.
    + destruct (IHi m).
      * rename t into j. exact (Some (Fin.FS j)).
      * exact None.
Defined.
*)

Definition finSplitLR {n m} (i: Fin.t (n + m)) : Fin.t n + Fin.t m.
  revert m i. induction n.
  - simpl. intros. right. exact i.
  - simpl. intros. remember (S (n + m)) as snm. destruct i.
    + left. exact Fin.F1.
    + injection Heqsnm. intro Heq. subst n0. clear Heqsnm. destruct (IHn m i) as [j | j].
      * left. exact (Fin.FS j).
      * right. exact j.
Defined.

Lemma finSplitLR_FinL: forall n (i: Fin.t n) m, finSplitLR (Fin.L m i) = inl i.
Proof.
  induction i; auto.
  simpl. intros. unfold eq_rec_r, eq_rec, eq_sym. simpl.
  rewrite IHi. reflexivity.
Qed.

Lemma finSplitLR_FinR: forall m (i: Fin.t m) n, finSplitLR (Fin.R n i) = inr i.
Proof.
  intros.  revert m i. induction n; auto.
  simpl. intros. unfold eq_rec_r, eq_rec, eq_sym. simpl.
  rewrite IHn. reflexivity.
Qed.

Definition Fin_eq_dep_dec: forall {m n} (x: Fin.t m) (y: Fin.t n),
  {eq_dep nat Fin.t m x n y} + {~eq_dep nat Fin.t m x n y}.
  intros m n x. revert n.
  induction x as [m | m x1 IHx1];
    destruct y as [n | n y1];
    try solve [right; intro H; inversion H].
  (* F1, F1 *) destruct (eq_nat_dec m n) as [Heq | Hneq].
    (* m = n *) subst n. left. reflexivity.
    (* m <> n *) right. intro H. apply Hneq. inversion H. reflexivity.
  (* fs, fs *) destruct (IHx1 n y1) as [Heq | Hneq].
    (* left *) left. inversion Heq. reflexivity.
    (* right *) right. intro H. apply Hneq. inversion H. reflexivity.
Defined.

Definition Fin_eq_dec: forall {n} (f1 f2: Fin.t n), {f1 = f2} + {f1 <> f2}.
  intros. destruct (Fin_eq_dep_dec f1 f2) as [Heq | Hneq].
  (* left *) left. apply (eq_dep_eq_dec eq_nat_dec). assumption.
  (* right *) right. intro H. apply Hneq. rewrite H. reflexivity.
Defined.

(* *** *)
(* The value domain of unlabeled binary trees: *)

Inductive Val: Set := VNil | VCons (hd tl: Val).

Fixpoint valDepth (v: Val) {struct v} : nat :=
  match v with
  | VCons v1 v2 => S (max (valDepth v1) (valDepth v2))
  | _ => 0
  end.

Definition Val_eq_dec: forall x y: Val, {x = y} + {x <> y}.
  decide equality.
Defined.

(* *** *)
(* Normal form of simple programs on binary trees and its evaluation: *)

Inductive Selector: Set := HD | TL.

Fixpoint scEval (sc: list Selector) (v: Val) {struct sc} : option Val :=
  match sc with
  | nil => Some v
  | sel::sc => match v with
    | VNil => None
    | VCons vh vt => match sel with
      | HD => scEval sc vh
      | TL => scEval sc vt
      end
    end
  end.

Inductive NTrm: Set :=
  | NNil: NTrm
  | NCons: NTrm -> NTrm -> NTrm
  | NSelCmp: list Selector -> NTrm
  | NIfNil: list Selector -> NTrm -> NTrm -> NTrm.

Fixpoint ntEval (t: NTrm) (v: Val) {struct t} : option Val :=
  match t with
  | NNil => Some VNil
  | NCons t1 t2 => optBind (ntEval t1 v) (fun v1 =>
      optBind (ntEval t2 v) (fun v2 => Some (VCons v1 v2)))
  | NSelCmp sc => scEval sc v
  | NIfNil sc t1 t2 => match scEval sc v with
    | None => None
    | Some VNil => ntEval t1 v
    | Some (VCons _ _) => ntEval t2 v
    end
  end.

Fixpoint ntMaxSelCmpLen (nt: NTrm) {struct nt} : nat :=
  match nt with
  | NCons nt1 nt2 => max (ntMaxSelCmpLen nt1) (ntMaxSelCmpLen nt2)
  | NSelCmp sels => length sels
  | NIfNil sels nt1 nt2 => max (S (length sels)) (max (ntMaxSelCmpLen nt1) (ntMaxSelCmpLen nt2))
  | _ => 0
  end.

(* *** *)
(* Binary trees with holes (represented by variables): *)

Inductive MVal: nat -> Set :=
  | MVNil: forall n, MVal n
  | MVVar: forall n, Fin.t n -> MVal n
  | MVCons: forall n, MVal n -> MVal n -> MVal n.

Implicit Arguments MVNil [n].
Implicit Arguments MVVar [n].
Implicit Arguments MVCons [n].

Definition Subst (n: nat) := Fin.t n -> Val.

Fixpoint mvSubstFlipped {n: nat} (t: MVal n) {struct t} : Subst n -> Val :=
  match t with
  | MVNil _ => fun _ => VNil
  | MVVar _ i => fun s => s i
  | MVCons _ t1 t2 => fun s => VCons (mvSubstFlipped t1 s) (mvSubstFlipped t2 s)
  end.

Definition mvSubst {n: nat} (s: Subst n) (t: MVal n) := mvSubstFlipped t s.

Fixpoint mvDepth {n} (mv: MVal n) {struct mv} : nat :=
  match mv with
  | MVCons _ mv1 mv2 => S (max (mvDepth mv1) (mvDepth mv2))
  | _ => 0
  end.

Fixpoint mvMinVarDepth {n} (mv: MVal n) : option nat :=
  match mv with
  | MVNil _ => None
  | MVVar _ _ => Some 0
  | MVCons _ mv1 mv2 =>
    match mvMinVarDepth mv1, mvMinVarDepth mv2 with
    | None, None => None
    | Some d, None => Some (S d)
    | None, Some d => Some (S d)
    | Some d1, Some d2 => Some (S (min d1 d2))
    end
  end.

Definition mvCast {n} (m: nat) (mv: MVal n) : MVal (n + m).
  revert m. induction mv.
  - intro m. exact MVNil.
  - rename t into i. intro m. exact (MVVar (Fin.L m i)).
  - intro m. exact (MVCons (IHmv1 m) (IHmv2 m)).
Defined.

Definition mvShift {m} (n: nat) (mv: MVal m) : MVal (n + m).
  revert n. induction mv.
  - rename n into m. intro n. exact MVNil.
  - rename n into m. rename t into i. intro n. exact (MVVar (Fin.R n i)).
  - rename n into m. intro n. exact (MVCons (IHmv1 n) (IHmv2 n)).
Defined.

Definition MVal_eq_dep_dec {m n}: forall (x: MVal m) (y: MVal n),
  {eq_dep nat MVal m x n y} + {~eq_dep nat MVal m x n y}.
  intro x. revert n.
  induction x; destruct y; try solve [right; intro H; inversion H].
  - (* MVNil n, MVNil n0 *) destruct (eq_nat_dec n n0) as [Heq | Hneq].
    + left. subst n0. reflexivity.
    + right. intro H. apply Hneq. destruct H. reflexivity.
  - rename n into m. rename t into i. rename n0 into n. rename t0 into j.
    (* MVVar m i, MVVar n j *) destruct (Fin_eq_dep_dec i j) as [Heq | Hneq].
    + left. destruct Heq. reflexivity.
    + right. intro H. apply Hneq. inversion H. reflexivity.
  - (* MVCons n x1 x2, MVCons n0 y1 y2 *)
    destruct (IHx1 n0 y1) as [Heq1 | Hneq1].
    + destruct (IHx2 n0 y2) as [Heq2 | Hneq2].
      * left. destruct Heq1. apply (eq_dep_eq_dec eq_nat_dec) in Heq2.
        subst. reflexivity.
      * right. intro H. apply Hneq2. inversion H. reflexivity.
    + right. intro H. apply Hneq1. inversion H. subst.
      apply (inj_pair2_eq_dec _ eq_nat_dec) in H4. subst. reflexivity.
Defined.

(* Print Assumptions MVal_eq_dep_dec. *)

Definition MVal_eq_dec {n}: forall x y: MVal n, {x = y} + {x <> y}.
  intros. destruct (MVal_eq_dep_dec x y) as [Heq | Hneq].
  - left. apply (eq_dep_eq_dec eq_nat_dec) in Heq. assumption.
  - right. intro H. apply Hneq. subst. reflexivity.
Defined.

Lemma mvDepth_mvCast: forall n (mv: MVal n) m,
  mvDepth (mvCast m mv) = mvDepth mv.
Proof.
  induction mv; auto.
  simpl. intros. rewrite IHmv1. rewrite IHmv2. reflexivity.
Qed.

Lemma mvDepth_mvShift: forall m (mv: MVal m) n,
  mvDepth (mvShift n mv) = mvDepth mv.
Proof.
  induction mv; auto.
  simpl. intros. rewrite IHmv1. rewrite IHmv2. reflexivity.
Qed.

Lemma mvMinVarDepth_mvCast: forall n (mv: MVal n) m,
  mvMinVarDepth (mvCast m mv) = mvMinVarDepth mv.
Proof.
  induction mv; auto.
  simpl. intros. rewrite IHmv1. rewrite IHmv2. reflexivity.
Qed.

Lemma mvMinVarDepth_mvShift: forall m (mv: MVal m) n,
  mvMinVarDepth (mvShift n mv) = mvMinVarDepth mv.
Proof.
  induction mv; auto.
  simpl. intros. rewrite IHmv1. rewrite IHmv2. reflexivity.
Qed.

Lemma valDepth_mvSubst_le: forall n (mv: MVal n) s d,
  (forall i, valDepth (s i) <= d) -> valDepth (mvSubst s mv) <= d + mvDepth mv.
Proof.
  induction mv; auto with arith.
  - rename t into i.
    (* MVVar i *) simpl. intros. rewrite <- plus_n_O. auto.
  - (* MVCons mv1 mv2 *) simpl. intros.
    rewrite <- plus_n_Sm. apply le_n_S.
    apply NPeano.Nat.max_lub.
    + transitivity (d + mvDepth mv1); auto with arith.
    + transitivity (d + mvDepth mv2); auto with arith.
Qed.

(* *** *)
(* A key testing lemma for binary trees with holes: *)

Lemma mvSubst_discrim: forall n (mv1 mv2: MVal n), mv1 <> mv2 -> exists s,
  (forall i, valDepth (s i) <= 1) /\ mvSubst s mv1 <> mvSubst s mv2.
Proof.
  induction mv1; destruct mv2; try congruence; auto.
  - rename t into i.
    (* MVNil, MVVar i *) simpl. intros.
    exists (fun j => if Fin_eq_dec i j then VCons VNil VNil else VNil).
    split.
    + intro j. destruct (Fin_eq_dec i j); auto.
    + destruct (Fin_eq_dec i i); congruence.
  - (* MVNil, MVCons mv2_1 mv2_2 *) simpl. intros.
    exists (fun j => VNil). split; try congruence; auto.
  - rename t into i.
    (* MVVar i, MVNil *) simpl. intros.
    exists (fun j => if Fin_eq_dec i j then VCons VNil VNil else VNil).
    split.
    + intro j. destruct (Fin_eq_dec i j); auto.
    + destruct (Fin_eq_dec i i); congruence.
  - rename t into i. rename t0 into j.
    (* MVVar i, MVVar j *) simpl. intros.
    exists (fun k => if Fin_eq_dec k i then VCons VNil VNil else VNil).
    split.
    + intro k. destruct (Fin_eq_dec k i); auto.
    + destruct (Fin_eq_dec i i); destruct (Fin_eq_dec j i); congruence.
  - rename t into i.
    (* MVVar i, MVCons mv2_1 mv2_2 *) simpl. intros.
    exists (fun j => if Fin_eq_dec i j then VNil else VCons VNil VNil).
    split.
    + intro j. destruct (Fin_eq_dec i j); auto.
    + destruct (Fin_eq_dec i i); congruence.
  - (* MVCons mv1_1 mv1_2, MVNil *) simpl. intros.
    exists (fun j => VNil). split; try congruence; auto.
  - rename t into i.
    (* MVCons mv1_1 mv1_2, MVVar i *) simpl. intros.
    exists (fun j => if Fin_eq_dec i j then VNil else VCons VNil VNil).
    split.
    + intro j. destruct (Fin_eq_dec i j); auto.
    + destruct (Fin_eq_dec i i); congruence.
  - (* MVCons mv1_1 mv1_2, MVCons mv2_1 mv2_2 *) simpl. intros.
    destruct (MVal_eq_dec mv1_1 mv2_1) as [Heq1 | Hneq1].
    + subst. destruct (MVal_eq_dec mv1_2 mv2_2) as [Heq2 | Hneq2]; try congruence.
      specialize (IHmv1_2 mv2_2 Hneq2). destruct IHmv1_2 as [s [Hdepth Hneq3]].
      exists s. split; auto.
      congruence.
    + specialize (IHmv1_1 mv2_1 Hneq1). destruct IHmv1_1 as [s [Hdepth Hneq2]].
      exists s. split; auto.
      congruence.
Qed.

(* *** *)
(* Normal-form evaluator extended to operate on trees with holes: *)

Fixpoint scmvEval (sc: list Selector) : forall {n}, MVal n -> option (MVal n) :=
  match sc with
  | nil => fun _ mv => Some mv
  | sel::sc => fun _ mv => match mv with
    | MVNil _ => None
    | MVVar _ _ => None
    | MVCons _ mv1 mv2 => match sel with
      | HD => scmvEval sc mv1
      | TL => scmvEval sc mv2
      end
    end
  end.

Fixpoint ntmvEval (t: NTrm) {struct t} : forall {n}, MVal n -> option (MVal n) :=
  match t with
  | NNil => fun _ _ => Some MVNil
  | NCons t1 t2 => fun _ mv => optBind (ntmvEval t1 mv) (fun mv1 =>
      optBind (ntmvEval t2 mv) (fun mv2 => Some (MVCons mv1 mv2)))
  | NSelCmp sc => fun _ mv => scmvEval sc mv
  | NIfNil sc t1 t2 => fun _ mv => match scmvEval sc mv with
    | None => None
    | Some (MVVar _ _) => None
    | Some (MVNil _) => ntmvEval t1 mv
    | Some (MVCons _ _ _) => ntmvEval t2 mv
    end
  end.

Definition mvSubst' {n} (s: Subst n) (omv: option (MVal n)) : option Val :=
  option_map (mvSubst s) omv.

(* *** *)
(* Key lemmas about commuting (extended) evaluation and hole-filling
  when selector-composition length <= min hole depth: *)

Lemma scmvEval_scEval: forall (sc: list Selector) n (s: Subst n) (mv: MVal n),
  match mvMinVarDepth mv with
   | None => True
   | Some d => length sc <= d
  end ->
  scEval sc (mvSubst s mv) = optBind (scmvEval sc mv) (fun mv => Some (mvSubst s mv)).
Proof.
  induction sc; auto.
  rename a into sel. simpl. intros. revert sel sc IHsc s H. destruct mv; auto.
  - (* MVVar t *) rename t into i. simpl. intros. contradict H. auto with arith.
  - (* MVCons mv1 mv2 *) simpl. intros. destruct sel.
    + apply IHsc; auto. destruct (mvMinVarDepth mv1); auto.
      destruct (mvMinVarDepth mv2); eauto with arith.
    + apply IHsc; auto. destruct (mvMinVarDepth mv2); auto.
      destruct (mvMinVarDepth mv1); eauto with arith.
Qed.

Lemma scmvEval_SomeMVVar_mvMinVarDepth: forall sc n (mv: MVal n) i,
  scmvEval sc mv = Some (MVVar i) -> exists d, mvMinVarDepth mv = Some d /\ d <= length sc.
Proof.
  induction sc.
  - simpl. intros. inversion H. subst. clear H. simpl. exists 0. auto with arith.
  - rename a into sel. simpl. intros.
    destruct mv; try congruence. simpl. destruct sel.
    + specialize (IHsc _ _ _ H). destruct IHsc as [d [Hmvd Hle]].
      rewrite Hmvd. destruct (mvMinVarDepth mv2); eauto with arith.
    + specialize (IHsc _ _ _ H). destruct IHsc as [d [Hmvd Hle]].
      rewrite Hmvd. destruct (mvMinVarDepth mv1); eauto with arith.
Qed.

Lemma ntmvEval_ntEval: forall (t: NTrm) n (s: Subst n) (mv: MVal n),
  match mvMinVarDepth mv with
   | None => True
   | Some d => ntMaxSelCmpLen t <= d
  end ->
  ntEval t (mvSubst s mv) = mvSubst' s (ntmvEval t mv).
Proof.
  induction t; auto.
  - (* NCons t1 t2 *) simpl. intros.
    rewrite IHt1; auto. 2: destruct (mvMinVarDepth mv); eauto with arith.
    rewrite IHt2; auto. 2: destruct (mvMinVarDepth mv); eauto with arith.
    unfold mvSubst'.
    rewrite optBind_option_map. rewrite option_map_optBind.
    apply optBind_extEq. intro mv1.
    rewrite optBind_option_map. rewrite option_map_optBind.
    reflexivity.
  - rename l into sc. simpl. intros.
    apply scmvEval_scEval; auto.
  - rename l into sc.
    (* NIfNil sc t1 t2 *)
    simpl. intros.
    rewrite scmvEval_scEval; auto. 2: destruct (mvMinVarDepth mv); eauto with arith.
    destruct (scmvEval sc mv) eqn: Heq; auto.
    simpl. destruct m.
    + simpl. apply IHt1. destruct (mvMinVarDepth mv); auto.
      change (max (S (length sc)) (max (ntMaxSelCmpLen t1) (ntMaxSelCmpLen t2)) <= n0) in H.
      eauto with arith.
    + rename t into i. simpl.
      apply scmvEval_SomeMVVar_mvMinVarDepth in Heq. destruct Heq as [d [Hmvd Hle]].
      rewrite Hmvd in *. contradict Hle.
      eauto with arith.
    + simpl. apply IHt2. destruct (mvMinVarDepth mv); auto.
      change (max (S (length sc)) (max (ntMaxSelCmpLen t1) (ntMaxSelCmpLen t2)) <= n0) in H.
      eauto with arith.
Qed.

(* *** *)
(* Decomposing a tree - at a given depth - to a tree with holes and a substitution
  giving subtrees for holes: *)

Definition vCutAt (d:nat) (v: Val) : {n: nat & Subst n * MVal n}%type.
  revert d. induction v.
  - (* VNil *) intro d. exists 0. split.
    + red. intro i. apply Fin.case0. exact i.
    + exact MVNil.
  - (* VCons v1 v2 *) intro d.
    destruct d as [|d].
    + exists 1. exact (fun i => VCons v1 v2, MVVar (Fin.F1)).
    + destruct (IHv1 d) as [n [s1 mv1]]. destruct (IHv2 d) as [m [s2 mv2]].
      exists (n + m).
      split.
      { intro i. destruct (finSplitLR i) as [j | j].
        - exact (s1 j).
        - exact (s2 j). }
      { exact (MVCons (mvCast m mv1) (mvShift n mv2)). }
Defined.

(* Eval simpl in (vCutAt 1 (VCons (VCons VNil VNil) (VCons (VCons VNil VNil) VNil))). *)

Lemma mvSubst_finSplitLR_mvCast: forall n m s1 s2 mv,
  mvSubst (fun i : Fin.t (n + m) =>
   match finSplitLR i with
   | inl j => s1 j
   | inr j => s2 j
   end) (mvCast m mv) = mvSubst s1 mv.
Proof.
  intros. revert m s1 s2. induction mv; auto.
  - simpl. intros.
    rewrite finSplitLR_FinL. reflexivity.
  - simpl. intros. rewrite IHmv1. rewrite IHmv2. reflexivity.
Qed.

Lemma mvSubst_finSplitLR_mvShift: forall n m s1 s2 mv,
  mvSubst (fun i : Fin.t (n + m) =>
   match finSplitLR i with
   | inl j => s1 j
   | inr j => s2 j
   end) (mvShift n mv) = mvSubst s2 mv.
Proof.
  intros. revert n s1 s2. induction mv; auto.
  - simpl. intros.
    rewrite finSplitLR_FinR. reflexivity.
  - simpl. intros. rewrite IHmv1. rewrite IHmv2. reflexivity.
Qed.

(* Correctness of tree decomposition: *)

Lemma vCutAt_mvSubst: forall d v n s mv,
  vCutAt d v = existT (fun n => Subst n * MVal n)%type n (s, mv) ->
  mvSubst s mv = v.
Proof.
  intros d v. revert d. induction v.
  - simpl. intros. rewrite eq_sigT_iff_eq_dep in H. inversion H.
    subst.
    apply (inj_pair2_eq_dec _ eq_nat_dec) in H3.
    apply (inj_pair2_eq_dec _ eq_nat_dec) in H4.
    subst. reflexivity.
  - simpl. destruct d as [|d].
    + intros. rewrite eq_sigT_iff_eq_dep in H. inversion H.
      subst.
      apply (inj_pair2_eq_dec _ eq_nat_dec) in H3.
      apply (inj_pair2_eq_dec _ eq_nat_dec) in H4.
      subst. reflexivity.
    + intros.
      destruct (vCutAt d v1) as [n' [s1 mv1]] eqn: Heq1.
      destruct (vCutAt d v2) as [m' [s2 mv2]] eqn: Heq2.
      rewrite eq_sigT_iff_eq_dep in H. inversion H. clear H.
      subst.
      apply (inj_pair2_eq_dec _ eq_nat_dec) in H3.
      apply (inj_pair2_eq_dec _ eq_nat_dec) in H4.
      subst.
      simpl. f_equal.
      * rewrite mvSubst_finSplitLR_mvCast. eauto.
      * rewrite mvSubst_finSplitLR_mvShift. eauto.
Qed.

Lemma mvDepth_vCutAt_le: forall d v n s mv,
  vCutAt d v = existT (fun n : nat => (Subst n * MVal n)%type) n (s, mv) ->
  mvDepth mv <= d.
Proof.
  intros d v. revert d. induction v.
  - simpl. intros.
    rewrite eq_sigT_iff_eq_dep in H. inversion H. auto with arith.
  - simpl. intros. destruct d.
    + rewrite eq_sigT_iff_eq_dep in H. inversion H. auto.
    + destruct (vCutAt d v1) as [n1 [s1 mv1]] eqn: Heq1.
      destruct (vCutAt d v2) as [n2 [s2 mv2]] eqn: Heq2.
      rewrite eq_sigT_iff_eq_dep in H. inversion H.
      simpl. apply le_n_S.

      rewrite mvDepth_mvCast. rewrite mvDepth_mvShift.
      specialize (IHv1 _ _ _ _ Heq1).
      specialize (IHv2 _ _ _ _ Heq2).
      apply NPeano.Nat.max_lub; auto.
Qed.

Lemma vCutAt_mvMinVarDepth: forall d v n s mv,
  vCutAt d v = existT (fun n : nat => (Subst n * MVal n)%type) n (s, mv) ->
  mvMinVarDepth mv = None \/ mvMinVarDepth mv = Some d.
Proof.
  intros d v. revert d. induction v.
  - simpl. intros.
    rewrite eq_sigT_iff_eq_dep in H. inversion H. auto.
  - simpl. intros. destruct d.
    + rewrite eq_sigT_iff_eq_dep in H. inversion H. auto.
    + destruct (vCutAt d v1) as [n1 [s1 mv1]] eqn: Heq1.
      destruct (vCutAt d v2) as [n2 [s2 mv2]] eqn: Heq2.
      rewrite eq_sigT_iff_eq_dep in H. inversion H. subst.
      apply (inj_pair2_eq_dec _ eq_nat_dec) in H3. subst. clear H2 H.
      simpl.
      specialize (IHv1 _ _ _ _ Heq1).
      specialize (IHv2 _ _ _ _ Heq2).
      rewrite mvMinVarDepth_mvCast. rewrite mvMinVarDepth_mvShift.
      destruct IHv1 as [IHv1 | IHv1]; rewrite IHv1;
      destruct IHv2 as [IHv2 | IHv2]; rewrite IHv2;
      auto with arith.
Qed.

(* *** *)
(* Main result about discriminating inequivalent programs by a finite test set: *)

Local Ltac solveBy_vCutAt_mvMinVarDepth :=
  match goal with [H: vCutAt _ _ = existT _ _ _ |- _] =>
    apply vCutAt_mvMinVarDepth in H;
    destruct H as [Heq | Heq]; rewrite Heq; auto
  end.

Lemma NTrm_fixed_MaxSelCmpLen_testable_aux:
  forall d t1 t2, ntMaxSelCmpLen t1 <= d -> ntMaxSelCmpLen t2 <= d ->
  (exists v, ntEval t1 v <> ntEval t2 v) ->
  exists v1, valDepth v1 <= S d /\ ntEval t1 v1 <> ntEval t2 v1.
Proof.
  intros. destruct H1 as [v H1].
  remember (vCutAt d v) as x. destruct x as [n [s mv]]. symmetry in Heqx.
  replace v with (mvSubst s mv) in H1. 2: apply vCutAt_mvSubst with (d:=d); auto.
  repeat (rewrite ntmvEval_ntEval in H1; try solveBy_vCutAt_mvMinVarDepth).
  destruct (option_eq_dec MVal_eq_dec (ntmvEval t1 mv) (ntmvEval t2 mv)) as [?|Hneq];
    try congruence.
  clear H1.
  destruct (ntmvEval t1 mv) as [mv1|] eqn: Heq1;
  destruct (ntmvEval t2 mv) as [mv2|] eqn: Heq2; try congruence.
  - (* Some mv1, Some mv2 *)
    destruct (MVal_eq_dec mv1 mv2) as [? | Hneq1]; try congruence. clear Hneq.
    pose (HexistsSubst := mvSubst_discrim _ _ _ Hneq1).
    destruct HexistsSubst as [s1 [Hdepth Hneq2]].
    exists (mvSubst s1 mv). split.
    + apply mvDepth_vCutAt_le in Heqx.
      transitivity (1 + mvDepth mv); auto with arith.
      apply valDepth_mvSubst_le; auto.
    + repeat (rewrite ntmvEval_ntEval; try solveBy_vCutAt_mvMinVarDepth).
      rewrite Heq1. rewrite Heq2. simpl. congruence.
  - (* Some mv1, None *)
    exists (mvSubst (fun _ => VNil) mv). split.
    + apply mvDepth_vCutAt_le in Heqx.
      transitivity (1 + mvDepth mv); auto with arith.
      apply valDepth_mvSubst_le; auto.
    + repeat (rewrite ntmvEval_ntEval; try solveBy_vCutAt_mvMinVarDepth).
      rewrite Heq1. rewrite Heq2. simpl. congruence.
  - (* None, Some mv2 *)
    exists (mvSubst (fun _ => VNil) mv). split.
    + apply mvDepth_vCutAt_le in Heqx.
      transitivity (1 + mvDepth mv); auto with arith.
      apply valDepth_mvSubst_le; auto.
    + repeat (rewrite ntmvEval_ntEval; try solveBy_vCutAt_mvMinVarDepth).
      rewrite Heq1. rewrite Heq2. simpl. congruence.
Qed.

Theorem NTrm_fixed_MaxSelCmpLen_testable:
  forall d t1 t2, ntMaxSelCmpLen t1 <= d -> ntMaxSelCmpLen t2 <= d ->
  (forall v, valDepth v <= S d -> ntEval t1 v = ntEval t2 v) ->
  forall v, ntEval t1 v = ntEval t2 v.
Proof.
  intros d t1 t2 HscLen1 HscLen2 HallTstEq v.
  destruct (option_eq_dec Val_eq_dec (ntEval t1 v) (ntEval t2 v)) as [Heq | Hneq]; auto.
  assert (Hneq': exists v, ntEval t1 v <> ntEval t2 v); eauto.
  contradict HallTstEq. intro HallTstEq.
  pose (H := NTrm_fixed_MaxSelCmpLen_testable_aux _ _ _ HscLen1 HscLen2 Hneq').
  destruct H as [v1 [Hdepth Hneq1]].
  specialize (HallTstEq _ Hdepth). congruence.
Qed.

(* Print Assumptions NTrm_fixed_MaxSelCmpLen_testable. *)

(* *** *)
(* Show that bound on test set depth is tight: *)

Definition replicate {X} n (x: X) := map (fun _ => x) (seq 0 n).

(* counterexample taken from some old essays from 20100722:
Definition undiscrTerms (n: nat) : (NTrm * NTrm) :=
  let sels := replicate n HD in
  let sels1 := sels ++ (HD::nil) in
  let sels2 := sels ++ (TL::nil) in
  let nt1 := NIfNil sels1 NNil (NIfNil sels2 NNil (NSelCmp sels1)) in
  let nt2 := NIfNil sels1 NNil (NIfNil sels2 NNil (NSelCmp sels2)) in
  (nt1, nt2).
*)

Lemma undiscrTerms_exist: forall n, exists nt1, exists nt2,
  ntMaxSelCmpLen nt1 = S n /\ ntMaxSelCmpLen nt2 = S n /\
  (forall v, valDepth v <= S n -> ntEval nt1 v = ntEval nt2 v)
  /\ exists v, ntEval nt1 v <> ntEval nt2 v.
Proof.
  intros.
  exists (NSelCmp (replicate n HD ++ (HD::nil))).
  exists (NSelCmp (replicate n HD ++ (TL::nil))).
  simpl.
  repeat (rewrite app_length). simpl. unfold replicate.
  rewrite map_length. rewrite seq_length. rewrite plus_comm.
  split; auto with arith.
  split; auto with arith.
  split.
  - induction n.
    + simpl. destruct v; auto. simpl.
      destruct v1; destruct v2; auto;
        simpl; try solve [intro H; contradict H; auto with arith].
    + simpl. destruct v; auto. simpl. intro Hle.
      rewrite <- seq_shift. rewrite map_map. apply IHn.
      apply le_S_n in Hle. eapply Max.max_lub_l. eassumption.
  - induction n.
    + simpl. exists (VCons VNil (VCons VNil VNil)). congruence.
    + simpl. rewrite <- seq_shift. rewrite map_map.
      destruct IHn as [v Hneq].
      exists (VCons v VNil). assumption.
Qed.


Require List.

Module proofs.

  Goal forall P Q, P <-> Q -> P -> Q.
    intros P Q H. rewrite H. easy.
  Qed.

End proofs.


From Cyclic_PA.Maths Require Import naturals.
From Cyclic_PA.Maths Require Import lists.
From Cyclic_PA.Logic Require Import definitions.
From Cyclic_PA.Logic Require Import fol.

(* Defining substitution indicators. When we later define formula substitution,
we will want to take some formula A, and replace any instances of the
subformula E with the formula F. However, we will only want to do this at
certain places in A. Substitution indicators will control this.
For instance, if A is "B \/ (C \/ D)" we might be given a substitution
indicator S that looks like "0 (1 0)" which indicates that we want to
substitute C (if C is E) but leave B,D alone even if they are E. *)
Inductive subst_ind : Type :=
| ind_0 : subst_ind
| ind_1 : subst_ind
| lor_ind : subst_ind -> subst_ind -> subst_ind.

Notation "(0)" := ind_0.
Notation "(1)" := ind_1.
Notation "( x y )" := (lor_ind x y).

Fixpoint non_target (A : formula) : subst_ind :=
match A with
| lor B C => lor_ind (non_target B) (non_target C)
| _ => (0)
end.

Fixpoint target (A : formula) : subst_ind :=
match A with
| lor B C => lor_ind (target B) (target C)
| _ => (1)
end.

Fixpoint subst_ind_fit (A : formula) (S : subst_ind) : bool :=
match A, S with
| lor B C, lor_ind S_B S_C =>
    subst_ind_fit B S_B && subst_ind_fit C S_C
| _, lor_ind _ _ => false
| lor _ _, _ => false
| _, _ => true
end.

Fixpoint formula_sub_ind_fit (A D E : formula) (S : subst_ind) : formula :=
match A with
| lor B C =>
  (match S with
  | lor_ind S1 S2 => lor (formula_sub_ind_fit B D E S1)
                         (formula_sub_ind_fit C D E S2)
  | _ => A
  end)
| _ =>
  (match form_eqb A D, S with
  | true, (1) => E
  | _, _ => A
  end)
end.

Definition formula_sub_ind (A D E : formula) (S : subst_ind) : formula :=
match subst_ind_fit A S with
| false => A
| true => formula_sub_ind_fit A D E S
end.

Lemma sub_fit_true :
    forall (A D E : formula) (S : subst_ind),
        subst_ind_fit A S = true ->
            formula_sub_ind A D E S = formula_sub_ind_fit A D E S.
Proof.
intros A D E S FS.
unfold formula_sub_ind.
destruct A;
rewrite FS;
reflexivity.
Qed.

Lemma sub_fit_false :
    forall (A D E : formula) (S : subst_ind),
        subst_ind_fit A S = false ->
            formula_sub_ind A D E S = A.
Proof.
intros A D E S FS.
unfold formula_sub_ind.
destruct A;
rewrite FS;
reflexivity.
Qed.

Lemma formula_sub_ind_fit_0 :
    forall (A D E : formula),
        formula_sub_ind_fit A D E (0) = A.
Proof.
intros A D E.
destruct A;
unfold formula_sub_ind_fit.
4 : case (form_eqb (univ n A) D).
2 : case (form_eqb (neg A) D).
1 : case (form_eqb (atom a) D).
all : reflexivity.
Qed.

Lemma formula_sub_ind_0 :
    forall (A D E : formula),
        formula_sub_ind A D E (0) = A.
Proof.
intros A D E.
case (subst_ind_fit A (0)) eqn:HA;
unfold formula_sub_ind;
rewrite HA.
- rewrite formula_sub_ind_fit_0.
  reflexivity.
- reflexivity.
Qed.

Lemma formula_sub_ind_lor :
    forall (A B D E : formula) (S_A S_B : subst_ind),
        subst_ind_fit A S_A && subst_ind_fit B S_B = true ->
            formula_sub_ind (lor A B) D E (lor_ind S_A S_B) =
                lor (formula_sub_ind A D E S_A) (formula_sub_ind B D E S_B).
Proof.
intros A B D E S_A S_B FS.
unfold formula_sub_ind.
destruct (and_bool_prop _ _ FS) as [FSA FSB].
rewrite FSA,FSB.
unfold subst_ind_fit; fold subst_ind_fit.
rewrite FS.
unfold formula_sub_ind_fit; fold formula_sub_ind_fit.
reflexivity.
Qed.

Lemma non_target_fit :
    forall (A : formula),
        subst_ind_fit A (non_target A) = true.
Proof.
intros A.
unfold subst_ind_fit, non_target.
induction A.
3 : rewrite IHA1, IHA2.
all : reflexivity.
Qed.

Lemma non_target_sub_fit :
    forall (A : formula) (n : nat) (t : term),
        subst_ind_fit (substitution A n t) (non_target A) = true.
Proof.
intros A n t.
unfold subst_ind_fit, non_target, substitution.
induction A.
3 : rewrite IHA1, IHA2.
4 : case (nat_eqb n0 n).
all : reflexivity.
Qed.

Lemma non_target_sub' :
    forall (A D E : formula),
        formula_sub_ind_fit A D E (non_target A) = A.
Proof.
intros A D E.
induction A;
unfold non_target, formula_sub_ind_fit;
fold non_target formula_sub_ind_fit.
4 : case (form_eqb (univ n A) D).
3 : rewrite IHA1, IHA2.
2 : case (form_eqb (neg A) D).
1 : case (form_eqb (atom a) D).
all : reflexivity.
Qed.

Lemma non_target_sub :
    forall (A C D : formula),
        formula_sub_ind A C D (non_target A) = A.
Proof.
intros A C D.
unfold formula_sub_ind.
rewrite non_target_fit.
apply non_target_sub'.
Qed.

Lemma non_target_sub_lor :
    forall (A B D E : formula) (S : subst_ind),
        formula_sub_ind (lor A B) D E (lor_ind (non_target A) S) =
            lor A (formula_sub_ind B D E S).
Proof.
intros A B D E S.
unfold formula_sub_ind, subst_ind_fit, formula_sub_ind_fit;
fold subst_ind_fit formula_sub_ind_fit.
rewrite non_target_fit, non_target_sub'.
case (subst_ind_fit B S) eqn:HB;
reflexivity.
Qed.

Lemma non_target_term_sub :
    forall (A : formula) (n : nat) (t : term),
        non_target A = non_target (substitution A n t).
Proof.
intros A n t.
induction A;
unfold non_target, substitution;
fold non_target substitution.
3 : rewrite IHA1,IHA2.
4 : case (nat_eqb n0 n).
all : reflexivity.
Qed.

Lemma non_target_sub_term' :
    forall (A C D: formula) (n : nat) (t : term),
        formula_sub_ind_fit (substitution A n t) C D (non_target A) = (substitution A n t).
Proof.
intros.
rewrite (non_target_term_sub _ n t).
apply non_target_sub'.
Qed.

Lemma formula_sub_ind_free_list :
    forall (A B C : formula),
        (free_list B = free_list C) ->
            forall (S : subst_ind),
                free_list (formula_sub_ind_fit A B C S) = free_list A.
Proof.
intros A B C FREE.
induction A;
intros S;
unfold formula_sub_ind.

all : unfold formula_sub_ind_fit;
      fold formula_sub_ind_fit;
      try case form_eqb eqn:EQ;
      destruct S;
      try apply form_eqb_eq in EQ;
      try destruct EQ, FREE;
      try reflexivity.

1 : unfold free_list;
    fold free_list.
    rewrite IHA1,IHA2.
    reflexivity.
Qed.

Lemma formula_sub_ind_closed :
    forall (A B C : formula),
        closed A = true ->
            (closed B = true -> closed C = true) ->
                forall (S : subst_ind),
                    closed (formula_sub_ind A B C S) = true.
Proof.
intros A B C.
induction A;
intros CA CBC S;
unfold formula_sub_ind.
4 : case (subst_ind_fit (univ n A) S).
3 : case (subst_ind_fit (lor A1 A2) S) eqn:FS.
2 : case (subst_ind_fit (neg A) S).
1 : case (subst_ind_fit (atom a) S).
all : try apply CA;
      unfold formula_sub_ind_fit;
      fold formula_sub_ind_fit;
      destruct S;
      try apply CA.
7 : { unfold formula_sub_ind, formula_sub_ind_fit, subst_ind_fit, closed in *;
      fold formula_sub_ind formula_sub_ind_fit subst_ind_fit closed in *.
      destruct (and_bool_prop _ _ CA) as [CA1 CA2].
      destruct (and_bool_prop _ _ FS) as [FS1 FS2].
      pose proof (IHA1 CA1 CBC S1) as CFA1.
      rewrite FS1 in CFA1.
      rewrite CFA1.
      pose proof (IHA2 CA2 CBC S2) as CFA2.
      rewrite FS2 in CFA2.
      rewrite CFA2.
      reflexivity. }
7-9 : case (form_eqb (univ n A) B) eqn:EQ.
4-6 : case (form_eqb (neg A) B) eqn:EQ.
1-3 : case (form_eqb (atom a) B) eqn:EQ.
all : try apply CA;
      apply form_eqb_eq in EQ;
      destruct EQ;
      apply (CBC CA).
Qed.

Lemma formula_sub_ind_1 :
    forall (A B : formula),
        (subst_ind_fit A (1) = true) ->
            formula_sub_ind A A B (1) = B.
Proof.
intros A B FS.
destruct A;
unfold formula_sub_ind, subst_ind_fit, formula_sub_ind_fit.
3 : inversion FS.
all : rewrite form_eqb_refl;
      reflexivity.
Qed.

Theorem lor_sub_right:
    forall C A E,
        (subst_ind_fit A (1) = true) ->
            formula_sub_ind (lor C A) A E (lor_ind (non_target C) (1)) = lor C E.
Proof.
intros C A E FS.
rewrite formula_sub_ind_lor.
- rewrite (formula_sub_ind_1 _ E FS).
  rewrite non_target_sub.
  reflexivity.
- rewrite non_target_fit.
  apply FS.
Qed.

Theorem lor_sub_left:
    forall A D E,
        (subst_ind_fit A (1) = true) ->
            formula_sub_ind (lor A D) A E (lor_ind (1) (non_target D)) = lor E D.
Proof.
intros A D E FS.
rewrite formula_sub_ind_lor.
- rewrite (formula_sub_ind_1 _ E FS).
  rewrite non_target_sub.
  reflexivity.
- rewrite FS.
  apply non_target_fit.
Qed.


(** * SfLib: Software Foundations Library *)

(* $Date: 2013-07-18 05:19:11 +0900 (木, 18  7月 2013) $ *)

(** Here we collect together several useful definitions and theorems
    from Basics.v, List.v, Poly.v, Ind.v, and Logic.v that are not
    already in the Coq standard library.  From now on we can [Import]
    or [Export] this file, instead of cluttering our environment with
    all the examples and false starts in those files. *)

(** * From the Coq Standard Library *)

Require Omega.   (* needed for using the [omega] tactic *)
Require Export Bool.
Require Export List.
Export ListNotations.
Require Export Arith.
Require Export Arith.EqNat.  (* Contains [beq_nat], among other things *)

(** * From Basics.v *)

Definition admit {T: Type} : T.  Admitted.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Fixpoint ble_nat (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => ble_nat n' m'
      end
  end.

Theorem andb_true_elim1 : forall b c,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
    reflexivity.
  Case "b = false".
    rewrite <- H. reflexivity.  Qed.

Theorem andb_true_elim2 : forall b c,
  andb b c = true -> c = true.
Proof.
(* An exercise in Basics.v *)
Admitted.

Theorem beq_nat_sym : forall (n m : nat),
  beq_nat n m = beq_nat m n.
(* An exercise in Lists.v *)
Admitted.

(** * From Props.v *)

Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n:nat, ev n -> ev (S (S n)).

(** * From Logic.v *)

Theorem andb_true : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  intros b c H.
  destruct b.
    destruct c.
      apply conj. reflexivity. reflexivity.
      inversion H.
    inversion H.  Qed.

Theorem false_beq_nat: forall n n' : nat,
     n <> n' ->
     beq_nat n n' = false.
Proof.
(* An exercise in Logic.v *)
Admitted.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.  Qed.

Theorem ev_not_ev_S : forall n,
  ev n -> ~ ev (S n).
Proof.
(* An exercise in Logic.v *)
Admitted.

Theorem ble_nat_true : forall n m,
  ble_nat n m = true -> n <= m.
(* An exercise in Logic.v *)
Admitted.

Theorem ble_nat_false : forall n m,
  ble_nat n m = false -> ~(n <= m).
(* An exercise in Logic.v *)
Admitted.

Inductive appears_in (n : nat) : list nat -> Prop :=
| ai_here : forall l, appears_in n (n::l)
| ai_later : forall m l, appears_in n l -> appears_in n (m::l).

Inductive next_nat (n:nat) : nat -> Prop :=
  | nn : next_nat n (S n).

Inductive total_relation : nat -> nat -> Prop :=
  tot : forall n m : nat, total_relation n m.

Inductive empty_relation : nat -> nat -> Prop := .

(** * From Later Files *)

Definition relation (X:Type) := X -> X -> Prop.

Definition deterministic {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Inductive multi (X:Type) (R: relation X)
                            : X -> X -> Prop :=
  | multi_refl  : forall (x : X),
                 multi X R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi X R y z ->
                    multi X R x z.
Implicit Arguments multi [[X]].

Tactic Notation "multi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "multi_refl" | Case_aux c "multi_step" ].

Theorem multi_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> multi R x y.
Proof.
  intros X R x y r.
  apply multi_step with y. apply r. apply multi_refl.   Qed.

Theorem multi_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      multi R x y  ->
      multi R y z ->
      multi R x z.
Proof.
  (* FILL IN HERE *) Admitted.

(**  Identifiers and polymorphic partial maps. *)

Inductive id : Type :=
  Id : nat -> id.

Theorem eq_id_dec : forall id1 id2 : id, {id1 = id2} + {id1 <> id2}.
Proof.
   intros id1 id2.
   destruct id1 as [n1]. destruct id2 as [n2].
   destruct (eq_nat_dec n1 n2) as [Heq | Hneq].
   Case "n1 = n2".
     left. rewrite Heq. reflexivity.
   Case "n1 <> n2".
     right. intros contra. inversion contra. apply Hneq. apply H0.
Defined.

Lemma eq_id : forall (T:Type) x (p q:T),
              (if eq_id_dec x x then p else q) = p.
Proof.
  intros.
  destruct (eq_id_dec x x); try reflexivity.
  apply ex_falso_quodlibet; auto.
Qed.

Lemma neq_id : forall (T:Type) x y (p q:T), x <> y ->
               (if eq_id_dec x y then p else q) = q.
Proof.
  (* FILL IN HERE *) Admitted.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

Notation "'\empty'" := empty.

Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
  fun x' => if eq_id_dec x x' then Some T else Gamma x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite eq_id; auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  x2 <> x1 ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite neq_id; auto.
Qed.

Lemma extend_shadow : forall A (ctxt: partial_map A) t1 t2 x1 x2,
  extend (extend ctxt x2 t1) x2 t2 x1 = extend ctxt x2 t2 x1.
Proof with auto.
  intros. unfold extend. destruct (eq_id_dec x2 x1)...
Qed.

(** -------------------- *)

(** * Some useful tactics *)

Tactic Notation "solve_by_inversion_step" tactic(t) :=
  match goal with
  | H : _ |- _ => solve [ inversion H; subst; t ]
  end
  || fail "because the goal is not solvable by inversion.".

Tactic Notation "solve" "by" "inversion" "1" :=
  solve_by_inversion_step idtac.
Tactic Notation "solve" "by" "inversion" "2" :=
  solve_by_inversion_step (solve by inversion 1).
Tactic Notation "solve" "by" "inversion" "3" :=
  solve_by_inversion_step (solve by inversion 2).
Tactic Notation "solve" "by" "inversion" :=
  solve by inversion 1.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.model.monoids.Qmonoid.
Require Import CoRN.algebra.CGroups.

(**
** Example of a group: $\langle$#⟨#[Q],[[+]]$\rangle$#⟩#
The rational numbers with addition form a group. The inverse function is taking the opposite.
*)

Lemma Q_is_CGroup : is_CGroup Q_as_CMonoid Qopp_is_fun.
Proof. split. apply Qplus_opp_r. simpl. rewrite Qplus_comm. apply Qplus_opp_r. Qed.

Definition Q_as_CGroup := Build_CGroup Q_as_CMonoid Qopp_is_fun Q_is_CGroup.

Canonical Structure Q_as_CGroup.


(* (c) Copyright Microsoft Corporation and Inria.                       *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path fintype bigop.
Require Import finset fingroup morphism automorphism quotient action.
Require Import commutator center.
(******************************************************************************)
(*           H <|<| G   <=> H is subnormal in G, i.e., H <| ... <| G.         *)
(* invariant_factor A H G <=> A normalises both H and G, and H <| G.          *)
(*         A.-invariant <=> the (invariant_factor A) relation, in the context *)
(*                          of the g_rel.-series notation.                    *)
(*    g_rel.-series H s <=> H :: s is a sequence of groups whose projection   *)
(*                          to sets satisfies relation g_rel pairwise; for    *)
(*                          example H <|<| G iff G = last H s for some s such *)
(*                          that normal.-series H s.                          *)
(*   stable_factor A H G == H <| G and A centralises G / H.                   *)
(*             A.-stable == the stable_factor relation, in the scope of the   *)
(*                          r.-series notation.                               *)
(*            G.-central == the central_factor relation, in the scope of the  *)
(*                          r.-series notation.                               *)
(*           maximal M G == M is a maximal proper subgroup of G.              *)
(*        maximal_eq M G == (M == G) or (maximal M G).                        *)
(*       maxnormal M G N == M is a maximal subgroup of G normalized by N.     *)
(*         minnormal M N == M is a minimal nontrivial group normalized by N.  *)
(*              simple G == G is a (nontrivial) simple group.                 *)
(*                       := minnormal G G                                     *)
(*              G.-chief == the chief_factor relation, in the scope of the    *)
(*                          r.-series notation.                               *)
(******************************************************************************)

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

Import GroupScope.

Section GroupDefs.

Variable gT : finGroupType.
Implicit Types A B U V : {set gT}.

Notation Local groupT := (group_of (Phant gT)).

Definition subnormal A B :=
  (A \subset B) && (iter #|B| (fun N => generated (class_support A N)) B == A).

Definition invariant_factor A B C :=
  [&& A \subset 'N(B), A \subset 'N(C) & B <| C].

Definition group_rel_of (r : rel {set gT}) := [rel H G : groupT | r H G].

Definition stable_factor A V U :=
  ([~: U, A] \subset V) && (V <| U). (* this orders allows and3P to be used *)

Definition central_factor A V U :=
  [&& [~: U, A] \subset V, V \subset U & U \subset A].

Definition maximal A B := [max A of G | G \proper B].

Definition maximal_eq A B := (A == B) || maximal A B.

Definition maxnormal A B U := [max A of G | G \proper B & U \subset 'N(G)].

Definition minnormal A B := [min A of G | G :!=: 1 & B \subset 'N(G)].

Definition simple A := minnormal A A.

Definition chief_factor A V U := maxnormal V U A && (U <| A).
End GroupDefs.

Arguments Scope subnormal [_ group_scope group_scope].
Arguments Scope invariant_factor [_ group_scope group_scope group_scope].
Arguments Scope stable_factor [_ group_scope group_scope group_scope].
Arguments Scope central_factor [_ group_scope group_scope group_scope].
Arguments Scope maximal [_ group_scope group_scope].
Arguments Scope maximal_eq [_ group_scope group_scope].
Arguments Scope maxnormal [_ group_scope group_scope group_scope].
Arguments Scope minnormal [_ group_scope group_scope].
Arguments Scope simple [_ group_scope].
Arguments Scope chief_factor [_ group_scope group_scope group_scope].
Prenex Implicits subnormal maximal simple.

Notation "H <|<| G" := (subnormal H G)
  (at level 70, no associativity) : group_scope.

Notation "A .-invariant" := (invariant_factor A)
  (at level 2, format "A .-invariant") : group_rel_scope.
Notation "A .-stable" := (stable_factor A)
  (at level 2, format "A .-stable") : group_rel_scope.
Notation "A .-central" := (central_factor A)
  (at level 2, format "A .-central") : group_rel_scope.
Notation "G .-chief" := (chief_factor G)
  (at level 2, format "G .-chief") : group_rel_scope.

Arguments Scope group_rel_of [_ group_rel_scope Group_scope Group_scope].

Notation "r .-series" := (path (rel_of_simpl_rel (group_rel_of r)))
  (at level 2, format "r .-series") : group_scope.

Section Subnormal.

Variable gT : finGroupType.
Implicit Types (A B C D : {set gT}) (G H K : {group gT}).

Let setIgr H G := (G :&: H)%G.
Let sub_setIgr G H : G \subset H -> G = setIgr H G.
Proof. by move/setIidPl/group_inj. Qed.

Let path_setIgr H G s :
   normal.-series H s -> normal.-series (setIgr G H) (map (setIgr G) s).
Proof.
elim: s H => //= K s IHs H /andP[/andP[sHK nHK] Ksn].
by rewrite /normal setSI ?normsIG ?IHs.
Qed.

Lemma subnormalP H G :
  reflect (exists2 s, normal.-series H s & last H s = G) (H <|<| G).
Proof.
apply: (iffP andP) => [[sHG snHG] | [s Hsn <-{G}]].
  elim: {G}#|G| {-2}G sHG snHG => [|m IHm] G sHG.
    by exists [::]; last by apply/eqP; rewrite eq_sym.
  rewrite iterSr => /IHm[|s Hsn defG].
    by rewrite sub_gen // class_supportEr (bigD1 1) //= conjsg1 subsetUl.
  exists (rcons s G); rewrite ?last_rcons // -cats1 cat_path Hsn defG /=.
  rewrite /normal gen_subG class_support_subG //=.
  by rewrite norms_gen ?class_support_norm.
set f := fun _ => <<_>>; have idf: iter _ f H == H.
  by elim=> //= m IHm; rewrite (eqP IHm) /f class_support_id genGid.
elim: {s}(size s) {-2}s (eqxx (size s)) Hsn => [[] //= | m IHm s].
case/lastP: s => // s G; rewrite size_rcons last_rcons -cats1 cat_path /=.
set K := last H s => def_m /and3P[Hsn /andP[sKG nKG] _].
have:= sKG; rewrite subEproper; case/predU1P=> [<-|prKG]; first exact: IHm.
pose L := [group of f G].
have sHK: H \subset K by case/IHm: Hsn.
have sLK: L \subset K by rewrite gen_subG class_support_sub_norm.
rewrite -(subnK (proper_card (sub_proper_trans sLK prKG))) iter_add iterSr.
have defH: H = setIgr L H by rewrite -sub_setIgr ?sub_gen ?sub_class_support.
have: normal.-series H (map (setIgr L) s) by rewrite defH path_setIgr.
case/IHm=> [|_]; first by rewrite size_map.
by rewrite {1 2}defH last_map (subset_trans sHK) //= (setIidPr sLK) => /eqP->.
Qed.

Lemma subnormal_refl G : G <|<| G.
Proof. by apply/subnormalP; exists [::]. Qed.

Lemma subnormal_trans K H G : H <|<| K -> K <|<| G -> H <|<| G.
Proof.
case/subnormalP=> [s1 Hs1 <-] /subnormalP[s2 Hs12 <-].
by apply/subnormalP; exists (s1 ++ s2); rewrite ?last_cat // cat_path Hs1.
Qed.

Lemma normal_subnormal H G : H <| G -> H <|<| G.
Proof. by move=> nsHG; apply/subnormalP; exists [:: G]; rewrite //= nsHG. Qed.

Lemma setI_subnormal G H K : K \subset G -> H <|<| G -> H :&: K <|<| K.
Proof.
move=> sKG /subnormalP[s Hs defG]; apply/subnormalP.
exists (map (setIgr K) s); first exact: path_setIgr.
rewrite (last_map (setIgr K)) defG.
by apply: val_inj; rewrite /= (setIidPr sKG).
Qed.

Lemma subnormal_sub G H : H <|<| G -> H \subset G.
Proof. by case/andP. Qed.

Lemma invariant_subnormal A G H :
    A \subset 'N(G) -> A \subset 'N(H) -> H <|<| G ->
  exists2 s, (A.-invariant).-series H s & last H s = G.
Proof.
move=> nGA nHA /andP[]; move: #|G| => m.
elim: m => [|m IHm] in G nGA * => sHG.
  by rewrite eq_sym; exists [::]; last exact/eqP.
rewrite iterSr; set K := <<_>>.
have nKA: A \subset 'N(K) by rewrite norms_gen ?norms_class_support.
have sHK: H \subset K by rewrite sub_gen ?sub_class_support.
case/IHm=> // s Hsn defK; exists (rcons s G); last by rewrite last_rcons.
rewrite rcons_path Hsn !andbA defK nGA nKA /= -/K.
by rewrite gen_subG class_support_subG ?norms_gen ?class_support_norm.
Qed.

Lemma subnormalEsupport G H :
  H <|<| G -> H :=: G \/ <<class_support H G>> \proper G.
Proof.
case/andP=> sHG; set K := <<_>> => /eqP <-.
have: K \subset G by rewrite gen_subG class_support_subG.
rewrite subEproper; case/predU1P=> [defK|]; [left | by right].
by elim: #|G| => //= _ ->.
Qed.

Lemma subnormalEr G H : H <|<| G ->
  H :=: G \/ (exists K : {group gT}, [/\ H <|<| K, K <| G & K \proper G]).
Proof.
case/subnormalP=> s Hs <-{G}.
elim/last_ind: s Hs => [|s G IHs]; first by left.
rewrite last_rcons -cats1 cat_path /= andbT; set K := last H s.
case/andP=> Hs nsKG; have:= normal_sub nsKG; rewrite subEproper.
case/predU1P=> [<- | prKG]; [exact: IHs | right; exists K; split=> //].
by apply/subnormalP; exists s.
Qed.

Lemma subnormalEl G H : H <|<| G ->
  H :=: G \/ (exists K : {group gT}, [/\ H <| K, K <|<| G & H \proper K]).
Proof.
case/subnormalP=> s Hs <-{G}; elim: s H Hs => /= [|K s IHs] H; first by left.
case/andP=> nsHK Ks; have:= normal_sub nsHK; rewrite subEproper.
case/predU1P=> [-> | prHK]; [exact: IHs | right; exists K; split=> //].
by apply/subnormalP; exists s.
Qed.

End Subnormal.

Implicit Arguments subnormalP [gT G H].
Prenex Implicits subnormalP.

Section MorphSubNormal.

Variable gT : finGroupType.
Implicit Type G H K : {group gT}.

Lemma morphim_subnormal (rT : finGroupType) G (f : {morphism G >-> rT}) H K :
  H <|<| K -> f @* H <|<| f @* K.
Proof.
case/subnormalP => s Hs <-{K}; apply/subnormalP.
elim: s H Hs => [|K s IHs] H /=; first by exists [::].
case/andP=> nsHK /IHs[fs Hfs <-].
by exists ([group of f @* K] :: fs); rewrite /= ?morphim_normal.
Qed.

Lemma quotient_subnormal H G K : G <|<| K -> G / H <|<| K / H.
Proof. exact: morphim_subnormal. Qed.

End MorphSubNormal.

Section MaxProps.

Variable gT : finGroupType.
Implicit Types G H M : {group gT}.

Lemma maximal_eqP M G :
  reflect (M \subset G  /\
             forall H, M \subset H -> H \subset G -> H :=: M \/ H :=: G)
       (maximal_eq M G).
Proof.
rewrite subEproper /maximal_eq; case: eqP => [->|_]; first left.
  by split=> // H sGH sHG; right; apply/eqP; rewrite eqEsubset sHG.
apply: (iffP maxgroupP) => [] [sMG maxM]; split=> // H.
  by move/maxM=> maxMH; rewrite subEproper; case/predU1P; auto.
by rewrite properEneq => /andP[/eqP neHG sHG] /maxM[].
Qed.

Lemma maximal_exists H G :
    H \subset G ->
  H :=: G \/ (exists2 M : {group gT}, maximal M G & H \subset M).
Proof.
rewrite subEproper; case/predU1P=> sHG; first by left.
suff [M *]: {M : {group gT} | maximal M G & H \subset M} by right; exists M.
exact: maxgroup_exists.
Qed.

Lemma mulg_normal_maximal G M H :
  M <| G -> maximal M G -> H \subset G -> ~~ (H \subset M) -> (M * H = G)%g.
Proof.
case/andP=> sMG nMG /maxgroupP[_ maxM] sHG not_sHM.
apply/eqP; rewrite eqEproper mul_subG // -norm_joinEr ?(subset_trans sHG) //.
by apply: contra not_sHM => /maxM <-; rewrite ?joing_subl ?joing_subr.
Qed.

End MaxProps.

Section MinProps.

Variable gT : finGroupType.
Implicit Types G H M : {group gT}.

Lemma minnormal_exists G H : H :!=: 1 -> G \subset 'N(H) ->
  {M : {group gT} | minnormal M G & M \subset H}.
Proof. by move=> ntH nHG; apply: mingroup_exists (H) _; rewrite ntH. Qed.

End MinProps.

Section MorphPreMax.

Variables (gT rT : finGroupType) (D : {group gT}) (f : {morphism D >-> rT}).
Variables (M G : {group rT}).
Hypotheses (dM : M \subset f @* D) (dG : G \subset f @* D).

Lemma morphpre_maximal : maximal (f @*^-1 M) (f @*^-1 G) = maximal M G.
Proof.
apply/maxgroupP/maxgroupP; rewrite morphpre_proper //= => [] [ltMG maxM].
  split=> // H ltHG sMH; have dH := subset_trans (proper_sub ltHG) dG.
  rewrite -(morphpreK dH) [f @*^-1 H]maxM ?morphpreK ?morphpreSK //.
  by rewrite morphpre_proper.
split=> // H ltHG sMH.
have dH: H \subset D := subset_trans (proper_sub ltHG) (subsetIl D _).
have defH: f @*^-1 (f @* H) = H.
  by apply: morphimGK dH; apply: subset_trans sMH; exact: ker_sub_pre.
rewrite -defH morphpre_proper ?morphimS // in ltHG.
by rewrite -defH [f @* H]maxM // -(morphpreK dM) morphimS.
Qed.

Lemma morphpre_maximal_eq : maximal_eq (f @*^-1 M) (f @*^-1 G) = maximal_eq M G.
Proof. by rewrite /maximal_eq morphpre_maximal !eqEsubset !morphpreSK. Qed.

End MorphPreMax.

Section InjmMax.

Variables (gT rT : finGroupType) (D : {group gT}) (f : {morphism D >-> rT}).
Variables M G L : {group gT}.

Hypothesis injf : 'injm f.
Hypotheses (dM : M \subset D) (dG : G \subset D) (dL : L \subset D).

Lemma injm_maximal : maximal (f @* M) (f @* G) = maximal M G.
Proof.
rewrite -(morphpre_invm injf) -(morphpre_invm injf G).
by rewrite morphpre_maximal ?morphim_invm.
Qed.

Lemma injm_maximal_eq : maximal_eq (f @* M) (f @* G) = maximal_eq M G.
Proof. by rewrite /maximal_eq injm_maximal // !eqEsubset !injmSK. Qed.

Lemma injm_maxnormal : maxnormal (f @* M) (f @* G) (f @* L) = maxnormal M G L.
Proof.
pose injfm := (injm_proper injf, injm_norms, injmSK injf, subsetIl).
apply/maxgroupP/maxgroupP; rewrite !injfm // => [[nML maxM]].
  split=> // H nHL sMH; have [/proper_sub sHG _] := andP nHL.
  have dH := subset_trans sHG dG; apply: (injm_morphim_inj injf) => //.
  by apply: maxM; rewrite !injfm.
split=> // fH nHL sMH; have [/proper_sub sfHG _] := andP nHL.
have{sfHG} dfH: fH \subset f @* D := subset_trans sfHG (morphim_sub f G).
by rewrite -(morphpreK dfH) !injfm // in nHL sMH *; rewrite (maxM _ nHL).
Qed.

Lemma injm_minnormal : minnormal (f @* M) (f @* G) = minnormal M G.
Proof.
pose injfm := (morphim_injm_eq1 injf, injm_norms, injmSK injf, subsetIl).
apply/mingroupP/mingroupP; rewrite !injfm // => [[nML minM]].
  split=> // H nHG sHM; have dH := subset_trans sHM dM.
  by apply: (injm_morphim_inj injf) => //; apply: minM; rewrite !injfm.
split=> // fH nHG sHM; have dfH := subset_trans sHM (morphim_sub f M).
by rewrite -(morphpreK dfH) !injfm // in nHG sHM *; rewrite (minM _ nHG).
Qed.

End InjmMax.

Section QuoMax.

Variables (gT : finGroupType) (K G H : {group gT}).

Lemma cosetpre_maximal (Q R : {group coset_of K}) :
  maximal (coset K @*^-1 Q) (coset K @*^-1 R) = maximal Q R.
Proof. by rewrite morphpre_maximal ?sub_im_coset. Qed.

Lemma cosetpre_maximal_eq (Q R : {group coset_of K}) :
  maximal_eq (coset K @*^-1 Q) (coset K @*^-1 R) = maximal_eq Q R.
Proof. by rewrite /maximal_eq !eqEsubset !cosetpreSK cosetpre_maximal. Qed.

Lemma quotient_maximal :
  K <| G -> K <| H -> maximal (G / K) (H / K) = maximal G H.
Proof. by move=> nKG nKH; rewrite -cosetpre_maximal ?quotientGK. Qed.

Lemma quotient_maximal_eq :
  K <| G -> K <| H -> maximal_eq (G / K) (H / K) = maximal_eq G H.
Proof. by move=> nKG nKH; rewrite -cosetpre_maximal_eq ?quotientGK. Qed.

Lemma maximalJ x : maximal (G :^ x) (H :^ x) = maximal G H.
Proof.
rewrite -{1}(setTI G) -{1}(setTI H) -!morphim_conj.
by rewrite injm_maximal ?subsetT ?injm_conj.
Qed.

Lemma maximal_eqJ x : maximal_eq (G :^ x) (H :^ x) = maximal_eq G H.
Proof. by rewrite /maximal_eq !eqEsubset !conjSg maximalJ. Qed.

End QuoMax.

Section MaxNormalProps.

Variables (gT : finGroupType).
Implicit Types (A B C : {set gT}) (G H K L M : {group gT}).

Lemma maxnormal_normal A B : maxnormal A B B -> A <| B.
Proof.
by case/maxsetP=> /and3P[/gen_set_id /= -> pAB nAB]; rewrite /normal proper_sub.
Qed.

Lemma maxnormal_proper A B C : maxnormal A B C -> A \proper B.
Proof.
by case/maxsetP=> /and3P[gA pAB _] _; exact: (sub_proper_trans (subset_gen A)).
Qed.

Lemma maxnormal_sub A B C : maxnormal A B C -> A \subset B.
Proof.
by move=> maxA; rewrite proper_sub //; exact: (maxnormal_proper maxA).
Qed.

Lemma ex_maxnormal_ntrivg G : G :!=: 1-> {N : {group gT} | maxnormal N G G}.
Proof.
move=> ntG; apply: ex_maxgroup; exists [1 gT]%G; rewrite norm1 proper1G.
by rewrite subsetT ntG.
Qed.

Lemma maxnormalM G H K :
  maxnormal H G G -> maxnormal K G G -> H :<>: K -> H * K = G.
Proof.
move=> maxH maxK /eqP; apply: contraNeq => ltHK_G.
have [nsHG nsKG] := (maxnormal_normal maxH, maxnormal_normal maxK).
have cHK: commute H K.
  exact: normC (subset_trans (normal_sub nsHG) (normal_norm nsKG)).
wlog suffices: H K {maxH} maxK nsHG nsKG cHK ltHK_G / H \subset K.
  by move=> IH; rewrite eqEsubset !IH // -cHK.
have{maxK} /maxgroupP[_ maxK] := maxK.
apply/joing_idPr/maxK; rewrite ?joing_subr //= comm_joingE //.
by rewrite properEneq ltHK_G; exact: normalM.
Qed.

Lemma maxnormal_minnormal G L M :
    G \subset 'N(M) -> L \subset 'N(G) ->  maxnormal M G L ->
  minnormal (G / M) (L / M).
Proof.
move=> nMG nGL /maxgroupP[/andP[/andP[sMG ltMG] nML] maxM]; apply/mingroupP.
rewrite -subG1 quotient_sub1 ?ltMG ?quotient_norms //.
split=> // Hb /andP[ntHb nHbL]; have nsMG: M <| G by exact/andP.
case/inv_quotientS=> // H defHb sMH sHG; rewrite defHb; congr (_ / M).
apply/eqP; rewrite eqEproper sHG /=; apply: contra ntHb => ltHG.
have nsMH: M <| H := normalS sMH sHG nsMG.
rewrite defHb quotientS1 // (maxM H) // ltHG /=  -(quotientGK nsMH) -defHb.
exact: norm_quotient_pre.
Qed.

Lemma minnormal_maxnormal G L M :
  M <| G -> L \subset 'N(M) -> minnormal (G / M) (L / M) -> maxnormal M G L.
Proof.
case/andP=> sMG nMG nML /mingroupP[/andP[/= ntGM _] minGM]; apply/maxgroupP.
split=> [|H /andP[/andP[sHG ltHG] nHL] sMH].
  by rewrite /proper sMG nML andbT; apply: contra ntGM => /quotientS1 ->.
apply/eqP; rewrite eqEsubset sMH andbT -quotient_sub1 ?(subset_trans sHG) //.
rewrite subG1; apply: contraR ltHG => ntHM; rewrite -(quotientSGK nMG) //.
by rewrite (minGM (H / M)%G) ?quotientS // ntHM quotient_norms.
Qed.

End MaxNormalProps.

Section Simple.

Implicit Types gT rT : finGroupType.

Lemma simpleP gT (G : {group gT}) :
  reflect (G :!=: 1 /\ forall H : {group gT}, H <| G -> H :=: 1 \/ H :=: G)
          (simple G).
Proof.
apply: (iffP mingroupP); rewrite normG andbT => [[ntG simG]].
  split=> // N /andP[sNG nNG].
  by case: (eqsVneq N 1) => [|ntN]; [left | right; apply: simG; rewrite ?ntN].
split=> // N /andP[ntN nNG] sNG.
by case: (simG N) ntN => // [|->]; [exact/andP | case/eqP].
Qed.

Lemma quotient_simple gT (G H : {group gT}) :
  H <| G -> simple (G / H) = maxnormal H G G.
Proof.
move=> nsHG; have nGH := normal_norm nsHG.
by apply/idP/idP; [exact: minnormal_maxnormal | exact: maxnormal_minnormal].
Qed.

Lemma isog_simple gT rT (G : {group gT}) (M : {group rT}) :
  G \isog M -> simple G = simple M.
Proof.
move=> eqGM; wlog suffices: gT rT G M eqGM / simple M -> simple G.
  by move=> IH; apply/idP/idP; apply: IH; rewrite // isog_sym.
case/isogP: eqGM => f injf <- /simpleP[ntGf simGf].
apply/simpleP; split=> [|N nsNG]; first by rewrite -(morphim_injm_eq1 injf).
rewrite -(morphim_invm injf (normal_sub nsNG)).
have: f @* N <| f @* G by rewrite morphim_normal.
by case/simGf=> /= ->; [left | right]; rewrite (morphim1, morphim_invm).
Qed.

Lemma simple_maxnormal gT (G : {group gT}) : simple G = maxnormal 1 G G.
Proof.
by rewrite -quotient_simple ?normal1 // -(isog_simple (quotient1_isog G)).
Qed.

End Simple.

Section Chiefs.

Variable gT : finGroupType.
Implicit Types G H U V : {group gT}.

Lemma chief_factor_minnormal G V U :
  chief_factor G V U -> minnormal (U / V) (G / V).
Proof.
case/andP=> maxV /andP[sUG nUG]; apply: maxnormal_minnormal => //.
by have /andP[_ nVG] := maxgroupp maxV; exact: subset_trans sUG nVG.
Qed.

Lemma acts_irrQ G U V :
    G \subset 'N(V) -> V <| U ->
  acts_irreducibly G (U / V) 'Q = minnormal (U / V) (G / V).
Proof.
move=> nVG nsVU; apply/mingroupP/mingroupP; case=> /andP[->] /=.
  rewrite astabsQ // subsetI nVG /= => nUG minUV.
  rewrite quotient_norms //; split=> // H /andP[ntH nHG] sHU.
  by apply: minUV (sHU); rewrite ntH -(cosetpreK H) actsQ // norm_quotient_pre.
rewrite sub_quotient_pre // => nUG minU; rewrite astabsQ //.
rewrite (subset_trans nUG); last first.
  by rewrite subsetI subsetIl /= -{2}(quotientGK nsVU) morphpre_norm.
split=> // H /andP[ntH nHG] sHU.
rewrite -{1}(cosetpreK H) astabsQ ?normal_cosetpre ?subsetI ?nVG //= in nHG.
apply: minU sHU; rewrite ntH; apply: subset_trans (quotientS _ nHG) _.
by rewrite -{2}(cosetpreK H) quotient_norm.
Qed.

Lemma chief_series_exists H G :
  H <| G -> {s | (G.-chief).-series 1%G s & last 1%G s = H}.
Proof.
elim: {H}_.+1 {-2}H (ltnSn #|H|) => // m IHm U leUm nsUG.
have [-> | ntU] := eqVneq U 1%G; first by exists [::].
have [V maxV]: {V : {group gT} | maxnormal V U G}.
  by apply: ex_maxgroup; exists 1%G; rewrite proper1G ntU norms1.
have /andP[ltVU nVG] := maxgroupp maxV.
have [||s ch_s defV] := IHm V; first exact: leq_trans (proper_card ltVU) _.
  by rewrite /normal (subset_trans (proper_sub ltVU) (normal_sub nsUG)).
exists (rcons s U); last by rewrite last_rcons.
by rewrite rcons_path defV /= ch_s /chief_factor; exact/and3P.
Qed.

End Chiefs.

Section Central.

Variables (gT : finGroupType) (G : {group gT}).
Implicit Types H K : {group gT}.

Lemma central_factor_central H K :
  central_factor G H K -> (K / H) \subset 'Z(G / H).
Proof. by case/and3P=> /quotient_cents2r *; rewrite subsetI quotientS. Qed.

Lemma central_central_factor H K :
  (K / H) \subset 'Z(G / H) -> H <| K -> H <| G -> central_factor G H K.
Proof.
case/subsetIP=> sKGb cGKb /andP[sHK nHK] /andP[sHG nHG].
by rewrite /central_factor -quotient_cents2 // cGKb sHK -(quotientSGK nHK).
Qed.

End Central.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export List.
Require Export Permutation.
Require Import Arith.

Section Iterator.
Variables A B : Set.
Variable zero : B.
Variable f : A ->  B.
Variable g : B -> B ->  B.
Hypothesis g_zero : forall a,  g a zero = a.
Hypothesis g_trans : forall a b c,  g a (g b c) = g (g a b) c.
Hypothesis g_sym : forall a b,  g a b = g b a.

Definition iter := fold_right (fun a r => g (f a) r) zero.
Hint Unfold iter .

Theorem iter_app: forall l1 l2,  iter (app l1 l2) = g (iter l1) (iter l2).
intros l1; elim l1; simpl; auto.
intros l2; rewrite g_sym; auto.
intros a l H l2; rewrite H.
rewrite g_trans; auto.
Qed.

Theorem iter_permutation: forall l1 l2, permutation l1 l2 ->  iter l1 = iter l2.
intros l1 l2 H; elim H; simpl; auto; clear H l1 l2.
intros a l1 l2 H1 H2; apply f_equal2 with ( f := g ); auto.
intros a b l; (repeat rewrite g_trans).
apply f_equal2 with ( f := g ); auto.
intros l1 l2 l3 H H0 H1 H2; apply trans_equal with ( 1 := H0 ); auto.
Qed.

Lemma iter_inv:
 forall P l,
 P zero ->
 (forall a b, P a -> P b ->  P (g a b)) ->
 (forall x, In x l ->  P (f x)) ->  P (iter l).
intros P l H H0; (elim l; simpl; auto).
Qed.
Variable next : A ->  A.

Fixpoint progression (m : A) (n : nat) {struct n} : list A :=
 match n with   0 => nil
               | S n1 => cons m (progression (next m) n1) end.

Fixpoint next_n (c : A) (n : nat) {struct n} : A :=
 match n with 0 => c | S n1 => next_n (next c) n1 end.

Theorem progression_app:
 forall a b n m,
 le m n ->
 b = next_n a m ->
  progression a n = app (progression a m) (progression b (n - m)).
intros a b n m; generalize a b n; clear a b n; elim m; clear m; simpl.
intros a b n H H0; apply f_equal2 with ( f := progression ); auto with arith.
intros m H a b n; case n; simpl; clear n.
intros H1; absurd (0 < 1 + m); auto with arith.
intros n H0 H1; apply f_equal2 with ( f := @cons A ); auto with arith.
Qed.

Let iter_progression := fun m n => iter (progression m n).

Theorem iter_progression_app:
 forall a b n m,
 le m n ->
 b = next_n a m ->
  iter (progression a n) =
  g (iter (progression a m)) (iter (progression b (n - m))).
intros a b n m H H0; unfold iter_progression; rewrite (progression_app a b n m);
 (try apply iter_app); auto.
Qed.

Theorem length_progression: forall z n,  length (progression z n) = n.
intros z n; generalize z; elim n; simpl; auto.
Qed.

End Iterator.
Implicit Arguments iter [A B].
Implicit Arguments progression [A].
Implicit Arguments next_n [A].
Hint Unfold iter .
Hint Unfold progression .
Hint Unfold next_n .

Theorem iter_ext:
 forall (A B : Set) zero (f1 : A ->  B) f2 g l,
 (forall a, In a l ->  f1 a = f2 a) ->  iter zero f1 g l = iter zero f2 g l.
intros A B zero f1 f2 g l; elim l; simpl; auto.
intros a l0 H H0; apply f_equal2 with ( f := g ); auto.
Qed.

Theorem iter_map:
 forall (A B C : Set) zero (f : B ->  C) g (k : A ->  B) l,
  iter zero f g (map k l) = iter zero (fun x => f (k x)) g l.
intros A B C zero f g k l; elim l; simpl; auto.
intros; apply f_equal2 with ( f := g ); auto with arith.
Qed.

Theorem iter_comp:
 forall (A B : Set) zero (f1 f2 : A ->  B) g l,
 (forall a,  g a zero = a) ->
 (forall a b c,  g a (g b c) = g (g a b) c) ->
 (forall a b,  g a b = g b a) ->
  g (iter zero f1 g l) (iter zero f2 g l) =
  iter zero (fun x => g (f1 x) (f2 x)) g l.
intros A B zero f1 f2 g l g_zero g_trans g_sym; elim l; simpl; auto.
intros a l0 H; rewrite <- H; (repeat rewrite <- g_trans).
apply f_equal2 with ( f := g ); auto.
(repeat rewrite g_trans); apply f_equal2 with ( f := g ); auto.
Qed.

Theorem iter_com:
 forall (A B : Set) zero (f : A -> A ->  B) g l1 l2,
 (forall a,  g a zero = a) ->
 (forall a b c,  g a (g b c) = g (g a b) c) ->
 (forall a b,  g a b = g b a) ->
  iter zero (fun x => iter zero (fun y => f x y) g l1) g l2 =
  iter zero (fun y => iter zero (fun x => f x y) g l2) g l1.
intros A B zero f g l1 l2 H H0 H1; generalize l2; elim l1; simpl; auto;
 clear l1 l2.
intros l2; elim l2; simpl; auto with arith.
intros; rewrite H1; rewrite H; auto with arith.
intros a l1 H2 l2; case l2; clear l2; simpl; auto.
elim l1; simpl; auto with arith.
intros; rewrite H1; rewrite H; auto with arith.
intros b l2.
rewrite <- (iter_comp
             _ _ zero (fun x => f x a)
             (fun x => iter zero (fun (y : A) => f x y) g l1)); auto with arith.
rewrite <- (iter_comp
             _ _ zero (fun y => f b y)
             (fun y => iter zero (fun (x : A) => f x y) g l2)); auto with arith.
(repeat rewrite H0); auto.
apply f_equal2 with ( f := g ); auto.
(repeat rewrite <- H0); auto.
apply f_equal2 with ( f := g ); auto.
Qed.

Theorem iter_comp_const:
 forall (A B : Set) zero (f : A ->  B) g k l,
 k zero = zero ->
 (forall a b,  k (g a b) = g (k a) (k b)) ->
  k (iter zero f g l) = iter zero (fun x => k (f x)) g l.
intros A B zero f g k l H H0; elim l; simpl; auto.
intros a l0 H1; rewrite H0; apply f_equal2 with ( f := g ); auto.
Qed.

Lemma next_n_S: forall n m,  next_n S n m = plus n m.
intros n m; generalize n; elim m; clear n m; simpl; auto with arith.
intros m H n; case n; simpl; auto with arith.
rewrite H; auto with arith.
intros n1; rewrite H; simpl; auto with arith.
Qed.

Theorem progression_S_le_init:
 forall n m p, In p (progression S n m) ->  le n p.
intros n m; generalize n; elim m; clear n m; simpl; auto.
intros; contradiction.
intros m H n p [H1|H1]; auto with arith.
subst n; auto.
apply le_S_n; auto with arith.
Qed.

Theorem progression_S_le_end:
 forall n m p, In p (progression S n m) ->  lt p (n + m).
intros n m; generalize n; elim m; clear n m; simpl; auto.
intros; contradiction.
intros m H n p [H1|H1]; auto with arith.
subst n; auto with arith.
rewrite <- plus_n_Sm; auto with arith.
rewrite <- plus_n_Sm; auto with arith.
generalize (H (S n) p); auto with arith.
Qed.


Require Import List.
Require Import ZArith.
Require Import Nat.
Open Scope nat_scope.
(*This file defines repeat2 and some theorems about lists.*)

Section functions.
  Definition repeat2 (a b : Z) (p q : nat) :=
    repeat a p ++ repeat b q.
End functions.

Section basic.
  Theorem cons_nil A (x : A) l :
    x::l <> nil.
  Proof.
    discriminate.
  Qed.
  Theorem cons_eq A (x : A) l y l' :
    x::l = y::l' <-> x = y /\ l = l'.
  Proof.
    split ; intros H.
    inversion H ; firstorder.
    destruct H as [H1 H2].
    rewrite H1, H2 ; firstorder.
  Qed.
End basic.

Section app.
  Theorem last_indep A l (d d' : A) :
    l <> nil -> last l d = last l d'.
  Proof.
    induction l as [|x l].
    - intros H. contradiction (H eq_refl).
    - destruct l as [|y l].
      + intros _. exact eq_refl.
      + intros _.
        simpl in *.
        rewrite (IHl (cons_nil A y l)).
        exact eq_refl.
  Qed.
  Theorem last_app A l l' (d : A) :
    last (l++l') d = last l' (last l d).
  Proof.
    induction l as [|x l].
    - trivial.
    - destruct l.
      + destruct l' ;
          [exact eq_refl|
           exact (last_indep _ _ _ _ (cons_nil _ _ _))].
      + exact IHl.
  Qed.
  Theorem last_app_cons A l x l' (y : A) :
    last (l ++ (x::l')) y = last (x::l') y.
  Proof.
    exact (eq_trans (last_app _ _ _ _)
                    (last_indep _ _ _ _ (cons_nil _ _ _))).
  Qed.
  Theorem tl_app A (l l' : list A) :
    l <> nil -> tl (l ++ l') = (tl l) ++ l'.
  Proof.
    destruct l ; firstorder.
  Qed.
  Theorem hd_app A (x : A) l l' :
    hd x (l++l') = hd (hd x l') l.
  Proof.
    destruct l ; firstorder.
  Qed.
End app.

Section rev.
  Theorem last_rev A l (x : A) :
    last (rev l) x = hd x l.
  Proof.
    destruct l.
    - trivial.
    - simpl.
      rewrite last_app_cons.
      trivial.
  Qed.
  Theorem tl_rev A (l : list A) :
    tl (rev l) = rev (removelast l).
  Proof.
    destruct l as [|x l].
    - trivial.
    - generalize x.
      induction l.
      + trivial.
      + simpl.
        simpl in IHl.
        intros.
        rewrite tl_app, IHl.
        trivial.
        intros H.
        destruct (app_eq_nil _ _ H) as [_ H0].
        discriminate H0.
  Qed.
End rev.

Section map.
  Theorem removelast_map A B (f : A -> B) l :
    removelast (map f l) = map f (removelast l).
  Proof.
    intros.
    induction l.
    - trivial.
    - simpl.
      destruct l.
      + trivial.
      + simpl in *.
        rewrite IHl.
        trivial.
  Qed.
End map.

Section repeat.
  Theorem hd_repeat A (a b : A) n :
    hd a (repeat b n) = if n =? 0 then a else b.
  Proof.
    destruct n ; firstorder.
  Qed.
  Theorem last_repeat A (a b : A) n :
    last (repeat a n) b = if n =? 0 then b else a.
  Proof.
    destruct n ; simpl ; trivial.
    induction n ; simpl ; trivial.
  Qed.
  Theorem map_repeat A B (f : A -> B) a n :
    map f (repeat a n) = repeat (f a) n.
  Proof.
    induction n.
    - trivial.
    - simpl.
      rewrite IHn.
      trivial.
  Qed.
  Theorem repeat_plus A (a : A) n m :
    repeat a (n + m) = repeat a n ++ repeat a m.
  Proof.
    induction n.
    - trivial.
    - simpl.
      rewrite IHn.
      trivial.
  Qed.
  Theorem cons_repeat A (a : A) n :
    a :: repeat a n = repeat a (S n).
  Proof.
    trivial.
  Qed.
  Theorem tl_repeat A (a : A) n :
    tl (repeat a n) = repeat a (n - 1).
  Proof.
    destruct n ; simpl ; firstorder.
  Qed.
  Theorem repeat_S_app A (a : A) n l :
    repeat a (S n) ++ l = repeat a n ++ (a::l).
  Proof.
    simpl.
    induction n.
    - trivial.
    - simpl ; intros ; rewrite IHn ; firstorder.
  Qed.
  Theorem repeat_spec_hd A (a : A) l b n :
    a::l = repeat b n -> a = b.
  Proof.
    destruct n ; simpl in * ; intuition ; try discriminate.
    injection H.
    trivial.
  Qed.
  Theorem repeat_spec1 A (a b : A) l l' n :
    l ++ a::l' = repeat b n -> a = b.
  Proof.
    generalize l' n ; clear l' n.
    induction l.
    - simpl.
      destruct n.
      + discriminate.
      + simpl.
        rewrite cons_eq.
        firstorder.
    - simpl.
      destruct n.
      + discriminate.
      + simpl.
        rewrite cons_eq.
        firstorder.
  Qed.
  Theorem repeat_spec2 A (a b c : A) l1 l2 l3 n :
    l1 ++ a :: l2 ++ b :: l3 = repeat c n -> a = b.
  Proof.
    intros H.
    rewrite app_comm_cons in H.
    rewrite (repeat_spec1  _ _ _ _ _ _ H) in *.
    rewrite app_assoc in H.
    rewrite (repeat_spec1  _ _ _ _ _ _ H) in *.
    firstorder.
  Qed.
  Theorem cons_repeat_app A (a : A) n :
    a :: repeat a n = repeat a n ++ a::nil.
  Proof.
    rewrite <- repeat_S_app, app_nil_r.
    trivial.
  Qed.
  Theorem eq_repeat_iff A (a : A) l n :
    l = repeat a n -> l = repeat a (length l).
  Proof.
    generalize n ; clear n.
    induction l.
    - simpl ; tauto.
    - simpl.
      destruct n.
      + simpl ; discriminate.
      + simpl.
        intros H.
        injection H.
        intros H0 H1.
        rewrite <- (IHl _ H0), H1.
        trivial.
  Qed.
  (*TODO: change to actually use repeat2*)
  Theorem repeat2_fact1 A (a1 a2 a3 d1 d2 : A) l1 l2 l3 n1 n2 :
    a1 :: l1 ++ a2 :: l2 ++ a3 :: l3 = repeat d1 n1 ++ repeat d2 n2
    -> a1 = a2 \/ a2 = a3.
  Proof.
    intros H.
    destruct n1 as [|n1].
    - rewrite app_comm_cons in H.
      rewrite (repeat_spec2 _ _ _ _ _ _ _ _ H).
      intuition.
    - simpl in H.
      rewrite cons_eq in H.
      destruct H as [Had H].
      rewrite Had in *.
      generalize n1, H.
      clear.
      induction l1.
      + simpl in *.
        intros.
        destruct n1 ; simpl in *.
        * rewrite <- (app_nil_l (_::_)) in H.
          rewrite (repeat_spec2 _ _ _ _ _ _ _ _ H).
          intuition.
        * rewrite cons_eq in H.
          intuition.
      + destruct n1 ; simpl in *.
        * intros.
          rewrite app_comm_cons in H.
          rewrite (repeat_spec2 _ _ _ _ _ _ _ _ H).
          intuition.
        * rewrite cons_eq.
          firstorder.
  Qed.
End repeat.

Section firstn_skipn.
  Theorem firstn_id A (l : list A) n :
    length l <= n -> firstn n l = l.
  Proof.
    generalize n ; clear n.
    induction l.
    - destruct n ; simpl ; tauto.
    - destruct n ; simpl ; firstorder.
      rewrite IHl ; trivial.
      refine (le_S_n _ _ _).
      assumption.
  Qed.
  Theorem skipn_nil A (l : list A) n :
    length l <= n -> skipn n l = nil.
  Proof.
    generalize n ; clear n.
    induction l ; destruct n ; simpl.
    - tauto.
    - tauto.
    - intros H ; contradiction (Nat.nle_succ_0 _ H).
    - intros H ; exact (IHl _ (le_S_n _ _ H)).
  Qed.
  Theorem hd_firstn A (a : A) n l :
    hd a (firstn n l) = if n =? 0 then a else hd a l.
  Proof.
    destruct n ; [|destruct l] ; simpl ; intuition.
  Qed.
  Theorem hd_skipn A (a : A) n l :
    hd a (skipn n l) = nth n l a.
  Proof.
    generalize l ; clear l.
    induction n ; destruct l ; simpl ; intuition.
  Qed.
End firstn_skipn.

Section nth.
  Theorem nth_0 A (a : A) l :
    nth 0 l a = hd a l.
  Proof.
    destruct l ; simpl ; intuition.
  Qed.
  Theorem nth_repeat A (a : A) k n :
    nth k (repeat a n) a = a.
  Proof.
    generalize n ; clear n.
    induction k ; destruct n ; simpl ; firstorder.
  Qed.
  Theorem nth_app_repeat2 A p q l (a b : A) :
    p <= l
    -> l < p + q
    -> nth l (repeat a p ++ repeat b q) b = b.
  Proof.
    intros.
    rewrite app_nth2.
    all : rewrite repeat_length.
    rewrite nth_repeat ; trivial.
    assumption.
  Qed.
  Theorem nth_tl_tl A (a : A) n l :
      2 <= n -> nth (n - 2) (tl (tl l)) a = nth n l a.
  Proof.
    intros.
    destruct n as [|[|n]] ; simpl ; try omega.
    rewrite PeanoNat.Nat.sub_0_r.
    destruct l as [|x [|y l]].
    all : simpl ; firstorder.
    all : destruct n ; trivial.
  Qed.
  Theorem nth_firstn1 A (a : A) p q l :
    p < q -> nth p (firstn q l) a = nth p l a.
  Proof.
    generalize q l ; clear q l.
    induction p.
    - destruct q.
      + intros ; omega.
      + destruct l ; simpl ; trivial.
    - destruct q.
      + intros ; omega.
      + intros.
        destruct l ; simpl ; trivial.
        exact (IHp _ _ (lt_S_n _ _ H)).
  Qed.
  Theorem nth_last A (a : A) l :
    nth (length l - 1) l a = last l a.
  Proof.
    induction l.
    - trivial.
    - simpl.
      destruct l.
      + simpl ; trivial.
      + simpl.
        simpl in IHl.
        rewrite Nat.sub_0_r in IHl.
        assumption.
  Qed.
  Theorem last_firstn A (a : A) n l :
    n <= length l
    -> last (firstn n l) a = if n =? 0 then a else nth (n - 1) l a.
  Proof.
    generalize l ; clear l.
    induction n.
    - trivial.
    - destruct l.
      + simpl. omega.
      + simpl.
        intros.
        pose (H1 := IHn _ (le_S_n _ _ H)).
        rewrite H1.
        destruct l.
        * destruct n ; simpl in *; trivial ; omega.
        * destruct n ; trivial.
          rewrite Nat.sub_0_r in *.
          destruct n ; simpl ; trivial.
  Qed.
End nth.

Section rewrite_length.
  Theorem length_firstn A n (l : list A) :
    length (firstn n l) = min n (length l).
  Proof.
    generalize l ; clear l.
    induction n.
    - simpl ; trivial.
    - destruct l.
      + simpl ; trivial.
      + simpl.
        rewrite IHn.
        trivial.
  Qed.
  Theorem length_skipn A n (l : list A) :
    length (skipn n l) = length l - n.
  Proof.
    generalize l ; clear l.
    induction n.
    - simpl.
      trivial.
      intros.
      omega.
    - destruct l.
      + simpl ; trivial.
      + simpl.
        rewrite IHn.
        trivial.
  Qed.
  Theorem length_cons A (a : A) l :
    length (a::l) = 1 + length l.
  Proof.
    firstorder.
  Qed.
  Theorem length_tl A (l : list A) :
    length (tl l) = length l - 1.
  Proof.
    destruct l ; firstorder.
  Qed.
  Theorem not_nil_iff_length_pos A (l : list A) :
    l <> nil <-> length l > 0.
  Proof.
    destruct l ; simpl ; firstorder.
  Qed.
  Theorem length_removelast A (l : list A) :
    length (removelast l) = length l - 1.
  Proof.
    destruct l as [|a l].
    - trivial.
    - generalize a.
      induction l.
      + trivial.
      + simpl.
        simpl in IHl.
        rewrite IHl.
        intros.
        omega.
  Qed.
End rewrite_length.

Hint Rewrite
     length_cons
     length_tl
     not_nil_iff_length_pos
     map_length
     rev_length
     app_length
     repeat_length
     length_removelast
     length_firstn
     length_skipn
: list.
Tactic Notation "simpl_length" :=
  repeat (simpl || autorewrite with list).
Tactic Notation "simpl_length" "in" hyp(H) :=
  repeat (simpl in H || autorewrite with list in H).
Ltac tac_length := simpl_length ; try omega.

Hint Rewrite
     hd_app
     hd_repeat
: rewritehd.
Tactic Notation "simpl_hd" :=
  repeat (simpl || autorewrite with rewritehd).
Tactic Notation "simpl_hd" "in" hyp(H) :=
  repeat (simpl in H || autorewrite with rewritehd in H).