Section C2_1.

  Parameter (A : Type) (R : A -> A -> Prop) (f : A -> A) (a : A).

  Hypothesis Hf : forall x y, R x y -> R x (f y).
  Hypothesis R_refl : forall x, R x x.

  (* Variables x : A. *)

  Lemma Lf : forall x, R x (f (f (f x))).
  Proof.
(*    intro x.
    apply Hf.
    apply Hf.
    apply Hf.
    apply R_refl. *)
    intro; repeat apply Hf; apply R_refl.
  Qed.

End C2_1.

Require Import Arith.

Section C2_2.

  Check lt_n_Sn.
  Check lt_trans.

  Lemma lt_n_SSn : forall i, i < S (S i).
  Proof.
    intro i.
    do 1 apply lt_trans with (2 := lt_n_Sn _).
    apply lt_n_Sn.
  Qed.

  Lemma greater : forall n, exists p, n < p.
  Proof.
    intros n.
    exists (S (S n)).
    apply lt_n_SSn.
  Qed.

  Print greater.

  Section absurd.

    Hypothesis H : exists n, forall p, p < n.

    Lemma absurd : False.
    Proof.
      destruct H as [ m Hm ].
      apply (lt_irrefl m).
      apply Hm.
    Qed.

  End absurd.

  Lemma L36 : 9 * 4 = 3 * 12.
  Proof.
    reflexivity.
  Qed.

  Variable (A : Type).

  Lemma eq_trans_on_A (x y z : A) : x = y -> y = z -> x = z.
  Proof.
    intros H1 H2.
    (* rewrite H1, <- H2; reflexivity. *)
    (* now rewrite H1. (* is the same as rewrite H1; easy. *) *)
    (* subst; reflexivity. *)
    (* symmetry; transitivity y; symmetry; trivial. *)
    replace z with y; trivial.
  Qed.

  Lemma L1 : forall x y : nat,
       x = S (S y) -> 2 <= x * x.
  Proof.
    intros x y H.
    pattern x at 1.
    rewrite H.
  Admitted.

End C2_2.

Section C2_3.

  Variable f : nat -> nat -> nat.

  Hypothesis f_comm : forall x y, f x y = f y x.

  Lemma L : forall x y z, f (f x y) z = f z (f y x).
  Proof.
    intros x y z.
    rewrite (f_comm x y).
    rewrite (f_comm _ z).
    reflexivity.
  Qed.

End C2_3.

Require Import Omega Lia.

Lemma L' : forall n, n < 2 -> n = 0 \/ n = 1.
Proof.
  intros; lia.
Qed.

Lemma L2 : forall i, i < 2 -> i*i = i.
Proof.
  intros i H.
  destruct L' with (1 := H); subst i; trivial.
Qed.

Lemma or_comm : forall P Q : Prop, P \/ Q -> Q \/ P.
Proof.
  intros ? ? []; [ right | left ]; assumption.
Qed.

Lemma not_ex_all_not : forall (A : Type) (P : A -> Prop),
  (~ exists a:A, P a) -> forall a, ~ P a.
Proof.
  intros A P H a H1.
  unfold not in *.
  apply H.
  exists a.
  trivial.
Qed.

Lemma all_not_not_ex (A : Type) (P : A -> Prop) :
  (forall a, ~ P a) -> ~ exists a:A, P a.
Proof.
  intros H (x & Hx).
  apply (H x), Hx.
Qed.

Lemma test_students : exists P : nat -> Prop, P 0 /\ ~ P 1.
Proof.
 (*  exists (fun x => x < 1); lia. *)

  exists (fun x : nat => 0 = x); lia.
 (* split.
  + reflexivity.
  + discriminate. *)
Qed.

Fixpoint factorial n :=
  match n with
    | 0 => 1
    | S n => (S n) * factorial n
  end.

Lemma factorial_prop n : forall p, 0 < p <= n -> exists q, factorial n = q * p.
Proof.
  induction n as [ | n IHn ].
Admitted.

Lemma exf : exists f : nat -> nat,
  forall n p, 0 < p -> p <= n -> exists q, f n = q * p.
Proof.
  exists (fun _ => 0).
  intros n p _ _.
  exists 0.
  simpl.
  reflexivity.
Qed.

Section HO.

  Variables (A : Type) (f : A -> A)
            (f_self_inverse : forall a, f (f a) = a).

  Lemma f_onto : forall b, exists a, b = f a.
  Proof.
    intros b.
    exists (f b).
    rewrite f_self_inverse.
    reflexivity.
  Qed.

End HO.

Require Import ZArith Ring.

Open Scope Z_scope.

Section Z_sect.

  Variable f : Z -> Z -> Z -> Z.

  Goal forall x y z, f (x+y) z 0 = f (y+x+0) (z*(1+0)) (x-x).
  Proof.
    intros x y z.
    f_equal; ring.
    (*
      replace (x+y) with (y+x+0).
      replace z with (z*(1+0)) at 1.
      replace 0 with (x-x) at 3.
      reflexivity. *)
  Qed.

End Z_sect.

Require Import Setoid.

Section rewrite_equivalence.

  Variable (A : Type) (P Q : A -> Prop).
  Hypothesis E : forall a : A, P a <-> ~ Q a.

  Goal (exists a, P a) -> ~ (forall x, Q x).
  Proof.
    intros (x & Hx) H1.
    rewrite E in Hx.
    apply Hx, H1.
  Qed.

Print L2.

  Check N.

  Print Lf.


Require Import bool.
Require Import nat.
Require Import syntax.
Require Import eval.
Require Import state.
Require Import dictionary.
Require Import equiv.

Definition atrans_sound (atrans:aexp -> aexp) : Prop :=
    forall (a:aexp), aequiv a (atrans a).

Definition btrans_sound (btrans:bexp -> bexp) : Prop :=
    forall (b:bexp), bequiv b (btrans b).

Definition ctrans_sound (ctrans:com -> com) : Prop :=
    forall (c:com), cequiv c (ctrans c).

Fixpoint btrans (fa:aexp -> aexp) (b:bexp) : bexp :=
    match b with
    | BTrue         => BTrue
    | BFalse        => BFalse
    | BEq a1 a2     =>
        match (fa a1, fa a2) with
        | (ANum n1, ANum n2)        => if eqb n1 n2 then BTrue else BFalse
        | (a1', a2')                => BEq a1' a2'
        end
    | BLe a1 a2     =>
        match (fa a1, fa a2) with
        | (ANum n1, ANum n2)        => if leb n1 n2 then BTrue else BFalse
        | (a1', a2')                => BLe a1' a2'
        end
    | BNot b1       =>
        match (btrans fa b1) with
        | BTrue     => BFalse
        | BFalse    => BTrue
        | b1'       => BNot b1'
        end
    | BAnd b1 b2    =>
        match (btrans fa b1, btrans fa b2) with
        | (BTrue, BTrue)    => BTrue
        | (BTrue, BFalse)   => BFalse
        | (BFalse, BTrue)   => BFalse
        | (BFalse, BFalse)  => BFalse
        | (b1', b2')        => BAnd b1' b2'
        end
    end.

Fixpoint ctrans (fa:aexp -> aexp)(fb:bexp -> bexp)(c:com) : com :=
    match c with
    | SKIP          => SKIP
    | k ::= a       => k ::= (fa a)
    | c1 ;; c2      => (ctrans fa fb c1) ;; (ctrans fa fb c2)
    | CIf b c1 c2   => match (fb b) with
                       | BTrue      => ctrans fa fb c1
                       | BFalse     => ctrans fa fb c2
                       | b'         => CIf b' (ctrans fa fb c1)
                                              (ctrans fa fb c2)
                       end
    | CWhile b c1   => match (fb b) with
                       | BTrue      => CWhile BTrue SKIP (* oo-loop all the same *)
                       | BFalse     => SKIP
                       | b'         => CWhile b' (ctrans fa fb c1)
                       end
    end.

Theorem ctrans_is_sound : forall (fa:aexp -> aexp) (fb:bexp -> bexp),
    atrans_sound fa -> btrans_sound fb -> ctrans_sound (ctrans fa fb).
Proof.
    intros fa fb Ha Hb. unfold ctrans_sound. intros c. induction c;
    try (apply refl_cequiv);
    try (apply CAss_congruence; apply Ha);
    try (apply CSeq_congruence; assumption).
    - destruct (fb b) eqn:E; simpl;
        try (rewrite E; apply CIf_congruence;
                try (assumption);
                try (rewrite <- E; apply Hb)
            ).
        + apply trans_cequiv with c1.
            { apply if_true. rewrite <- E. apply Hb. }
            { rewrite E. assumption. }
        + apply trans_cequiv with c2.
            { apply if_false. rewrite <- E. apply Hb. }
            { rewrite E. assumption. }
    - destruct (fb b) eqn:E; simpl; rewrite E;
        try ( apply CWhile_congruence; try (assumption);
              rewrite <- E; apply Hb
            ).
        + apply while_true. rewrite <- E. apply Hb.
        + apply while_false. rewrite <- E. apply Hb.
Qed.

Theorem btrans_is_sound : forall (fa:aexp -> aexp),
    atrans_sound fa -> btrans_sound (btrans fa).
Proof.
    intros fa Ha b e. induction b;
    try (reflexivity).
    - simpl; rename a into a1; rename a0 into a2;
      destruct (fa a1) eqn:E1, (fa a2) eqn:E2;
      try (rewrite <- E1, <- E2, (Ha a1), (Ha a2); reflexivity).
      rewrite (Ha a1), (Ha a2), E1, E2; simpl; destruct (eqb n n0); reflexivity.
    - simpl; rename a into a1; rename a0 into a2;
      destruct (fa a1) eqn:E1, (fa a2) eqn:E2;
      try (rewrite <- E1, <- E2, (Ha a1), (Ha a2); reflexivity).
      rewrite (Ha a1), (Ha a2), E1, E2; simpl; destruct (leb n n0); reflexivity.
    - simpl. destruct (btrans fa b); rewrite IHb; reflexivity.
    - simpl. destruct (btrans fa b1), (btrans fa b2); rewrite IHb1, IHb2;
        reflexivity.
Qed.

Lemma compose_aexp_sound : forall (f g:aexp -> aexp),
    atrans_sound f -> atrans_sound g -> atrans_sound (fun x => g (f x)).
Proof.
    intros f g Hf Hg. unfold atrans_sound, aequiv. intros a e.
    apply eq_trans with (aeval e (f a)).
    - apply Hf.
    - apply Hg.
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 List Arith Max Omega Wellfounded Bool.

Require Import list_focus utils_tac utils_list.

Set Implicit Arguments.

Fact interval_dec a b i : { a <= i < b } + { i < a \/ b <= i }.
Proof.
  destruct (le_lt_dec b i).
  right; omega.
  destruct (le_lt_dec a i).
  left; omega.
  right; omega.
Qed.

Definition lsum := fold_right plus 0.
Definition lmax := fold_right max 0.

Fact lsum_app l r : lsum (l++r) = lsum l+lsum r.
Proof.
  induction l as [ | x l IHl ]; simpl; auto; rewrite IHl; omega.
Qed.

Section new.

  Definition nat_new l := S (lmax l).

  Fact nat_new_spec l : ~ In (nat_new l) l.
  Proof.
    assert (forall x, In x l -> x < nat_new l) as H.
      induction l as [ | x l IHl ].
      intros _ [].
      intros y [ [] | Hy ]; apply le_n_S;
        [ apply le_max_l | ].
      apply IHl, le_S_n in Hy.
      apply le_trans with (1 := Hy), le_max_r.
    intros C; apply H in C; omega.
  Qed.

End new.

Local Notation Zero := false.
Local Notation One  := true.

Fixpoint div2 n : nat * bool :=
  match n with
    | 0 => (0,Zero)
    | 1 => (0,One)
    | S (S n) => let (p,b) := div2 n in (S p,b)
  end.

Fact div2_spec n : match div2 n with
                     | (p,One)  => n = 2*p+1
                     | (p,Zero) => n = 2*p
                   end.
Proof.
  induction n as [ [ | [ | n ] ] IHn ] using (well_founded_induction lt_wf); simpl; auto.
  specialize (IHn n).
  destruct (div2 n) as (p,[]); simpl in * |- *; omega.
Qed.

Fixpoint div2_2p1 p : div2 (2*p+1) = (p,One).
Proof.
  destruct p as [ | p ].
  simpl; auto.
  replace (2*S p+1) with (S (S (2*p+1))) by omega.
  unfold div2; fold div2; rewrite div2_2p1; auto.
Qed.

Fixpoint div2_2p0 p : div2 (2*p) = (p,Zero).
Proof.
  destruct p as [ | p ].
  simpl; auto.
  replace (2*S p) with (S (S (2*p))) by omega.
  unfold div2; fold div2; rewrite div2_2p0; auto.
