(**
   型付インタープリタ

   https://www.math.nagoya-u.ac.jp/~garrigue/lecture/2011_AW/coq7.pdf
 *)

From mathcomp Require Import all_ssreflect.

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

Inductive exp : Type -> Type :=
| Nat : nat -> exp nat
| Pair : forall t1 t2, exp t1 -> exp t2 -> exp (t1 * t2)
| App : forall t1 t2, exp (t1 -> t2) -> exp t1 -> exp t2
| Plus : exp (nat -> nat -> nat).

Fixpoint eval (t : Type) (e : exp t) : t :=
  match e with
  | Nat n => n
  | Pair t1 t2 a b => (eval a, eval b) (* (@eval t1 a, @eval t2 b) *)
  | App t1 t2 f g => (eval f) (eval g) (* (@eval (t1 -> t2) f) (@eval t1 g) *)
  | Plus => addn
  end.

Compute eval (App (App Plus (Nat 1)) (Nat 2)). (* 3 *)

Inductive evaluate : forall {t : Type}, exp t -> t -> Prop :=
| e_nat n : evaluate (Nat n) n
| e_pair t1 t2 (a : exp t1) (b : exp t2) (a' : t1) (b' : t2) :
    evaluate a a' -> evaluate b b' -> evaluate (Pair a b) (a' , b')
| e_app t1 t2 (f : exp (t1 -> t2)) (g : exp t1) (f' : t1 -> t2) (g' : t1) :
    evaluate f f' -> evaluate g g' -> evaluate (App f g) (f' g')
| e_plus : evaluate Plus plus.
Hint Constructors evaluate.

Goal evaluate (App (App Plus (Nat 1)) (Nat 2)) (plus 1 2).
Proof.
  apply: e_app.
  - by apply: e_app.
  - done.
Qed.

Lemma eval_eval (t : Type) (e : exp t) (v : t) : evaluate e v <-> eval e = v.
Proof.
  split.
  - elim=> //=.
    + move=> t1 t2 a b a' b' H1 H2 H3 H4.
        by subst.
    + move=> t1 t2 a b a' b' H1 H2 H3 H4.
        by subst.
  - elim: e v => [n v H | t1 t2 e1 H1 e2 H2 v IH | t1 t2 f Hf g Hg v IH | v H];
                   subst => //=.
    + apply: e_pair.
      * by apply: H1.
      * by apply: H2.
    + apply: e_app.
      * by apply: Hf.
      * by apply: Hg.
Qed.

Require Import Program.
Program Fixpoint eval' (t : Type) (e : exp t) : {v | evaluate e v} :=
  match e with
  | Nat n => n
  | Pair t1 t2 a b => (eval' a, eval' b)
  | App t1 t2 f g => (eval' f) (eval' g)
  | Plus => addn
  end.
(* 証明責務はなし。 *)

