(**************************************
  not Finish reading, not Finish exercise
**************************************)

Require Import Coq.Setoids.Setoid List Nat.
Import ListNotations.

(** **** Exercise: 2 stars (and_exercise)  *)
Example and_exercise: forall n m: nat, n + m = 0 -> n = 0 /\ m = 0.
Proof.
  intros n m P.
  split.
  - destruct n.
    + reflexivity.
    + inversion P.
  - destruct n.
    + simpl in P.
      rewrite P.
      reflexivity.
    + inversion P.
Qed.

(** **** Exercise: 1 star, optional (proj2)  *)
Lemma proj2: forall P Q: Prop, P /\ Q -> Q.
Proof.
  intros P Q [H1 H2].
  apply H2.
Qed.

(** **** Exercise: 2 stars (and_assoc)  *)
Theorem and_assoc: forall P Q R: Prop, P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R [HP [HQ HR]].
  split.
  - split.
    apply HP.
    apply HQ.
  - apply HR.
Qed.

(** **** Exercise: 1 star (mult_eq_0)  *)
Lemma mult_eq_0: forall n m, n * m = 0 -> n = 0 \/ m = 0.
Proof.
  intros [|n] [|m] P.
  - left. reflexivity.
  - left. reflexivity.
  - right. reflexivity.
  - inversion P.
Qed.

(** **** Exercise: 1 star (or_commut)  *)
Theorem or_commut: forall P Q: Prop, P \/ Q  -> Q \/ P.
Proof.
  intros P Q [HP|HQ].
  - right.
    apply HP.
  - left.
    apply HQ.
Qed.

(** **** Exercise: 2 stars, optional (not_implies_our_not)  *)
Fact not_implies_our_not: forall (P: Prop),~P -> (forall (Q: Prop), P -> Q).
Proof.
  intros P nP Q xP.
  destruct nP.
  apply xP.
Qed.

(** **** Exercise: 2 stars, advanced, recommended (double_neg_inf)  *)
(* not do it *)

(** **** Exercise: 2 stars, recommended (contrapositive)  *)
Theorem contrapositive: forall P Q: Prop, (P -> Q) -> (~Q -> ~P).
Proof.
  unfold not.
  intros P Q H1 H2 H3.
  apply H1 in H3.
  apply H2 in H3.
  apply H3.
Qed.

(** **** Exercise: 1 star (not_both_true_and_false)  *)
Theorem not_both_true_and_false: forall P: Prop, ~ (P /\ ~P).
Proof.
  intros P.
  unfold not.
  intros H.
  destruct H as [H1 H2].
  apply H2 in H1.
  apply H1.
Qed.

(** **** Exercise: 1 star, advanced (informal_not_PNP)  *)
(* not do it *)

(** **** Exercise: 1 star, optional (iff_properties)  *)
Theorem iff_refl: forall P: Prop, P <-> P.
Proof.
  intros P.
  split.
  - intros.
    apply H.
  - intros.
    apply H.
Qed.