Qed.

Fixpoint pow2 p :=
  match p with
    | 0   => 1
    | S p => 2*pow2 p
  end.

Section pow2_bound.

  Let loop := fix loop x n :=
    match n with
      | 0 => 0
      | S n => match div2 x with
                 | (0,_) => 0
                 | (p,_) => S (loop p n)
               end
    end.

  Let loop_prop n : forall x, x < n -> x < pow2 (S (loop x n)).
  Proof.
    induction n as [ | n IHn ]; intros x Hx.
    omega.
    unfold loop; fold loop.
    generalize (div2_spec x).
    destruct (div2 x) as ([ | p ],[]); intros H.
    simpl; omega.
    simpl; omega.
    specialize (IHn (S p)); spec in IHn.
    omega.
    simpl in IHn |- *; omega.
    specialize (IHn (S p)); spec in IHn.
    omega.
    simpl in IHn |- *; omega.
  Qed.

  Definition find_pow2 x := S (loop (pred x) x).

  Fact find_pow2_geq x : 1 <= find_pow2 x.
  Proof. unfold find_pow2; omega. Qed.

  Fact find_pow2_prop x : x <= pow2 (find_pow2 x).
  Proof.
    unfold find_pow2; destruct x.
    simpl; omega.
    apply loop_prop; auto.
  Qed.

End pow2_bound.

Section nat_sorted.

  Definition nat_sorted ll := forall l a m b r, ll = l ++ a :: m ++ b :: r -> a < b.

  Fact in_nat_sorted_0 : nat_sorted nil.
  Proof. intros [] ? ? ? ? ?; discriminate. Qed.

  Fact in_nat_sorted_1 x : nat_sorted (x::nil).
  Proof. intros [ | ? [] ] ? [] ? ? ?; discriminate. Qed.

  Fact in_nat_sorted_2 x y ll : x < y -> nat_sorted (y::ll) -> nat_sorted (x::y::ll).
  Proof.
    intros H1 H2 l a m b r H3.
    destruct l as [ | u l ].
    inversion H3; subst.
    destruct m as [ | v m ].
    inversion H4; subst; auto.
    inversion H4; subst.
    apply lt_trans with (1 := H1), (H2 nil _ m _ r); auto.
    inversion H3; subst.
    apply (H2 l _ m _ r); auto.
  Qed.

  Fact in_nat_sorted_3 x ll : Forall (lt x) ll -> nat_sorted ll -> nat_sorted (x::ll).
  Proof.
    induction 1 as [ | y ll Hll IHl ].
    intro; apply in_nat_sorted_1.
    intros H.
    apply in_nat_sorted_2; auto.
  Qed.

  Fact nat_sorted_cons_inv x ll : nat_sorted (x::ll) -> nat_sorted ll.
  Proof. intros H l a m b r ?; apply (H (x::l) _ m _ r); subst; solve list eq. Qed.

  Fact nat_sorted_Forall x ll : nat_sorted (x::ll) -> Forall (lt x) ll.
  Proof.
    rewrite Forall_forall; intros H y Hy.
    apply in_split in Hy.
    destruct Hy as (l & r & ?); subst.
    apply (H nil _ l _ r); auto.
  Qed.

  Fact nat_sorted_head_inv x y ll : nat_sorted (x::y::ll) -> x < y.
  Proof. intros H; apply (H nil _ nil _ ll); solve list eq. Qed.

  Variable P : list nat -> Type.

  Hypothesis (HP0 : P nil).
  Hypothesis (HP1 : forall x, P (x::nil)).
  Hypothesis (HP2 : forall x y l, x < y -> P (y::l) -> P (x::y::l)).

  Theorem nat_sorted_rect l : nat_sorted l -> P l.
  Proof.
    induction l as [ [ | x [ | y l ] ] IHl ] using (measure_rect (@length _)).
    intro; apply HP0.
    intro; apply HP1.
    intros H; apply HP2.
    revert H; apply nat_sorted_head_inv.
    apply IHl.
    rew length; omega.
    revert H; apply nat_sorted_cons_inv.
  Qed.

End nat_sorted.

Fact nat_sorted_injective ll : nat_sorted ll -> list_injective ll.
Proof.
  intros H l a m b r E; generalize (H _ _ _ _ _  E); omega.
Qed.

Fixpoint nat_list_insert x l :=
  match l with
    | nil  => x::nil
    | y::l => if x <? y then x::y::l else
              if y <? x then y::nat_list_insert x l else y::l
  end.

Fact nat_list_insert_length x l : length (nat_list_insert x l) <= S (length l).
Proof.
  induction l as [ | y l IHl ]; simpl.
  omega.
  destruct (x <? y); simpl; try omega.
  destruct (y <? x); simpl; omega.
Qed.

Fact nat_list_insert_incl x l : incl (nat_list_insert x l) (x::l)
                             /\ incl (x::l) (nat_list_insert x l).
Proof.
  split.

  induction l as [ | y l IHl ]; simpl.
  intro; auto.
  destruct (x <? y); destruct (y <? x).
  intro; auto.
  intro; auto.
  intros ? [ [] | H ]; simpl; auto.
  apply IHl in H; simpl in H; tauto.
  intro; simpl; tauto.

  induction l as [ | y l IHl ]; simpl.
  intro; auto.
  generalize (Nat.ltb_lt x y) (Nat.ltb_lt y x).
  destruct (x <? y); destruct (y <? x); intros H1 H2 z; auto.
  intros [ Hz | [ Hz | Hz ] ]; subst.
  right; apply IHl; left; auto.
  left; auto.
  right; apply IHl; right; auto.
  destruct (lt_eq_lt_dec x y) as [ [ H | ] | H ].
  apply H1 in H; discriminate.
  2: apply H2 in H; discriminate.
  intros [ Hz | [ Hz | Hz ] ]; subst; auto.
  left; auto.
  left; auto.
  right; auto.
Qed.

Fact nat_list_insert_Forall (P : nat -> Prop) x l :
      P x -> Forall P l -> Forall P (nat_list_insert x l).
Proof.
  do 2 rewrite Forall_forall; intros H1 H2 y Hy.
  apply nat_list_insert_incl in Hy.
  destruct Hy; subst; auto.
Qed.

Fact nat_list_insert_sorted x l : nat_sorted l -> nat_sorted (nat_list_insert x l).
Proof.
  induction l as [ | y l IHl ]; simpl.
  intro; apply in_nat_sorted_1.
  intros H.
  generalize (Nat.ltb_lt x y) (Nat.ltb_lt y x).
  destruct (x <? y); destruct (y <? x); intros H1 H2.
  apply proj1 in H1; spec in H1; auto.
  apply proj1 in H2; spec in H2; auto.
  omega.
  apply in_nat_sorted_2; auto; tauto.
  apply in_nat_sorted_3.
  apply nat_list_insert_Forall.
  tauto.
  apply nat_sorted_Forall; auto.
  apply IHl; revert H; apply nat_sorted_cons_inv.
  auto.
Qed.

Definition nat_sort := fold_right (nat_list_insert) nil.

Fact nat_sort_length l : length (nat_sort l) <= length l.
Proof.
  induction l as [ | x l IHl ]; simpl.
  omega.
  apply le_trans with (1 := nat_list_insert_length _ _); omega.
Qed.

Fact nat_sort_eq l : incl (nat_sort l) l /\ incl l (nat_sort l).
Proof.
  induction l as [ | x l IHl ]; simpl; split; intros y Hy; auto.
  apply nat_list_insert_incl in Hy; simpl.
  destruct Hy as [ | Hy ]; auto; right; apply IHl; auto.
  apply nat_list_insert_incl.
  destruct Hy; [ left | right ]; auto.
  apply IHl; auto.
Qed.

Fact nat_sort_sorted l : nat_sorted (nat_sort l).
Proof.
  induction l as [ | x l IHl ].
  apply in_nat_sorted_0.
  simpl; apply nat_list_insert_sorted; auto.
Qed.

Fact nat_sinc (f : nat -> nat) a b :
      (forall x, a <= x < b -> f x < f (S x))
   -> (forall x y, a <= x < y /\ y <= b -> f x < f y).
Proof.
  intros H1.
  assert (forall n m, n <= m <= b - a -> f (a+n) <= f (a+m)) as H2.
    intros n m (H2 & H3); revert H2 H3.
    induction 1 as [ | m Hm IH ]; auto.
    intros H. spec in IH. omega.
    apply le_trans with (1 := IH).
    replace (a+S m) with (S (a+m)) by omega.
    apply lt_le_weak, H1; omega.
  assert (forall n m, n < m <= b - a -> f (a+n) < f (a+m)) as H3.
    unfold lt at 1; intros n m H.
    specialize (H1 (a+n)).
    spec in H1.
    omega.
    apply lt_le_trans with (1 := H1).
    replace (S (a+n)) with (a+S n) by omega.
    apply H2; auto.
  intros x y H4.
  replace x with (a+(x-a)) by omega.
  replace y with (a+(y-a)) by omega.
  apply H3.
  omega.
Qed.

Fact nat_sinc_inj f a b :
      (forall x y,  a <= x < y /\ y <= b -> f x < f y)
   -> (forall x y,  a <= x <= b -> a <= y <= b -> f x = f y -> x = y).
Proof.
  intros H0 x y Hx Hy.
  destruct Hx; destruct Hy.
  destruct (lt_eq_lt_dec x y) as [ [ ? | ? ] | ? ]; auto.
  specialize (H0 x y).
  spec in H0; repeat split; auto; intro; omega.
  specialize (H0 y x).
  spec in H0; repeat split; auto; intro; omega.
Qed.


(* Based on the imp example in coind,
   extracted to a single-file.
 *)
(* Developed with Coq 8.9.1 *)

Require Import String.
Require Import ZArith.
Require Import List.

Set Implicit Arguments.

Local Open Scope Z.
Import List.ListNotations.
Local Open Scope list.
Local Open Scope string.

(** * The syntax of IMP programs *)

Inductive AExp :=
  | var : string -> AExp
  | con : Z -> AExp
  | div : AExp -> AExp -> AExp
  | plus : AExp -> AExp -> AExp
  .

Inductive BExp :=
  | bcon : bool -> BExp
  | le : AExp -> AExp -> BExp
  | not : BExp -> BExp
  | and : BExp -> BExp -> BExp
  .

Inductive Stmt :=
  | assign : string -> AExp -> Stmt
  | cond : BExp -> Stmt -> Stmt -> Stmt
  | while : BExp -> Stmt -> Stmt
  | seq : Stmt -> Stmt -> Stmt
  | skip : Stmt
  .

Inductive Pgm :=
    pgm : list string -> Stmt -> Pgm.

(** Here is the sum program *)
Definition sum_pgm N : Pgm :=
 pgm ["n"; "sum"]
(seq (assign "n" (con N))
(seq (assign "sum" (con 0))
     (while (not (le (var "n") (con 0)))
     (seq (assign "sum" (plus (var "sum") (var "n")))
          (assign "n" (plus (var "n") (con (-1)))))))).

(** * The semantics of IMP programs *)