Compute (eval (App (App Plus (Nat 1)) (Nat 2))).
Compute (eval' (App (App Plus (Nat 1)) (Nat 2))).

(** END **)


Require Export GeoCoq.Tarski_dev.Annexes.circles.
Require Export GeoCoq.Tarski_dev.Annexes.half_angles.
Require Export GeoCoq.Tarski_dev.Ch12_parallel_inter_dec.

Import circles.

Section Inscribed_angle.

Context `{TE:Tarski_euclidean}.

(** The sum of the angles of a triangle is the flat angle. *)

Lemma trisuma__bet : forall A B C D E F, TriSumA A B C D E F -> Bet D E F.
Proof.
  apply alternate_interior__triangle.
  unfold alternate_interior_angles_postulate.
  apply l12_21_a.
Qed.

Lemma bet__trisuma : forall A B C D E F, Bet D E F -> A <> B -> B <> C -> A <> C -> D <> E -> E <> F ->
  TriSumA A B C D E F.
Proof.
  intros A B C D E F HBet; intros.
  destruct (ex_trisuma A B C) as [P [Q [R HTri]]]; auto.
  apply conga_trisuma__trisuma with P Q R; trivial.
  assert (Hd := HTri).
  apply trisuma_distincts in Hd; spliter.
  apply conga_line; auto.
  apply (trisuma__bet A B C); trivial.
Qed.

Lemma right_saccheris : forall A B C D, Saccheri A B C D -> Per A B C.
Proof.
  apply postulates_in_euclidean_context; simpl; repeat (try (left; reflexivity); right).
Qed.

Lemma not_obtuse_saccheris : ~ hypothesis_of_obtuse_saccheri_quadrilaterals.
Proof.
  apply not_oah; right.
  unfold hypothesis_of_right_saccheri_quadrilaterals; apply right_saccheris.
Qed.

Lemma suma123231__sams : forall A B C D E F, SumA A B C B C A D E F -> SAMS D E F C A B.
Proof. exact (t22_20 not_obtuse_saccheris). Qed.

Lemma bet_suma__suma : forall A B C D E F G H I, G <> H -> H <> I ->
  Bet G H I -> SumA A B C B C A D E F -> SumA D E F C A B G H I.
Proof.
  intros A B C D E F G H I HGH HHI HBet HSuma.
  suma.assert_diffs.
  destruct (bet__trisuma A B C G H I) as [D' [E' [F' []]]]; auto.
  apply (conga3_suma__suma D' E' F' C A B G H I); try apply conga_refl; auto.
  apply (suma2__conga A B C B C A); assumption.
Qed.

Lemma suma__suppa : forall A B C D E F, SumA A B C B C A D E F -> SuppA D E F C A B.
Proof.
  intros A B C D E F HSuma.
  suma.assert_diffs.
  destruct (point_construction_different A B) as [A' []].
  apply bet_suma__suppa with A B A'; trivial.
  apply bet_suma__suma; auto.
Qed.

Lemma high_school_exterior_angle_theorem : forall A B C B', A <> B -> B <> C -> A <> C -> A <> B' ->
  Bet B A B' -> SumA A B C B C A C A B'.
Proof.
  intros A B C B'; intros.
  destruct (ex_suma A B C B C A) as [D [E [F HSuma]]]; auto.
  apply (conga3_suma__suma A B C B C A D E F); try apply conga_refl; auto.
  apply suppa2__conga123 with C A B.
    apply suma__suppa; assumption.
    apply suppa_sym, suppa_left_comm, bet__suppa; auto.
Qed.

(** If A, B and C are points on a circle where the line AB is a diameter of the circle,
    then the angle ACB is a right angle. *)

Lemma thales_theorem : forall A B C M,
  Midpoint M A B -> Cong M A M C -> Per A C B.
Proof.
  apply rah__thales_postulate.
  unfold postulate_of_right_saccheri_quadrilaterals; apply right_saccheris.
Qed.

(** In a right triangle, the midpoint of the hypotenuse is the circumcenter. *)

Lemma thales_converse_theorem : forall A B C M,
  Midpoint M A B -> Per A C B -> Cong M A M C.
Proof.
  apply thales_postulate__thales_converse_postulate.
  unfold thales_postulate; apply thales_theorem.
Qed.

Lemma thales_converse_theorem_1 : forall A B C O, A <> C -> B <> C ->
  Per A C B -> Cong O A O B -> Cong O A O C -> Coplanar A B C O -> Midpoint O A B.
Proof.
  intros A B C O HAC HBC HPer HCong1 HCong2 HCop.
  destruct (midpoint_existence A B) as [M HM].
  assert (M = O); [|subst; apply HM].
  suma.assert_diffs.
  apply (cong4_cop2__eq A C B); Cong; [|Cop..].
  apply cong_commutativity, thales_converse_theorem with B; assumption.
Qed.

Lemma bet_cong__ghalfa : forall A B C B', A <> B -> B <> C -> A <> B' ->
  Bet B A B' -> Cong A B A C -> gHalfA A B C C A B'.
Proof.
  intros A B C B' HAB HBC HAB' HBet HCong.
  apply ghalfa_chara; split.
    apply cong__acute; auto.
  suma.assert_diffs.
  apply (conga3_suma__suma A B C B C A C A B'); try apply conga_refl; auto.
    apply high_school_exterior_angle_theorem; auto.
  apply conga_left_comm, l11_44_1_a; Cong.
Qed.

(** If the angle ACB is inscribed in a circle of center O and
    C, O lie on the same side of AB, then this angle is acute. *)

Lemma onc3_os__acute : forall O P A B C,
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> OS A B O C ->
  Acute A C B.
Proof.
  intros O P A B C HA HB HC HOS.
  destruct (midpoint_existence A B) as [M HM].
  assert (HNCol : ~ Col A B C) by (eapply one_side_not_col124, HOS).
  assert (HLt : Lt M A M C).
  { assert (HNCol1 : ~ Col A B O) by (eapply one_side_not_col123, HOS).
    assert (M <> O) by (intro; treat_equalities; apply HNCol1; Col).
    assert (O <> C) by (intro; treat_equalities; auto).
    suma.assert_diffs.
    assert (Cong O A O C) by (apply (onc2__cong O P); assumption).
    destruct (angle_partition M O C); auto.
    - assert (HMO := H).
      clear H.
      destruct (l8_18_existence M O C) as [H []].
      { intro.
        destruct (acute_col__out M O C) as [_ [_ [HBet|HBet]]]; auto.
        - apply l9_9_bis in HOS.
          apply HOS.
          repeat split; Col.
          exists M; split; Col.
        - apply (le__nlt O C O M); Le.
          apply (cong2_lt__lt O M O P); Cong.
          apply bet_inc2__incs with A B; Circle; Between.
      }
      assert (Perp O M A B) by (apply mid_onc2__perp with P; auto).
      assert (HOS1 : OS A B C H).
      { apply l12_6, par_not_col_strict with C; Col.
        apply l12_9 with O M; Perp; [|Cop| |Cop].
          apply coplanar_perm_5, col_cop__cop with B; Col; Cop.
          apply coplanar_perm_5, col_cop__cop with A; Col; Cop.
      }
      assert (M <> H) by (intro; subst; apply one_side_not_col124 in HOS1; apply HOS1; Col).
      assert (Per M H C) by (apply perp_per_1, perp_left_comm, perp_col with O; Col).
      apply lt_transitivity with H C; [|suma.assert_diffs; apply l11_46; auto].
      apply cong_lt_per2__lt_1 with O O; Cong.
        apply l8_2, per_col with M; Col; Perp.
        apply perp_per_1, perp_left_comm, perp_col1 with B; Col.
      apply bet__lt1213; auto; apply out2__bet.
        apply (acute_col_perp__out C); [apply acute_sym|..]; Col; Perp.
        apply (l9_19 A B); Col; apply one_side_transitivity with C; assumption.
    - apply lt_transitivity with O C; [|apply l11_46; auto].
      apply (cong2_lt__lt M A O A); Cong.
      apply l11_46; auto.
      left.
      apply mid_onc2__per with P B; auto.
  }
  destruct HLt as [[C' [HBet HCong]] HNCong].
  exists A, C', B; split.
    apply thales_theorem with M; trivial.
  suma.assert_diffs.
  assert (C <> C') by (intro; subst; apply HNCong, HCong).
  apply os3__lta.
  - apply one_side_transitivity with M.
      apply invert_one_side, out_one_side; [Col|apply l6_6, bet_out; Between].
      apply out_one_side; [left; intro; apply HNCol; ColR|apply l6_6, bet_out; Between].
  - apply out_one_side_1 with M; Col; apply l6_6, bet_out; auto.
  - apply one_side_transitivity with M.
      apply invert_one_side, out_one_side; [Col|apply l6_6, bet_out; Between].
      apply out_one_side; [left; intro; apply HNCol; ColR|apply l6_6, bet_out; Between].
Qed.

Lemma inscribed_angle_aux : forall O P A B C,
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P ->
  OS A B O C -> TS O C A B ->
  gHalfA A C B A O B.
Proof.
  intros O P A B C HA HB HC HOS HTS.
  destruct (segment_construction C O O P) as [C' []].
  suma.assert_diffs.
  assert (O <> C') by (intro; treat_equalities; auto).
  assert (HCong := (onc2__cong O P)).
  apply suma_preserves_ghalfa with A C C' C' C B A O C' C' O B.
    apply (onc3_os__acute O P); assumption.
    apply ts__suma, invert_two_sides, col_two_sides with O; Side; Col.
    apply ts__suma, invert_two_sides, col_two_sides with C; Col.
    apply ghalfa_out4__ghalfa with A O A C'; try apply out_trivial; auto;
      [apply l6_6, bet_out|apply ghalfa_left_comm, bet_cong__ghalfa]; auto.
    apply ghalfa_out4__ghalfa with O B C' B; try apply out_trivial; auto;
      [apply l6_6, bet_out|apply ghalfa_right_comm, bet_cong__ghalfa]; auto.
Qed.

Lemma inscribed_angle_aux1 : forall O P A B C,
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P ->
  OS A B O C -> OS O C A B ->
  gHalfA A C B A O B.
Proof.
  assert (Haux : forall O P A B C, OnCircle A O P -> OnCircle B O P -> OnCircle C O P ->
  OS A B O C -> OS O C A B -> OS O B A C -> gHalfA A C B A O B).
  { intros O P A B C HA HB HC HOS1 HOS2 HOS3.
    destruct (chord_completion O P C O) as [C' [HC' HBet ]]; Circle.
    suma.assert_diffs.
    assert (C' <> O) by (intro; treat_equalities; auto).
    assert (TS O B A C').
    { apply l9_8_2 with C; [|Side].
      apply one_side_not_col124 in HOS3.
      repeat split.
        Col.
        intro; apply HOS3; ColR.
      exists O; split; Col.
    }
    assert (HCong := (onc2__cong O P)).
    apply acute_ghalfa2_sams_suma2__ghalfa123 with B C O A C O B O C' A O C'.
    - repeat split; auto.
        right; intro; assert_cols; assert_ncols; Col.
      exists C'.
      split; CongA.
      repeat split; [Side| |Cop].
      apply l9_9_bis, invert_one_side, one_side_symmetry, os_ts1324__os; [|Side].
      apply col_one_side with C; Col; Side.
    - apply (onc3_os__acute O P); assumption.
    - exists O.
      repeat (split; CongA); [|Cop].
      apply l9_9, invert_two_sides, l9_31; Side.
    - exists C'.
      repeat (split; CongA); [Side|Cop].
    - apply ghalfa_left_comm, bet_cong__ghalfa; auto.
    - apply ghalfa_left_comm, bet_cong__ghalfa; auto.
  }
  intros O P A B C HA HB HC HOS1 HOS2.
  assert_ncols.
  destruct (cop__one_or_two_sides O B A C) as [HTS|]; Col; Cop.
    apply ghalfa_comm, Haux with P; auto; [..|apply one_side_symmetry, os_ts1324__os]; Side.
    apply Haux with P; assumption.
Qed.

(** Euclid Book III Prop 20:
    In a circle the angle at the centre is double of the angle at the circumference,
    when the angles have the same circumference as base. *)

Lemma inscribed_angle : forall O P A B C,
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> OS A B O C ->
  gHalfA A C B A O B.
Proof.
  intros O P A B C HA HB HC HOS.
  assert (HCong := (onc2__cong O P)).
  destruct (col_dec A O C).
  { suma.assert_diffs.
    assert (Bet C O A) by (apply col_inc_onc2__bet with O P; Col; Circle).
    assert (O <> C) by (intro; treat_equalities; auto).
    apply ghalfa_right_comm, ghalfa_out4__ghalfa with O B B A; try apply out_trivial; auto.
      apply l6_6, bet_out; auto.
    apply bet_cong__ghalfa; auto.
  }
  destruct (col_dec B O C).
  { suma.assert_diffs.
    assert (Bet C O B) by (apply col_inc_onc2__bet with O P; Col; Circle).
    assert (O <> C) by (intro; treat_equalities; auto).
    apply ghalfa_left_comm, ghalfa_out4__ghalfa with O A A B; try apply out_trivial; auto.
      apply l6_6, bet_out; auto.
    apply bet_cong__ghalfa; auto.
  }
  destruct (cop__one_or_two_sides O C A B); Cop.
    apply inscribed_angle_aux with P; assumption.
    apply inscribed_angle_aux1 with P; assumption.
Qed.

Lemma diam_onc2_ts__suppa : forall O P A B C C',
  OnCircle A O P -> OnCircle B O P -> Diam C C' O P -> TS A B C C' ->
  SuppA A C B A C' B.
Proof.
  intros O P A B C C' HA HB [HBet [HC HC']] HTS.
  suma.assert_diffs.
  assert (HCong := onc2__cong O P).
  assert (HMid : Midpoint O C C') by (split; Cong).
  assert (C <> C') by (intro; treat_equalities; auto).
  assert (HNColA : ~ Col C C' A) by (apply (onc3__ncol O P); auto).
  assert (HNColB : ~ Col C C' B) by (apply (onc3__ncol O P); auto).
  assert (HSumaA : SumA A C C' C C' A C A C') by (apply cong_mid__suma with O; auto).
  assert (HSumaB : SumA B C C' C C' B C B C') by (apply cong_mid__suma with O; auto).
  assert (Per C A C') by (apply thales_theorem with O; auto).
  assert (Per C B C') by (apply thales_theorem with O; auto).
  assert (HSuma : SumA C A C' C B C' C O C') by (suma.assert_diffs; apply bet_per2__suma; auto).
  apply bet_suma__suppa with C O C'; trivial.
  destruct (ex_suma C A C' C' C B) as [D [E [F HSuma1]]]; auto.
  assert (HTS2 : TS C C' A B) by (apply (chord_intersection O P); assumption).
  assert (HTS3 : TS C' C A B) by (apply invert_two_sides, HTS2).
  assert (Acute C' C A).
  { suma.assert_diffs; apply acute_out2__acute with O A.
      apply l6_6, bet_out; auto.
      apply out_trivial; auto.
      apply cong__acute; auto.
  }
  assert (Acute C' C B).
  { suma.assert_diffs; apply acute_out2__acute with O B.
      apply l6_6, bet_out; auto.
      apply out_trivial; auto.
      apply cong__acute; auto.
  }
  assert (Acute C C' A).
  { suma.assert_diffs; apply acute_out2__acute with O A.
      apply l6_6, bet_out; Between.
      apply out_trivial; auto.
      apply cong__acute; auto.
  }
  assert (Acute C C' B).
  { suma.assert_diffs; apply acute_out2__acute with O B.
      apply l6_6, bet_out; Between.
      apply out_trivial; auto.
      apply cong__acute; auto.
  }
  assert (HSuma2 : SumA A C B A C' C D E F).
    apply suma_sym, suma_assoc_1 with A C C' C' C B C A C'; SumA.
  assert (HSAMS : SAMS A C B A C' C).
    apply sams_sym, sams_assoc_1 with A C C' C' C B C A C'; SumA.
  apply suma_assoc_1 with A C' C C C' B D E F; [SumA..|].
  apply suma_assoc_2 with C A C' B C C' C B C'; SumA.
Qed.

(** In a circle the angle at the centre is double of the angle at the circumference. *)

Lemma inscribed_angle_1 : forall O P A B C, A <> B -> B <> C -> A <> C ->
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> Coplanar A B C O ->
  SumA A C B A C B A O B.
Proof.
  intros O P A B C HAB HBC HAC HA HB HC HCop.
  assert (~ Col A B C) by (apply (onc3__ncol O P); auto).
  destruct (col_dec A B O).
  { assert (Midpoint O A B) by (apply col_onc2__mid with P; auto).
    assert (Per A C B) by (apply thales_theorem with O; auto; apply cong_transitivity with O P; Cong).
    suma.assert_diffs; apply bet_per2__suma; Between.
  }
  destruct (cop__one_or_two_sides A B O C); Col; Cop.
  - destruct (chord_completion O P C O) as [C' []]; Circle.
    assert (TS A B C' C) by (apply l9_2, bet_ts__ts with O; Side).
    assert (SuppA A C' B A C B).
      apply (diam_onc2_ts__suppa O P); [..|repeat split|]; Between.
    apply (suma_suppa2__suma A C' B A C' B); trivial.
    apply ghalfa__suma, inscribed_angle with P; trivial.
    exists C; split; trivial.
  - apply ghalfa__suma, inscribed_angle with P; trivial.
Qed.

(** If two angles ACB and ADB are inscribed in the same circle,
    then they are either congruent or supplementary. *)

Lemma cop2_onc4__or_conga_suppa : forall O P A B C C',
  A <> B -> B <> C -> A <> C -> B <> C' -> A <> C' ->
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> OnCircle C' O P ->
  Coplanar A B C O -> Coplanar A B C' O ->
  CongA A C B A C' B \/ SuppA A C B A C' B.
Proof.
  intros O P A B C C'; intros.
  apply suma2__or_conga_suppa with A O B; trivial; apply inscribed_angle_1 with P; assumption.
Qed.

(** If the angle ACB is inscribed in a circle of center O and
    C, O lie on opposite sides of AB, then this angle is obtuse. *)

Lemma onc3_ts__obtuse : forall O P A B C,
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> TS A B O C ->
  Obtuse A C B.
Proof.
  intros O P A B C HA HB HC HTS.
  destruct (chord_completion O P C O) as [C' []]; Circle.
  assert (TS A B C C') by (apply bet_ts__ts with O; Side).
  apply (acute_suppa__obtuse A C' B).
    apply (onc3_os__acute O P); trivial; exists C; split; Side.
  apply (diam_onc2_ts__suppa O P); Side.
  repeat split; Between.
Qed.

(** Euclid Book III Prop 21:
    In a circle the angles in the same segment are equal to one another. *)

Lemma cop_onc4_os__conga : forall O P A B C C',
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> OnCircle C' O P ->
  OS A B C C' -> Coplanar A B C O ->
  CongA A C B A C' B.
Proof.
  intros O P A B C C' HA HB HC HC' HOS HCop.
  assert_ncols.
  destruct (col_dec A B O).
  { suma.assert_diffs.
    assert (Midpoint O A B) by (apply col_onc2__mid with P; auto).
    apply l11_16; auto; apply thales_theorem with O; Col; apply cong_transitivity with O P; Cong.
  }
  destruct (cop__one_or_two_sides A B O C); Col; Cop.
  - suma.assert_diffs; destruct (cop2_onc4__or_conga_suppa O P A B C C') as [|Habs]; auto.
      apply coplanar_trans_1 with C; Col; Cop.
    exfalso.
    apply (nlta A C' B), acute_obtuse__lta.
      apply (obtuse_suppa__acute A C B); [apply (onc3_ts__obtuse O P)|]; trivial.
      apply (onc3_ts__obtuse O P); trivial; apply l9_2, l9_8_2 with C; Side.
  - apply ghalfa2__conga_2 with A O B; apply inscribed_angle with P; trivial.
    apply one_side_transitivity with C; Side.
Qed.

(** Euclid Book III Prop 22:
    The opposite angles of quadrilaterals in circles are equal to two right angles. *)

Lemma cop_onc4_ts__suppa : forall O P A B C C',
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> OnCircle C' O P ->
  TS A B C C' -> Coplanar A B C O ->
  SuppA A C B A C' B.
Proof.
  intros O P A B C C' HA HB.
  revert C C'.
  assert (Haux : forall C C', OnCircle C O P -> OnCircle C' O P -> TS A B C C' -> OS A B O C ->
    SuppA A C B A C' B).
  { intros C C' HC HC' HTS HOS.
    suma.assert_diffs.
    assert (~ Col C A B) by (destruct HTS; assumption).
    assert (Coplanar A B C' O) by (apply coplanar_trans_1 with C; Cop).
    destruct (cop2_onc4__or_conga_suppa O P A B C C') as [Habs|]; Cop.
    exfalso.
    assert (HLta : LtA A C B A C' B); [|destruct HLta as [_ HN]; apply HN, Habs].
    apply acute_obtuse__lta.
      apply (onc3_os__acute O P); assumption.
    apply (onc3_ts__obtuse O P); trivial.
    apply l9_8_2 with C; Side.
  }
  intros C C' HC HC' HTS HCop.
  assert (~ Col C A B) by (destruct HTS; assumption).
  destruct (col_dec A B O).
  { suma.assert_diffs.
    assert (Midpoint O A B) by (apply col_onc2__mid with P; auto).
    destruct HTS as [_ []].
    apply per2__suppa; auto; apply thales_theorem with O; trivial; apply onc2__cong with P; assumption.
  }
  destruct (cop__one_or_two_sides A B O C); Col; Cop.
  apply suppa_sym, Haux; [..|exists C; split]; Side.
Qed.

(** If the angle ACB is acute and inscribed in a circle of center O,
    then C and O lie on the same side of AB. *)

Lemma acute_cop_onc3__os : forall O P A B C, A <> B ->
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> Coplanar A B C O -> Acute A C B ->
  OS A B O C.
Proof.
  intros O P A B C HAB HA HB HC HCop HAcute.
  suma.assert_diffs.
  assert (~ Col A B C) by (apply (onc3__ncol O P); auto).
  apply coplanar_perm_1 in HCop.
  apply cop_nts__os; Col; intro Habs; apply (nlta A C B).
  - apply acute_per__lta; auto.
    apply thales_theorem with O; trivial.
      apply col_onc2__mid with P; Col.
      apply (onc2__cong O P); assumption.
  - apply acute_obtuse__lta; trivial.
    apply (onc3_ts__obtuse O P); assumption.
Qed.

(** If the angle ACB is obtuse and inscribed in a circle of center O,
    then C and O lie on opposite sides of AB. *)

Lemma cop_obtuse_onc3__ts : forall O P A B C,
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> Coplanar A B C O -> Obtuse A C B ->
  TS A B O C.
Proof.
  intros O P A B C HA HB HC HCop HObtuse.
  suma.assert_diffs.
  assert (~ Col A B C) by (apply (onc3__ncol O P); auto).
  apply coplanar_perm_1 in HCop.
  apply cop_nos__ts; Col; intro Habs; apply (nlta A C B).
  - apply obtuse_per__lta; auto.
    apply thales_theorem with O; trivial.
      apply col_onc2__mid with P; Col.
      apply (onc2__cong O P); assumption.
  - apply acute_obtuse__lta; trivial.
    apply (onc3_os__acute O P); assumption.
Qed.

(** If the angles ACB and ADB are congruent and inscribed in the same circle,
    then C and D lie on the same side of AB. *)

Lemma conga_cop2_onc4__os : forall O P A B C D, ~ Col A B O ->
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> OnCircle D O P ->
  Coplanar A B O C -> Coplanar A B O D -> CongA A C B A D B ->
  OS A B C D.
Proof.
  intros O P A B C D HNCol HA HB HC HD HCopC HCopD HConga.
  suma.assert_diffs.
  destruct (angle_partition A C B) as [HAcute|[HPer|HObtuse]]; auto.
  - apply one_side_transitivity with O; [apply one_side_symmetry|];
      apply acute_cop_onc3__os with P; Cop.
    apply (acute_conga__acute A C B); assumption.
  - exfalso.
    apply HNCol, col_permutation_1, midpoint_col.
    assert (HCong := onc2__cong O P).
    apply thales_converse_theorem_1 with C; Cop.
  - exists O; split; apply l9_2; apply cop_obtuse_onc3__ts with P; Cop.
    apply (conga_obtuse__obtuse A C B); assumption.
Qed.

(** If the angles ACB and ADB are supplementary and inscribed in the same circle,
    then C and D lie on opposite sides of AB. *)

Lemma cop2_onc4_suppa__ts : forall O P A B C D, ~ Col A B O ->
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> OnCircle D O P ->
  Coplanar A B O C -> Coplanar A B O D -> SuppA A C B A D B ->
  TS A B C D.
Proof.
  intros O P A B C D HNCol HA HB HC HD HCopC HCopD HSuppa.
  suma.assert_diffs.
  destruct (angle_partition A C B) as [HAcute|[HPer|HObtuse]]; auto.
  - apply l9_8_2 with O.
      apply cop_obtuse_onc3__ts with P; Cop; apply (acute_suppa__obtuse A C B); assumption.
      apply acute_cop_onc3__os with P; Cop.
  - exfalso.
    apply HNCol, col_permutation_1, midpoint_col.
    assert (HCong := onc2__cong O P).
    apply thales_converse_theorem_1 with C; Cop.
  - apply l9_2, l9_8_2 with O.
      apply cop_obtuse_onc3__ts with P; Cop.
    apply acute_cop_onc3__os with P; Cop; apply (obtuse_suppa__acute A C B); assumption.
Qed.

(** Non degenerated triangles can be circumscribed. *)

Lemma triangle_circumscription : forall A B C, ~ Col A B C ->
  exists CC : Tpoint, Cong A CC B CC /\ Cong A CC C CC /\ Coplanar A B C CC.
Proof.
  apply postulates_in_euclidean_context; simpl; repeat (try (left; reflexivity); right).
Qed.

(** Euclid Book III Prop 23:
    On the same straight line there cannot be constructed
    two similar and unequal segments of circles on the same side. *)

Lemma conga_cop_onc6_os__eqc : forall A B C D O P O' P',
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P -> Coplanar A B C O ->
  OnCircle A O' P' -> OnCircle B O' P' -> OnCircle D O' P' -> Coplanar A B D O' ->
  OS A B C D -> CongA A C B A D B ->
  EqC O P O' P'.
Proof.
  intros A B C D O P O' P' HA HB HC HCop HA' HB' HD' HCop' HOS HConga.
  apply eqc_chara.
  assert (O = O'); [|split; trivial; subst O'; apply cong_transitivity with O A; Cong].
  assert (HNCol : ~ Col A B C) by (apply one_side_not_col123 with D, HOS).
  assert (HCong := onc2__cong O P).
  assert (HCong' := onc2__cong O' P').
  destruct (col_dec A B O) as [|HNCol1].
  { suma.assert_diffs.
    assert (Midpoint O A B) by (apply col_onc2__mid with P; assumption).
    apply (l7_17 A B); trivial.
    apply thales_converse_theorem_1 with D; auto.
    apply (l11_17 A C B); trivial.
    apply thales_theorem with O; auto.
  }
  assert (HNCol' : ~ Col A B D) by (apply one_side_not_col124 with C, HOS).
  destruct (midpoint_existence A B) as [M HM].
  assert (HOS1 : OS A B O O').
  { suma.assert_diffs; destruct (angle_partition A C B) as [HAcute|[HPer|HObtuse]]; auto.
    - apply one_side_transitivity with C;
        [|apply one_side_transitivity with D; trivial; apply one_side_symmetry].
        apply acute_cop_onc3__os with P; auto.
      apply acute_cop_onc3__os with P'; auto.
      apply (acute_conga__acute A C B); assumption.
    - exfalso.
      apply HNCol1, col_permutation_1, midpoint_col.
      apply thales_converse_theorem_1 with C; auto.
    - exists C; split; [|apply l9_2, l9_8_2 with D; [apply l9_2|Side]].
        apply cop_obtuse_onc3__ts with P; auto.
      apply cop_obtuse_onc3__ts with P'; auto.
      apply (conga_obtuse__obtuse A C B); assumption.
  }
  assert (HNCol1' : ~ Col A B O') by (apply one_side_not_col124 with O, HOS1).
  destruct (bet_cop_onc2__ex_onc_os_out O P A B C M) as [C1]; Between; Col; [suma.assert_diffs; auto..|].
  destruct (bet_cop_onc2__ex_onc_os_out O' P' A B D M) as [D1]; Between; Col; [suma.assert_diffs; auto..|].
  spliter.
  assert (HNCol2 : ~ Col A B C1) by (apply one_side_not_col124 with C; assumption).
  assert (HOut : Out M C1 D1).
  { apply (l9_19 A B); [Col| |
      apply one_side_transitivity with C; [|apply one_side_transitivity with D]; Side].
    assert (O <> M) by (intro; subst; apply HNCol1; Col).
    assert (O' <> M) by (intro; subst; apply HNCol1'; Col).
    assert (Col O O' M); [|ColR].
    suma.assert_diffs; apply (cop_per2__col A); auto;
      [|apply mid_onc2__per with P B; auto|apply mid_onc2__per with P' B; auto].
    apply coplanar_trans_1 with B; Col; [|Cop].
    apply coplanar_trans_1 with C; Col; [Cop|].
    apply coplanar_perm_12, coplanar_trans_1 with D; Col; Cop.
  }
  destruct (eq_dec_points C1 D1).
  { subst D1.
    suma.assert_diffs.
    apply (cong4_cop2__eq A B C1); Cong; exists M; left; split; Col.
  }
  assert (HNCol2' : ~ Col A B D1) by (apply one_side_not_col124 with D; assumption).
  assert (CongA A C1 B A C B) by (apply (cop_onc4_os__conga O P); Side; exists M; left; split; Col).
  assert (CongA A D1 B A D B) by (apply (cop_onc4_os__conga O' P'); Side; exists M; left; split; Col).
  assert (Out A B M) by (suma.assert_diffs; apply l6_6, bet_out; Between).
  assert (Out B A M) by (suma.assert_diffs; apply l6_6, bet_out; Between).
  assert (HH := HOut).
  destruct HH as [HMC1 [HMD1 [HBet|HBet]]]; exfalso.
  - apply (lta_not_conga A D B A C B); CongA.
    apply (conga_preserves_lta A D1 B A C1 B); trivial.
    assert (Out D1 M C1) by (apply l6_6, bet_out; Between).
    apply os3__lta; [|apply one_side_symmetry, l9_19 with M; Col|];
      apply one_side_transitivity with M.
      apply invert_one_side, out_one_side; Col.
      apply out_one_side; trivial; left; intro; apply HNCol2'; ColR.
      apply invert_one_side, out_one_side; Col.
      apply out_one_side; trivial; left; intro; apply HNCol2'; ColR.
  - apply (lta_not_conga A C B A D B); trivial.
    apply (conga_preserves_lta A C1 B A D1 B); trivial.
    assert (Out C1 M D1) by (apply l6_6, bet_out; Between).
    apply os3__lta; [|apply l9_19 with M; Col|];
      apply one_side_transitivity with M.
      apply invert_one_side, out_one_side; Col.
      apply out_one_side; trivial; left; intro; apply HNCol2; ColR.
      apply invert_one_side, out_one_side; Col.
      apply out_one_side; trivial; left; intro; apply HNCol2; ColR.
Qed.

Lemma conga_cop_onc3_os__onc : forall A B C D O P,
  OnCircle A O P -> OnCircle B O P -> OnCircle C O P ->
  Coplanar A B C O -> OS A B C D -> CongA A C B A D B ->
  OnCircle D O P.
Proof.
  intros A B C D O P HA HB HC HCop HOS HConga.
  destruct (triangle_circumscription A B D) as [O'].
    apply one_side_not_col124 in HOS; Col.
  spliter.
  assert (OnCircle A O' A /\ OnCircle B O' A /\ OnCircle D O' A).
    unfold OnCircle; repeat split; Cong.
  spliter.
  apply (conga_cop_onc6_os__eqc A B C D O P O' A); trivial.
Qed.

(** If the angles ACB and ADB are congruent and C, D lie on the same side of AB,
    then A, B, C and D are concyclic. *)

Lemma conga_os__concyclic : forall A B C D,
  OS A B C D -> CongA A C B A D B -> Concyclic A B C D.
Proof.
  intros A B C D HOS HConga.
  split.
    apply os__coplanar, HOS.
  destruct (triangle_circumscription A B C) as [O]; spliter.
    apply one_side_not_col123 with D, HOS.
  assert (OnCircle A O A /\ OnCircle B O A /\ OnCircle C O A).
    unfold OnCircle; repeat split; Cong.
  spliter.
  exists O, A; repeat split; trivial.
  apply (conga_cop_onc3_os__onc A B C); assumption.
Qed.

(** If the angles ACB and ADB are supplementary and C, D lie on opposite sides of AB,
    then A, B, C and D are concyclic. *)

Lemma suppa_ts__concyclic : forall A B C D,
  TS A B C D -> SuppA A C B A D B -> Concyclic A B C D.
Proof.
  intros A B.
  assert (Haux : forall C D, TS A B C D -> Obtuse A C B -> SuppA A C B A D B -> Concyclic A B C D).
  { intros C D HTS HObtuse HSuppa.
    split.
      apply ts__coplanar, HTS.
    assert (HNCol : ~ Col A B C) by (destruct HTS; Col).
    destruct (triangle_circumscription A B C HNCol) as [O]; spliter.
    assert (OnCircle A O A /\ OnCircle B O A /\ OnCircle C O A).
      unfold OnCircle; repeat split; Cong.
    spliter.
    exists O, A; repeat split; trivial.
    destruct (chord_completion O A C O) as [C'[HC' HBet]]; Circle.
    assert (TS A B C C').
      apply bet_ts__ts with O; [apply l9_2, cop_obtuse_onc3__ts with A|]; assumption.
    apply (conga_cop_onc3_os__onc A B C'); trivial.
      apply coplanar_trans_1 with C; Col; Cop.
      exists C; split; Side.
      apply (suppa2__conga456 A C B); [apply (cop_onc4_ts__suppa O A)|]; assumption.
  }
  intros C D HTS HSuppa.
  assert (HCop : Coplanar A B C D) by (apply ts__coplanar, HTS).
  suma.assert_diffs; destruct (angle_partition A C B) as [|[|]]; auto; split; trivial.
  { destruct (Haux D C) as [_ [O [P]]].
      Side.
      apply (acute_suppa__obtuse A C B); trivial.
      apply suppa_sym, HSuppa.
    exists O, P.
    spliter; repeat split; trivial.
  }
  destruct (midpoint_existence A B) as [M].
  exists M, A.
  destruct HTS as [HNCol1 [HNCol2 _]].
  unfold OnCircle; repeat split; [Cong..| |];
    apply cong_symmetry, thales_converse_theorem with B; auto.
  apply (per_suppa__per A C B); assumption.
Qed.

(** In a convex quadrilateral, if two opposite angles are supplementary
    then the two other angles are also supplementary. *)

Lemma suppa_ts2__suppa : forall A B C D,
  TS A C B D -> TS B D A C -> SuppA A B C A D C -> SuppA B A D B C D.
Proof.
  intros A B C D HTS1 HTS2 HSuppa.
  assert (HCon : Concyclic A C B D) by (apply suppa_ts__concyclic; trivial).
  apply concyclic_aux in HCon.
  destruct HCon as [O [P]]; spliter.
  apply (cop_onc4_ts__suppa O P); trivial.
  apply coplanar_perm_2, coplanar_trans_1 with C; [destruct HTS1; Col|Cop..].
Qed.

End Inscribed_angle.

Section Inscribed_angle_2.

Context `{T2D:Tarski_2D}.
Context `{TE:@Tarski_euclidean Tn TnEQD}.

Lemma chord_par_diam : forall O P A B C C' A' U,
 O <> P -> ~Col A B C' -> Diam C C' O P -> Midpoint A' A C' -> OnCircle A O P -> OnCircle B O P ->
 Col A B U -> Perp O U A B -> Par A C' O U -> B = C.
Proof.
intros.
suma.assert_diffs.
assert(Midpoint U A B).
{
  apply(col_onc2_perp__mid O P A B U); Col.
}
assert(O <> A').
intro.
treat_equalities.
induction H7.
apply H7.
exists O.
split; Col.
spliter.
assert(Perp A U  O U).
{
  apply perp_sym in H6.
  apply (perp_col A B O U U); Col.
  intro.
  treat_equalities.
  apply perp_distinct in H6.
  tauto.
}
apply perp_left_comm in H18.
apply perp_not_col in H18.
apply H18; Col.
unfold Diam in H1.
spliter.
assert(HH:=mid_onc2__perp O P A C' A' H15 H13 H3 H17 H2).
assert(Perp O U O A').
{
  apply(par_perp__perp A C' O U O A' H7); Perp.
}

assert(Par O A' A B).
{
  apply (l12_9_2D _ _ _ _ O U); Perp.
}
assert(HM:=midpoint_existence B C').
ex_and HM O'.
assert(HP:= triangle_mid_par A B C' O' A' H0 H20 H2).
apply par_strict_par in HP.
assert(Par O A' A' O').
{
  apply (par_trans _ _ A B); Par.
}
assert(Col O O' A').
{
  induction H21.
  apply False_ind.
  apply H21.
  exists A'.
  split; Col.
  spliter.
  Col.
}

induction(eq_dec_points O O').
treat_equalities.
apply(symmetric_point_uniqueness C' O); Midpoint.
split; [Between|CongR].

assert(HQ:= mid_onc2__perp O P B C' O' H23  H10 H4 H17 H20).
apply(perp_col O A' A C' O') in HH; Col.
assert(Par A C' B C').
{
  apply(l12_9_2D A C' B C' O O'); Perp.
}
apply False_ind.
induction H24.
apply H24.
exists C'.
split;Col.
spliter.
apply H0.
Col.
Qed.

End Inscribed_angle_2.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf3 : natural) (z : natural) (lf2 : natural) (lf1 : natural)
  : natural := plus Zero (plus Zero lf1).


Theorem Ex037 (A B C : Prop) :  A \/ B -> ~A \/ ~C -> C -> B.
Proof.
  intros.
  destruct H.
  + destruct H0.
    - contradiction.
    - contradiction.
  + exact H.
Qed.


Require Import CT.Category.
Require Import CT.Functor.
Require Import CT.NaturalTransformation.
Require Import CT.Instance.Functor.ComposeFunctor.

(** * Horizontal Composition of Natural Transformations

From wikipedia:

Natural transformations also have a "horizontal composition". If η : F → G is a
natural transformation between functors F,G : C → D and ε : J → K is a natural
transformation between functors J,K : D → E, then the composition of functors
allows a composition of natural transformations εη : JF → KG. This operation is
also associative with identity, and the identity coincides with that for
vertical composition.
*)
Section HCNaturalTransformation.
  Context {C D E : Category} {F G : Functor C D} {J K : Functor D E}.
  Variable mu : NaturalTransformation F G.
  Variable epsilon : NaturalTransformation J K.
  Let JF := ComposeFunctor F J.
  Let KG := ComposeFunctor G K.

  Program Definition HCNaturalTransformation : NaturalTransformation JF KG :=
    {| nt_components :=
         fun X => comp (nt_components J K epsilon (F_ob F X)) (F_mor K (nt_components F G mu X))
    |}.
  Next Obligation.
  Proof.
    rewrite assoc.
    rewrite nt_commutes.
    rewrite assoc_sym.
    rewrite <- F_comp_law.
    rewrite nt_commutes.
    rewrite F_comp_law.
    rewrite assoc.
    reflexivity.
  Qed.
  Next Obligation.
  Proof.
    symmetry.
    apply HCNaturalTransformation_obligation_1.
  Qed.
End HCNaturalTransformation.


Require Import Setoid Field Min List Aux.

Structure eparams: Type := {
 E:> Set;                      (* the vector type *)
 stype:> fparams;              (* the scalar field *)
 E0: E;                        (* 0 *)
 eqE: E -> E -> bool;          (* = as a boolean function *)
 addE : E -> E -> E;          (* + *)
 scalE : (K stype) -> E -> E   (* scalar *)
}.

Delimit Scope vector_scope with v.

Notation "x ?= y" := (eqE _ x y) (at level 70): vector_scope.
Notation "0" := (E0 _): vector_scope.
Notation "x + y" := (addE _ x y): vector_scope.
Notation "x .* y" := (scalE _ x%f y) (at level 31, no associativity): vector_scope.

Arguments scalE _ _%field_scope _%vector_scope.

Section VectorSpace.

(* This is our scalar space *)
Variable p : eparams.

Open Scope vector_scope.

Implicit Type v x y z: p.
Implicit Type k: stype p.

(* Multiple product for characterizing linear combinations *)
Definition  mprod ks vs :=
   fold2 (fun k v r => k .* v + r) ks vs 0.

Notation " x *X* y " := (mprod x y) (at level 40, no associativity): vector_scope.

(* What it means for a sub vector space (i.e a list of vectors)
   to be free *)
Definition free vs :=
  forall ks, length ks = length vs -> ks *X* vs = 0 ->
    (forall k, In k ks -> k = 0%f).

(* What it is to be a linear combination *)
Inductive cbl (l: list (E p)): (E p) -> Prop :=
  cbl0: cbl l 0
| cbl_in: forall v, In v l -> cbl l v
| cbl_add: forall x y, cbl l x -> cbl l y -> cbl l (x + y)
| cbl_scal: forall k x, cbl l x -> cbl l (k .* x).

Lemma cbl_trans l1 l2 x:
  (forall i, In i l2 -> cbl l1 i) -> cbl l2 x -> cbl l1 x.
Proof.
intros H1 H2; elim H2; auto.
apply cbl0.
intros; apply cbl_add; auto.
intros; apply cbl_scal; auto.
Qed.

Definition is_base vs := free vs /\ forall e, cbl vs e.

Structure vparamsProp: Type := {
 sProp : fparamsProp p;
 eqE_dec: forall x y, if x ?= y then x = y else x <> y;
          (* Boolean equality *)
 addE_assoc: forall x y z, (x + y) + z = x + (y + z);
          (* Associativity for + *)
 addE_com: forall x y, x + y = y + x;
          (* Commutativity for + *)
 addE0l: forall x, 0 + x = x;
          (* Left neutral  for + *)
 scalE0l: forall x, 0 .* x = 0;
          (* scalar 0 *)
 scalE1: forall x, 1 .* x = x;
          (* scalar 1 *)
 scal_addEl: forall k1 k2 x, (k1 + k2) .* x = (k1.* x) + (k2 .* x);
          (* scalar distributivity left *)
 scal_addEr: forall k x y, k .* (x + y) = k .* x + k .* y;
          (* scalar distributivity right *)
 scal_multE: forall k1 k2 x, (k1 * k2) .* x = k1.* (k2 .* x)
          (* scalar distributivity left *)
}.

Variable Hp: vparamsProp.

Lemma eqE_refl x: (x ?= x) = true.
Proof.
generalize (eqE_dec Hp x x); case eqE; auto.
Qed.

Lemma addE0r: forall x, x + 0 = x.
Proof.
intros x; rewrite addE_com; auto; rewrite addE0l; auto.
Qed.

Let sfP := sProp Hp.

Lemma addE_cancell x y z : z + x = z + y -> x = y.
Proof.
intros H.
rewrite <-addE0l; auto.
rewrite <-(fun xx => scalE0l xx z); auto.
rewrite <-(oppKl _ sfP 1%f); auto.
rewrite scal_addEl; auto.
rewrite scalE1; auto.
rewrite addE_assoc; auto.
rewrite <-H; rewrite <-addE_assoc; auto.
pattern z at 2; rewrite <-(fun xx => scalE1 xx z); auto.
rewrite <-scal_addEl; auto.
rewrite oppKl; auto.
rewrite scalE0l; auto.
rewrite addE0l; auto.
Qed.

Lemma addE_cancelr x y z : x + z = y + z -> x = y.
Proof.
intros H; apply addE_cancell with z.
repeat rewrite (fun xx => addE_com xx z); auto.
Qed.

Lemma scalE0r k : k .* 0 = 0.
Proof.
apply addE_cancell with (k .* 0).
rewrite addE0r.
rewrite <-scal_addEr; auto.
rewrite addE0l; auto.
Qed.

(* Opposite for  + *)
Lemma scal_addE0 x : x + (- (1)) .* x = 0.
Proof.
generalize (scal_addEl Hp (1)%f (- (1))%f x).
rewrite oppKr; auto; rewrite scalE1, scalE0l; auto.
Qed.

Lemma addE_eq_opp x y : x + (-(1)) .* y = 0 -> x = y.
Proof.
intros H; apply addE_cancell with ((-(1)) .* y).
rewrite addE_com, H, addE_com, scal_addE0; auto.
Qed.

(* Recursive equation for multiple product *)
Lemma mprod_S k ks v vs : (k :: ks) *X* (v :: vs) = k .* v + ks *X* vs.
Proof.
assert (Hf: forall ks vs v,
   fold2 (fun k v r => k .* v + r) ks vs v = v + ks *X* vs).
intros ks1; induction ks1 as [| k1 ks1 IH]; simpl.
  intros vs1 v1; unfold mprod; simpl; rewrite addE0r; auto.
intros [| v' vs1] v1; unfold mprod; simpl.
  rewrite addE0r; auto.
rewrite IH; rewrite IH; rewrite addE0r;
  rewrite (fun xx => addE_com xx v1); auto; repeat rewrite addE_assoc; auto;
  rewrite (fun xx => addE_com xx v1); auto.
unfold mprod; simpl.
rewrite Hf; rewrite Hf; rewrite addE0r; rewrite addE0l; auto.
Qed.

Lemma mprod0l vs : nil *X* vs = 0.
Proof. auto. Qed.

Lemma mprod0r ks : ks *X* nil = 0.
Proof. destruct ks as [| k ks]; auto. Qed.

Lemma mprod0 vs1 vs2 : map (fun _ : E p => 0%f) vs1 *X* vs2 = 0.
Proof.
generalize vs2; clear vs2.
induction vs1 as [| a vs1]; intros [| b vs2]; simpl map;
  try rewrite mprod0r; auto.
rewrite mprod_S; rewrite scalE0l; auto; rewrite addE0l; auto.
Qed.

(* Concation for multiple product *)
Lemma mprod_app ks1 ks2 vs1 vs2 :
   length ks1 = length vs1 ->
      (ks1 ++ ks2) *X* (vs1 ++ vs2) = ks1 *X* vs1 + ks2 *X* vs2.
Proof.
generalize ks2 vs1 vs2; clear ks2 vs1 vs2.
induction ks1 as [| k ks1 IH]; intros ks2 [| v vs1] vs2 H;
  try discriminate H.
simpl mprod; unfold mprod; simpl; rewrite addE0l; auto.
simpl app; rewrite mprod_S; rewrite mprod_S; rewrite IH; auto;
  rewrite addE_assoc; auto.
Qed.

Lemma eqE_spec x y : eq_Spec x y (x ?= y).
Proof.
generalize (eqE_dec Hp x y); case eqE; constructor; auto.
Qed.

(* Lemmas for free *)

Lemma free_nil : free nil.
Proof.
intros [| k ks]; auto.
intros H1 H2 l Hk; case Hk.
intros HH; discriminate HH.
Qed.

Lemma free_cons v vs : free (v::vs) -> free vs.
Proof.
intros Hvs ks Hlks Hpks k Hk.
apply (Hvs (0%f::ks)); simpl; auto.
rewrite mprod_S; rewrite Hpks; rewrite scalE0l; auto; rewrite addE0l; auto.
Qed.

Lemma free_perm vs1 vs2 : perm vs1 vs2 -> free vs2 -> free vs1.
Proof.
intros HH Hvs1.
assert (Hf: forall (k1: list _), length k1 = length vs1 ->
  exists (k2:list _), perm k1 k2 /\ k1 *X* vs1 = k2 *X* vs2).
elim HH; clear vs1 vs2 HH Hvs1; auto.
intros l k1 Hk1; exists k1; split; auto.
apply perm_id.
intros a b vs1 [|k1 [| k2 ks1]] Hl; try discriminate Hl.
exists (k2::k1::ks1); split; auto.
apply Aux.perm_swap.
repeat rewrite mprod_S; repeat rewrite <-addE_assoc; auto.
rewrite (addE_com Hp (k1 .* a)); auto.
intros a vs1 vs2 Hperm IH [| k1 ks1]; intros HH; try discriminate.
case (IH ks1); auto.
intros ks2 (H1ks2, H2ks2); exists (k1::ks2); split; simpl; auto.
apply Aux.perm_skip; auto.
repeat rewrite mprod_S; rewrite H2ks2; auto.
intros vs1 vs2 vs3 Hp1 IH1 Hp2 IH2 k1 Hk1.
case (IH1 _ Hk1); intros k2 (H1k2, H2k2).
assert (Hk2: length k2 = length vs2).
  rewrite <-(perm_length _ _ _ Hp1);
  rewrite <-(perm_length _ _ _ H1k2); auto.
case (IH2 _ Hk2); intros k3 (H1k3, H2k3).
exists k3; split.
apply Aux.perm_trans with (1 := H1k2); auto.
rewrite H2k2; auto.
intros ks Hlks Hpks k Hk.
case (Hf ks); auto.
intros ks1 (H1ks1, H2ks1).
apply (Hvs1 ks1); auto.
rewrite <-(perm_length _ _ _ HH);
  rewrite <-(perm_length _ _ _ H1ks1); auto.
rewrite <-H2ks1; auto.
apply perm_in with ks; auto.
Qed.

Lemma uniq_free vs : free vs -> uniq vs.
Proof.
induction vs as [| a vs IH]; intros Hf.
apply uniq_nil.
apply uniq_cons; auto.
intros HH; case (perm_in_inv _ _ _ HH).
intros vs1 Hp1.
assert (H1: free (a::a::vs1)).
apply free_perm with (a::vs); auto.
apply Aux.perm_skip; auto.
apply perm_sym; auto.
case (one_diff_zero _ sfP).
apply (H1 (1%f::(-(1))%f::(map (fun _ => 0%f) vs1))); simpl; auto.
rewrite map_length; auto.
repeat rewrite mprod_S; rewrite mprod0.
rewrite addE0r.
rewrite <-scal_addEl; auto.
rewrite  oppKr; auto.
rewrite scalE0l; auto.
apply IH; apply free_cons with a; auto.
Qed.

Lemma free_incl vs1 vs2 : incl vs1 vs2 -> uniq vs1 -> free vs2 -> free vs1.
Proof.
intros Hi Hu Hf.
case (perm_incl_inv _ vs1 vs2); auto.
apply uniq_free; auto.
intros vs3 H3 ks Hlks Hpks x Hx.
assert (H1: free (vs1 ++ vs3)).
apply free_perm with (1 := perm_sym _ _ _ H3); auto.
apply (H1 (ks ++ map (fun _ => 0%f) vs3)%list); auto with datatypes.
repeat rewrite app_length; rewrite map_length; auto.
rewrite mprod_app; auto.
rewrite Hpks; rewrite addE0l; auto.
rewrite mprod0; auto.
Qed.

(* Lemmas for cbl *)

(* Linear combination  behaves well with inclusion *)
Lemma cbl_incl l1 l2 v : incl l1 l2 -> cbl l1 v -> cbl l2 v.
Proof.
intros H1 H2.
generalize H1; elim H2; clear H1 H2.
intros; apply cbl0.
intros; apply cbl_in; auto with datatypes.
intros; apply cbl_add; auto.
intros; apply cbl_scal; auto.
Qed.

Lemma cbl0_inv x : cbl nil x -> x = 0.
Proof.
intros HH; elim HH; simpl; auto.
intros v [].
intros x1 y1 _ H1 _ H2; rewrite H1, H2; rewrite addE0l; auto.
intros k x1 _ H1; rewrite H1, scalE0r; auto.
Qed.

(* Multiple products are linear combinations *)
Lemma mprod_cbl l ks : cbl l (ks *X* l).
Proof.
generalize ks; clear ks.
induction l as [| x l1 IH].
  intros [| k ks]; unfold mprod; simpl; apply cbl0.
intros [| k ks].
  unfold mprod; simpl; apply cbl0.
rewrite mprod_S; apply cbl_add.
apply cbl_scal; apply cbl_in; auto with datatypes.
apply cbl_incl with (2 := IH ks); auto with datatypes.
Qed.

(* Multiple product of a sum *)
Lemma addE_mprod ks1 ks2 vs : length ks1 = length ks2 ->
  map2 (fun k1 k2 => (k1 + k2)%f) ks1 ks2 *X* vs = ks1 *X* vs + ks2 *X* vs.
Proof.
generalize ks2 vs; clear ks2 vs.
induction ks1 as [| k1 ks1 IH]; intros [| k2 ks2].
intros; unfold mprod; simpl; rewrite addE0l; auto.
intros vs H; discriminate H.
intros vs H; discriminate H.
simpl length; intros [| v vs] Hl.
unfold mprod; simpl; rewrite addE0l; auto.
simpl map2; repeat rewrite mprod_S.
rewrite scal_addEl; auto; rewrite IH; auto.
repeat rewrite addE_assoc; auto.
 apply f_equal2 with (f := addE p); auto.
rewrite addE_com; auto; repeat rewrite addE_assoc; auto;
  apply f_equal2 with (f := addE p); auto.
rewrite addE_com; auto.
Qed.

(* Multiple production of a scalar product *)
Lemma scalE_mprod k ks vs :
 map (fun k1 => (k * k1)%f) ks *X* vs = k .* (ks *X* vs).
Proof.
generalize vs; clear vs.
induction ks as [| k1 ks IH].
intros; unfold mprod; simpl; rewrite scalE0r; auto.
intros [| v vs].
unfold mprod; simpl; rewrite scalE0r; auto.
simpl map; repeat rewrite mprod_S.
rewrite scal_multE; auto; rewrite IH; auto.
rewrite scal_addEr; auto.
Qed.

Lemma mprod_perm l1 l2 lk1: perm l1 l2 -> length lk1 = length l1 ->
  exists lk2, perm lk1 lk2 /\ lk1 *X* l1 = lk2 *X* l2.
Proof.
intros HH; generalize lk1; elim HH; auto; clear l1 l2 lk1 HH.
intros l1 lk1 _; exists lk1; split; auto; apply perm_id.
intros a b l1 [| a1 [| b1 lk]] HH; try discriminate HH.
exists (b1::a1::lk); split; auto.
apply perm_swap.
rewrite !mprod_S, <-!addE_assoc, (addE_com Hp (a1 .* a)); auto.
intros a l1 l2 Hp1 IH [|a1 lk1] Hlk1; try discriminate Hlk1.
case (IH lk1); auto.
intros lk2 (H1lk2, H2lk2).
exists (a1 :: lk2); repeat split; auto.
apply perm_skip; auto.
rewrite !mprod_S, H2lk2; auto.
intros l1 l2 l3 Hp1 IH1 Hp2 IH2 lk1 Hlk1.
case (IH1 _ Hlk1); intros lk2 (H1lk2, H2lk2).
case (IH2 lk2); auto.
rewrite <-(perm_length _ _  _ H1lk2), Hlk1.
apply perm_length; auto.
intros lk3 (H1lk3, H2lk3); exists lk3; split; auto.
apply perm_trans with (1 := H1lk2); auto.
rewrite H2lk2; auto.
Qed.

(* How to generate the multiple product for a constant *)
Fixpoint lgenk (n: nat) (k: K p) {struct n} : list (K p) :=
  match n  with
    O => nil
  | 1 => k :: nil
  | S n1 => k::lgenk n1 k
  end.

(* The length is ok *)
Lemma lgenk_length n k : length (lgenk n k) = n.
Proof.
generalize k; clear k.
induction n as [| n IH]; simpl; auto.
intros k; generalize IH; case n; clear n IH; auto.
intros n IH; pattern (S n) at 2; rewrite <- (IH k); auto.
Qed.

(* 0 as a multiple product *)
Lemma genk0_mprod vs :  0 = lgenk (length vs) 0%f *X* vs.
Proof.
induction vs as [| v [| v' vs] IH]; auto;
  simpl lgenk; rewrite mprod_S; rewrite IH; rewrite scalE0l; auto;
  rewrite addE0l; auto.
Qed.

(* A linear combination is a multiple product *)
Lemma cbl_mprod vs v : cbl vs v ->
  exists ks, length ks = length vs /\ v = ks *X* vs.
Proof.
intros H; elim H.
exists (lgenk (length vs) 0%f); rewrite lgenk_length; split; auto.
apply genk0_mprod.
intros v2; clear H; induction vs as [| v' vs IH]; auto.
intros HH; absurd (In v2 nil); auto with datatypes.
simpl In; intros [H1 | H1].
  exists (1%f::lgenk (length vs) 0%f); split.
  simpl; rewrite lgenk_length; auto.
  rewrite mprod_S; rewrite scalE1; auto; rewrite <- genk0_mprod;
  rewrite addE0r; auto.
  case IH; auto; intros ks (Hks, Hks1); exists (0%f::ks); split.
  simpl; auto.
  rewrite mprod_S; rewrite scalE0l; auto; rewrite addE0l; auto.
intros x y Hcx (ks1, (Hlks1, Hks1)) Hcy (ks2, (Hlks2, Hks2)).
exists (map2 (fun k1 k2 => (k1 + k2)%f) ks1 ks2); split.
rewrite map2_length; rewrite min_l; auto.
rewrite Hlks1; rewrite Hlks2; auto with arith.
rewrite addE_mprod; try rewrite Hks1; try rewrite Hks2; auto.
rewrite Hlks1; auto.
intros k x Hcx (ks, (Hlks, Hks)).
exists (map (fun k1 => (k * k1)%f) ks); split.
  rewrite map_length; auto.
rewrite scalE_mprod; rewrite Hks; auto.
Qed.

Lemma scalE_add0 x : x + (- (1)) .* x = 0.
Proof.
pattern x at 1; rewrite <- (fun xx => scalE1 xx x); auto.
rewrite <-scal_addEl; auto.
rewrite oppKr; auto.
rewrite scalE0l; auto.
Qed.

Lemma scalE_integral k x : k .* x = 0 -> {k = 0%f} + {x = 0}.
Proof.
intros Hk.
generalize (eqK_dec _ sfP k 0%f); case eqK; auto; intros Hk1.
right.
rewrite <-(scalE1 Hp x).
simpl; rewrite <-(invKr _ sfP _ Hk1).
rewrite scal_multE; auto.
rewrite Hk; rewrite scalE0r; auto.
Defined.

Lemma scalE_opp k1 k2 x : k1 .* ((- (k2)) .* x) = (-k1).* (k2 .* x).
Proof.
rewrite <- scal_multE,  <- opp_multKr, opp_multKl, scal_multE; auto.
Qed.

Lemma scalE_swap k1 k2 x : k1 .* (k2 .* x) = k2 .* (k1 .* x).
Proof.
repeat rewrite <- scal_multE; auto.
rewrite multK_com; auto.
Qed.

Lemma addE_swap x1 x2 x3 : x1 + (x2 + x3) = x2 + (x1 + x3).
Proof.
rewrite addE_com; auto; repeat rewrite addE_assoc; auto.
apply f_equal2 with (f := addE _); auto; rewrite addE_com; auto.
Qed.

Lemma cblnil x : cbl nil x -> x = 0.
Proof.
intros H; elim H; auto; clear x H.
intros v [].
intros x y _ Hx _ Hy; rewrite Hx, Hy; rewrite addE0l; auto.
intros k x _ Hx; rewrite Hx; rewrite scalE0r; auto.
Qed.

Lemma cbl1 x y : cbl (x::nil) y -> exists k, y = k .* x.
Proof.
intros H; elim H; auto; clear y H.
exists 0%f; rewrite scalE0l; auto.
simpl; intros v [[]|[]]; exists 1%f; rewrite scalE1; auto.
intros x1 y _ (k1,Hk1) _ (k2,Hk2).
exists (k1 + k2)%f; subst; rewrite scal_addEl; auto.
intros k x1 _ (k1,Hk1); exists (k * k1)%f; rewrite Hk1, scal_multE; auto.
Qed.

End VectorSpace.

Notation " x *X* y " := (mprod _ x y) (at level 40, no associativity): vector_scope.

Section Trans.

Variable p p1 : eparams.
Hypothesis Hp: vparamsProp p.
Hypothesis Hp1: vparamsProp p1.
Variable (f: p -> p1).
Variable (g : stype p -> stype p1).
Variable (g1 : stype p1 -> stype p).
Hypothesis Hf0: f 0%v = 0%v.
Hypothesis Hf1: forall x y : p, (f (x + y) = f x + f y)%v.
Hypothesis Hf2: forall (k: stype p) (x : p), (f (k .* x) = g k .* f x)%v.
Hypothesis Hg: forall k, g (g1 k) = k.

Lemma cbl_map l v : cbl _ l v -> cbl _ (map f l) (f v).
Proof.
intros Hcb; elim Hcb; auto.
rewrite Hf0; constructor.
intros v1 Hv1; constructor; apply in_map; auto.
intros; rewrite Hf1; apply cbl_add; auto.
intros; rewrite Hf2; apply cbl_scal; auto.
Qed.

Lemma cbl_map_inv l v :
 cbl _ (map f l) v -> exists v1, cbl _ l v1 /\ v = f v1.
Proof.
assert (exists l1, l1 = map f l).
exists (map f l); auto.
case H; intros l1 Hl1; rewrite <-Hl1; intros HH.
generalize Hl1; elim HH; auto; clear HH Hl1.
intros H1; exists 0%v; split; auto; constructor.
intros v1 Hv1 H1; subst.
rewrite in_map_iff in Hv1; case Hv1; intros v2 (H1v2, H2v2); subst.
exists v2; split; auto; constructor; auto.
intros c y H1 H2 H3 H4 H5.
case (H2 H5); intros v1 (H1v1, H2v1).
case (H4 H5); intros v2 (H1v2, H2v2); subst.
exists (v1 + v2)%v; split; auto.
apply cbl_add; auto.
intros k x H1 H2 H3.
case (H2 H3); intros v1 (H1v1, H2v1).
exists ((g1 k).* v1)%v; split; subst; auto.
apply cbl_scal; auto.
rewrite Hf2, Hg; auto.
Qed.

End Trans.

Structure params: Type := {
 dim:> nat;           (* the dimension of the space *)
 K:> fparams          (* the scalar type *)
}.

Ltac Vrm0 := Krm0;
  repeat (rewrite addE0l ||rewrite addE0r || rewrite scalE0l|| rewrite scalE0r); auto.


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

Require Coq.Classes.RelationClasses.
Require Coq.Setoids.Setoid.
Require Coq.Relations.Relations.

Require Import Coq.micromega.Lia.
Import ListNotations.
Require Import Turing.Lang.
Require Import Turing.Regex.
Require Import Turing.Util.

Section Defs.
  Inductive Regular: language -> Prop :=
  | regular_def:
    forall r l,
    Equiv (Accept r) l ->
    Regular l.
End Defs.

Section Props.
  Lemma union_regular:
    forall L1 L2,
    Regular L1 ->
    Regular L2 ->
    Regular (Lang.Union L1 L2).
  Proof.
    intros.
    inversion H; subst; clear H.
    inversion H0; subst; clear H0.
    apply regular_def with (r:=r_union r r0).
    split; intros.
    - inversion H0; subst; clear H0.
      + apply union_in_l.
        apply H1.
        assumption.
      + apply union_in_r.
        apply H.
        assumption.
    - destruct H0.
      + apply H1 in H0.
        apply accept_union_l.
        assumption.
      + apply H in H0.
        apply accept_union_r.
        assumption.
  Qed.
End Props.

Section Pumping.

  Inductive Pump (L:language) (p:nat) (w:word) : Prop :=
  | pump_def:
    forall x y z,
    w = x ++ y ++ z ->
    y <> [] ->
    length (x ++ y) <= p ->
    (forall i, In (x ++ pow y i ++ z) L) ->
    Pump L p w.

  Lemma rex_pump_to_pump:
    forall L r w,
    Equiv (Accept r) L ->
    RexPump r w ->
    In w (Pump L (pumping_constant r)).
  Proof.
    intros.
    inversion H0; subst; clear H0.
    apply pump_def with (x:=x) (y:=y) (z:=z); auto.
    intros.
    apply H.
    apply H4.
  Qed.

  Theorem pumping:
    forall L,
    Regular L ->
    exists p, p >= 1 /\
    forall w, In w L ->
    length w >= p ->
    In w (Pump L p).
  Proof.
    intros.
    inversion H; subst; clear H.
    exists (pumping_constant r).
    split. {
      apply pumping_constant_ge_1.
    }
    intros.
    assert (RexPump r w). {
      apply rex_pumping.
      + apply H0.
        assumption.
      + lia.
    }
    apply rex_pump_to_pump; auto.
  Qed.

  (** We say that a word [w] and size [p] clogs a language [L] when
      no matter how we divide [w] into three parts, there is at least one pumped
      string not in the language. *)
  Definition Clogs (L:language) p w :=
    forall (x y z:word),
      w = x ++ y ++ z ->
      y <> [] ->
      length (x ++ y) <= p ->
      exists i,
      ~ In (x ++ (pow y i) ++ z) L.

  Lemma in_clogs:
    forall w p L,
    (forall x y z,
    w = x ++ y ++ z ->
    y <> [] ->
    length (x ++ y) <= p ->
    exists i, ~ In (x ++ (pow y i) ++ z) L) ->
    In w (Clogs L p).
  Proof.
    intros.
    unfold Clogs.
    intros; auto.
  Qed.

  (**

  A language is clogged if we can find one word in language [L] that clogs [L].

   w \in L    |w| >= p    w \in Clogs L p
   -----------------------------------
            L clogged with p
  *)
  Inductive Clogged (L:language) p : Prop :=
  | clogged_def:
    forall w,
    In w L ->
    length w >= p ->
    In w (Clogs L p) ->
    Clogged L p.

  (** Clogged languages are not regular.
      We show that a language is not regular by clogging it for all p >= 1. *)
  Lemma not_regular:
    forall (L:language),
    (forall p, p >= 1 -> Clogged L p) ->
    ~ Regular L.
  Proof.
    (* H: For any p >= 1, L is clogged starting with p *)
    intros.
    (* Assume N: (L is regular) to reach a contradiction. *)
    intros N.
    (* Since L is regular, then we can apply the pumping lemma. *)
    apply pumping in N.
    destruct N as (p, (Hle, Hw)). (* there is a p which we can pump *)
    (* We have that p >= 1, so L is clogged on p *)
    assert (H := H _ Hle).
    (* We cannot use Hw, so we are only left with H:Clogged L p,
       let us open it. *)
    (* We now know that there is a string `w` in `L` that clogs `L`. *)
    inversion H as (w, Hin, Hlen, Hc); subst; clear H.
    (* Let us use string `w` in the pumping of L *)
    assert (Hw := Hw w Hin Hlen).
    (* If w is in the pumping of L, then we can pump it for any i *)
    inversion Hw as (x, y, z, ?, ?, ?, Ha); subst; clear Hw.
    (* But we recall that w is clogged (H2), so there is some i that is not in L *)
    assert (Hi: exists i, ~ In (x ++ (pow y i) ++ z) L). {
      apply Hc.
      - reflexivity.
      - assumption.
      - assumption.
    }
    destruct Hi as (i, Hi).
    contradict Hi.
    apply Ha.
  Qed.

  Lemma not_regular_ex:
    forall (L:language),
    (forall p, p >= 1 ->
      exists w,
      (
        In w L /\
        length w >= p /\ (
          forall x y z,
          (w = x ++ y ++ z ->
           y <> [] ->
           length (x ++ y) <= p ->
           exists i,  ~ In (x ++ pow y i ++ z) L
           )))) ->
    ~ Regular L.
  Proof.
    intros.
    apply not_regular.
    intros.
    destruct (H _ H0) as (w, (Ha, (Hb, Hc))); clear H.
    apply clogged_def with (w:=w); auto.
  Qed.

  Lemma equiv_clogs_impl:
    forall n L1 L2,
    Equiv L1 L2 ->
    Equiv (Clogs L1 n) (Clogs L2 n).
  Proof.
    intros.
    unfold Clogs; split; unfold In; intros; subst.
    - assert (H0 := H0 x y z eq_refl H2 H3).
      destruct H0 as (i, Hx).
      exists i.
      intros N.
      contradict Hx.
      apply H.
      assumption.
    - assert (H0 := H0 x y z eq_refl H2 H3).
      destruct H0 as (i, Hx).
      exists i.
      intros N.
      contradict Hx.
      apply H.
      assumption.
  Qed.

  Lemma equiv_clogged:
    forall L1 L2 p,
    Equiv L1 L2 ->
    Clogged L1 p ->
    Clogged L2 p.
  Proof.
    intros.
    inversion H0; subst; clear H0.
    apply clogged_def with (w:=w).
    - apply H.
      assumption.
    - assumption.
    - apply equiv_clogs_impl with (n:=p) in H.
      rewrite <- H.
      assumption.
  Qed.

  Import Morphisms.
  Global Instance rw_equiv_proper: Proper (Equiv ==> eq ==> iff) Clogged.
  Proof.
    unfold Proper.
    unfold respectful.
    intros.
    subst.
    split; intros.
    - eapply equiv_clogged; eauto.
    - eapply equiv_clogged; eauto.
      symmetry.
      assumption.
  Qed.

End Pumping.

Module Examples.
  Import RegexNotations.
  Import LangNotations.
  Import Lang.
  Import Setoid.

  Open Scope lang_scope.

  (** Ends with "a" *)

  Lemma l1_is_reg:
    Regular Examples.L1.
  Proof.
    apply regular_def with (r:= r_star r_any ;; "a").
    unfold Examples.L1.
    rewrite r_app_rw.
    rewrite r_char_rw.
    rewrite r_star_rw.
    rewrite r_any_rw.
    rewrite star_any_rw.
    reflexivity.
    (* Direct proof: *)
    (*
    apply app_spec.
    unfold Equiv; split; unfold Examples.L1; intros.
    - inversion H; subst; clear H.
      exists s1.
      inversion H3; subst; clear H3.
      reflexivity.
    - destruct H as (w, Hs).
      subst.
      apply accept_app with (s1:=w) (s2:=["a"]); auto.
      + apply accept_any_star.
      + auto using accept_char.
      *)
  Qed.

  (** Any string of length 2 *)

  Lemma l2_is_reg:
    Regular Examples.L2.
  Proof.
    apply regular_def with (r:= r_any ;; r_any).
    unfold Equiv, Examples.L2; split; intros.
    - inversion H; subst.
      apply accept_any_inv in H2.
      apply accept_any_inv in H3.
      destruct H2 as (c1, ?).
      destruct H3 as (c2, ?).
      subst.
      reflexivity.
    - destruct w. {
        inversion H.
      }
      inversion H; subst; clear H.
      destruct w. {
        inversion H1.
      }
      inversion H1; subst; clear H1.
      destruct w. {
        simpl.
        apply accept_any_cons.
        apply accept_any.
      }
      inversion H0.
  Qed.

  (** Any string that starts with "a" and ends with "b". *)
  Lemma l3_is_reg:
    Regular Examples.L3.
  Proof.
    unfold Examples.L3.
    apply regular_def with (r:="a" ;; r_star r_any ;; "b").
    repeat rewrite r_app_rw.
    rewrite r_star_rw.
    rewrite r_any_rw.
    repeat rewrite r_char_rw.
    rewrite star_any_rw.
    reflexivity.
  Qed.

  Lemma l1_l3:
    Regular (Lang.Union Examples.L1 Examples.L3).
  Proof.
    apply union_regular.
    - apply l1_is_reg.
    - apply l3_is_reg.
  Qed.

  (** Irregular language *)

  Lemma xyz_rw:
    forall (a:ascii) b p x y z,
    (
      length (x ++ y) <= p ->
      pow1 a p ++ pow1 b p = x ++ y ++ z ->
      exists n,
      (length (x ++ y) + n) % nat = p /\
      pow1 a (length x + (length y + n)) ++ pow1 b (length x + length y + n) = x ++ y ++ z
    ) % list.
  Proof.
    intros.
    apply le_to_plus in H.
    destruct H as (n, Hlen).
    exists n.
    split; auto.
    rewrite <- Hlen in H0.
    rewrite app_length in H0.
    rewrite Nat.add_assoc.
    assumption.
  Qed.

  Lemma pow1_plus_xy:
    forall (a:ascii) z x n y,
    pow1 a (length x + n) ++ z = x ++ y ->
    x = pow1 a (length x) /\ y = pow1 a n ++ z.
  Proof.
    induction x; intros.
    - simpl in *.
      rewrite H.
      auto.
    - simpl in *.
      inversion H; subst; clear H.
      apply IHx in H2.
      destruct H2.
      split; auto.
      rewrite <- H.
      reflexivity.
  Qed.

  Lemma l4_not_regular:
    ~ Regular Turing.Lang.Examples.L4.
  Proof.
    apply not_regular.
    (* Adversary picks `p` *)
    intros.
    rewrite Turing.Lang.Examples.l4_spec.
    (* We pick our word: *)
    apply clogged_def with (w:=(pow1 "a" p ++ pow1 "b" p) % list).
    - unfold In.
      exists p.
      reflexivity.
    - Search (length (_ ++ _)).
      rewrite app_length.
      Search (length (pow1 _ _)).
      rewrite pow1_length.
      lia.
    - (* Finally, we show that our string clogs the language *)
      Search (In _ (Clogs _ _)).
      apply in_clogs.
      (* Adversary gives x y z *)
      intros x y z Ha Hneq Hlen.
      (* We pick the number of pumps that breaks: *)
      exists 2.
      (* Open up the definition of In *)
      unfold In.
      (* We have that there is a word in L4 and we will reach a contradiction *)
      intros N.
      (* Break down some n *)
      destruct N as (n, N).
      (* We don't want pow in N, so we compute function pow with simpl: *)
      simpl in N.
      (* We remove the ++ [] *)
      Search (_ ++ []).
      rewrite app_nil_r in N.
      (* We start working on our assumption H0, this is the first step of the slides:
         There is some b such that lenght (x ++ y) + b = p *)
      apply xyz_rw in Ha; auto.
      destruct Ha as (b, (_, Hb)).
      (* We now separate x, y, and z in Hb *)
      apply pow1_plus_xy in Hb.
      destruct Hb as (Hx, Hyz).
      symmetry in Hyz.
      apply pow1_plus_xy in Hyz.
      destruct Hyz as (Hy, Hz).
      (* We now know what x, y, and z are.
         We are ready to rewrite them in N. *)
      rewrite Hy in N.
      rewrite Hx in N.
      rewrite Hz in N.
      (* Next, we want to simplify all of our powers of a into a single base at the
         RHS of the equality in N, so that we get a^x b^y = a^v b^w *)
      (* First we normalize ++ *)
      repeat rewrite app_assoc in *.
      (* Then, we eagerly join the terms with the same base *)
      repeat rewrite pow1_plus in N.
      assert ("a" <> "b") by (intros M; inversion M).
      apply pow1_a_b_inv_eq in N; auto.
      destruct N as (L, R).
      subst.
      repeat rewrite <- Nat.add_assoc in *.
      apply plus_inv_eq_r in R.
      apply plus_inv_eq_r in R.
      (* We now have to show that |y| + b = b *)
      apply plus_inv_zero_l in R.
      (* But we know that |y| >= 1, so we reach a contradiction *)
      destruct y. {
        contradiction.
      }
      inversion R.
  Qed.

  Lemma xyz_rw_ex:
    forall (a:ascii) p x y z w,
    length (x ++ y) <= p ->
    pow1 a p ++ w = x ++ y ++ z ->
    exists n,
    p = length (x ++ y) + n /\
    length w + n = length z /\
    x = pow1 a (length x) /\
    y = pow1 a (length y) /\
    z = pow1 a n ++ w.
  Proof.
    intros.
    apply le_to_plus in H.
    destruct H as (n, Hlen).
    exists n.
    split; auto.
    rewrite <- Hlen in H0.
    rewrite app_length in H0.
    rewrite <- Nat.add_assoc in *.
    apply pow1_plus_xy in H0.
    destruct H0 as (Ha, Hb).
    symmetry in Hb.
    apply pow1_plus_xy in Hb.
    destruct Hb as (Hb, Hc).
    repeat split; auto.
    subst.
    rewrite app_length.
    rewrite pow1_length.
    auto with *.
  Qed.

  Lemma l4_not_regular_v2:
    ~ Regular Turing.Lang.Examples.L4.
  Proof.
    apply not_regular_ex.
    (* Adversary: picks p >= 1 *)
    intros p Hge.
    (* We pick a string *)
    exists (pow1 "a" p ++ pow1 "b" p) % list.
    repeat split.
    - unfold Examples.L4, In.
      exists p.
      apply app_in_eq.
      + apply pow_char_in.
      + apply pow_char_in.
    - Search (length (_ ++ _)).
      rewrite app_length.
      Search (length (pow1 _ _)).
      rewrite pow1_length.
      lia.
    - (* Adversary picks x y z *)
      intros x y z Ha Hneq Hlen.
      (* We pick 2 *)
      exists 2.
      intros N.
      (* Break down some n *)
      destruct N as (n, N).
      (* We don't want pow in N, so we compute function pow with simpl: *)
      simpl in N.
      (* We remove the ++ [] *)
      Search (_ ++ []).
      rewrite app_nil_r in N.
      (* We start working on our assumption H0, this is the first step of the slides:
         There is some b such that lenght (x ++ y) + b = p *)
      apply xyz_rw_ex in Ha; auto.
      destruct Ha as (b, (Hz, (_,(Hb,(Hc,Hd))))).

      (* We note that we can simplify away p *)
      rewrite Hz in Hd; clear Hz.

      (* Similarly, we simplify x, y, and z in N. *)
      rewrite Hb in N; clear Hb.
      rewrite Hc in N; clear Hc.
      rewrite Hd in N; clear Hd.

      (* Next, we want to simplify all of our powers of a into a single base at the
         RHS of the equality in N, so that we get a^x b^y = a^v b^w *)
      (* Normalize app (++) *)
      repeat rewrite app_assoc in *.
      (* Then, we eagerly join the terms with the same base *)
      repeat rewrite pow1_plus in N.
      assert ("a" <> "b") by (intros M; inversion M).
      Search (In _ (_ >> _)).
      apply pow_pow_in_inv in N.
      apply pow1_a_b_inv_eq in N; auto.
      destruct N as (L, R).
      subst.
      rewrite app_length in *.
      (* Normalize addition, like we did with app *)
      repeat rewrite <- Nat.add_assoc in *.
      (* We now have to show that |y| + b = b *)
      apply plus_inv_eq_r in R.
      apply plus_inv_eq_r in R.
      (* Thus, |y| = 0 *)
      assert (X: length y = 0). { lia. }
      (* However, from y <> [], we have that |y| > 0*)
      destruct y. { contradiction. }
      inversion X.
  Qed.

  Lemma l4_not_regular_v3:
    ~ Regular Turing.Lang.Examples.L4.
  Proof.
    apply not_regular.
    intros.
    rewrite Turing.Lang.Examples.l4_spec.
    (* We pick our word: *)
    apply clogged_def with (w:=(pow1 "a" p ++ pow1 "b" p) % list).
    - unfold In.
      exists p.
      reflexivity.
    - Search (length (_ ++ _)).
      rewrite app_length.
      Search (length (pow1 _ _)).
      rewrite pow1_length.
      lia.
    - unfold In.
      unfold Clogs.
      intros.
      (* Goal 3: *)
      exists 2.
      (* Open up the definition of In *)
      unfold In.
      (* We have that there is a word in L4 and we will reach a contradiction *)
      intros N.
      (* Break down some n *)
      destruct N as (n, N).
      (* We don't want pow in N, so we compute function pow with simpl: *)
      simpl in N.
      (* We remove the ++ [] *)
      Search (_ ++ []).
      rewrite app_nil_r in N.
      (* We start working on our assumption H0, this is the first step of the slides:
         There is some b such that lenght (x ++ y) + b = p *)
      apply xyz_rw_ex in H0; auto.
      destruct H0 as (b, (Hz, (_,(Hb,(Hc,Hd))))).
      (* We already used H2 for xyz_rw, we can safely remove it. *)
      clear H2.

      (* We note that we can simplify away p *)
      rewrite Hz in Hd; clear Hz.

      (* Similarly, we simplify x, y, and z in N. *)
      rewrite Hb in N; clear Hb.
      rewrite Hc in N; clear Hc.
      rewrite Hd in N; clear Hd.

      (* Next, we want to simplify all of our powers of a into a single base at the
         RHS of the equality in N, so that we get a^x b^y = a^v b^w *)
      (* Normalize app (++) *)
      repeat rewrite app_assoc in *.
      (* Then, we eagerly join the terms with the same base *)
      repeat rewrite pow1_plus in N.
      assert ("a" <> "b") by (intros M; inversion M).
      apply pow1_a_b_inv_eq in N; auto.
      destruct N as (L, R).
      subst.
      rewrite app_length in *.
      (* Normalize addition, like we did with app *)
      repeat rewrite <- Nat.add_assoc in *.
      (* We now have to show that |y| + b = b *)
      apply plus_inv_eq_r in R.
      apply plus_inv_eq_r in R.
      apply plus_inv_zero_l in R.
      (* But we know that |y| >= 1, so we reach a contradiction *)
      destruct y. {
        contradiction.
      }
      inversion R.
  Qed.
End Examples.


Require Export P06.

(* Write a relation [bevalR] in the same style as
   [aevalR], and prove that it is equivalent to [beval]. *)

(* Don't use aeval and beval when define bevalR (only use aevalR). *)

Inductive bevalR: bexp -> bool -> Prop :=
  (* FILL_IN_HERE *)
.

(** If your definition can't proof these examples using "do 20 try econstructor", **)
(** comment out and write your proofs in following area. **)

(*
Example my_bevalR1: bevalR (BNot BTrue) false.
Proof. do 20 try econstructor. Qed.
Example my_bevalR2: bevalR (BEq (APlus (ANum 2) (ANum 1)) (ANum 3)) true.
Proof. do 20 try econstructor. Qed.
Example my_bevalR3: bevalR (BAnd (BLe (AMult (ANum 3) (ANum 1))
                                        (AMinus (ANum 1) (ANum 3)))
                                   BTrue) false.
Proof. do 20 try econstructor. Qed.
*)

Check aeval_iff_aevalR.

Lemma beval_iff_bevalR : forall b bv,
  bevalR b bv <-> beval b = bv.
Proof.
  exact FILL_IN_HERE.
Qed.


(* Produce canonical lists using merge sort and deduplication. *)

Require Import Permutation.
From larith Require Import A_setup B1_utils.

Notation Sorted leb := (RTC (λ x y, leb x y = true)).
Notation Increasing leb := (RTC (λ x y, leb y x = false)).

(*
The primary goal of this file is to supply an efficient algorithm to normalize
lists of states in the powerset automaton construction. For the correctness of
the depth-first search, a list containing all states must exist. To realize this
we will represent states as strictly increasing lists.
*)
Section Canonical_lists.

Variable X : Type.
Variable leb : X -> X -> bool.

Notation Sorted := (Sorted leb).
Notation Increasing := (Increasing leb).

Notation "x <= y" := (leb x y = true) (at level 70).
Notation "x > y" := (leb x y = false) (at level 70).

(* Proving `Sorted (mergesort l)` only requires totality. *)
Hypothesis leb_total : ∀x y, x <= y \/ y <= x.

(* Proving `Increasing (dedup l)` only requires anti-symmetry. *)
Hypothesis leb_asym : ∀x y, x <= y /\ y <= x <-> x = y.

(* Proving uniqueness of increasing lists uses the above + transitivity. *)
Hypothesis leb_trans : ∀x y z, x <= y -> y <= z -> x <= z.

(* These three hypotheses represent a linear order. *)
Definition Linear_order :=
  (∀x y, x <= y /\ y <= x <-> x = y) /\
  (∀x y z, x <= y -> y <= z -> x <= z) /\
  (∀x y, x <= y \/ y <= x).

Local Lemma gt_leb x y :
  x > y -> y <= x.
Proof.
destruct (leb_total y x); [easy|congruence].
Qed.

Local Lemma leb_refl x :
  x <= x.
Proof.
apply leb_asym; easy.
Qed.

(******************************************************************************)
(* I. A merge sort algorithm.                                                 *)
(******************************************************************************)
(* Initial author: Hugo Herbelin, Oct 2009                                    *)
(* This section only relies on the leb_total hypothesis.                      *)
(******************************************************************************)
Section Mergesort.

Notation Sorted_stack stack := (Forall Sorted (strip stack)).
Notation flatten stack := (concat (strip stack)).

Fixpoint merge l1 l2 :=
  let fix merge_aux l2 :=
  match l1, l2 with
  | [], _ => l2
  | _, [] => l1
  | x1 :: l1', x2 :: l2' =>
    if leb x1 x2
    then x1 :: merge l1' l2
    else x2 :: merge_aux l2'
  end
  in merge_aux l2.

Fixpoint merge_push stack l :=
  match stack with
  | [] => [Some l]
  | None :: stack' => Some l :: stack'
  | Some l' :: stack' => None :: merge_push stack' (merge l' l)
  end.

Fixpoint merge_all stack :=
  match stack with
  | [] => []
  | None :: stack' => merge_all stack'
  | Some l :: stack' => merge l (merge_all stack')
  end.

Fixpoint merge_iter stack l :=
  match l with
  | [] => merge_all stack
  | x :: l' => merge_iter (merge_push stack [x]) l'
  end.

Definition mergesort := merge_iter [].

Section Sorted.

Theorem Sorted_merge l1 l2 :
  Sorted l1 -> Sorted l2 -> Sorted (merge l1 l2).
Proof.
revert l2; induction l1; induction l2; intros; simpl; auto.
destruct (leb a a0) eqn:Heq1.
- inv H. simpl; apply RTC_cons; easy.
  assert(IH := IHl1 _ H3 H0); simpl; simpl in IH.
  destruct (leb y a0); apply RTC_cons; easy.
- apply gt_leb in Heq1.
  inv H0. apply RTC_cons; easy.
  assert(IH := IHl2 H H3); simpl; simpl in IH.
  destruct (leb a y); apply RTC_cons; easy.
Qed.

Theorem Sorted_stack_merge_push stack l :
  Sorted_stack stack -> Sorted l -> Sorted_stack (merge_push stack l).
Proof.
revert l; induction stack as [|[|]]; intros; simpl.
1,3: constructor; easy. inv H. apply IHstack. easy.
apply Sorted_merge; easy.
Qed.

Theorem Sorted_stack_merge_all stack :
  Sorted_stack stack -> Sorted (merge_all stack).
Proof.
induction stack as [|[|]]; simpl; intros. constructor.
inv H; apply Sorted_merge. all: auto.
Qed.

Theorem Sorted_merge_iter stack l :
  Sorted_stack stack -> Sorted (merge_iter stack l).
Proof.
revert stack; induction l; simpl; intros.
apply Sorted_stack_merge_all, H.
apply IHl, Sorted_stack_merge_push. easy. constructor.
Qed.

Theorem Sorted_mergesort l :
  Sorted (mergesort l).
Proof.
apply Sorted_merge_iter; constructor.
Qed.

End Sorted.

Section Permutation.

Theorem Permutation_merge l1 l2 :
  Permutation (l1 ++ l2) (merge l1 l2).
Proof.
revert l2; induction l1; simpl merge; intros.
- destruct l2; apply Permutation_refl.
- induction l2. rewrite app_nil_r; apply Permutation_refl.
  destruct (leb a a0). apply perm_skip, IHl1.
  apply Permutation_sym, Permutation_cons_app, Permutation_sym, IHl2.
Qed.

Theorem Permutation_merge_push stack l :
  Permutation (l ++ flatten stack) (flatten (merge_push stack l)).
Proof.
revert l; induction stack as [|[]]; simpl; intros.
- reflexivity.
- rewrite app_assoc; etransitivity.
  apply Permutation_app_tail; etransitivity.
  apply Permutation_app_comm. apply Permutation_merge. apply IHstack.
- reflexivity.
Qed.

Theorem Permutation_merge_all stack :
  Permutation (flatten stack) (merge_all stack).
Proof.
induction stack as [|[]]; simpl. easy.
transitivity (l ++ merge_all stack).
apply Permutation_app_head, IHstack.
apply Permutation_merge. apply IHstack.
Qed.

Theorem Permutation_merge_iter l stack :
  Permutation (flatten stack ++ l) (merge_iter stack l).
Proof.
revert stack; induction l; simpl; intros.
rewrite app_nil_r; apply Permutation_merge_all.
rewrite cons_app, app_assoc; etransitivity.
apply Permutation_app_tail; etransitivity.
apply Permutation_app_comm.
apply Permutation_merge_push.
apply IHl.
Qed.

Theorem Permutation_mergesort l :
  Permutation l (mergesort l).
Proof.
apply (Permutation_merge_iter l []).
Qed.

End Permutation.

End Mergesort.

(******************************************************************************)
(* II. Deduplication of sorted lists.                                         *)
(******************************************************************************)
(* This section only relies on the leb_asym hypothesis.                       *)
(******************************************************************************)
Section Deduplication.

Fixpoint dedup l :=
  match l with
  | [] => []
  | x :: l' =>
    match l' with
    | []     => [x]
    | y :: _ => if leb y x then dedup l' else x :: dedup l'
    end
  end.

Theorem dedup_eqv l x :
  Sorted l -> In x (dedup l) <-> In x l.
Proof.
intros; induction l; simpl.
easy. destruct l. easy. inv H.
apply IHl in H2; destruct (leb x0 a) eqn:Ha.
- assert(a = x0) by (apply leb_asym; easy); subst.
  etransitivity. apply H2. simpl; intuition.
- symmetry; transitivity (a = x \/ In x (dedup (x0 :: l))).
  rewrite H2; reflexivity. easy.
Qed.

Lemma Increasing_cons_dedup x y l :
  Sorted (y :: l) -> y > x -> Increasing (x :: dedup (y :: l)).
Proof.
revert x y; induction l; intros. repeat constructor; easy.
replace (dedup _) with (if leb a y then dedup (a::l) else y :: dedup (a::l))
by easy; inv H; destruct (leb a y) eqn:Ha.
- apply IHl. easy. assert(a = y) by (now apply leb_asym); subst; easy.
- constructor. apply IHl. all: easy.
Qed.

Theorem Increasing_dedup l :
  Sorted l -> Increasing (dedup l).
Proof.
induction l; simpl; intros. constructor.
inv H. constructor. destruct (leb y a) eqn:Hy.
auto. apply Increasing_cons_dedup; easy.
Qed.

Theorem length_dedup l :
  (length (dedup l) <= length l)%nat.
Proof.
induction l. easy. destruct l. easy.
replace (dedup _) with (if leb x a then dedup (x::l) else a :: dedup (x::l))
by easy; destruct (leb _). apply le_S, IHl. apply le_n_S, IHl.
Qed.

End Deduplication.

(******************************************************************************)
(* III. Uniqueness of increasing lists.                                       *)
(******************************************************************************)
Section Uniqueness.

Lemma Increasing_le x y l :
  Increasing (y :: l) -> x <= y -> ¬In x l.
Proof.
revert y; induction l; simpl; intros. easy.
inv H; intros []. subst; congruence.
apply IHl with (y:=a); try easy.
apply leb_trans with (y:=y). easy. apply gt_leb, H5.
Qed.

Corollary Increasing_tl x l :
  Increasing (x :: l) -> ¬In x l.
Proof.
intros; apply Increasing_le with (y:=x).
apply H. apply leb_refl.
Qed.

Corollary Increasing_lt x y l :
  Increasing (y :: l) -> y > x -> ¬In x (y :: l).
Proof.
intros Hy Hx [F|F].
subst; rewrite leb_refl in Hx; easy.
apply Increasing_le with (y:=y) in F.
easy. easy. apply gt_leb, Hx.
Qed.

Theorem Increasing_unique l1 l2 :
  (∀x, In x l1 <-> In x l2) ->
  Increasing l1 -> Increasing l2 ->
  l1 = l2.
Proof.
revert l2; induction l1; destruct l2; intros. easy.
1,2: exfalso; eapply in_nil, H, in_eq. assert(a = x).
- apply leb_asym; split.
  + destruct (leb a x) eqn:F; [easy|exfalso].
    eapply Increasing_lt; [apply H0|apply F|apply H, in_eq].
  + destruct (leb x a) eqn:F; [easy|exfalso].
    eapply Increasing_lt; [apply H1|apply F|apply H, in_eq].
- subst; apply wd, IHl1. apply Increasing_tl in H0, H1.
  intros y; split; intros Y; eapply in_cons in Y as Z; apply H in Z; inv Z.
  all: eapply RTC_weaken. apply H0. apply H1.
Qed.

End Uniqueness.

(******************************************************************************)
(* IV. The normalization function.                                            *)
(******************************************************************************)
Section Normalization.

Definition normalize l := dedup (mergesort l).

Theorem Increasing_normalize l :
  Increasing (normalize l).
Proof.
apply Increasing_dedup, Sorted_mergesort.
Qed.

Theorem normalize_eqv l x :
  In x (normalize l) <-> In x l.
Proof.
etransitivity. apply dedup_eqv, Sorted_mergesort.
split; apply Permutation_in. apply Permutation_sym.
all: apply Permutation_mergesort.
Qed.

Theorem normalize_fixed_point l :
  Increasing l -> normalize l = l.
Proof.
intros; apply Increasing_unique. apply normalize_eqv.
apply Increasing_normalize. apply H.
Qed.

End Normalization.

(******************************************************************************)
(* V. Exhausting all increasing sequences over a finite domain.               *)
(******************************************************************************)
Section Powerset.

Notation Below x := (Forall (λ y, leb y x = false)).

Fixpoint powerset (dom : list X) :=
  match dom with
  | [] => [[]]
  | a :: dom' => let p := powerset dom' in p ++ map (cons a) p
  end.

Theorem Increasing_Below x l :
  Increasing (x :: l) -> Below x l.
Proof.
intros; apply Forall_forall; intros.
destruct (leb x0 x) eqn:Hx; [|easy].
apply Increasing_le with (l:=l) in Hx; easy.
Qed.

Theorem Below_Increasing x l :
  Increasing l -> Below x l -> Increasing (x :: l).
Proof.
destruct l; intros; constructor.
easy. inv H0.
Qed.

Local Lemma X_dec (x y : X) :
  {x = y} + {x ≠ y}.
Proof.
destruct (leb x y) eqn:Hx, (leb y x) eqn:Hy. left; apply leb_asym; easy.
all: right; intros F; apply leb_asym in F; rewrite Hx, Hy in F; easy.
Qed.

Local Lemma Increasing_remove x l :
  Increasing l -> Increasing (remove X_dec x l).
Proof.
induction l; simpl; intros. constructor.
apply RTC_weaken in H as Hl; apply IHl in Hl.
destruct (X_dec x a); [easy|].
apply Below_Increasing; [easy|].
apply Forall_incl with (l':=l); intros.
apply in_remove in H0; easy. apply Increasing_Below, H.
Qed.

Theorem Increasing_In_powerset dom l :
  (∀x, In x l -> In x dom) ->
  Increasing dom -> Increasing l ->
  In l (powerset dom).
Proof.
revert l; induction dom as [|e dom']; simpl; intros.
destruct l; [now left|right]; eapply H, in_eq.
assert(He := Increasing_remove e _ H1).
assert(In (remove X_dec e l) (powerset dom')). {
  apply IHdom'. intros x Hx; apply in_remove in Hx as [].
  apply H in H2 as []; [congruence|easy].
  eapply RTC_weaken, H0. easy. }
apply in_app_iff; destruct (in_dec X_dec e l).
2: left; rewrite notin_remove in H2; easy. right.
apply in_map_iff; exists (remove X_dec e l); split; [|easy].
apply Increasing_unique; try easy.
- split. intros []. subst; easy. apply in_remove in H3; easy.
  intros; destruct (X_dec x e). subst; apply in_eq.
  apply in_cons, in_in_remove; easy.
- apply Below_Increasing.
  apply Increasing_remove, H1.
  apply Forall_incl with (l':=dom'); intros.
  apply in_remove in H3 as [].
  apply H in H3 as []; [congruence|easy].
  apply Increasing_Below, H0.
Qed.

End Powerset.

End Canonical_lists.

Arguments Linear_order {_}.
Arguments mergesort {_}.
Arguments dedup {_}.
Arguments normalize {_}.
Arguments powerset {_}.


Require Export List.
Require Export Induction.

Inductive list (X: Type): Type :=
| nil: list X
| cons: X -> list X -> list X.

Check nil.
Check cons.

Check nil.
Check (cons nat 2 (cons nat 1 (nil nat))).

Fixpoint repeat (X: Type) (x: X) (count: nat): list X :=
    match count with
    | O => nil X
    | S count' => cons X x (repeat X x count')
    end.

Example test_repeat1 :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity. Qed.

Example test_repeat2 :
  repeat bool false 1 = cons bool false (nil bool).
Proof. reflexivity. Qed.

Module MumbleGrumble.
  Inductive mumble: Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.

  Inductive grumble (X: Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

  Compute (d mumble (b a 5)).
  Compute d bool (b a 5).
  Compute d nat (b a 5).

End MumbleGrumble.

Fixpoint repeat' X x count: list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat' X x count')
  end.

Check 1.

Theorem repeat_same: forall (X: Type) (x: X) (count: nat),
    repeat X x count = repeat X x count.
Proof.
  intros X x count.
  reflexivity.
Qed.

Fixpoint repeat'' X x count: list X :=
  match count with
  | 0 => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

Definition p_zl: forall (n: nat), 0 + n = n.
Proof.
  intros n.
  reflexivity.
Qed.

Definition p_zr: forall (n: nat), n + 0 = n.
Proof.
  intros n.
  induction n as [|k IH].
  - reflexivity.
  - simpl.
    rewrite -> IH.
    reflexivity.
Qed.

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

Fixpoint repeat''' {X: Type} (x: X) (count: nat) : list X :=
  match count with
  | 0 => nil
  | S count' => cons x (repeat''' x count')
  end.

Inductive list' {X: Type} : Type :=
| nil' : list'
| cons' : X -> list' -> list'.

Fixpoint app {X: Type} (l1 l2: list X) : (list X) :=
  match l1 with
  | nil => l2
  | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X: Type} (l: list X) : (list X) :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint length {X: Type} (l: list X) : nat :=
  match l with
  | nil => 0
  | cons h t => (length t) + 1
  end.

Example test_rev1 :
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity. Qed.

Example test_rev2:
  rev (cons true nil) = cons true nil.
Proof. reflexivity. Qed.

Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity. Qed.

Fail Definition mynil := nil.

Definition mynil: list nat := nil.

Check @nil.

Definition mynil' := @nil nat.

Notation "x :: y" := (cons x y)
                       (at level 60, right associativity).

Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y) (at level 60, right associativity).

Definition list123'''' := [1;2;3].

Theorem app_nil_r: forall (X: Type), forall (l: list X), l ++ [] = l.
Proof.
  intros X l.
  induction l.
  - reflexivity.
  - simpl.
    rewrite -> IHl.
    reflexivity.
Qed.

Theorem app_assoc: forall A (l m n: list A),
    l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros A l m n.
  induction l.
  - reflexivity.
  - simpl.
    rewrite -> IHl.
    reflexivity.
Qed.

Theorem app_length: forall (X: Type) (l1 l2: list X),
    length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros X l1 l2.
  induction l1.
  - reflexivity.
  - simpl.
    rewrite -> IHl1.
    rewrite <- plus_assoc.
    replace (length l2 + 1) with (1 + length l2).
    rewrite -> plus_assoc.
    + reflexivity.
    + rewrite -> plus_comm.
      reflexivity.
Qed.

Theorem rev_app_distr: forall X (l1 l2: list X),
    rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros X l1 l2.
  induction l1.
  - simpl.
    rewrite -> app_nil_r.
    reflexivity.
  - simpl.
    rewrite -> IHl1.
    rewrite -> app_assoc.
    reflexivity.
Qed.

Theorem rev_involutive: forall (X: Type) (l: list X),
    rev (rev l) = l.
Proof.
  intros X l.
  induction l.
  - reflexivity.
  - simpl.
    rewrite -> rev_app_distr.
    rewrite -> IHl.
    reflexivity.
Qed.

Inductive prod (X Y: Type) :Type :=
| pair: X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).

(* Notation "X * Y" := (prod X Y) : type_scope. *)
Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | pair x y => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | pair x y => y
  end.

Fixpoint combine {X Y : Type} (lx: list X) (ly: list Y) : list (X * Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: combine tx ty
  end.

Compute (combine [1;2] [true;false;true]).

Fixpoint split {X Y: Type} (l: list (X * Y)) : (list X) * (list Y) :=
  match l with
  | [] => ([], [])
  | (x, y) :: t => (x :: fst (split t), y :: snd (split t))
  end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof.
  reflexivity.
Qed.

Inductive option (X: Type): Type :=
| Some : X -> option X
| None : option X.

Arguments Some {X} _.
Arguments None {X}.

Fixpoint nth_error {X: Type} (l: list X) (n: nat) : option X :=
  match l with
    | [] => None
    | h :: t => if beq_nat n 0 then Some h else nth_error t (n -1)
  end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.

Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.

Example test_nth_error3 : nth_error [true] 2 = None.
Proof. reflexivity. Qed.

Definition hd_error {X : Type} (l : list X) : option X :=
  nth_error l 0.

Example test_hd_error1 : hd_error [1;2] = Some 1.
Proof. reflexivity. Qed.

Example test_hd_error2 : hd_error [[1];[2]] = Some [1].
Proof. reflexivity. Qed.

Definition doit3times {X: Type} {f: X -> X} (n: X): X :=
  f (f (f n)).
Arguments doit3times {X} _ _.

Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity. Qed.

Example test_doit3times': doit3times negb true = false.
Proof. reflexivity. Qed.

Fixpoint filter {X: Type} (test: X -> bool) (l: list X) :(list X) :=
  match l with
  | [] => []
  | h :: t => if test h then h :: (filter test t) else (filter test t)
  end.

Example test_filter1: filter evenb [1;2;3;4] = [2;4].
Proof. reflexivity. Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  beq_nat (length l) 1.

Example test_filter2:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.

Definition countoddmembers' (l:list nat) : nat :=
  length (filter oddb l).

Example test_countoddmembers'1: countoddmembers' [1;0;3;1;4;5] = 4.
Proof. reflexivity. Qed.
Example test_countoddmembers'2: countoddmembers' [0;2;4] = 0.
Proof. reflexivity. Qed.
Example test_countoddmembers'3: countoddmembers' nil = 0.
Proof. reflexivity. Qed.

Example test_anon_fun':
  doit3times (fun n => n * n) 2 = 256.
Proof.
  reflexivity.
Qed.

Example test_filter2':
    filter (fun l => beq_nat (length l) 1)
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.

Require Export Basics.

Definition filter_even_gt7 (l: list nat) : list nat :=
  filter (blt_nat 7) (filter evenb l).

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof.
  reflexivity.
Qed.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof. reflexivity. Qed.

Definition partition {X: Type} (f: X -> bool) (l: list X) : list X * list X :=
  pair (filter f l) (filter (fun n => negb (f n)) l).

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity. Qed.

Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity. Qed.

Fixpoint map {X Y: Type} (f: X -> Y) (l: list X) : (list Y) :=
  match l with
  | [] => []
  | h :: t => f h :: map f t
  end.

Example test_map1: map (fun x => plus 3 x) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.

Example test_map2:
  map oddb [2;1;2;5] = [false;true;false;true].
Proof. reflexivity. Qed.

Example test_map3:
    map (fun n => [evenb n;oddb n]) [2;1;2;5]
  = [[true;false];[false;true];[true;false];[false;true]].
Proof. reflexivity. Qed.

Lemma map_rev_assoc: forall (X Y: Type) (f: X -> Y) (l1 l2: list X),
    map f (l1 ++ l2) = map f l1 ++ map f l2.
Proof.
  intros X Y f l1 l2.
  induction l1.
  - reflexivity.
  - simpl.
    rewrite -> IHl1.
    reflexivity.
Qed.

Theorem map_rev: forall (X Y: Type) (f: X -> Y) (l: list X),
    map f (rev l) = rev (map f l).
Proof.
  intros X Y f l.
  induction l.
  - reflexivity.
  - simpl.
    rewrite <- IHl.
    rewrite -> map_rev_assoc.
    reflexivity.
Qed.

Fixpoint flat_map {X Y: Type} (f: X -> list Y) (l: list X) : (list Y) :=
  match l with
  | [] => []
  | h :: t => f h ++ flat_map f t
  end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. reflexivity. Qed.

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

Fixpoint fold {X Y: Type} (f: X -> Y -> Y) (l: list X) (b: Y) : Y :=
  match l with
  | [] => b
  | h :: t => f h (fold f t b)
  end.

Example fold_example1 :
  fold mult [1;2;3;4] 1 = 24.
Proof. reflexivity. Qed.

Example fold_example2 :
  fold andb [true;true;false;true] true = false.
Proof. reflexivity. Qed.

Example fold_example3 :
  fold app [[1];[];[2;3];[4]] [] = [1;2;3;4].
Proof. reflexivity. Qed.

Definition constfun {X: Type} (x: X): nat -> X :=
  fun (k: nat) => x.

Definition ftrue := constfun true.

Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.

Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

Definition plus3 := plus 3.
Check plus3.

Example test_plus3 : plus3 4 = 7.
Proof. reflexivity. Qed.
Example test_plus3' : doit3times plus3 0 = 9.
Proof. reflexivity. Qed.
Example test_plus3'' : doit3times (plus 3) 0 = 9.
Proof. reflexivity. Qed.

Module Exercises.
  Definition fold_length {X: Type} (l: list X) : nat :=
    fold (fun _ n => S n) l 0.

  Example test_fold_length1 : fold_length [4;7;0] = 3.
  Proof. reflexivity. Qed.

  Lemma eq_remove_s: forall n m,
      n = m -> S n = S m.
  Proof.
    intros n m H.
    rewrite -> H.
    reflexivity.
  Qed.

  Theorem fold_length_correct: forall X (l: list X),
      fold_length l = length l.
  Proof.
    intros X l.
    induction l.
    - reflexivity.
    - unfold fold_length.
      unfold fold_length in IHl.
      simpl.
      simpl in IHl.
  Admitted.

  Definition fold_map {X Y: Type} (f: X -> Y) (l: list X) : list Y :=
    fold (fun x p => f x :: p) l [].

  Theorem fold_map_correct: forall X Y (l: list X) (f: X -> Y),
      fold_map f l = map f l.
  Proof.
    intros X Y l f.
    induction l.
    - reflexivity.
    - unfold fold_map.
      unfold fold_map in IHl.
      simpl.
      rewrite -> IHl.
      reflexivity.
  Qed.

  Definition prod_curry {X Y Z: Type} (f: X * Y -> Z) (x: X) (y: Y) : Z := f (x, y).

  Definition prod_uncurry {X Y Z: Type} (f: X -> Y -> Z) (p: X * Y) : Z :=
    match p with
    | (x, y) => f x y
    end.

  Example test_map2: map (fun x => plus 3 x) [2;0;2] = [5;3;5].
  Proof. reflexivity. Qed.

  Theorem uncurry_curry: forall (X Y Z: Type) (f: X -> Y ->Z) x y,
      prod_curry (prod_uncurry f) x y = f x y.
  Proof.
    intros X Y Z f x y.
    unfold prod_curry.
    unfold prod_uncurry.
    reflexivity.
  Qed.

  Fixpoint nth_error {X: Type} (l: list X) (n: nat) : option X :=
    match l with
    | [] => None
    | a :: l' => if beq_nat n O then Some a else nth_error l' (pred n)
    end.

  Theorem p1n0: forall (n: nat),
      beq_nat (n + 1) 0 = false.
  Proof.
    intro n.
    induction n.
    + reflexivity.
    + reflexivity.
  Qed.

  Theorem pred_length: forall X (x: X) (l: list X) (n: nat),
      length (x :: l) = n -> length l = pred n.
  Proof.
    intros X x l n H.
    simpl in H. induction l.
    - simpl in H.
      rewrite <- H.
      reflexivity.
    - Admitted.

  Theorem nth_index_error: forall X (l: list X) (n: nat),
      length l = n -> @nth_error X l n = None.
  Proof.
    intros X l n H.
    generalize dependent n.
    induction l.
    - reflexivity.
    - intros.
      apply pred_length in H.
      apply IHl in H.
  Admitted.

  Module Church.
    Definition nat := forall {X: Type},
      (X -> X) -> X -> X.

    Definition zero: nat :=
      fun {X: Type} (f: X -> X) (x: X) => x.

    Definition one: nat :=
      fun {X: Type} (f: X -> X) (x: X) => f x.

    Definition two: nat :=
      fun {X: Type} (f: X -> X) (x: X) => f (f x).

    Definition three: nat := @doit3times.

    Definition succ (n: nat): nat :=
      fun {X: Type} (f: X -> X) (x: X) => f (n X f x).

    Example succ_1: succ zero = one.
    Proof. reflexivity. Qed.

    Example succ_2: succ one = two.
    Proof. reflexivity. Qed.

    Example succ_3: succ two = three.
    Proof. reflexivity. Qed.

    Definition plus(n m: nat): nat :=
      fun (X: Type) (f: X -> X) (x: X) => (n X f (m X f x)).

    Example plus_1 : plus zero one = one.
    Proof. reflexivity. Qed.

    Example plus_2 : plus two three = plus three two.
    Proof. reflexivity. Qed.

    Example plus_3 : plus (plus two two) three = plus one (plus three three).
    Proof. reflexivity. Qed.

    Definition mult(n m: nat): nat :=
      fun (X: Type) (f: X -> X) (x: X) => (m X (n X f) x).

    Example mult_1 : mult one one = one.
    Proof. reflexivity. Qed.

    Example mult_2 : mult zero (plus three three) = zero.
    Proof. reflexivity. Qed.

    Example mult_3 : mult two three = plus three three.
    Proof. reflexivity. Qed.

    Compute (mult two two).

  End Church.
End Exercises.