Require Import Coq.Sets.Constructive_sets.
Require Import Coq.Bool.Bool.
Require Import Coq.micromega.Lia.
Require Import Coq.Arith.PeanoNat.

Definition group_closure {X : Type} (A : Ensemble X) (op : X -> X -> X) :=
    forall x y: X, A x /\ A y -> A (op x y).

Definition group_associativity {X : Type} (A : Ensemble X) (op : X -> X -> X) :=
    forall x y z : X, A x /\ A y /\ A z -> op (op x y) z = op x (op y z).

Definition group_identity {X : Type} (e : X) (A : Ensemble X) (op : X -> X -> X) :=
    forall x : X, A x -> op x e = op e x /\ op x e = x /\ op e x = x.

Definition group_inverse {X : Type} (e : X) (A : Ensemble X) (op : X -> X -> X) :=
    forall x : X, A x -> exists x_inv, op x x_inv = e /\ op x_inv x = e.

Definition EmptyBoolSet : Ensemble bool :=
    Empty_set bool.

Definition BoolSet : Ensemble bool := Full_set bool.

Theorem All_in_BoolSet : forall x : bool, In bool BoolSet x.
Proof.
    unfold In.
    unfold BoolSet.
    apply Full_intro.
Qed.

Theorem Bool_closed : group_closure BoolSet xorb.
Proof.
    unfold group_closure.
    intros x y H.
    apply All_in_BoolSet.
Qed.

Theorem Bool_associative : group_associativity BoolSet xorb.
Proof.
    unfold group_associativity.
    intros x y z H.
    apply xorb_assoc_reverse.
Qed.

Theorem Bool_identity : group_identity false BoolSet xorb.
Proof.
    unfold group_identity.
    intros x H.
    rewrite xorb_false_r.
    rewrite xorb_false_l.
    split; try split; reflexivity.
Qed.

Theorem Bool_inverse : group_inverse false BoolSet xorb.
Proof.
    unfold group_inverse.
    intros x H.
    destruct x.
    - exists true. split; reflexivity.
    - exists false. split; reflexivity.
Qed.

Definition Group {X : Type} (S : Ensemble X) (op : X -> X -> X) (e : X) :=
group_closure S op /\ group_associativity S op /\ group_identity e S op /\ group_inverse e S op.

Theorem BooleanGroup : Group BoolSet xorb false.
Proof.
    unfold Group.
    split.
    apply Bool_closed.
    split.
    apply Bool_associative.
    split.
    apply Bool_identity.
    apply Bool_inverse.
Qed.

Definition plus_mod_n (n x y : nat) := (plus x y) mod n.

Fixpoint Numbers0Ton (n : nat) (S : Ensemble nat) :=
match n with
| 0 => Add nat S 0
| S n' => Add nat (Numbers0Ton n' S) n
end.

Definition Zn (n : nat) :=
match n with
| 0 => Empty_set nat
| S n' => Numbers0Ton n' (Empty_set nat)
end.