Definition Env := list (string * Z).
Definition empty_env : Env := [].
Fixpoint get x (env:Env) :=
  match env with
  | [] => None
  | (x',v)::env' =>
    if string_dec x x' then Some v else get x env'
  end.
Fixpoint set x v (env:Env) :=
  match env with
  | [] => []
  | (x',v')::env' =>
    if string_dec x x' then (x,v)::env' else (x',v')::set x v env'
  end.
  (* "simpl" should reduce set if concrete values are given for both variables *)

(* ** These "step" types together define single execution steps  *)
Inductive step_e : (AExp * Env) -> (AExp * Env) -> Prop :=
  | step_var: forall v x env, get v env = Some x ->
      step_e (var v, env) (con x, env)
  | step_plus: forall x y env,
      step_e (plus (con x) (con y), env) (con (Z.add x y), env)
  | step_div: forall x y env,
      y <> 0%Z ->
      step_e (div (con x) (con y), env) (con (Z.div x y), env)
  | cong_plus_r: forall e1 e2 e2' env env',
      step_e (e2, env) (e2', env') ->
      step_e (plus e1 e2, env) (plus e1 e2', env')
  | cong_plus_l: forall e2 e1 e1' env env',
      step_e (e1, env) (e1', env') ->
      step_e (plus e1 e2, env) (plus e1' e2, env')
  | cong_div_r: forall e1 e2 e2' env env',
      step_e (e2, env) (e2', env') ->
      step_e (div e1 e2, env) (div e1 e2', env')
  | cong_div_l: forall e2 e1 e1' env env',
      step_e (e1, env) (e1', env') ->
      step_e (div e1 e2, env) (div e1' e2, env')
  .

(* These abbreviations capture the pattern of the congruence rules *)
Notation cong_l op R1 R2 :=
  (forall a env a' env', R1 (a,env) (a',env') ->
   forall b, R2 (op a b, env) (op a' b, env')).
Notation cong_r op nf R1 R2 :=
  (forall b env b' env', R1 (b,env) (b',env') ->
   forall a, R2 (op (nf a) b, env) (op (nf a) b', env')).
Notation cong_1 op R1 R2 :=
  (forall a env a' env', R1 (a,env) (a',env') -> R2 (op a, env) (op a', env')).

Inductive step_b : (BExp * Env) -> (BExp * Env) -> Prop :=
  | eval_le : forall v1 v2 env,
      step_b (le (con v1) (con v2), env) (bcon (Z.leb v1 v2), env)
  | eval_not : forall b env,
      step_b (not (bcon b), env) (bcon (negb b), env)
  | eval_and : forall b e env,
      step_b (and (bcon b) e, env) (if b then e else bcon false, env)
  | cong_le_r : cong_r le con step_e step_b
  | cong_le_l : cong_l le step_e step_b
  | cong_not : cong_1 not step_b step_b
  | cong_and : cong_l and step_b step_b
  .

Inductive step_s : (Stmt * Env) -> (Stmt * Env) -> Prop :=
  | exec_assign : forall x v v0 env,  get x env = Some v0 ->
      step_s (assign x (con v),env) (skip, set x v env)
  | cong_assign : forall x,
      cong_1 (assign x) step_e step_s
  | exec_seq : forall s env,
      step_s (seq skip s,env) (s,env)
  | cong_seq : cong_l seq step_s step_s
  | exec_cond : forall b s1 s2 env,
      step_s (cond (bcon b) s1 s2, env) (if b then s1 else s2, env)
  | cong_cond : forall b b' env env' s1 s2, step_b (b,env) (b',env') ->
      step_s (cond b s1 s2,env) (cond b' s1 s2,env')
  | exec_while : forall b s env,
      step_s (while b s,env) (cond b (seq s (while b s)) skip, env)
  .

Inductive step_p : (Pgm * Env) -> (Pgm * Env) -> Prop :=
  | exec_init: forall x xs s env,
      step_p (pgm (x::xs) s,env) (pgm xs s, (x,0)::env)
  | exec_body: forall s env s' env',
      step_s (s, env) (s', env') ->
      step_p (pgm nil s, env) (pgm nil s', env')
  .

(** Now we verify the program *)
Require Import proof_system.

(** The claim about the loop says that running the loop in any enviroment
    with a non-negative n finishes with n set to zero, and sum increased
    from it's original value by the sum of numbers 0+1+...+n.
 *)
Inductive sum_spec : Spec (Pgm * Env) :=
 | sum_claim: forall n, 0 <= n ->
   sum_spec
     (pgm ["n"; "sum"]
       (seq (assign "n" (con n))
       (seq (assign "sum" (con 0))
            (while (not (le (var "n") (con 0)))
            (seq (assign "sum" (plus (var "sum") (var "n")))
                 (assign "n" (plus (var "n") (con (-1))))))))
     ,[])
     (fun cfg' => cfg' = (pgm [] skip, [("sum",((n + 1) * n)/2);("n",0)]))
 | sum_loop_claim : forall env n, get "n" env = Some n -> 0 <= n ->
                    forall s, get "sum" env = Some s ->
      sum_spec
         (pgm []
           (while (not (le (var "n") (con 0)))
             (seq (assign "sum" (plus (var "sum") (var "n")))
                  (assign "n" (plus (var "n") (con (-1))))))
         ,env)
      (fun cfg' => fst cfg' = pgm [] skip /\
         snd cfg' = set "n" 0 (set "sum" (s + ((n + 1) * n)/2) env)).

(* Some lemmas about enviroment stuff *)
Ltac env_ind_tac env :=
  induction env as [|[]];try reflexivity;simpl;
  repeat match goal with
  | [ |- context [string_dec ?a ?b]] => destruct (string_dec a b);simpl;try congruence
  end.

Lemma env_set_id: forall x v env,
    get x env = Some v ->
    set x v env = env.
Proof.
  env_ind_tac env.
  intro. f_equal. tauto.
Qed.

Lemma env_set_eq:
  forall x v1 v2 env,
    set x v1 (set x v2 env) = set x v1 env.
Proof. env_ind_tac env. Qed.

Lemma env_set_ne_comm:
  forall x1 x2, x1 <> x2 ->
  forall v1 v2 env,
    set x1 v1 (set x2 v2 env) = set x2 v2 (set x1 v1 env).
Proof. env_ind_tac env. Qed.

Lemma env_set_set: forall x1 x2 v1 v2 env,
    set x1 v1 (set x2 v2 env) =
    if string_dec x1 x2
    then set x1 v1 env
    else set x2 v2 (set x1 v1 env).
Proof. env_ind_tac env. Qed.

Definition env_has x env: bool :=
  match get x env with
  | Some _ => true
  | None => false
  end.

Lemma env_has_get x v env:
  get x env = Some v ->
  env_has x env = true.
Proof.
  unfold env_has;intros ->;reflexivity.
Qed.

Lemma env_get_set x x' v env:
  get x (set x' v env) =
  if string_dec x x'
  then if env_has x env then Some v else None
  else get x env.
Proof. unfold env_has; env_ind_tac env. Qed.

Lemma env_has_set x x' v env:
  env_has x (set x' v env) = env_has x env.
Proof.
  unfold env_has.
  rewrite env_get_set.
  unfold env_has.
  destruct (string_dec x x');[|reflexivity].
  destruct (get x env);reflexivity.
Qed.

Ltac step_tac :=
  match goal with
  | [ |- step_p _ _] => econstructor;step_tac
  | [ |- step_s _ _] => econstructor;step_tac
  | [ |- step_b _ _] => econstructor;step_tac
  | [ |- step_e _ _] => econstructor;step_tac
  | [ |- get _ _ = _] => rewrite ?env_get_set;(reflexivity || eassumption)
  end.

Ltac run := repeat first[
   eapply dtrans;[constructor|]
  |eapply ddone;simpl;split;[reflexivity|]
  |eapply dstep;[step_tac|]].

Require Import Recdef.
Function sum_to (n:Z) { wf (fun x y => 0 <= x < y) n } : Z :=
  if Z_lt_ge_dec 0 n then n + sum_to (n - 1) else 0.
intros;omega.
exact (Z.lt_wf 0).
Defined.

Lemma sum_algebra: forall s n, 0 < n ->
  s + n + (n + -1 + 1) * (n + -1) / 2
           = s + (n + 1) * n / 2.
Proof.
  intros s n H.
  rewrite <- Z.add_assoc.
  f_equal.
  rewrite <- Z.add_assoc, Z.add_0_r.
  rewrite <- Z.div_add_l by omega.
  f_equal.
  rewrite Z.mul_add_distr_r, Z.mul_add_distr_l.
  omega.
Qed.

Lemma sum_ok : sound step_p sum_spec.
apply proved_sound;destruct 1.

{ (* Overall claim, easily proved with loop claim *)
  eapply sstep;[solve[step_tac]|].
  run;[reflexivity || assumption ..|].
  destruct k';simpl.
  destruct 1 as [-> ->].
  apply ddone.
  reflexivity.
}

eapply sstep;[solve[step_tac]|].
run.
destruct (Z.leb_spec n 0);simpl.

(* when n = 0, loop exits.
   To conclude, need to prove that the initial
   environment env is an acceptable result *)
run.
replace n with 0 in H |- * by auto with zarith.
rewrite (env_set_id "sum") by (rewrite H1;f_equal;auto with zarith).
rewrite (env_set_id "n") by assumption.
reflexivity.

(* when n > 0, execution goes through the loop body,
   then sum_loop_claim is applied by transitivity,
   which takes us to a state satisfying the goal *)
run.
{ rewrite env_get_set, ?env_has_set.
  simpl.
  erewrite env_has_get by eassumption;reflexivity. }
  omega.
{ rewrite !env_get_set.
  simpl.
  erewrite env_has_get by eassumption;reflexivity. }
destruct k';simpl;intros [-> ->].

run.
rewrite (env_set_set "sum" "n"). simpl.
rewrite 2 env_set_eq.
f_equal.
f_equal.
apply sum_algebra.
assumption.
Qed.


Variables A B C : Prop.
Lemma ex6 : ((A -> B) /\ (A -> C)) -> A -> (B /\ C).
Proof.
  intro HaImpliesHb_and_HaImpliesHc.
  destruct HaImpliesHb_and_HaImpliesHc as [Ha_implies_Hb Ha_implies_Hc].
  intro Ha.
  split.
    +
      apply Ha_implies_Hb.
      assumption.
    +
      apply Ha_implies_Hc.
      assumption.
Qed.


Require Export P02.

(** ** Exercise: Power Series *)

(** **** Exercise: 4 stars, optional (dpow2_down)  *)
(** Here is a program that computes the series:
    [1 + 2 + 2^2 + ... + 2^m = 2^(m+1) - 1]

  X ::= 0;;
  Y ::= 1;;
  Z ::= 1;;
  WHILE X <> m DO
    Z ::= 2 * Z;;
    Y ::= Y + Z;;
    X ::= X + 1
  END

I = > Y = 2^X - 1 + Z /\ Z = 2^X

    {{ True }} ->>
    {{ I [X |-> 0] [Y |-> 1] [Z |-> 1] }} // {{ 1 = 1 /\ 1 = 1}}
  X ::= 0;;
    {{ I [Y |-> 1] [Z |-> 2 * Z] }} // {{ 1 = 2^X /\ 1 = 2^X}}
  Y ::= 1;;
    {{ I [Z |-> 1] }} // {{ Y = 2^X /\ 1 = 2^X }}
  Z ::= 1;;
    {{ I }} // {{ Y = 2^X - 1 + Z /\ Z = 2^X }}
  WHILE X <> m DO
      {{ I /\ X <> m}} ->>
      {{ I [Z |-> 2 * Z] [Y |-> Y + Z] [X |-> X + 1] }} // {{ Y + 2 * Z = 2^(X+1) - 1 + 2 * Z /\ 2 * Z = 2^(X+1) }}
    Z ::= 2 * Z;;
      {{ I [Y |-> Y + Z] [X |-> X + 1] }} // {{ Y + Z = 2^(X+1) - 1 + Z /\ Z = 2^(X+1) }}
    Y ::= Y + Z;;
      {{ I [X |-> X + 1] }} // {{ Y = 2^(X+1) - 1 + Z /\ Z = 2^(X+1) }}
    X ::= X + 1
      {{ I }} // {{ Y = 2^X - 1 + Z /\ Z = 2^X }}
  END;;
    {{ I /\ X = m}} ->>  // {{ Y = 2^X - 1 + Z /\ Z = 2^X /\ X = m }}
    {{ Y = 2^(m+1) - 1 }}

    Write a decorated program for this. *)

Lemma pow_2_S : forall n,
    pow 2 (S n) = 2 * pow 2 n.
Proof.
  intros. simpl. reflexivity.
Qed.

Lemma pow_2_plus1 : forall n,
    pow 2 (n + 1) = 2 * pow 2 n.
Proof.
  intros. rewrite (Nat.add_1_r n). apply pow_2_S.
Qed.

Theorem dopw2_down_correct: forall m,
  {{ fun st => True }}
  X ::= ANum 0;;
  Y ::= ANum 1;;
  Z ::= ANum 1;;
  WHILE BNot (BEq (AId X) (ANum m)) DO
    Z ::= AMult (ANum 2) (AId Z);;
    Y ::= APlus (AId Y) (AId Z);;
    X ::= APlus (AId X) (ANum 1)
  END
  {{ fun st => st Y = pow 2 (S m) - 1 }}.
Proof.
  intros m. apply hoare_consequence with (P' := fun st => 1 = 1 /\ 1 = 1) (Q' := fun st => st Y = pow 2 (st X) - 1 + st Z /\ st Z = pow 2 (st X) /\  st X = m).
  - apply hoare_seq with (Q := fun st => 1 = pow 2 (st X) /\ 1 = pow 2 (st X)).
    apply hoare_seq with (Q := fun st => st Y = pow 2 (st X) /\ 1 = pow 2 (st X)).
    apply hoare_seq with (Q := fun st => st Y = pow 2 (st X) - 1 + st Z /\ st Z = pow 2 (st X)).
    + eapply hoare_consequence_post. apply hoare_while.
      * apply hoare_consequence_pre with (P' := fun st => st Y + 2 * (st Z) = pow 2 (st X + 1) - 1 + 2 * st Z /\ 2 * st Z = pow 2 (st X + 1)).
        apply hoare_seq with (Q := fun st => st Y + st Z = pow 2 (st X + 1) - 1 + st Z /\ st Z = pow 2 (st X + 1)).
        apply hoare_seq with (Q := fun st => st Y = pow 2 (st X + 1) - 1 + st Z /\ st Z = pow 2 (st X + 1)).
        { eapply hoare_consequence_pre. apply hoare_asgn.
          - unfold assert_implies, assn_sub. intros st H. simpl.
            rewrite t_update_eq. rewrite t_update_neq. rewrite t_update_neq. assumption.
            unfold not. intros Hcontra. inversion Hcontra.
            unfold not. intros Hcontra. inversion Hcontra. }
        { eapply hoare_consequence_pre. apply hoare_asgn.
          - unfold assert_implies, assn_sub. intros st H. simpl.
            rewrite t_update_eq. rewrite t_update_neq. rewrite t_update_neq. assumption.
            unfold not. intros Hcontra. inversion Hcontra.
            unfold not. intros Hcontra. inversion Hcontra. }
        { eapply hoare_consequence_pre. apply hoare_asgn.
          - unfold assert_implies, assn_sub. intros st H. simpl.
            rewrite t_update_eq. rewrite t_update_neq. rewrite t_update_neq. assumption.
            unfold not. intros Hcontra. inversion Hcontra.
            unfold not. intros Hcontra. inversion Hcontra. }
        { unfold assert_implies. intros st [[H HZ] HX]. split.
          - rewrite pow_2_plus1. rewrite H. rewrite HZ. omega.
          - rewrite pow_2_plus1. rewrite HZ. reflexivity. }
      * unfold assert_implies. intros st [[H HZ] HX]. split.
        { assumption. }
        { split.
          - assumption.
          - unfold not, bassn in HX. simpl in HX. rewrite negb_true_iff in HX.
            apply eq_false_true_abs in HX. apply beq_nat_true in HX. omega. }
    + unfold hoare_triple. intros st st' HZ [HY H]. inversion HZ. subst. simpl. split.
      * rewrite t_update_neq. rewrite t_update_neq. rewrite t_update_eq. omega.
        unfold not. intros Hcontra. inversion Hcontra.
        unfold not. intros Hcontra. inversion Hcontra.
      * rewrite t_update_eq. rewrite t_update_neq. assumption.
        unfold not. intros Hcontra. inversion Hcontra.
    + unfold hoare_triple. intros st st' HZ [HY H]. inversion HZ. subst. simpl. split.
      * rewrite t_update_eq. rewrite t_update_neq. assumption.
        unfold not. intros Hcontra. inversion Hcontra.
      * rewrite t_update_neq. assumption.
        unfold not. intros Hcontra. inversion Hcontra.
    + unfold hoare_triple. intros st st' H _. inversion H. subst. split.
      * rewrite t_update_eq. reflexivity.
      * rewrite t_update_eq. reflexivity.
  - unfold assert_implies. intros. split. reflexivity. reflexivity.
  - unfold assert_implies. intros st [HY [HZ HX]]. rewrite pow_2_S. subst. simpl. rewrite <- plus_n_O. omega.
Qed.


(** * Indu\u00e7\u00e3o em Coq *)

Add LoadPath "/Users/marcosmonteiro/desktop/coq".
Require Export aula05_inducao.
Module NatList.

(* ############################################### *)
(** * Pares de n\u00fameros *)

(** A seguinte declara\u00e7\u00e3o pode ser lida como
    "s\u00f3 existe uma maneira de construir um
    par de n\u00fameros, que \u00e9 aplicando o construtor
    [pair] a dois argumentos do tipo [nat]" *)

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

Check (pair 3 5).

(** Definindo fun\u00e7\u00f5es para pares.
    Observe o casamento de padr\u00e3o. *)

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

(* Definindo uma nota\u00e7\u00e3o mais conveniente. *)

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

Compute (fst (3,5)).

(* Observe que \u00e9 poss\u00edvel, inclusive,
   usar esta sintaxe no casamento de padr\u00f5es. *)

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.

(** Algumas provas associadas a pares. *)

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

(** Observe que o pr\u00f3ximo teorema representa
    o mesmo fato, mas [reflexivity] n\u00e3o
    \u00e9 suficiente para concluir esta prova. *)

Theorem surjective_pairing_stuck :
  forall (p : natprod),
    p = (fst p, snd p).
Proof.
  simpl. (* Doesn't reduce anything! *)
Abort.

(** \u00c9 preciso expor a estrutura de [p], tal
    que [simpl] possa realizar casamento de
    padr\u00e3o. [destruct] permite fazer isto. *)

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

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

(* ############################################### *)
(** * Lista de n\u00fameros *)

(** Defini\u00e7\u00e3o de uma lista de n\u00fameros. *)

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

(** Exemplo de uma lista com 3 elementos. *)

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

(** Definindo uma nota\u00e7\u00e3o mais conveniente. *)

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

(** As defini\u00e7\u00f5es a seguir s\u00e3o equivalentes. *)

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

(** Definindo fun\u00e7\u00f5es para listas. *)

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

Example test_repeat1 :
  repeat 5 3
  = [5;5;5].
Proof. simpl. reflexivity. Qed.

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

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

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

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

(** Na defini\u00e7\u00e3o a seguir, observe o
    valor [default]. *)

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. simpl. reflexivity. Qed.

(** **** Exercise: (list_funs)  *)
(** Complete as defini\u00e7\u00f5es de [nonzeros],
    [oddmembers] e [countoddmembers]. Os testes
    mostram o comportamento esperado. *)

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

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

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

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

Definition countoddmembers (l:natlist) : nat
(* SUBSTITUA COM ":= _sua_defini\u00e7\u00e3o_ ." *). Admitted.

Example test_countoddmembers1:
  countoddmembers [1;0;3;1;4;5] = 4.
(* COMPLETE AQUI *) Admitted.

Example test_countoddmembers2:
  countoddmembers [0;2;4] = 0.
(* COMPLETE AQUI *) Admitted.

Example test_countoddmembers3:
  countoddmembers nil = 0.
(* COMPLETE AQUI *) Admitted.

(* ############################################### *)
(** * Representando multiconjuntos como listas *)

Definition bag := natlist.

(** **** Exercise: (bag_functions)  *)
(** Complete as defini\u00e7\u00f5es de: [count], [sum],
    [add], e [member] para multiconjuntos (bags).
    Os testes mostram o comportamento esperado. *)

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

Example test_count1:
  count 1 [1;2;3;1;4;1] = 3.
Proof. simpl. reflexivity. Qed.

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

(** A opera\u00e7\u00e3o [sum] em multiconjuntos \u00e9 similar
    ao conceito de [union] de conjuntos: [sum a b]
    cont\u00e9m todos os elementos de [a] e [b].

    Observe que a pr\u00f3xima defini\u00e7\u00e3o n\u00e3o possui
    nome para os par\u00e2metros, mas somente seus tipos.
    Al\u00e9m disto, a defini\u00e7\u00e3o n\u00e3o \u00e9 recursiva. Portanto,
    [sum] precisa ser definida em fun\u00e7\u00e3o de defini\u00e7\u00f5es
    passadas. *)

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

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

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

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

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

(** Observe que a pr\u00f3xima defini\u00e7\u00e3o
    tamb\u00e9m n\u00e3o \u00e9 recursiva. *)

Definition member (v:nat) (s:bag) : bool :=
  match count v s with
  | O => false
  | _ => true
  end.

Example test_member1:
  member 1 [1;4;1] = true.
Proof. simpl. reflexivity. Qed.

Example test_member2:
  member 2 [1;4;1] = false.
Proof. simpl. reflexivity. Qed.

(** **** Exercise: (bag_theorem)  *)
(** Prove o seguinte teorema. Talvez voc\u00ea
    precise provar um teorema auxiliar. *)

Theorem bag_theorem :
  forall (v : nat) (b : bag),
    (count v (add v b)) = (1 + (count v b)).
Proof.
  intros. simpl. Admitted.

(* ############################################### *)
(** * Raciocinando sobre listas *)

(** Algumas propriedades podem ser provadas
    somente com [reflexivity]. *)

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

(** \u00c0s vezes, ser\u00e1 preciso fazer an\u00e1lise de casos. *)

Theorem tl_length_pred : forall l:natlist,
  pred (length l) = length (tl l).
Proof.
  (* Observe a quantidade de elementos
     da segunda lista do destruct. *)
  intros l. destruct l as [| n l'].
  - (* l = nil *)
    simpl. reflexivity.
  - (* l = cons n l' *)
    Print length. simpl. reflexivity.
Qed.

(** \u00c0s vezes, ser\u00e1 preciso fazer indu\u00e7\u00e3o. *)

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 *)
    simpl. reflexivity.
  - (* l1 = cons n l1' *)
    Print app. simpl.
    rewrite -> IHl1'. reflexivity.
Qed.

(** Considere a seguinte defini\u00e7\u00e3o de [rev]. *)

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. simpl. reflexivity.  Qed.
Example test_rev2:
  rev nil = nil.
Proof. reflexivity.  Qed.

(** Vamos tentar provar a seguinte afirma\u00e7\u00e3o.
    Observe que ficamos "travados" no segundo caso. *)

Theorem rev_length_firsttry : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - (* l = [] *)
    simpl. reflexivity.
  - (* l = n :: l' *)
    Print rev. simpl. rewrite <- IHl'.
    (* Como continuar a partir daqui? *)
Abort.

(** Vamos definir um teorema auxiliar a partir
    do ponto em que ficamos "travados" no
    teorema anterior. Contudo, vamos tornar
    o teorema auxiliar o mais geral poss\u00edvel:
    [l1] e [l2] no lugar de [rev l'] e [n]. *)

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. (* l1 = nil *)
    reflexivity.
  - (* l1 = cons *)
    simpl. rewrite -> IHl1'. reflexivity.
Qed.

(** Agora concluimos a prova de [rev_length]. *)

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

(** **** Exercise: (list_exercises)  *)
(** Prove os seguintes teoremas. *)

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

Theorem rev_app_distr: forall l1 l2 : natlist,
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
(* COMPLETE AQUI *) Admitted.

Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
(* COMPLETE AQUI *) Admitted.

Lemma nonzeros_app : forall l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros. induction l1.
  - simpl. reflexivity.
  - destruct n.
    + simpl. rewrite IHl1. reflexivity.
    + simpl. rewrite IHl1. reflexivity.
Qed.

(** **** Exercise: (beq_natlist)  *)
(** Complete a defini\u00e7\u00e3o de [beq_natlist], que
    compara listas de n\u00fameros. Veja os exemplos.
    Em seguida, prove o teorema [beq_natlist_refl]. *)

Fixpoint beq_natlist (l1 l2 : natlist) : bool :=
  match l1, l1 with
  | [], [] => true
  | _, [] => false
  | [], _ => false
  | h1 :: t1, h2 :: t2 =>
    match beq_nat h1 h2 with
    | true => beq_natlist t1 t2
    | false => false
    end
  end.

Example test_beq_natlist1 :
  (beq_natlist nil nil = true).
(* COMPLETE AQUI *) Admitted.

Example test_beq_natlist2 :
  beq_natlist [1;2;3] [1;2;3] = true.
(* COMPLETE AQUI *) Admitted.

Example test_beq_natlist3 :
  beq_natlist [1;2;3] [1;2;4] = false.
(* COMPLETE AQUI *) Admitted.

Theorem beq_natlist_refl : forall l:natlist,
  true = beq_natlist l l.
Proof.
  intros. induction l.
  - simpl. reflexivity.
Abort.

(* ############################################### *)
(** * Options *)

(** Considere a seguinte implementa\u00e7\u00e3o de uma
    fun\u00e7\u00e3o que retorna o i-\u00e9simo elemento
    de uma lista. *)

Fixpoint nth_bad (l:natlist) (n:nat) : nat :=
  match l with
  | nil => 42  (* um valor arbitr\u00e1rio! *)
  | a :: l' => match beq_nat n O with
               | true => a
               | false => nth_bad l' (pred n)
               end
  end.

(** Outra alternativa seria considerar um
    elemento padr\u00e3o -- ver defini\u00e7\u00e3o de [hd].

    Uma melhor solu\u00e7\u00e3o \u00e9 definir um "option".
    Similar ao conceito de "maybe" em Haskell. *)

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

(** Veja agora a fun\u00e7\u00e3o [nth_error]. *)

Fixpoint nth_error (l:natlist) (n:nat) : natoption :=
  match l with
  | nil => None
  | a :: l' => match beq_nat n O with
               | true => Some a
               | false => nth_error l' (pred n)
               end
  end.

Example test_nth_error1 :
  nth_error [4;5;6;7] 0 = Some 4.
Proof. simpl. reflexivity. Qed.
Example test_nth_error2 :
  nth_error [4;5;6;7] 3 = Some 7.
Proof. simpl. reflexivity. Qed.
Example test_nth_error3 :
  nth_error [4;5;6;7] 9 = None.
Proof. simpl. reflexivity. Qed.

(** A seguir, uma outra possibilidade de
    implementa\u00e7\u00e3o de [nth_error] usando "if". *)

Fixpoint nth_error' (l:natlist) (n:nat) : natoption :=
  match l with
  | nil => None
  | a :: l' => if beq_nat n O then Some a
               else nth_error' l' (pred n)
  end.

(** No entanto, cuidado com o "if". *)

Inductive tipo : Type :=
  | cons1 : tipo
  | cons2 : tipo.

Definition beq_tipo (n m : nat) : tipo :=
  if beq_nat n m then cons2 else cons1.

Definition teste_if (n m : nat) : bool :=
  if beq_tipo n m then true
  else false.

Compute (teste_if 2 2).

(** O "if" s\u00f3 pode ser aplicado a tipos
    indutivos com dois construtores. *)

(** A fun\u00e7\u00e3o a seguir retira o [nat] encapsulado
    no [natoption]. Observe aqui o uso do default. *)

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

(** **** Exercise: (hd_error)  *)
(** Use a ideia do "option" e atualize
    a defini\u00e7\u00e3o da fun\u00e7\u00e3o [hd]. *)

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

Example test_hd_error1 : hd_error [] = None.
Proof. simpl. reflexivity. Qed.

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

Example test_hd_error3 : hd_error [5;6] = Some 5.
Proof. simpl. reflexivity. Qed.

(** **** Exercise: (option_elim_hd)  *)
(** Prove o seguinte teorema relacionando
    [hd_error] com [hd]. *)

Theorem option_elim_hd : forall (l:natlist) (default:nat),
  hd default l = option_elim default (hd_error l).
Proof.
  Print hd. Print option_elim.
  intros. destruct l.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

End NatList.

(* ############################################### *)
(** * Mapeamentos parciais *)

(** Veja a seguinte defini\u00e7\u00e3o de mapeamentos parciais,
    similar aos tipos map ou dictionary das
    principais linguagens de programa\u00e7\u00e3o.

    Inicialmente, definimos a "chave": o [id]. *)

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

Definition beq_id (x1 x2 : id) :=
  match x1, x2 with
  | Id n1, Id n2 => beq_nat n1 n2
  end.

(** **** Exercise: (beq_id_refl)  *)
Theorem beq_id_refl :
  forall x, true = beq_id x x.
Proof.
  intros. destruct x. simpl. induction n.
  - simpl. reflexivity.
  - simpl. rewrite <- IHn. reflexivity.
Qed.

(** Agora, o tipo de mapeamentos parciais *)

Module PartialMap.
Export NatList.

Inductive partial_map : Type :=
  | empty  : partial_map
  | record : id -> nat -> partial_map -> partial_map.

(** Logo, existem duas maneiras de construir
    [partial_map]: usando o construtor [empty],
    representando o mapeamento vazio; usando
    o construtor [record], passando uma chave,
    um n\u00famero e um mapeamento existente.

    A fun\u00e7\u00e3o [update] atualiza um mapeamento.
    Observe que, conceitualmente, o valor antigo,
    caso exista, \u00e9 mantido no mapeamento. O
    primeiro valor ser\u00e1 o mais recente. *)

Definition update (d : partial_map)
                  (x : id) (value : nat)
                  : partial_map :=
  record x value d.

Example test_partial_map1 :
  (update empty (Id 0) 3)
  = (record (Id 0) 3 empty).
Proof.
    simpl. reflexivity.
Qed.

Example test_partial_map2 :
  (update (record (Id 0) 2 empty) (Id 0) 3)
  = (record (Id 0) 3 (record (Id 0) 2 empty)).
Proof.
    simpl. reflexivity.
Qed.

(** A fun\u00e7\u00e3o [find] procura por um valor em
    um mapeamento. Se houver m\u00faltiplos mapeamentos,
    retorna o primeiro. *)

Fixpoint find (x : id) (d : partial_map) : natoption :=
  match d with
  | empty         => None
  | record y v d' => if beq_id x y
                     then Some v
                     else find x d'
  end.

(** **** Exercise: (update_eq)  *)
Theorem update_eq :
  forall (d : partial_map) (x : id) (v: nat),
    find x (update d x v) = Some v.
Proof.
(* COMPLETE AQUI *) Admitted.

(** **** Exercise: (update_neq)  *)
Theorem update_neq :
  forall (d : partial_map) (x y : id) (o: nat),
    beq_id x y = false ->
    find x (update d y o) = find x d.
Proof.
(* COMPLETE AQUI *) Admitted.

End PartialMap.

(** Veja a diferen\u00e7a entre os dois pr\u00f3ximos
    comandos. O segundo garante que a
    express\u00e3o \u00e0 direita da igualdade
    seja igual (sintaticamente) ao
    segundo operando da soma. *)

Search (_ + _ = _).
Search (_ + ?x = ?x).

(* ############################################### *)
(** * Leitura sugerida *)

(** Software Foundations: volume 1
  - Lists
  https://softwarefoundations.cis.upenn.edu/lf-current/Lists.html
*)


Require Import Essentials.Notations.
Require Import Essentials.Arith.
Require Import Metrics.UltraMetric.
Require Import Essentials.Omega.
Require Import Essentials.Facts_Tactics.

Local Open Scope order_scope.
Local Open Scope lattice_scope.
Local Open Scope metric_scope.

(** Limit of a sequence in an ultra metric space. *)
Section Limit.
  Context {L : MLattice} {U : UltraMetric L} (Seq : Sequence U).

  (** The limit of a sequence is an element whose distance from elements of the sequence
decreases below any positive distance as the sequence progresses. *)
  Record Limit : Type :=
    {
      Lim :> U;
      Lim_limit :
        ∀ (ε : (ApprType L)),
          {N : nat | ∀ (n : nat), N ≤ n →
              δ(Seq n, Lim) ⊏ (projT1 ε)}
    }.

  Theorem Limit_unique (l l' : Limit) : l = l' :> U.
  Proof.
    destruct (ML_bottom_dichotomy L) as [dicht|dicht].
    {
      apply UM_zero_dist_eq.
      apply ML_appr_dominate_pos.
      intros y H1.
      destruct (dicht _ H1) as [y' Hd1 [Hd2 Hd3]].
      destruct (Lim_limit l (existT _ _ Hd1)) as [Nl Hl].
      destruct (Lim_limit l' (existT _ _ Hd1)) as [Nl' Hl'].
      eapply LE_LT_Trans; [apply (UM_ineq L U l l' (Seq (max Nl Nl'))) |].
      eapply LE_LT_Trans; [|apply Hd3].
      apply lub_lst; intros [|].
      + rewrite UM_dist_sym.
        apply Hl.
        apply l_le_max.
      + apply Hl'.
        apply r_le_max.
    }
    {
      destruct dicht as [ab Hd1 Hd2].
      destruct (Lim_limit l (existT _ _ Hd1)) as [Nl Hl].
      destruct (Lim_limit l' (existT _ _ Hd1)) as [Nl' Hl'].
      apply UM_zero_dist_eq.
      apply LE_Bottom_Bottom.
      eapply PO_Trans; [apply (UM_ineq L U l l' (Seq (max Nl Nl'))) |].
      apply lub_lst; intros [|].
      + rewrite UM_dist_sym.
        specialize (Hl (max Nl Nl') (l_le_max _ _)).
        apply Hd2 in Hl; rewrite Hl; trivial.
      + specialize (Hl' (max Nl Nl') (r_le_max _ _)).
        apply Hd2 in Hl'; rewrite Hl'; trivial.
    }
  Qed.

End Limit.

Section Eq_Seq_Eq_Limits.
  Context {L : MLattice}
          {U : UltraMetric L}
          (Seq Seq' : Sequence U)
          (l : Limit Seq)
          (l' : Limit Seq')
  .

  Theorem Eq_Seq_Eq_Limits : Seq = Seq' → l = l' :> U.
  Proof.
    intros H.
    destruct H.
    apply Limit_unique.
  Qed.

End Eq_Seq_Eq_Limits.

Arguments Lim {_ _ _} _.
Arguments Lim_limit {_ _ _} _ _.

Section Limit_of_SubSeq.
  Context {L : MLattice} {U : UltraMetric L}.

  Program Definition Limit_of_SubSeq {Seq : Sequence U} (l : Limit Seq) (m : nat) :
    Limit (fun n => Seq (m + n)) :=
    {|
      Lim := l
    |}.

  Next Obligation.
  Proof.
    destruct (Lim_limit l ε) as [N H].
    exists (m + N).
    intros n H2.
    apply H.
    abstract omega.
  Defined.

  Theorem Limit_of_SubSeq_equal_1 {Seq : Sequence U} (l : Limit Seq) (l' : Limit (fun n => Seq (S n))) : l = l' :> U.
  Proof.
    cut (∀ (ε : (ApprType L)),
            {N : nat | ∀ (n : nat),
                N ≤ n →
                δ(Seq n, l') ⊏ (projT1 ε)}
        ).
    {
      intros H.
      transitivity ({|Lim := l'; Lim_limit := H|}); trivial.
      apply Limit_unique.
    }
    {
      intros ε.
      destruct (Lim_limit l' ε) as [m H'].
      exists (S m).
      intros n H1.
      destruct n; [omega|].
      cut (m ≤ n); auto; omega.
    }
  Qed.

  Theorem Limit_of_SubSeq_equal {Seq : Sequence U} (l : Limit Seq) (m : nat) (l' : Limit (fun n => Seq (m + n))) : l = l' :> U.
  Proof.
    induction m.
    + apply Limit_unique.
    + rewrite ((IHm (Limit_of_SubSeq l m))).
      set (W := Limit_of_SubSeq_equal_1 (Limit_of_SubSeq l m)).
      cbn in W.
      replace (fun n : nat => Seq (m + S n)) with (fun n : nat => Seq (S m + n)) in W
        by (abstract (FunExt; apply f_equal; omega)).
      apply W.
  Qed.

End Limit_of_SubSeq.

Section Limit_of_ConstSeq.
  Context {L : MLattice} {U : UltraMetric L} (A : U).

  Program Definition Limit_of_ConstSeq :
    Limit (fun _ => A) :=
    {|
      Lim := A
    |}.

  Next Obligation.
  Proof.
    exists 0.
    intros ? ?.
    rewrite UM_eq_zero_dist.
    apply ML_appr_pos.
    apply (projT2 ε).
  Qed.

  Theorem Limit_of_ConstSeq_equal (l : Limit (fun _ => A)) : l = A :> U.
  Proof.
    change A with (Lim Limit_of_ConstSeq).
    apply Limit_unique.
  Qed.

End Limit_of_ConstSeq.

Section Distance_of_Limits.
  Context {L : MLattice} {U : UltraMetric L} (Seq Seq' : Sequence U).

  Theorem Distance_of_Limits (δ : L) (l : Limit Seq) (l' : Limit Seq') :
    ⊥ ⊏ δ → (∀ n, δ(Seq n, Seq' n) ⊑ δ) → δ(l, l') ⊑ δ.
  Proof.
    intros H1 H2.
    destruct (ML_all_approximatable _ _ H1) as [δ' H3 H4].
    destruct (Lim_limit l (existT _ _ H4)) as [m H5].
    destruct (Lim_limit l' (existT _ _ H4)) as [m' H6].
    eapply PO_Trans; [apply UM_ineq|].
    apply lub_lst; intros [].
    {
      rewrite UM_dist_sym.
      eapply PO_Trans; [|apply H3].
      apply (H5 (max m m') (l_le_max _ _)).
    }
    {
      eapply PO_Trans; [apply UM_ineq|].
      apply lub_lst; intros [].
      {
        apply H2.
      }
      {
        eapply PO_Trans; [|apply H3].
        apply (H6 (max m m') (r_le_max _ _)).
      }
    }
  Qed.

End Distance_of_Limits.


(* ================================ *)
(* ========== CH01_ccw.v ========== *)
(* ================================ *)

Require Export Del13.

Open Scope R_scope.

(* ================================ *)
(* ========== ########## ========== *)
(* ================================ *)

Definition det (p q r : point) : R :=
  (fst p * snd q) - (fst q * snd p) - (fst p * snd r) + (fst r * snd p) +
  (fst q * snd r) - (fst r * snd q).

Lemma eq_det : forall (p q r : point),
  det p q r = det q r p.
Proof.
intros p q r.
unfold det; ring.
Qed.

Lemma neq_det : forall (p q r : point),
  det p q r = - det p r q.
Proof.
intros p q r.
unfold det; ring.
Qed.

(* ================================ *)
(* ========== ########## ========== *)
(* ================================ *)

Definition ccw (p q r : point) : Prop :=
  (det p q r > 0).

Lemma ccw_dec : forall (p q r : point),
  {ccw p q r} + {~ ccw p q r}.
Proof.
intros p q r.
unfold ccw; apply Rgt_dec.
Qed.

(* ================================ *)

Definition align (p q r : point) : Prop :=
  (det p q r = 0).

Lemma align_dec : forall (p q r : point),
  {align p q r} + {~align p q r}.
Proof.
intros p q r.
unfold align.
generalize (total_order_T (det p q r) 0).
generalize (Rlt_dichotomy_converse (det p q r) 0).
tauto.
Qed.

(* ================================ *)
(* ========== ########## ========== *)
(* ================================ *)

Lemma Rle_neq_lt : forall (r1 r2 : R),
  r1 <= r2 -> r1 <> r2 -> r1 < r2.
Proof.
intros r1 r2 H1 H2.
elim (Rdichotomy r1 r2).
trivial.
generalize (Rle_not_lt r2 r1).
tauto.
assumption.
Qed.

Lemma R_gt_0_plus : forall (r1 r2 : R),
  r1 > 0 -> r2 > 0 -> r1 + r2 > 0.
Proof.
intros r1 r2 H1 H2.
apply Rgt_trans with r1.
 pattern r1 at 2; rewrite <- (Rplus_0_r r1).
 apply Rplus_gt_compat_l; assumption.
assumption.
Qed.

Lemma R_gt_0_mult : forall (r1 r2 : R),
  r1 > 0 -> r2 > 0 -> r1 * r2 > 0.
Proof.
apply Rmult_gt_0_compat.
Qed.

Lemma R_gt_0_div : forall (r1 r2 : R),
  r1 > 0 -> r2 > 0 -> r1 * / r2 > 0.
Proof.
intros r1 r2 H1 H2.
apply R_gt_0_mult.
 assumption.
 unfold Rgt in *; auto with real.
Qed.

Lemma R_mult_div : forall (r1 r2 r3 : R),
  r1 = r2 * r3 -> r2 > 0 -> r1 * / r2 = r3.
Proof.
intros r1 r2 r3 H1 H2.
subst r1; auto with real.
Qed.

(* ================================ *)
(* ========== ########## ========== *)
(* ================================ *)

Lemma axiom_orientation_1 :
  forall (A:point)(B:point)(C:point),
  ccw A B C -> ccw B C A.
Proof.
intros A B C.
unfold ccw; rewrite eq_det; trivial.
Qed.

Lemma axiom_orientation_2 :
  forall (A:point)(B:point)(C:point),
  align A B C -> align B C A.
Proof.
intros A B C.
unfold align; rewrite eq_det; trivial.
Qed.

Lemma axiom_orientation_3 :
  forall (A:point)(B:point)(C:point),
  align A B C -> align A C B.
Proof.
intros A B C.
unfold align; rewrite neq_det.
generalize (Rplus_opp_r (det A C B)).
generalize (Rplus_0_l (det A C B)).
intros H1 H2 H3.
rewrite H3 in H2; clear H3.
rewrite Rplus_comm in H1.
rewrite H1 in H2; clear H1.
assumption.
Qed.

Hint Resolve axiom_orientation_1 axiom_orientation_2 axiom_orientation_3 : myorientation.

(* ================================ *)

Lemma axiom_orientation_4 :
  forall (A:point)(B:point)(C:point),
  ccw A B C -> ~ ccw A C B.
Proof.
intros A B C.
unfold ccw; rewrite neq_det.
generalize (Ropp_gt_lt_contravar (- det A C B) 0).
rewrite Ropp_involutive; rewrite Ropp_0.
intro H1; generalize (Rlt_le (det A C B) 0).
intro H2; generalize (Rle_not_lt 0 (det A C B)).
intro H3; tauto.
Qed.

Lemma axiom_orientation_5 :
  forall (A:point)(B:point)(C:point),
  ccw A B C -> ~ align A B C.
Proof.
intros A B C.
unfold ccw, align in *.
apply Rgt_not_eq; assumption.
Qed.

Lemma axiom_orientation_6 :
  forall (A:point)(B:point)(C:point),
  align A B C -> ~ ccw A B C.
Proof.
intros A B C.
unfold ccw, align in *.
intro H1; rewrite H1.
unfold not; intro H2.
apply Rgt_not_eq in H2; tauto.
Qed.

Hint Resolve axiom_orientation_4 axiom_orientation_5 axiom_orientation_6 : myorientation.

(* ================================ *)

Lemma axiom_orientation_7 :
  forall (A:point)(B:point)(C:point),
  ~ ccw A B C -> ccw A C B \/ align A B C.
Proof.
intros A B C H.
elim (ccw_dec A C B).
 intro H1; left; assumption.
 intro H1; right.
 unfold ccw, align in *.
 rewrite neq_det in H1.
 apply Rle_antisym.
  apply Rnot_gt_le; assumption.
  apply Rnot_gt_le; auto with real.
Qed.

Lemma axiom_orientation_8 :
  forall (A:point)(B:point)(C:point),
  ~ align A B C -> ccw A B C \/ ccw A C B.
Proof.
intros A B C H.
elim (ccw_dec A B C).
 intro H0; left; assumption.
 intro H0; right.
 apply axiom_orientation_7 in H0.
 elim H0; [trivial|contradiction].
Qed.

Hint Resolve axiom_orientation_7 axiom_orientation_8 : myorientation.

(* ================================ *)
(* ========== ########## ========== *)
(* ================================ *)

Lemma ccw_axiom_1 : forall (p q r : point),
  ccw p q r -> ccw q r p.
Proof.
auto with myorientation.
Qed.

Lemma ccw_axiom_2 : forall (p q r : point),
  ccw p q r -> ~ ccw p r q.
Proof.
auto with myorientation.
Qed.

Lemma ccw_axiom_3 : forall (p q r : point),
  ~ align p q r -> (ccw p q r) \/ (ccw p r q).
Proof.
auto with myorientation.
Qed.

Lemma ccw_axiom_4 : forall (p q r t : point),
  (ccw t q r) -> (ccw p t r) -> (ccw p q t) -> (ccw p q r).
Proof.
intros p q r t H1 H2 H3.
unfold ccw in *.
assert (det t q r + det p t r + det p q t = det p q r).
unfold det; ring.
rewrite <- H.
apply R_gt_0_plus; [apply R_gt_0_plus; assumption | assumption].
Qed.

Lemma ccw_axiom_5 : forall (p q r s t : point),
  (ccw t s p) -> (ccw t s q) -> (ccw t s r) -> (ccw t p q) -> (ccw t q r) ->
  (ccw t p r).
Proof.
intros p q r s t H1 H2 H3 H4 H5.
unfold ccw in *.
replace (det t p r) with ((det t p q * det t s r + det t q r * det t s p) * / (det t s q)).
apply R_gt_0_div.
 apply R_gt_0_plus.
  apply R_gt_0_mult; assumption.
  apply R_gt_0_mult; assumption.
 assumption.
apply R_mult_div.
 unfold det; ring.
 assumption.
Qed.

Lemma ccw_axiom_5_bis : forall (p q r s t : point),
  (ccw s t p) -> (ccw s t q) -> (ccw s t r) -> (ccw t p q) -> (ccw t q r) ->
  (ccw t p r).
Proof.
intros p q r s t H1 H2 H3 H4 H5.
unfold ccw in *.
replace (det t p r) with ((det t p q * det s t r + det t q r * det s t p) * / (det s t q)).
apply R_gt_0_div.
 apply R_gt_0_plus.
  apply R_gt_0_mult; assumption.
  apply R_gt_0_mult; assumption.
 assumption.
apply R_mult_div.
 unfold det; ring.
 assumption.
Qed.


(** * Rel: Properties of Relations *)

(* $Date: 2011-03-21 10:44:46 -0400 (Mon, 21 Mar 2011) $ *)

(** This short chapter develops some basic definitions that will be
    needed when we come to working with small-step operational
    semantics in [Smallstep.v].  It can be postponed until just before
    [Smallstep.v], but it is also a good source of good exercises for
    developing facility with Coq's basic reasoning facilities, so it
    may be useful to look at it just after [Logic.v]. *)

Require Export Logic.

(** A _relation_ is just a parameterized proposition.  As you know
    from your undergraduate discrete math course, there are a lot of
    ways of discussing and describing relations _in general_ -- ways
    of classifying relations (are they reflexive, transitive, etc.),
    theorems that can be proved generically about classes of
    relations, constructions that build one relation from another,
    etc.  Let us pause here to review a few that will be useful in
    what follows. *)

(** A relation _on_ a set [X] is a proposition parameterized by two
    [X]s -- i.e., it is a logical assertion involving two values from
    the set [X].  *)

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

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

(* ######################################################### *)
(** * Basic Properties of Relations *)

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

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

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

Theorem next_nat_partial_function :
   partial_function next_nat.
Proof.
  unfold partial_function.
  intros x y1 y2 P Q.
  inversion P. inversion Q.
  reflexivity.  Qed.

(** However, the [<=] relation on numbers is not a partial function.

    This can be shown by contradiction.  In short: Assume, for a
    contradiction, that [<=] is a partial function.  But then, since
    [0 <= 0] and [0 <= 1], it follows that [0 = 1].  This is nonsense,
    so our assumption was contradictory. *)

Theorem le_not_a_partial_function :
  ~ (partial_function le).
Proof.
  unfold not. unfold partial_function. intros H.
  assert (0 = 1) as Nonsense.
   Case "Proof of assertion".
   apply H with 0.
     apply le_n.
     apply le_S. apply le_n.
  inversion Nonsense.   Qed.

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

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

(** **** Exercise: 2 stars, optional *)
(** Show that the [empty_relation] defined in Logic.v is a partial
    function. *)

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

(** A _reflexive_ relation on a set [X] is one that holds for every
    element of [X]. *)

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

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

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

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

Theorem le_trans :
  transitive le.
Proof.
  intros n m o Hnm Hmo.
  induction Hmo.
  Case "le_n". apply Hnm.
  Case "le_S". apply le_S. apply IHHmo.  Qed.

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

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

Theorem lt_trans' :
  transitive lt.
Proof.
  (* Prove this by induction on evidence that [m] is less than [o]. *)
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction Hmo as [| m' Hm'o].
    (* FILL IN HERE *) Admitted.
(** [] *)

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

Theorem lt_trans'' :
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction o as [| o'].
  (* FILL IN HERE *) Admitted.
(** [] *)

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

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

(** **** Exercise: 1 star, optional *)
Theorem le_S_n : forall n m,
  (S n <= S m) -> (n <= m).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

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

    A formal proof of this is an optional exercise below, but try
    the informal proof without doing the formal proof first.

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

(** **** Exercise: 1 star, optional *)
Theorem le_Sn_n : forall n,
  ~ (S n <= n).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

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

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

(** **** Exercise: 2 stars, optional *)
Theorem le_not_symmetric :
  ~ (symmetric le).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

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

(** **** Exercise: 2 stars, optional *)
Theorem le_antisymmetric :
  antisymmetric le.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional *)
Theorem le_step : forall n m p,
  n < m ->
  m <= S p ->
  n <= p.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

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

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

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

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

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

Theorem le_order :
  order le.
Proof.
  unfold order. split.
    Case "refl". apply le_reflexive.
    split.
      Case "antisym". apply le_antisymmetric.
      Case "transitive.". apply le_trans.  Qed.

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

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

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

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

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

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

    Here is a more useful definition... *)

Inductive refl_step_closure {X:Type} (R: relation X)
                            : X -> X -> Prop :=
  | rsc_refl  : forall (x : X),
                 refl_step_closure R x x
  | rsc_step : forall (x y z : X),
                    R x y ->
                    refl_step_closure R y z ->
                    refl_step_closure R x z.

(** (The following [Tactic Notation] definitions are explained in
    Imp.v.  You can ignore them if you haven't read that chapter
    yet.) *)

Tactic Notation "rt_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "rt_step" | Case_aux c "rt_refl"
  | Case_aux c "rt_trans" ].

Tactic Notation "rsc_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "rsc_refl" | Case_aux c "rsc_step" ].

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

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

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

Theorem rsc_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> refl_step_closure R x y.
Proof.
  intros X R x y r.
  apply rsc_step with y. apply r. apply rsc_refl.   Qed.

(** **** Exercise: 2 stars, optional (rsc_trans) *)
Theorem rsc_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      refl_step_closure R x y  ->
      refl_step_closure R y z ->
      refl_step_closure R x z.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

(** **** Exercise: 3 stars, optional (rtc_rsc_coincide) *)
Theorem rtc_rsc_coincide :
         forall (X:Type) (R: relation X) (x y : X),
  clos_refl_trans R x y <-> refl_step_closure R x y.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)


Require Import List Arith Lia.
Import ListNotations.
From Undecidability.HOU Require Import std.tactics std.lists.basics std.decidable.

Set Default Proof Using "Type".

(* nth *)
Notation nth := nth_error.
Section Nth.

  Variable (X Y: Type).

  Lemma nth_error_map_option n (f: X -> Y) (A: list X):
    nth_error (map f A) n = option_map f (nth_error A n).
  Proof.
    destruct (nth_error A n) eqn: H1.
    + eapply map_nth_error in H1. rewrite H1. reflexivity.
    + eapply nth_error_None in H1.
      eapply nth_error_None. now rewrite map_length.
  Qed.

  Lemma nth_error_lt_Some Z m (L: list Z):
    m < length L -> exists a, nth L m = Some a.
  Proof.
    intros H % nth_error_Some.
    destruct nth; intuition. now (exists z).
  Qed.

  Lemma nth_error_Some_lt Z m a (L: list Z):
    nth L m = Some a -> m < length L.
  Proof.
    intros H; eapply nth_error_Some; rewrite H; discriminate.
  Qed.

End Nth.

(* nats *)
Section Nats.

  Fixpoint nats (n: nat) :=
    match n with
    | 0 => nil
    | S n => 0 :: map S (nats n)
    end.

  Lemma nats_lt: forall k i, i ∈ nats k -> i < k.
  Proof.
    induction k; cbn; intuition. lia.
    eapply in_map_iff in H0. destruct H0; intuition; subst.
    specialize (IHk x H1); lia.
  Qed.

  Lemma nth_nats m k:
    m < k -> nth (nats k) m = Some m.
  Proof.
    induction k in m |-*.
    - lia.
    - intros; destruct m; cbn in *; eauto.
      erewrite map_nth_error; eauto.
      eapply IHk; lia.
  Qed.

  Lemma lt_nats x k:
    x < k -> x ∈ nats k.
  Proof.
    now intros H % nth_nats % nth_error_In.
  Qed.

  Lemma incl_nats I k:
    I ⊆ nats k -> forall i, i ∈ I -> i < k.
  Proof.
    firstorder using nats_lt.
  Qed.

  Lemma nats_incl I k:
    (forall i, i ∈ I -> i < k) -> I ⊆ nats k.
  Proof.
    firstorder using lt_nats.
  Qed.

  Lemma length_nats k: length (nats k) = k.
  Proof.
    induction k; cbn; lsimpl; congruence.
  Qed.

End Nats.
Global Hint Rewrite length_nats : listdb.

(* tabulate *)
Section Tabulate.
  Implicit Type  X: Type.

  Fixpoint tab {X} (f: nat -> X) k  :=
    match k with
    | 0 => nil
    | S n => tab f n ++ [f n]
    end.

  Lemma tab_length X (f: nat -> X) k: length (tab f k) = k.
  Proof.
    induction k; cbn; lsimpl; cbn; lsimpl; lia.
  Qed.

  Lemma tab_map X Y (f: nat -> X) (g: X -> Y) k:
    map g (tab f k) = tab (fun x => g (f x)) k.
  Proof.
    induction k; cbn; eauto; lsimpl; now rewrite IHk.
  Qed.

  Lemma tab_S X (f: nat -> X) n:
    tab f (S n) = f 0 :: tab (fun k => f (S k)) n.
  Proof.
    induction n; cbn; eauto.
    cbn in *; now rewrite IHn.
  Qed.

  Lemma tab_plus X (f: nat -> X) n m:
    tab f (n + m) = tab f n ++ tab (fun k => f (n + k)) m.
  Proof.
    induction n in f |-*; eauto.
    cbn [plus]; now rewrite tab_S, IHn, tab_S.
  Qed.

  Lemma tab_map_nats X k (f: nat -> X): tab f k = map f (nats k).
  Proof.
    induction k in f |-*; eauto.
    cbn [nats map]; now rewrite tab_S, IHk, map_map.
  Qed.

  Lemma tab_id_nats k: tab id k = nats k.
  Proof.
    rewrite tab_map_nats; now lsimpl.
  Qed.

  Lemma tab_nth {X} n m (f: nat -> X):
    n < m -> nth (tab f m) n = Some (f n).
  Proof.
    induction 1; cbn.
    + rewrite nth_error_app2, tab_length, Nat.sub_diag; cbn; eauto.
      rewrite tab_length; eauto.
    + rewrite nth_error_app1; eauto.
      now rewrite tab_length.
  Qed.

  Lemma tab_ext {X} (f g: nat -> X) n: (forall x, f x = g x) -> tab f n = tab g n.
  Proof.
    rewrite !tab_map_nats. intros; now apply map_ext.
  Qed.

End Tabulate.
Global Hint Rewrite tab_length tab_id_nats : listdb.

(* Repeated *)
Section Repeated.
  Variable (X Y: Type).
  Implicit Types (x y: X) (n m: nat) (f: X -> Y).

  Lemma repeated_in x n y: y ∈ repeat x n -> x = y.
  Proof.
    induction n; cbn; firstorder.
  Qed.

  Lemma repeated_plus n m x:
    repeat x (n + m) = repeat x n ++ repeat x m.
  Proof.
    induction n; cbn; congruence.
  Qed.

  Lemma repeated_rev n x: rev (repeat x n) = repeat x n.
  Proof.
    induction n; cbn; eauto.
    rewrite IHn. change [x] with (repeat x 1).
    rewrite <-repeated_plus.
    rewrite plus_comm. reflexivity.
  Qed.

  Lemma repeated_map n x f:
    map f (repeat x n) = repeat (f x) n.
  Proof.
    induction n; cbn; congruence.
  Qed.

  Lemma repeated_length n x: length (repeat x n) = n.
  Proof.
    induction n; cbn; congruence.
  Qed.

  Lemma repeated_equal n y A:
    (forall x, x ∈ A -> x = y) -> length A = n -> repeat y n = A.
  Proof.
    induction A in n |-*; destruct n; cbn; eauto; try discriminate.
    injection 2. rewrite IHA; eauto.
    intros. erewrite <-H; intuition.
  Qed.

  Lemma repeated_incl x n A:
    x ∈ A -> repeat x n ⊆ A.
  Proof.
    intros ? ? ? % repeated_in; subst; eauto.
  Qed.

  Lemma repeated_tab (x: X) n:
    repeat x n = tab (Basics.const x) n.
  Proof.
    induction n; eauto; cbn [tab].
    replace (S n) with (n + 1) by lia.
    rewrite repeated_plus; cbn.
    rewrite IHn; reflexivity.
  Qed.

  Lemma nth_error_repeated (x: X) n k :
    k < n -> nth (repeat x n) k = Some x.
  Proof.
    intros H.
    erewrite repeated_tab, tab_map_nats, map_nth_error; eauto.
    now eapply nth_nats.
  Qed.

  Lemma repeated_app_inv n x A B:
    repeat x n = A ++ B ->
    n = length A + length B /\
    A = repeat x (length A) /\
    B = repeat x (length B).
  Proof.
    induction n in A, B |-*.
    - cbn; destruct A, B; try discriminate. intuition.
    - destruct A; cbn; try discriminate.
      + destruct B; try discriminate.
        injection 1. intuition. cbn; now rewrite <-H0, repeated_length.
        subst. cbn; now rewrite repeated_length.
      + injection 1; intros; edestruct IHn; eauto.
        intuition. f_equal; eauto.
  Qed.

End Repeated.

Global Hint Rewrite  repeated_length repeated_map repeated_plus repeated_rev: listdb.

(* select *)
Section Select.

  Context {X: Type}.

  Fixpoint select (A: list nat) (B: list X)  :=
    match A with
    | nil => nil
    | i :: A => match nth B i with
               | Some x => x :: select A B
               | None => select A B
               end
    end.

  Lemma select_nil I:
    select I nil = nil.
  Proof.
    induction I; cbn.
    - reflexivity.
    - destruct nth eqn: H; eauto.
      eapply nth_error_In in H; cbn in H; intuition.
  Qed.

  Lemma select_S I (x: X) A:
    select (map S I) (x :: A) = select I A.
  Proof.
    induction I.
    - reflexivity.
    - cbn. rewrite IHI. reflexivity.
  Qed.

  Lemma select_nats k A:
    select (nats k) A = firstn k A.
  Proof.
    induction k in A |-*.
    - reflexivity.
    - destruct A.
      + rewrite select_nil; reflexivity.
      + cbn. rewrite select_S, IHk. reflexivity.
  Qed.

  Lemma select_repeated n I x:
    I ⊆ nats n -> select I (repeat x n) = repeat x (length I).
  Proof.
    induction I; cbn; eauto; intros.
    rewrite IHI; eauto with listdb.
    edestruct (nth_error_lt_Some) as [y H']; try rewrite H'.
    eapply nats_lt; lsimpl; firstorder.
    now eapply nth_error_In, repeated_in in H'; subst.
  Qed.

  Lemma select_incl I A: select I A ⊆ A.
  Proof.
    induction I; cbn; intuition.
    destruct nth eqn: H1; intuition.
    eapply nth_error_In in H1. intuition.
  Qed.

  Lemma incl_select A B: A ⊆ B -> exists I, I ⊆ nats (length B) /\ select I B = A.
  Proof.
    induction A.
     + exists nil. lauto.
     + intros; destruct IHA as [I []]; lauto. specialize (H a). mp H; lauto.
        eapply In_nth_error in H as [i].
        exists (i::I). cbn. rewrite H, H1. split; lauto.
        eapply nth_error_Some_lt, lt_nats in H; lauto.
  Qed.
End Select.

Lemma select_map X Y (f: X -> Y) I A:
  map f (select I A) = select I (map f A).
Proof.
  induction I in A |-*; cbn; eauto.
  rewrite nth_error_map_option.
  destruct nth; cbn; now rewrite IHI.
Qed.

(* find *)
Section Find.

  Context {X: Type}.
  Context {D: Dis X}.

  Fixpoint find (x: X) (A: list X) : option nat :=
    match A with
    | nil => None
    | y :: A => if x == y then Some 0 else option_map S (find x A)
    end.

  Lemma find_Some x A n:
    find x A = Some n -> nth A n = Some x.
  Proof.
    induction A in n |-*; cbn.
    - discriminate.
    - destruct (x == a).
      injection 1; intros; subst. reflexivity.
      destruct find; try discriminate.
      cbn; injection 1; intros; subst.
      cbn. now rewrite IHA.
  Qed.

  Lemma find_in x A:
    x ∈ A -> exists n, find x A = Some n.
  Proof.
    induction A; cbn; intuition.
    - exists 0. destruct (x == a); subst; intuition.
    - destruct (x == a).
      + subst; exists 0; intuition.
      + destruct H as [m]; exists (S m); intuition.
        rewrite H; reflexivity.
  Qed.

  Lemma find_Some_nth x A n:
    nth A n = Some x -> exists k, find x A = Some k.
  Proof.
    now intros ? % nth_error_In % find_in.
  Qed.

  Lemma find_not_in x A:
    find x A = None -> ~ x ∈ A.
  Proof.
    intros H [n H'] % find_in; rewrite H in H'; discriminate.
  Qed.

  Lemma find_map f A n x:
    find x A = Some n -> exists m, find (f x) (map f A) = Some m.
  Proof.
    induction A in n |-*; cbn; try discriminate.
    destruct eq_dec; intuition; subst.
    - exists 0; destruct eq_dec; intuition.
    - destruct (find x A); try discriminate.
      edestruct IHA as [m]; eauto.
      destruct eq_dec; eauto.
      exists (S m). now rewrite H0.
  Qed.

End Find.

Lemma find_map_inv X Y {D1: Dis X} {D2: Dis Y} y (f: X -> Y) (A: list X) (n: nat):
  find y (map f A) = Some n -> exists x, f x = y /\ find x A = Some n.
Proof.
  induction A in y, n  |-*; cbn; intuition; try discriminate.
  destruct eq_dec.
  + injection H as ?; subst; exists a; intuition. destruct eq_dec; intuition.
  + destruct find eqn: H1; try discriminate. injection H as ?; subst.
    eapply IHA in H1 as []; intuition; subst.
    exists x. intuition; destruct eq_dec; cbn; try congruence. now rewrite H1.
Qed.

Section Remove.

  Variable (X: Type) (D: Dis X).

  Lemma remove_remain  (x y: X) A:
    x ∈ A -> x <> y -> x ∈ remove eq_dec y A.
  Proof.
    induction A; cbn; intuition; subst.
    - destruct (y == x); subst; intuition.
    - destruct (y == a); subst; intuition.
  Qed.

  Lemma remove_prev (x y: X) (A: list X):
    y ∈ remove eq_dec x A -> y ∈ A.
  Proof.
    induction A; intuition.
    cbn in H. destruct (x == a); subst; intuition.
    cbn in *; intuition.
  Qed.

End Remove.

Section FlatMap.

  Variable (X Y: Type).
  Implicit Types (A B: list X) (f: X -> list Y).

  Lemma flat_map_app f A B:
    flat_map f (A ++ B) = flat_map f A ++ flat_map f B.
  Proof.
    induction A; cbn; eauto; now rewrite IHA, app_assoc.
  Qed.

  Lemma flat_map_incl (f: X -> list Y) A B:
    A ⊆ B -> flat_map f A ⊆ flat_map f B.
  Proof.
    intros H x [y []] % in_flat_map.
    eapply in_flat_map; exists y; intuition.
  Qed.

  Lemma flat_map_in_incl f a A:
    a ∈ A -> f a ⊆ flat_map f A.
  Proof.
    revert A; eapply in_ind; cbn; intuition.
  Qed.

End FlatMap.


(** * Logic: Logic in Coq *)

Require Export MoreCoq.

(** * Proofs and Evidence *)

(** ** Implications _are_ functions *)

(** * Conjunction (Logical "and") *)

Inductive and (P Q : Prop) : Prop :=
  conj : P -> Q -> (and P Q).

Notation "P /\ Q" := (and P Q) : type_scope.

(** ** "Eliminating" conjunctions *)

Theorem proj1 : forall P Q : Prop,
  P /\ Q -> P.
Proof.
  intros P Q H.
  inversion H as [HP HQ].
  apply HP.  Qed.

(** **** Exercise: 1 star, optional (proj2) *)
Theorem proj2 : forall P Q : Prop,
  P /\ Q -> Q.
Proof.
  intros P Q H.
  inversion H as [HP HQ].
  apply H.
Qed.

Theorem and_commut : forall P Q : Prop,
  P /\ Q -> Q /\ P.
Proof.
  (* WORKED IN CLASS *)
  intros P Q H.
  inversion H as [HP HQ].
  split.
    Case "left". apply HQ.
    Case "right". apply HP.  Qed.

(** **** Exercise: 2 stars (and_assoc) *)
(** In the following proof, notice how the _nested pattern_ in the
    [inversion] breaks the hypothesis [H : P /\ (Q /\ R)] down into
    [HP: P], [HQ : Q], and [HR : R].  Finish the proof from there: *)

Theorem and_assoc : forall P Q R : Prop,
  P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R H.
  inversion H as [HP [HQ HR]].
  split.
    split.
      apply HP.
      apply HQ.
    apply HR.
Qed.

(** * Iff *)

Definition iff (P Q : Prop) := (P -> Q) /\ (Q -> P).

Notation "P <-> Q" := (iff P Q)
                      (at level 95, no associativity)
                      : type_scope.

Theorem iff_implies : forall P Q : Prop,
  (P <-> Q) -> P -> Q.
Proof.
  intros P Q H.
  inversion H as [HAB HBA]. apply HAB.  Qed.

Theorem iff_sym : forall P Q : Prop,
  (P <-> Q) -> (Q <-> P).
Proof.
  (* WORKED IN CLASS *)
  intros P Q H.
  inversion H as [HAB HBA].
  split.
    Case "->". apply HBA.
    Case "<-". apply HAB.  Qed.

(** **** Exercise: 1 star, optional (iff_properties) *)
(** Using the above proof that [<->] is symmetric ([iff_sym]) as
    a guide, prove that it is also reflexive and transitive. *)

Theorem iff_refl : forall P : Prop,
  P <-> P.
Proof.
  intros P.
  split.
    intros HP. apply HP.
    intros HP. apply HP.
Qed.

Theorem iff_trans : forall P Q R : Prop,
  (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
  intros P Q R HPQ HQR.
  inversion HPQ as [HAB HBA].
  inversion HQR as [HBC HCB].
  split.
    Case "P -> R".
      intros HP.
      apply HAB in HP. apply HBC. apply HP.
    Case "R -> P".
      intros HR.
      apply HCB in HR. apply HBA. apply HR.
Qed.
(** Hint: If you have an iff hypothesis in the context, you can use
    [inversion] to break it into two separate implications.  (Think
    about why this works.) *)

(** * Disjunction (Logical "or") *)

(** ** Implementing Disjunction *)

Inductive or (P Q : Prop) : Prop :=
  | or_introl : P -> or P Q
  | or_intror : Q -> or P Q.

Notation "P \/ Q" := (or P Q) : type_scope.

Theorem or_commut : forall P Q : Prop,
  P \/ Q  -> Q \/ P.
Proof.
  intros P Q H.
  inversion H as [HP | HQ].
    Case "left". apply or_intror. apply HP.
    Case "right". apply or_introl. apply HQ.  Qed.

Theorem or_distributes_over_and_1 : forall P Q R : Prop,
  P \/ (Q /\ R) -> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R. intros H. inversion H as [HP | [HQ HR]].
    Case "left". split.
      SCase "left". left. apply HP.
      SCase "right". left. apply HP.
    Case "right". split.
      SCase "left". right. apply HQ.
      SCase "right". right. apply HR.  Qed.

(** **** Exercise: 2 stars (or_distributes_over_and_2) *)
Theorem or_distributes_over_and_2 : forall P Q R : Prop,
  (P \/ Q) /\ (P \/ R) -> P \/ (Q /\ R).
Proof.
  intros P Q R H.
  inversion H as [[HP1 | HQ] [HP2 | HR]].
  Case "P1 and P2".
    left. apply HP1.
  Case "P1 and R".
    left. apply HP1.
  Case "Q and P2".
    left. apply HP2.
  Case "Q and R".
    right. split. apply HQ. apply HR.
Qed.

(** **** Exercise: 1 star, optional (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.
    Case "->". apply or_distributes_over_and_1.
    Case "<-". apply or_distributes_over_and_2.
Qed.

(** ** Relating [/\] and [\/] with [andb] and [orb] (advanced) *)

Theorem andb_prop : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  (* WORKED IN CLASS *)
  intros b c H.
  destruct b.
    Case "b = true". destruct c.
      SCase "c = true". apply conj. reflexivity. reflexivity.
      SCase "c = false". inversion H.
    Case "b = false". inversion H.  Qed.

Theorem andb_true_intro : forall b c,
  b = true /\ c = true -> andb b c = true.
Proof.
  (* WORKED IN CLASS *)
  intros b c H.
  inversion H.
  rewrite H0. rewrite H1. reflexivity. Qed.

(** **** Exercise: 2 stars, optional (bool_prop) *)
Theorem andb_false : forall b c,
  andb b c = false -> b = false \/ c = false.
Proof.
  intros b c H. destruct b.
    Case "b = true". destruct c.
      SCase "c = true". inversion H.
      SCase "c = false". right. reflexivity.
    Case "b = false". left. reflexivity.
Qed.

Theorem orb_prop : forall b c,
  orb b c = true -> b = true \/ c = true.
Proof.
  intros b c H. destruct b.
    Case "b = true". left. reflexivity.
    Case "b = false". destruct c.
      SCase "c = true". right. reflexivity.
      SCase "c = false". inversion H.
Qed.

Theorem orb_false_elim : forall b c,
  orb b c = false -> b = false /\ c = false.
Proof.
  intros b c H. destruct b.
    Case "b = true". inversion H.
    Case "b = false". destruct c.
      inversion H.
      apply conj. reflexivity. reflexivity.
Qed.

(** * Falsehood *)

Inductive False : Prop := .

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

(** ** Truth *)

(** **** Exercise: 2 stars, advanced (True) *)
(** Define [True] as another inductively defined proposition.  (The
    intuition is that [True] should be a proposition for which it is
    trivial to give evidence.) *)

Inductive True : Prop := true : True.

(** * Negation *)

Definition not (P:Prop) := P -> False.

Notation "~ x" := (not x) : type_scope.

Theorem not_False :
  ~ False.
Proof.
  unfold not. intros H. inversion H.  Qed.

Theorem contradiction_implies_anything : forall P Q : Prop,
  (P /\ ~P) -> Q.
Proof.
  (* WORKED IN CLASS *)
  intros P Q H. inversion H as [HP HNA]. unfold not in HNA.
  apply HNA in HP. inversion HP.  Qed.

Theorem double_neg : forall P : Prop,
  P -> ~~P.
Proof.
  (* WORKED IN CLASS *)
  intros P H. unfold not. intros G. apply G. apply H.  Qed.

(** **** Exercise: 2 stars, advanced (double_neg_inf) *)
(** Write an informal proof of [double_neg]:

   _Theorem_: [P] implies [~~P], for any proposition [P].

   _Proof_:
(* TODO *)
   []
*)

(** **** Exercise: 2 stars (contrapositive) *)
Theorem contrapositive : forall P Q : Prop,
  (P -> Q) -> (~Q -> ~P).
Proof.
  intros P Q H1 H2. unfold not. unfold not in H2. intros H.
  apply H2. apply H1. apply H.
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. inversion H. apply H1. apply H0.
Qed.

(** **** Exercise: 1 star, advanced (informal_not_PNP) *)
(** Write an informal proof (in English) of the proposition [forall P
    : Prop, ~(P /\ ~P)]. *)

(* TODO *)
(** [] *)

(** *** Constructive logic *)

(** **** Exercise: 5 stars, advanced, optional (classical_axioms) *)
(** For those who like a challenge, here is an exercise
    taken from the Coq'Art book (p. 123).  The following five
    statements are often considered as characterizations of
    classical logic (as opposed to constructive logic, which is
    what is "built in" to Coq).  We can't prove them in Coq, but
    we can consistently add any one of them as an unproven axiom
    if we wish to work in classical logic.  Prove that these five
    propositions are equivalent. *)

Definition peirce := forall P Q: Prop,
  ((P->Q)->P)->P.
Definition classic := forall P:Prop,
  ~~P -> P.
Definition excluded_middle := forall P:Prop,
  P \/ ~P.
Definition de_morgan_not_and_not := forall P Q:Prop,
  ~(~P /\ ~Q) -> P\/Q.
Definition implies_to_or := forall P Q:Prop,
  (P->Q) -> (~P\/Q).

Module ex_classical_axioms.

(* Theorem th1eq2 : forall P Q : Prop, *)
(*   ((P->Q)->P)->P <-> ~~P -> P. *)
(* Proof. *)
(*   intros P Q. split. *)
(*   Case "->". intros H0. unfold not. intros H1. apply H0. *)
(*   intros H2. apply contrapositive in H2. unfold not in H2. *)
(*   apply H1 in H2. inversion H2. *)
(*   unfold not. intros HQ. apply H1. intros HP. apply double_neg.  *)
(** [] *)

End ex_classical_axioms.

(** **** Exercise: 3 stars (excluded_middle_irrefutable) *)
(** This theorem implies that it is always safe to add a decidability
axiom (i.e. an instance of excluded middle) for any _particular_ Prop [P].
Why? Because we cannot prove the negation of such an axiom; if we could,
we would have both [~ (P \/ ~P)] and [~ ~ (P \/ ~P)], a contradiction. *)

Theorem excluded_middle_irrefutable : forall (P : Prop),
  ~ ~ (P \/ ~ P).
Proof.
  intros P. unfold not. intros H0. apply H0.
  right. intros HP. apply H0. left. apply HP.
Qed.

(** ** Inequality *)

Notation "x <> y" := (~ (x = y)) : type_scope.

Theorem not_false_then_true : forall b : bool,
  b <> false -> b = true.
Proof.
  intros b H. destruct b.
  Case "b = true". reflexivity.
  Case "b = false".
    unfold not in H.
    apply ex_falso_quodlibet.
    apply H. reflexivity.   Qed.

(** **** Exercise: 2 stars (false_beq_nat) *)
Theorem false_beq_nat : forall n m : nat,
     n <> m ->
     beq_nat n m = false.
Proof.
  intros n.
  induction n as [| n'].
  Case "n = 0".
    intros m H. unfold not in H. destruct m as [| m'].
    SCase "m = 0".
      simpl. apply ex_falso_quodlibet. apply H. reflexivity.
    SCase "m = S m'".
      simpl. reflexivity.
  Case "n = S n'".
    intros m H. destruct m as [| m'].
    SCase "m = 0".
      simpl. reflexivity.
    SCase "m = S m'".
      apply IHn'.
      unfold not. unfold not in H. intros H0.
      apply H. apply f_equal. apply H0.
Qed.

(** **** Exercise: 2 stars, optional (beq_nat_false) *)
Theorem beq_nat_false : forall n m,
  beq_nat n m = false -> n <> m.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
    intros m H. destruct m as [| m'].
    SCase "m = 0".
      unfold not. inversion H.
    SCase "m = S m'". intros H0. inversion H0.
  Case "n = S n'".
    intros m H. destruct m as [| m'].
    SCase "m = 0".
      unfold not. intro H0. inversion H0.
    SCase "m = S m'".
      apply IHn' in H. unfold not. unfold not in H.
      intros H0. apply H. apply eq_add_S. apply H0.
Qed.


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


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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