Theorem iff_trans: forall P Q R: Prop,
  (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
  intros P Q R [H1 H2] [H3 H4].
  split.
  - intros.
    apply H3.
    apply H1.
    apply H.
  - intros.
    apply H2.
    apply H4.
    apply H.
Qed.

(** **** Exercise: 3 stars (or_distributes_over_and)  *)
Theorem or_distributes_over_and: forall P Q R: Prop,
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R.
  split.
  - intros [H1 | H2].
    + split.
      * left. assumption.
      * left. assumption.
    + assert (Q). { apply proj1 in H2. assumption. }
      assert (R). { apply proj2 in H2. assumption. }
      split.
      * right. assumption.
      * right. assumption.
  - intros [[H1|H2] [H3|H4]].
    + left. apply H1.
    + left. apply H1.
    + left. apply H3.
    + right. split. assumption. assumption.
Qed.

(** **** Exercise: 1 star (dist_not_exists)  *)
Theorem dist_not_exists: forall (X: Type)(P: X -> Prop),
  (forall x, P x) -> ~ (exists x, ~ P x).
Proof.
  unfold not.
  intros X P S [x].
  apply H.
  apply S.
Qed.

(** **** Exercise: 2 stars (dist_exists_or)  *)
Theorem dist_exists_or: forall (X: Type) (P Q: X -> Prop),
  (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
  intros X P Q.
  split.
  - intros [x0 [H1|H2]].
    + left. exists x0. assumption.
    + right. exists x0. assumption.
  - intros [[x0 H] | [x0 H]].
    + exists x0. left. assumption.
    + exists x0. right. assumption.
Qed.

Fixpoint In {A: Type}(x: A)(l: list A): Prop :=
  match l with
  | [] => False
  | x' :: l' => x' = x \/ In x l'
  end.

(** **** Exercise: 2 stars (In_map_iff)  *)
Lemma In_map_iff:
  forall (A B: Type)(f: A -> B)(l: list A)(y: B),
    In y (map f l) <->
    exists x, f x = y /\ In x l.
Proof.
  intros A B f l y.
  split.
  - intros H.
    induction l as [|a l R].
    + simpl in H.
      destruct H.
    + simpl.
      simpl in H.
      destruct H as [H|H].
      * exists a.
        split.
        apply H.
        left. reflexivity.
      * apply R in H.
        destruct H as [x0 H].
        exists x0.
        destruct H as [H0 H1].
        split.
        apply H0.
        right.
        apply H1.
  - intros [x [H P]].
    induction l as [|a l R].
    + destruct P.
    + simpl.
      simpl in P.
      destruct P as [P|P].
      * left.
        subst.
        reflexivity.
      * right.
        apply R in P.
        apply P.
Qed.

(** **** Exercise: 2 stars (in_app_iff)  *)
Lemma in_app_iff: forall A l l' (a: A),
  In a (l++l') <-> In a l \/ In a l'.
Proof.
  intros A l l' a.
  split.
  - induction l as [|x l H].
    + simpl.
      intros P.
      right.
      apply P.
    + simpl.
      intros P.
      destruct P as [P|P].
      * left.
        left.
        apply P.
      * apply H in P.
        destruct P as [P|P].
        left.
        right.
        apply P.
        right.
        apply P.
  - intros [H|H].
    + induction l as [|x l P].
      * destruct H.
      * simpl.
        simpl in H.
        destruct H as [H|H].
        left. apply H.
        right. apply P in H. apply H.
    + induction l as [|x l P].
      * simpl.
        apply H.
      * simpl.
        right.
        apply P.
Qed.

(** **** Exercise: 3 stars (All)  *)

Fixpoint All {T: Type}(P: T -> Prop)(l: list T): Prop :=
  match l with
  | nil => True
  | h :: t => P h /\ All P t
  end.

Lemma All_In:
  forall T (P: T -> Prop)(l: list T), (forall x, In x l -> P x) <-> All P l.
Proof.
  intros T P l.
  split.
  - intros H.
    induction l as [|t l Q].
    + simpl.
      apply I.
    + simpl.
      simpl in H.
      split.
      * apply H.
        left.
        reflexivity.
      * apply Q.
        intros y R.
        apply H.
        right.
        apply R.
  - intros H x R.
    induction l as [|t l Q].
    + simpl in R.
      destruct R.
    + simpl in H.
      simpl in R.
      destruct R.
      * subst.
        destruct H as [H0 H1].
        apply H0.
      * apply Q.
        destruct H.
        apply H1.
        apply H0.
Qed.

(** **** Exercise: 3 stars (combine_odd_even)  *)
Definition combine_odd_even_imp (Podd Peven: nat -> Prop)(n: nat): Prop :=
  if odd n then Podd n else Peven n.

Definition combine_odd_even (Podd Peven: nat -> Prop): nat -> Prop :=
  combine_odd_even_imp Podd Peven.

(** To test your definition, prove the following facts: *)

Theorem combine_odd_even_intro:
  forall (Podd Peven: nat -> Prop)(n: nat),
    (odd n = true -> Podd n) ->
    (odd n = false -> Peven n) ->
    combine_odd_even Podd Peven n.
Proof.
  intros Podd Peven n H P.
  unfold combine_odd_even.
  unfold combine_odd_even_imp.
  destruct (odd n).
  - apply H.
    reflexivity.
  - apply P.
    reflexivity.
Qed.

Theorem combine_odd_even_elim_odd:
  forall (Podd Peven: nat -> Prop)(n: nat),
    combine_odd_even Podd Peven n ->
    odd n = true ->
    Podd n.
Proof.
  intros Podd Peven n H P.
  unfold combine_odd_even in H.
  unfold combine_odd_even_imp in H.
  destruct (odd n).
  - apply H.
  - inversion P.
Qed.

Theorem combine_odd_even_elim_even:
  forall (Podd Peven: nat -> Prop)(n: nat),
    combine_odd_even Podd Peven n ->
    odd n = false ->
    Peven n.
Proof.
  intros Podd Peven n P Q.
  unfold combine_odd_even in P.
  unfold combine_odd_even_imp in P.
  destruct (odd n).
  - inversion Q.
  - apply P.
Qed.

(** **** Exercise: 4 stars (tr_rev)  *)
Axiom functional_extensionality: forall {X Y: Type}{f g: X -> Y},
  (forall (x: X), f x = g x) -> f = g.

Fixpoint rev_append {X}(l1 l2: list X): list X :=
  match l1 with
  | [] => l2
  | x :: l1' => rev_append l1' (x :: l2)
  end.

Definition tr_rev {X}(l: list X): list X := rev_append l [].

Lemma xyz: forall (X: Type)(l1 l2: list X), rev_append l1 l2 = rev_append l1 [] ++ l2.
Proof.
  intros X l1 l2.
  induction l1 as [|x l H].
  - reflexivity.
  - simpl.
    induction l2 as [|y l2 H2].
    + rewrite app_nil_r.
      reflexivity.
    + simpl.
Admitted.

Lemma tr_rev_correct: forall X, @tr_rev X = @rev X.
Proof.
  intros X.
  apply functional_extensionality.
  intros l.
  induction l as [|x l H].
  - reflexivity.
  - simpl.
    rewrite <- H.
    unfold tr_rev.
    simpl.
    clear H.
    generalize dependent x.
    induction l as [|y l P].
    + reflexivity.
    + simpl.
      intros x.
      rewrite P.
      simpl.
Admitted.

(** **** Exercise: 3 stars (evenb_double_conv)  *)
Theorem evenb_S: forall n: nat, even (S n) = negb (even n).
Proof. Admitted.

Theorem double_negb: forall b: bool, negb (negb b) = b.
Proof. Admitted.

Theorem evenb_double_conv: forall n,
  exists k, n = if even n then double k
                else S (double k).
Proof.
  intros n.
  induction n as [|n [k0 H]].
  - simpl.
    exists 0.
    reflexivity.
  - simpl.
    destruct (even n) eqn:P.
    + exists k0.
      rewrite <- H.
      simpl.
      destruct n.
      * reflexivity.
      * rewrite evenb_S in P.
        destruct (even n).
        simpl in P.
        inversion P.
        reflexivity.
    + exists (k0+1).
      unfold double.
      unfold double in H.
      destruct n.
      * inversion H.
      * rewrite evenb_S in P.
        destruct (even n).
        rewrite H.
Admitted. (* use omega? *)


Require Import Relations.
Section Sequences.
 Variable A : Type.

 Variable R : A -> A -> Prop.

 Lemma not_acc : forall a b:A, R a b -> ~ Acc R a -> ~ Acc R b.
 Proof.
  intros a b H H0 H1;  absurd (Acc R a); auto.
  generalize a H; now induction H1.
 Qed.

 Lemma acc_imp : forall a b:A, R a b -> Acc R b -> Acc R a.
 Proof.
  intros a b H H0;  generalize a H; now induction H0.
 Qed.

 Hypothesis W : well_founded R.
 #[local] Hint Resolve W : core.

 Section seq_intro.
  Variable seq : nat -> A.

  Let is_in_seq (x:A) :=  exists i : nat, x = seq i.

  Lemma not_decreasing_aux : ~ (forall n:nat, R (seq (S n)) (seq n)).
  Proof.
   unfold not in |- *; intro Hseq.
  assert  (H : forall a:A, is_in_seq a -> ~ Acc R a).
  -   intro a; pattern a in |- *; apply well_founded_ind with A R; auto.
      intros x Hx [i Hi]; generalize (Hseq i); intro H0; rewrite Hi.
      apply not_acc with (seq (S i)); auto.
      apply Hx.
      +  rewrite Hi; auto.
      +  exists (S i); auto.
  - apply (H (seq 0)).
    +  exists 0; trivial.
    + apply W.
 Qed.

 End seq_intro.

 Theorem not_decreasing :
  ~ (exists seq : nat -> A, (forall i:nat, R (seq (S i)) (seq i))).
 Proof.
   intros [s Hs];  now apply (not_decreasing_aux s).
 Qed.

End Sequences.


Require Export ct04.

Section DivConq.

Variable A : Type.
Implicit Type l : list A.

(* div_conq_pair:
 * - works similar to induction (i.e. list_rect), but instead of cutting just
 *   head of the list in each recursive step, this induction principle cut two
 *   heads of the list in each recursive step.
 * - To prove some proposition P holds for all lists ls, one needs to prove the
 *   following:
 *   1. P holds for empty list, nil.
 *   2. P holds for one-element list, (a :: nil).
 *   3. P holds for two-elements list, (a1 :: a2 :: nil).
 *   4. If P hold (a1 :: a2 :: nil) and l, then P must also hold for
 *      (a1 :: a2 :: l).
 *)

Lemma div_conq_pair : forall (P : list A -> Type),
    P nil -> (forall (a : A), P (a :: nil))
    -> (forall (a1 a2 : A), P (a1 :: a2 :: nil))
    -> (forall (a1 a2 : A) (l : list A), P (a1 :: a2 :: nil) -> P l
       -> P (a1 :: a2 :: l))
    -> forall (l : list A), P l.
Proof.
intros; eapply well_founded_induction_type. eapply lengthOrder_wf.
destruct x; auto; destruct x; auto. intros; apply X2; auto.
apply X3; unfold lengthOrder; simpl; auto.
Defined.

End DivConq.

Ltac div_conq_pair := eapply div_conq_pair.


(* Exercise coq_nat_10 *)

(* Multiplication distributes over addition *)

Require Import Arith.

Print Nat.add_assoc.
Print Nat.add_comm.

Lemma mult_plus_distr : forall m n p, m * (n + p) = m * n + m * p.

Proof.
 intros.
 induction m.
 rewrite Nat.mul_0_l.
 reflexivity.
 simpl.
 rewrite IHm.
 rewrite Nat.add_assoc.
 rewrite Nat.add_assoc with (m := p).
 rewrite Nat.add_comm with (n := n+p).
 rewrite Nat.add_assoc.
 rewrite Nat.add_comm with (n := m*n).
 reflexivity.
Qed.


Require Import ssreflect ssrfun ssrbool.
Require Import Generic.lemmas Generic.wlog.
Require Import Generic.pg3x_spec.

Require Import  PG33.pg33_inductive.

Module PS : ProjectiveSpace.

  Definition Point := Point.
  Definition Line := Line.

  Definition incid_lp := incid_lp.
  Definition eqP := eqP.
  Definition eqL := eqL.

  (** a1_exists : existence of a line generated from 2 points *)

  Check l_from_points.

  Ltac prove_a1_exists :=
    let A:=fresh in
    let B:=fresh in
    intros A B;  pose (l:=(l_from_points A B));
                   revert l;case A; case B; intros l; exists l; exact (erefl true).

  Lemma a1_exists : forall A B : Point,
      {l : Line | incid_lp A l && incid_lp B l}.
  Proof.
    idtac "-> proving a1_exists".
    time (prove_a1_exists).
    Time Qed.
  Check a1_exists.

  (** a3_1 : every line has at least three distinct points *)

  Ltac exists_p3 t u v :=
    exact (existT _ t
                  (existT _  u
                          (exist _   v (erefl true)))).

  Ltac prove_a3_1 := let l := fresh "l" in
                     let x := fresh "x" in
                     intros l; pose (x:= points_from_line l); revert x;
                     case l; intros x;
                     exists_p3 (fst (fst (fst x))) (snd (fst (fst x))) (snd (fst x)).

  Definition dist_3p  (A B C :Point) : bool := (negb (eqP A B)) && (negb (eqP A C)) && (negb (eqP B C)).

  Lemma a3_1 :
    forall l:Line,{A:Point &{B:Point &{ C:Point|
            dist_3p A B C && (incid_lp A l && incid_lp B l && incid_lp C l)}}}.
    Proof.
    idtac "-> proving a3_1".
    time (prove_a3_1).
    Time Qed.

    Check a3_1.

  (** a1_unique : unicity of the line generated from 2 points *)
  (** l_from_points is actually a1_exists *)
  Check l_from_points.
  Check a1_exists.

  Lemma points_line : forall T Z:Point, forall x:Line,
        incid_lp T x -> incid_lp Z x -> (T<>Z) -> x = (l_from_points T Z).
  Proof.
    idtac "-> proving points_line".
    time (intros T Z x;
          case x; case T; intros HTx;
          first [ discriminate |
                 case Z; intros HZx HTZ;
                 solve  [ discriminate |  exact (@erefl Line _) | apply False_rect; auto ] ]).
    Time Qed.

  Check points_line.

  Ltac handle x :=
    match goal with Ht  : is_true (incid_lp ?T x),
                    Hz  : is_true (incid_lp ?Z x),
                    Htz : (not (@eq Point ?T ?Z))  |- _ =>
                    let HP := fresh in pose proof (points_line T Z x Ht Hz Htz) as HP;
                                       clear Ht Hz; rewrite HP(*; subst*)  end.

  Ltac prove_a1_unique :=
    let A:=fresh in
    let B:= fresh in
    let HAB' := fresh in
    let l1:=fresh in
    let l2:=fresh in
    let HAB:=fresh in
    let HAl1:=fresh in
    let HBl1:= fresh in
    let HAl2 := fresh in
    let HBl2 := fresh in
    intros A B l1 l2 HAB HAl1 HBl1 HAl2 HBl2;
    revert A B HAB l1 HAl1 HBl1 l2 HAl2 HBl2;
    intros  X; case X;
    intros Y;case Y; intros HAB;
    solve [apply False_rect; auto
          | discriminate
          | intros l1 HAl1 HBl1; handle l1; intros l2 HAl2 HBl2; handle l2; exact (@erefl Line _)].

  Lemma a1_unique:forall (A B :Point)(l1 l2:Line),
      ~A=B -> incid_lp A l1 -> incid_lp B l1  -> incid_lp A l2 -> incid_lp B l2 -> l1=l2.
  Proof.
    idtac "-> proving a1_unique".
    time(prove_a1_unique).
    Time Qed.

  Check a1_unique.

  Lemma Point_dec : forall T U:Point, {T=U}+{~T=U}.
  Proof.
    intros T U; case T; case U;
      solve [left; exact (@erefl Point _) | right; discriminate].
  Qed.

  Ltac prove_uniqueness :=
    let P:= fresh in
    let Q:= fresh in
    let hypP := fresh in
    let HPQdiff := fresh in
    let hypQ := fresh in
    let HPQ := fresh in
    let l := fresh in
    let m := fresh in
    let Hl := fresh in
    let Hl' := fresh in
    let Hm := fresh in
    let Hm' := fresh in
    intros P Q l m Hl Hl' Hm Hm';
    revert l Hl Hl' m Hm Hm';
    destruct (Point_dec P Q) as [HPQdiff | HPQdiff];
    [left; rewrite HPQdiff; exact (@erefl Point _) | idtac]; revert HPQdiff;
    case P; case Q; intros HPQdiff;
    solve [discriminate |
      intros  l Hl Hl';handle l; intros m Hm Hm'; handle m; right; exact (@erefl Line _)].

  Lemma uniqueness : forall (A B :Point)(l1 l2:Line),
      incid_lp A l1 -> incid_lp B l1  -> incid_lp A l2 -> incid_lp B l2 -> A = B \/ l1 = l2.
  Proof.
    idtac "-> proving uniqueness".
    time(prove_uniqueness).
    Time Qed.
  Check uniqueness.

  (** a3_2 : there exists 2 lines which do not intersect, i.e. dim >= 3  *)

  Ltac solve_a3_2 := let p:= fresh in
                     intros p; case p;
                     let hypp:=fresh in let t := fresh in intros hypp t; discriminate.

  (*Ltac prove_a3_2 := try_all_l ltac:(fun l1 => exists l1; try_all_l ltac:(fun l2 => exists l2; solve_a3_2)).*)

  Lemma a3_2 : exists l1:Line, exists l2:Line, forall p:Point, ~(incid_lp p l1 && incid_lp p l2).
  Proof.
    idtac "-> proving a3_2".
    exists L0; exists L34;intros p; case p;
      let hypp:=fresh in let t := fresh in intros t; discriminate.
    (*Time (prove_a3_2).*) (* we could have chosen GKL and EHM for instance:  exists (o 35 0); exists (o 35 34)).*)
    Time Qed.
  Check a3_2.

(* a3_3 : given 3 lines, there exists a line which intersects these 3 lines *)

  Definition Intersect_In (l1 l2 :Line) (P:Point) := incid_lp P l1 && incid_lp P l2.

  (** points_from_l is actually a3_1 *)

  Definition points_from_l (l:Line) := points_from_line l.

  Ltac exists_lppp l t u v :=
    exact (ex_intro _  l
                 (ex_intro _  t
                  (ex_intro _ u
                          (ex_intro _  v  (erefl true))))).

  Definition dist_3l (A B C :Line) : bool :=
    (negb (eqL A B)) && (negb (eqL A C)) && (negb (eqL B C)).

  Lemma a3_3_simple :
    forall v1 v2 v3:Line,
      leL v1 v2-> leL v2 v3 ->
      dist_3l v1 v2 v3 ->
      exists v4 :Line, exists T1:Point, exists T2:Point, exists T3:Point,
              (Intersect_In v1 v4 T1) && (Intersect_In v2 v4 T2) && (Intersect_In v3 v4 T3).
   Proof.
     idtac "-> proving a3_3_simple".
     unfold dist_3l; intros v1 v2 v3 Hv1v2 Hv2v3 Hd;
       pose (t:=f_a3_3 v1 v2 v3) ;
pose(l:=fst t); pose (x:= fst (fst (snd t))); pose (y:= snd (fst (snd t))); pose (z:=snd (snd t));
       revert Hv1v2 Hv2v3 Hd t l x y z.

     case v1.

(*case v2;
                  intros hp1p2;try exact (degen_bool _ hp1p2) .

case v3;intros hp1p3 hdist l x y z.*)

    par: abstract
           (time (case v2;
                  intros hp1p2;
                  first [exact (degen_bool _ hp1p2) |
                         (case v3;
                          intros hp1p3 hdist t l x y z;
                          solve [ (exact (degen_bool _ hp1p3))
                                | (exact (degen_bool _ hdist))
                                | exists_lppp l x y z ])])).

      Time Qed.
(*233s*)
   Lemma eqL_sym : forall x y:Line, eqL x y = eqL y x.
    Proof.
      idtac "proving eqL_sym".
      time (intros; apply PeanoNat.Nat.eqb_sym).
    Time Qed.
    Check eqL_sym.

    Lemma eqP_sym : forall x y:Point, eqP x y = eqP y x.
    Proof.
      idtac "proving eqP_sym".
      time (intros;apply PeanoNat.Nat.eqb_sym).
    Time Qed.
    Check eqP_sym.

    Lemma exchL: forall x y B C, ~~eqL y x && B &&C-> ~~eqL x y && B && C.
    Proof.
      intros x y b c H.
      apply ab_bool in H.
      destruct H as [Hx Hy].
      apply ab_bool in Hx.
      destruct Hx.
      apply ab_bool; split.
      apply ab_bool; split.
      rewrite eqL_sym.
      assumption.
      assumption.
      assumption.
    Qed.

    Lemma exchP: forall x y B C D E F,
        ~~eqP y x && B &&C &&D &&E &&F-> ~~eqP x y && B && C && D && E &&F.
    Proof.
      intros x y b c d e f H.
      apply ab_bool in H.
      destruct H as [Ha Hf]; apply ab_bool in Ha;
        destruct Ha as [Ha He]; apply ab_bool in Ha;
          destruct Ha as [Ha Hd]; apply ab_bool in Ha;
            destruct Ha as [Ha Hc]; apply ab_bool in Ha;
              destruct Ha as [Ha Hb].
      apply ab_bool; split.
      apply ab_bool; split.
      apply ab_bool; split.
      apply ab_bool; split.
      apply ab_bool; split.
      rewrite eqP_sym.
      assumption.
      assumption.
      assumption.
      assumption.
      assumption.
      assumption.
    Qed.

   Lemma a3_3 : forall v1 v2 v3:Line,
      dist_3l v1 v2 v3 -> exists v4 :Line,  exists T1:Point, exists T2:Point, exists T3:Point,
             (Intersect_In v1 v4 T1) && (Intersect_In v2 v4 T2) && (Intersect_In v3 v4 T3).
  Proof.
    idtac "-> proving a3_3".
    intros v1 v2 v3.
    wlog3 v1 v2 v3 leL leL_total idtac idtac.

    intros; apply a3_3_simple.
    destruct (ab_bool_lr _ _  H) as [Ha1 Ha2]; exact Ha1.
    destruct (ab_bool_lr _ _  H) as [Ha1 Ha2]; exact Ha2.
    assumption.

    intros.
    assert (Hd: dist_3l x z y).
    unfold dist_3l in *;
      apply circ3;apply circ3;apply exchL;apply circ3; apply comm12L; assumption.
    destruct (H Hd) as [v4 [t1 [t2 [t3 Hv4t1t2t3]]]].
    exists v4; exists t1; exists t3; exists t2.
    apply circ3; apply circ3; apply comm12L; assumption.

    intros.
    assert (Hd: dist_3l y x z).
    unfold dist_3l in *; apply exchL; apply circ3; apply circ3; apply comm12L; assumption.
    destruct (H Hd) as [v4 [t1 [t2 [t3 Hv4t1t2t3]]]].
    exists v4; exists t2; exists t1; exists t3.
    apply comm12L; assumption.

    intros.
    assert (Hd: dist_3l y z x).
    unfold dist_3l in *.
    apply circ3; apply exchL; apply circ3; apply exchL; apply circ3; apply circ3; assumption.
    destruct (H Hd) as [v4 [t1 [t2 [t3 Hv4t1t2t3]]]].
    exists v4; exists t3; exists t1; exists t2.
    apply circ3; assumption.

    intros.
    assert (Hd: dist_3l z x y).
    unfold dist_3l in *.
    apply exchL; apply circ3; apply exchL; apply circ3; assumption.
    destruct (H Hd) as [v4 [t1 [t2 [t3 Hv4t1t2t3]]]].
    exists v4; exists t2; exists t3; exists t1.
    apply circ3; apply circ3; assumption.

    intros.
    assert (Hd: dist_3l z y x).
    unfold dist_3l in *.
    apply exchL; apply circ3; apply exchL; apply circ3; apply exchL;
      apply circ3; apply circ3; apply comm12L; assumption.
    destruct  (H Hd) as [v4 [t1 [t2 [t3 Hv4t1t2t3]]]].
    exists v4; exists t3; exists t2; exists t1.
    apply comm12L; apply circ3;apply circ3; assumption.
    Time Qed.

  (** a2 : Pasch's axiom *)

  Definition dist_4p  (A B C D:Point) : bool :=
    (negb (eqP A B)) && (negb (eqP A C)) && (negb (eqP A D))
                     && (negb (eqP B C)) && (negb (eqP B D)) && (negb (eqP C D)).

  Ltac findp' := match goal with
                  |-  (@ex Point (fun J:Point =>
                                       is_true (andb (incid_lp J ?m)
                                                     (incid_lp J ?p))))
                  /\ (@ex Point (fun K:Point =>
                                       is_true (andb (incid_lp K ?q)
                                                     (incid_lp K ?r))))=>
                  exact (conj (ex_intro _  ((*pg33_ind.*)f_a2 m p) (erefl true))
                              (ex_intro _  ((*pg33_ind.*)f_a2 q r) (erefl true)))
                 end.

  Lemma a2_conj_specific :
    forall A B C D:Point, leP A B -> leP C D ->
        let lAB := l_from_points A B in
        let lCD := l_from_points C D in
        let lAC := l_from_points A C in
        let lBD := l_from_points B D in
        let lAD := l_from_points A D in
        let lBC := l_from_points B C in

        dist_4p A B C D ->
        incid_lp A lAB && incid_lp B lAB ->
        incid_lp C lCD && incid_lp D lCD ->
        incid_lp A lAC && incid_lp C lAC ->
        incid_lp B lBD && incid_lp D lBD ->
        incid_lp A lAD && incid_lp D lAD ->
        incid_lp B lBC && incid_lp C lBC ->

        (exists I:Point, incid_lp I lAB && incid_lp I lCD) ->
        (exists J:Point, (incid_lp J lAC && incid_lp J lBD)) /\
        (exists K:Point, (incid_lp K lAD && incid_lp K lBC)).
  Proof.
  idtac "-> proving a2_conj_specific".
     intros A B C D HleAB HleCD lAB lCD lAC lBD lAD lBC Hdist HlAB HlCD HlAC HlBD HlAD HlBC Hex;
       destruct (ab_bool_lr _ _ Hdist) as [Hdist1 HCD]; clear Hdist;
         destruct (ab_bool_lr _ _ Hdist1) as [Hdist2 HBD]; clear Hdist1;
           destruct (ab_bool_lr _ _ Hdist2) as [Hdist3 HBC]; clear Hdist2;
             destruct (ab_bool_lr _ _ Hdist3) as [Hdist4 HAD]; clear Hdist3;
               destruct (ab_bool_lr _ _ Hdist4) as [HAB HAC]; clear Hdist4;
        revert A B HleAB HAB lAB HlAB C HBC HAC lBC HlBC lAC HlAC D HleCD HAD HBD HCD lAD HlAD lBD HlBD lCD HlCD Hex.

     time (intros A B; case A; case B; intros HlePAB HAB lAB HlAB).
     par: abstract (time (first [exact (degen_bool _ HlePAB) |exact (degen_bool _ HAB) | exact (degen_bool _ HlAB)|

      (intros C; case C; intros HBC HAC lBC HlBC lAC HlAC;
           first [  exact (degen_bool _ HBC) | exact (degen_bool _ HAC)
                        |

                        (intros D; case D; intros HleCD HAD HBD HCD lAD HlAD lBD HlBD lCD HlCD Hex;

                         first [ exact (degen_bool _ HleCD) | exact (degen_bool _ HAD)
                                 | exact (degen_bool _ HBD) | exact (degen_bool _ HCD)

                                 | case Hex; intros t; case t; intros Ht;
                                 first [exact (degen_bool _ Ht) | findp'] ])])])).
  Qed.
  Check a2_conj_specific.

  Lemma l_from_points_sym : forall x y:Point, l_from_points x y = l_from_points y x.
  Proof.
    intros x y; case x; case y; reflexivity.
  Qed.

Lemma a2_conj :
    forall A B C D:Point, dist_4p A B C D ->
         let lAB := l_from_points A B in
         let lCD := l_from_points C D in
         let lAC := l_from_points A C in
         let lBD := l_from_points B D in
         let lAD := l_from_points A D in
         let lBC := l_from_points B C in

         incid_lp A lAB && incid_lp B lAB ->
         incid_lp C lCD && incid_lp D lCD ->
         incid_lp A lAC && incid_lp C lAC ->
         incid_lp B lBD && incid_lp D lBD ->
         incid_lp A lAD && incid_lp D lAD ->
         incid_lp B lBC && incid_lp C lBC ->

         (exists I:Point, incid_lp I lAB && incid_lp I lCD) ->
         (exists J:Point, (incid_lp J lAC && incid_lp J lBD)) /\
         (exists J:Point, (incid_lp J lAD && incid_lp J lBC)).
  Proof.
    intros A B.
    wlog2 A B leP leP_total idtac idtac.
    intros A B HleAB.
    intros C D.
    wlog2 C D leP leP_total idtac ltac:(intros; apply a2_conj_specific; assumption || exact I).
    (* other cases *)

    intros C D Hr.

    intros lAB lCD lAC lBD lAD lBC Hdist HlAB HlCD HlAC HlBD HlAD HlBC Hex.
    assert (Hd' : dist_4p A B D C).
    unfold dist_4p in *.
    apply circ6; apply comm12P; apply circ6; apply circ6 ; apply comm12P; apply circ6;
    apply circ6; apply exchP; apply circ6; assumption.

    assert (HlDC:(incid_lp D (l_from_points D C) && incid_lp C (l_from_points D C))).
    apply circ2; rewrite l_from_points_sym; assumption.
    assert (Hex': (exists I : Point, incid_lp I (l_from_points A B) && incid_lp I (l_from_points D C))).
    rewrite (l_from_points_sym D C); assumption.
    generalize (Hr Hd' HlAB HlDC HlAD HlBC HlAC HlBD Hex').
    solve [intuition].

    intros A B Hr C D.
    intros Hd lAB lCD lAC lBD lAD lBC HlAB HlCD HlAC HlBD HlAD HlBC Hex.
    assert (Hd':  dist_4p B A C D).
    unfold dist_4p in *.
    apply exchP; apply circ6; apply circ6; apply comm12P; apply circ6; apply comm12P;
      apply circ6; apply circ6; apply circ6; apply circ6; apply comm12P; apply circ6;
        apply comm12P; apply circ6; apply circ6; apply circ6; apply circ6; assumption.

    assert (HlBA:incid_lp B (l_from_points B A) && incid_lp A (l_from_points B A)).
    apply circ2; rewrite l_from_points_sym; assumption.
    assert (HlDB:(incid_lp D (l_from_points D B) && incid_lp B (l_from_points D B))).
    apply circ2; rewrite l_from_points_sym; assumption.
    assert (Hex':(exists I : Point, incid_lp I (l_from_points B A) && incid_lp I (l_from_points C D))).
    rewrite (l_from_points_sym B A); assumption.

    generalize (Hr C D Hd' HlBA HlCD HlBC HlAD HlBD HlAC Hex').
    intros (He1,He2).
    split.
    destruct He2 as [e2 He2]; apply circ2 in He2; exists e2; assumption.
    destruct He1 as [e1 He1]; apply circ2 in He1; exists e1; assumption.
  Qed.

  Check a2_conj.

  Lemma points_line' : forall T Z:Point, forall x:Line,
        incid_lp T x -> incid_lp Z x -> ~~ eqP T Z -> x = (l_from_points T Z).
  Proof.
    idtac "-> proving points_line".
    time (intros T Z x;
           case x ;
           case T; intros  HTx;
           first [ discriminate |
                   case Z; intros  HZx HTZ;
                   solve [discriminate | apply False_rect; auto | exact (@erefl Line _)]]).
    Time Qed.

  Ltac handle' x :=
    match goal with Ht  : is_true (incid_lp ?T x),
                          Hz  : is_true (incid_lp ?Z x),
                                Htz : is_true (negb (eqP ?T ?Z)) |- _ =>
                    let HP := fresh in pose proof (points_line' T Z x Ht Hz Htz) as HP;
                                       clear Ht Hz; rewrite HP(*; subst*)  end.

  Ltac handle_eff l P Q HlAB:= assert (l=l_from_points P Q);[
                                 assert (incid_lp P l) by ( solve [intuition]);
                                 assert (incid_lp Q l) by ( solve [intuition]);
                                 handle' l; reflexivity | idtac].

  Lemma incid_lp_l_from_point1 : forall x y, incid_lp x (l_from_points x y).
  Proof.
    intros x y; case x; case y; trivial.
  Qed.

  Lemma incid_lp_l_from_point2 : forall x y, incid_lp y (l_from_points x y).
  Proof.
    intros x y; case x; case y; trivial.
  Qed.

  Lemma a2 : forall A B C D:Point, forall lAB lCD lAC lBD :Line,
        dist_4p A B C D ->
        incid_lp A lAB && incid_lp B lAB ->
        incid_lp C lCD && incid_lp D lCD ->
        incid_lp A lAC && incid_lp C lAC ->
        incid_lp B lBD && incid_lp D lBD ->
        (exists I:Point, incid_lp I lAB && incid_lp I lCD) ->
        exists J:Point, incid_lp J lAC && incid_lp J lBD.
  Proof.
    intros A B C D lAB lCD lAC lBD Hdist HlAB HlCD HlAC HlBD Hex.
    destruct (ab_bool_lr _ _ HlAB) as [HlAB1 HlAB2];
      destruct (ab_bool_lr _ _ HlCD) as [HlCD1 HlCD2];
      destruct (ab_bool_lr _ _ HlAC) as [HlAC1 HlAC2];
      destruct (ab_bool_lr _ _ HlBD) as [HlBD1 HlBD2];
      destruct (ab_bool_lr _ _ Hdist) as [Hdist1 HCD];
      destruct (ab_bool_lr _ _ Hdist1) as [Hdist2 HBD];
      destruct (ab_bool_lr _ _ Hdist2) as [Hdist3 HBC];
      destruct (ab_bool_lr _ _ Hdist3) as [Hdist4 HAD];
      destruct (ab_bool_lr _ _ Hdist4) as [HAB HAC].

    handle_eff lAB A B HlAB.
    handle_eff lCD C D HlCD.
    handle_eff lAC A C HlAC.
    handle_eff lBD B D HlBD.
    rewrite H in HlAB.
    rewrite H0 in HlCD.
    rewrite H1 in HlAC.
    rewrite H2 in HlBD.
    rewrite H in Hex.
    rewrite H0 in Hex.
    assert (HlAD:(incid_lp A (l_from_points A D) && incid_lp D (l_from_points A D))).
    apply Bool.andb_true_iff; split;
      [apply incid_lp_l_from_point1 | apply incid_lp_l_from_point2].

    assert (HlBC: (incid_lp B (l_from_points B C) && incid_lp C (l_from_points B C))).
    apply Bool.andb_true_iff; split;
      [apply incid_lp_l_from_point1 | apply incid_lp_l_from_point2].

    rewrite H1.
    rewrite H2.
    elim (a2_conj A B C D Hdist HlAB HlCD HlAC HlBD HlAD HlBC Hex).
    intros; assumption.
  Qed.
  Check a2.

End PS.

(* Local Variables: *)
(* coq-prog-name: "/Users/magaud/.opam/4.11.1/bin/coqtop" *)
(* coq-load-path: (("." "Top") ) *)
(* suffixes: .v *)
(* End: *)


Require Import Vector.
Require Import JMeq.

Section Null_vectors.
 Variable A:Set.

 Fact F1 : forall (n:nat)(v:t A n), n=0 -> JMeq v (nil A).
 Proof.
  intros n  v; case v.
  reflexivity.
  discriminate 1.
 Qed.

 Lemma V0_JMeq_Vnil:  forall (v:t A 0), JMeq v (nil A).
 Proof.
  intro v; apply F1.
  trivial.
 Qed.

 Lemma  V0_eq_Vnil : forall (v:t A  0), eq v (nil A).
 Proof.
  intros  v.
  apply JMeq_eq.
  apply V0_JMeq_Vnil.
 Qed.

End Null_vectors.


Require Import Coq.omega.Omega.

Hint Rewrite <- nat_compare_lt : hints.
Hint Rewrite <- nat_compare_gt : hints.
Hint Rewrite nat_compare_eq_iff : hints.
Hint Rewrite <- nat_compare_eq_iff : hints.

Ltac autorewrite_nat_compare :=
  autorewrite with hints.

Lemma nat_compare_eq_refl : forall x, nat_compare x x = Eq.
  intros; apply nat_compare_eq_iff; trivial.
Qed.

Lemma nat_compare_consistent :
  forall n0 n1,
    { nat_compare n0 n1 = Lt /\ nat_compare n1 n0 = Gt }
    + { nat_compare n0 n1 = Eq /\ nat_compare n1 n0 = Eq }
    + { nat_compare n0 n1 = Gt /\ nat_compare n1 n0 = Lt }.
Proof.
  intros n0 n1;
  destruct (lt_eq_lt_dec n0 n1) as [ [_lt | _eq] | _lt ];
  [ constructor 1; constructor 1  | constructor 1; constructor 2 | constructor 2 ];
  split;
  autorewrite_nat_compare;
  intuition.
Qed.


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

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint less (less_arg0 : natural) (less_arg1 : natural) : bool
           := match less_arg0, less_arg1 with
              | x, Zero => false
              | Zero, Succ x => true
              | Succ x, Succ y => less x y
              end.
Fixpoint eqb (n m: natural) : bool :=
match n, m with
   | Zero, Zero => true
   | Zero, Succ _ => false
   | Succ _, Zero => false
   | Succ n', Succ m' => eqb n' m'
end.
Fixpoint count (count_arg0 : natural) (count_arg1 : lst) : natural
           := match count_arg0, count_arg1 with
              | x, Nil => Zero
              | x, Cons y z => if eqb x y then Succ (count x z) else count x z
              end.

Fixpoint insort (insort_arg0 : natural) (insort_arg1 : lst) : lst
           := match insort_arg0, insort_arg1 with
              | i, Nil => Cons i Nil
              | i, Cons x y => if less i x then Cons i (Cons x y) else Cons x (insort i y)
              end.

Fixpoint sort (sort_arg0 : lst) : lst
           := match sort_arg0 with
              | Nil => Nil
              | Cons x y => insort x (sort y)
              end.

Lemma Nat_beq_eq : forall (x y : natural), eqb x y = true -> x = y.
Proof.
   intros.
   generalize dependent y.
   induction x.
   - intros. destruct y.
   + simpl in H. apply IHx in H. rewrite H. reflexivity.
   + discriminate.

   - intros. destruct y.

   + discriminate.
   + reflexivity.

Qed.

Theorem theorem0 : forall (x : natural) (y : natural) (z : lst), not (eq x y) -> eq (count x (insort y z)) (count x z).
Proof.
   intros.
  induction z.
  - simpl. destruct (eqb x n) eqn:?.
    + destruct (less y n) eqn:?.
      * simpl. destruct (eqb x y) eqn:?.
        --
         apply Nat_beq_eq in Heqb1. contradiction.
        -- rewrite Heqb. reflexivity.
      * simpl. rewrite Heqb. rewrite IHz. reflexivity.
    + destruct (less y n) eqn:?.
      * simpl. destruct (eqb x y) eqn:?.
        -- apply Nat_beq_eq in Heqb1. contradiction.
        -- rewrite Heqb. reflexivity.
      * simpl. rewrite Heqb. assumption.
   - simpl. destruct (eqb x y) eqn:?.
   + apply Nat_beq_eq in Heqb. contradiction.
      + reflexivity.
Qed.


(**************************************************************)
(*   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 Lia.

Set Implicit Arguments.

Section wf_chains.

  Variables (X : Type) (R : X -> X -> Prop).

  Inductive chain : nat -> X -> X -> Prop :=
    | in_chain_0 : forall x, chain 0 x x
    | in_chain_1 : forall n x y z, R x y -> chain n y z -> chain (S n) x z.

  Fact chain_plus a b x y z : chain a x y -> chain b y z -> chain (a+b) x z.
  Proof.
    induction 1 as [ | ? ? y ]; simpl; auto.
    constructor 2 with y; auto.
  Qed.

  Fact chain_rev n x y z : chain n x y -> R y z -> chain (S n) x z.
  Proof.
    intros H1 H2.
    replace (S n) with (n+1) by lia.
    apply chain_plus with y; auto.
    constructor 2 with z; auto.
    constructor 1.
  Qed.

  (* If chains to x have bounded length then x is R-accessible *)

  Lemma Acc_chains k x : (forall n y, chain n y x -> n <= k) -> Acc R x.
  Proof.
    revert x; induction k as [ | k IHk ]; intros x Hx.
    + constructor 1; intros y Hy.
      generalize (Hx _ _ (in_chain_1 Hy (in_chain_0 x))); lia.
    + constructor 1; intros y Hy.
      apply IHk; intros n z Hn.
      apply le_S_n, (Hx _ z), chain_rev with y; auto.
  Qed.

  (* If every x has bounded chains to itself then R is WF *)

  Hypothesis (HR : forall x, exists k, forall n y, chain n y x -> n <= k).

  Theorem wf_chains : well_founded R.
  Proof.
    intros x.
    destruct (HR x) as (k & Hk).
    revert Hk; apply Acc_chains.
  Qed.

End wf_chains.


(* An alternate nat induction principle. *)

Section nat_ind_alt_sect.

  Variables
    (P: nat -> Prop).

  Hypotheses
    (P_0: P 0)
    (P_1: P 1)
    (P_2: forall n, P n -> P (S (S n))).

  (* You'll need to strengthen the goal before induction,
     to get a stronger induction hypothesis.
     Use `assert something` first to achieve this.
     The `something` must be weak enough to be true in the base case,
     and strong enough to leapfrog alternate nats in the inductive case.
     Start by thinking about what you already know in the base case. *)
  Lemma nat_ind_alt (n: nat): P n.
  Proof.

  Qed.

End nat_ind_alt_sect.


Require Import String ZArith List.
Open Scope Z_scope.

Inductive aexpr : Type :=
 | anum ( x : Z ) : aexpr
 | avar ( s : string ) : aexpr
 | aplus ( e1 e2 : aexpr ) : aexpr.

Inductive bexpr : Type :=
 | blt ( e1 e2 : aexpr ) : bexpr.

Inductive instr : Type :=
 | assign ( x : string ) ( e : aexpr )
 | seq ( i1 i2 : instr ) : instr
 | while ( b : bexpr ) ( i : instr ) : instr.

Fixpoint af ( g : string -> Z ) ( e : aexpr ) : Z :=
 match e with
 | anum n => n
 | avar x => g x
 | aplus e1 e2 => af g e1 + af g e2
 end.

SearchAbout ( Z -> Z -> bool ).
Fixpoint bf ( g : string -> Z ) ( b : bexpr )  :=
 match b with
 | blt b1 b2 => Z.ltb ( af g b1 ) ( af g b2 )
 end.

Inductive assert : Type :=
 | pred ( p : string ) ( l : list aexpr )
 | a_b ( b : bexpr )
 | a_conj ( a1 a2 : assert )
 | a_not ( a : assert )
 | a_true
 | a_false.

Fixpoint ia  ( m : string -> list Z -> Prop ) ( g : string -> Z )
  ( a : assert ) : Prop :=
 match a with
 | pred s l => m s ( map ( af g ) l )
 | a_b b => bf g b = true
 | a_conj a1 a2 => ( ia m g a1 ) /\ ( ia m g a2 )
 | a_not a => not ( ia m g a )
 | a_true => True
 | a_false => False
 end.

Inductive a_instr : Type :=
 | pre ( a : assert ) ( i : a_instr )
 | a_assign ( x : string ) ( e : aexpr )
 | a_seq ( i1 i2 : a_instr )
 | a_while ( b : bexpr ) ( a : assert ) ( i : a_instr ).

Fixpoint asubst ( x : string ) ( s : aexpr ) ( e : aexpr ) : aexpr :=
 match e with
 | anum n => anum n
 | avar x1 => if string_dec x x1 then s else e
 | aplus e1 e2 => aplus ( asubst x s e1 ) ( asubst x s e2 )
 end.

Definition bsubst ( x : string ) ( s : aexpr ) ( b : bexpr ) : bexpr :=
 match b with
 | blt e1 e2 => blt ( asubst x s e1 ) ( asubst x s e2 )
 end.

Fixpoint subst ( x : string )  ( s : aexpr ) ( a : assert ) : assert :=
 match a with
 | pred p l => pred p ( map ( asubst x s ) l )
 | a_b b => a_b ( bsubst x s b )
 | a_conj a1 a2 => a_conj ( subst x s a1 ) ( subst x s a2 )
 | a_not a => a_not ( subst x s a)
 | any => any
 end.


Require Export ZArith.
Require Export List.
Require Export Arith.
Require Export Lia.
Require Export Zwf.

(* taken from chapter 5 *)

Inductive plane : Set :=
    point : Z->Z->plane.

Inductive htree (A:Type) : nat->Type :=
  | hleaf : A -> htree A 0%nat
  | hnode : forall n:nat, A -> htree A n -> htree A n -> htree A (S n).

Inductive south_west : plane->plane->Prop :=
  south_west_def :
  forall a1 a2 b1 b2:Z, (a1 <= b1)%Z -> (a2 <= b2)%Z ->
        south_west (point a1 a2)(point b1 b2).

Inductive even : nat->Prop :=
  | O_even : even 0
  | plus_2_even : forall n:nat, even n -> even (S (S n)).

Inductive sorted {A:Type}(R:A->A->Prop) : list A -> Prop :=
  | sorted0 : sorted  R nil
  | sorted1 : forall x:A, sorted  R (x :: nil)
  | sorted2 :
      forall (x y:A)(l:list A),
        R x y ->
        sorted  R (y :: l)-> sorted  R (x  ::  y :: l).

#[export] Hint Constructors sorted :  sorted_base.

Require Export Relations.

Inductive clos_trans {A:Type}(R:relation A) : A->A->Prop :=
  | t_step : forall x y:A, R x y -> clos_trans  R x y
  | t_trans :
    forall x y z:A, clos_trans  R x y -> clos_trans  R y z ->
        clos_trans  R x z.

Theorem sorted_nat_123 : sorted le (1::2::3::nil).
Proof.
 auto with sorted_base arith.
Qed.

Theorem xy_ord :
 forall x y:nat, le x y -> sorted  le (x::y::nil).
Proof.
 auto with sorted_base.
Qed.

Theorem zero_cons_ord :
 forall l:list nat, sorted le l -> sorted le (cons 0 l).
Proof.
 induction 1; auto with sorted_base arith.
Qed.

Theorem sorted1_inv {A:Type}{le : relation A} { x l} (H: sorted le (x::l))  :
  sorted le l.
Proof.
 inversion H;  auto with sorted_base.
Qed.

Theorem sorted2_inv {A:Type}{le : relation A} {x y  l}
        (H: sorted le (x::y::l)): le x y.
Proof.
 inversion H; auto with sorted_base.
Qed.

Theorem not_sorted_132 :  ~ sorted le (1::3::2::nil).
Proof.
 intros H; generalize  (sorted1_inv   H); intro H0.
 generalize (sorted2_inv H0).
 lia.
Qed.

(** Tests :
Check True_ind.

Check False_ind.

Check and_ind.

Check or_ind.

Check ex_ind.

Check eq_ind.
*)

Require Import JMeq.

(** Tests :
Check JMeq_eq.

Check JMeq_ind.

*)

Inductive ahtree(A:Type) : Type :=
  any_height : forall n:nat, htree A n -> ahtree A.

Arguments any_height {A} n _.

Theorem any_height_inj2 {A:Type} :
 forall (n1 n2:nat)(t1:htree A n1)(t2:htree A n2),
   any_height n1 t1 = any_height   n2 t2 -> JMeq t1 t2.
Proof.
 intros  n1 n2 t1 t2 H.
 injection H; intros H1 H2.
 dependent rewrite <- H1.
 trivial.
Qed.

Theorem any_height_inj2' {A:Type} :
 forall (n1 n2:nat)(t1:htree A n1)(t2:htree A n2),
   any_height n1 t1 = any_height   n2 t2 -> JMeq t1 t2.
Proof.
 intros  n1 n2 t1 t2 H.
 change (match any_height n2 t2 with
        | any_height  n t => JMeq t1 t
        end);
   now rewrite <- H.
Qed.

Require Import List  Vector.

Section vectors_and_lists.
 Variable A : Type.
 (** Note :
    The type of A-vectors of length n is just (t A n)
    or (Vector.t A n)

    Since the Vector library overloads nil and cons, we use qualified names
    for the operations on lists *)

 Fixpoint vector_to_list (n:nat)(v:t A n){struct v}
  : list A :=
  match v with
  | nil _ => List.nil
  | cons _ a p tl => List.cons a (vector_to_list p tl)
  end.

 Fixpoint list_to_vector (l:list A) : t A (length l) :=
   match l as x return t A (length x) with
   | List.nil => nil A
   | List.cons a tl => cons A a (length tl)(list_to_vector tl)
   end.

 Theorem keep_length :
  forall (n:nat)(v:t A n), length (vector_to_list n v) = n.
 Proof.
   intros n v; induction  v; simpl; auto.
 Qed.

 Lemma Vconseq :
  forall (a:A)(n m:nat),
   n = m ->
   forall (v:t A n)(w:t A m),
     JMeq v w -> JMeq (cons A a n v)(cons A a m w).
 Proof.
  intros a n m Heq; rewrite Heq.
  intros v w HJeq.
  rewrite HJeq; reflexivity.
Qed.

 Theorem vect_to_list_and_back :
  forall n (v:t A n),
    JMeq v (list_to_vector (vector_to_list n v)).
 Proof.
  intros n v; induction  v as [ | h n v IHv].
 -   reflexivity.
 -    simpl;  apply Vconseq.
   +    now rewrite  keep_length.
   +   assumption.
 Qed.

End vectors_and_lists.

Theorem structured_intro_example1 : forall A B C:Prop, A/\B/\C->A.
Proof.
 intros A B C [Ha [Hb Hc]];
 assumption.
Qed.

Theorem structured_intro_example2 : forall A B:Prop, A \/ B/\(B->A)->A.
Proof.
 intros A B [Ha | [Hb Hi]].
 - assumption.
 - now apply Hi.
Qed.

Theorem sum_even : forall n p:nat, even n -> even p -> even (n+p).
Proof.
(** False start
 intros n; elim n.
 auto.
 intros n' Hrec p Heven_Sn' Heven_p.
Restart.
*)

 intros n p Heven_n; induction Heven_n.
 -  trivial.
 -  intro H0; simpl;  constructor; auto.
Qed.

(**
Check le_ind.

*)

Theorem lt_le : forall n p:nat, n < p -> n <= p.
Proof.
 intros n p H; induction H; repeat constructor; assumption.
Qed.

Open Scope Z_scope.

Inductive Pfact : Z->Z->Prop :=
  Pfact0 : Pfact 0 1
| Pfact1 : forall n v:Z, n <> 0 -> Pfact (n-1) v -> Pfact n (n*v).

Theorem pfact3 : Pfact 3 6.
Proof.
 apply Pfact1 with (n := 3)(v := 2).
 discriminate.
 apply (Pfact1 2 1).
 discriminate.
 apply (Pfact1 1 1).
 discriminate.
 apply Pfact0.
Qed.

Theorem fact_def_pos : forall x y:Z, Pfact x y ->  0 <= x.
Proof.
 intros x y H; induction  H.
 -  auto with zarith.
 -  lia.
Qed.

(**
Check Zwf_well_founded.

Check well_founded_ind.
*)

Theorem Zle_Pfact : forall x:Z, 0 <= x -> exists y:Z, Pfact x y.
Proof.
 intros x; induction  x using (well_founded_ind (Zwf_well_founded 0)).
 intros  Hle; destruct  (Zle_lt_or_eq  _ _ Hle).
 - destruct (H (x-1)).
   +  unfold Zwf; lia.
   +  lia.
   + exists (x*x0); apply Pfact1; auto with zarith.
 -  subst x; exists 1; constructor.

Qed.

Section little_semantics.
 Variables Var aExp bExp : Set.
 Inductive inst : Set :=
 | Skip : inst
 | Assign : Var->aExp->inst
 | Sequence : inst->inst->inst
 | WhileDo : bExp->inst->inst.

 Variables
  (state : Set)
  (update : state->Var->Z -> option state)
  (evalA : state->aExp -> option Z)
  (evalB : state->bExp -> option bool).

 Inductive exec : state->inst->state->Prop :=
 | execSkip : forall s:state, exec s Skip s
 | execAssign :
    forall (s s1:state)(v:Var)(n:Z)(a:aExp),
     evalA s a = Some n -> update s v n = Some s1 ->
     exec s (Assign v a) s1
 | execSequence :
    forall (s s1 s2:state)(i1 i2:inst),
     exec s i1 s1 -> exec s1 i2 s2 ->
     exec s (Sequence i1 i2) s2
 | execWhileFalse :
    forall (s:state)(i:inst)(e:bExp),
     evalB s e = Some false -> exec s (WhileDo e i) s
 | execWhileTrue :
    forall (s s1 s2:state)(i:inst)(e:bExp),
     evalB s e = Some true ->
     exec s i s1 ->
     exec s1 (WhileDo e i) s2 ->
     exec s (WhileDo e i) s2.

 Theorem HoareWhileRule :
  forall (P:state->Prop)(b:bExp)(i:inst)(s s':state),
    (forall s1 s2:state,
      P s1 -> evalB s1 b = Some true -> exec s1 i s2 -> P s2)->
    P s -> exec s (WhileDo b i) s' ->
    P s' /\ evalB s' b = Some false.
 Proof.
(*  intros P b i s s' H Hp Hexec; elim Hexec.
 Restart.
  intros P b i s s' H Hp Hexec; generalize H Hp; elim Hexec.
 Restart. *)

  intros P b i s s' H.
  cut
   (forall i':inst,
     exec s i' s' ->
     i' = WhileDo b i -> P s -> P s' /\ evalB s' b = Some false);
   eauto.
  intros i' Hexec; elim Hexec; try (intros; discriminate).
  intros s0 i0 e Heval Heq; injection Heq; intros H1 H2.
  match goal  with
  | id:(e = b) |- _ => rewrite <- id; auto
  end.
  intros;
   match goal with
   | id:(_ = _) |- _ => injection id; intros H' H''
   end.
    subst i0 b;eauto.
 Qed.

End little_semantics.

Open Scope nat_scope.

Inductive is_0_1 : nat->Prop :=
  is_0 : is_0_1 0 | is_1 : is_0_1 1.

#[export] Hint Resolve is_0 is_1 : core.

Lemma sqr_01 : forall x:nat, is_0_1 x -> is_0_1 (x * x).
Proof.
  induction 1; simpl; auto.
Qed.

Theorem elim_example : forall n:nat, n <= 1 -> n*n <= 1.
Proof.
 intros n H.
 destruct (sqr_01 n); auto.
 inversion_clear H; auto.
 inversion_clear H0; auto.
Qed.

(** bad attempt
Section bad_proof_for_inversion.

 Theorem not_1_even : ~even 1.
 Proof.
  red; intros H; elim H.
 Abort.

End bad_proof_for_inversion.

*)

Theorem not_even_1 : ~even 1.
Proof.
 unfold not; intros H.
 inversion H.
Qed.

Theorem plus_2_even_inv : forall n:nat, even (S (S n))-> even n.
Proof.
 intros n H; inversion H; assumption.
Qed.

(** Same theorems, but using basic tactics only
*)

Theorem not_even_1' : ~even 1.
Proof.
 intro H.
 generalize (refl_equal 1).
 pattern 1 at -2.
 induction H.
 - discriminate.
 - discriminate.
Qed.

Theorem plus_2_even_inv' : forall n:nat, even (S (S n))-> even n.
Proof.
 intros n H.
 generalize (refl_equal (S (S n))); pattern (S (S n)) at -2.
 induction  H.
 -  discriminate.
 -  intros H0 ; injection H0; intro; now subst n0.
Qed.


(* From the chapter entitled Inductive Predicates in CPDT *)
Require Import Bool Arith List CpdtTactics.

Print ex.

Lemma exist1 : exists x : nat, x + 1 = 2.
Proof.
  exists 1.
  reflexivity.
Qed.

Lemma exist2 : forall (n m:nat), (exists x, n + x = m) -> n <= m.
Proof.
  destruct 1.
  crush.
Qed.

Inductive isZero : nat -> Prop :=
| IsZero : isZero 0.

Theorem isZero_zero : isZero 0.
  constructor.
Qed.

Lemma isZero_plus : forall n m : nat, isZero m -> n + m = n.
Proof.
  destruct 1.
  crush.
Qed.

Lemma isZero_contra : isZero 1 -> False.
Proof.
  inversion 1.
Qed.

Inductive even : nat -> Prop :=
| Even0 : even 0
| EvenSS : forall n, even n -> even (S (S n)).

Theorem even_0 : even 0.
  constructor.
Qed.

Definition even_4 : even 4.
  repeat constructor.
Qed.
Print even_4.

(*Hint Constructors even.

Theorem even_4' : even 4.
  auto.
Qed.

*)
Theorem even_1_contra : even 1 -> False.
  intro H.
  inversion H.
Qed.
Print even_1_contra.

Theorem even_3_contr : even 3 -> False.
  intro H.
  inversion H.
  inversion H1.
Qed.

Hint Constructors even.
Theorem even_plus : forall n m, even n -> even m -> even (n + m).
Proof.
  induction 1 ; crush.
Qed.

(*
Theorem even_contra : forall n, even (S (n + n)) -> False.
  induction 1.
*)

Theorem even_contra : forall n, even (S (n + n)) -> False.
Proof.
  assert (forall n', even n' -> forall n, n' = S (n + n) -> False).
  Focus 2.
  intros.
  apply (H _ H0 _ eq_refl).
  induction 1 ; crush.
  destruct n ; destruct n0 ; crush.
  rewrite <- plus_n_Sm in H0.
  apply (IHeven _ H0).
Qed.

Print even_contra.


Require Import Arith.

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

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint less (less_arg0 : natural) (less_arg1 : natural) : bool
           := match less_arg0, less_arg1 with
              | x, Zero => false
              | Zero, Succ x => true
              | Succ x, Succ y => less x y
              end.
Fixpoint eqb (n m: natural) : bool :=
match n, m with
   | Zero, Zero => true
   | Zero, Succ _ => false
   | Succ _, Zero => false
   | Succ n', Succ m' => eqb n' m'
end.
Definition leq (x : natural) (y : natural) : bool :=
eqb x y || less x y.
(*
Fixpoint leq (n m : natural) : bool :=
match n, m with
| Zero  , x   => true
| x , Zero   => false
| Succ x, Succ y => leq x y
end. *)

Fixpoint insort (insort_arg0 : natural) (insort_arg1 : lst) : lst
           := match insort_arg0, insort_arg1 with
              | i, Nil => Cons i Nil
              | i, Cons x y => if less i x then Cons i (Cons x y) else Cons x (insort i y)
              end.

Fixpoint sorted (sorted_arg0 : lst) : bool
:= match sorted_arg0 with
   | Nil => true
   | Cons x l => match l with
      | Nil => true
      | Cons z y => andb (sorted l) (leq x z)
      end
   end.

Fixpoint sort (sort_arg0 : lst) : lst
           := match sort_arg0 with
              | Nil => Nil
              | Cons x y => insort x (sort y)
              end.
Lemma not_less : forall (x y : natural), less x y = false -> leq y x = true.
Proof.
   intros.
   generalize dependent y.
   induction x.
   - intros. unfold leq. destruct y.
   + simpl in H. apply IHx in H. unfold leq in H. simpl. assumption.
   + reflexivity.
   - intros. unfold leq. destruct y.
   + discriminate.
   + reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : natural), eq (sorted x) true -> eq (sorted (insort y x)) true.
Proof.
   (* intros.
  induction x.
  - destruct x.
    + simpl. destruct (less y n) eqn:?.
      * simpl. unfold leq. rewrite Heqb. admit.
      * simpl. apply not_less. assumption.
    + simpl in H. apply andb_true_iff in H. destruct H. simpl in IHx. simpl. destruct (less y n) eqn:?.
      * simpl. rewrite H. rewrite H0. unfold leq. rewrite Heqb. apply orb_true_r.
      * destruct (less y n0) eqn:?.
        -- simpl. rewrite H. apply not_less in Heqb. rewrite Heqb. unfold leq. rewrite Heqb0. rewrite orb_true_r. reflexivity.
        -- simpl. apply IHx in H. simpl in H. rewrite H. rewrite H0. reflexivity.
     - reflexivity. *)
Admitted.


(** 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) (z : natural) (x : natural) : natural :=
  mult (plus x y) z.


(** 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 (z : natural) (y : natural) (lf1 : natural) : natural :=
  plus lf1 (mult y z).


Require Import Ascii.
Require Import Bool.
Require Import Omega.
Require Import Peano.

Inductive eq_ascii : ascii -> ascii -> Prop :=
| ascii_eq : forall (a b:ascii),
  (nat_of_ascii a) = (nat_of_ascii b) -> eq_ascii a b.

Lemma bit_significant_r : forall n m, 2*n+1 <> 2*m+0.
Proof.
  intros n m. omega.
Defined.

Lemma bit_significant_l : forall n m, 2*n+0 <> 2*m+1.
Proof.
  intros n m. omega.
Defined.

Lemma bit_reg_l : forall n m, 2*n = 2*m -> n = m.
Proof.
  intros n m. omega.
Defined.

Lemma plus_reg_r : forall n m p, n + p = m + p -> n = m.
  intros. omega.
Defined.

Ltac simplify_nat :=
  match goal with
    | H: 2*?m + ?p = 2*?n + ?p |- _ => eapply plus_reg_r in H ; simplify_nat
    | H: 2*?m = 2*?n |- _ => eapply bit_reg_l in H ; simplify_nat
    | H: 2*?m + 0 = 2*?n + 1 |- _ => eapply bit_significant_l in H ; simplify_nat
    | H: 2*?m + 1 = 2*?n + 0 |- _ => eapply bit_significant_r in H ; simplify_nat
    | H: False |- _ => inversion H
    | H: true <> true |- _ => congruence
    | H: false <> false |- _ => congruence
    | H: true = false |- _ => congruence
    | H: false = true |- _ => congruence
    | H: ?b <> ?b', b : bool, b' : bool |- _ => destruct b ; destruct b' ; simplify_nat
    | _ : _ |- _ => idtac
  end.

Theorem eq_ascii_eq : forall a b, eq_ascii a b -> a = b.
Proof.
  intros a b.
  destruct a as [b1 b2 b3 b4 b5 b6 b7 b8].
  destruct b as [b1' b2' b3' b4' b5' b6' b7' b8'].
  intros H ; inversion H ; clear H ; subst ; unfold nat_of_ascii in *.
  (* bit 1 *)
  case (bool_dec b1 b1') ; intro H' ; subst ; simplify_nat.
  case (bool_dec b2 b2') ; intro H' ; subst ; simplify_nat.
  case (bool_dec b3 b3') ; intro H' ; subst ; simplify_nat.
  case (bool_dec b4 b4') ; intro H' ; subst ; simplify_nat.
  case (bool_dec b5 b5') ; intro H' ; subst ; simplify_nat.
  case (bool_dec b6 b6') ; intro H' ; subst ; simplify_nat.
  case (bool_dec b7 b7') ; intro H' ; subst ; simplify_nat.
  case (bool_dec b8 b8') ; intro H' ; subst ; auto.
  destruct b8 ; destruct b8' ; auto ; congruence.
Qed.

Print eq_ascii_eq.


Require Import ssreflect.

Section Socrates.
Variable A : Set.
Variables human mortal : A -> Prop.
Variable socrates : A.

Hypothesis hm : forall x, human x -> mortal x.
Hypothesis hs : human socrates.

Theorem ms : mortal socrates.
Proof.
  apply: (hm socrates).
  assumption.
Qed.

Print ms.
End Socrates.

Section Eq.
  Variable T : Type.

  Lemma symmetry : forall x y : T, x = y -> y = x.
  Proof.
    move=> x y exy.
    rewrite exy.
    done.
  Restart.
    by move=> x y ->.
  Restart.
    by move=> x y <-. (* <- だと逆に書き換え *)
  Qed.

  Lemma transitivity : forall x y z : T, x = y -> y = z -> x = z.
  Proof.
    by move=> x y z xy <-.
  Restart.
    by move=> x y z <-.
  Qed.
End Eq.

Section Group.
  Variable G : Set.
  Variable e : G.
  Variable op : G -> G -> G.
  Notation "a * b" := (op a b).
  Variable inv : G -> G.
  Hypothesis associativity : forall a b c, (a * b) * c = a * (b * c).
  Hypothesis left_identity : forall a, e * a = a.
  Hypothesis right_identity : forall a, a * e = a.
  Hypothesis left_inverse : forall a, inv a * a = e.
  Hypothesis right_inverse : forall a, a * inv a = e.

  Lemma unit_unique : forall e', (forall a, a * e' = a) -> e' = e.
  Proof.
    move=> e' He'.
    rewrite -[RHS]He'.
    rewrite (left_identity e').
    done.
  Qed.

  Lemma inv_unique : forall a b, a * b = e -> a = inv b.
  Proof.
    move=> a b.
    Check f_equal.
    move/(f_equal (fun x => x * inv b)).
    rewrite associativity right_inverse left_identity right_identity.
    (*
    rewrite associativity.
    rewrite right_inverse.
    rewrite left_identity.
    rewrite right_identity.
    *)
    done.
  Qed.

  Lemma inv_involutive : forall a, inv (inv a) = a.
  Proof.
    move=> a.
    by rewrite <- (inv_unique a (inv a)).
  Restart.
    move=>a.
    move/inv_unique :(right_inverse a).
  Restart.
    move=> a.
    by rewrite <- (inv_unique _ _ (right_inverse _)).
  Qed.
End Group.
Check unit_unique.

Section Laws.
Variables (A:Set) (P Q : A->Prop).

Lemma DeMorgan2 : (~ exists x, P x) -> forall x, ~ P x.
Proof.
  move=> N x Px. elim: N. by exists x.
Qed.

Theorem exists_or :
  (exists x, P x \/ Q x) -> (exists x, P x) \/ (exists x, Q x).
Proof.
  move=> [x [Px | Qx]]; [left|right]; by exists x.
Qed.

Hypothesis EM : forall P, P \/ ~P.

Lemma DeMorgan2' : ~ (forall x, P x) -> exists x, ~ P x.
Proof.
  move=> nap.
  (*
  move: (EM (exists x, ~ P x)).
  case; move => //.
  *)
  case: (EM (exists x, ~ P x)) => //. (* 片方の分岐を解決 *)
  move=> nnpx.
  elim: nap => x.
  (*
  case: (EM (P x)) => // => npx.
  *)
  case: (EM (P x)) => //.
  move => npx.
  elim: nnpx.
  by exists x.
Qed.

End Laws.

Section Coq3.
  Variable A : Set.
  Variable R : A -> A -> Prop.
  Variables P Q : A -> Prop.

  Theorem exists_postpone :
    (exists x, forall y, R x y) -> (forall y, exists x, R x y).
  Proof.
    case => x H y. by exists x.
  Restart.
    move=> [x H] y. by exists x.
  Qed.

  Theorem exists_mp : (forall x, P x -> Q x) -> ex P -> ex Q.
  Proof.
    move => H [y Py]. exists y. by apply H.
  Restart.
    move => H [y /H Qy]. by exists y.
  Qed.

  Theorem or_exists :
    (exists x, P x) \/ (exists x, Q x) -> exists x, P x \/ Q x.
  Proof.
    by move => [[x Px]|[x Qx]]; exists x; [left|right].
  Restart.
    by case => [[x Px]|[x Qx]]; exists x; [left|right].
  Qed.

  Hypothesis EM : forall P, P \/ ~P.

  Variables InPub Drinker : A -> Prop.
  Theorem drinkers_paradox :
    (exists consumer, InPub consumer) ->
    exists man, InPub man /\ Drinker man ->
    forall other, InPub other -> Drinker other.
  Proof.
    case => consumer Hc.
    case : (EM (forall man, InPub man -> Drinker man))
      => [H|/(DeMorgan2' _ _ EM) [man H]]; [ by exists consumer|].
      by exists man => [[]].
  Restart.
    move=> [c Ic].
    case: (EM (exists x, ~ Drinker x)).
      move=> [nd nDnd].
      exists nd. move=> [Ind Dnd]. by elim: nDnd.
    move=> nenD. exists c.
    case: (EM (~Drinker c)).
      move=> nDc [_ Dc]. by elim nDc.
    move=> nnDc [_ Dc] o Io.
    case: (EM (Drinker o)) => //.
    move=> nDo. elim: nenD. by exists o.
  Restart.
  Abort.

  Theorem remove_c : forall a,
    (forall x y, Q x -> Q y) ->
    (forall c, ((exists x, P x) -> P c) -> Q c) -> Q a.
  Proof.
    move=> a allQ H.
    case : (EM (exists x, P x)) =>[[c pc]|np].
    - by apply : allQ (H c _).
    - by apply : H.
  Restart.
    move=> a Qxy H.
    case: (EM (exists x, P x)).
      move=> [b Pb]. move: (H b). move=> H2.
      apply: (Qxy b).
      apply: H2. by move=> //.
    move=> neP. apply : H. move=> [b Pb].
    elim: neP. by exists b.
  Restart.
  Abort.
End Coq3.


Require Import Omega.

Inductive Plus : nat -> nat -> nat -> Prop :=
| PlusZero
  : forall m, Plus 0 m m
| PlusSucc
  : forall n m r,
    Plus n m r ->
    Plus (S n) m (S r).

Hint Constructors Plus.

Definition plus_cert : forall (n m : nat), {r : nat | Plus n m r}.
  refine (fix plus_cert (n m : nat) : {r | Plus n m r} :=
            match n return {r | Plus n m r} with
            | O    => exist _ m _
            | S n1 =>
              match plus_cert n1 m with
              | exist _ r1 _ => exist _ (S r1) _
              end
            end) ; clear plus_cert ; auto.
Defined.

Definition pred_cert : forall (n : nat), n > 0 -> {r | n = 1 + r}.
  refine (fun n =>
            match n return n > 0 -> {r | n = 1 + r} with
            | O => fun _ => False_rec _ _
            | S n' => fun _ => exist _ n' _
            end) ; omega.
Defined.

Notation "!" := (False_rec _ _).
Notation "[ e ]" := (exist _ e _).

Definition pred_cert1 : forall (n : nat), n > 0 -> {r | n = 1 + r}.
  refine (fun n =>
            match n return n > 0 -> {r | n = 1 + r} with
            | O => fun _ => !
            | S n' => fun _ => [ n' ]
            end) ; omega.
Defined.

Notation "'Yes'" := (left _ _).
Notation "'No'" := (right _ _).
Notation "'Reduce' x" := (if x then Yes else No) (at level 50).

Definition eq_nat_dec : forall (n m : nat), {n = m} + {n <> m}.
  refine (fix eq_nat n m : {n = m} + {n <> m} :=
            match n , m with
            | O    , O    => Yes
            | S n' , S m' => Reduce (eq_nat n' m')
            | _    , _    => No
            end) ; clear eq_nat ; congruence.
Defined.

(** exercício 44 *)

Definition eq_bool_dec : forall (a b : bool), {a = b} + {a <> b}.
Admitted.

(** exercício 45 *)

Definition eq_list_dec
           {A : Type}
           (eqAdec : forall (x y : A), {x = y} + {x <> y})
  : forall (xs ys : list A), {xs = ys} + {xs <> ys}.
Admitted.

Notation "!!" := (inright _ _).
Notation "[|| x ||]" := (inleft _ [x]).

Definition pred_cert_full : forall n, {r | n = 1 + r} + {n = 0}.
  refine (fun n =>
            match n return {r | n = 1 + r} + {n = 0} with
            | O => !!
            | S n' => [|| n' ||]
            end) ; auto.
Defined.

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

Section MAP.
  Variable Key : Type.
  Variable Value : Type.
  Variable eqKeyDec : forall (x y : Key), {x = y} + {x <> y}.

  Inductive Map : Type :=
  | nil : Map
  | cons : Key -> Value -> Map -> Map.

  Inductive MapsTo : Key -> Value -> Map -> Prop :=
  | Here  : forall k v m, MapsTo k v (cons k v m)
  | There : forall k v m k' v', k <> k' ->
            MapsTo k v m -> MapsTo k v (cons k' v' m).

  Hint Constructors MapsTo.

  Definition lookupMap
    : forall (k : Key)(m : Map), {v | MapsTo k v m} + {forall v, ~ MapsTo k v m}.
    refine (fix look k m : {v | MapsTo k v m} + {forall v, ~ MapsTo k v m} :=
              match m return {v | MapsTo k v m} + {forall v, ~ MapsTo k v m} with
              | nil => !!
              | cons k' v' m' =>
                match eqKeyDec k k' with
                | Yes => [|| v' ||]
                | No  =>
                  match look k m' with
                  | !! => !!
                  | [|| v ||] => [|| v ||]
                  end
                end
              end) ;
      clear look ; subst ;
        try (repeat (match goal with
                     | [H : MapsTo _ _ nil |- _] => inverts H
                     | [H : MapsTo _ _ (cons _ _ _) |- _] => inverts H
                     | [|- forall x, ~ _ ] => unfold not ; intros
                     | [ H : forall x, ~ (MapsTo _ _ _)
                         , H1 : MapsTo _ _ _ |- _] => apply H in H1
                     end)) ; auto.
  Defined.

  (** exercício 46 *)

  Definition insertMap : forall (k : Key)(v : Value)(m : Map), {m' | MapsTo k v m'}.
  Admitted.

  (** exercício 47 *)

  Definition removeMap : forall (k : Key)(m : Map), {m' | forall v, ~ MapsTo k v m'}.
  Admitted.
End MAP.

Section VEC.

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

  Fixpoint app {A : Set}{n1 n2}(ls1 : vector A n1)(ls2 : vector A n2) : vector A (n1 + n2) :=
    match ls1 with
    | vnil _ => ls2
    | vcons _ _ x ls1' => vcons _ _ x (app ls1' ls2)
    end.

  Definition vhead {A : Set}{n}(v : vector A (S n)) : A :=
    match v with
    | vcons _ _ x _ => x
    end.

  (** exercício 48 *)

  Fixpoint vmap {A B : Set}{n}(f : A -> B)(v : vector A n) : vector B n.
  Admitted.

  (** exercício 49
      Enuncie um teorema sobre a associatividade da
      concatenação de vectors e o prove. *)

  Inductive fin : nat -> Set :=
  | fzero : forall {n}, fin (S n)
  | fsucc : forall {n}, fin n -> fin (S n).

  Fixpoint get {A}{n}(ls : vector A n) : fin n -> A :=
    match ls with
      | vnil _ => fun idx =>
        match idx in fin n' return (match n' with
                                        | O => A
                                        | S _ => unit
                                      end) with
          | fzero => tt
          | fsucc _ => tt
        end
      | vcons _ _ x ls' => fun idx =>
        match idx in fin n' return (fin (pred n') -> A) -> A with
          | fzero => fun _ => x
          | fsucc idx' => fun get_ls' => get_ls' idx'
        end (get ls')
    end.
End VEC.


Module Sets.
Definition full {A : Type} : A -> Prop := fun _ => True.
Definition empty {A : Type} : A -> Prop := fun _ => False.
Definition union {A : Type} (X Y : A -> Prop) : A -> Prop := fun a => X a \/ Y a.
Definition intersect {A : Type} (X Y : A -> Prop) : A -> Prop := fun a => X a /\ Y a.
Definition omega_union {A : Type} (X : nat -> A -> Prop) : A -> Prop := fun a => exists n, X n a.
End Sets.

Module BinRel.
Definition id {A : Type} : A -> A -> Prop := fun x y => x = y.
Definition empty {A : Type} : A -> A -> Prop := fun x y => False.
Definition concat {A : Type} (r1 r2 : A -> A -> Prop) : A -> A -> Prop := fun x z => exists y, r1 x y /\ r2 y z.
Definition union {A : Type} (r1 r2 : A -> A -> Prop) : A -> A -> Prop := fun x y => r1 x y \/ r2 x y.
Definition intersection {A : Type} (r1 r2 : A -> A -> Prop) : A -> A -> Prop := fun x y => r1 x y /\ r2 x y.
Definition testrel {A : Type} (r : A -> Prop) := fun x y => x = y /\ r x.
Definition omega_union {A : Type} (r : nat -> A -> A -> Prop) : A -> A -> Prop := fun x y => exists n, r n x y.
Definition dia {A : Type} (r : A -> A -> Prop) (s : A -> Prop) : A -> Prop := fun x => exists y, r x y /\ s y.
End BinRel.


(** Structured Data *)

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

Check (pair 3 5).

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

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

Compute (fst (pair 3 5)).

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

Compute (fst (3,5)).

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

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

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

Theorem surjective_pairing' : forall (n m : nat),
  (n,m) = (fst (n,m), snd (n,m)).
Proof.
  reflexivity.  Qed.

Theorem surjective_pairing_stuck : forall (p : natprod),
  p = (fst p, snd p).
Proof.
  simpl.
Abort.

Theorem surjective_pairing : forall (p : natprod),
  p = (fst p, snd p).
Proof.
  intros p.  destruct p as [n m].  simpl.  reflexivity.
Qed.

Theorem snd_fst_is_swap : forall (p : natprod),
  (snd p, fst p) = swap_pair p.
Proof.
  intros[ n m ]; simpl; reflexivity.
Qed.
Theorem fst_swap_is_snd : forall (p : natprod),
  fst (swap_pair p) = snd p.
Proof.
  intros[ n m ]; simpl; reflexivity.
Qed.

(** * Lists of Numbers *)

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

Definition mylist := cons 1 (cons 2 (cons 3 nil)).

Notation "[ ]" := nil.

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

Definition mylist1 := 1 :: (2 :: (3 :: nil)).
Definition mylist2 := 1 :: 2 :: 3 :: nil.
Definition mylist3 := [1;2;3].

Fixpoint repeat (n count : nat) : natlist :=
  match count with
  | O => nil
  | S count' => n :: (repeat n count')
  end.
Compute (repeat 7 20).

Fixpoint length (l : natlist) : nat :=
match l with
| [] => O
| n :: l' => S (length l')
end.

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

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

Example test_app1:             [1;2;3] ++ [4;5] = [1;2;3;4;5].
Proof. reflexivity.  Qed.
Example test_app2:             nil ++ [4;5] = [4;5].
Proof. reflexivity.  Qed.
Example test_app3:             [1;2;3] ++ nil = [1;2;3].
Proof. reflexivity.  Qed.

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

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

Example test_hd1:             hd 0 [1;2;3] = 1.
Proof. reflexivity.  Qed.
Example test_hd2:             hd 0 [] = 0.
Proof. reflexivity.  Qed.
Example test_tl:              tl [1;2;3] = [2;3].
Proof. reflexivity.  Qed.

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

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

Compute (nonzeros [0;1;0;2;3;0;0]).

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

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

Definition oddb (n : nat) : bool := negb (evenb n).

Fixpoint oddmembers (l : natlist) : natlist :=
match l with
| nil     => nil
| h :: t  =>  if evenb h
              then oddmembers t
              else h :: oddmembers t
end.

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

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

Fixpoint countoddmembers (l : natlist) : nat :=
match l with
| nil     => O
| h :: t  =>  if oddb h
              then S (countoddmembers t)
              else countoddmembers t
end.

Example test_countoddmembers1:
  countoddmembers [1;0;3;1;4;5] = 4.
Proof.
  reflexivity.
Qed.

Example test_countoddmembers2:
  countoddmembers [0;2;4] = 0.
Proof.
   reflexivity.
Qed.

Example test_countoddmembers3:
  countoddmembers nil = 0.
Proof.
  reflexivity.
Qed.

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

Compute (alternate [1;2;3] [4;5;6]).

Example test_alternate1:
  alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
Proof.
  reflexivity.
Qed.

Example test_alternate2:
  alternate [1] [4;5;6] = [1;4;5;6].
Proof.
  reflexivity.
Qed.

Example test_alternate3:
  alternate [1;2;3] [4] = [1;4;2;3].
Proof.
  reflexivity.
Qed.

Example test_alternate4:
  alternate [] [20;30] = [20;30].
Proof.
  reflexivity.
Qed.

Theorem nil_app : forall l:natlist,
  [] ++ l = l.
Proof. reflexivity. Qed.

Definition pred (n : nat) : nat :=
  match n with
  | O => O
  | S m => m
  end.

Theorem tl_length_pred :
  forall l : natlist,
  pred (length l) = length (tl l).
Proof.
  intros l. destruct l as [| n l'].
  - simpl.
    reflexivity.
  - simpl.
    reflexivity.
Qed.

Theorem app_assoc : forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros l1 l2 l3.
  induction l1 as [| n l1' IHl1'].
  - (* l1 = nil *)
    reflexivity.
  - (* l1 = cons n l1' *)
    simpl. rewrite -> IHl1'. reflexivity.
Qed.

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

Example test_rev1 : rev [1;2;3] = [3;2;1].
Proof. reflexivity.  Qed.
Example test_rev2 : rev nil = nil.
Proof. reflexivity.  Qed.

Theorem rev_length_firsttry :
  forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l.
  induction l as [| n l' IHl'].
  - simpl.
    reflexivity.
  - simpl.
    rewrite <- IHl'.
Abort.

Theorem app_length :
  forall l1 l2 : natlist,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  intros l1 l2.
  induction l1 as [| n l1' IHl1'].
  - simpl.
    reflexivity.
  - simpl. rewrite -> IHl1'. reflexivity.
Qed.

Theorem plus_n_Sm :
  forall n m : nat,
  S (n + m) = n + (S m).
Proof.
intros *.
induction n as [| n' IHn'].
- simpl. reflexivity.
- simpl. rewrite <- IHn'. reflexivity.
Qed.

Theorem plus_comm :
  forall n m : nat,
  n + m = m + n.
Proof.
  intros*.
  induction n as [| n' IHn']; simpl.
  -apply plus_n_O.
  -rewrite IHn'. apply plus_n_Sm.
Qed.

Theorem rev_length :
  forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - (* l = nil *)
    reflexivity.
  - (* l = cons *)
    simpl. rewrite -> app_length. rewrite plus_comm.
    simpl. rewrite -> IHl'. reflexivity.
Qed.

Theorem app_nil_r : forall l : natlist,
  l ++ [] = l.
Proof.
  intros*.
  induction l; simpl. reflexivity.
  rewrite -> IHl. reflexivity.
Qed.

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

Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  intros*.
  induction l; simpl. reflexivity.
  rewrite rev_app_distr. rewrite IHl. simpl. reflexivity.
Qed.

Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist,
  l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  intros*.
  induction l1; simpl.
  -rewrite app_assoc. reflexivity.
  -rewrite <- IHl1. reflexivity.
Qed.

Lemma nonzeros_app : forall l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros *.
  induction l1.
  - simpl; reflexivity.
  - induction n as [| n IHn ]; simpl.
    + rewrite IHl1. reflexivity.
    + rewrite IHl1. reflexivity.

Qed.

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

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

Example test_beq_natlist1 :
  (beq_natlist nil nil = true).
Proof.
  reflexivity.
Qed.

Example test_beq_natlist2 :
  beq_natlist [1;2;3] [1;2;3] = true.
Proof.
  reflexivity.
Qed.

Example test_beq_natlist3 :
  beq_natlist [1;2;3] [1;2;4] = false.
Proof.
  reflexivity.
Qed.

Theorem beq_natlist_refl :
  forall l : natlist,
  true = beq_natlist l l.
Proof.
  intros *.
  induction l; simpl. reflexivity.
  replace (ravno n n) with true. rewrite IHl. reflexivity.
  induction n; simpl. reflexivity.
  rewrite IHn. reflexivity.
Qed.

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

Theorem ble_n_Sn :
  forall n : nat,
  leb n (S n) = true.
Proof.
  intros n. induction n as [| n' IHn'].
  - (* 0 *)
    simpl.  reflexivity.
  - (* S n' *)
    simpl.  rewrite IHn'.  reflexivity.
Qed.


Add LoadPath ".".
Require Import Nat Arith Cpdt.CpdtTactics.

Set Implicit Arguments.
Set Asymmetric Patterns.

Definition var := nat.
Definition vars := var -> nat.
Definition set (vs : vars) (v1 : var) (n : nat) : vars :=
  fun v2 => if beq_nat v1 v2 then n else vs n.

Inductive exp : Set :=
| Const : nat -> exp
| Var : var -> exp
| Plus : exp -> exp -> exp
| Times : exp -> exp -> exp.

Fixpoint evalExp (vs : vars) (e : exp) : nat :=
  match e with
  | Const n => n
  | Var v => vs v
  | Plus e1 e2 => evalExp vs e1 + evalExp vs e2
  | Times e1 e2 => evalExp vs e1 * evalExp vs e2
  end.

Inductive cmd : Set :=
| Assign : var -> exp -> cmd
| Seq : cmd -> cmd -> cmd
| While : exp -> cmd -> cmd
| If : exp -> cmd -> cmd -> cmd.

CoInductive evalCmd : vars -> cmd -> vars -> Prop :=
| EvalAssign : forall vs v e,
    evalCmd vs (Assign v e) (set vs v (evalExp vs e))
| EvalSeq : forall vs1 vs2 vs3 c1 c2,
    evalCmd vs1 c1 vs2 ->
    evalCmd vs2 c2 vs3 ->
    evalCmd vs1 (Seq c1 c2) vs3
| EvalWhileFalse : forall vs e c,
    evalExp vs e = 0 ->
    evalCmd vs (While e c) vs
| EvalWhileTrue : forall vs1 vs2 vs3 e c,
    evalExp vs1 e <> 0 ->
    evalCmd vs1 c vs2 ->
    evalCmd vs2 (While e c) vs3 ->
    evalCmd vs1 (While e c) vs3
| EvalIfFalse : forall vs1 vs2 e c1 c2,
    evalExp vs1 e = 0 ->
    evalCmd vs1 c2 vs2 ->
    evalCmd vs1 (If e c1 c2) vs2
| EvalIfTrue : forall vs1 vs2 e c1 c2,
    evalExp vs1 e <> 0 ->
    evalCmd vs1 c1 vs2 ->
    evalCmd vs1 (If e c1 c2) vs2.

Section evalCmd_coind.
  Variable R : vars -> cmd -> vars -> Prop.

  Hypothesis AssignCase : forall vs1 vs2 v e,
      R vs1 (Assign v e) vs2 ->
      vs2 = set vs1 v (evalExp vs1 e).

  Hypothesis SeqCase : forall vs1 vs3 c1 c2,
      R vs1 (Seq c1 c2) vs3 ->
      exists vs2, R vs1 c1 vs2 /\ R vs2 c2 vs3.

  Hypothesis WhileCase : forall vs1 vs3 e c,
      R vs1 (While e c) vs3 ->
      (evalExp vs1 e = 0 /\ vs1 = vs3) \/
      exists vs2, evalExp vs1 e <> 0 /\ R vs1 c vs2 /\ R vs2 (While e c) vs3.

  Hypothesis IfCase : forall vs1 vs2 e c1 c2,
      R vs1 (If e c1 c2) vs2 ->
      (evalExp vs1 e = 0 /\ R vs1 c2 vs2) \/
      (evalExp vs1 e <> 0 /\ R vs1 c1 vs2).

  Theorem evalCmd_coind : forall vs1 c vs2, R vs1 c vs2 -> evalCmd vs1 c vs2.
    cofix; intros ? ? ? H; destruct c.
    - rewrite (AssignCase H); constructor.
    - destruct (SeqCase H) as [? [? ?]]; econstructor; eauto.
    - destruct (WhileCase H) as [[? ?] | [? [? [? ?]]]]; subst; econstructor; eauto.
    - destruct (IfCase H) as [[? ?] | [? ?]].
      + apply EvalIfFalse; auto.
      + apply EvalIfTrue; auto.
  Qed.
End evalCmd_coind.

Fixpoint optExp (e : exp) : exp :=
  match e with
  | Plus (Const 0) e => optExp e
  | Plus e (Const 0) => optExp e
  | Plus e1 e2 => Plus (optExp e1) (optExp e2)
  | Times (Const 0) _ => Const 0
  | Times _ (Const 0) => Const 0
  (* | Times (Const 1) e => optExp e *)
  (* | Times e (Const 1) => optExp e *)
  | Times e1 e2 => Times (optExp e1) (optExp e2)
  | e => e
  end.

Fixpoint optCmd (c : cmd) : cmd :=
  match c with
  | Assign v e => Assign v (optExp e)
  | Seq c1 c2 => Seq (optCmd c1) (optCmd c2)
  | While e c => While (optExp e) (optCmd c)
  | If e c1 c2 => If (optExp e) (optCmd c1) (optCmd c2)
  end.

Lemma optExp_plus_dist : forall vs e1 e2,
    evalExp vs (optExp (Plus e1 e2)) = evalExp vs (Plus (optExp e1) (optExp e2)).
  induction e1; induction e2; auto; induction n; simpl; auto; induction n0; simpl; auto.
Qed.

Lemma optExp_plus : forall vs e1 e2,
    evalExp vs (optExp (Plus e1 e2)) = evalExp vs (optExp e1) + evalExp vs (optExp e2).
  induction e1; induction e2; auto; induction n; simpl; auto; induction n0; simpl; auto.
Qed.

(*
Lemma optExp_times_const : forall vs e n,
    evalExp vs (optExp (Times e (Const n))) = evalExp vs (optExp e) * n.
  intros; induction e; simpl; crush.
Admitted.

Lemma optExp_const_times : forall vs e n,
    evalExp vs (optExp (Times (Const n) e)) = n * evalExp vs (optExp e).
Admitted.
*)

Lemma optExp_times : forall vs e1 e2,
    evalExp vs (optExp (Times e1 e2)) = evalExp vs (optExp e1) * evalExp vs (optExp e2).
  (* Hint Rewrite optExp_times_const optExp_const_times. *)
  induction e1; induction e2; auto; induction n; auto; induction n0; auto.
    (* rewrite ? optExp_times_const, ? optExp_const_times; auto. *)
Qed.

Lemma optExp_correct : forall vs e, evalExp vs (optExp e) = evalExp vs e.
  induction e; auto; (rewrite optExp_plus || rewrite optExp_times); rewrite IHe1, IHe2; auto.
  (*
  induction e; crush;
    repeat (match goal with
            | [ |- context[match ?E with Const _ => _ | Plus _ _ => _ | _ => _ end] ] =>
              destruct E
            | [ |- context[match ?E with O => _ | S _ => _ end] ] =>
              destruct E
            end; crush).
   *)
Qed.

Hint Rewrite optExp_correct.

Ltac finisher :=
  match goal with
  | [ H : evalCmd _ _ _ |- _ ] => ((inversion H; []) || (inversion H; [|])); subst
  end; crush; eauto 10.

Lemma optCmd_correct1 : forall vs1 c vs2, evalCmd vs1 c vs2 -> evalCmd vs1 (optCmd c) vs2.
  intros;
    apply (evalCmd_coind (fun vs1 c vs2 => exists c', evalCmd vs1 c' vs2 /\ c = optCmd c'));
    eauto; crush;
      match goal with
      | [ H : _ = optCmd ?E |- _ ] =>
        destruct E; simpl in *; discriminate || injection H; intros; subst
      end; finisher.
Qed.

Lemma optCmd_correct2 : forall vs1 c vs2, evalCmd vs1 (optCmd c) vs2 -> evalCmd vs1 c vs2.
  intros; apply (evalCmd_coind (fun vs1 c vs2 => evalCmd vs1 (optCmd c) vs2));
    crush; finisher.
Qed.

Theorem optCmd_correct : forall vs1 c vs2, evalCmd vs1 (optCmd c) vs2 <-> evalCmd vs1 c vs2.
  intuition; apply optCmd_correct1 || apply optCmd_correct2; assumption.
Qed.


Require Import String.
Require Import List.
Import ListNotations.

Definition Var := string.
Open Scope string_scope.

Inductive BExp :=
| btrue : BExp
| bfalse : BExp
| bvar : string -> BExp
| bor : BExp -> BExp ->BExp
| bnot : BExp -> BExp
| band : BExp -> BExp -> BExp.

Fixpoint interpretB (e : BExp) (env : Var -> bool) : bool :=
  match e with
  | btrue => true
  | bfalse => false
  | bvar a => env a
  | bor e1 e2 => orb (interpretB e1 env)  (interpretB e2 env )
  | bnot e1 => negb (interpretB e1 env)
  | band e1 e2 => andb (interpretB e1 env ) (interpretB e2 env)
  end.

Definition env1 := fun x => if string_dec x "n" then true else false.
Check env1.

Compute (interpretB (bor (bnot (bvar "x")) bfalse) env1).

Inductive Instructionb :=
| push_con : bool -> Instructionb
| push_bvar : Var -> Instructionb
| or' : Instructionb
| not' : Instructionb
| and' :Instructionb.

Definition Stackb := list bool.
Fixpoint run_instructionb (i : Instructionb)
         (env : Var -> bool) (stack : Stackb) : Stackb :=
  match i with
  | push_con c => (c :: stack)
  | push_bvar x => ((env x) :: stack)
  | or' => match stack with
           | n1 :: n2 :: stack' => (orb n1  n2) :: stack'
           | _ => stack
           end
  | not' => match stack with
           | n1 :: stack' => (negb n1) :: stack'
           | _ => stack
           end
  | and'  => match stack with
           | n1 :: n2 :: stack' => (andb n1 n2) :: stack'
           | _ => stack
           end
  end.

Compute (run_instructionb (push_con true) env1 []).
Compute (run_instructionb (push_bvar "x") env1 []).
Compute (run_instructionb or' env1 [ true ; false ; true]).
Compute (run_instructionb and' env1 [ false ; true ; true]).

Fixpoint run_instructionsb (is' : list Instructionb)
         (env : Var -> bool) (stack : Stackb) : Stackb :=
  match is' with
  | [] => stack
  | i :: is'' => run_instructionsb is'' env (run_instructionb i env stack)
  end.

Definition pgm1b := [
                    push_con true ;
                    push_bvar "x"
                  ].
Compute run_instructionsb pgm1b env1 [].

Fixpoint compileb (e : BExp) : list Instructionb :=
  match e with
  | btrue => [push_con true]
  | bfalse => [push_con false]
  | bvar x => [push_bvar x]
  | bor e1 e2 => (compileb e1) ++ (compileb e2) ++ [or']
  | band e1 e2 => (compileb e1) ++ (compileb e2) ++ [and']
  | bnot e1 => (compileb e1) ++ [not']
  end.

Compute compileb (btrue).
Compute compileb (band (bvar "x") btrue).
Compute compileb (band (bnot (band btrue (bor btrue bfalse)))(band (bvar "x") btrue)).

Compute interpretB (band (bnot (band btrue (bor btrue bfalse)))(band (bvar "x") btrue)) env1.
Compute run_instructionsb
        (compileb (band (bnot (band btrue (bor btrue bfalse)))(band (bvar "x") btrue)))
        env1
        [].

Lemma orb_comm : forall b1 b2:bool, orb b1 b2 = orb b2 b1.
Proof.
 intros. induction b1. - unfold orb. induction b2. eauto. eauto.
-unfold orb. induction b2. eauto. eauto.
Qed.

Lemma andb_comm : forall b1 b2:bool, andb b1 b2 =andb b2 b1.
Proof.
 intros. induction b1. - unfold andb. induction b2. eauto. eauto.
-unfold orb. induction b2. eauto. eauto.
Qed.

 Lemma soundness_helper :
  forall e env stack is',
    run_instructionsb (compileb e ++ is') env stack =
    run_instructionsb is' env ((interpretB e env) :: stack).

Proof.
  induction e; intros; simpl; trivial.
  - rewrite <- app_assoc.
    rewrite <- app_assoc.
    rewrite IHe1.
    rewrite IHe2.
    simpl.
    eauto. trivial. rewrite orb_comm. reflexivity.
  - rewrite <- app_assoc. induction e.
    rewrite IHe. simpl. eauto. rewrite IHe. simpl. eauto.
    rewrite IHe. simpl. eauto. rewrite IHe. simpl. eauto.
rewrite IHe. simpl. eauto. rewrite IHe. simpl. eauto.
  -rewrite <- app_assoc. rewrite <- app_assoc.
rewrite IHe1. rewrite IHe2. simpl. rewrite andb_comm. reflexivity.
Qed.


Fixpoint factorial (n:nat) : nat :=
  match n with
  | O => S O
  | S n' => mult (S n') (factorial n')
  end.

Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.


Require Import NArith.
Require Import Setoid.

Set Implicit Arguments.
Unset Strict Implicit.
Generalizable All Variables.

Class has_mul A :=
  { mul : A -> A -> A }.

Infix "*" := mul (left associativity, at level 40).

Class is_assoc {A} (r : A -> A -> A) :=
  { assoc : `(r a (r b c) = r (r a b) c) }.

Class semigroup `(has_mul A) `(is_assoc _ mul).

(* TODO: Complete the following in the same vein. *)

(** * Monoids *)
Module Type monoid.
  Include semigroup.

  (** The neutral (unit) element *)
  Variable e : elt.

  (** Multiplication by the unit is identity *)
  Axiom lunit_id : forall a, e * a = a.
  Axiom runit_id : forall a, a * e = a.

  Hint Resolve lunit_id runit_id : monoid.

  (** Exponentiation *)
  Fixpoint pow (a : elt) (n : nat) :=
    match n with
    | 0    => e
    | S n' => pow a n' * a
    end.

  Definition order a n := (forall i, 1 <= i < n -> pow a i <> e) /\ pow a n = e.

  Require Import Coq.Lists.List.
  Import List.ListNotations.

  Fixpoint prod (xs : list elt) :=
    match xs with
    | [] => e
    | x :: xs => prod xs * x
    end.
End monoid.

Module monoid_facts (Import M : monoid).
  (** Square of the unit is unit *)
  Lemma unit2_unit : M.e * M.e = M.e.
  Proof. now rewrite lunit_id. Qed.

  Lemma pow_O : forall a, pow a 0 = M.e.
  Proof. now cbn. Qed.

  Lemma pow_1 : forall a, pow a 1 = a.
  Proof. now intro; cbn; rewrite M.lunit_id. Qed.

  Lemma pow_unit_unit : forall n, pow M.e n = M.e.
  Proof.
    induction n; [trivial |].
    cbn.
    rewrite IHn.
    apply unit2_unit.
  Qed.

  Lemma pow_lmul : forall a n, a * pow a n = pow a (S n).
  Proof.
    induction n; cbn.
    - now rewrite runit_id, lunit_id.
    - rewrite <- assoc, IHn.
      now cbn.
  Qed.

  Lemma pow_rmul : forall a n, pow a n * a = pow a (S n).
  Proof. reflexivity. Qed.

  Lemma pow_sum : forall a m n, pow a m * pow a n = pow a (m + n).
  Proof.
    induction m; intro.
    - apply lunit_id.
    - cbn.
      rewrite assoc, pow_lmul.
      cbn.
      now rewrite <- assoc, IHm.
  Qed.

  Lemma pow_prod : forall a m n, pow (pow a m) n = pow a (m * n).
  Proof.
    induction n.
    - now rewrite Nat.mul_0_r; cbn. (* now cbn; rewrite pow_unit_unit. *)
    - rewrite Nat.mul_succ_r.
      cbn.
      now rewrite IHn,  pow_sum.
  Qed.
End monoid_facts.

(** * Groups *)
Module Type group.
  Include monoid.

  (** The inverse of an element *)
  Variable inv : elt -> elt.
  Notation "a '⁻¹'" := (inv a) (at level 10, format "a '⁻¹'").

  (** The inverse of an element times the element equals the unit *)
  Axiom linv_unit : forall a, a⁻¹ * a = e.
End group.

Module group_facts (Import G : group).
  Module MFacts := monoid_facts G.
  Include MFacts.

  Lemma lcancel : forall a b c, a * b = a * c -> b = c.
  Proof.
    intros.
    rewrite <- (lunit_id b), <- (lunit_id c), <- (linv_unit a).
    now rewrite assoc, H, <- assoc.
  Qed.

  Lemma runit_id : forall a, a * G.e = a.
  Proof.
    intro a.
    apply (lcancel (G.inv a)).
    rewrite <- assoc, linv_unit.
    apply unit2_unit.
  Qed.

  Lemma rinv_unit : forall a, a * a⁻¹ = G.e.
  Proof.
    intros.
    apply (lcancel (G.inv a)).
    rewrite <- assoc, linv_unit.
    now rewrite lunit_id, runit_id.
  Qed.

  Lemma rcancel : forall a b c, b * a = c * a -> b = c.
  Proof.
    intros.
    rewrite <- (runit_id b), <- (runit_id c), <- (rinv_unit a).
    now rewrite <- assoc, <- assoc, H.
  Qed.

  Lemma unit_inv_unit : (G.e)⁻¹ = G.e.
  Proof.
    now rewrite <- (linv_unit G.e) at 2; rewrite runit_id.
  Qed.

  Lemma inv_inv : forall x, (x⁻¹)⁻¹ = x.
  Proof.
    intro x.
    rewrite <- (lunit_id x) at 2; rewrite <- (linv_unit (G.inv x)).
    now rewrite assoc, linv_unit, runit_id.
  Qed.

  Lemma inv_dist : forall a b, (a * b)⁻¹ = b⁻¹ * a⁻¹.
  Proof.
    intros a b.
    apply (lcancel (a * b)).
    rewrite rinv_unit.
    rewrite assoc, <- (assoc _ (G.inv _) (G.inv _)), rinv_unit, lunit_id.
    now rewrite rinv_unit.
  Qed.

  Lemma lmul_unit_is_inv : forall a b, b * a = G.e -> b = G.inv a.
  Proof.
    intros a b H.
    apply (rcancel a).
    now rewrite H, linv_unit.
  Qed.

  Lemma rmul_unit_is_inv : forall a b, a * b = G.e -> b = G.inv a.
  Proof.
    intros a b H.
    apply (lcancel a).
    now rewrite H, rinv_unit.
  Qed.

  Lemma commut_iff : forall a b, a * b * a⁻¹ * b⁻¹ = G.e <-> a * b = b * a.
  Proof.
    split; intro H.
    - rewrite <- lunit_id, <- H.
      rewrite assoc, <- (assoc _ b a), linv_unit, lunit_id.
      now rewrite assoc, linv_unit, runit_id.
    - rewrite assoc, <- inv_dist, H.
      now rewrite rinv_unit.
  Qed.

  Lemma inv_pow : forall a n, pow (a⁻¹) n = (pow a n)⁻¹.
  Proof.
    induction n.
    - cbn.
      now rewrite unit_inv_unit.
    - cbn.
      rewrite IHn, <- inv_dist.
      now rewrite pow_lmul, pow_rmul.
  Qed.
End group_facts.

Module Type group_homo (G H : group).
  Infix "*" := G.op (left associativity, at level 40).
  Infix "#" := H.op (left associativity, at level 40).

  Parameter f : G.elt -> H.elt.

  Axiom homo_spec : forall a b, f (a * b) = f a # f b.
End group_homo.

Module group_homo_facts (G H : group) (Import Homo : group_homo G H).
  Module GFacts := group_facts G.
  Module HFacts := group_facts H.

  Lemma unit_to_unit : f G.e = H.e.
  Proof.
    apply (HFacts.lcancel (f G.e)).
    rewrite <- homo_spec, GFacts.unit2_unit.
    now rewrite HFacts.runit_id.
  Qed.

  Lemma inv_to_inv : forall a, f (G.inv a) = H.inv (f a).
  Proof.
    intro a.
    apply (HFacts.lcancel (f a)).
    rewrite <- homo_spec, GFacts.rinv_unit.
    now rewrite HFacts.rinv_unit, unit_to_unit.
  Qed.
End group_homo_facts.

Module Type group_direct_prod (G H : group) <: group.
  Definition elt := (G.elt * H.elt)%type.
  Definition e := (G.e, H.e).

  Definition op g h :=
    match g, h with
    | (a, b), (c, d) => (G.op a c, H.op b d)
    end.

  Definition inv a :=
    match a with
    | (g, h) => (G.inv g, H.inv h)
    end.

  Local Infix "*" := op (left associativity, at level 40).

  Lemma assoc : forall a b c, a * b * c = a * (b * c).
  Proof.
    intros [a b] [c d] [e f]; cbn.
    now rewrite G.assoc, H.assoc.
  Qed.

  Lemma lunit_id : forall a, e * a = a.
  Proof.
    intros [a b]; cbn.
    now rewrite G.lunit_id, H.lunit_id.
  Qed.

  Lemma linv_unit : forall a, inv a * a = e.
  Proof.
    intros [a b]; cbn.
    now rewrite G.linv_unit, H.linv_unit.
  Qed.

End group_direct_prod.