Theorem m_lt_n_in_Zn : forall n m, m < n -> In nat (Zn n) m.
Proof.
  intros.
  induction n.
  - lia.
  - assert(H' : m < n \/ m = n). { lia. }
    destruct H'.
    + apply IHn in H0.
      destruct n.
      simpl in H0.
      contradiction.
      simpl.
      apply Union_introl.
      apply H0.
    + destruct n;
      apply Union_intror;
      rewrite H0;
      apply In_singleton.
Qed.

Theorem Zn_set_equivalence : forall n : nat, Zn (S n) = Add nat (Zn n) n.
Proof.
  intros.
  apply Extensionality_Ensembles.
  induction n.
  {
    split.
    - unfold Included.
      intros.
      simpl.
      simpl in H.
      apply H.
    - unfold Included.
      intros.
      simpl.
      simpl in H.
      apply H.
  }
  {
    apply Extensionality_Ensembles in IHn.
    split.
    - intros x H.
      simpl.
      simpl in H.
      apply H.
    - intros x H.
      apply H.
  }
Qed.

Theorem m_in_Zn_m_lt_n : forall n m, In nat (Zn n) m -> m < n.
Proof.
  intros.
  induction n.
  - simpl in H. apply Noone_in_empty in H. contradiction.
  - assert(H0: Zn (S n) = Add nat (Zn n) n). { apply Zn_set_equivalence. }
    assert(H1 : In nat (Zn n) m \/ m = n).
    {
      rewrite H0 in H.
      induction H.
      - left. apply H.
      - right.
        apply Singleton_inv in H.
        lia.
    }
    destruct H1.
    + apply IHn in H1. lia.
    + lia.
Qed.

Definition group_homomorphism {X Y : Type} (G1 : Ensemble X) (op1 : X -> X -> X) (e1 : X)
(G2 : Ensemble Y) (op2 : Y -> Y -> Y) (e2 : Y) (f : X -> Y) : Prop :=
Group G1 op1 e1 /\ Group G2 op2 e2 -> forall (x y : X), G1 x /\ G1 y -> f (op1 x y) = op2 (f x) (f y) /\ G2 (f x) /\ G2 (f y).

Theorem mod_lt_n : forall x n, x < S n -> x mod (S n) = x.
Proof.
Admitted.

Theorem mod_plus : forall n x y, x mod S n + y mod (S n) = (x + y) mod S n.
Proof.
  intros.
Admitted.

Theorem mod_mod : forall n x, (x mod S n) mod S n = x mod S n.
Admitted.

Theorem In_Zn_iff_lt_n : forall n x, x < n <-> Zn n x.
Admitted.

Theorem n_mod_n : forall n, n <> 0 -> n mod n = 0.
Proof.
Admitted.

Theorem plus_mod_n_3 : forall n x y z,
plus_mod_n (S n) (plus_mod_n (S n) x y) z = (x + y + z) mod (S n).
Proof.
  intros.
  unfold plus_mod_n.
  remember (x + y) as w.
  rewrite <- mod_plus.
  rewrite mod_mod.
  rewrite mod_plus.
  reflexivity.
Qed.

Theorem ZnGroup : forall n, n <> 0 -> Group (Zn n) (plus_mod_n n) 0.
Proof.
    unfold Group.
    intros.
    destruct n.
    - contradiction.
    - split.
      unfold group_closure.
      intros.
      simpl.
      induction n.
      simpl.
      apply Add_intro2.
      assert(S n <> 0). {
        lia.
      }
      induction (x+y); simpl.
      assert(H' : n - n = 0). { lia. }
      rewrite H'.
      assert(H'' : Add nat (Numbers0Ton n (Empty_set nat)) (S n) = Zn (S (S n))).
      {
        reflexivity.
      }
      rewrite H''.
      assert(H''' : 0 < S (S n)).
      {
        lia.
      }
      apply m_lt_n_in_Zn in H'''.
      apply H'''.
      destruct (snd (Init.Nat.divmod n0 (S n) 0 n)).
      apply Add_intro2.
      assert(H'' : Add nat (Numbers0Ton n (Empty_set nat)) (S n) = Zn (S (S n))).
      {
        reflexivity.
      }
      rewrite H''.
      apply m_lt_n_in_Zn.
      lia.
      split.
      simpl.
      unfold group_associativity.
      intros.
      destruct H0.
      destruct H1.
      rewrite plus_mod_n_3.
      unfold plus_mod_n.
      replace ((x + y + z)) with ((x + (y + z))).
      remember (y + z) as w.
      rewrite <- mod_plus.
      replace (x + w mod S n) with (w mod S n + x).
      rewrite <- mod_plus.
      rewrite mod_mod.
      replace (x mod S n + w mod S n) with (w mod S n + x mod S n).
      reflexivity.
      lia.
      lia.
      lia.
      split.
      unfold group_identity.
      intros.
      split.
      unfold plus_mod_n.
      replace (x + 0) with x.
      replace (0 + x) with x.
      reflexivity.
      lia.
      lia.
      split.
      unfold plus_mod_n.
      replace (x + 0) with x.
      apply mod_lt_n.
      simpl.
      apply In_Zn_iff_lt_n.
      apply H0.
      lia.
      unfold plus_mod_n.
      replace (0 + x) with x.
      apply mod_lt_n.
      apply In_Zn_iff_lt_n.
      apply H0.
      lia.
      unfold group_inverse.
      intros.
      exists (S n - x).
      split.
      unfold plus_mod_n.
      assert(H' : x < S n).
      {
        apply In_Zn_iff_lt_n in H0.
        apply H0.
      }
      assert(x + (S n - x) = S n). { lia. }
      rewrite H1.
      apply n_mod_n.
      apply H.
      unfold plus_mod_n.
      assert(H' : x < S n).
      {
        apply In_Zn_iff_lt_n in H0.
        apply H0.
      }
      assert(S n - x + x = S n). { lia. }
      rewrite H1.
      apply n_mod_n.
      lia.
Qed.

Theorem Z2_Group : Group (Zn 2) (plus_mod_n 2) 0.
Proof.
 apply ZnGroup.
 lia.
Qed.

Definition Bool_Z2_Map (x : bool) : nat :=
match x with
| false => 0
| true => 1
end.

Theorem Bool_Z2_Homomorphism : group_homomorphism
BoolSet xorb false
(Zn 2) (plus_mod_n 2) 0
Bool_Z2_Map.
Proof.
  unfold group_homomorphism.
  intros.
  unfold plus_mod_n.
  destruct x; destruct y; try simpl; repeat (try split; try reflexivity; try apply Add_intro2; try apply Add_intro1).
Qed.


Require Export TopologicalSpaces.
Require Export OrderTopology.
Require Export Reals.

Definition RTop := OrderTopology Rle.

Require Export MetricSpaces.

Definition R_metric (x y:R) : R := Rabs (y-x).

Lemma R_metric_is_metric: metric R_metric.
Proof.
constructor.
intros.
unfold R_metric.
pose proof (Rabs_pos (y-x)).
auto with *.

intros.
unfold R_metric.
replace (y-x) with (-(x-y)); try ring.
apply Rabs_Ropp.

intros.
unfold R_metric.
replace (z-x) with ((y-x) + (z-y)); try ring.
apply Rabs_triang.

intros.
unfold R_metric.
replace (x-x) with 0; try ring.
exact Rabs_R0.

intros.
assert (y-x=0).
apply NNPP.
contradict H.
apply Rabs_no_R0; assumption.
auto with *.
Qed.

Lemma Rmetric_bound: forall x y z:R, R_metric x z < y - x ->
  z < y.
Proof.
intros.
replace z with (x + (z-x)); try ring.
apply Rle_lt_trans with (x + R_metric x z).
assert (z - x <= R_metric x z).
apply Rle_abs.
auto with real.
replace y with (x + (y-x)); try ring.
auto with real.
Qed.

Lemma Rmetric_bound2: forall x y z:R, R_metric y z < y - x ->
  x < z.
Proof.
intros.
replace z with (y + (z-y)); try ring.
apply Rlt_le_trans with (y - R_metric y z).
apply Rlt_minus in H.
apply Rminus_lt.
replace (x - (y - R_metric y z)) with
  (R_metric y z - (y - x)); try ring.
trivial.
assert (y - z <= R_metric y z).
rewrite (metric_sym _ _ R_metric_is_metric y z).
apply Rle_abs.
apply Rle_minus in H0.
apply Rminus_le.
replace (y - R_metric y z - (y + (z - y))) with
  (y - z - R_metric y z); trivial; ring.
Qed.

Lemma RTop_metrization: metrizes RTop R_metric.
Proof.
refine (let Hsubbasis := Build_TopologicalSpace_from_subbasis_subbasis
  _ (order_topology_subbasis _ Rle) in _).
clearbody Hsubbasis.
red; intros.
constructor.
intros.
destruct H.
assert (open_ball (point_set RTop) R_metric x r = Intersection
  [ y:R | x-r <= y /\ y <> x-r ]
  [ y:R | y <= x+r /\ y <> x+r ]).
apply Extensionality_Ensembles; split; red; intros.
destruct H0.
assert (x - r < x0).
apply Rmetric_bound2 with x.
ring_simplify; trivial.
assert (x + r > x0).
apply Rmetric_bound with x.
ring_simplify; trivial.
repeat split; auto with real.
constructor.
destruct H0.
destruct H0.
destruct H0.
destruct H1.
destruct H1.
apply Rabs_def1.
assert (x0-x <= r).
apply Rminus_le.
apply Rle_minus in H1.
replace (x0 - x - r) with (x0 - (x + r)); trivial; ring.
assert (x0 - x <> r).
intro.
contradiction H3.
rewrite <- H5.
ring.
destruct (total_order_T (x0 - x) r) as [[|]|]; try tauto.
assert (r < r).
apply Rlt_le_trans with (x0 - x); trivial.
contradict H6.
apply Rlt_irrefl.
assert (-r <= x0 - x).
apply Rle_minus in H0.
apply Rminus_le.
replace (-r - (x0 - x)) with (x - r - x0); try ring; trivial.
assert (-r <> x0 - x).
intro.
contradiction H2.
replace r with (- -r); try ring.
rewrite H5; ring.
destruct (total_order_T (-r) (x0 - x)) as [[|]|]; try tauto.
assert (-r < -r).
apply Rle_lt_trans with (x0 - x); trivial.
contradict H6.
apply Rlt_irrefl.

rewrite H0.
constructor.
apply (@open_intersection2 RTop).
apply Hsubbasis; constructor.
apply Hsubbasis; constructor.
assert (x-r < x).
apply Rminus_lt.
ring_simplify.
auto with real.
assert (x+r > x).
apply Rminus_gt.
ring_simplify; trivial.
repeat split; auto with real.

intros.
destruct H.
destruct H.
destruct H0.
pose proof (H _ H0).
assert (exists eps:R, eps > 0 /\ Included (open_ball _ R_metric x eps) S).
clear H0.
induction H2.
exists 1.
split.
red.
auto with real.
intro; constructor.
destruct H0.
destruct H1.
destruct H0.
exists (x0-x).
split.
destruct (total_order_T x0 x) as [[]|].
assert (x < x).
apply Rle_lt_trans with x0; trivial.
contradict H2.
apply Rlt_irrefl.
congruence.
apply Rgt_minus; trivial.
red; intros y ?.
destruct H2.
constructor.
assert (y < x0).
apply Rmetric_bound with x; trivial.
split; auto with real.

destruct H1.
destruct H0.
exists (x - x0).
split.
destruct (total_order_T x0 x) as [[]|].
apply Rgt_minus; trivial.
congruence.
assert (x < x).
apply Rlt_le_trans with x0; trivial.
contradict H2.
apply Rlt_irrefl.
intros y ?.
destruct H2.
constructor.
assert (x0 < y).
apply Rmetric_bound2 with x; trivial.
split; auto with real.
destruct H1.
apply IHfinite_intersections in H1.
apply IHfinite_intersections0 in H3.
destruct H1 as [eps1 []].
destruct H3 as [eps2 []].
exists (Rmin eps1 eps2).
split.
unfold Rmin.
destruct Rle_dec; trivial.
red; intros y ?.
destruct H6.
constructor.
apply H4.
constructor.
apply Rlt_le_trans with (Rmin eps1 eps2); trivial.
unfold Rmin; destruct Rle_dec; auto with real.
apply H5.
constructor.
apply Rlt_le_trans with (Rmin eps1 eps2); trivial.
unfold Rmin; destruct Rle_dec; auto with real.

destruct H3 as [eps []].
exists (open_ball R R_metric x eps).
split.
constructor.
trivial.
assert (Included S (FamilyUnion F)).
intros y ?.
exists S; trivial.
auto with sets.
Qed.

Corollary RTop_metrizable: metrizable RTop.
Proof.
exists R_metric.
exact R_metric_is_metric.
exact RTop_metrization.
Qed.

Lemma RTop_separable: separable RTop.
Proof.
Require Import RationalsInReals.
exists (Im Full_set Q2R).
apply countable_img.
apply countable_type_ensemble.
exact Q_countable.

apply meets_every_nonempty_open_impl_dense.
intros.
destruct H0 as [x].
destruct (RTop_metrization x).
destruct (open_neighborhood_basis_cond U) as [V []].
split; trivial.
destruct H1.
destruct (rationals_dense_in_reals (x-r) (x+r)) as [q].
apply Rminus_gt.
replace (x+r-(x-r)) with (r+r); try ring.
apply Rgt_trans with r; auto with real.
pattern r at 3.
replace r with (r+0); try ring.
auto with real.

exists (Q2R q).
constructor.
exists q; trivial.
constructor.
apply H2.
constructor.
destruct H3.
apply Rabs_def1.
apply Rminus_lt.
apply Rlt_minus in H4.
replace (Q2R q - x - r) with (Q2R q - (x + r)); trivial; ring.
apply Rminus_lt.
apply Rlt_minus in H3.
replace (-r - (Q2R q - x)) with (x - r - Q2R q); trivial; ring.
Qed.

Require Export Compactness.

Lemma bounded_real_net_has_cluster_point: forall (I:DirectedSet)
  (x:Net I RTop) (a b:R), (forall i:DS_set I, a <= x i <= b) ->
  exists x0:point_set RTop, net_cluster_point x x0.
Proof.
(* idea: the liminf is a cluster point *)
intros.
destruct (classic (inhabited (DS_set I))) as [Hinh|Hempty].
assert (forall i:DS_set I, { y:R | is_glb
                             (Im [ j:DS_set I | DS_ord i j ] x) y }).
intro.
apply inf.
exists a.
red; intros.
destruct H0.
destruct (H x0).
rewrite H1.
auto with real.
exists (x i).
exists i; trivial.
constructor.
apply preord_refl.
apply DS_ord_cond.

assert ({ x0:R | is_lub (Im Full_set (fun i:DS_set I => proj1_sig (X i)))
                        x0 }).
apply sup.
exists b.
red; intros.
destruct H0 as [i].
destruct (X i).
simpl in H1.
rewrite H1.
destruct i0.
cut (b >= x0).
auto with real.
apply Rge_trans with (x i).
destruct (H i).
auto with real.
apply H2.
exists i; trivial.
constructor.
apply preord_refl.
apply DS_ord_cond.

destruct Hinh as [i0].
exists (proj1_sig (X i0)).
exists i0; trivial.
constructor.

destruct H0 as [x0].
exists x0.
assert (forall i j:DS_set I, DS_ord i j ->
  proj1_sig (X i) <= proj1_sig (X j)).
intros.
destruct (X i0).
destruct (X j).
simpl.
destruct i1.
destruct i2.
apply H4.
red; intros.
destruct H5.
destruct H5.
apply H1.
exists x3; trivial.
constructor.
apply preord_trans with j; trivial.
apply DS_ord_cond.

red; intros.
destruct (RTop_metrization x0).
destruct (open_neighborhood_basis_cond U).
split; trivial.
destruct H3.
destruct H3.
destruct (lub_approx _ _ r i).
trivial.
destruct H5.
destruct H5.
destruct H6.
red; intros.
destruct (DS_join_cond x1 i0).
destruct H9.
remember (X x2) as y2.
destruct y2.
destruct (glb_approx _ _ r i1).
trivial.
destruct H11.
destruct H11.
destruct H11.
destruct H12.
exists x4.
split.
apply preord_trans with x2; trivial.
apply DS_ord_cond.
apply H4.
constructor.
assert (y <= proj1_sig (X x2)).
rewrite H7.
apply H0; trivial.
rewrite <- Heqy2 in H15.
simpl in H15.
assert (proj1_sig (X x2) <= x0).
apply i.
exists x2; trivial.
constructor.
rewrite <- Heqy2 in H16.
simpl in H16.
rewrite <- H13.
apply Rabs_def1.

cut (y0 < x0 + r).
intro.
apply Rlt_minus in H17.
apply Rminus_lt.
replace (y0 - x0 - r) with (y0-(x0+r)); trivial; ring.
apply Rlt_le_trans with (x3 + r).
trivial.
auto with real.

cut (y0 > x0 - r).
intro.
apply Rlt_minus in H17.
apply Rminus_lt.
replace (-r - (y0-x0)) with (x0-r-y0); trivial; ring.
apply Rge_gt_trans with y.
apply Rge_trans with x3; auto with real.
trivial.

exists a.
red; intros.
red; intros.
contradiction Hempty.
exists; exact i.
Qed.

Lemma R_closed_interval_compact: forall a b:R, a <= b ->
  compact (SubspaceTopology ([x:point_set RTop | a <= x <= b])).
Proof.
intros a b Hbound.
apply net_cluster_point_impl_compact.
intros.
pose (y := fun i:DS_set I => proj1_sig (x i)).
destruct (bounded_real_net_has_cluster_point _ y a b).
intros.
unfold y.
destruct (x i).
destruct i0.
simpl.
trivial.

assert (closed [x:point_set RTop | a <= x <= b]).
assert ([x:point_set RTop | a <= x <= b] = Intersection
                [ x:point_set RTop | a <= x ]
                [ x:point_set RTop | x <= b ]).
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
destruct H1.
constructor; constructor; trivial.
destruct H1.
destruct H1.
destruct H2.
constructor.
auto.
rewrite H1.
apply closed_intersection2.
apply upper_closed_interval_closed.
constructor; red; intros; auto with real.
apply Rle_trans with y0; trivial.
intros.
destruct (total_order_T x1 y0) as [[|]|]; auto with real.
apply lower_closed_interval_closed.
constructor; red; intros; auto with real.
apply Rle_trans with y0; trivial.
intros.
destruct (total_order_T x1 y0) as [[|]|]; auto with real.

assert (Ensembles.In [x:point_set RTop | a <= x <= b] x0).
rewrite <- (closure_fixes_closed _ H1).
apply net_cluster_point_in_closure with y.
destruct H as [i0].
exists i0.
intros.
constructor.
unfold y.
destruct (x j).
simpl.
destruct i.
trivial.
trivial.

exists (exist _ x0 H2).
red; intros.
destruct (subspace_topology_topology _ _ _ H3) as [V].
destruct H5.
red; intros.
assert (Ensembles.In V x0).
rewrite H6 in H4.
destruct H4.
simpl in H4.
trivial.

destruct (H0 V H5 H7 i) as [j []].
exists j.
split; trivial.
rewrite H6.
constructor.
simpl.
exact H9.
Qed.

Lemma R_compact_subset_bounded: forall A:Ensemble (point_set RTop),
  compact (SubspaceTopology A) -> bound A.
Proof.
intros.
destruct (H (Im Full_set (fun y:R => inverse_image (subspace_inc _)
                   [ x:point_set RTop | y - 1 < x < y + 1 ]))).
intros.
destruct H0.
rewrite H1.
apply subspace_inc_continuous.
replace [x0:point_set RTop | x-1 < x0 < x+1] with
  (Intersection [x0:point_set RTop | x-1 <= x0 /\ x0 <> x-1]
                [x0:point_set RTop | x0 <= x+1 /\ x0 <> x+1]).
pose proof (Build_TopologicalSpace_from_subbasis_subbasis
  _ (order_topology_subbasis _ Rle)).
apply open_intersection2.
apply H2.
constructor.
apply H2.
constructor.
apply Extensionality_Ensembles; split; red; intros.
destruct H2.
destruct H2.
destruct H2.
destruct H3.
destruct H3.
constructor.
split.
destruct (total_order_T (x-1) x0) as [[|]|]; auto with real.
contradiction H4; symmetry; trivial.
assert (x0 < x0).
apply Rlt_le_trans with (x-1); auto with real.
contradict H6; apply Rlt_irrefl.
destruct (total_order_T x0 (x+1)) as [[|]|]; auto with real.
contradiction H5.
assert (x0 < x0).
apply Rle_lt_trans with (x+1); auto with real.
contradict H6; apply Rlt_irrefl.
destruct H2.
destruct H2.
constructor; constructor; split; auto with real.

apply Extensionality_Ensembles; split; red; intros.
constructor.
eexists.
exists (proj1_sig x).
constructor.
reflexivity.
constructor.
constructor.
destruct x.
simpl.
split; apply Rminus_lt; auto with real.
replace (x-1-x) with (-1); try ring.
apply Ropp_lt_gt_0_contravar.
exact Rlt_0_1.

destruct H0.
destruct H1.
assert (exists a:R, forall S:Ensemble (point_set (SubspaceTopology A)),
  forall b:point_set (SubspaceTopology A),
  Ensembles.In x S -> Ensembles.In S b -> proj1_sig b < a).
clear H2.
induction H0.
exists 0.
intros.
destruct H0.
destruct IHFinite.
cut (Included A0 (Add A0 x)); auto with sets.
assert (Ensembles.In (Add A0 x) x).
right.
constructor.
apply H1 in H4.
destruct H4.
exists (Rmax x0 (x+1)).
intros.
destruct H6.
apply Rlt_le_trans with x0.
apply H3 with x1; trivial.
unfold Rmax.
destruct Rle_dec; auto with real.
destruct H6.
rewrite H5 in H7.
destruct H7.
destruct H6.
apply Rlt_le_trans with (x+1).
apply H6.
unfold Rmax; destruct Rle_dec; auto with real.

destruct H3 as [a].
exists a.
red; intros.
assert (Ensembles.In (FamilyUnion x)
  (exist (fun x:R => Ensembles.In A x) x0 H4)).
rewrite H2; constructor.
inversion H5.
pose proof (H3 _ _ H6 H7).
simpl in H9.
auto with real.
Qed.

Lemma Ropp_continuous: continuous Ropp (X:=RTop) (Y:=RTop).
Proof.
apply pointwise_continuity.
intro.
apply metric_space_fun_continuity with R_metric R_metric;
  try apply RTop_metrization.
intros.
exists eps.
split; trivial.
intros.
unfold R_metric.
replace (-x' - -x) with (x-x'); try ring.
rewrite Rabs_minus_sym; trivial.
Qed.

Require Export Connectedness.

Lemma R_connected: connected RTop.
Proof.
cut (forall S:Ensemble (point_set RTop),
  clopen S -> Ensembles.In S 0 -> S = Full_set).
intro.
red; intros.
destruct (classic (Ensembles.In S 0)).
right.
apply H; trivial.
left.
assert (Complement S = Full_set).
apply H; trivial.
destruct H0; split; trivial.
red; rewrite Complement_Complement; trivial.
apply Extensionality_Ensembles; split; red; intros.
assert (Ensembles.In (Complement S) x).
rewrite H2; constructor.
contradiction H4.
destruct H3.

cut (forall S:Ensemble (point_set RTop),
  clopen S -> Ensembles.In S 0 -> forall x:R, x > 0 ->
                                  Ensembles.In S x).
intro.
assert (forall S:Ensemble (point_set RTop),
  clopen S -> Ensembles.In S 0 -> forall x:R, x < 0 ->
                                  Ensembles.In S x).
intros.
pose (T := inverse_image Ropp S).

assert (Ensembles.In T (-x)).
apply H.
destruct H0; split.
apply Ropp_continuous; trivial.
red.
subst T.
rewrite <- inverse_image_complement.
apply Ropp_continuous; trivial.
constructor.
replace (-0) with 0; trivial; ring.
cut (0 < -x); auto with real.
destruct H3.
rewrite Ropp_involutive in H3; trivial.

intros.
apply Extensionality_Ensembles; split; red; intros.
constructor.
destruct (total_order_T x 0) as [[|]|].
apply H0; trivial.
congruence.
apply H; trivial.

intros.
apply NNPP; intro.
pose (T := [ y:R | forall z:R, 0 <= z <= y -> Ensembles.In S z ]).
assert (Ensembles.In T 0).
constructor.
intros.
assert (z = 0).
destruct H3; auto with real.
rewrite H4; trivial.

destruct (sup T).
exists x.
red; intros.
cut (~ x0>x).
apply Rnot_lt_le; auto with real.
intro.
destruct H4.
apply H2.
apply H4.
split; auto with real.
exists 0.
exact H3.

assert (0 <= x0).
apply i.
exact H3.

destruct (RTop_metrization x0).
assert (Ensembles.In S x0).
rewrite <- (closure_fixes_closed S); try apply H.
apply meets_every_open_neighborhood_impl_closure.
intros.
destruct (open_neighborhood_basis_cond U).
split; trivial.
destruct H7.
destruct H7.
destruct (lub_approx _ _ r i).
trivial.
destruct H9.
exists (Rmax x1 0).
constructor.
unfold Rmax.
destruct Rle_dec.
trivial.
apply H9.
auto with real.

apply H8.
constructor.
unfold Rmax.
destruct Rle_dec.
unfold R_metric.
rewrite Rabs_minus_sym.
replace (x0-0) with x0; try ring.
apply Rabs_def1.
apply Rminus_lt.
destruct H10.
apply Rlt_le_trans with x1; trivial.
apply Rlt_le_trans with 0; auto with real.

apply Rabs_def1.
apply Rle_lt_trans with 0; auto with real.
destruct H10.
apply Rle_minus; trivial.
destruct H10.
apply Rminus_lt.
apply Rlt_minus in H10.
replace (-r - (x1-x0)) with (x0-r-x1); trivial; ring.

destruct (open_neighborhood_basis_cond S).
split; trivial.
apply H.
destruct H6.
destruct H6.

destruct (lub_approx _ _ r i).
trivial.
destruct H8.

assert (Ensembles.In T (x0+r/2)).
constructor.
intros.
destruct H10.
destruct (total_order_T z x1) as [[|]|].
apply H8.
split; auto with real.
apply H8.
split; auto with real.
apply H7.
constructor.
apply Rabs_def1.
apply Rle_lt_trans with (r/2).
apply Rminus_le.
apply Rle_minus in H11.
replace (z-x0-r/2) with (z-(x0+r/2)); trivial; ring.
apply Rminus_gt.
replace (r-r/2) with (r/2); try field.
apply Rmult_gt_0_compat; auto with real.
auto with *.
apply Rlt_trans with (x1 - x0).
destruct H9.
apply Rlt_minus in H9.
apply Rminus_lt.
replace (-r - (x1-x0)) with (x0-r-x1); trivial; ring.
cut (x1<z); trivial.
intro.
unfold Rminus.
auto with real.

assert (x0 + r/2 <= x0).
apply i.
exact H10.

absurd (x0 + r/2 > x0).
apply Rge_not_gt; auto with real.
apply Rminus_gt.
ring_simplify.
apply Rmult_gt_0_compat; auto with real.
apply Rinv_0_lt_compat.
auto with real.
Qed.

Require Export Completeness.

Lemma R_cauchy_sequence_bounded: forall x:nat->R,
  cauchy R_metric x -> bound (Im Full_set x).
Proof.
intros.
destruct (H 1) as [N].
red; auto with real.
assert (exists y:R, forall n:nat, (n<N)%nat -> x n <= y).
clear H0; induction N.
exists 0.
intros.
contradict H0.
auto with arith.
destruct IHN as [y].
exists (Rmax y (x N)).
intros.
apply lt_n_Sm_le in H1.
destruct (le_lt_or_eq _ _ H1).
apply Rle_trans with y.
apply H0; trivial.
apply Rmax_l.
rewrite H2.
apply Rmax_r.

destruct H1 as [y].
exists (Rmax y (x N + 1)).
red; intros.
destruct H2 as [n].
rewrite H3; clear y0 H3.
destruct (le_or_lt N n).
apply Rle_trans with (x N + 1).
assert (R_metric (x n) (x N) < 1).
apply H0; auto with arith.
apply Rabs_def2 in H4.
destruct H4.
Require Import Fourier.
fourier.
apply Rmax_r.
apply Rle_trans with y; auto.
apply Rmax_l.
Qed.

Lemma R_cauchy_sequence_lower_bound: forall x:nat->R,
  cauchy R_metric x -> lower_bound (Im Full_set x).
Proof.
intros.
assert (cauchy R_metric (fun n:nat => - x n)).
red; intros.
destruct (H eps H0) as [N].
exists N.
intros.
replace (R_metric (- x m) (- x n)) with (R_metric (x m) (x n)).
apply H1; trivial.
unfold R_metric.
replace (x n - x m) with (- (- x n - - x m)) by ring.
apply Rabs_Ropp.
destruct (R_cauchy_sequence_bounded _ H0) as [m].
exists (-m).
red; intros.
cut (-x0 <= m).
intros; fourier.
apply H1.
destruct H2 as [n].
exists n; trivial.
f_equal; trivial.
Qed.

Lemma R_metric_complete: complete R_metric R_metric_is_metric.
Proof.
red; intros.
destruct (R_cauchy_sequence_bounded _ H) as [b].
destruct (R_cauchy_sequence_lower_bound _ H) as [a].
destruct (bounded_real_net_has_cluster_point nat_DS x a b) as [x0].
intros; split; [ cut (x i >= a); auto with real; apply H1 | apply H0 ];
  exists i; trivial; constructor.
exists x0.
apply cauchy_sequence_with_cluster_point_converges; trivial.
apply metric_space_net_cluster_point with R_metric;
  try apply MetricTopology_metrizable.
intros.
apply metric_space_net_cluster_point_converse with RTop; trivial.
apply RTop_metrization.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Arith.Compare_dec.
Require Import Arith.Wf_nat.
Require Import Recdef.

Open Scope nat_scope.

Definition max (a b : nat) :=
    match nat_compare a b with
    | Lt => b
    | _  => a
    end.

Inductive tree :=
    | Tip : tree
    | Bin : nat -> tree -> tree -> tree.

Definition ht (t : tree) :=
    match t with
    | Tip       => 0
    | Bin n _ _ => n
    end.

Definition join (x y : tree) : tree := Bin (max (ht x) (ht y) + 1) x y.

Fixpoint step (t : tree) (xs : list tree) : list tree :=
    match xs with
    | nil      => t :: nil
    | u :: nil =>
        match nat_compare (ht t) (ht u) with
        | Lt => t :: u :: nil
        | _  => (join t u) :: nil
        end
    | u :: v :: ts =>
        match nat_compare (ht t) (ht u) with
        | Lt => t :: u :: v :: ts
        | _  =>
            match nat_compare (ht t) (ht v) with
            | Lt => step (join t u) (v :: ts)
            | _  => step t (step (join u v) ts)
            end
        end
    end.

(* TODO: problem: there is no fold1 in Coq (partial) *)
Definition build (xs : list tree) := fold_left join (fold_right step nil xs).


Require Import Ring.
Require Import Field.
Require Import Setoid.
Require Import Classes.RelationClasses.
Require Import Classes.Morphisms.
Require Import Ensembles.
Require Import Vector.

Section VS.

(*Variable (A : Type).*)

Class Ring A :=
  {
  r0 : A;
  r1 : A;
  radd : A -> A -> A;
  rmult : A -> A -> A;
  rainv : A -> A;
  rminus : A -> A -> A;
  isring : ring_theory r0 r1 radd rmult rminus rainv eq;
  }.
(*
Context `{Ring A}.
*)
Class Field A `{Ring A} :=
  {
  fdiv : A -> A -> A;
  finv : A -> A;
  isfield : field_theory r0 r1 radd rmult rminus rainv fdiv finv eq;
  }.

Declare Scope field_scope.
Delimit Scope field_scope with fieldsc.
Open Scope field_scope.
Bind Scope field_scope with Field.
Infix "+" := radd : field_scope.
Infix "*" := rmult : field_scope.
Notation "- k" := rainv : field_scope.
Notation "/ k" := finv : field_scope.
Infix "/" := fdiv : field_scope.

Variable (F V : Type).
Context `{Field F}.
Variable vadd : V -> V -> V.
Variable vsmult : F -> V -> V.
Variable v0 : V.
Variable veq : V -> V -> Prop.

Infix "⨥" := vadd (at level 50).
Infix "*" := vsmult.
Notation "0" := v0.
Infix "==" := veq (at level 90).

(*1.19*)
Record vectorspace_theory
       (*(vadd : V -> V -> V) (vsmult : F -> V -> V) (v0 : V) (veq : V -> V -> Prop)*)
  : Prop
  := mk_vst
       {
         vadd_comm : forall (x y : V), x ⨥ y == y ⨥ x;
         vadd_assoc : forall (x y z : V), (x ⨥ y) ⨥ z == x ⨥ (y ⨥ z);
         vadd_ident : forall (x : V), x ⨥ 0 == x;
         vadd_inv : forall (x : V), exists (w : V), x ⨥ w == 0;
         vsmult_ident : forall (x : V), r1 * x == x;
         vdistr1 : forall (a : F) (x y : V), a * (x ⨥ y) == (a * x) ⨥ (a * y);
         vdistr2 : forall (a b : F) (x : V), (a + b) * x == (a * x) ⨥ (b * x);
       }.

(*vector equality is extensional*)
Record vec_eq_ext : Prop
  :=
    mk_veqe {
        vadd_ext : Proper (veq ==> veq ==> veq) vadd;
        vsmult_ext : Proper (eq ==> veq ==> veq) vsmult;
      }.

(*1.18*)
Class VectorSpace F `{Field F} V :=
  {
  vaddition : V -> V -> V;
  vscalar_mult : F -> V -> V;
  v0 : V;
  veq : relation V;
  isvectorspace : vectorspace_theory vaddition vscalar_mult v0 veq;
  }.

Declare Scope vectorspace_scope.
Delimit Scope vectorspace_scope with vecsc.
Open Scope vectorspace_scope.
Bind Scope vectorspace_scope with VectorSpace.

Context `{VectorSpace F V}.

Definition vainv (v : V) :=
  vscalar_mult (rainv r1) v.

Definition vminus (u v : V) :=
  vaddition u (vainv v).

Infix "⨥" := vaddition (at level 50) : vectorspace_scope.
Infix "*" := vscalar_mult : vectorspace_scope.
Notation "⨪" := vainv : vectorspace_scope.
Infix "⨪" := vminus (at level 50) : vectorspace_scope.
Infix "==" := veq (at level 90) : vectorspace_scope.

Record vectorspace_eq_ext : Prop
  :=
    mk_vseqe
      {
        vadd_ext : Proper ((fun u => fun v => u == v) ==> (fun u => fun v => u == v) ==> (fun u => fun v => u == v))
                          (fun u => fun v => u ⨥ v);
        vsmult_ext : Proper ((fun x => fun y => x = y) ==> (fun u => fun v => u == v) ==> (fun u => fun v => u == v))
                            (fun (a : F) => fun (v : V) => a * v);
        v0_ext : Proper (fun u => fun v => u == v) v0;
}.
Compute relation V.
Instance vadd_Proper (u v : V) :
  Proper (veq ==> veq ==> veq) vaddition.
Proof.
  unfold Proper.

Theorem veq_equiv_refl : forall (v : V), v == v.
  Admitted.

Theorem veq_equiv_symm : forall (u v : V), u == v -> v == u.
  Admitted.

Theorem veq_equiv_trans : forall (u v w : V), u == v -> v == w -> u == w.
  Admitted.

Instance VEqReflexive : Reflexive veq :=
  {
  reflexivity := veq_equiv_refl;
  }.

Instance VEqSymmetric : Symmetric veq :=
  {
  symmetry := veq_equiv_symm;
  }.

Instance VEqTransitive : Transitive veq :=
  {
  transitivity := veq_equiv_trans
  }.

Instance VEqEquiv : Equivalence veq :=
  {
  Equivalence_Reflexive := VEqReflexive;
  Equivalence_Symmetric := VEqSymmetric;
  Equivalence_Transitive := VEqTransitive;
  }.

Theorem veq_refl : forall (v : V), v == v.
Proof.
  intros.
  reflexivity.
Qed.

Theorem veq_symm : forall (u v : V), u == v -> v == u.
Proof.
  intros u v H2.
  rewrite H2.
  reflexivity.
Qed.

Theorem veq_trans : forall (u v w : V), u == v -> v == w -> u == w.
Proof.
  intros u v w H2 H3.
  rewrite H2.
  rewrite <- H3.
  reflexivity.
Qed.

Add Parametric Relation : V veq
  reflexivity proved by veq_refl
  symmetry proved by veq_symm
  transitivity proved by veq_trans
    as veq_equiv_rel.

Add Morphism vaddition with signature (veq ==> veq ==> veq) as vadd_ext1.
  intros.
  Admitted.

Add Morphism vscalar_mult with signature (eq ==> veq ==> veq) as vsmult_ext1.
  intros.
  Admitted.

Ltac unpack_vectorspace H :=
  destruct H;
  inversion isvectorspace0.

Ltac unpack_ring H :=
  destruct H; inversion isring0.

Ltac unpack_field H :=
  destruct H; inversion isfield0.

Ltac vby_definition H :=
  destruct H;
  inversion isvectorspace0;
  simpl;
  easy.

Lemma vaddition_assoc (u v w : V) : (u ⨥ v) ⨥ w == u ⨥ (v ⨥ w).
Proof.
  vby_definition H1.
Qed.

Lemma vaddition_commu (u v : V) : u ⨥ v == v ⨥ u.
Proof.
  vby_definition H1.
Qed.

Lemma vaddition_ident (v : V) : v ⨥ v0 == v.
Proof.
  vby_definition H1.
Qed.

Lemma vaddition_inverse (v : V) : exists (w : V), v ⨥ w == v0.
Proof.
  unpack_vectorspace H1.
  specialize (vadd_inv0 v).
  destruct vadd_inv0 as [w vadd_inv0].
  exists w.
  apply vadd_inv0.
Qed.

Lemma vmultiplicative_identity (v : V) : r1 * v == v.
Proof.
  vby_definition H1.
Qed.

Lemma vdistributive1 (a : F) (u v : V) : a * (u ⨥ v) == a * u ⨥ a * v.
Proof.
  vby_definition H1.
Qed.

Lemma vdistributive2 (a b : F) (v : V) : (a + b) * v == a * v ⨥ b * v.
Proof.
  vby_definition H1.
Qed.

Lemma radd_inv_zero (x : F) : x + rainv x = r0.
Proof.
  unpack_ring H.
  simpl.
  rewrite (Ropp_def x).
  reflexivity.
Qed.

(*1.29*)
Theorem zero_times_vector (v : V) :
  r0 * v == v0.
Proof.
  unpack_field H0.
  inversion F_R.
  rewrite <- (Radd_0_l r0).
  destruct H1; inversion isvectorspace0.
Admitted.

Lemma vadd_inverse_zero (v : V) : v ⨥ ⨪ v == v0.
Proof.
  unfold vainv.
  rewrite <- vmultiplicative_identity at 1.
  rewrite vdistributive1.
  rewrite (vmultiplicative_identity (rainv r1 * v)).
  rewrite <- vdistributive2.
  rewrite radd_inv_zero.
  apply zero_times_vector.
Qed.

Lemma cancel_vadditive1 (u v : V) : u == v -> u ⨥ (⨪ u) == v ⨥ (⨪ u).
Proof.
  intros H2.
  rewrite vadd_inverse_zero.
Admitted.

Lemma add_to_both_sides1 (u v : V) : forall w, u == v -> w ⨥ u == w ⨥ v.
Proof.
  intros.
  rewrite H2.
  reflexivity.
Qed.

Lemma add_to_both_sides2 (u v : V) : forall w, w ⨥ u == w ⨥ v -> u == v.
Proof.
  intros.
  apply add_to_both_sides1 with (w:= ⨪ w) in H2.
  rewrite <- vaddition_assoc in H2; rewrite <- vaddition_assoc in H2 at 1.
  rewrite vaddition_commu with (u:=⨪ w) in H2.
  rewrite vadd_inverse_zero in H2.
  rewrite vaddition_commu in H2; rewrite vaddition_ident in H2.
  rewrite vaddition_commu in H2; rewrite vaddition_ident in H2.
  apply H2.
Qed.

Lemma add_to_both_sides (u v : V) : forall w, u == v <-> w ⨥ u == w ⨥ v.
Proof.
  split.
  - apply add_to_both_sides1.
  - apply add_to_both_sides2.
Qed.

Lemma vaddition_injective (v : V) : forall u w : V, v ⨥ u == v ⨥ w -> u == w.
Proof.
  intros u w H2.
  rewrite (add_to_both_sides2 u w v); easy.
Qed.

(*1.25*)
Theorem unique_vadditive_identity (v v0' : V) (H2 : forall u, u ⨥ v0' == u) : v0' == v0.
Proof.
  specialize (H2 v0).
  rewrite <- H2.
  rewrite vaddition_commu.
  rewrite vaddition_ident.
  reflexivity.
Qed.

Lemma unique_vadditive_identity' (v v0' : V) : v ⨥ (⨪ v) == v0' -> v0' == v0.
Proof.
  intros H2.
  subst.
  rewrite vadd_inverse_zero in H2.
  symmetry.
  apply H2.
Qed.

(*1.26*)
Theorem unique_vadditive_inverse
        (*        (v z' : V) : v ⨥ ((- r1) * v) = z' -> v0 = z'. *)
        (v : V) : forall (w w' : V) (H__w : v ⨥ w == v0) (H__w' : v ⨥ w' == v0),
    w == w'.
Proof.
  intros.
  rewrite <- H__w' in H__w.
  apply vaddition_injective in H__w.
  apply H__w.
Qed.

(*1.30*)
Theorem number_times_zero (a : F) :
  a * v0 == v0.
Proof.
  unpack_vectorspace H1.
  simpl.

Admitted.

(*1.31*)
Theorem minusone_times_vector (v : V) :
  (rainv r1) * v = ⨪ v.
Proof.
  unfold vainv.
  reflexivity.
Qed.

(*exercise 1.B.1*)
Theorem vainv_involutive (v : V) :
  ⨪ (⨪ v) = v.
Proof.
  unfold vainv.
  simpl.

Admitted.

(*exercise 1.B.2*)
Theorem zero_or (a : F) (u : V) :
  a * u = v0 -> a = r0 \/ u = v0.
Proof.
Admitted.

(*End VS.

Section Subspaces.
*)
Record Subspace :=
  {
    set__subspace : Ensemble V;
    additive_ident__subspace : set__subspace v0;
    closed_addition__subspace :
      forall (u w : V), set__subspace u -> set__subspace w -> set__subspace (u ⨥ w);
    closed_smult__subspace :
      forall (a : F) (u : V), set__subspace u -> set__subspace (a * u);
  }.

Definition biplus__subset (U W : Ensemble V) : Ensemble V :=
  fun v => exists (u w : V), U u -> W w -> v == u ⨥ w.

Definition empty_set : Ensemble V :=
  fun u => False.

Definition plus__subset {n : nat} (Un : t (Ensemble V) n) : Ensemble V :=
  fold_left biplus__subset empty_set Un.

Context (U W : Subspace).

Infix "∔" := (fun U1 => fun U2 => biplus__subset (set__subspace U1) (set__subspace U2)) (at level 50).

Definition bi_smallest_containing_subspace (U W : Subspace) : Prop :=
  Included V (set__subspace U) (U ∔ W) /\
  Included V (set__subspace W) (U ∔ W) /\
  (forall (X : Subspace),
      Included V (set__subspace U) (set__subspace X) ->
      Included V (set__subspace W) (set__subspace X) ->
      Included V (U ∔ W) (set__subspace X)).

Theorem smallest_containing_subspace2 : bi_smallest_containing_subspace U W.
Proof.
  unfold bi_smallest_containing_subspace, Included, Ensembles.In in *;
    intros;
    split;
    try split;
    intros.
  - unfold biplus__subset.
    exists x. exists v0.
    intros.
    rewrite vaddition_ident.
    reflexivity.
  - unfold biplus__subset.
    exists v0. exists x.
    intros.
    rewrite vaddition_commu.
    rewrite vaddition_ident.
    reflexivity.
  - unfold biplus__subset in H4; destruct H4 as [u [w H4]].
    inversion X as [X' zero_in_X X_closed_addition _].
    simpl.
Admitted.

Theorem singleton_zero_closed_addition (u w : V) : u == v0 -> w == v0 -> u ⨥ w == v0.
Proof.
  intros.
  rewrite H2.
  rewrite H3.
  rewrite vaddition_ident.
  reflexivity.
Qed.

Theorem singleton_zero_closed_smult (a : F) (u : V) : u == v0 -> a * u == v0.
Proof.
  intros.
Admitted.

Definition singleton_zero : Subspace :=
  {|
  set__subspace := fun v => v == v0 ;
  additive_ident__subspace := (veq_refl v0) ;
  closed_addition__subspace := singleton_zero_closed_addition ;
  closed_smult__subspace := singleton_zero_closed_smult
  |}.

Definition Directsum2'
           (U1 U2 : Subspace)
           (H : (forall (u1 u2 : V), set__subspace U1 u1 -> set__subspace U2 u2 ->
                                u1 ⨥ u2 = v0 -> (u1 == v0) /\ (u2 == v0)))
  : Subspace
  :=

    (*
      function subspace -> subspace -> subspace
      Proposition: subspace -> subspaces -> (a belief that zero can be written uniquely)
     *)

Record Directsum2 :=
  {
  U1 : Subspace;
  U2 : Subspace;
  zero_unique2 :
    forall (u1 u2 : V), set__subspace U1 u1 -> set__subspace U2 u2 ->
                   u1 ⨥ u2 = v0 -> (u1 == v0) /\ (u2 == v0)
  }.

(*1.45*)

Theorem direct_sum_of_two_subspaces (U W : Subspace) :
  Build_Directsum2 U W <-> Intersection V (set__subspace U) (set__subspace W) = singleton_zero.

Inductive even (n : nat) : Prop :=
| ev0 : even 0
| ev__SS (n : nat) : even n.

Record Directsum :=
  {
  n : nat;
  Un : t Subspace n;
  vn : t V n;
  zero_unique :

  }

    End VS.


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

(** Documentation for the standard library can be found at
    http://coq.inria.fr/library/.

    The [Search] command is a good way to look for theorems involving
    objects of specific types.  Take a minute now to experiment with it. *)

(* ################################################################# *)
(** * Identifiers *)
Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

(** (The function [string_dec] comes from Coq's string library.
    If you check the result type of [string_dec], you'll see that it
    does not actually return a [bool], but rather a type that looks
    like [{x = y} + {x <> y}], called a [sumbool], which can be
    thought of as an "evidence-carrying boolean."  Formally, an
    element of [sumbool] is either a proof that two things are equal
    or a proof that they are unequal, together with a tag indicating
    which.  But for present purposes you can think of it as just a
    fancy [bool].) *)

(** Now we need a few basic properties of string equality... *)
Theorem eqb_string_refl : forall s : string, true = eqb_string s s.
Proof. intros s. unfold eqb_string. destruct (string_dec s s) as [|Hs].
  - reflexivity.
  - destruct Hs. reflexivity.
Qed.

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

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

(** This handy variant follows just by rewriting: *)

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

(* ################################################################# *)
(** * Total Maps *)

(** Our main job in this chapter will be to build a definition of
    partial maps that is similar in behavior to the one we saw in the
    [Lists] chapter, plus accompanying lemmas about its behavior.

    This time around, though, we're going to use _functions_, rather
    than lists of key-value pairs, to build maps.  The advantage of
    this representation is that it offers a more _extensional_ view of
    maps, where two maps that respond to queries in the same way will
    be represented as literally the same thing (the very same function),
    rather than just "equivalent" data structures.  This, in turn,
    simplifies proofs that use maps. *)

(** We build partial maps in two steps.  First, we define a type of
    _total maps_ that return a default value when we look up a key
    that is not present in the map. *)

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

(** Intuitively, a total map over an element type [A] is just a
    function that can be used to look up [string]s, yielding [A]s. *)

(** The function [t_empty] yields an empty total map, given a default
    element; this map always returns the default element when applied
    to any string. *)

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

(** More interesting is the [update] function, which (as before) takes
    a map [m], a key [x], and a value [v] and returns a new map that
    takes [x] to [v] and takes every other key to whatever [m] does. *)

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

(** This definition is a nice example of higher-order programming:
    [t_update] takes a _function_ [m] and yields a new function
    [fun x' => ...] that behaves like the desired map. *)

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true)
           "bar" true.

(*Notation*)

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

Example example_empty := (_ !-> false).

(** We then introduce a convenient notation for extending an existing
    map with some bindings. *)
Notation "x '!->' v ';' m" := (t_update m x v)
                                (at level 100, v at next level, right associativity).

Definition examplemap' :=
  ( "bar" !-> true;
    "foo" !-> true;
    _     !-> false
  ).

Example update_example1 : examplemap' "baz" = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap' "foo" = true.
Proof. reflexivity. Qed.

Example update_example3 : examplemap' "quux" = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap' "bar" = true.
Proof. reflexivity. Qed.

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
    (_ !-> v) x = v.
Proof.
  intros. unfold t_empty . reflexivity. Qed.
(** [] *)

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

Definition beq_id id1 id2 :=
  match id1,id2 with
    | Id n1, Id n2 => beq_nat n1 n2
  end.
Check @eqb_string_refl.

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

  (** Vr2_ unfold eqb_string. destruct (string_dec x x) as [|Hx] .
  -reflexivity.
   -rewrite beq_id_refl  *)

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

Lemma t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
    (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
Proof.
  intros. unfold t_update. extensionality i . remember (eqb_string x i) as e; induction e.
  -reflexivity.
   -reflexivity. Qed.

Lemma eqb_stringP : forall x y : string,
    reflect (x = y) (eqb_string x y).
Proof.
  intros. apply iff_reflect. rewrite eqb_string_true_iff. reflexivity. Qed.

Theorem t_update_same : forall (A : Type) (m : total_map A) x,
    (x !-> m x ; m) = m.
Proof.
 (* intros. unfold t_update. extensionality i. remember (eqb_string x i) as e; induction e. trivial.
  -simpl. symmetry in Heqe. apply eqb_string_true_iff in Heqe. rewrite Heqe. reflexivity.
   -simpl.reflexivity.*)
Admitted.
   (** [] *)

Theorem t_update_permute : forall (A : Type) (m : total_map A)
                                  v1 v2 x1 x2,
    x2 <> x1 ->
    (x1 !-> v1 ; x2 !-> v2 ; m)
    =
    (x2 !-> v2 ; x1 !-> v1 ; m).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Partial maps *)

(** Finally, we define _partial maps_ on top of total maps.  A partial
    map with elements of type [A] is simply a total map with elements
    of type [option A] and default element [None]. *)

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

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

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

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

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

Example examplepmap :=
  ("Church" |-> true ; "Turing" |-> false).

(** We now straightforwardly lift all of the basic lemmas about total
    maps to partial maps.  *)

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

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

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

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

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

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


From Undecidability.Shared.Libs.PSL Require Import Base.
From Undecidability.Shared.Libs.PSL Require Import FiniteTypes.
From Complexity.Libs Require Import MorePrelim.
Require Import Lia.

(** * 3-Covering Cards *)
(** We define a variant of Covering Cards where the width is fixed to 3 and the offset is fixed to 1.
  The resulting specialised definitions make the reduction from Turing machines easier to construct.

Moreover, we generalise the definition of CC-steps (here called "valid") to arbitrary coversHead predicates.
This allows us to define the reduction from Turing machines using inductive predicates.
The list-based version (with a set of cards given as a list) is obtained as a special case.

To that end, we define two variants of 3-CC in this file:
- the usual variant (TCC) which is based on lists of cards
- the propositional variant PTCC over an abstract coversHead predicate
*)

Section abstractDefs.
  Variable (X : Type).
  Notation string := (list X).

  (** We first define some general notions for an arbitrary coversHead predicate *)
  Definition coversHeadAbstract := string -> string -> Prop.

  Section fixCoversHead.
    Variable (p : coversHeadAbstract).

    (** coverings inside a string *)
    Definition coversAt (i : nat) a b := p (skipn i a) (skipn i b).
    Lemma coversAt_head a b : p a b <-> coversAt 0 a b.
    Proof.
      unfold coversAt.
      rewrite <- firstn_skipn with (n:= 0) (l:= a) at 1.
      rewrite <- firstn_skipn with (n:= 0) (l:= b) at 1.
      repeat rewrite firstn_O; now cbn.
    Qed.

    Lemma coversAt_step a b x y (i:nat) : coversAt i a b <-> coversAt (S i) (x :: a) (y:: b).
    Proof. intros. unfold coversAt. now cbn. Qed.

    (** validity of a covering *)
    Inductive valid : string -> string -> Prop :=
    | validB: valid [] []
    | validSA a b x y: valid a b -> length a < 2 -> valid (x:: a) (y:: b)
    | validS a b x y : valid a b -> p (x::a) (y::b) -> valid (x::a) (y::b).

    Hint Constructors valid : core.

    Lemma valid_vacuous a b : |a| <= 2 -> |a| = |b| -> valid a b.
    Proof.
      intros.
      destruct a as [ | a1 a]; [ | destruct a as [ | a2 a]; [ | destruct a; cbn in *; [ | lia]]];
      (destruct b as [ | b1 b]; [ | destruct b as [ | b2 b]; [ | destruct b; cbn in *; [ | lia]]]);
          cbn in *; try congruence; eauto.
    Qed.

    Lemma valid_length_inv a b : valid a b -> length a = length b.
    Proof. induction 1; cbn; lia. Qed.

    Lemma relpower_valid_length_inv n a b : relpower valid n a b -> length a = length b.
    Proof.  induction 1; [solve [eauto] | ]. apply valid_length_inv in H. congruence. Qed.

    Lemma valid_base (a b c d e f : X) : valid [a; b ; c] [d; e; f] <-> p [a; b; c] [d; e; f].
    Proof.
      split.
      - intros; inv H. cbn in H5; lia. apply H5.
      - constructor 3. 2: apply H. repeat constructor.
    Qed.

    (** a different characterisation not allocardg vacuous coverings *)
    (** this is conceptually nicer, but it has the problem that p is used in two cases, which makes some proofs harder *)
    Inductive validDirect : string -> string -> Prop :=
    | validDirectB a b : |a| = 3 -> |b| = 3 -> p a b -> validDirect a b
    | validDirectS a b x y : validDirect a b -> p (x::a) (y::b) -> validDirect (x::a) (y::b).

    Lemma validDirect_valid a b : validDirect a b <-> valid a b /\ |a| >= 3.
    Proof.
      split.
      - induction 1 as [a b H0 H1 H2 | a b x y H0 IH H1].
        + split; [ | lia]. list_length_inv. eauto 10.
        + destruct IH as [IH H2]. split; [ | cbn; lia]. eauto 10.
      - intros (H1 & H2). induction H1 as [ | a b x y H0 IH H1 | a b x y H0 IH H1]; cbn in H2; [easy | easy | ].
        list_length_inv. destruct a.
        + clear IH. apply valid_length_inv in H0. cbn in H0. constructor; cbn; easy.
        + constructor 2; [ | apply H1]. apply IH. now cbn.
    Qed.

    (** the explicit characterisation using bounded quantification *)
    Definition validExplicit a b :=
      length a = length b
      /\ forall i, 0 <= i < length a - 2  -> coversAt i a b.

    Lemma valid_iff a b :
      valid a b <-> validExplicit a b.
    Proof.
      unfold validExplicit. split.
      - induction 1.
        + cbn; split; [reflexivity | ].
          intros; lia.
        + destruct IHvalid as (IH1 & IH2). split; [cbn; congruence | ].
          cbn [length]; intros. lia.
        + destruct IHvalid as (IH1 & IH2); split; [cbn; congruence | ].
          cbn [length]; intros.
          destruct i.
          * eauto.
          * assert (0 <= i < (|a|) - 2) by lia. eauto.
      - revert b. induction a; intros b (H1 & H2).
        + inv_list. constructor.
        + inv_list. destruct (le_lt_dec 2 (length a0)).
          * cbn [length] in H2.
            assert (0 <= 0 < S (|a0|) - 2) by lia. specialize (H2 0 H) as H3.
            eapply (@validS a0 b a x). 2: assumption.
            apply IHa. split; [congruence | ].
            intros. assert (0 <= S i < S (|a0|) - 2) by lia.
            specialize (H2 (S i) H4). eauto.
          * constructor.
            2: assumption.
            apply IHa. split; [congruence | intros ].
            cbn [length] in H2. assert (0 <= S i < S(|a0|) - 2) by lia.
            specialize (H2 (S i) H0); eauto.
    Qed.
  End fixCoversHead.

  Hint Constructors valid : core.

  (** valid is congruent with regards to coversHead predicates*)
  Lemma valid_monotonous (p1 p2 : coversHeadAbstract) : (forall x y, p1 x y -> p2 x y) -> forall x y, valid p1 x y -> valid p2 x y.
  Proof.
    intros H x y. induction 1.
    - eauto.
    - constructor 2; eauto.
    - apply H in H1. eauto.
  Qed.

  Corollary valid_congruent p1 p2 :
    (forall u v, p1 u v <-> p2 u v)
    -> forall a b, valid p1 a b <-> valid p2 a b.
  Proof.
    intros; split; [apply valid_monotonous; intros; now apply H | ].
    assert (forall u v, p2 u v <-> p1 u v) by (intros; now rewrite H).
    apply valid_monotonous. intros; now apply H.
  Qed.

End abstractDefs.

Arguments valid {X}.
#[export]
Hint Constructors valid : core.

Ltac inv_valid := match goal with
                    | [ H : valid _ _ _ |- _] => inv H
                  end;
                  try match goal with
                  | [ H : | _ | < 2 |- _] => solve [exfalso;cbn in H;nia]
                  end.

(** ** 3-CC using list-based cards *)

(** use an explicit representation instead of vectors of size 3 since this will make the problem closer to the flattened extractable problem *)
Inductive TCCCardP (Sigma : Type) := {
         cardEl1 : Sigma;
         cardEl2 : Sigma;
         cardEl3 : Sigma
       }.

Inductive TCCCard (Sigma : Type) := {
          prem : TCCCardP Sigma;
          conc : TCCCardP Sigma
        }.

Definition TCCCardP_to_list (sig : Type) (a : TCCCardP sig) := match a with Build_TCCCardP a b c => [a; b; c] end.
Coercion TCCCardP_to_list : TCCCardP >-> list.

Declare Scope cc_scope.
Local Open Scope cc_scope.
Notation "'{' a ',' b ',' c '}'" := (Build_TCCCardP a b c) (format "'{' a ',' b ',' c '}'") : cc_scope.
Notation "a / b" := ({|prem := a; conc := b|}) : cc_scope.

Record TCC := {
               Sigma : finType;
               init : list Sigma;  (* length is encoded implicitly as the length of init*)
               cards : list (TCCCard Sigma);
               final : list (list Sigma);
               steps : nat
             }.

Definition TCC_wellformed C := length (init C) >= 3.

Implicit Type (C : TCC).

(** the final constraint*)
Definition satFinal (X : Type) final (s : list X) :=
  exists subs, subs el final /\ substring subs s.

(** specific definitions and results for list-based cards*)
Section fixInstance.
  Variable (Sigma : Type).
  Variable (init : list Sigma).
  Variable (cards : list (TCCCard Sigma)).
  Variable (final : list (list Sigma)).
  Variable (steps : nat).

  Notation string := (list Sigma).
  Notation card := (TCCCard Sigma).

  Implicit Type (s a b: string).
  Implicit Type (w card : card).
  Implicit Type (x y : Sigma).

  Definition isCard w := w el cards.
  Lemma isRule_length w : length (prem w) = 3 /\ length (conc w) = 3.
  Proof.
    intros. destruct w.
    cbn. destruct prem0, conc0. now cbn.
  Qed.

  (** we now define a concrete covering predicate based on a set of cards *)
  Definition coversHead card a b := prefix (prem card) a /\ prefix (conc card) b.

  Lemma coversHead_length_inv card a b : coversHead card a b -> isCard card -> length a >= 3 /\ length b >= 3.
  Proof.
    intros. unfold coversHead, prefix in *. firstorder.
    - rewrite H. rewrite app_length, (proj1 (isRule_length card)). lia.
    - rewrite H1. rewrite app_length, (proj2 (isRule_length card)). lia.
  Qed.

  Definition coversHeadList cards a b := exists card, card el cards /\ coversHead card a b.

  Lemma coversHeadList_subset cards1 cards2 a b :
    cards1 <<= cards2 -> coversHeadList cards1 a b -> coversHeadList cards2 a b.
  Proof. intros H (r & H1 & H2). exists r. split; [ apply H, H1 | apply H2]. Qed.

  Lemma coversHead_card_inv r a b (σ1 σ2 σ3 σ4 σ5 σ6 : Sigma) : coversHead r (σ1 :: σ2 :: σ3 :: a) (σ4 :: σ5 :: σ6 :: b) -> r = {σ1, σ2 , σ3} / {σ4 , σ5, σ6}.
  Proof.
    unfold coversHead. unfold prefix. intros [(b' & H1) (b'' & H2)]. destruct r. destruct prem0, conc0. cbn in H1, H2. congruence.
  Qed.

  Lemma coversAt_HeadList_add_at_end i (a b c d : string) :
    coversAt (coversHeadList cards) i a b -> coversAt (coversHeadList cards) i (a ++ c) (b ++ d).
  Proof.
    intros. unfold coversAt, coversHeadList in *.
    destruct H as (card & H0 & H). exists card; split; [assumption | ].
    unfold prefix in *. destruct H as ((b1 & H1) & (b2 & H2)).
    split.
    - exists (b1 ++ c). rewrite app_assoc. apply skipn_app2 with (c := prem card ++ b1); [ | assumption].
      destruct card, prem. now cbn.
    - exists (b2 ++ d). rewrite app_assoc. apply skipn_app2 with (c := conc card ++ b2); [ | assumption].
      destruct card, conc. now cbn.
   Qed.
End fixInstance.

(** we define it using the coversHead_pred rewrite predicate *)
Definition TCCLang (C : TCC) :=
  TCC_wellformed C
  /\ exists (sf : list (Sigma C)), relpower (valid (coversHeadList (cards C))) (steps C) (init C) sf
    /\ satFinal (final C) sf.

(** ** variant P-3-CC using propositional rules (defined via inductive predicates) *)

Record PTCC := {
             PSigma : finType;
             Pinit : list PSigma;  (* length is encoded implicitly as the length of init*)
             Pcards : PSigma -> PSigma -> PSigma -> PSigma -> PSigma -> PSigma -> Prop;
             Pfinal : list (list PSigma);
             Psteps : nat
           }.

Definition PTCC_wellformed D := length (Pinit D) >= 3.

Section fixRulePred.
  (** We define the equivalent of coversHeadList for predicate-based rules  *)

  Variable (X : Type).
  Definition cardPred := X -> X -> X -> X -> X -> X -> Prop.
  Variable (p : cardPred).

  Inductive coversHeadInd: list X -> list X -> Prop :=
    | coversHead_indC (x1 x2 x3 x4 x5 x6 : X) s1 s2 :
        p x1 x2 x3 x4 x5 x6 -> coversHeadInd (x1 :: x2 :: x3 :: s1) (x4 :: x5 :: x6 :: s2).

  Hint Constructors coversHeadInd : core.

  (** a few facts which will be useful *)
  Lemma coversHeadInd_tail_invariant (γ1 γ2 γ3 γ4 γ5 γ6 : X) s1 s2 s1' s2' :
    coversHeadInd (γ1 :: γ2 :: γ3 :: s1) (γ4 :: γ5 :: γ6 :: s2) <-> coversHeadInd (γ1 :: γ2 :: γ3 :: s1') (γ4 :: γ5 :: γ6 :: s2').
  Proof. split; intros; inv H; eauto. Qed.

  Corollary coversHeadInd_rem_tail (γ1 γ2 γ3 γ4 γ5 γ6 : X) h1 h2 :
    coversHeadInd [γ1; γ2; γ3] [γ4; γ5; γ6] <-> coversHeadInd (γ1 :: γ2 :: γ3 :: h1) (γ4 :: γ5 :: γ6 :: h2).
  Proof. now apply coversHeadInd_tail_invariant. Qed.

  Lemma coversHeadInd_append_invariant (γ1 γ2 γ3 γ4 γ5 γ6 : X) s1 s2 s1' s2' :
    coversHeadInd (γ1 :: γ2 :: γ3 :: s1) (γ4 :: γ5 :: γ6 :: s2) <-> coversHeadInd (γ1 :: γ2 :: γ3 :: s1 ++ s1') (γ4 :: γ5 :: γ6 :: s2 ++ s2').
  Proof. now apply coversHeadInd_tail_invariant. Qed.

  Lemma coversAt_coversHeadInd_add_at_end i a b h1 h2 :
    coversAt coversHeadInd i a b -> coversAt coversHeadInd i (a ++ h1) (b ++ h2).
  Proof.
    intros. unfold coversAt in *. inv H; symmetry in H0; symmetry in H1; repeat erewrite skipn_app2; eauto; try congruence; cbn; eauto.
  Qed.

  Lemma coversAt_coversHeadInd_rem_at_end i a b h1 h2 :
    coversAt coversHeadInd i (a ++ h1) (b ++ h2) -> i < |a| - 2 -> i < |b| - 2 -> coversAt coversHeadInd i a b.
  Proof.
    intros. unfold coversAt in *.
    assert (i <= |a|) by lia. destruct (skipn_app3 h1 H2) as (a' & H3 & H4). rewrite H3 in H.
    assert (i <= |b|) by lia. destruct (skipn_app3 h2 H5) as (b' & H6 & H7). rewrite H6 in H.
    clear H2 H5.
    rewrite <- firstn_skipn with (l := a) (n := i) in H4 at 1. apply app_inv_head in H4 as <-.
    rewrite <- firstn_skipn with (l := b) (n := i) in H7 at 1. apply app_inv_head in H7 as <-.
    specialize (skipn_length i a) as H7. specialize (skipn_length i b) as H8.
    remember (skipn i a) as l. do 3 (destruct l as [ | ? l] ; [cbn in H7; lia | ]).
    remember (skipn i b) as l'. do 3 (destruct l' as [ | ? l']; [cbn in H8; lia | ]).
    cbn in H. rewrite coversHeadInd_tail_invariant in H. apply H.
  Qed.

End fixRulePred.

#[export]
Hint Constructors coversHeadInd : core.

Definition cardPred_subs (X : Type) (p1 p2 : cardPred X) := forall x1 x2 x3 x4 x5 x6, p1 x1 x2 x3 x4 x5 x6 -> p2 x1 x2 x3 x4 x5 x6.

Lemma coversHeadInd_monotonous (X : Type) (p1 p2 : cardPred X) : cardPred_subs p1 p2 -> forall x y, coversHeadInd p1 x y -> coversHeadInd p2 x y.
Proof.
  intros H x y H1. inv H1. apply H in H0. eauto.
Qed.

Lemma coversHeadInd_congruent (X : Type) (p1 p2 : cardPred X) : (forall x1 x2 x3 x4 x5 x6, p1 x1 x2 x3 x4 x5 x6 <-> p2 x1 x2 x3 x4 x5 x6) -> forall x y, coversHeadInd p1 x y <-> coversHeadInd p2 x y.
Proof.  intros H; intros. split; apply coversHeadInd_monotonous; unfold cardPred_subs; apply H. Qed.

#[export]
Hint Constructors coversHeadInd : core.

Definition PTCCLang (C : PTCC) :=
  PTCC_wellformed C
  /\ exists (sf : list (PSigma C)), relpower (valid (coversHeadInd (@Pcards C))) (Psteps C) (Pinit C) sf
    /\ satFinal (Pfinal C) sf.

(** ** results for agreement of P-3-CC and 3-CC *)
Definition cards_list_ind_agree {X : Type} (p : X -> X -> X -> X -> X -> X -> Prop) (l : list (TCCCard X)) :=
  forall x1 x2 x3 x4 x5 x6, p x1 x2 x3 x4 x5 x6 <-> {x1, x2, x3} / {x4, x5, x6} el l.

Lemma cards_list_ind_coversHead_agree {X : Type} (p : X -> X -> X -> X -> X -> X -> Prop) (l : list (TCCCard X)) :
  cards_list_ind_agree p l -> forall s1 s2, (coversHeadInd p s1 s2 <-> coversHeadList l s1 s2).
Proof.
  intros; split; intros.
  + inv H0. exists ({x1, x2, x3} / {x4, x5, x6}). split.
    * apply H, H1.
    * split; unfold prefix; cbn; eauto.
  + destruct H0 as (r & H1 & ((b & ->) & (b' & ->))).
    destruct r as [prem0 conc0], prem0, conc0. cbn. constructor. apply H, H1.
Qed.

Lemma tpr_ptpr_agree (X : finType) s final steps indcards (listcards : list (TCCCard X)):
  cards_list_ind_agree indcards listcards
  -> (TCCLang (Build_TCC s listcards final steps) <-> PTCCLang (Build_PTCC s indcards final steps)).
Proof.
  intros; split; intros (H0 & sf & H1 & H2); cbn in *.
  - split; [apply H0 | ].
    exists sf; cbn. split; [ | apply H2].
    eapply relpower_congruent; [ apply valid_congruent, cards_list_ind_coversHead_agree, H | apply H1].
  - split; [apply H0 | ].
    exists sf; cbn. split; [ | apply H2].
    eapply relpower_congruent; [ apply valid_congruent; symmetry; apply cards_list_ind_coversHead_agree, H | apply H1].
Qed.


Theorem plus_O_n: forall n : nat , (plus O n) = n.
Proof.
  intros n. simpl. reflexivity. Qed.

Theorem plus_O_n': forall n : nat , (O + n) = n.
Proof.
  intros n. simpl. reflexivity. Qed.

Theorem plus_O_n'': forall n : nat, (plus O n) = n.
Proof.
  intros n. reflexivity. Qed.

Theorem plus_1_1 : forall n : nat, ((S O) + n) = (S n).
Proof.
  intros n. simpl. reflexivity. Qed.

Theorem mult_0_1: forall n:nat, (O * n) = O.
Proof.
  intros n. reflexivity. Qed.

Theorem mult_0_11: forall n:nat, (mult O n) = O.
Proof.
  intros n. reflexivity. Qed.

Theorem plus_n_0: forall n:nat, n = (n + O).
Proof.
intros n.
Admitted.

Theorem plus_id_example: forall n m :nat,
n = m ->
n + n = m + m.
Proof.
Admitted.

Theorem plus_id_exercise: forall n m o : nat,
n = m -> m = o -> n + m = m + o.
Proof.
intros n m o.
intros H.
intros J.
rewrite H.
rewrite J.
reflexivity.
Qed.

Theorem mult_0_plus : forall n m: nat,
(O + n) * m = n * m.
Proof.
intros n m.
simpl.
reflexivity.
Qed.

Theorem mult_0_plus' : forall n m: nat,
(O + n) * m = n * m.
Proof.
intros n m.
rewrite mult_0_plus.
reflexivity.
Qed.

Theorem mult_0_plus'' : forall n m: nat,
(O + n) * m = n * m.
Proof.
intros n m.
rewrite plus_O_n'.
reflexivity.
Qed.

Theorem mult_S_1 : forall n m : nat,
m = S n ->
m * ((S O) + n) = m * m.
Proof.
intros n m.
intros H.
rewrite plus_1_1.
rewrite <- H.
reflexivity.
Qed.

Theorem plus_1_neq_0_firsttry : forall n : nat,
beq_nat (n + (S O)) O = false.
Proof.
intros n.
destruct n as [| n'].
reflexivity.
reflexivity.
Qed.

Theorem plus_1_neq_0_firsttry' : forall n : nat,
beq_nat (n + (S O)) O = false.
Proof.
intros n.
destruct n as [| n'].
simpl.
reflexivity.
simpl.
reflexivity.
Qed.

Theorem negb_involutive : forall b : bool,
(negb (negb b)) = b.
Proof.
intro b.
simpl.
destruct b.
- simpl.
reflexivity.
- simpl.
reflexivity.
Qed.

Theorem andb_commutative : forall b c: bool,
andb b c = andb c b.
Proof.
intros b c.
destruct b.
destruct c.
simpl.
reflexivity.
simpl.
reflexivity.
destruct c.
simpl.
reflexivity.
simpl.
reflexivity.
Qed.

Theorem andb_commutative_with_braces : forall b c:bool,
andb b c = andb c b.
Proof.
intros b c.
destruct b.
{ destruct c.
{ simpl. reflexivity. }
{ simpl. reflexivity. } }
{ destruct c.
  { simpl. reflexivity. }
{ simpl. reflexivity. } }
Qed.

Theorem andb3_exchange: forall b c d,
andb (andb b c) d = andb (andb b d) c.
intros b c d.
{ destruct b.
{ destruct c.
{ destruct d.
{ simpl.
reflexivity. }
{ simpl.
reflexivity. } }
{ destruct d.
{ simpl.
reflexivity. }
{ simpl.
reflexivity. } }
{ destruct c.
{ destruct d.
{ simpl.
reflexivity. }
{ simpl.
reflexivity. } }
{ destruct d.
{ simpl.
reflexivity. }
{ simpl.
reflexivity. } } } } }
Qed.

Theorem plus_1_neq_0''' : forall n : nat,
beq_nat (n + (S O)) O = false.
Proof.
intros [|n].
reflexivity.
reflexivity.
Qed.

Theorem andb_true_elim2: forall b c: bool,
andb b c = true -> c = true.
Proof.
intros b c.
{ destruct b.
{ destruct c.
{ simpl.
intros H1.
reflexivity. }

{ simpl.
intros H2.
rewrite H2.
reflexivity. } }

{ destruct c.
{ simpl.
intros H3.
reflexivity. }

{ simpl.
intros H4.
rewrite H4.
reflexivity. } } }

Qed.

Theorem zero_nbeq_plus_1 : forall n: nat,
beq_nat O (S n) = false.
Proof.
intros n.
{ simpl.
reflexivity. }
Qed.

Theorem identity_fn_applied_twice : forall (f : bool -> bool),
(forall (x : bool), f x = x) ->
forall (b : bool),
f (f b) = b.
Proof.
intros f.
intros H.
intros b0.
rewrite H.
rewrite H.
reflexivity.
Qed.

Theorem andb_eq_orb:
forall (b c : bool),
(andb b c) = (orb b c) ->
b=c.
Proof.
intros b0.
intros c.
destruct b0.
destruct c.
simpl.
intros H.
reflexivity.

simpl.
intros H1.
rewrite H1.
reflexivity.

destruct c.
simpl.
intros H2.
rewrite H2.
reflexivity.

simpl.
intros H3.
reflexivity.

Qed.


(* Software Foundations Chapter 3 : Lists *)
Add LoadPath "./bin".
Require Import lesson1_Basics.
Require Import lesson2_Induction.

Module NatList.

(**************************************************
  Exercise: 1 star (snd_fst_is_swap)
 **************************************************)

Inductive natprod : Type :=
  pair : nat -> nat -> natprod.

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

Definition swap_pair (p : natprod) : natprod :=
  match p with
    | (x,y) => (y,x)
  end.

Definition fst (p : natprod) : nat :=
  match p with
  | pair x y => x
  end.

Definition snd (p : natprod) : nat :=
  match p with
  | pair x y => y
  end.

Theorem snd_fst_is_swap : forall (p : natprod),
                            (snd p, fst p) = swap_pair p.
Proof.
  intros p.
  destruct p as (m,n).
  reflexivity.
Qed.

(**************************************************
  Exercise: 1 star, optional (fst_swap_is_snd)
 **************************************************)

Theorem fst_swap_is_snd : forall (p : natprod),
                            fst (swap_pair p) = snd p.
Proof.
  intros p.
  destruct p as (m,n).
  reflexivity.
Qed.

(**************************************************
  Exercise: 2 stars (list_funs)
  Complete the definitions of nonzeros, oddmembers and countoddmembers below. Have a look at the tests to understand what these functions should do.
 **************************************************)

Inductive natlist : Type :=
| nil : natlist
| cons : nat -> natlist -> natlist.

Notation "x :: l" := (cons x l) (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).
Notation "x + y" := (plus x y) (at level 50, left associativity).

Fixpoint nonzeros (l : natlist) : natlist :=
  match l with
    | nil => nil
    | O :: t => nonzeros t
    | h :: t => h :: nonzeros t
  end.

Example test_nonzeros: nonzeros [0,1,0,2,3,0,0] = [1,2,3].
Proof. reflexivity. Qed.

Fixpoint oddmembers (l : natlist) : natlist :=
match l with
| nil => nil
| h :: t => match evenb h with
            | true => oddmembers t
            | false => h :: oddmembers t
            end
end.

Example test_oddmembers: oddmembers [0,1,0,2,3,0,0] = [1,3].
Proof. simpl. reflexivity. Qed.

Fixpoint countoddmembers (l : natlist) : nat :=
match l with
| nil => O
| h :: t => match evenb h with
            | true => countoddmembers t
            | false => S (countoddmembers t)
            end
end.

Example test_countoddmembers1: countoddmembers [1,0,3,1,4,5] = 4.
Proof. simpl. reflexivity. Qed.
Example test_countoddmembers2: countoddmembers [0,2,4] = 0.
Proof. reflexivity. Qed.
Example test_countoddmembers3: countoddmembers nil = 0.
Proof. reflexivity. Qed.

(**************************************************
  Exercise: 3 stars, advanced (alternate)
  Complete the definition of alternate, which "zips up" two lists into one, alternating between elements taken from the first list and elements from the second. See the tests below for more specific examples.

  Note: one natural and elegant way of writing alternate will fail to satisfy Coq's requirement that all Fixpoint definitions be "obviously terminating." If you find yourself in this rut, look for a slightly more verbose solution that considers elements of both lists at the same time. (One possible solution requires defining a new kind of pairs, but this is not the only way.)
 **************************************************)

Inductive natlistprod : Type :=
  lpair : natlist -> natlist -> natlistprod.

Fixpoint alternate (l1 l2 : natlist) : natlist :=
  match lpair l1 l2 with
    | lpair nil nil => nil
    | lpair nil l => l
    | lpair l nil => l
    | lpair (h1 :: t1) (h2 :: t2) => h1 :: h2 :: (alternate t1 t2)
  end.

Example test_alternate1: alternate [1,2,3] [4,5,6] = [1,4,2,5,3,6].
Proof. simpl. reflexivity. Qed.
Example test_alternate2: alternate [1] [4,5,6] = [1,4,5,6].
Proof. reflexivity. Qed.
Example test_alternate3: alternate [1,2,3] [4] = [1,4,2,3].
Proof. simpl. reflexivity. Qed.
Example test_alternate4: alternate [] [20,30] = [20,30].
Proof. reflexivity. Qed.

(**************************************************
  Exercise: 3 stars (bag_functions)
  Complete the following definitions for the functions count, sum, add, and member for bags.
 **************************************************)

Definition bag := natlist.

Fixpoint count (v : nat) (s : bag) : nat :=
match s with
| nil => 0
| h :: t => match beq_nat v h with
            | true => S (count v t)
            | false => count v t
            end
end.

(* All these proofs can be done just by reflexivity. *)

Example test_count1: count 1 [1,2,3,1,4,1] = 3.
Proof. reflexivity. Qed.
Example test_count2: count 6 [1,2,3,1,4,1] = 0.
Proof. reflexivity. Qed.

(* Multiset sum is similar to set union: sum a b contains all the elements of a and of b. (Mathematicians usually define union on multisets a little bit differently, which is why we don't use that name for this operation.) For sum we're giving you a header that does not give explicit names to the arguments. Moreover, it uses the keyword Definition instead of Fixpoint, so even if you had names for the arguments, you wouldn't be able to process them recursively. The point of stating the question this way is to encourage you to think about whether sum can be implemented in another way — perhaps by using functions that have already been defined. *)

Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil => l2
  | h :: t => h :: (app t l2)
  end.

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

Definition sum : bag -> bag -> bag := app.

Example test_sum1: count 1 (sum [1,2,3] [1,4,1]) = 3.
Proof. reflexivity. Qed.

Definition add (v : nat) (s : bag) : bag := v :: s.

Example test_add1: count 1 (add 1 [1,4,1]) = 3.
Proof. reflexivity. Qed.

Example test_add2: count 5 (add 1 [1,4,1]) = 0.
Proof. reflexivity. Qed.

Fixpoint bgteq_nat (n : nat) (m : nat) :=
  match (n, m) with
    | (_ , O) => true
    | (O , _) => false
    | (S nn, S mm) => bgteq_nat nn mm
  end.

Definition member (v:nat) (s:bag) : bool :=
  bgteq_nat (count v s) 1.

Example test_member1: member 1 [1,4,1] = true.
Proof. reflexivity. Qed.
Example test_member2: member 2 [1,4,1] = false.
Proof. reflexivity. Qed.

(**************************************************
  Exercise: 3 stars, optional (bag_more_functions)
  Here are some more bag functions for you to practice with.
**************************************************)

Fixpoint remove_one (v:nat) (s:bag) : bag :=
  match s with
    | nil => nil
    | h :: t => match beq_nat h v with
                  | true => t
                  | false => h :: remove_one v t
                end
  end.

Example test_remove_one1: count 5 (remove_one 5 [2,1,5,4,1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_one2: count 5 (remove_one 5 [2,1,4,1]) = 0. Proof. reflexivity. Qed.
Example test_remove_one3: count 4 (remove_one 5 [2,1,4,5,1,4]) = 2. Proof. reflexivity. Qed.
Example test_remove_one4: count 5 (remove_one 5 [2,1,5,4,5,1,4]) = 1. Proof. reflexivity. Qed.

Fixpoint remove_all (v:nat) (s:bag) : bag :=
  match s with
    | nil => nil
    | h :: t => match beq_nat v h with
                  | true => remove_all v t
                  | false => h :: remove_all v t
                end
  end.

Example test_remove_all1: count 5 (remove_all 5 [2,1,5,4,1]) = 0. Proof. reflexivity. Qed.
Example test_remove_all2: count 5 (remove_all 5 [2,1,4,1]) = 0. Proof. reflexivity. Qed.
Example test_remove_all3: count 4 (remove_all 5 [2,1,4,5,1,4]) = 2. Proof. reflexivity. Qed.
Example test_remove_all4: count 5 (remove_all 5 [2,1,5,4,5,1,4,5,1,4]) = 0. Proof. reflexivity. Qed.

Fixpoint subset (s1:bag) (s2:bag) : bool :=
match s1 with
| nil => true
| h :: t => andb (member h s2) (subset t (remove_one h s2))
end.

Example test_subset1: subset [1,2] [2,1,4,1] = true. Proof. reflexivity. Qed.
Example test_subset2: subset [1,2,2] [2,1,4,1] = false. Proof. simpl. reflexivity. Qed.

(**************************************************
  Exercise: 3 stars (bag_theorem)
  Write down an interesting theorem about bags involving the functions count and add, and prove it. Note that, since this problem is somewhat open-ended, it's possible that you may come up with a theorem which is true, but whose proof requires techniques you haven't learned yet. Feel free to ask for help if you get stuck!
 **************************************************)

Theorem beq_n_n : forall (n : nat),
                    beq_nat n n = true.
Proof.
  intros n. induction n as [|nn].
  simpl. reflexivity.
  simpl. rewrite -> IHnn. reflexivity.
Qed.

Theorem inc_count_by_one : forall (v1 v2 : nat) (s : bag),
                             v1 = v2 -> count v1 (add v2 s) = 1 + count v1 s.
Proof.
  intros v1 v2 s H.
  unfold add.
  rewrite <- H.
  assert (Thm1 : forall (v : nat) (b : bag),
                  count v (v::[]) = 1).
   intros v E. simpl. rewrite -> beq_n_n. reflexivity.
  simpl. rewrite -> beq_n_n. reflexivity.
Qed.

(**************************************************
  Exercise: 3 stars (list_exercises)
  More practice with lists.
 **************************************************)

Theorem app_nil_end : forall l : natlist,
                        l ++ [] = l.
Proof.
  intro l. induction l as [| h t].
  reflexivity.
  simpl. rewrite -> IHt. reflexivity.
Qed.

Fixpoint snoc (l:natlist) (v:nat) : natlist :=
  match l with
  | nil => [v]
  | h :: t => h :: (snoc t v)
  end.

Fixpoint rev (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => snoc (rev t) h
  end.

Theorem cibele : forall (l : natlist) (n : nat),
                   rev (snoc l n) = n :: (rev l).
Proof.
 intros l n. induction l as [| h t].
 simpl. reflexivity.
 simpl. rewrite -> IHt. simpl. reflexivity.
Qed.

Theorem rev_involutive :  forall l : natlist,
                            rev (rev l) = l.
Proof.
 intro l. induction l as [| h t].
 reflexivity.
 simpl. rewrite -> cibele. rewrite -> IHt. reflexivity.
Qed.

(* There is a short solution to the next exercise. If you find yourself getting tangled up, step back and try to look for a simpler way. *)

Theorem app_right : forall l1 l2 l3 : natlist,
                      l1 ++ (l2 ++ l3) = (l1 ++ l2) ++ l3.
Proof.
  intros m1 m2 m3. induction m1 as [|h1 t1].
  reflexivity.
  simpl. rewrite -> IHt1. reflexivity.
Qed.

Theorem app_ass4 :  forall l1 l2 l3 l4 : natlist,
                      l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  intros l1 l2 l3 l4.
  rewrite <- app_right.
  rewrite app_right.
  reflexivity.
Qed.

Theorem snoc_append : forall (l:natlist) (n:nat),
                        snoc l n = l ++ [n].
Proof.
 intros l n. induction l as [| nn ll]. reflexivity.
 simpl. rewrite <- IHll. reflexivity.
Qed.

Theorem distr_rev : forall l1 l2 : natlist,
                      rev (l1 ++ l2) = (rev l2) ++ (rev l1).
Proof.
  intros l1 l2.
  induction l1 as [| h1 t1].
  Case "l1 is nil".
  simpl. rewrite -> app_nil_end. reflexivity.
  Case "l1 is some h::t".
  simpl.
  rewrite -> snoc_append.
  rewrite -> IHt1.
  rewrite -> snoc_append.
  rewrite -> app_right.
  reflexivity.
Qed.

(* An exercise about your implementation of nonzeros: *)

Lemma nonzeros_app : forall l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros l1. induction l1 as [|h1 t1].
  Case "l1 is an empty list".
  simpl. reflexivity.
  Case "l2 is not an empty list.".
  destruct h1 as [|n].
  SCase "the head of l1 is zero".
  simpl. intros l2.
  rewrite -> IHt1.
  reflexivity.
  SCase "the head of l1 is not zero".
  simpl. intros l2.
  rewrite -> IHt1.
  reflexivity.
Qed.

(**************************************************
  Exercise: 2 stars (list_design)
  Design exercise:
  Write down a non-trivial theorem involving cons (::), snoc, and app (++).
  Prove it.
 **************************************************)

Theorem tack : forall (n : nat) (l : natlist),
                 snoc (n::l) n = n :: (snoc l n).
Proof.
  intros n l. destruct l as [|h t].
  Case "The list is empty".
  simpl. reflexivity.
  Case "The list is not empty".
  simpl. reflexivity.
Qed.

(**************************************************
  Exercise: 3 stars, advanced (bag_proofs)
  Here are a couple of little theorems to prove about your definitions about bags in the previous problem.
**************************************************)

Theorem count_member_nonzero : forall (s : bag),
                                 ble_nat 1 (count 1 (1 :: s)) = true.
Proof.
  intros s. simpl. reflexivity.
Qed.

(* The following lemma about ble_nat might help you in the next proof. *)

Theorem ble_n_Sn : forall n,
  ble_nat n (S n) = true.
Proof.
  intros n. induction n as [| n'].
  Case "0".
    simpl. reflexivity.
  Case "S n'".
    simpl. rewrite IHn'. reflexivity. Qed.

Theorem remove_decreases_count: forall (s : bag),
                                  ble_nat (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
  intros s. induction s as [|h t].
  Case "bag is empty".
  simpl. reflexivity.
  Case "bag is not empty".
  destruct h as [|n].
  SCase "the head is a zero".
  simpl. rewrite -> ble_n_Sn.
  reflexivity.
  SCase "the head is not zero".
  simpl. rewrite -> IHt. reflexivity.
Qed.

(**************************************************
  Exercise: 3 stars, optional (bag_count_sum)
  Write down an interesting theorem about bags involving the functions count and sum, and prove it.
 **************************************************)

(* no, thanks *)

(**************************************************
  Exercise: 4 stars, advanced (rev_injective)
  Prove that the rev function is injective, that is,
    ∀(l1 l2 : natlist), rev l1 = rev l2 → l1 = l2.
  There is a hard way and an easy way to solve this exercise.
 **************************************************)

Fixpoint length (l : natlist) : nat :=
match l with
| nil => O
| h :: t => S (length t)
end.

Theorem rev_injective : forall (l1 l2 : natlist),
                          rev l1 = rev l2 -> l1 = l2.
Proof.
  intros l1 l2 H.
  rewrite <- rev_involutive.
  rewrite <- H.
  rewrite rev_involutive.
  reflexivity.
Qed.

(**************************************************
  Exercise: 2 stars (hd_opt)
  Using the same idea, fix the hd function from earlier so we don't have to pass a default element for the nil case.
 **************************************************)

Inductive natoption : Type :=
| Some : nat -> natoption
| None : natoption.

Definition hd_opt (l : natlist) : natoption :=
 match l with
   | nil => None
   | h::t => Some h
 end.

Example test_hd_opt1 : hd_opt [] = None.
Proof. reflexivity. Qed.
Example test_hd_opt2 : hd_opt [1] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_opt3 : hd_opt [5,6] = Some 5.
Proof. reflexivity. Qed.

(**************************************************
  Exercise: 1 star, optional (option_elim_hd)
  This exercise relates your new hd_opt to the old hd.
 **************************************************)

Definition hd (default : nat) (l : natlist) : nat :=
  match l with
    | nil => default
    | h :: t => h
  end.

Definition option_elim (d : nat) (o : natoption) : nat :=
match o with
| Some nn => nn
| None => d
end.

Theorem option_elim_hd : forall (l : natlist) (default : nat),
                           hd default l = option_elim default (hd_opt l).
Proof.
  intros l n. destruct l as [| h t].
  reflexivity. reflexivity.
Qed.

(**************************************************
  Exercise: 2 stars (beq_natlist)
  Fill in the definition of beq_natlist, which compares lists of numbers for equality. Prove that beq_natlist l l ypields true for every list l.
 **************************************************)

Fixpoint beq_natlist (l1 l2 : natlist) : bool :=
match l1 with
| nil => match l2 with
         | nil => true
         | _ => false
         end
| h1::t1 => match l2 with
            | nil => false
            | h2::t2 => if beq_nat h1 h2
                        then beq_natlist t1 t2
                        else false
            end
end.

Example test_beq_natlist1 : (beq_natlist nil nil = true).
Proof. reflexivity. Qed.
Example test_beq_natlist2 : beq_natlist [1,2,3] [1,2,3] = true.
Proof. reflexivity. Qed.
Example test_beq_natlist3 : beq_natlist [1,2,3] [1,2,4] = false.
Proof. reflexivity. Qed.

Theorem beq_natlist_refl : forall l : natlist,
                             true = beq_natlist l l.
Proof.
 intro l. induction l as [| h t].
 Case "arg is an empty list".
 simpl. reflexivity.
 Case "arg is not an empty lst.".
 simpl.
 rewrite <- IHt.
 rewrite -> beq_n_n.
 reflexivity.
Qed.

Module Dictionary.

Inductive dictionary : Type :=
| empty : dictionary
| record : nat -> nat -> dictionary -> dictionary.

Definition insert (key value : nat) (d : dictionary) :=
  (record key value d).

Fixpoint find (key : nat) (d : dictionary) : natoption :=
  match d with
    | empty => None
    | record k v d' => if (beq_nat key k)
                       then (Some v)
                       else (find key d')
  end.

Theorem dictionary_invariant1 : forall (d : dictionary) (k v : nat),
  (find k (insert k v d)) = Some v.
Proof.
 intros d k v.
 simpl. assert (H : beq_nat k k = true).
  induction k as [| kk].
  reflexivity.
  simpl. rewrite -> IHkk. reflexivity.
  rewrite -> H. reflexivity.
Qed.

Theorem dictionary_invariant2 : forall (d : dictionary) (m n o : nat),
(beq_nat m n) = false -> (find m d) = (find m (insert n o d)).
Proof.
 intros d m n o.
 intro H.
 simpl. rewrite -> H. reflexivity.
Qed.

End Dictionary.

End NatList.


(** * Rel: Properties of Relations *)

(** This short (and optional) chapter develops some basic definitions
    and a few theorems about binary relations in Coq.  The key
    definitions are repeated where they are actually used (in the
    \CHAPV2{Smallstep} chapter of _Programming Language Foundations_),
    so readers who are already comfortable with these ideas can safely
    skim or skip this chapter.  However, relations are also a good
    source of exercises for developing facility with Coq's basic
    reasoning facilities, so it may be useful to look at this material
    just after the [IndProp] chapter. *)

Set Warnings "-notation-overridden,-parsing".
Require Export IndProp.
Check evenb.

(* ################################################################# *)
(** * Relations *)

(** A binary _relation_ on a set [X] is a family of propositions
    parameterized by two elements of [X] -- i.e., a proposition about
    pairs of elements of [X].  *)

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

(** Confusingly, the Coq standard library hijacks the generic term
    "relation" for this specific instance of the idea. To maintain
    consistency with the library, we will do the same.  So, henceforth
    the Coq identifier [relation] will always refer to a binary
    relation between some set and itself, whereas the English word
    "relation" can refer either to the specific Coq concept or the
    more general concept of a relation between any number of possibly
    different sets.  The context of the discussion should always make
    clear which is meant. *)

(** An example relation on [nat] is [le], the less-than-or-equal-to
    relation, which we usually write [n1 <= n2]. *)

Print le.
(* ====> Inductive le (n : nat) : nat -> Prop :=
             le_n : n <= n
           | le_S : forall m : nat, n <= m -> n <= S m *)
Check le : nat -> nat -> Prop.
Check le_ind.
Check le : relation nat.
Check le_ind.
(** (Why did we write it this way instead of starting with [Inductive
    le : relation nat...]?  Because we wanted to put the first [nat]
    to the left of the [:], which makes Coq generate a somewhat nicer
    induction principle for reasoning about [<=].) *)

(* ################################################################# *)
(** * Basic Properties *)

(** As anyone knows who has taken an undergraduate discrete math
    course, there is a lot to be said about relations in general,
    including ways of classifying relations (as reflexive, transitive,
    etc.), theorems that can be proved generically about certain sorts
    of relations, constructions that build one relation from another,
    etc.  For example... *)

(* ----------------------------------------------------------------- *)
(** *** Partial Functions *)

(** A relation [R] on a set [X] is a _partial function_ if, for every
    [x], there is at most one [y] such that [R x y] -- i.e., [R x y1]
    and [R x y2] together imply [y1 = y2]. *)

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

(** For example, the [next_nat] relation defined earlier is a partial
    function. *)

Print next_nat.
(* ====> Inductive next_nat (n : nat) : nat -> Prop :=
           nn : next_nat n (S n) *)
Check next_nat : relation nat.

Theorem next_nat_partial_function :
   partial_function next_nat.
Proof.
  unfold partial_function.
  intros x y1 y2 H1 H2.
  inversion H1. inversion H2.
  reflexivity.  Qed.

(** However, the [<=] relation on numbers is not a partial
    function.  (Assume, for a contradiction, that [<=] is a partial
    function.  But then, since [0 <= 0] and [0 <= 1], it follows that
    [0 = 1].  This is nonsense, so our assumption was
    contradictory.) *)

Theorem le_not_a_partial_function :
  ~ (partial_function le).
Proof.
  unfold not. unfold partial_function. intros Hc.
  assert (0 = 1) as Nonsense. {
    apply Hc with (x := 0).
    - apply le_n.
    - apply le_S. apply le_n. }
  inversion Nonsense.   Qed.

(** **** Exercise: 2 stars, optional (total_relation_not_partial)  *)
(** Show that the [total_relation] defined in earlier is not a partial
    function. *)

Check total_relation.
Print total_relation.

Theorem total_relation_not_partial: ~(partial_function total_relation).
Proof.
  unfold not. unfold partial_function.
  intros H. Print total_relation.
  assert(0 = 1) as NOnsense.
  - apply (H 0).
     + apply tr2. + Print total_relation. apply (tr1_L 0 1).
  - inversion NOnsense.
Qed.

(** **** Exercise: 2 stars, optional (empty_relation_partial)  *)
(** Show that the [empty_relation] that we defined earlier is a
    partial function. *)

(* FILL IN HERE *)
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Reflexive Relations *)

(** A _reflexive_ relation on a set [X] is one for which every element
    of [X] is related to itself. *)

Definition reflexive {X: Type} (R: relation X) :=
  forall a : X, R a a.

Theorem le_reflexive :
  reflexive le.
Proof.
  unfold reflexive. intros n. apply le_n.  Qed.

(* ----------------------------------------------------------------- *)
(** *** Transitive Relations *)

(** A relation [R] is _transitive_ if [R a c] holds whenever [R a b]
    and [R b c] do. *)

Definition transitive {X: Type} (R: relation X) :=
  forall a b c : X, (R a b) -> (R b c) -> (R a c).

Theorem le_trans :
  transitive le.
Proof.
  intros n m o Hnm Hmo.
  induction Hmo.
  - (* le_n *) apply Hnm.
  - (* le_S *) apply le_S. apply IHHmo.  Qed.

Theorem lt_trans:
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  apply le_S in Hnm.
  apply le_trans with (a := (S n)) (b := (S m)) (c := o).
  apply Hnm.
  apply Hmo. Qed.

(** **** Exercise: 2 stars, optional (le_trans_hard_way)  *)
(** We can also prove [lt_trans] more laboriously by induction,
    without using [le_trans].  Do this.*)

Theorem lt_trans' :
  transitive lt.
Proof.
  (* Prove this by induction on evidence that [m] is less than [o]. *)
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction Hmo as [| m' Hm'o].
  - apply le_S. apply Hnm.
  - apply le_S. apply IHHm'o.
Qed.

(** **** Exercise: 2 stars, optional (lt_trans'')  *)
(** Prove the same thing again by induction on [o]. *)

Theorem lt_trans'' :
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction o as [| o'].
  - inversion Hmo.
  - induction Hmo.
      + apply le_S. apply Hnm.
      + apply le_S. apply IHHmo.
Qed.

(** The transitivity of [le], in turn, can be used to prove some facts
    that will be useful later (e.g., for the proof of antisymmetry
    below)... *)

Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
Proof.
  intros n m H. apply le_trans with (S n).
  - apply le_S. apply le_n.
  - apply H.
Qed.

(** **** Exercise: 1 star, optional (le_S_n)  *)
Theorem le_S_n : forall n m,
  (S n <= S m) -> (n <= m).
Proof.
  intros n m H.
  inversion H.
  - apply le_n. - apply le_trans with (S n).
  + apply le_S. apply le_n. + apply H1.
Qed.

(** **** Exercise: 2 stars, optional (le_Sn_n_inf)  *)
(** Provide an informal proof of the following theorem:

    Theorem: For every [n], [~ (S n <= n)]

    A formal proof of this is an optional exercise below, but try
    writing an informal proof without doing the formal proof first.
           by induction first n = 0. ~(1 ,<= 0 ) trivial
           IH: Soupose n', ~(S n' <= n') <= is total relation that is to say n' < S n'
           => S n' < S (S n') which is ~(S (S n')  <= S n')

    Proof: *)
    (* FILL IN HERE *)
(** [] *)

(** **** Exercise: 1 star, optional (le_Sn_n)  *)
Theorem le_Sn_n : forall n,
  ~ (S n <= n).
Proof.
   intros n contra. induction n.
  - inversion contra. - apply IHn. apply le_S_n. apply contra.
Qed.
(** [] *)

(** Reflexivity and transitivity are the main concepts we'll need for
    later chapters, but, for a bit of additional practice working with
    relations in Coq, let's look at a few other common ones... *)

(* ----------------------------------------------------------------- *)
(** *** Symmetric and Antisymmetric Relations *)

(** A relation [R] is _symmetric_ if [R a b] implies [R b a]. *)

Definition symmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a).

(** **** Exercise: 2 stars, optional (le_not_symmetric)  *)
Theorem le_not_symmetric :
  ~ (symmetric le).
Proof.
   unfold symmetric. intros contra.
   assert( 1 <= 0) as nonsense.
  - apply contra. apply le_S. apply le_n.
  - inversion nonsense.
Qed.
(** [] *)

(** A relation [R] is _antisymmetric_ if [R a b] and [R b a] together
    imply [a = b] -- that is, if the only "cycles" in [R] are trivial
    ones. *)

Definition antisymmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a) -> a = b.

(** **** Exercise: 2 stars, optional (le_antisymmetric)  *)
Theorem le_antisymmetric :
  antisymmetric le.
Proof.
  unfold antisymmetric.
  intros a.
  induction a as [|a' IHa'].
  - intros. inversion H0. reflexivity.
  - intros. destruct b.
     + inversion H.
     + Search (S _ = S _). apply eq_S. apply IHa'.
        * Search (S _ <= S _). apply le_S_n in H. apply H.
        * apply le_S_n in H0. apply H0.
Qed.

(** **** Exercise: 2 stars, optional (le_step)  *)
Theorem le_step : forall n m p,
  n < m ->
  m <= S p ->
  n <= p.
Proof.
   unfold lt. intros.
   apply (le_trans (S n) (m) (S p) H ) in H0.
   apply le_S_n in H0. apply H0.
Qed.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Equivalence Relations *)

(** A relation is an _equivalence_ if it's reflexive, symmetric, and
    transitive.  *)

Definition equivalence {X:Type} (R: relation X) :=
  (reflexive R) /\ (symmetric R) /\ (transitive R).

(* ----------------------------------------------------------------- *)
(** *** Partial Orders and Preorders *)

(** A relation is a _partial order_ when it's reflexive,
    _anti_-symmetric, and transitive.  In the Coq standard library
    it's called just "order" for short. *)

Definition order {X:Type} (R: relation X) :=
  (reflexive R) /\ (antisymmetric R) /\ (transitive R).

(** A preorder is almost like a partial order, but doesn't have to be
    antisymmetric. *)

Definition preorder {X:Type} (R: relation X) :=
  (reflexive R) /\ (transitive R).

Theorem le_order :
  order le.
Proof.
  unfold order. split.
    - (* refl *) apply le_reflexive.
    - split.
      + (* antisym *) apply le_antisymmetric.
      + (* transitive. *) apply le_trans.  Qed.

(* ################################################################# *)
(** * Reflexive, Transitive Closure *)

(** The _reflexive, transitive closure_ of a relation [R] is the
    smallest relation that contains [R] and that is both reflexive and
    transitive.  Formally, it is defined like this in the Relations
    module of the Coq standard library: *)

Inductive clos_refl_trans {A: Type} (R: relation A) : relation A :=
    | rt_step : forall x y, R x y -> clos_refl_trans R x y
    | rt_refl : forall x, clos_refl_trans R x x
    | rt_trans : forall x y z,
          clos_refl_trans R x y ->
          clos_refl_trans R y z ->
          clos_refl_trans R x z.

(** For example, the reflexive and transitive closure of the
    [next_nat] relation coincides with the [le] relation. *)

Theorem next_nat_closure_is_le : forall n m,
  (n <= m) <-> ((clos_refl_trans next_nat) n m).
Proof.
  intros n m. split.
  - (* -> *)
    intro H. induction H.
    + (* le_n *) apply rt_refl.
    + (* le_S *)
      apply rt_trans with m. apply IHle. apply rt_step.
      apply nn.
  - (* <- *)
    intro H. induction H.
    + (* rt_step *) inversion H. apply le_S. apply le_n.
    + (* rt_refl *) apply le_n.
    + (* rt_trans *)
      apply le_trans with y.
      apply IHclos_refl_trans1.
      apply IHclos_refl_trans2. Qed.

(** The above definition of reflexive, transitive closure is natural:
    it says, explicitly, that the reflexive and transitive closure of
    [R] is the least relation that includes [R] and that is closed
    under rules of reflexivity and transitivity.  But it turns out
    that this definition is not very convenient for doing proofs,
    since the "nondeterminism" of the [rt_trans] rule can sometimes
    lead to tricky inductions.  Here is a more useful definition: *)

Inductive clos_refl_trans_1n {A : Type}
                             (R : relation A) (x : A)
                             : A -> Prop :=
  | rt1n_refl : clos_refl_trans_1n R x x
  | rt1n_trans (y z : A) :
      R x y -> clos_refl_trans_1n R y z ->
      clos_refl_trans_1n R x z.

(** Our new definition of reflexive, transitive closure "bundles"
    the [rt_step] and [rt_trans] rules into the single rule step.
    The left-hand premise of this step is a single use of [R],
    leading to a much simpler induction principle.

    Before we go on, we should check that the two definitions do
    indeed define the same relation...

    First, we prove two lemmas showing that [clos_refl_trans_1n] mimics
    the behavior of the two "missing" [clos_refl_trans]
    constructors.  *)

Lemma rsc_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> clos_refl_trans_1n R x y.
Proof.
  intros X R x y H.
  apply rt1n_trans with y. apply H. apply rt1n_refl.   Qed.

(** **** Exercise: 2 stars, optional (rsc_trans)  *)
Lemma rsc_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      clos_refl_trans_1n R x y  ->
      clos_refl_trans_1n R y z ->
      clos_refl_trans_1n R x z.
Proof.
   intros X R x y z Hxy. generalize dependent z.
   induction Hxy.
  - intros. apply H.
  - intros. apply IHHxy in H0. apply rt1n_trans with y.
     + apply H. + apply H0.
Qed.

(** Then we use these facts to prove that the two definitions of
    reflexive, transitive closure do indeed define the same
    relation. *)

(** **** Exercise: 3 stars, optional (rtc_rsc_coincide)  *)
Theorem rtc_rsc_coincide :
         forall (X:Type) (R: relation X) (x y : X),
  clos_refl_trans R x y <-> clos_refl_trans_1n R x y.
Proof.
   intros X R x y.
   split.
   - intros. induction H.
      * apply rsc_R. apply H.
     * apply rt1n_refl.
     * apply (rsc_trans X R x y z IHclos_refl_trans1 IHclos_refl_trans2)  .
   - intros. induction H.
      + apply rt_refl.
      + apply rt_trans with y.
          * apply rt_step. apply H.
         * apply IHclos_refl_trans_1n.
Qed.
(** [] *)