From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* relation x / (s y) *)
Definition  d (x y a b: nat) := (x = a * (S y) + b) /\ b <= y.
(* a - quotient *)
(* b - remainder *)

(* 16.1.1 *)
Lemma d1: forall y, d 0 y 0 0.
Proof.
  split.
    by [].
  by [].
Qed.

Lemma d2: forall x y a b, d x y a b -> b = y -> d (S x) y (S a) 0.
Proof.
  move => x y a b H E.
  move: E H ->.
  rewrite /d.
  move => [Hl Hr].
  split; last by done.
  by rewrite Hl -addnS mulSn addn0 addnC.
Qed.

Lemma d3: forall x y a b, d x y a b -> b <> y -> d (S x) y a (S b).
Proof.
  move => x y a b [Hl Hr] Neq.
  split; last first.
    move: Hr.
    rewrite leq_eqVlt; move => /orP; case; last by done.
      move => /eqP Contra.
      exfalso; apply (Neq Contra).
  by rewrite Hl addnS.
Qed.

(* 16.1.2 *)
Theorem cert_div: forall x y, { ' (a, b) & d x y a b }.
Proof.
  elim => [ y | x' IH y].
    exists (0, 0).
    apply d1.
  set U := IH y.
  move: (IH y) => [[a b] [Hl Hr]].
  move: Hr.
  case: (ltngtP b y) => //.
    move => Lby _.
    exists (a, (S b)).
    apply d3.
    split => //.
      apply (ltnW Lby).
    move => contra.
    move: Lby.
    rewrite contra /(_ < _) subSn.
    rewrite subnn.
    apply /eqP. by [].
      by [].
  move => H _.
  exists ((S a), 0).
  apply (d2 (b:=b)) => //.
  split => //.
  by rewrite H.
Defined.

Print cert_div.
Definition x: nat := match cert_div 5 3 with (existT (a, b) _) => a end.
Compute (cert_div 5 3).
Compute (projT1 (cert_div 5 3)).
Compute (x).

Lemma tst: forall n m k, n = m.+1 + k -> m < n.
Proof.
  elim => [m k H | n IH m k].
    exfalso; move: H.
    rewrite addSn.
    by [].
  rewrite addSn. move /eq_add_S ->.
  by rewrite /(_ < _) subSS subnDA subnn sub0n.
Qed.

(* 16.3.1 / 16.3.2 *)
Theorem cert_div_unique: forall (x y a b a' b': nat),
  d x y a b -> d x y a' b' -> a = a' /\ b = b'.
Proof.
  move => x y a.
  move: a x y.
  elim => [x y b a' b' | a IH x y b a' b'].
    rewrite /d mul0n add0n.
    move => [-> Hr] [Hl' Hr'].
    case: a' Hl'.
      by rewrite mul0n add0n.
    move => a'' Hcontr.
    exfalso; have: b > y.
      move: Hcontr.
      rewrite mulSn -addnA.
      apply tst.
    move => Hl.
    move: (leq_gtF Hr).
    by rewrite Hl.
  case a' => [|a''].
    move => [Hl Hr] [Hl' Hr'].
    exfalso.
    move: Hl'; rewrite Hl mul0n add0n => H.
    move: Hr'.
    rewrite -H mulSn 2!addSn -addnA.
    rewrite -{3}(addn0 y).
    by rewrite ltn_add2l.
  move => [Hl Hr] [Hl' Hr'].
  move: (Hl) (Hl') => ->.
  rewrite 2!mulSn 2!mulnS -addnA.
  rewrite -[y.+1 + (a'' + a'' * y) + b']addnA.
  move /eqP.
  rewrite (eqn_add2l y.+1) => H.
  have: d (a * y.+1 + b) y a b.
    by split.
  have: d (a'' * y.+1 + b') y a'' b'.
    by split.
  rewrite 2!mulnS.
  move/eqP :H => ->.
  move => D' D.
  move: (IH _ _ _ _ _ D D') => [HL HR].
  by rewrite HL HR.
Qed.

(* 16.3.3 *)
Lemma d4: forall x y, x <= y -> d x y 0 x.
Proof.
  move => x y Hl.
  split => //.
Qed.

Lemma d5: forall x y a b, x > y -> d (x - y.+1) y a b -> d x y a.+1 b.
Proof.
  move => x y a b L [Hl Hr].
  split => //.
  rewrite mulSn -addnA -Hl.
  rewrite subnKC => //.
Qed.

(* 16.3.4 *)
(* TODO *)

(* 16.3.5 *)
(* TODO *)

(* 16.3.6 *)
(* TODO *)

(* 16.3.7 *)
(* TODO *)

(* 16.3.8 *)
Lemma uniq2: forall (y a b a' b': nat),
  (b <= y) -> (b' <= y) -> (a * y.+1 + b = a' * y.+1 + b') -> a = a' /\ b = b'.
Proof.
  move => y a b a' b' Hl Hl' H.
  apply (cert_div_unique (x:=(a * y.+1 + b)) (y:=y)).
  by split.
  by split.
Qed.

Lemma ex1638: forall x y z, x * (z.+2) + 1 <> y * (z.+2) + 0.
Proof.
  move => x y z H.
  have Hl: 1 <= z.+2.
    by [].
  have Hl': 0 <= z.+2.
    by [].
  move: (uniq2 (a:=x) (a':=y) (y:= z.+1)(b:=1) (b':=0) Hl Hl' H).
  by move => [_ Contra].
Qed.

(* 16.3.9 *)
(* TODO *)


Require Import Morphisms.
Require Import GeoCoq.Axioms.hilbert_axioms.
Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Meta_theory.Parallel_postulates.tarski_playfair.
Require Import GeoCoq.Meta_theory.Parallel_postulates.SPP_ID.
Require Import GeoCoq.Meta_theory.Dimension_axioms.upper_dim_3.
Require Import GeoCoq.Meta_theory.Parallel_postulates.parallel_postulates.

Require Export GeoCoq.Utils.triples.

Section T.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

(** We need a notion of line. *)

Definition Line := @Couple Tpoint.
Definition Lin := build_couple Tpoint.

Definition IncidentL := fun A l => Col A (P1 l) (P2 l).

(** * Group I Incidence *)

(** For every pair of distinct points there is a line containing them. *)

Lemma axiom_line_existence : forall A B, A<>B -> exists l, IncidentL A l /\ IncidentL B l.
Proof.
intros.
exists (Lin A B H).
unfold IncidentL.
intuition.
Qed.

(** We need a notion of equality over lines. *)

Definition EqL : relation Line := fun l m => forall X, IncidentL X l <-> IncidentL X m.

Infix "=l=" := EqL (at level 70):type_scope.

Lemma incident_eq : forall A B l, forall H : A<>B,
 IncidentL A l -> IncidentL B l ->
 (Lin A B H) =l= l.
Proof.
intros.
unfold EqL.
intros.
unfold IncidentL in *.
replace (P1 (Lin A B H)) with A; trivial.
replace (P2 (Lin A B H)) with B; trivial.
split;intro.
assert (T:=Cond l).
elim (eq_dec_points X B); intro.
subst X.
auto.
assert (Col (P1 l) A B).
apply col_transitivity_1 with (P2 l); Col.
assert (Col (P2 l) A B).
apply (col_transitivity_2 (P1 l)); Col.
apply (col3 A B); Col.

assert (U:=Cond l).
apply (col3 (P1 l) (P2 l)); Col.
Qed.

(** Our equality is an equivalence relation. *)

Lemma eq_transitivity : forall l m n, l =l= m -> m =l= n -> l =l= n.
Proof.
unfold EqL,IncidentL.
intros.
assert (T:=H X).
assert (V:= H0 X).
split;intro;intuition.
Qed.

Lemma eq_reflexivity : forall l, l =l= l.
Proof.
intros.
unfold EqL.
intuition.
Qed.

Lemma eq_symmetry : forall l m, l =l= m -> m =l= l.
Proof.
unfold EqL.
intros.
assert (T:=H X).
intuition.
Qed.

Instance EqL_Equiv : Equivalence EqL.
Proof.
split.
unfold Reflexive.
apply eq_reflexivity.
unfold Symmetric.
apply eq_symmetry.
unfold Transitive.
apply eq_transitivity.
Defined.

(** The equality is compatible with IncidentL *)

Lemma eq_incident : forall A l m, l =l= m ->
 (IncidentL A l <-> IncidentL A m).
Proof.
intros.
split;intros;
unfold EqL in *;
assert (T:= H A);
intuition.
Qed.

Instance incident_Proper (A:Tpoint) :
Proper (EqL ==>iff) (IncidentL A).
Proof.
intros a b H .
apply eq_incident.
assumption.
Defined.

Lemma axiom_Incid_morphism :
 forall P l m, IncidentL P l -> EqL l m -> IncidentL P m.
Proof.
intros.
destruct (eq_incident P l m H0).
intuition.
Qed.

Lemma axiom_Incid_dec : forall P l, IncidentL P l \/ ~IncidentL P l.
Proof.
intros.
unfold IncidentL.
apply col_dec.
Qed.

(** There is only one line going through two points. *)

Lemma axiom_line_uniqueness : forall A B l m, A <> B ->
 IncidentL A l -> IncidentL B l -> IncidentL A m -> IncidentL B m ->
 l =l= m.
Proof.
intros.
assert ((Lin A B H) =l= l).
eapply incident_eq;assumption.
assert ((Lin A B H) =l= m).
eapply incident_eq;assumption.
rewrite <- H4.
assumption.
Qed.

(** Every line contains at least two points. *)

Lemma axiom_two_points_on_line : forall l,
  { A : Tpoint & { B | IncidentL B l /\ IncidentL A l /\ A <> B}}.
Proof.
intros.
exists (P1 l).
exists (P2 l).
unfold IncidentL.
repeat split;Col.
exact (Cond l).
Qed.

(** Definition of the collinearity predicate.
 We say that three points are collinear if they belongs to the same line. *)

Definition Col_H := fun A B C =>
  exists l, IncidentL A l /\ IncidentL B l /\ IncidentL C l.

(** We show that the notion of collinearity we just defined is equivalent to the
 notion of collinearity of Tarski. *)

Lemma cols_coincide_1 : forall A B C, Col_H A B C -> Col A B C.
Proof.
intros.
unfold Col_H in H.
DecompExAnd H l.
unfold IncidentL in *.
assert (T:=Cond l).
apply (col3 (P1 l) (P2 l)); Col.
Qed.

Lemma cols_coincide_2 : forall A B C, Col A B C -> Col_H A B C.
Proof.
intros.
unfold Col_H.
elim (eq_dec_points A B); intro.
subst B.
elim (eq_dec_points A C); intro.
subst C.
assert (exists B, A<>B).
eapply another_point.
DecompEx H0 B.
exists (Lin A B H1).
unfold IncidentL;intuition.
exists (Lin A C H0).
unfold IncidentL;intuition.
exists (Lin A B H0).
unfold IncidentL;intuition.
Qed.

Lemma cols_coincide : forall A B C, Col A B C <-> Col_H A B C.
Proof.
intros.
split.
apply cols_coincide_2.
apply cols_coincide_1.
Qed.

Lemma ncols_coincide : forall A B C, ~ Col A B C <-> ~ Col_H A B C.
Proof.
intros.
split; intros HNCol HCol; apply HNCol, cols_coincide, HCol.
Qed.

(** There exists three non collinear points. *)

Lemma lower_dim' : PA <> PB /\ PB <> PC /\ PA <> PC /\ ~ Col_H PA PB PC.
Proof.
assert (HNCol : ~ Col PA PB PC) by (apply lower_dim).
assert_diffs.
apply ncols_coincide in HNCol.
repeat split; auto.
Qed.

(** We need a notion of plane. *)

Record Plane := Plan {M1; M2; M3; NCol : ~ Col_H M1 M2 M3}.

Definition IncidentP := fun A p => Coplanar (M1 p) (M2 p) (M3 p) A.

(** For every triplet of non collinear points there is a plane containing them. *)

Lemma axiom_plane_existence : forall A B C, ~ Col_H A B C ->
  exists p, IncidentP A p /\ IncidentP B p /\ IncidentP C p.
Proof.
intros A B C HNCol.
exists (Plan A B C HNCol).
unfold IncidentP; simpl; repeat split; Cop.
Qed.

(** We need a notion of equality over planes. *)

Definition EqP : relation Plane := fun p q => forall X, IncidentP X p <-> IncidentP X q.

Infix "=p=" := EqP (at level 70):type_scope.

Lemma incidentp_eqp : forall A B C p, forall H : ~ Col_H A B C,
 IncidentP A p -> IncidentP B p -> IncidentP C p ->
 (Plan A B C H) =p= p.
Proof.
intros A B C p HNCol HA HB HC X.
unfold IncidentP in *; simpl.
assert (Hp := NCol p).
apply ncols_coincide in Hp.
apply ncols_coincide in HNCol.
split; intro; [apply coplanar_pseudo_trans with A B C; trivial|];
apply coplanar_pseudo_trans with (M1 p) (M2 p) (M3 p); Cop.
Qed.

(** Our equality is an equivalence relation. *)

Lemma eqp_transitivity : forall p q r, p =p= q -> q =p= r -> p =p= r.
Proof.
intros p q r H1 H2 X.
rewrite (H1 X); apply H2.
Qed.

Lemma eqp_reflexivity : forall p, p =p= p.
Proof.
intros.
unfold EqP.
intuition.
Qed.

Lemma eqp_symmetry : forall p q, p =p= q -> q =p= p.
Proof.
unfold EqP.
intros p q H X.
assert (T := H X).
intuition.
Qed.

Instance EqP_Equiv : Equivalence EqP.
Proof.
split.
unfold Reflexive.
apply eqp_reflexivity.
unfold Symmetric.
apply eqp_symmetry.
unfold Transitive.
apply eqp_transitivity.
Defined.

(** The equality is compatible with IncidentL *)

Lemma eqp_incidentp : forall A p q, p =p= q ->
 (IncidentP A p <-> IncidentP A q).
Proof.
intros A p q H.
exact (H A).
Qed.

Instance incidentp_Proper (A:Tpoint) :
Proper (EqP ==>iff) (IncidentP A).
Proof.
intros a b H.
apply eqp_incidentp.
assumption.
Defined.

Lemma axiom_Incidp_morphism :
 forall M p q, IncidentP M p -> EqP p q -> IncidentP M q.
Proof.
intros M p q Hp H.
destruct (eqp_incidentp M p q H).
intuition.
Qed.

Lemma axiom_Incidp_dec : forall M p, IncidentP M p \/ ~ IncidentP M p.
Proof.
intros.
apply cop_dec.
Qed.

(** There is only one plane going through three non collinear points. *)

Lemma axiom_plane_uniqueness : forall A B C p q, ~ Col_H A B C ->
 IncidentP A p -> IncidentP B p -> IncidentP C p ->
 IncidentP A q -> IncidentP B q -> IncidentP C q ->
 p =p= q.
Proof.
intros A B C p q H; intros.
assert (Heq : (Plan A B C H) =p= p).
apply incidentp_eqp;assumption.
assert ((Plan A B C H) =p= q).
apply incidentp_eqp;assumption.
rewrite <- Heq.
assumption.
Qed.

(** Every plane contains at least one point. *)

Lemma axiom_one_point_on_plane : forall p,
  { A | IncidentP A p }.
Proof.
intro p.
exists (M1 p).
unfold IncidentP; Cop.
Qed.

(** Definition of a line belonging to a plane.
  We say that a line belongs to a plane if every point of the line belongs to the plane. *)

Definition  IncidentLP := fun l p => forall A, IncidentL A l -> IncidentP A p.

(** If two distinct points of a line belong to a plane, then the line belongs to the plane. *)

Lemma axiom_line_on_plane : forall A B l p, A <> B ->
 IncidentL A l -> IncidentL B l -> IncidentP A p -> IncidentP B p ->
 IncidentLP l p.
Proof.
intros A B l p HAB HAl HBl HAp HBp X HXl.
destruct (ex_ncol_cop (M1 p) (M2 p) (M3 p) A B HAB) as [C [HCp HNCol]].
apply ncols_coincide in HNCol.
assert (Heq : (Plan A B C HNCol) =p= p).
apply incidentp_eqp; auto.
rewrite <- Heq.
unfold IncidentP; simpl.
exists X; left; split.
apply cols_coincide_1; exists l; repeat split; assumption.
Col.
Qed.

(** * Group II Order *)

(** Definition of the Between predicate of Hilbert.
    Note that it is different from the Between of Tarski.
    The Between of Hilbert is strict. *)

Definition Between_H := fun A B C =>
  Bet A B C /\ A <> B /\ B <> C /\ A <> C.

Lemma axiom_between_col :
 forall A B C, Between_H A B C -> Col_H A B C.
Proof.
intros.
unfold Col_H, Between_H in *.
DecompAndAll.
exists (Lin A B H2).
unfold IncidentL.
intuition.
Qed.

Lemma axiom_between_diff :
 forall A B C, Between_H A B C -> A<>C.
Proof.
intros.
unfold Between_H in *.
intuition.
Qed.

(** If B is between A and C, it is also between C and A. *)

Lemma axiom_between_comm : forall A B C, Between_H A B C -> Between_H C B A.
Proof.
unfold Between_H in |- *.
intros.
intuition.
Qed.

Lemma axiom_between_out :
 forall A B, A <> B -> exists C, Between_H A B C.
Proof.
intros.
prolong A B C A B.
exists C.
unfold Between_H.
repeat split;
auto;
intro;
treat_equalities;
tauto.
Qed.

Lemma axiom_between_only_one :
 forall A B C,
 Between_H A B C -> ~ Between_H B C A.
Proof.
unfold Between_H in |- *.
intros.
intro;
spliter.
assert (B=C) by
 (apply (between_equality B C A);Between).
solve [intuition].
Qed.

Lemma between_one : forall A B C,
 A<>B -> A<>C -> B<>C -> Col A B C ->
 Between_H A B C \/ Between_H B C A \/ Between_H B A C.
Proof.
intros.
unfold Col, Between_H in *.
destruct H2 as [|[|]]; [left|right..]; Between.
Qed.

Lemma axiom_between_one : forall A B C,
 A<>B -> A<>C -> B<>C -> Col_H A B C ->
 Between_H A B C \/ Between_H B C A \/ Between_H B A C.
Proof.
intros.
apply between_one;try assumption.
apply cols_coincide_1.
assumption.
Qed.

(** Axiom of Pasch, (Hilbert version). *)

(** First we define a predicate which means that the line l intersects the segment AB. *)

Definition cut := fun l A B =>
  ~ IncidentL A l /\ ~ IncidentL B l /\ exists I, IncidentL I l /\ Between_H A I B.

(** We show that this definition is equivalent to the predicate TS of Tarski. *)

Lemma cut_two_sides : forall l A B, cut l A B <-> TS (P1 l) (P2 l) A B.
Proof.
intros.
unfold cut.
unfold TS.
split.
intros.
spliter.
repeat split; intuition.
ex_and H1 T.
exists T.
unfold IncidentL in H1.
unfold Between_H in *.
intuition.

intros.
spliter.
ex_and H1 T.
unfold IncidentL.
repeat split; try assumption.
exists T.
split.
assumption.
unfold Between_H.
repeat split.
assumption.
intro.
subst.
contradiction.
intro.
subst.
contradiction.
intro.
treat_equalities.
contradiction.
Qed.

Lemma cop_plane_aux : forall A B C D, Coplanar A B C D -> A <> B ->
  exists p, IncidentP A p /\ IncidentP B p /\ IncidentP C p /\ IncidentP D p.
Proof.
  intros A B C D HCop HAB.
  destruct (col_dec A B C) as [|HNCol]; [destruct (col_dec A B D) as [|HNCol]|].
  - destruct (not_col_exists A B HAB) as [E HNCol].
    apply ncols_coincide in HNCol.
    exists (Plan A B E HNCol).
    unfold IncidentP; simpl; repeat split; Cop.
  - apply ncols_coincide in HNCol.
    exists (Plan A B D HNCol).
    unfold IncidentP; simpl; repeat split; Cop.
  - apply ncols_coincide in HNCol.
    exists (Plan A B C HNCol).
    unfold IncidentP; simpl; repeat split; Cop.
Qed.

Lemma cop_plane : forall A B C D, Coplanar A B C D ->
  exists p, IncidentP A p /\ IncidentP B p /\ IncidentP C p /\ IncidentP D p.
Proof.
  intros A B C D HCop.
  destruct (eq_dec_points A B) as [|HAB]; [destruct (eq_dec_points A C);
    [destruct (eq_dec_points A D)|]|].
  - destruct (another_point D) as [E].
    destruct (cop_plane_aux D E E E) as [p []]; Cop.
    subst; exists p; repeat split; assumption.
  - destruct (cop_plane_aux A D B C) as [p]; Cop.
    spliter; exists p; repeat split; assumption.
  - destruct (cop_plane_aux A C B D) as [p]; Cop.
    spliter; exists p; repeat split; assumption.
  - apply (cop_plane_aux A B C D HCop HAB).
Qed.

Lemma plane_cop: forall A B C D p,
  IncidentP A p -> IncidentP B p -> IncidentP C p -> IncidentP D p -> Coplanar A B C D.
Proof.
  unfold IncidentP.
  intros A B C D p HA HB HC HD.
  assert (HNCol := NCol p).
  apply ncols_coincide in HNCol.
  apply coplanar_pseudo_trans with (M1 p) (M2 p) (M3 p); assumption.
Qed.

Lemma axiom_pasch : forall A B C l p, ~ Col_H A B C ->
 IncidentP A p -> IncidentP B p -> IncidentP C p -> IncidentLP l p -> ~ IncidentL C l ->
 cut l A B -> cut l A C \/ cut l B C.
Proof.
intros.
apply cut_two_sides in H5.
assert(~Col A B C).
apply ncols_coincide.
assumption.

assert(HH:=H5).
unfold TS in HH.
spliter.

unfold IncidentL in H4.
assert (HCop : Coplanar (P1 l) (P2 l) A C).
apply plane_cop with p; trivial; apply H3; unfold IncidentL; simpl; Col.

assert(HH:= cop__one_or_two_sides (P1 l)(P2 l) A C HCop H7 H4).

induction HH.
left.
apply <-cut_two_sides.
assumption.
right.
apply <-cut_two_sides.
apply l9_2.
eapply l9_8_2.
apply H5.
assumption.
Qed.

Lemma Incid_line :
 forall P A B l, A<>B ->
 IncidentL A l -> IncidentL B l -> Col P A B -> IncidentL P l.
Proof.
intros.
unfold IncidentL in *.
destruct l as [C D HCD].
simpl in *.
ColR.
Qed.

(** * Group III Congruence *)

(** The cong predicate of Hilbert is the same as the one of Tarski: *)

Definition outH := fun P A B => Between_H P A B \/ Between_H P B A \/ (P <> A /\ A = B).

Lemma out_outH : forall P A B, Out P A B -> outH P A B.
unfold Out.
unfold outH.
intros.
spliter.
induction H1.

induction (eq_dec_points A B).
right; right.
split; auto.
left.
unfold Between_H.
repeat split; auto.

induction (eq_dec_points A B).
right; right.
split; auto.
right; left.
unfold Between_H.
repeat split; auto.
Qed.

Lemma axiom_hcong_1_existence : forall A B A' P l,
  A <> B -> A' <> P ->
  IncidentL A' l -> IncidentL P l ->
  exists B', IncidentL B' l /\ outH A' P B' /\ Cong A' B' A B.
Proof.
intros; destruct (l6_11_existence A' A B P) as [B' [HOut HCong]]; auto.
exists B'; repeat split; try apply out_outH, l6_6; auto; unfold IncidentL in *.
destruct l; simpl in *; ColR.
Qed.

Lemma axiom_hcong_1_uniqueness :
 forall A B l M A' B' A'' B'', A <> B -> IncidentL M l ->
  IncidentL A' l -> IncidentL B' l ->
  IncidentL A'' l -> IncidentL B'' l ->
  Between_H A' M B' -> Cong M A' A B ->
  Cong M B' A B -> Between_H A'' M B'' ->
  Cong M A'' A B -> Cong M B'' A B ->
  (A' = A'' /\ B' = B'') \/ (A' = B'' /\ B' = A'').
Proof.
unfold Between_H.
unfold IncidentL.
intros.
spliter.

assert(A' <> M /\ A'' <> M /\ B' <> M /\ B'' <> M /\ A' <> B' /\ A'' <> B'').
repeat split; intro; treat_equalities; tauto.
spliter.

induction(out_dec M A' A'').
left.
assert(A' = A'').
apply (l6_11_uniqueness M A B A''); try assumption.
apply out_trivial.
assumption.

split.
assumption.
subst A''.

apply (l6_11_uniqueness M A B B''); try assumption.

unfold Out.
repeat split; try assumption.
eapply l5_2.
apply H18.
assumption.
assumption.
apply out_trivial.
assumption.

right.
apply not_out_bet in H23.

assert(A' = B'').
apply (l6_11_uniqueness M A B A'); try assumption.
apply out_trivial.
assumption.

unfold Out.
repeat split; try assumption.

eapply l5_2.
apply H18.
assumption.
apply between_symmetry.
assumption.

split.
assumption.

subst B''.
apply (l6_11_uniqueness M A B B'); try assumption.
apply out_trivial.
assumption.
unfold Out.
repeat split; try assumption.
eapply l5_2.
apply H20.
apply between_symmetry.
assumption.
assumption.
eapply col3.
apply (Cond l).
Col.
Col.
Col.
Qed.

(** As a remark we also prove another version of this axiom as formalized in Isabelle by
Phil Scott. *)

Definition same_side_scott := fun E A B => E <> A /\ E <> B /\ Col_H E A B /\ ~ Between_H A E B.

Remark axiom_hcong_scott:
 forall P Q A C, A <> C -> P <> Q ->
  exists B, same_side_scott A B C  /\ Cong P Q A B.
Proof.
intros.
unfold same_side_scott.
assert (exists X : Tpoint, Out A X C /\ Cong A X P Q).
apply l6_11_existence;auto.
decompose [ex and] H1;clear H1.
exists x.
repeat split.
unfold Out in H3.
intuition.
unfold Out in H3.
intuition.
apply cols_coincide_2.
apply out_col;assumption.

unfold Out in H3.
unfold Between_H.
intro.
decompose [and] H3;clear H3.
decompose [and] H1;clear H1.
clear H8.
destruct H7.
assert (A = x).
eapply between_equality;eauto.
intuition.
assert (A = C).
eapply between_equality;eauto.
apply between_symmetry.
auto.
intuition.
Cong.
Qed.

(** We define when two segments do not intersect. *)

Definition disjoint := fun A B C D => ~ exists P, Between_H A P B /\ Between_H C P D.

(** Note that two disjoint segments may share one of their extremities. *)

Lemma col_disjoint_bet : forall A B C, Col_H A B C -> disjoint A B B C -> Bet A B C.
Proof.
intros.
apply cols_coincide_1 in H.
unfold disjoint in H0.

induction (eq_dec_points A B).
subst  B.
apply between_trivial2.
induction (eq_dec_points B C).
subst  C.
apply between_trivial.

unfold Col in H.
induction H.
assumption.

induction H.
apply False_ind.
apply H0.
assert(exists M, Midpoint M B C) by(apply midpoint_existence).
ex_and H3 M.
exists M.
unfold Midpoint in H4.
spliter.
split.
unfold Between_H.
repeat split.
apply between_symmetry.
eapply between_exchange4.
apply H3.
assumption.
intro.
treat_equalities.
(*
apply between_symmetry in H.
apply between_equality in H.
treat_equalities.
*)
tauto.
(*
apply between_symmetry.
assumption.
*)
intro.
treat_equalities.
tauto.
assumption.
unfold Between_H.
repeat split.
assumption.
intro.
treat_equalities.
tauto.
intro.
treat_equalities.
tauto.
assumption.

apply False_ind.
apply H0.
assert(exists M, Midpoint M A B) by(apply midpoint_existence).
ex_and H3 M.
exists M.
unfold Midpoint in H4.
spliter.
split.
unfold Between_H.
repeat split.
assumption.
intro.
treat_equalities.
tauto.
intro.
treat_equalities.
tauto.
assumption.

unfold Between_H.
repeat split.

eapply between_exchange4.
apply between_symmetry.
apply H3.
apply between_symmetry.
assumption.
intro.
treat_equalities.
tauto.
intro.
treat_equalities.
intuition.
assumption.
Qed.

Lemma axiom_hcong_3 : forall A B C A' B' C',
   Col_H A B C -> Col_H A' B' C' ->
  disjoint A B B C -> disjoint A' B' B' C' ->
  Cong A B A' B' -> Cong B C B' C' -> Cong A C A' C'.
Proof.
intros.
assert(Bet A B C).
eapply col_disjoint_bet.
assumption.
assumption.

assert(Bet A' B' C').
eapply col_disjoint_bet.
assumption.
assumption.
eapply l2_11;eauto.
Qed.

Lemma exists_not_incident : forall A B : Tpoint, forall  HH : A <> B , exists C, ~ IncidentL C (Lin A B HH).
Proof.
intros.
unfold IncidentL.
assert(HC:=not_col_exists A B HH).
ex_and HC C.
exists C.
intro.
apply H.
simpl in H0.
Col.
Qed.

Definition same_side := fun A B l => exists P, cut l A P /\ cut l B P.

(** Same side predicate corresponds to OS of Tarski. *)

Lemma same_side_one_side : forall A B l, same_side A B l -> OS (P1 l) (P2 l) A B.
Proof.
unfold same_side.
intros.
destruct H as [P []].
apply cut_two_sides in H.
apply cut_two_sides in H0.
eapply l9_8_1.
apply H.
apply H0.
Qed.

Lemma one_side_same_side : forall A B l, OS (P1 l) (P2 l) A B -> same_side A B l.
Proof.
intros.
unfold same_side.
unfold OS in H.
destruct H as [P []].
exists P.
unfold cut.
unfold IncidentL.
unfold TS in H.
unfold TS in H0.
spliter.
repeat split; auto.
ex_and H4 T.
exists T.
unfold Between_H.
repeat split; auto.
intro.
subst T.
contradiction.
intro.
subst T.
contradiction.
intro.
subst P.
apply between_identity in H5.
subst T.
contradiction.
ex_and H2 T.
exists T.
unfold Between_H.
repeat split; auto.
intro.
subst T.
contradiction.
intro.
subst T.
contradiction.
intro.
subst P.
apply between_identity in H5.
subst T.
contradiction.
Qed.

Definition same_side' := fun A B X Y =>
  X <> Y /\ forall l, IncidentL X l -> IncidentL Y l -> same_side A B l.

Lemma OS_distinct : forall P Q A B,
  OS P Q A B -> P<>Q.
Proof.
intros.
apply one_side_not_col123 in H.
assert_diffs;assumption.
Qed.

Lemma OS_same_side' :
 forall P Q A B, OS P Q A B -> same_side' A B P Q.
Proof.
intros.
unfold same_side'.
intros.
split.
apply OS_distinct with A B;assumption.
intros.

apply  one_side_same_side.
destruct l.
unfold IncidentL in *.
simpl in *.
apply col2_os__os with P Q; try assumption; ColR.
Qed.

Lemma same_side_OS :
 forall P Q A B, same_side' P Q A B -> OS A B P Q.
Proof.
intros.
unfold same_side' in *.
destruct H.
destruct (axiom_line_existence A B H).
destruct H1.
assert (T:=H0 x H1 H2).
assert (U:=same_side_one_side P Q x T).
destruct x.
unfold IncidentL in *.
simpl in *.
apply col2_os__os with P1 P2;Col.
Qed.

(** This is equivalent to the out predicate of Tarski. *)

Lemma outH_out : forall P A B, outH P A B -> Out P A B.
Proof.
unfold outH.
unfold Out.
intros.
induction H.
unfold Between_H in H.
spliter.
repeat split; auto.
induction H.
unfold Between_H in H.
spliter.
repeat split; auto.
spliter.
repeat split.
auto.
subst B.
auto.
subst B.
left.
apply between_trivial.
Qed.

(** The 2D version of the fourth congruence axiom **)

Lemma incident_col : forall M l, IncidentL M l -> Col M (P1 l)(P2 l).
Proof.
unfold IncidentL.
intros.
assumption.
Qed.

Lemma col_incident : forall M l, Col M (P1 l)(P2 l) -> IncidentL M l.
Proof.
unfold IncidentL.
intros.
assumption.
Qed.

Lemma Bet_Between_H : forall A B C,
 Bet A B C -> A<>B -> B<>C -> Between_H A B C.
Proof.
intros.
unfold Between_H.
repeat split;try assumption.
intro.
subst.
treat_equalities.
intuition.
Qed.

Lemma axiom_cong_5' : forall A B C A' B' C', ~ Col_H A B C -> ~ Col_H A' B' C' ->
           Cong A B A' B' -> Cong A C A' C' -> CongA B A C B' A' C' -> CongA A B C A' B' C'.
Proof.
intros A B C A' B' C'.
intros.
assert (T:=l11_49 B A C B' A' C').
assert (~ Col A B C).
intro.
apply cols_coincide_2 in H4.
intuition.
assert_diffs.
intuition.
Qed.

Lemma axiom_hcong_4_existence :  forall A B C O X P,
   ~ Col_H P O X -> ~ Col_H A B C ->
  exists Y, CongA A B C X O Y  (* /\ ~Col O X Y *) /\ same_side' P Y O X.
Proof.
intros.
rewrite <- cols_coincide in H.
rewrite <- cols_coincide in H0.

assert(~Col X O P).
intro.
apply H.
Col.
assert(HH:=angle_construction_1 A B C X O P H0 H1).

ex_and HH Y.

exists Y.
split.
assumption.
apply OS_same_side'.
apply invert_one_side.
apply one_side_symmetry.
assumption.
Qed.

Lemma same_side_trans :
 forall A B C l,
  same_side A B l -> same_side B C l -> same_side A C l.
Proof.
intros.
apply one_side_same_side.
apply same_side_one_side in H.
apply same_side_one_side in H0.
eapply one_side_transitivity.
apply H.
assumption.
Qed.

Lemma same_side_sym :
 forall A B l,
  same_side A B l -> same_side B A l.
Proof.
intros.
apply one_side_same_side.
apply same_side_one_side in H.
apply one_side_symmetry.
assumption.
Qed.

Lemma axiom_hcong_4_uniqueness :
  forall A B C O P X Y Y', ~ Col_H P O X  -> ~ Col_H A B C -> CongA A B C X O Y -> CongA A B C X O Y' ->
  same_side' P Y O X -> same_side' P Y' O X -> outH O Y Y'.
Proof.
intros.
rewrite <- cols_coincide in H.
rewrite <- cols_coincide in H0.
assert (T:CongA X O Y X O Y').
eapply conga_trans.
apply conga_sym.
apply H1.
assumption.

apply out_outH.
apply (conga_os__out X).
assumption.

apply same_side_OS in H3.
apply same_side_OS in H4.
apply invert_one_side.
apply one_side_transitivity with P.
apply one_side_symmetry.
assumption.
assumption.
Qed.

Lemma axiom_conga_comm : forall A B C,
 ~ Col_H A B C -> CongA A B C C B A.
Proof.
intros.
rewrite <- cols_coincide in H.
assert_diffs.
apply conga_pseudo_refl;auto.
Qed.

Lemma axiom_congaH_outH_congaH :
 forall A B C D E F A' C' D' F' : Tpoint,
  CongA A B C D E F ->
  Between_H B A A' \/ Between_H B A' A \/ B <> A /\ A = A' ->
  Between_H B C C' \/ Between_H B C' C \/ B <> C /\ C = C' ->
  Between_H E D D' \/ Between_H E D' D \/ E <> D /\ D = D' ->
  Between_H E F F' \/ Between_H E F' F \/ E <> F /\ F = F' ->
  CongA A' B C' D' E F'.
Proof.
intros.
apply l11_10 with A C D F; trivial; apply l6_6; apply outH_out; auto.
Qed.

Lemma axiom_conga_permlr:
forall A B C D E F : Tpoint, CongA A B C D E F -> CongA C B A F E D.
Proof.
apply Ch11_angles.conga_comm.
Qed.

(*
Lemma axiom_inter_dec : forall l m,
  (exists P, IncidentL P l /\ IncidentL P m) \/ ~ (exists P, IncidentL P l /\ IncidentL P m).
Proof.
intros l m;
elim (inter_dec (P1 l) (P2 l) (P1 m) (P2 m));
intro; [left|right]; auto.
Qed.
*)

Lemma axiom_conga_refl : forall A B C, ~ Col_H A B C -> CongA A B C A B C.
Proof.
intros A B C H.
apply Ch11_angles.conga_refl; intro; subst; apply H; apply cols_coincide; Col.
Qed.

End T.

Section Tarski_neutral_to_Hilbert_neutral.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Instance Hilbert_neutral_follows_from_Tarski_neutral : Hilbert_neutral_dimensionless.
Proof.
exact (Build_Hilbert_neutral_dimensionless Tpoint Line Plane EqL EqL_Equiv EqP EqP_Equiv IncidentL
       IncidentP axiom_Incid_morphism axiom_Incid_dec axiom_Incidp_morphism axiom_Incidp_dec
       eq_dec_points axiom_line_existence axiom_line_uniqueness axiom_two_points_on_line PA
       PB PC lower_dim' axiom_plane_existence axiom_one_point_on_plane axiom_plane_uniqueness
       axiom_line_on_plane Between_H axiom_between_diff axiom_between_col axiom_between_comm
       axiom_between_out axiom_between_only_one axiom_pasch Cong cong_right_commutativity
       axiom_hcong_1_existence cong_inner_transitivity
        axiom_hcong_3 CongA axiom_conga_refl axiom_conga_comm
       axiom_conga_permlr axiom_congaH_outH_congaH axiom_hcong_4_existence
       axiom_hcong_4_uniqueness axiom_cong_5').
Defined.

End Tarski_neutral_to_Hilbert_neutral.

Section Tarski_neutral_2D_to_Hilbert_neutral_2D.

Context `{T2D:Tarski_2D}.

Instance Hilbert_2D_follows_from_Tarski_2D : Hilbert_neutral_2D Hilbert_neutral_follows_from_Tarski_neutral.
Proof.
split.
intros A B C l HNCol HNCl Hcut.
apply axiom_pasch with (Plan A B C HNCol); trivial;
  unfold IncidentLP, IncidentP; intros; try (apply all_coplanar).
Defined.

End Tarski_neutral_2D_to_Hilbert_neutral_2D.

Section Tarski_neutral_3D_to_Hilbert_neutral_3D.

Context `{T3D:Tarski_3D}.

Lemma lower_dim_3' : {A : Tpoint & {B : Tpoint & {C : Tpoint & {D |
  ~ exists p, IncidentP A p /\ IncidentP B p /\ IncidentP C p /\ IncidentP D p}}}}.
Proof.
exists S1, S2, S3, S4.
intros [p]; spliter.
apply tarski_axioms.lower_dim_3, plane_cop with p; assumption.
Qed.

Instance Hilbert_3D_follows_from_Tarski_3D : Hilbert_neutral_3D Hilbert_neutral_follows_from_Tarski_neutral.
Proof.
destruct lower_dim_3' as [A [B [C [D n]]]].
exists A B C D; [|assumption].
clear A B C D n.
intros A p q HAp HAq.
destruct p as [P1 P2 P3 HP].
destruct q as [Q1 Q2 Q3 HQ].
unfold IncidP in *; simpl in *; unfold IncidentP in *; simpl in *.
assert (pi : plane_intersection_axiom).
cut upper_dim_3_axiom.
apply upper_dim_3_equivalent_axioms; simpl; tauto.
unfold upper_dim_3_axiom.
apply upper_dim_3.
apply pi; assumption.
Defined.

End Tarski_neutral_3D_to_Hilbert_neutral_3D.

Section Tarski_Euclidean_to_Hilbert_Euclidean.

Context `{TE:Tarski_euclidean}.

(** * Group Parallels *)

Definition Para := fun l m =>
  (~ exists X, IncidentL X l /\ IncidentL X m) /\ exists p, IncidentLP l p /\ IncidentLP m p.

Lemma Para_Par : forall A B C D (HAB : A<>B) (HCD: C<>D),
 Para (Lin A B HAB) (Lin C D HCD) -> Par A B C D.
Proof.
unfold Para, IncidentL, Par, Par_strict; simpl.
intros.
destruct H as [HNI [p []]].
left.
repeat split;auto.
apply plane_cop with p; [apply H|apply H|apply H0..]; unfold IncidentL; simpl; Col.
Qed.

Lemma axiom_euclid_uniqueness :
  forall l P m1 m2,
  ~ IncidentL P l ->
   Para l m1 -> IncidentL P m1 ->
   Para l m2 -> IncidentL P m2 ->
   EqL m1 m2.
Proof.
intros.
destruct l as [A B HAB].
destruct m1 as [C D HCD].
destruct m2 as [C' D' HCD'].
unfold IncidentL in *;simpl in *.
apply Para_Par in H0.
apply Para_Par in H2.
elim (tarski_s_euclid_implies_playfair euclid A B C D C' D' P H0 H1 H2 H3);intros.
apply axiom_line_uniqueness with C' D';
unfold IncidentL;simpl;Col.
Qed.

Instance Hilbert_euclidean_follows_from_Tarski_euclidean :
  Hilbert_euclidean Hilbert_neutral_follows_from_Tarski_neutral.
Proof.
split.
apply axiom_euclid_uniqueness.
Defined.

Instance Hilbert_euclidean_ID_follows_from_Tarski_euclidean :
  Hilbert_euclidean_ID Hilbert_euclidean_follows_from_Tarski_euclidean.
Proof.
split.
intros l m.
assert (ID : decidability_of_intersection).
apply strong_parallel_postulate_implies_inter_dec.
cut tarski_s_parallel_postulate.
apply equivalent_postulates_without_decidability_of_intersection_of_lines_bis; simpl; tauto.
unfold tarski_s_parallel_postulate.
apply euclid.
destruct l as [L1 L2 HL].
destruct m as [M1 M2 HM].
simpl; unfold IncidentL; simpl.
apply ID.
Defined.

End Tarski_Euclidean_to_Hilbert_Euclidean.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Omega.

Set Implicit Arguments.

Parameter Var : Type.

(* Definition of the terms of combinatory algebras *)

Inductive clterm : Type :=
 | cl_S   : clterm
 | cl_K   : clterm
 | cl_I   : clterm
 | cl_app : clterm -> clterm -> clterm
 | cl_var : Var -> clterm.

(* Some short notations *)

Infix "o" := (@cl_app) (at level 61, left associativity).
Notation " 'µ' x " := (@cl_var x) (at level 0).

(* an n-iterate of cl_K *)

Fixpoint cl_Kn n :=
  match n with
    | 0   => cl_K
    | S n => cl_K o cl_Kn n
  end.

(* A measure of the size of terms *)

Fixpoint cl_size f :=
  match f with
    | f o g => 1 + cl_size f + cl_size g
    | _     => 1
  end.

(** Some more short notations
    Beware that S masks the S : nat -> nat
    successor constructor of the type nat
*)

Notation K := cl_K.
Notation S := cl_S.
Notation I := cl_I.

(* cl_* constructors are injective *)

Fact cl_var_inj p q : µ p = µ q -> p = q.
Proof.
  injection 1; auto.
Qed.

Fact cl_app_inj f g a b : f o a = g o b -> f = g /\ a = b.
Proof.
  injection 1; auto.
Qed.

(* The size of cl_Kn *)

Fact cl_Kn_size i : cl_size (cl_Kn i) = 2*i+1.
Proof.
  induction i; simpl; omega.
Qed.

(* The map n -> cl_Kn is injective as well *)

Corollary cl_Kn_inj i j : cl_Kn i = cl_Kn j -> i = j.
Proof.
  intros H.
  apply f_equal with (f := cl_size) in H.
  do 2 rewrite cl_Kn_size in H.
  omega.
Qed.


Require Export D.

(** **** Problem : 2 stars (double_plus) *)

(* See [D.v] for the definition of [double] *)

(** Use induction to prove this simple fact about [double]: *)

Lemma double_plus : forall n, double n = n + n .
Proof.
  intros. induction n. simpl. reflexivity.
  simpl. rewrite -> IHn.
  Lemma plus_Smn_mSn : forall m n:nat, S (m + n) = m + S n.
  Proof.
      intros. induction m. reflexivity.
      simpl. rewrite -> IHm. reflexivity. Qed.
  rewrite -> plus_Smn_mSn. reflexivity.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Definition unit  := unit.

Parameter mark : Type.

Parameter at1: forall (a:Type), a -> mark  -> a.

Implicit Arguments at1.

Parameter old: forall (a:Type), a  -> a.

Implicit Arguments old.

Inductive ref (a:Type) :=
  | mk_ref : a -> ref a.
Implicit Arguments mk_ref.

Definition contents (a:Type)(u:(ref a)): a :=
  match u with
  | mk_ref contents1 => contents1
  end.
Implicit Arguments contents.

Inductive even : Z -> Prop :=
  | even_0 : (even 0%Z)
  | even_odd : forall (x:Z), (even x) -> (even (x + 2%Z)%Z).

Theorem even_not_odd : forall (x:Z), (even x) -> ~ (even (x + 1%Z)%Z).
(* YOU MAY EDIT THE PROOF BELOW *)
assert (nonneg: forall x:Z, even x -> (x >= 0)%Z).
induction 1; auto with *.
induction 1.
red; intro.
inversion H.
assert (h: (x = -1)%Z) by omega.
absurd (-1 >= 0)%Z.
omega.
apply nonneg.
rewrite <- h; auto.
intuition.
inversion H0.
assert (h: (x = -3)%Z) by omega.
absurd (-3 >= 0)%Z.
omega.
apply nonneg.
rewrite <- h; auto.
assert (x0 = x+1)%Z by omega.
subst x0; auto.
Qed.
(* DO NOT EDIT BELOW *)


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf1 : natural) (x : natural) (y : natural) : natural :=
  mult x (plus Zero y).


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (y : natural) (x : natural) (lf1 : natural) : natural :=
  mult (Succ y) x.


(** CS6225 PSet5a *)

(** * 6.822 Formal Reasoning About Programs, Spring 2018 - Pset 3 *)

Require Import Frap.

(* In this problem set, we'll get some experience with higher-order functions,
 * which are functions that themselves take functions as arguments!
 *)

Inductive tree {A} :=
| Leaf
| Node (l : tree) (d : A) (r : tree).
Arguments tree : clear implicits.

Fixpoint flatten {A} (t : tree A) : list A :=
  match t with
  | Leaf => []
  | Node l d r => flatten l ++ d :: flatten r
  end.

Module Type S.

  (* Define the identity function [id], which just returns its
   * argument without modification.
   *)
  Parameter id : forall {A : Type}, A -> A.
  (* 5 points *)

  (* [compose] is another higher-order function: [compose g f]
   * applies [f] to its input and then applies [g]. Argument order
   * follows the general convention of functional composition in
   * mathematics denoted by the small circle.
   *)
  Parameter compose : forall {A B C : Type}, (B -> C) -> (A -> B) -> A -> C.
  (* 5 points *)

  (* If we map the [id] function over any list, we get the
   * same list back.
   *)
  Axiom map_id : forall {A : Type} (xs : list A),
    map id xs = xs.
  (* 5 points *)

  (* If we map the composition of two functions over the list,
   * it's the same as mapping the first function over the whole list
   * and then mapping the second function over that resulting list.
   *)
  Axiom map_compose : forall {A B C : Type} (g : B -> C) (f : A -> B)
                             (xs : list A),
    map (compose g f) xs = map g (map f xs).
  (* 5 points *)

  (* Next we can show some classic properties that demonstrate a
   * certain sense in which [map] only modifies the elements of
   * a list but preserves its structure: [map_length] shows it
   * preserves length, and [map_append] and [map_rev] show that
   * it commutes with [++] and [rev], respectively.
   * For each of [length], [++], and [rev], it doesn't matter
   * whether we apply [map] before the operation or after.
   *)
  Axiom map_length : forall {A B : Type} (f : A -> B) (xs : list A),
    length (map f xs) = length xs.
  (* 5 points *)

  Axiom map_append : forall {A B : Type} (f : A -> B) (xs ys : list A),
    map f (xs ++ ys) = map f xs ++ map f ys.
  (* 5 points *)

  Axiom map_rev : forall {A B : Type} (f : A -> B) (xs : list A),
    map f (rev xs) = rev (map f xs).
  (* 5 points *)

  (* [fold] is a higher-order function that is even more general
   * than [map]. In essence, [fold f z] takes as input a list
   * and produces a term where the [cons] constructor is
   * replaced by [f] and the [nil] constructor is replaced
   * by [z].
   *
   * [fold] is a "right" fold, which associates the binary operation
   * the opposite way as the [fold_left] function that we defined
   * in lecture.
   *)
  Parameter fold : forall {A B : Type}, (A -> B -> B) -> B -> list A -> B.
  (* 5 points *)

  (* For instance, we should have
       fold plus 10 [1; 2; 3]
     = 1 + (2 + (3 + 10))
     = 16
   *)
  Axiom fold_example : fold plus 10 [1; 2; 3] = 16.
  (* 5 points *)

  (* Prove that [map] can actually be defined as a particular
   * sort of [fold].
   *)
  Axiom map_is_fold : forall {A B : Type} (f : A -> B) (xs : list A),
    map f xs = fold (fun x ys => cons (f x) ys) nil xs.
  (* 5 points *)

  (* Since [fold f z] replaces [cons] with [f] and [nil] with
   * [z], [fold cons nil] should be the identity function.
   *)
  Axiom fold_id : forall {A : Type} (xs : list A),
    fold cons nil xs = xs.
  (* 5 points *)

  (* If we apply [fold] to the concatenation of two lists,
   * it is the same as folding the "right" list, and using
   * that as the starting point for folding the "left" list.
   *)
  Axiom fold_append : forall {A : Type} (f : A -> A -> A) (z : A)
                        (xs ys : list A),
    fold f z (xs ++ ys) =
    fold f (fold f z ys) xs.
  (* 5 points *)

  (* Using [fold], define a function that computes the
   * sum of a list of natural numbers.
   *)
  Parameter sum : list nat -> nat.
  (* 5 points *)

  (* Note that [simplify] fails to reduce [ sum [1; 2; 3] ].
   * This is due to a quirk of [simplify]'s behavior: because
   * unfolding [sum] does not present an immediate opportunity
   * for reduction (since [fold] will still need to be unfolded
   * to its fixpoint definition, no simplification is performed).
   * A simple remedy is to use the tactic [unfold sum] prior to
   * calling [simplify]. This should come in handy for future proofs
   * involving definitions that use [fold], too.
   *)
  Axiom sum_example : sum [1; 2; 3] = 6.
  (* 5 points *)

  (* Using [fold], define a function that computes the
   * conjunction of a list of Booleans (where the 0-ary
   * conjunction is defined as [true]).
   *)
  Parameter all : list bool -> bool.
  (* 5 points *)

  Axiom all_example : all [true; false; true] = false.
  (* 5 points *)

  (* The following two theorems, [sum_append] and [all_append],
   * say that the sum of the concatenation of two lists
   * is the same as summing each of the lists first and then
   * adding the result.
   *)
  Axiom sum_append : forall (xs ys : list nat),
      sum (xs ++ ys) = sum xs + sum ys.
  (* 5 points *)

  Axiom all_append : forall (xs ys : list bool),
      all (xs ++ ys) = andb (all xs) (all ys).
  (* 5 points *)

  (* Just like we defined [map] for lists, we can similarly define
   * a higher-order function [tree_map] which applies a function on
   * elements to all of the elements in the tree, leaving the tree
   * structure intact.
   *)
  Parameter tree_map : forall {A B : Type}, (A -> B) -> tree A -> tree B.
  (* 5 points *)

  Axiom tree_map_example :
    tree_map (fun x => x + 1) (Node (Node Leaf 1 Leaf) 2 (Node Leaf 3 (Node Leaf 4 Leaf)))
    = (Node (Node Leaf 2 Leaf) 3 (Node Leaf 4 (Node Leaf 5 Leaf))).
  (* 5 points *)

  (* [tree_map_flatten] shows that [map]
   * and [tree_map] are related by the [flatten] function.
   *)
  Axiom tree_map_flatten : forall {A B : Type} (f : A -> B) (t : tree A),
      flatten (tree_map f t) = map f (flatten t).
  (* 5 points *)

  (* Using [fold], define a function that composes a list of functions,
   * applying the *last* function in the list *first*.
   *)
  Parameter compose_list : forall {A : Type}, list (A -> A) -> A -> A.
  (* 5 points *)

  Axiom compose_list_example :
    compose_list [fun x => x + 1; fun x => x * 2; fun x => x + 2] 1 = 7.
  (* 5 points *)

  (* Show that [sum xs] is the same as converting each number
   * in the list [xs] to a function that adds that number,
   * composing all of those functions together, and finally
   * applying that large composed function to [0].
   * Note that function [plus], when applied to just one number as an
   * argument, returns a function over another number, which
   * adds the original argument to it!
   *)
  Axiom compose_list_map_add_sum : forall (xs : list nat),
    compose_list (map plus xs) 0 = sum xs.
  (* 5 points *)

End S.


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

(* $Id: Field.v 14641 2011-11-06 11:59:10Z herbelin $ *)

(**** Tests of Field with real numbers ****)

Require Import Reals RealField.
Open Scope R_scope.

(* Example 1 *)
Goal
forall eps : R,
eps * (1 / (2 + 2)) + eps * (1 / (2 + 2)) = eps * (1 / 2).
Proof.
  intros.
   field.
Qed.

(* Example 2 *)
Goal
forall (f g : R -> R) (x0 x1 : R),
(f x1 - f x0) * (1 / (x1 - x0)) + (g x1 - g x0) * (1 / (x1 - x0)) =
(f x1 + g x1 - (f x0 + g x0)) * (1 / (x1 - x0)).
Proof.
  intros.
   field.
Abort.

(* Example 3 *)
Goal forall a b : R, 1 / (a * b) * (1 / (1 / b)) = 1 / a.
Proof.
  intros.
   field.
Abort.

Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a.
Proof.
  intros.
   field_simplify_eq.
Abort.

Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a.
Proof.
  intros.
   field_simplify (1 / (a * b) * (1 / 1 / b)).
Abort.

(* Example 4 *)
Goal
forall a b : R, a <> 0 -> b <> 0 -> 1 / (a * b) / (1 / b) = 1 / a.
Proof.
  intros.
   field; auto.
Qed.

(* Example 5 *)
Goal forall a : R, 1 = 1 * (1 / a) * a.
Proof.
  intros.
   field.
Abort.

(* Example 6 *)
Goal forall a b : R, b = b * / a * a.
Proof.
  intros.
   field.
Abort.

(* Example 7 *)
Goal forall a b : R, b = b * (1 / a) * a.
Proof.
  intros.
   field.
Abort.

(* Example 8 *)
Goal forall x y : R,
  x * (1 / x + x / (x + y)) =
  - (1 / y) * y * (- (x * (x / (x + y))) - 1).
Proof.
  intros.
   field.
Abort.

(* Example 9 *)
Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a -> False.
Proof.
intros.
field_simplify_eq in H.
Abort.


Require Import Problem Arith.
From mathcomp Require Import ssreflect.

Lemma L0: forall n m, product_of_range n (S m) = (S n) * product_of_range (S n) m.
Proof.
  by rewrite /=.
Qed.

Lemma L1: forall n m, product_of_range n (S m) = (n + S m) * product_of_range n m.
Proof.
  intros n m.
  revert n.
  elim: m => [| m' IHm'].
  intros n.
  by rewrite /= !Nat.mul_1_r Nat.add_1_r.
  intros.
  rewrite L0.
  rewrite IHm'.
  rewrite L0.
  by ring.
Qed.

Theorem solution: task.
Proof.
  rewrite /task.
  intros n m.
  revert n.
  elim m => [| m' IHm].
  rewrite /product_of_range.
  exists 1.
  by rewrite /=.
  intros n.
  elim n => [| n' IHn].
  exists 1.
  by rewrite /=.
  case: (IHm (S n')) => p Hp.
  case: IHn => k Hk.
  exists (p + k).
  rewrite L1.
  rewrite L0 in Hk.
  repeat rewrite Nat.mul_add_distr_r.
  rewrite Hk.
  rewrite Hp.
  rewrite (_ : S m' * (p * product_of_range 0 m') = p * ((0 + S m') * product_of_range 0 m')).
  rewrite -L1.
  by rewrite Nat.add_comm.
  rewrite Nat.add_0_l.
  rewrite !Nat.mul_assoc.
  by rewrite (Nat.mul_comm (S m') p).
Qed.


Require Import Arith.
Require Import Ascii.
Require Import Nat.
Require Import Bool.
Require Import Coq.Strings.Byte.
Require Import Strings.String.
Scheme Equality for string.
Local Open Scope string_scope.

Inductive NaturaL : Type :=
| TypeNat : nat -> NaturaL
| ErrorNat : NaturaL.

Inductive BooleaN : Type :=
| TypeBool : bool -> BooleaN
| ErrorBool : BooleaN.

Inductive StringS : Type :=
| TypeString : string -> StringS
| ErrorString : StringS.

Inductive DataS :=
| undecl : DataS
| assign : DataS
| default : DataS
| nat_type : NaturaL -> DataS
| bool_type : BooleaN -> DataS.

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

Coercion TypeNat : nat >-> NaturaL.
Coercion TypeBool : bool >-> BooleaN.
Coercion TypeString : string >->StringS.

Scheme Equality for DataS.

Definition Env := string -> DataS.

Inductive list (T : Type) : Type :=
| null
| cons (t : T) (l : list T).

Check cons NaturaL 4 (cons NaturaL 3 (null NaturaL)).
Check cons BooleaN false (cons BooleaN true (null BooleaN)).

Arguments null {T}.
Notation "[]" := null.

Notation "{ X , .. , Y }" := (cons NaturaL X .. (cons NaturaL Y []) ..).
Notation "{ X ; .. ; Y }" := (cons BooleaN X .. (cons BooleaN Y []) ..).
Notation "{ X ;;; .. ;;; Y }" := (cons StringS X .. (cons StringS Y []) ..).

Check {1, 2, 3}.
Check {false; true; true; false}.

Definition listanat1 := {1, 2, 3, 4, 5}.
Definition listanat2 := {1, 4, 6, 8, 9}.
Definition listabool := {true; false; true; false; false}.
Definition listastring := { "gabriel" ;;; "gabriela" }.

 Inductive Vectori : Type :=
| vector_natural : list NaturaL -> Vectori
| vector_boolean : list BooleaN -> Vectori
| vector_string : list StringS -> Vectori
| Matrice : list Vectori -> Vectori.

Check vector_natural listanat1.
Check vector_boolean listabool.

Notation "{ X & .. & Y }" := (cons Vectori X .. (cons Vectori Y []) ..).
Check Matrice { (vector_natural listanat1) & ( vector_natural listanat2) }.

Notation "'[Natural]' = V " := (vector_natural V) (at level 20).
Notation "'[Boolean]' = V " := (vector_boolean V) (at level 20).
Notation "'[String]' = V " := (vector_string V) (at level 20).
Notation "'[[Matrice]]' = V" := (Matrice V) (at level 20).

Definition vector_nat := [Natural] = listanat1.
Definition vector_bool := [Boolean] = listabool.
Definition vector_string1 := [String] = listastring.

Compute vector_nat.
Compute vector_bool.
Compute vector_string.

(*EXPRESII ARITMETICE *)
Inductive AExp :=
| a_variabila : string -> AExp
| a_numar : NaturaL -> AExp
| a_plus : AExp -> AExp -> AExp
| a_mul : AExp -> AExp -> AExp
| a_min : AExp -> AExp -> AExp
| a_mod : AExp -> AExp -> AExp
| a_div : AExp -> AExp -> AExp.

Inductive Var := n | i | x | y | sum.

(*Notatii folosite pentru expresii aritmetice*)

Notation "A +' B" := (a_plus A B) (at level 48).
Notation "A -' B" := (a_min A B) (at level 48).
Notation "A /' B" := (a_div A B) (at level 46).
Notation "A *' B" := (a_mul A B) (at level 46).
Notation "A %' B" := (a_mod A B) (at level 47).

Coercion a_numar: NaturaL >-> AExp.
Coercion a_variabila: string >-> AExp.

Check "y".
Check( 1 %' 2).

Inductive BExp :=
| btrue
| bfalse
| bvar: string->BExp
| b_egal : AExp -> AExp -> BExp (* sintaxa pentru egal *)
| b_less : AExp -> AExp -> BExp
| b_lessequal : AExp -> AExp -> BExp
| b_greater : AExp -> AExp -> BExp
| b_greaterequal : AExp -> AExp -> BExp
| b_notegal : AExp -> AExp -> BExp
| b_not : BExp -> BExp (*sintaxa pentru not*)
| b_and : BExp -> BExp -> BExp (*sintaxa pentru and *)
| b_or : BExp -> BExp -> BExp (*sintaxa pentru or*)
| b_xor : BExp -> BExp -> BExp. (*sintaxa pentru xor*)
Coercion bvar: string>->BExp.
(*Notatii  pentru expresii booleane*)
Notation "! A" := (b_not A) (at level 52).
Notation "A &&' B" := (b_and A B) (at level 53).
Notation "A ||' B" := (b_or A B) (at level 54).
Notation "A \\' B " := (b_xor A B) (at level 54).
Notation "A <' B" := (b_less A B) (at level 70, no associativity).
Notation "A <=' B" := (b_lessequal A B) (at level 70, no associativity).
Notation "A >' B" := (b_greater A B) (at level 70, no associativity).
Notation "A >=' B" := (b_greaterequal A B) (at level 70, no associativity).
Notation "A ==' B" := (b_egal A B) (at level 70, no associativity).
Notation "A !=' B" := (b_notegal A B) (at level 70, no associativity).

Check 4 +' 5.
Check (btrue &&' bfalse ).
Check ( ! btrue).
Check( btrue ||' bfalse).
Check( btrue \\' bfalse).
Check( 1 <' 2).
Check( 1 <=' 2).

(* Functii predefinite *)
Inductive Functii :=
| Max : AExp -> AExp -> Functii
| Min : AExp -> AExp -> Functii
| Egal : AExp -> AExp -> Functii
| Putere : AExp -> AExp -> Functii.

Notation "'Max' '(' A , B ')'" := (Max A B) (at level 50).
Notation "'Min' '(' A , B ')'" := (Min A B) (at level 50).
Notation "'Egal' '(' A , B ')'" := (Egal A B) (at level 50).
Notation "'Putere' '(' A , B ')'" := (Putere A B) (at level 57).

Check ( Max(1, 2) ).
Check ( Min(1, 2) ).
Check ( Egal(19 +' 23 *' 3, 22 /' 4 -' 2) ).
Check ( Putere(2, 3) ).

Inductive Stmt : Type :=
(*DECLARARI*)
| declarareNatural :  string -> Stmt
| declarareBoolean :  string -> Stmt
| declarareString :  string -> Stmt

(*ATRIBURI*)
| atribuireNatural : string -> AExp -> Stmt
| atribuireBoolean : string -> BExp -> Stmt
| atribuireString : string -> AExp -> Stmt

(*INITIALIZARI*)
| initializareNatural : string -> AExp -> Stmt
| initializareBoolean : string -> BExp -> Stmt
| initializareString : string -> AExp -> Stmt

(*INSTRUCTIUNI*)
| pop : string -> Stmt
| secventa : Stmt -> Stmt -> Stmt
| incrementare : string -> AExp -> Stmt (*sintaxa pentru incrementare*)
| decrementare : string -> AExp -> Stmt (*sintaxa pentru decrementare*)
| if_then_else : BExp -> Stmt -> Stmt -> Stmt
| if_then : BExp -> Stmt -> Stmt
| while_do : BExp -> Stmt -> Stmt
| for_do : Stmt -> BExp -> Stmt -> Stmt -> Stmt
| break : Stmt
| continue : Stmt
| functie : string -> Stmt -> Stmt
| comentariu  : string -> Stmt (*sintaxa pentru comentarii*)

(*VECTORI*)
| declarare_vector_natural : string -> Stmt
| declarare_vector_boolean : string -> Stmt
| declarare_vector_string : string -> Stmt
| declarare_matrice : string -> Stmt

| initializare_vector_natural : string -> list NaturaL -> Stmt
| initializare_vector_boolean : string -> list BooleaN -> Stmt
| initializare_vector_string : string -> list StringS-> Stmt
| initializare_matrice : string -> list Vectori -> Stmt

| element: string -> nat -> Stmt

| valoareElemNatural : string -> nat -> NaturaL -> Stmt
| valoareElemBoolean : string -> nat -> BooleaN -> Stmt
| valoareElemString : string -> nat -> StringS-> Stmt
| valoareElemMatrice : string -> nat -> Vectori -> Stmt

| adaugareNatural : string -> NaturaL -> Stmt
| adaugareBoolean : string -> BooleaN -> Stmt
| adaugareString : string -> StringS -> Stmt
| adaugareMatrice : string -> Vectori -> Stmt

| eliminare : string -> Stmt.

Notation "'natural' S" := (declarareNatural S) (at level 79).
Notation "'boolean' S" := (declarareBoolean S) (at level 79).
Notation "'char' S" := (declarareString S) (at level 79).

Notation "S =nat= X" := (atribuireNatural S X) (at level 80).
Notation "S =bool= X" := (atribuireBoolean S X) (at level 80).
Notation "S =string= X" := (atribuireString S X) (at level 80).

Notation "'natural' S ::= A" := (initializareNatural S A) (at level 78).
Notation "'boolean' S [=] A" := (initializareBoolean S A) (at level 78).
Notation "'char' S [=] A" := (initializareString S A) (at level 78).

Notation "S1 ;; S2" := (secventa S1 S2 ) (at level 98, left associativity).
Notation "I ++" := (incrementare I 1) (at level 60).
Notation "D --" := (decrementare D 1) (at level 60).
Notation "'If' ( A ) 'Then' ( S1 ) 'Else' ( S2 ) 'EndIF'" := (if_then_else A S1 S2) (at level 97).
Notation "'If' ( A ) 'Then' ( S ) 'EndIF1'" := (if_then A S ) (at level 97).
Notation "'While' ( C ) # S # 'EndWhile' " := (while_do C S) (at level 97).
Notation "'For' ( S1 ';' C ';' S2 ) { S3 }  'EndF'" := (for_do S1 C S2 S3) (at level 97).

Notation "'Break'" := (break) (at level 97).
Notation "'Continue'" := (continue) (at level 97).
Notation " // A \\  " := (comentariu A) (at level 99).
Notation " 'f' ( A ) { B } " := (functie A B) (at level 90).
Notation "'switch'  'case' ( A ) ( B ) ( 'case' ( C )  ( D ) 'default' ( E ))" := (if_then_else A B (if_then_else C D E)) (at level 66).

Notation "[Is_V_Natural] V" := (declarare_vector_natural V) (at level 79).
Notation "[Is_V_Boolean] V" := (declarare_vector_boolean V) (at level 79).
Notation "[Is_V_String] V" := (declarare_vector_string V) (at level 79).
Notation "[Is_V_Matrice] V" := (declarare_matrice V) (at level 79).

Notation "[Natural] V ::= W" := (initializare_vector_natural V W) (at level 79).
Notation "[Boolean] V ::= W" := (initializare_vector_boolean V W) (at level 79).
Notation "[String] V ::= W" := (initializare_vector_string V W) (at level 79).
Notation "[[Matrice]] V ::= W" := (initializare_matrice V W) (at level 79).

Notation "V [ P ]" := (element V P)(at level 79).

Notation "V [ P ] :n= W" := (valoareElemNatural V P W) (at level 78).
Notation "V [ P ] :b= W" := (valoareElemBoolean V P W) (at level 78).
Notation "V [ P ] :s= W" := (valoareElemString V P W) (at level 78).
Notation "V [ P ] :m= W" := (valoareElemMatrice V P W) (at level 78).

Notation "pushnat( V ) X" := (adaugareNatural V X) (at level 79).
Notation "pushbool( V ) X" := (adaugareBoolean V X) (at level 79).
Notation "pushstring( V ) X" := (adaugareString V X) (at level 79).
Notation "pushmatrice( V ) X" := (adaugareMatrice V X) (at level 79).

Notation "pop ( V )" := (pop V) (at level 79).

Check ( char "c" ) .
Check( boolean "aux").
Check( natural "i").
Check ("i" =nat= 1).
Check( "i" =bool= btrue).
Check( "i" =string= "c").
Check( "i" ++).
Check( "a" --).
Check( Break).
Check( Continue).
Check(  // "acesta este un comentariu" \\ ).
Check( If ( btrue ) Then ( "i" =nat= 1 ) EndIF1 ).
Check( "s" [ 23 ] :n= 434).
Check( "s" [ 23 ] :b= TypeBool true).
Check( pushnat( "v" ) 43 ).
Check( pushbool( "v" ) TypeBool true ).
Check( pushstring( "v" ) "string" ).
Check( pop ( "v" ) ).

Definition program1 :=
boolean "is_bool";;
"is_bool" =bool= btrue ;;
"is_bool" =bool= "is_bool" &&' bfalse ;;
[Is_V_Natural] "vec";;
pushnat( "vec" ) 1 ;;
pushnat( "vec" ) 2 ;;
pop ("vec");;
pushnat( "vec" ) 3 ;;
natural "t";;
"t" =nat= 0 ;;
natural "x" ;;
"t" =nat= 4 ;;
While ( "x" <=' 1000 ) #
	"x" ++ ;;
	If ( "x" %' 3 ==' 0 ) Then ( "x" =nat= "x" +' 3 ;; "t" =nat= "t" +' 1 ) EndIF1
 # EndWhile.
Check program1.

Definition program2 :=
natural "a" ;;
natural "b" ;;
natural "c" ;; // "exemplu de comentariu" \\ ;;
"c" =nat= "a" +' "b" ;;
"c" ++ ;;
Break ;;
natural  "i" ;;
natural "p" ;;
If ( btrue ) Then ( "i" =nat= 1 ) EndIF1 .

Check program2.


Require Import List.
Import ListNotations.
Require Import Nat.

Fixpoint myNth {X : Type} (n : nat) (ls : list X) : option X :=
match ls with
| [] => None
| x::xs => match n with
           | 0 => None
           | (S m) => if eqb m 0 then Some x else myNth m xs
           end
end.

Theorem emptyList {X : Type} (n : nat) : myNth n ([] : list X) = None.
Proof.
  destruct n; auto.
Qed.

Theorem zeroNth {X : Type} (ls : list X) : myNth 0 ls = None.
Proof.
  destruct ls; auto.
Qed.

Theorem leLtN {X : Type} (ls : list X) (n : nat) :
  length ls < n -> myNth n ls = None.
Proof.
  generalize dependent n.
  induction ls; intros.
  + destruct n; auto.
  + destruct n.
    - inversion H.
    - destruct n.
      * inversion H.
        inversion H1.
      * assert (myNth (S (S n)) (a::ls) = myNth (S n) ls).
        { clear; reflexivity. }
        rewrite H0. clear H0.
        apply IHls.
        simpl in H.
        intuition.
Qed.

Theorem myNthCorrect {X : Type}: forall (ls xs ys : list X) n x,
  length (xs ++ [x]) = n -> ls = xs ++ x :: ys -> myNth n ls = Some x.
Proof.
  intro.
  induction ls; intros.
  + destruct xs; inversion H0.
  + destruct n.
    - destruct xs.
      * inversion H.
      * inversion H.
    - destruct n.
      * destruct xs.
        ++ inversion H0.
           auto.
        ++ destruct xs.
           -- inversion H.
           -- inversion H.
      * destruct xs.
        ++ inversion H.
        ++ inversion H0.
           assert (myNth (S (S n)) (x0 :: xs ++ x :: ys) = myNth (S n) (xs ++ x :: ys)).
           { clear. reflexivity. }
           rewrite H1. clear H1. rewrite <- H3.
           eapply IHls.
           -- simpl in H.
              apply eq_add_S in H.
              exact H.
           -- exact H3.
Qed.


Require Import Imp.

(** Proving the correctness of a compiler.
   Andrew W. Appel, Princeton University, December 2009.
   Minor edits, March 2011 and May 2014.
*)

(** Let's start by defining a machine language.  The compiler will only use the
   first 5 instructions, but the extra instructions don't hurt. *)

Inductive instr : Type :=
| i_move: id -> id -> instr
| i_num: nat -> id -> instr
| i_plus: id -> id -> id -> instr
| i_minus: id -> id -> id -> instr
| i_mult: id -> id -> id -> instr
| i_eq: id -> id -> id -> instr
| i_le: id -> id -> id -> instr
| i_not: id -> id -> instr
| i_and: id -> id -> id -> instr
| i_or: id -> id -> id -> instr.

(** Operational semantics for instructions. *)
Inductive exec: state -> instr -> state -> Prop :=
| exec_move: forall st i j, exec st (i_move i j) (update st j (st i))
| exec_num: forall st n i, exec st (i_num n i) (update st i n)
| exec_plus: forall st i j k, exec st (i_plus i j k) (update st k (st i + st j))
| exec_minus: forall st i j k, exec st (i_minus i j k) (update st k (st i - st j))
| exec_mult: forall st i j k, exec st (i_mult i j k) (update st k (st i * st j))
| exec_eq_true : forall st i j k, st i = st j -> exec st (i_eq i j k) (update st k 1)
| exec_eq_false : forall st i j k, st i <> st j -> exec st (i_eq i j k) (update st k 0).

Hint Constructors exec.

(** Operational semantics for lists of instructions. *)
Inductive exec_list: state -> list instr -> state -> Prop :=
| exec_nil: forall st, exec_list st nil st
| exec_cons: forall h t st st' st'', exec st h st' -> exec_list st' t st'' -> exec_list st (h::t) st''.

Hint Constructors exec_list.

(** Here's the compiler for arithmetic expressions.
      It uses variables >= N as scratch temporaries for subexpressions *)
Fixpoint compile_aexp (N: nat) (a: aexp) : list instr :=
  match a with
  | ANum n =>  i_num n (Id N) :: nil
  | AId i => i_move i (Id N) :: nil
  | APlus a1 a2 => compile_aexp N a1 ++ compile_aexp (S N) a2 ++
                               i_plus (Id N) (Id (S N)) (Id N) :: nil
  | AMinus a1 a2 => compile_aexp N a1 ++ compile_aexp (S N) a2 ++
                               i_minus (Id N) (Id (S N)) (Id N) :: nil
  | AMult a1 a2 => compile_aexp N a1 ++ compile_aexp (S N) a2 ++
                               i_mult (Id N) (Id (S N)) (Id N) :: nil
 end.

Fixpoint compile_com (N: nat) (c: com) : list instr :=
 match c with
  | CSkip => nil
  | CAss i a => compile_aexp N a ++ i_move (Id N) i :: nil
  | CSeq c1 c2 => compile_com N c1 ++ compile_com N c2
  | _ => nil
 end.

Fixpoint check_exp N (a: aexp) : Prop :=
  match a with
  | ANum n => True
  | AId (Id i) => i < N
  | APlus a1 a2 => check_exp N a1 /\ check_exp N a2
  | AMinus a1 a2 => check_exp N a1 /\ check_exp N a2
  | AMult a1 a2 => check_exp N a1 /\ check_exp N a2
 end.

Fixpoint check_com N (c: com) : Prop :=
  match c with
  | CSkip => True
  | CAss (Id i) a => i < N /\ check_exp N a
  | CSeq c1 c2 => check_com N c1 /\ check_com N c2
  | _ => False
 end.

Definition my_prog := (X ::= APlus (AId Y) (ANum 1) ;; Y ::= AMult (AId X)  (APlus (AId X) (AId Y))).

Example check_my_prog:
  check_com 10 my_prog.
Proof. simpl. intuition. Qed.

Example compile_my_prog:
   compile_com 10 my_prog =
    i_move Y (Id 10)
    :: i_num 1 (Id 11)
    :: i_plus (Id 10) (Id 11) (Id 10)
    :: i_move (Id 10) X
    :: i_move X (Id 10)
    :: i_move X (Id 11)
    :: i_move Y (Id 12)
    :: i_plus (Id 11) (Id 12) (Id 11)
    :: i_mult (Id 10) (Id 11) (Id 10)
    :: i_move (Id 10) Y
    :: nil.
Proof. reflexivity. Qed.

Example ceval_my_prog:
     my_prog / empty_state || (update (update empty_state X 1) Y 1).
Proof.
repeat (econstructor; simpl; try reflexivity).
Qed.

Example exec_my_prog:
    exists st, exec_list empty_state (compile_com 10 my_prog) st.
Proof.
econstructor.
simpl.
repeat (eapply exec_cons; [eauto|]).
apply exec_nil.
Qed.

(*EX 3 (wrong_compiler_correctness) *)
Definition wrong_compiler_correctness_specification :=
     forall c N, check_com N c ->
           forall st stx, exec_list st (compile_com N c) stx ->
                      ceval c st stx.

Theorem wrong_specification_wrong:
  ~ wrong_compiler_correctness_specification.
(* FILL IN HERE *) Admitted.
(** [] *)

Definition same_below (N: nat) (st st': state) : Prop :=
            forall i, i < N -> st (Id i) = st' (Id i).

Definition compiler_correctness_specification :=
     forall c N, check_com N c ->
           forall st stx, exec_list st (compile_com N c) stx ->
                 forall sty, ceval c st sty ->
                   same_below N stx sty.

Ltac inv H := inversion H; clear H; subst.

(** **** Exercise: 3 stars (exec_list_lemmas) *)
Lemma exec_list_app:
    forall il1 il2 st1 st2 st3,
      exec_list st1 il1 st2 -> exec_list st2 il2 st3 ->
      exec_list st1 (il1++il2) st3.
(* FILL IN HERE *) Admitted.
Hint Resolve exec_list_app.

Lemma exec_list_app_inv:
  forall il1 il2 st1 st3, exec_list st1 (il1++il2) st3 ->
  exists st2, exec_list st1 il1 st2 /\ exec_list st2 il2 st3.
(* FILL IN HERE *) Admitted.
(** [] *)

Ltac overr := rewrite update_neq;
                         [| intro Hx; inv  Hx; subst; omega].

(* The tactic [crunch] is an example of the "Adam Chlipala style"; just
  a baby example of course.  For a complete introduction to this style
  of proof automation, see,
   Certified Programming with Dependent Types
   by Adam Chlipala, MIT Press, 2013.
   http://adam.chlipala.net/cpdt/
*)

Ltac crunch :=
          intros;
          repeat
             first [rewrite update_eq
                    | overr
                    | match goal with
                        | H: False |- _ => contradiction
                        | H: _ /\ _ |- _  => destruct H
                        | H: exec_list _ (_ ++ _) _ |- _ =>
                            apply exec_list_app_inv in H; destruct H as [?st [? ?]]
                        | H: exec_list _ (_ :: _) _ |- _ => inv H
                        | H: exec_list _ nil _ |- _ => inv H
                        | H: exec _ (i_move _ _) _ |- _ => inv H
                        | H: exec _ (i_num _ _) _ |- _ => inv H
                        | H: exec _ (i_plus _ _ _) _ |- _ => inv H
                        | H: exec _ (i_minus _ _ _) _ |- _ => inv H
                        | H: exec _ (i_mult _ _ _) _ |- _ => inv H
                        | H: match ?ii with Id _ => _ end |- _ => destruct ii
                        | H: ceval _ CSkip _ |- _ => inv H
                        | H: ceval _ (CAss _ _) _  |- _=> inv H
                        end]; auto.

Lemma check_S:  forall N a, check_exp N a -> check_exp (S N) a.
Proof.
(aexp_cases (induction a) Case); simpl; crunch.
Qed.

Lemma same_below_refl: forall N st, same_below N st st.
Proof. unfold same_below; auto.
Qed.

Hint Resolve same_below_refl.

Lemma same_below_sym: forall N st st',
        same_below N st st' -> same_below N st' st.
Proof.
unfold same_below; intros. symmetry; auto.
Qed.

Lemma same_below_trans:  forall N st1 st2 st3,
        same_below N st1 st2 -> same_below N st2 st3 -> same_below N st1 st3.
Proof.
unfold same_below; intros.
rewrite H; auto.
Qed.

(** **** Exercise: 2 stars (same_below_update) *)
Lemma same_below_update:
  forall i N v v' st st',
         v = v' ->
        same_below N st st' ->
        same_below N (update st i v) (update st' i v').
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

Hint Resolve same_below_update.

(** **** Exercise: 3 stars (compile_aexp_same_below) *)
Lemma compile_aexp_same_below:
  forall a N st st', exec_list st (compile_aexp N a) st' ->
          same_below N st st'.
Proof.
unfold same_below.
(aexp_cases (induction a) Case); simpl; crunch.
(** Instructions:  First, remove "crunch" from the line above, and use
     "Focus" to examine each of the 5 subgoals.  Now, put "crunch" back,
     notice that it has already disposed of 2 subgoals and made some progress
     in the other 3, and finish the proof.
*)
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (aeval_same_below) *)
Lemma aeval_same_below:
  forall st st' a N,
   check_exp N a ->
   same_below N st st' ->
   aeval st a = aeval st' a.
Proof.
unfold same_below.
(aexp_cases (induction a) Case); simpl; crunch.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (compile_aexp_correct) *)
Theorem compile_aexp_correct:
     forall a N, check_exp N a ->
           forall st st', exec_list st (compile_aexp N a) st' ->
                    st' (Id N) = aeval st a.
Proof.
(aexp_cases (induction a) Case); simpl; crunch.
(* FILL IN HERE *) Admitted.
(** [] *)

(**  Consider an arithmetic expression [a] with no variables named N or above,
      and compile it with [compile N a].
      Now we believe that executing the compiled expression [compile N a]
      should not affect any variables below N.  That is, if [st1] and [st1'] are
      the same below N, and we can execute from [st1] to get [st2], then
      we should be able to execute from st1' to get st2'.   Not only must
     st2' exist, but it should be the same as st2, below N.

    This can be explained by a  "commutative diagram".    The solid lines
    ( st1---st1',  st1---st2) indicate sides that are given in the hypothesis.
    The dotted lines  (st1' - - - st2',  st2 - - - st2') indicate sides that
    we claim must exist.

   (Caveat: This diagram works in Lucida Sans Unicode 10, looks terrible otherwise)

      st1 ----------------------  st1'
         |              same_below                 i
         |                                                  i
         | compile                                    i compile
         |                                                  i
         |              same_below                 i
       st2 - - - - - - - - - - - - - - -  st2'

   The formal statement of this is [comple_exp_fiddle], below.
*)

(** **** Exercise: 4 stars (compile_exp_fiddle) *)
Lemma compile_exp_fiddle:
  forall a N, check_exp N a ->
          forall J st1 st1', J <= N -> same_below J st1 st1' ->
          forall st2, exec_list st1 (compile_aexp N a) st2 ->
            exists st2', exec_list st1' (compile_aexp N a) st2' /\ same_below J st2 st2'.
Proof.
(aexp_cases (induction a) Case); simpl; crunch.
(* FILL IN HERE *) Admitted.
(** [] *)

(** We have the same kind of commutative diagram for compile_com. *)

(** **** Exercise: 4 stars (compile_com_fiddle) *)
Lemma compile_com_fiddle:
  forall c N,
          check_com N c ->
          forall st1 st1', same_below N st1 st1' ->
          forall st2, exec_list st1 (compile_com N c) st2 ->
                exists st2', exec_list st1' (compile_com N c) st2' /\ same_below N st2 st2'.
Proof.
(com_cases (induction c) Case); simpl; crunch.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars (compile_com_correct) *)
Theorem compile_com_correct: compiler_correctness_specification.
Proof.
unfold compiler_correctness_specification.
(com_cases (induction c) Case); simpl; crunch.
(* FILL IN HERE *) Admitted.

(** [] *)


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

(** The syntax {param} declares the parameter [param] as implicit. In the case
of [rtc], it allows one to write [rtc R x y] instead of [rtc A R x y]. *)

(** The reflexive transitive closure of a relation A. **)
(** This signature reads: if R is a binary relation on type A, then it's
reflexive transitive closure is also a binary relation on A **)
Inductive rtc {A} (R : relation A) : relation A :=
  (** The first constructor reads: every A is in reflexive-transitive closure
  to itself, no matter what the relation actually is **)
  | rtc_refl x : rtc R x x
  (** The second constructor reads: given that x is in relation R to y and  y
  is in reflexive transitive closure to z then x is in rtc to z (one step plus
  many steps is again many steps) **)
  | rtc_l x y z : R x y -> rtc R y z -> rtc R x z.

Print rtc_ind.

(** The diamond property, in general **)
(** This definition reads: Two relations R and T together have the diamond property if:

        x
     R / \ T
      /   \
    y1     y2
      \   /
     T \ / R
        z

If x R y1 and x T y2 there exists a z such that y1 T z and y2 R z.
**)
Definition gen_dp {A} (R T : relation A) := forall x y1 y2,
  R x y1 -> T x y2 -> exists z, T y1 z /\ R y2 z.

(** To prove: the diamond property is symmetrical.  **)
Lemma gen_dp_sym {A} (R T : relation A) :
  gen_dp R T -> gen_dp T R.
Proof.
unfold gen_dp.
intro.
intro.
intro.
intro.
intro.
intro.
elim H with x y2 y1.
intro.
intro.
exists x0.
split.
elim H2.
intros.
assumption.
elim H2.
intros.
assumption.
assumption.
assumption.
Qed.

(** Relation A has the diamond property if it has the generic diamond property
with itself **)
Definition dp {A} (R : relation A) := gen_dp R R.

(** Relation A is church-rosser if it's reflexive-transitive closure has the
diamond property. **)
Definition cr {A} (R : relation A) := dp (rtc R).

Lemma rtc_reverse {A} (R : relation A) (x y : A) : R x y -> rtc R x y.
Proof.
intros.
apply (rtc_l R x y).
assumption.
apply (rtc_refl).
Qed.

(** If two relation R, T have the generic diamond property together, then the
reflexive-transitive closure of R and T have the generic diamond property.
**)
Lemma rtc_gen_dp {A} (R T : relation A) :
  gen_dp R T -> gen_dp (rtc R) T.
Proof.

unfold gen_dp.
intro.
intros x y1 y2.

intros.

elim H with x y1 y2.
intro.
intro.
Focus 2.
apply (rtc_reverse R x y1).

induction H0.
exists y2.
split.
assumption.
apply rtc_refl.

apply IHrtc.

inversion H0.
exists y2.
split.
subst y1.
assumption.
apply rtc_refl.

exists y.
split.
Focus 2.
apply (rtc_l R y2 z).

Qed.

Lemma dp_cr {A} (R : relation A) :
  dp R -> cr R.
Proof.
  (* exercise *)
Qed.

(* vim: ft=coq
*)


From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype ssrfun.

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

Module PCMDef.

Record mixin_of (T : Type) := Mixin {
    valid_op : T -> bool;
    join_op : T -> T -> T;
    unit_op : T;
    _ : commutative join_op;
    _ : associative join_op;
    _ : left_id unit_op join_op;
    _ : forall x y, valid_op (join_op x y) -> valid_op x;
    _ : valid_op unit_op
}.

Section Packing.

Structure pack_type : Type := Pack {type : Type; _ : mixin_of type}.
Local Coercion type : pack_type >-> Sortclass.
Variable cT: pack_type.
Definition pcm_struct : mixin_of cT :=
    let: Pack _ c := cT return mixin_of cT in c.

Definition valid := valid_op pcm_struct.
Definition join := join_op pcm_struct.
Definition unit := unit_op pcm_struct.

End Packing.

Module Exports.

Notation pcm := pack_type.
Notation PCMMixin := Mixin.
Notation PCM T m := (@Pack T m).

Notation "x \+ y" := (join x y) (at level 43, left associativity).
Notation valid := valid.
Notation Unit := unit.

Coercion type : pack_type >-> Sortclass.

Section PCMLemmas.
Variable U : pcm.

Lemma joinC (x y : U) : x \+ y = y \+ x.
Proof.
by case: U x y=> tp [v j z Cj *]; apply Cj.
Qed.

Lemma joinA (x y z : U) : x \+ (y \+ z) = x \+ y \+ z.
Proof.
by case: U x y z=>tp [v j z Cj Aj *]; apply: Aj.
Qed.

(*******************************************************************)
(**                     * Exercices 1 *                            *)
(*******************************************************************)

(**
---------------------------------------------------------------------
Exercise [PCM Laws]
---------------------------------------------------------------------

Proove the rest of the PCM laws.
*)

Lemma joinAC (x y z : U) : x \+ y \+ z = x \+ z \+ y.
Proof. by rewrite -joinA (joinC y) joinA. Qed.

Lemma joinCA (x y z : U) : x \+ (y \+ z) = y \+ (x \+ z).
Proof. by rewrite joinA (joinC x) -joinA. Qed.

Lemma validL (x y : U) : valid (x \+ y) -> valid x.
Proof.
case: U x y=>tp [v j z Cj Aj Uj /= Mj inv f].
by apply: Mj.
Qed.

Lemma validR (x y : U) : valid (x \+ y) -> valid y.
Proof. by rewrite joinC; apply: validL. Qed.

Lemma unitL (x : U) : (@Unit U) \+ x = x.
Proof. by case: U x=>tp [v j z Cj Aj Uj *]; apply: Uj. Qed.

Lemma unitR (x : U) : x \+ (@Unit U) = x.
Proof. by rewrite joinC unitL. Qed.

Lemma valid_unit : valid (@Unit U).
Proof. by case: U=>tp [v j z Cj Aj Uj Vm Vu *]. Qed.

(*******************************************************************)
(**                 * End of Exercices 1 *                         *)
(*******************************************************************)

End PCMLemmas.

End Exports.

End PCMDef.

Export PCMDef.Exports.

(*******************************************************************)
(**                     * Exercices 2 *                            *)
(*******************************************************************)

(**
---------------------------------------------------------------------
Exercise [Partially-ordered sets]
---------------------------------------------------------------------

A partially ordered set order is a triple (T, \pre, \bot), such that T
is a carrier set, \pre is a relation on T and \bot is an element of T,
such that

- forall x in T, \bot \pre x (\bot is a bottom element);

- forall x in T, x \pre x (reflexivity);

- forall x, y in T, x \pre y \wedge y \pre x \implies x = y (antisymmetry);

- forall x, y, z in T, x \pre y \wedge y \pre z \implies x \pre z (transitivity).

Implement a data structure for partially-ordered sets using mixins and
packed classes. Prove the following laws:

Lemma botP (x : T) : bot <== x.
Lemma poset_refl (x : T) : x <== x.
Lemma poset_asym (x y : T) : x <== y -> y <== x -> x = y.
Lemma poset_trans (y x z : T) : x <== y -> y <== z -> x <== z.

*)

Module Poset.
Section RawMixin.

Record mixin_of (T : Type) := Mixin {
  mx_leq : T -> T -> Prop;
  _ : forall x, mx_leq x x;
  _ : forall x y, mx_leq x y -> mx_leq y x -> x = y;
  _ : forall x y z, mx_leq x y -> mx_leq y z -> mx_leq x z}.

End RawMixin.
Section ClassDef.

Record class_of T := Class {mixin : mixin_of T}.

Structure pack_type : Type := Pack {sort : Type; _ : mixin_of sort}.
Local Coercion sort : pack_type >-> Sortclass.

Variables (cT : pack_type).
Definition poset_struct := let: Pack _ c := cT return mixin_of cT in c.

Definition leq := mx_leq poset_struct.

End ClassDef.

Module Exports.
Coercion sort : pack_type >-> Sortclass.
Notation poset := pack_type.
Notation PosetMixin := Mixin.
Notation Poset T m := (@Pack T m).

Notation "x <== y" := (Poset.leq x y) (at level 70).

Section Laws.
Variable T : poset.

Lemma poset_refl (x : T) : x <== x.
Proof. by case: T x=>S [leq B R]. Qed.

Lemma poset_asym (x y : T) : x <== y -> y <== x -> x = y.
Proof. by case: T x y=>S [l R A Tr] *; apply: (A). Qed.

Lemma poset_trans (y x z : T) : x <== y -> y <== z -> x <== z.
Proof. by case: T y x z=>S [l R A Tr] ? x y z; apply: (Tr). Qed.
End Laws.
End Exports.
End Poset.

Export Poset.Exports.

(**
---------------------------------------------------------------------
Exercise [Canonical instances of partially ordered sets]
---------------------------------------------------------------------

Provide canonical instances of partially ordered sets for the
following types:

- [nat] and [<=];

- [prod], whose components are posets;

- functions [A -> B], whose codomain (range) [B] is a partially
  ordered set.

In order to provide a canonical instance for functions, you will need
to assume and make use of the following axiom of functional
extensionality:

*)

Section NatPoset.
Lemma nat_refl x : x <= x. Proof. by []. Qed.

Lemma nat_asym x y : x <= y -> y <= x -> x = y.
Proof. by move=>H1 H2; apply: anti_leq; rewrite H1 H2. Qed.

Lemma nat_trans x y z : x <= y -> y <= z -> x <= z.
Proof. by apply: leq_trans. Qed.

Definition natPosetMixin := PosetMixin nat_refl nat_asym nat_trans.
Canonical natPoset := Eval hnf in Poset nat natPosetMixin.
End NatPoset.

Section PairPoset.
Variable (A B : poset).
Local Notation tp := (A * B)%type.

Definition pair_leq (p1 p2 : tp) := p1.1 <== p2.1 /\ p1.2 <== p2.2.

Lemma pair_refl x : pair_leq x x.
Proof. by split; apply: poset_refl. Qed.

Lemma pair_asym x y : pair_leq x y -> pair_leq y x -> x = y.
Proof.
move: x y=>[x1 x2][y1 y2][/= H1 H2][/= H3 H4].
by congr (_, _); apply: poset_asym.
Qed.

Lemma pair_trans x y z : pair_leq x y -> pair_leq y z -> pair_leq x z.
Proof.
move: x y z=>[x1 x2][y1 y2][z1 z2][/= H1 H2][/= H3 H4]; split=>/=.
- by apply: poset_trans H3.
by apply: poset_trans H4.
Qed.

Definition pairPosetMixin :=
  PosetMixin pair_refl pair_asym pair_trans.
Canonical pairPoset := Eval hnf in Poset tp pairPosetMixin.

End PairPoset.

Axiom fext : forall A (B : A -> Type) (f1 f2 : forall x, B x),
               (forall x, f1 x = f2 x) -> f1 = f2.

Section FunPoset.
Variable (A : Type) (B : poset).
Local Notation tp := (A -> B).

Definition fun_leq (p1 p2 : tp) := forall x, p1 x <== p2 x.

Lemma fun_refl x : fun_leq x x.
Proof. by move=>z; apply: poset_refl. Qed.

Lemma fun_asym x y : fun_leq x y -> fun_leq y x -> x = y.
Proof.
move=>H1 H2. apply: fext=>z;
by apply: poset_asym; [apply: H1 | apply: H2].
Qed.

Lemma fun_trans x y z : fun_leq x y -> fun_leq y z -> fun_leq x z.
Proof. by move=>H1 H2 t; apply: poset_trans (H2 t). Qed.

Definition funPosetMixin := PosetMixin fun_refl fun_asym fun_trans.
Canonical funPoset := Eval hnf in Poset tp funPosetMixin.

End FunPoset.

(*******************************************************************)
(**                 * End of Exercices 2 *                         *)
(*******************************************************************)


From MyCoq.Lib Require Export Nat.

Inductive natprod : Type :=
| pair (n_1 n_2 : nat).

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


(* TP2 Langages formels

   LISEZ BIEN TOUT CE QUI EST PRÉCISÉ EN COMMENTAIRES

   Décommentez les 'Example' pour vérifier que vos fonctions fonctionnent correctement

*)

(******************************************************************************)
(********** programmation fonctionnelle et automates en Coq (partie 1) ********)
(******************************************************************************)

(* L'objectif de LIFLF-TP2 est de définir tout ce dont on a besoin pour définir
   des automates et de les faire s'exécuter dans la partie *programme* de Coq.

   Les composants dont on aura besoin pour les automates :
    - On va définir le type "Alphabet" avec une fonction qui teste l'égalité
    - On va utiliser le type prédéfini "option" pour représenter les fonctions partielles
    - On va utiliser le type prédéfini "prod A B" des paires
    - On va définir la recherche dans une liste d'entiers et dans une liste de paires

   Le quintuplet usuel M = <K, Sigma, delta : K*Sigma -> K, s, F> sera défini en coq
   dans le TP3.
*)

(******************************************************************************)
(* L'alphabet et son égalité calculable *)
(******************************************************************************)

(* On définit un petit alphabet d'exemple : c'est juste une énumération, représentée
   en Coq par un type inductif avec 2 constructeurs sans argument (des constantes). *)
Inductive Alphabet : Type :=
| a : Alphabet
| b : Alphabet.

(* Ici, Alphabet est 'le plus petit ensemble qui contient a, b et rien d'autre', donc
   intuitivement, Alphabet est l'ensemble {a,b} *)

(* EXERCICE *)
(* Définir une fonction comp_alphabet qui teste si deux éléments de l'alphabet sont égaux
   et énoncer son théorème de correction *)
Definition comp_alphabet (x : Alphabet)  (y : Alphabet) : bool :=
match (x, y) with
| (a, a) => true
| (b, b) => true
|_ => false
end.

(* On attend "false" comme résultat *)
Compute (comp_alphabet a b).

(* On peut aussi écrire les exemples précédents comme des tests unitaires

   EXEMPLES À DÉCOMMENTER

   Ici, la 'preuve' est obtenue par calcul :
     - "cbv" (call by value) effectue le calcul
     - la tactique "reflexivity" finit le job. *)
(*
Example comp_alphabet_ex1 : comp_alphabet a a = true.
Proof.
cbv.         (* on effectue le calcul *)
reflexivity. (* c'est bien l'axiome du prédicat d'égalité *)
Qed.

Example comp_alphabet_ex2 : comp_alphabet a b = false.
Proof.
cbv.
reflexivity.
Qed.
*)

(* Le travail de définition d'une fonction déterminant l'égalité qui a été fait
   sur Alphabet existe bien sûr pour les "nat". *)

(* Les entiers *)
Require Import Nat.
Print nat.

(* La fonction qui teste l'égalité de deux entiers. *)
Check Nat.eqb : nat -> nat -> bool.
Print Nat.eqb.

(******************************************************************************)
(* Le type prédéfini "option A" *)
(******************************************************************************)

(* Pour un type A, le type "option A" est
   - Soit un élément de A,
   - Soit rien.
*)

(* tout d'abord la définition (NE PAS DÉCOMMENTER, c'est un type prédéfini) :
   Inductive option (A : Type) : Type :=
     | Some : A -> option A
     | None : option A
*)

Print option.

(* EXERCICE *)
(* Définir une fonction comp_option_nat qui teste si deux "option nat" sont égaux.
   Par convention, comparer 'rien' et 'rien' renverra vrai.
   Comparer 'rien' et 'qqchose' renverra forcément faux.
   Pour le dernier cas, comparer deux 'qqchose' renverra la comparaison effective de ces deux qqchose.
   Vérifier les tests unitaires et énoncer le théorème de correction associé *)
Definition comp_option_nat (x : option nat) (y : option nat) : bool :=
match (x, y) with
| (None, None) => true
| (None, Some m) => false
| (Some m, None) => false
| (Some m, Some n) => Nat.eqb m n
end.

Theorem comp_option_nat_correct : forall (x : option nat), forall (y : option nat), comp_option_nat x y =true -> x=y.
Proof.
Admitted.

(* Tests unitaires avec reflexivity *)

Example comp_option_nat_ex1 : comp_option_nat (Some 1) (Some 2) = false.
Proof.
cbv. reflexivity.
Qed.

Example comp_option_nat_ex2 : comp_option_nat (Some 2) (Some 2) = true.
Proof.
cbv. reflexivity.
Qed.

Example comp_option_nat_ex3 : comp_option_nat (None) (Some 2) = false.
Proof.
cbv. reflexivity.
Qed.

Example comp_option_nat_ex4 : comp_option_nat (Some 2) (None) = false.
Proof.
cbv. reflexivity.
Qed.

(******************************************************************************)
(* Le type prédéfini produit de A et B "prod A B" *)
(******************************************************************************)

(* Le type 'produit de A et B' est défini par "prod A B" dans la bibliothèque Coq
   (NE PAS DECOMMENTER)

   Inductive prod (A B : Type) : Type :=
     pair : A -> B -> A * B

   En Coq, on écrit "A * B" au lieu de  "prod A B" (c'est juste une notation)
*)
Print prod.

(* Ce type n'a qu'un seul constructeur "pair" qui prend deux arguments : (x:A) et (y:B)
   Prod A B est donc 'le plus petit ensemble qui contient tous les éléments
   de la forme "pair x y" (avec x dans A et y dans B) et rien d'autre'
   donc intuitivement, Prod A B est le produit cartésien de A et B, qui contient
   toutes les paires (x,y) (et rien d'autres).
*)

(* EXERCICE *)
(* Définir les fonctions "fsta" et "snda" de projection sur les couples d'éléments
   de type Alphabet avec "match" : p:A*B correspond au motif (x,y) où x est de type A et
   y de type B *)

Definition fsta (p : Alphabet*Alphabet) : Alphabet :=
match p with
|(x, y) => x
end.

Definition snda (p : Alphabet*Alphabet) : Alphabet :=
match p with
|(x, y) => y
end.

Example fsta_ex1 : (fsta (a,b)) = a.
Proof.
  cbv. reflexivity.
Qed.

Example snda_ex1 : (snda (a,b)) = b.
Proof.
  cbv. reflexivity.
Qed.

(* On peut ré-écrire comp_alphabet en utilisant le pattern matching
   sur la paire (x,y). Attention il y a un "let" caché dans cette
   façon de faire (donc on évitera).  On remarque aussi l'utilisation
   de "_" le joker pour les arguments génériques. *)
Definition comp_alphabet' (x y : Alphabet) : bool :=
  match (x,y) with
  | (a,a) => true
  | (b,b) => true
  | (_,_) => false (* pour tous les autres cas *)
end.

Print comp_alphabet'.

Example comp_alphabet'_ex1 : (comp_alphabet' a a) = true.
Proof.
  cbv. reflexivity.
Qed.

(* EXERCICE *)
(* Définir la fonction comp_pair_nat qui compare deux paires d'entiers.
   L'égalité sur les nat est "Nat.eqb" et le connecteur et sur les bool est "andb". *)
Definition comp_pair_nat (p1 : nat*nat) (p2 : nat*nat) : bool :=
match (p1,p2) with
| ((x, y),(x', y')) => andb (Nat.eqb x x') (Nat.eqb y y')
end.

(* Tests unitaires avec reflexivity *)

Example comp_pair_nat_ex1 : comp_pair_nat (0,1) (0,0) = false.
Proof.
cbv.
reflexivity.
Qed.
Example comp_pair_nat_ex2 : comp_pair_nat (0,1) (0,1) = true.
Proof.
reflexivity.
Qed.

(* EXERCICE *)
(* Définir une fonction swap qui à la paire d'entiers (a,b) fait correspondre (b,a) *)
Definition swap (p : nat*nat) : nat*nat :=
match p with
|(x, y) => (y,x)
end.

Example swap_ex1 : swap (1,2) = (2,1).
Proof.
  cbv. reflexivity.
Qed.

(******************************************************************************)
(* Recherche dans les listes d'entier  *)
(******************************************************************************)

(* On rappelle ici la définition des listes natives : on aurait pu
   tout faire avec les listes définies dans les TP précédents, comme
   avec nos entiers, mais c'est réinventer la roue

   NE PAS DECOMMENTER

   Inductive list (A : Type) : Type :=
   | nil : list A
   | cons : A -> list A -> list A
*)
Require Export List.
Import ListNotations.

(* à partir d'ici on a
    - []   : la liste vide
    - n::l : le constructeur d'ajout de n en tête de l
    - ++   : la fonction de concaténation en position infixe *)
Print list.

(* EXERCICE *)
(* Définir la fonction "concatene" qui prend en paramètres deux listes d'entiers
   (donc de type "list nat") et renvoie la concaténation de ces deux listes *)
Fixpoint concatene (l1 : list nat) (l2 : list nat) : list nat :=
match l1 with
| nil => l2
| cons x l => cons x (concatene l l2)
end.

Example concatene_ex1 : concatene [1;2;3] [4;5] = [1;2;3;4;5].
Proof.
cbv. reflexivity.
Qed.

(* EXERCICE *)
(* Définir la fonction "appartient" qui prend en paramètres un entier
   n et une liste d'entiers (donc de type "list nat") et renvoie true
   si et seulement si n est dans la liste *)
Fixpoint appartient (n : nat) (l : list nat) : bool :=
match l with
| nil => false
| cons x l1 => match eqb n x with
               | true => true
               | false => appartient n l1
               end
end.

(* Tests unitaires avec reflexivity *)

Example appartient_ex1 : appartient 0 [1;3;0;5] = true.
Proof.
cbv. reflexivity.
Qed.

Example appartient_ex2 : appartient 4 [1;3;0;5] = false.
Proof.
cbv. reflexivity.
Qed.

(******************************************************************************)
(* Recherche dans les listes de paires *)
(******************************************************************************)

(* on peut représenter un dictionnaire comme une liste de paire (clef, valeur) *)

(* La principale fonctionnalité que l'on attend d'un dictionnaire est de pouvoir retrouver
   la valeur associée à une clef. Si plusieurs valeurs sont associées, alors on retourne
   la première qu'on trouve.

   On comprend bien que rien ne garantit qu'on trouve toujours une valeur, donc le type
   de retour de cette fonction est de type "option valeur"
*)

(* EXERCICE *)
(* Définir la fonction "trouve" qui prend en paramètres
    - une listes de paires (clef,valeur)
    - une clef k
   et renvoie la première valeur associée à k quand elle existe et None sinon.
   Les clés seront des Alphabet, les valeurs des nat.
*)
Fixpoint trouve (l : list (Alphabet*nat)) (x : Alphabet) : option nat :=
match l with
| nil => None
| cons (y, n) l1 => match comp_alphabet x y with
                    | true => Some n
                    | false => trouve l1 x
                    end
end.

(* Tests unitaires avec reflexivity *)

Example trouve_ex1 :  trouve [(a,1); (b,2)] a = Some 1.
Proof.
cbv. reflexivity.
Qed.
Example trouve_ex2 :  trouve [(a,2); (a,1)] a = Some 2.
Proof.
cbv. reflexivity.
Qed.
Example trouve_ex3 :  trouve [(a,2); (a,1)] b = None.
Proof.
cbv. reflexivity.
Qed.

(* FIN DU TP2 *)

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

(* EXERCICES A FAIRE CHEZ VOUS *)

(* EXERCICE *)
(* On va montrer que (comp_alphabet x y) = true si et seulement si (x = y).
   Autrement dit, comp_alphabet *décide* l'égalité entre deux éléments de alphabet.
   On va utiliser pour cela les tactiques vues dans les TP précédents
   - intros [Id1] [Id2] ...
   - destruct [Hypothèse]
   - discriminate
   - reflexivity
   - cbv (in [Hypothèse])
   - apply [Théorème] (in [Hypothèse])
   - rewrite [Théorème d'égalité] (in [Hypothèse])

   On peut décomposer la preuve :
   - prouver comp_alphabet_correct : si comp_alphabet x y = true alors x = y
   - prouver comp_alphabet_complet : si x = y alors comp_alphabet x y = true
*)

Theorem comp_alphabet_correct : forall (x : Alphabet), forall (y : Alphabet), comp_alphabet x y = true -> x=y.
Proof.
intro h0.
intro h1.
intro h2.
(* EXERCICE *)
(* Enoncer et prouver la propriété que comparer un symbole de l'alphabet avec lui-même renvoie vrai.
   HINT : "comp_alphabet_complet" fait exactement ce dont on a besoin, on peut donc l'utiliser *)

(* EXERCICE *)
(* Compléter la preuve suivante
   HINT : "destruct x", "left" ou "right" pour "\/" *)
Lemma alphabet_a_juste_deux_elements : forall x:Alphabet, x = a \/ x = b.
Proof.
Admitted.

(* EXERCICE *)
(* Enoncer et prouver la propriété que la fonction "comp_option_nat" est correcte et complète *)
(* HINT : si la tactique "cbv" ne calcule pas 'assez', remplacez le
   nom de fonction par sa valeur avec "unfold", comme par exemple avec le
   "unfold not" qui remplace "~A" par "A -> False". *)

(* EXERCICE *)
(* Prouver le lemme suivant *)
Lemma projection_product (A B : Type) : forall p:A*B, p = (fst p, snd p).
Proof.
Admitted.

(* EXERCICE *)
(* Prouver que "swap" est involutive.
   Rappel. Une fonction f est une involution ssi quel que soit x, f(f(x)) = x
   HINT : pour p:A*B une paire, utiliser "destruct p" pour retrouver "(a,b)"
*)

(* EXERCICE *)
(* Enoncer et prouver la propriété que la fonction "comp_pair_nat" est correcte
   HINT : utiliser "Bool.andb_true_iff"
   Bool.andb_true_iff : forall b1 b2 : bool, (b1 && b2)%bool = true <-> b1 = true /\ b2 = true
   Ce théorème lie le *ET* des booléens, la fonction "andb" en Coq (qui se note aussi "&&")
   et le *ET* logique, noté "/\" en Coq (qui se note aussi "and" )
*)
Check Bool.andb_true_iff.
Check PeanoNat.Nat.eqb_eq.

(* EXERCICE *)
(* Enoncer et prouver la propriété que l'appartenance d'un élément à une liste vide
   est fausse *)

(* EXERCICE *)
(* Enoncer et prouver la propriété que l'appartenance d'un élément à une liste singleton
   est vraie SSI l'élément recherché et celui du singleton sont égaux
   On utilisera les théorèmes suivants
   "Bool.orb_false_r : forall b : bool, (b || false)%bool = b"
   "PeanoNat.Nat.eqb_eq : forall n m : nat, PeanoNat.Nat.eqb n m = true <-> n = m"
*)

(* EXERCICE *)
(* Énoncer et prouver le lemme de correction de "appartient"
   nommé "appartient_correct" qui dit en langue naturelle :
   (appartient x ls) est vrai SI ET SEULEMENT SI il existe une décomposition
   de ls de la forme ls = l1 ++ x :: l2.

   NOTA BENE : c'est assez ambitieux à prouver à ce stade.
*)

(* EXERCICE *)
(* Enoncer et prouver la propriété "trouve_tete" qui, pour toute liste l,
   toute clé k et toute valeur v, trouve ((k,v)::l) k = Some v.

   HINT : vous pouvez ajouter une nouvelle assertion dans le contexte avec
   la tactique "assert H", un nouveau sous-but demandant de prouver "H"
   est alors ajouté
*)

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