Require Import Coq.Arith.PeanoNat.
Require Import List.
Import ListNotations.
Require Import Lia.

Require Import CoqChess.Util.Rel.
Require Import CoqChess.Util.Dist.
Require Import CoqChess.Util.SBetween.
Require Import CoqChess.Util.Dec.
Require Import CoqChess.Util.UIP.

Definition Fin (n : nat) : Type :=
  { x : nat & x < n }.

Definition val : forall {n}, Fin n -> nat :=
  fun n => @projT1 nat (fun x => x < n).

Definition val_small : forall {n} (i : Fin n), val i < n :=
  fun n => @projT2 nat (fun x => x < n).

Lemma val_inj : forall {n} (i j : Fin n),
  val i = val j -> i = j.
Proof.
  induction n; intros.
  { destruct i; lia. }
  { destruct i,j; simpl in *.
    destruct H.
    f_equal; apply UIP.
  }
Qed.

Definition Fin_0 {n} : Fin (S n).
Proof.
  exists 0.
  lia.
Defined.

Definition Fin_S {n} : Fin n -> Fin (S n).
Proof.
  intros [i Hi].
  exists (S i).
  lia.
Defined.

Definition Fin_case {n} : forall (i : Fin (S n)),
  (i = Fin_0) + {j : Fin n & i = Fin_S j}.
Proof.
  intro i.
  destruct (val i) eqn:?.
  - left.
    apply val_inj; auto.
  - right.
    destruct i as [i Hi].
    destruct i.
    + discriminate.
    + simpl in *.
      assert (i < n) as pf by lia.
      exists (existT _ i pf).
      apply val_inj.
      reflexivity.
Defined.

Fixpoint all_fin n : list (Fin n) :=
  match n with
  | 0 => []
  | S m => Fin_0 :: List.map Fin_S (all_fin m)
  end.

Lemma all_fin_In (n : nat) : forall i : Fin n,
  In i (all_fin n).
Proof.
  induction n.
  - intros [n Hn]; lia.
  - intro i.
    destruct (Fin_case i).
    + left; congruence.
    + right.
      destruct s as [j Hj].
      rewrite Hj.
      apply in_map.
      apply IHn.
Qed.

Definition fin_dist {n} : Fin n -> Fin n -> nat :=
  fun i j => dist (val i) (val j).

Lemma fin_dist_sym {n} : forall i j : Fin n,
  fin_dist i j = fin_dist j i.
Proof.
  intros.
  apply dist_sym.
Qed.

Definition fin_sbetween {n} : Rel 3 (Fin n) :=
  fun i j k => sbetween (val i) (val j) (val k).

Lemma fin_sbetween_sym {n} : forall i j k : Fin n,
  fin_sbetween i j k -> fin_sbetween k j i.
Proof.
  intros i j k; unfold fin_sbetween; apply sbetween_sym.
Qed.

#[export] Instance Fin_Discrete : forall {n},
  Discrete (Fin n).
Proof.
  intros.
  constructor.
  intros i j.
  destruct (Nat.eq_dec (val i) (val j)).
  - left; apply val_inj; auto.
  - right; congruence.
Defined.

#[export] Instance Fin_Exhaustible : forall {n},
  Exhaustible (Fin n).
Proof.
  intro n.
  constructor.
  induction n.
  - intros P _.
    right; intros [[] _]; lia.
  - intros P Pd.
    destruct (Pd Fin_0).
    + left; exists Fin_0; auto.
    + destruct (IHn (fun j => P (Fin_S j))).
      * intro; apply Pd.
      * left; destruct e as [j Hj].
        exists (Fin_S j); auto.
      * right; intros [i Hi].
        destruct (Fin_case i) as [|[j Hj]].
        ** congruence.
        ** apply n1.
           exists j; congruence.
Defined.


(** * Selection:  Selection Sort, With Specification and Proof of Correctness*)
(**
  This sorting algorithm works by choosing (and deleting) the smallest
  element, then doing it again, and so on.  It takes O(N^2) time.

  You should never* use a selection sort.  If you want a simple
  quadratic-time sorting algorithm (for small input sizes) you should
  use insertion sort.  Insertion sort is simpler to implement, runs
  faster, and is simpler to prove correct.   We use selection sort here
  only to illustrate the proof techniques.

     *Well, hardly ever.  If the cost of "moving" an element is _much_
  larger than the cost of comparing two keys, then selection sort is
  better than insertion sort.  But this consideration does not apply in our
  setting, where the elements are  represented as pointers into the
  heap, and only the pointers need to be moved.

  What you should really never use is bubble sort.  Bubble sort
  would be the wrong way to go.  Everybody knows that!
  https://www.youtube.com/watch?v=k4RRi_ntQc8
*)

(* ################################################################# *)
(** * The Selection-Sort Program  *)

Require Export Coq.Lists.List.
From VFA Require Import Perm.
From VFA Require Import Multiset.

(** Find (and delete) the smallest element in a list. *)

Fixpoint select (x: nat) (l: list nat) : nat * list nat :=
match l with
|  nil => (x, nil)
|  h::t => if x <=? h
               then let (j, l') := select x t in (j, h::l')
               else let (j,l') := select h t in (j, x::l')
end.

(** Now, selection-sort works by repeatedly extracting the smallest element,
   and making a list of the results. *)

(* Uncomment this function, and try it.
Fixpoint selsort l :=
match l with
| i::r => let (j,r') := select i r
               in j :: selsort r'
| nil => nil
end.
*)

(** _Error: Recursive call to selsort has principal argument equal
  to [r'] instead of [r]_.  That is, the recursion is not _structural_, since
  the list r' is not a structural sublist of (i::r).  One way to fix the
  problem is to use Coq's [Function] feature, and prove that
  [length(r')<length(i::r)].  Later in this chapter, we'll show that approach.

  Instead, here we solve this problem is by providing "fuel", an additional
  argument that has no use in the algorithm except to bound the
  amount of recursion.  The [n] argument, below, is the fuel. *)

Fixpoint selsort l n {struct n} :=
match l, n with
| x::r, S n' => let (y,r') := select x r
               in y :: selsort r' n'
| nil, _ => nil
| _::_, O => nil  (* Oops!  Ran out of fuel! *)
end.

(** What happens if we run out of fuel before we reach the end
   of the list?  Then WE GET THE WRONG ANSWER. *)

Example out_of_gas: selsort [3;1;4;1;5] 3 <> [1;1;3;4;5].
Proof.
simpl.
intro. inversion H.
Qed.

(** What happens if we have have too much fuel?  No problem. *)

Example too_much_gas: selsort [3;1;4;1;5] 10 = [1;1;3;4;5].
Proof.
simpl.
auto.
Qed.

(** The selection_sort algorithm provides just enough fuel. *)

Definition selection_sort l := selsort l (length l).

Example sort_pi: selection_sort [3;1;4;1;5;9;2;6;5;3;5] = [1;1;2;3;3;4;5;5;5;6;9].
Proof.
unfold selection_sort.
simpl.
reflexivity.
Qed.

(** Specification of correctness of a sorting algorithm:
   it rearranges the elements into a list that is totally ordered. *)

Inductive sorted: list nat -> Prop :=
 | sorted_nil: sorted nil
 | sorted_1: forall i, sorted (i::nil)
 | sorted_cons: forall i j l, i <= j -> sorted (j::l) -> sorted (i::j::l).

Definition is_a_sorting_algorithm (f: list nat -> list nat) :=
  forall al, Permutation al (f al) /\ sorted (f al).

(* ################################################################# *)
(** * Proof of Correctness of Selection sort *)

(** Here's what we want to prove. *)

Definition selection_sort_correct : Prop :=
    is_a_sorting_algorithm selection_sort.

(** We'll start by working on part 1, permutations. *)

(** **** Exercise: 3 stars (select_perm)  *)
Lemma select_perm: forall x l,
  let (y,r) := select x l in
   Permutation (x::l) (y::r).
Proof.

(** NOTE: If you wish, you may [Require Import Multiset] and use the  multiset
  method, along with the theorem [contents_perm].  If you do,
  you'll still leave the statement of this theorem unchanged. *)

intros x l; revert x.
induction l; intros; simpl in *.
auto.
bdestruct (x <=? a).
- remember (select x l). destruct p.
  apply perm_trans with (l' := ((a :: x :: l))).
  -- econstructor.
  -- apply perm_trans with (l' := ((a :: n :: l0))).
     * econstructor. specialize (IHl x).
       remember (select x l). destruct Heqp. auto.
     * econstructor.
- remember (select a l). destruct p.
  apply perm_trans with (l' := ((x :: n :: l0))).
  -- constructor.
     specialize (IHl a).
     remember (select a l). destruct p.
     eapply perm_trans. apply IHl. inv Heqp. auto.
  -- constructor.
Qed.
(** [] *)

Lemma select_perm_alt: forall x l y r,
   (y,r) = select x l ->
   Permutation (x::l) (y::r).
Proof.
  intros.
  assert (let (y,r) := select x l in
   Permutation (x::l) (y::r)).
  -- apply select_perm.
  -- destruct H. auto.
Qed.

Lemma select_preserves_len:
   forall  y r x l, ((y,r) = select x l) -> (length r) = (length l).
Proof.
  intros. generalize dependent r. generalize dependent x.
   generalize dependent y. induction l.
  - intros. simpl in H. inv H. auto.
  - intros. simpl in H. destruct (x <=? a).
    -- destruct (select x l) eqn : T. inv H. simpl. f_equal. eapply IHl. eauto.
    --  destruct (select a l) eqn : T. inv H.  simpl. f_equal. eapply IHl. eauto.
Qed.

(** **** Exercise: 3 stars (selection_sort_perm)  *)
Lemma selsort_perm:
  forall n,
  forall l, length l = n -> Permutation l (selsort l n).
Proof.
(** NOTE: If you wish, you may [Require Import Multiset] and use the  multiset
  method, along with the theorem [same_contents_iff_perm]. *)
intros.
(* apply same_contents_iff_perm. *)
generalize dependent l.
induction n.
- intros. destruct l. simpl. auto. inv H.
- intros. destruct l.
  -- inv H.
  -- simpl.
     remember (select n0 l). destruct p.
     apply perm_trans with (l' := (n1 :: l0)).
     * apply select_perm_alt. auto.
     * econstructor. apply IHn. simpl in H. inv H.
       eapply select_preserves_len. eauto.
Qed.

Theorem selection_sort_perm:
  forall l, Permutation l (selection_sort l).
Proof.
  unfold selection_sort. intros.
  apply selsort_perm. auto.
Qed.
(** [] *)

(** **** Exercise: 3 stars (select_smallest)  *)
Lemma select_smallest_aux:
  forall x al y bl,
    Forall (fun z => y <= z) bl ->
    select x al = (y,bl) ->
    y <= x.
Proof.
(* Hint: no induction needed in this lemma.
   Just use existing lemmas about select, along with [Forall_perm] *)
intros.
assert (Permutation (x :: al) (y :: bl)).
- apply select_perm_alt.  auto.
- assert (Forall (fun z : nat => y <= z) (y :: bl)).
  * constructor. auto. auto.
  * assert (Forall (fun z : nat => y <= z) (x :: al)).
    -- eapply Forall_perm.
       2 : apply H2. apply Permutation_sym. auto.
    -- inv H3. auto.
Qed.

Theorem select_smallest:
  forall x al y bl, select x al = (y,bl) ->
     Forall (fun z => y <= z) bl.
Proof.
intros x al; revert x; induction al; intros; simpl in *.
- inv H. auto.
- bdestruct (x <=? a).
  * destruct (select x al) eqn:?H.
    inv H. constructor.
    --  eapply le_trans.
        2 : apply H0.
        eapply select_smallest_aux. eapply IHal. apply H1. apply H1.
    -- eapply IHal. eauto.
  * destruct (select a al) eqn:?H.
    inv H.
    constructor.
    -- apply le_trans with (m := a).
       **  eapply select_smallest_aux. eapply IHal. eauto. eauto.
       **  omega.
    -- eauto.
Qed.

(** **** Exercise: 3 stars (selection_sort_sorted)  *)
Lemma selection_sort_sorted_aux:
  forall  y bl,
   sorted (selsort bl (length bl)) ->
   Forall (fun z : nat => y <= z) bl ->
   sorted (y :: selsort bl (length bl)).
Proof.
 (* Hint: no induction needed.  Use lemmas selsort_perm and Forall_perm.*)
 intros.
 assert (Forall (fun z : nat => y <= z) (selsort bl (length bl)) ).
 - eapply Forall_perm. eapply selsort_perm. auto. auto.
 - destruct (selsort bl (length bl)) eqn : S.
  -- constructor.
  -- econstructor.
    * inv H1. auto.
    * auto.
Qed.

Theorem selection_sort_sorted: forall al, sorted (selection_sort al).
Proof.
intros.
unfold selection_sort.
(* Hint: do induction on the [length] of al.
    In the inductive case, use [select_smallest], [select_perm],
    and [selection_sort_sorted_aux]. *)
remember (length al). generalize dependent al.
induction n.
- intros. destruct al. simpl. constructor. simpl in Heqn. discriminate.
- intros. destruct al. simpl in Heqn. discriminate.
  remember (select n0 al). destruct p.
  assert (sorted (n1 :: (selsort l n))).
  -- assert (length l = n).
     * simpl in Heqn.
       replace n with (length al).
       --- eapply select_preserves_len. eauto.
       ---  omega.
     * rewrite <- H. apply selection_sort_sorted_aux.
       ** rewrite -> H. apply IHn. auto.
       ** eapply select_smallest. rewrite -> Heqp. auto.
  -- unfold selsort. rewrite <- Heqp. apply H.
Qed.

(** [] *)

(** Now we wrap it all up.  *)

Theorem selection_sort_is_correct: selection_sort_correct.
Proof.
split. apply selection_sort_perm. apply selection_sort_sorted.
Qed.

(* ################################################################# *)
(** * Recursive Functions That are Not Structurally Recursive *)

(** [Fixpoint] in Coq allows for recursive functions where some
  parameter is structurally recursive: in every call, the argument
  passed at that parameter position is an immediate substructure
  of the corresponding formal parameter.  For recursive functions
  where that is not the case -- but for which you can still prove
  that they terminate -- you can use a more advanced feature of
  Coq, called [Function]. *)

Require Import Recdef.  (* needed for [Function] feature *)

Function selsort' l {measure length l} :=
match l with
| x::r => let (y,r') := select x r
               in y :: selsort' r'
| nil => nil
end.

(** When you use [Function] with [measure], it's your
  obligation to prove that the measure actually decreases,
  before you can use the function. *)

Proof.
intros.
pose proof (select_perm x r).
rewrite teq0 in H.
apply Permutation_length in H.
simpl in *; omega.
Defined.  (* Use [Defined] instead of [Qed], otherwise you
  can't compute with the function in Coq. *)

(** **** Exercise: 3 stars (selsort'_perm)  *)
Lemma selsort'_perm:
  forall n,
  forall l, length l = n -> Permutation l (selsort' l).
Proof.

(** NOTE: If you wish, you may [Require Import Multiset]
  and use the  multiset method, along with the
  theorem [same_contents_iff_perm]. *)

(** Important!  Don't unfold [selsort'], or in general, never
  unfold anything defined with [Function]. Instead, use the
  recursion equation [selsort'_equation] that is automatically
  defined by the [Function] command. *)

  intros. generalize dependent l.
  induction n; intros.
  - destruct l. auto. simpl in H. inv H.
  - destruct l. simpl in H. inv H.
    remember (select n0 l). destruct p.
    rewrite -> selsort'_equation. rewrite <- Heqp.
    apply perm_trans with (l' := (n1 :: l0)).
    * apply select_perm_alt. auto.
    * econstructor. apply IHn. simpl in H. replace n with (length l).
      -- eapply select_preserves_len. eauto.
      -- omega.
(** [] *)

Eval compute in selsort' [3;1;4;1;5;9;2;6;5].

(** $Date$ *)


Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import String.
Import ListNotations.

Module AExp.

Inductive aexp: Type:=
  | ANum: nat -> aexp
  | APlus: aexp -> aexp -> aexp
  | AMinus: aexp -> aexp -> aexp
  | AMult: aexp -> aexp -> aexp.

Inductive bexp: Type :=
  | BTrue: bexp
  | BFalse: bexp
  | BEq: aexp -> aexp -> bexp
  | BLe: aexp -> aexp -> bexp
  | BNot: bexp -> bexp
  | BAnd: bexp -> bexp -> bexp.

Fixpoint aeval (a: aexp): nat :=
  match a with
  | ANum n => n
  | APlus a1 a2 => (aeval a1) + (aeval a2)
  | AMinus a1 a2  => (aeval a1) - (aeval a2)
  | AMult a1 a2 => (aeval a1) * (aeval a2)
  end.

Fixpoint beval (b: bexp): bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval a1) (aeval a2)
  | BLe a1 a2   => leb (aeval a1) (aeval a2)
  | BNot b1     => negb (beval b1)
  | BAnd b1 b2  => andb (beval b1) (beval b2)
  end.

Fixpoint optimize_0plus (a: aexp): aexp :=
  match a with
  | ANum n =>
      ANum n
  | APlus (ANum 0) e2 =>
      optimize_0plus e2
  | APlus e1 e2 =>
      APlus (optimize_0plus e1) (optimize_0plus e2)
  | AMinus e1 e2 =>
      AMinus (optimize_0plus e1) (optimize_0plus e2)
  | AMult e1 e2 =>
      AMult (optimize_0plus e1) (optimize_0plus e2)
  end.

(* proved in Imp *)
Axiom optimize_0plus_sound: forall a, aeval (optimize_0plus a) = aeval a.

(** **** Exercise: 3 stars (optimize_0plus_b)  *)

Fixpoint optimize_0plus_b (b: bexp): bexp :=
  match b with
  | BTrue => BTrue
  | BFalse => BFalse
  | BEq a1 a2 => BEq (optimize_0plus a1) (optimize_0plus a2)
  | BLe a1 a2 => BLe (optimize_0plus a1) (optimize_0plus a2)
  | BNot b1 => BNot (optimize_0plus_b b1)
  | BAnd b1 b2 => BAnd (optimize_0plus_b b1) (optimize_0plus_b b2)
  end.

Theorem optimize_0plus_b_sound: forall b, beval (optimize_0plus_b b) = beval b.
Proof.
  intros b.
  induction b;
    try (
      reflexivity
    );
    try (
      simpl;
      repeat (rewrite optimize_0plus_sound);
      reflexivity
    ).
  - simpl.
    rewrite IHb.
    reflexivity.
  - simpl.
    rewrite IHb1.
    rewrite IHb2.
    reflexivity.
Qed.

(** **** Exercise: 4 stars, optional (optimizer)  *)
(* not do it *)

End AExp.

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

Definition beq_id x y :=
  match x, y with
  | Id n1, Id n2 => if string_dec n1 n2 then true else false
  end.

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

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

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

Definition state := total_map nat.

Definition empty_state : state :=  t_empty 0.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp                (* <----- NEW *)
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Definition W : id := Id "W".
Definition X : id := Id "X".
Definition Y : id := Id "Y".
Definition Z : id := Id "Z".

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x                                (* <----- NEW *)
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2  => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2   => leb (aeval st a1) (aeval st a2)
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  end.

Inductive com: Type :=
  | CSkip: com
  | CAss: id -> aexp -> com
  | CSeq: com -> com -> com
  | CIf: bexp -> com -> com -> com
  | CWhile: bexp -> com -> com.

Notation "'SKIP'" := CSkip.
Notation "x '::=' a" := (CAss x a) (at level 60).
Notation "c1 ;; c2" := (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).

Reserved Notation "c1 '/' st '\\' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st \\ st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      (x ::= a1) / st \\ (t_update st x n)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  \\ st' ->
      c2 / st' \\ st'' ->
      (c1 ;; c2) / st \\ st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      c1 / st \\ st' ->
      (IFB b THEN c1 ELSE c2 FI) / st \\ st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      c2 / st \\ st' ->
      (IFB b THEN c1 ELSE c2 FI) / st \\ st'
  | E_WhileEnd : forall b st c,
      beval st b = false ->
      (WHILE b DO c END) / st \\ st
  | E_WhileLoop : forall st st' st'' b c,
      beval st b = true ->
      c / st \\ st' ->
      (WHILE b DO c END) / st' \\ st'' ->
      (WHILE b DO c END) / st \\ st''

  where "c1 '/' st '\\' st'" := (ceval c1 st st').

(** **** Exercise: 2 stars (ceval_example2)  *)
Example ceval_example2:
    (X ::= ANum 0;; Y ::= ANum 1;; Z ::= ANum 2) / empty_state \\
    (t_update (t_update (t_update empty_state X 0) Y 1) Z 2).
Proof.
  apply E_Seq with (t_update empty_state X 0).
  - apply E_Ass.
    reflexivity.
  - apply E_Seq with (t_update (t_update empty_state X 0) Y 1).
    + apply E_Ass.
      reflexivity.
    + apply E_Ass.
      reflexivity.
Qed.

(** **** Exercise: 3 stars, advanced (pup_to_n)  *)

Definition pup_to_n: com :=
  Y ::= ANum 0;;
  WHILE (BLe (AId X) (ANum 0)) DO
    Y ::= APlus (AId X) (AId Y);;
    X ::= AMinus (AId X) (ANum 1)
  END.

(*
Theorem pup_to_2_ceval :
  pup_to_n / (t_update empty_state X 2) \\
    t_update (t_update (t_update (t_update (t_update (t_update empty_state
      X 2) Y 0) Y 2) X 1) Y 3) X 0.
Proof.
  unfold pup_to_n.
  apply E_Seq with (t_update (t_update empty_state X 2) Y 0).
  - apply E_Ass.
    reflexivity.
Abort.
*)

(** **** Exercise: 3 stars, recommendedM (XtimesYinZ_spec)  *)
Definition XtimesYinZ : com := Z ::= (AMult (AId X) (AId Y)).

(* proved in Maps *)
Axiom t_update_eq: forall A (m: total_map A) x v, (t_update m x v) x = v.

Theorem xtimesyinz_spec: forall st n m st',
  st X = n ->
  st Y = m ->
  XtimesYinZ / st \\ st' ->
  st' Z = n * m.
Proof.
  intros st n m st' H P Q.
  inversion Q.
  subst.
  simpl.
  apply t_update_eq.
Qed.

(* More exercises *)

(** **** Exercise: 3 stars (stack_compiler)  *)

Module stack_compiler.
Inductive aexp: Type:=
  | ANum: nat -> aexp
  | AId: id-> aexp
  | APlus: aexp -> aexp -> aexp
  | AMinus: aexp -> aexp -> aexp
  | AMult: aexp -> aexp -> aexp.

Inductive sinstr: Type :=
  | SPush: nat -> sinstr
  | SLoad: id -> sinstr
  | SPlus: sinstr
  | SMinus: sinstr
  | SMult: sinstr
  .

Fixpoint s_execute (st: state)(stack: list nat)(prog: list sinstr): list nat :=
  match prog with
  | nil => stack
  | SPush n :: h  => s_execute st (n :: stack) h
  | SLoad id :: h => s_execute st (st id :: stack) h
  | SPlus :: h =>
    match stack with
    | x :: y :: t => s_execute st ((y + x) :: t) h
    | _ => stack
    end
  | SMinus :: h =>
    match stack with
    | x :: y :: t => s_execute st ((y - x) :: t) h
    | _ => stack
    end
  | SMult :: h =>
    match stack with
    | x :: y :: t => s_execute st ((y * x) :: t) h
    | _ => stack
    end
  end.

Example s_execute1: s_execute empty_state [] [SPush 5; SPush 3; SPush 1; SMinus] = [2; 5].
Proof. reflexivity. Qed.

Definition X: id := Id "X".
Definition Y: id := Id "Y".

Example s_execute2: s_execute (t_update empty_state X 3) [3;4][SPush 4; SLoad X; SMult; SPlus]
   = [15; 4].
Proof. reflexivity. Qed.

Fixpoint s_compile (e: aexp): list sinstr :=
  match e with
  | ANum n =>     SPush n :: nil
  | AId id =>     SLoad id :: nil
  | APlus x y =>  s_compile x ++ s_compile y ++ [SPlus]
  | AMinus x y => s_compile x ++ s_compile y ++ [SMinus]
  | AMult x y =>  s_compile x ++ s_compile y ++ [SMult]
  end.

Example s_compile1: s_compile (AMinus (AId X) (AMult (ANum 2) (AId Y)))
  = [SLoad X; SPush 2; SLoad Y; SMult; SMinus].
Proof. reflexivity. Qed.

End stack_compiler.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div fintype.
From mathcomp Require Import tuple finfun bigop.
Require Import Reals Fourier.
Require Import Reals_ext Rssr Rbigop log2 ln_facts proba divergence.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** * Entropy of a distribution *)

Section entropy_definition.

Variable A : finType.
Variable P : dist A.

Definition entropy := - \rsum_(a in A) P a * log (P a).
Local Notation "'`H'" := (entropy) (at level 5).

Lemma entropy_pos : 0 <= `H.
Proof.
rewrite /entropy big_endo; last 2 first.
  move=> *; by rewrite Ropp_plus_distr.
  by rewrite Ropp_0.
rewrite (_ : \rsum_(_ in _) _ = \rsum_(i in A | predT A) - (P i * log (P i))); last first.
  apply eq_bigl => i /=; by rewrite inE.
apply Rle_big_0_P_g => i _.
case: (Req_EM_T (P i) 0).
  (* NB: this step in a standard textbook would be handled as a
     consequence of lim x->0 x log x = 0 *)
  move=> ->.
  rewrite Rmult_0_l.
  fourier.
move=> Hi.
rewrite Rmult_comm -Ropp_mult_distr_l_reverse.
apply Rmult_le_pos; last by apply Rle0f.
apply Ropp_0_ge_le_contravar, Rle_ge.
rewrite -log_1.
apply log_increasing_le.
move: (Rle0f P i) => abs'.
apply Rnot_le_lt => abs.
move: (Rle_antisym _ _ abs' abs) => abs''; by rewrite abs'' in Hi.
by apply dist_max.
Qed.

Hypothesis P_pos : forall b, 0 < P b.

Lemma entropy_pos_P_pos : 0 <= `H.
Proof.
rewrite /entropy big_endo; last 2 first.
  move=> *; by rewrite Ropp_plus_distr.
  by rewrite Ropp_0.
rewrite (_ : \rsum_(_ in _) _ = \rsum_(i in A | predT A) - (P i * log (P i))).
  apply Rle_big_0_P_g => i _.
  rewrite Rmult_comm -Ropp_mult_distr_l_reverse.
  apply Rmult_le_pos; last by apply Rle0f.
  apply Ropp_0_ge_le_contravar, Rle_ge.
  rewrite -log_1.
  apply log_increasing_le; by [apply P_pos | apply dist_max].
apply eq_bigl => i /=; by rewrite inE.
Qed.

End entropy_definition.

Notation "'`H'" := (entropy) (at level 5) : entropy_scope.

Local Open Scope entropy_scope.
Local Open Scope proba_scope.

Lemma entropy_Ex {A} (P : dist A) : `H P = `E (--log P).
Proof.
rewrite /entropy /mlog_rv /Ex_alt /= (big_morph _ morph_Ropp Ropp_0).
apply eq_bigr => a _; by rewrite mulRC -Ropp_mult_distr_l_reverse.
Qed.

Lemma xlnx_entropy {A} (P : dist A) :
  `H P = / ln 2 * - \rsum_(a : A) xlnx (P a).
Proof.
rewrite /entropy; f_equal; rewrite Ropp_mult_distr_r_reverse; f_equal.
rewrite (big_morph _ (morph_mulRDr _) (mulR0 _)).
apply eq_bigr => a _ ;rewrite /log /Rdiv mulRA mulRC; f_equal.
rewrite /xlnx; case : ifP => // /RltP Hcase.
have : P a = 0; last by move=> ->; rewrite mul0R.
case (Rle_lt_or_eq_dec 0 (P a)) => //; by apply Rle0f.
Qed.

Lemma entropy_uniform {A : finType} n (HA : #|A| = n.+1) :
  `H (Uniform.d HA) = log (INR #|A|).
Proof.
rewrite /entropy /Uniform.d /Uniform.f /=.
rewrite big_const iter_Rplus /Rdiv mul1R mulRA Rinv_r; last first.
  rewrite HA; by apply not_0_INR.
rewrite mul1R log_Rinv; last by rewrite HA; apply lt_0_INR; apply/ltP.
by rewrite Ropp_involutive.
Qed.

Local Open Scope reals_ext_scope.

Lemma entropy_max {A : finType} (P : dist A) : `H P <= log (INR #|A|).
Proof.
have [n HA] : exists n, #|A| = n.+1.
  exists (#|A|.-1); rewrite prednK //; by apply (dist_support_not_empty P).
have : P << (Uniform.d HA) by apply dom_by_uniform.
move/leq0div => H.
rewrite /div in H.
suff Htmp : 0 <= - `H P + log (INR #|A|) by fourier.
eapply Rle_trans; first by apply H.
apply Req_le.
transitivity (\rsum_(a|a \in A) P a * log (P a) + \rsum_(a|a \in A) P a * - log ((Uniform.d HA) a)).
  rewrite -big_split /=.
  apply eq_bigr => a _.
  by rewrite mulRDr.
rewrite /= /Uniform.f /= /Rdiv mul1R.
rewrite -[in X in _ + X = _]big_distrl /= pmf1 mul1R.
rewrite /entropy Ropp_involutive.
rewrite log_Rinv; last first.
  rewrite HA.
  apply lt_0_INR; by apply/ltP.
by rewrite Ropp_involutive.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_oppositesidesymmetric.
Require Export GeoCoq.Elements.OriginalProofs.proposition_27.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma proposition_28A :
   forall A B C D E G H,
   BetS A G B -> BetS C H D -> BetS E G H -> CongA E G B G H D -> OS B D G H ->
   Par A B C D.
Proof.
intros.
assert (OS D B G H) by (forward_using lemma_samesidesymmetric).
assert (nCol E G B) by (conclude_def CongA ).
assert (eq G G) by (conclude cn_equalityreflexive).
assert (Col G H G) by (conclude_def Col ).
assert (~ Col G H A).
 {
 intro.
 assert (Col H G A) by (forward_using lemma_collinearorder).
 assert (Col E G H) by (conclude_def Col ).
 assert (Col H G E) by (forward_using lemma_collinearorder).
 assert (neq G H) by (forward_using lemma_betweennotequal).
 assert (neq H G) by (conclude lemma_inequalitysymmetric).
 assert (Col G A E) by (conclude lemma_collinear4).
 assert (Col A G E) by (forward_using lemma_collinearorder).
 assert (Col A G B) by (conclude_def Col ).
 assert (neq A G) by (forward_using lemma_betweennotequal).
 assert (Col G E B) by (conclude lemma_collinear4).
 assert (Col E G B) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (TS A G H B) by (conclude_def TS ).
assert (TS B G H A) by (conclude lemma_oppositesidesymmetric).
assert (BetS B G A) by (conclude axiom_betweennesssymmetry).
assert (CongA E G B A G H) by (conclude proposition_15a).
assert (CongA A G H E G B) by (conclude lemma_equalanglessymmetric).
assert (CongA A G H G H D) by (conclude lemma_equalanglestransitive).
assert (TS D G H A) by (conclude lemma_planeseparation).
assert (TS A G H D) by (conclude lemma_oppositesidesymmetric).
assert (Par A B C D) by (conclude proposition_27).
close.
Qed.

End Euclid.


Set Implicit Arguments.

Require Import
        Discrete.DiscType
        Discrete.DupFree
        Discrete.In
        Tactics.Tactics.

(** function to count the number of an element in
    a list *)

Fixpoint count {A : discType}(xs : list A)(x : A) : nat :=
  match xs with
  | nil => 0
  | (cons y ys) => if decision (x = y) then 1 + (count ys x) else count ys x
  end.

(** some facts about count *)

Lemma count_not_in_iff {A : discType}
  : forall (xs : list A)(x : A), ~ (x el xs) <-> count xs x = 0.
Proof.
  induction xs as [ | x xs] ; crush.
  +
    destruct (decision (x0 = x)) ; crush.
    apply IHxs ; auto.
  +
    destruct (decision (x = x)) ; crush.
  +
    destruct* (decision (x0 = x)) as [G | G]; crush.
    specialize (IHxs x0).
    destruct IHxs. specialize (H2 H) ; crush.
Qed.

Hint Resolve count_not_in_iff.

Lemma count_in_gt_zero {A : discType}
  : forall (xs : list A)(x : A), x el xs <-> count xs x > 0.
Proof.
  induction xs as [| x xs ] ; crush.
  +
    destruct* (decision (x = x)) ; crush.
  +
    destruct* (decision (x0 = x)) ; crush.
    destruct* (IHxs x0) ; crush.
  +
    destruct (decision (x0 = x)) ; crush.
Qed.

Lemma count_in_dupfree {A : discType} (xs : list A) x
  : dup_free xs -> x el xs -> count xs x = 1.
Proof.
  intros H ; revert x ; induction H as [| x xs] ; intros y H1 ; simpl in *.
  +
    crush.
  +
    destruct H1 as [H1 | H1] ; substs.
    *
      decide (x = x) as [G | G].
      -
        specialize (count_not_in_iff xs x) ; intros H2.
        destruct* H2.
      -
        crush.
    *
      specialize (IHdup_free y H1).
      rewrite IHdup_free.
      decide (y = x) as [G | G] ; substs* ; crush.
Qed.

Lemma count_lt_dup_free {A : discType}(xs : list A)
  : (forall x, count xs x <= 1) -> dup_free xs.
Proof.
  induction xs as [| x xs] ; eauto.
  -
    intro H. constructor.
    +
      cbn in H.  specialize (H x). decide (x = x).
      assert (Hz : count xs x = 0) by omega. apply count_not_in_iff in Hz ; eauto.
      crush.
    +
      apply IHxs. intro y. specialize (H y). cbn in H. decide (y = x) ; omega.
Qed.

Lemma count_app {A : discType}(xs ys : list A) x
  : count (xs ++ ys) x = count xs x + count ys x.
Proof.
  induction xs ; crush.
  +
    decide (x = a) ; crush.
Qed.

(** dealing with options *)

Definition to_option_list {A : Type} (xs : list A) :=
    None :: map (@Some _) xs.

Lemma count_option_list (A : discType) (xs : list A) x
  : count (to_option_list xs) (Some x) = count xs x .
Proof.
  unfold to_option_list. simpl. dec ; try congruence.
  induction xs ; crush.
  +
    dec ; congruence.
Qed.

(** A list produced by toOptionList contains None exactly once *)

Lemma count_option_list_none (A : discType) (xs : list A)
  : count (to_option_list xs) None = 1.
Proof.
  unfold to_option_list. simpl. dec ; try congruence. f_equal.
    induction xs as [| x xs] ; crush.
  -
    simpl; dec; congruence.
 Qed.

Lemma dup_free_count
      (A : discType)
      (x : A)
      (xs : list A)
  : dup_free xs -> x el xs -> count xs x = 1.
Proof.
  intros D E. induction D.
  -
    contradiction E.
  -
    cbn.
    dec.
    +
      f_equal.
      subst x0.
      apply count_not_in_iff. auto.
    +
      destruct E as [E | E] ; [> congruence | auto].
Qed.


Set Warnings "-notation-overridden,-parsing".
From LF Require Export Tactics.

Definition injective {A B} (f : A -> B) :=
  forall x y : A, f x = f y -> x = y.

Theorem S_inj : injective S.
Proof.
  intros x y H. injection H as goal.
  apply goal. Qed.

Check @eq : forall A : Type, A -> A -> Prop.

Example and_example: 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  split.
  - reflexivity.
  - reflexivity. Qed.

Lemma and_intro : forall A B : Prop, A -> B -> A /\ B.
Proof.
  intros A B HA HB. split.
  - apply HA.
  - apply HB. Qed.

Example and_example': 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  apply and_intro.
  - reflexivity.
  - reflexivity. Qed.

Example and_exercise :
  forall n m : nat, n + m = 0 -> n = 0 /\ m = 0.
Proof.
  intros n m H. destruct n as [| n'] eqn:En.
  - destruct m as [| m'] eqn:Em.
    + split.
      * reflexivity.
      * reflexivity.
    + discriminate H.
  - discriminate H. Qed.

Lemma and_example2 :
  forall n m : nat, n = 0 /\ m = 0 -> n + m = 0.
Proof.
  intros n m H.
  destruct H as [Hn Hm].
  rewrite Hn. rewrite Hm.
  reflexivity. Qed.

Lemma and_example3 :
  forall n m : nat, n + m = 0 -> n * m = 0.
Proof.
  intros n m H. apply and_exercise in H.
  destruct H as [Hn Hm]. rewrite Hn. rewrite Hm.
  reflexivity. Qed.

Lemma proj1 : forall P Q : Prop,
    P /\ Q -> P.
Proof.
  intros P Q H. destruct H as [HP _]. apply HP. Qed.

Lemma proj2 : forall P Q : Prop,
    P /\ Q -> Q.
Proof.
  intros P Q H. destruct H as [_ HQ]. apply HQ. Qed.

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

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

Check and : Prop -> Prop -> Prop.

Search (_ * 0 = 0).

Lemma eq_mult_0 : forall n m : nat,
    n = 0 \/ m = 0 -> n * m = 0.
Proof.
  intros n m [Hn | Hm].
  - rewrite Hn. reflexivity.
  - rewrite Hm. rewrite <- mult_n_O. reflexivity. Qed.

Lemma or_intro_l : forall A B : Prop,
    A -> A \/ B.
Proof.
  intros A B H. left. apply H. Qed.

Lemma zero_or_succ :
  forall n : nat, n = 0 \/ n = S (pred n).
Proof.
  intro n. destruct n as [| n'] eqn:E.
  - left. reflexivity.
  - right. reflexivity. Qed.

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

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

  Check not : Prop -> Prop.
End MyNot.

Theorem ex_falso_quodlibet : forall (P : Prop), False -> P.
Proof.
  intros P contra. destruct contra. Qed.

Theorem implies_false_implies_neg : forall (P : Prop),
    (P -> False) -> ~ P.
Proof.
  intros P H. unfold not. apply H. Qed.

Theorem not_p_implies_q_implies_p_and_not_q :
  forall (P Q : Prop), ~ (P -> Q) -> ~ P /\ Q.
Proof.
  intros P Q H. Abort.

Example implication_test : forall (P Q : Prop),
    ((P -> Q) -> False) -> P.
Proof.
  intros P Q HnPQ. apply implies_false_implies_neg in HnPQ. Abort.

Fact not_implies_our_not : forall (P : Prop),
    ~ P -> (forall Q : Prop, P -> Q).
Proof.
  intros P HnP Q HP. destruct HnP. apply HP. Qed.

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

Theorem zero_not_one : 0 <> 1.
Proof.
  unfold not. intro H. discriminate H. Qed.

Theorem not_false : ~ False.
Proof.
  unfold not. intro H. destruct H. Qed.

Theorem contradiction_implies_anything : forall P Q : Prop,
    (P /\ ~P) -> Q.
Proof.
  intros P Q [HP HNA]. unfold not in HNA.
  apply HNA in HP. destruct HP. Qed.

Theorem double_neg : forall P : Prop,
    P -> ~~P.
Proof.
  intros P HP. unfold not. intros HNA.
  apply HNA in HP. destruct HP. Qed.

Theorem contrapositive : forall P Q : Prop,
    (P -> Q) -> (~Q -> ~P).
Proof.
  intros P Q HPQ. unfold not. intro HNQ. intro HP.
  apply HPQ in HP. apply HNQ in HP. destruct HP. Qed.

Theorem not_both_true_and_false : forall P : Prop,
    ~ (P /\ ~P).
Proof.
  intro P. unfold not. intros [HP HNP].
  apply HNP in HP. destruct HP. Qed.

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

Theorem not_true_is_false' : forall b : bool,
    b <> true -> b = false.
Proof.
  intros b H. destruct b eqn:Eb.
  - unfold not in H. exfalso.
    apply H. reflexivity.
  - reflexivity. Qed.

Check I : True.

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

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

Theorem iff_sym : forall (P Q : Prop),
    (P <-> Q) -> (Q <-> P).
Proof.
  intros P Q. unfold iff. intros [HPQ HQP]. split.
  - apply HQP.
  - apply HPQ. Qed.

Lemma not_true_iff_false : forall b : bool,
    b <> true <-> b = false.
Proof.
  unfold iff. split.
  - apply not_true_is_false.
  - intro H. rewrite H. intro H'. discriminate H'. Qed.

Theorem or_distributes_over_and : forall P Q R : Prop,
    P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R. unfold iff. split.
  - intros [HP | HQR].
    + split.
      * left. apply HP.
      * left. apply HP.
    + destruct HQR as [HQ HR]. split.
      * right. apply HQ.
      * right. apply HR.
  - intros [HPoQ HPoR]. destruct HPoQ as [HP | HQ].
    + destruct HPoR as [HP' | HR].
      * left. apply HP.
      * left. apply HP.
    + destruct HPoR as [HP' | HR].
      * left. apply HP'.
      * right. split.
        apply HQ. apply HR. Qed.

Lemma mult_0 : forall n m, n * m = 0 <-> n = 0 \/ m = 0.
Proof.
  split.
  - destruct n as [| n'].
    + destruct m as [| m'].
      * intro H. left. reflexivity.
      * intro H. left. reflexivity.
    + destruct m as [| m'].
      * intro H. right. reflexivity.
      * intro H. simpl in H. discriminate H.
  - apply eq_mult_0.
Qed.

Theorem or_assoc :
  forall P Q R : Prop, P \/ (Q \/ R) <-> (P \/ Q) \/ R.
Proof.
  intros P Q R. split.
  - intros [H | [H | H]].
    + left. left. apply H.
    + left. right. apply H.
    + right. apply H.
  - intros [[H | H] | H].
    + left. apply H.
    + right. left. apply H.
    + right. right. apply H.
Qed.

Lemma mult_0_3 : forall n m p,
    n * m * p = 0 <-> n = 0 \/ m = 0 \/ p = 0.
Proof.
  intros n m p. rewrite mult_0. rewrite mult_0.
  rewrite or_assoc. reflexivity. Qed.

Definition Even x := exists n : nat, x = double n.

Theorem four_is_even : Even 4.
Proof.
  unfold even. exists 2. reflexivity. Qed.

Theorem exists_example_2 : forall n,
    (exists m, n = 4 + m) ->
    (exists o, n = 2 + o).
Proof.
  intro n. intros [m Hm]. exists (2 + m).
  apply Hm. Qed.

Theorem dist_not_exists {X : Type} (P : X -> Prop) :
  (forall x, P x) -> ~ (exists x, ~ P x).
Proof.
  intros HA [x HE]. unfold not in HE.
  apply HE. apply HA. Qed.

Theorem dist_exists_or {X : Type} (P Q : X -> Prop) :
  (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
  unfold iff. split.
  - intros H. destruct H as [x HE] eqn:E.
    destruct HE as [HP | HQ].
    + left. exists x. apply HP.
    + right. exists x. apply HQ.
  - intros HE. destruct HE as [HP | HQ].
    + destruct HP as [x HE]. exists x. left. apply HE.
    + destruct HQ as [x HE]. exists x. right. apply HE. Qed.

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

Example In_example_1 : In 4 [1; 2; 3; 4; 5].
Proof.
  simpl. right. right. right. left. reflexivity. Qed.

Example In_example_2 : forall n, In n [2; 4] -> exists n', n = 2 * n'.
Proof.
  simpl. intros n [H | [H | []]].
  - exists 1. rewrite <- H. reflexivity.
  - exists 2. rewrite <- H. reflexivity. Qed.

Theorem In_map : forall (A B : Type) (f : A -> B) (l : list A) (x : A),
    In x l -> In (f x) (map f l).
Proof.
  induction l as [| h t IHt].
  - intros x. simpl. intros [].
  - simpl. intros x [Hhx | Hin].
    + left. rewrite Hhx. reflexivity.
    + right. apply IHt. apply Hin. Qed.

Theorem In_map_iff : forall (A B : Type) (f : A -> B)
                       (l : list A) (y : B),
    In y (map f l) <->
    exists x, f x = y /\ In x l.
Proof.
  intros A B f l y. split.
  - induction l as [| h t IHt].
    + intros [].
    + simpl. intros [Hfh | Hy].
      * (* f h = y *) exists h. rewrite Hfh. split.
        reflexivity. left. reflexivity.
      * (* In y (map f t) *) apply IHt in Hy.
        destruct Hy as [x [Hy Hin]]. exists x. split.
        apply Hy. right. apply Hin.
  - intros [x [Hy Hin]]. rewrite <- Hy. apply In_map.
    apply Hin. Qed.

Theorem In_app_iff : forall (A : Type) (l l' : list A) (a : A),
    In a (l ++ l') <-> (In a l) \/ (In a l').
Proof.
  intros A l. split.
  - induction l as [| h t IHt].
    + (* In a l' *) simpl. intro H. right. apply H.
    + (* In a h::t *) simpl. intros [Hha | Hin].
      * left. left. apply Hha.
      * apply or_assoc. right. apply IHt. apply Hin.
  - induction l as [| h t IHt].
    + (* In a l' *) simpl. intros [[] | H]. apply H.
    + (* In a h::t *) simpl. rewrite <- or_assoc.
      intros [Hha | Hin].
      * left. apply Hha.
      * right. apply IHt. apply Hin. Qed.

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

Theorem All_in : forall (T : Type) (P : T -> Prop) (l : list T),
    (forall x, In x l -> P x) <-> All P l.
Proof.
  intros T P. split.
  - intro H. induction l as [| h t IHt].
    + reflexivity.
    + simpl. simpl in H. split.
      * (* P h *) apply H. left. reflexivity.
      * (* All P t *) apply IHt. intros x Hin.
        apply H. right. apply Hin.
  - intro H. induction l as [| h t IHt].
    + intros x Hin. simpl in Hin. destruct Hin.
    + simpl in H. destruct H as [HPh HPt].
      simpl. intros x H. destruct H as [Hh | Ht].
      * rewrite <- Hh. apply HPh.
      * apply IHt. apply HPt. apply Ht. Qed.

Definition combine_odd_even (Podd Peven : nat -> Prop) : nat -> Prop
  := fun n : nat =>
       match (odd n) with
       | true => Podd n
       | false => Peven n
       end.

Theorem combine_odd_even_intro :
  forall (Podd Peven : nat -> Prop) (n : nat),
    (odd n = true -> Podd n) ->
    (odd n = false -> Peven n) ->
    combine_odd_even Podd Peven n.
Proof.
  intros Podd Peven n. destruct (odd n) eqn:E.
  - intros Hodd Heven. unfold combine_odd_even.
    rewrite E. apply Hodd. reflexivity.
  - intros Hodd Heven. unfold combine_odd_even.
    rewrite E. apply Heven. reflexivity. Qed.

Theorem combine_odd_even_elim_odd :
  forall (Podd Peven : nat -> Prop) (n : nat),
    combine_odd_even Podd Peven n ->
    odd n = true ->
    Podd n.
Proof.
  intros Podd Peven n H. unfold combine_odd_even in H.
  intro Hodd. rewrite Hodd in H. apply H. Qed.

Theorem combine_odd_even_elim_even :
  forall (Podd Peven : nat -> Prop) (n : nat),
    combine_odd_even Podd Peven n ->
    even n = true ->
    Peven n.
Proof.
  intros Podd Peven n H. unfold combine_odd_even in H.
  intro Heven. unfold odd in H. rewrite Heven in H.
  simpl in H. apply H. Qed.

Definition disc_fn (n : nat) : Prop :=
  match n with
  | O => True
  | S _ => False
  end.

Theorem disc : forall n, ~ (O = S n).
Proof.
  intros n H1. assert (H2: disc_fn O).
  { reflexivity. }
  rewrite H1 in H2. simpl in H2. apply H2. Qed.

Check add_comm.

Theorem in_not_nil : forall (X : Type) (x : X) (l : list X),
    In x l -> l <> [].
Proof.
  intros X x l H. unfold not. intro Hl.
  rewrite Hl in H. simpl in H. apply H. Qed.

Theorem in_not_nil_42 : forall (l : list nat),
    In 42 l -> l <> [].
Proof.
  intros l H. apply in_not_nil with (x:=42).
  apply H. Qed.

Theorem in_not_nil_42' : forall (l : list nat),
    In 42 l -> l <> [].
Proof.
  intros l H. apply in_not_nil in H.
  apply H. Qed.

Theorem in_not_nil_42'' : forall (l : list nat),
    In 42 l -> l <> [].
Proof.
  intros l H. Check (in_not_nil nat 42).
  apply (in_not_nil nat 42). apply H. Qed.

Theorem in_not_nil_42''' : forall (l : list nat),
    In 42 l -> l <> [].
Proof.
  intros l H. Check (in_not_nil _ _ _ H).
  apply (in_not_nil _ _ _ H). Qed.

Module MyPlayground.
  Theorem matching_test : forall (x : nat) (P : nat -> Prop), P x -> P (S x).
  Admitted.

  Theorem matching_test' : forall (P : nat -> Prop),
      P 12 -> P (S 12).
  Proof.
    intros P H. Check (matching_test _ _ H). Abort.
End MyPlayground.

Axiom functional_extensionality : forall {X Y : Type}
                                    {f g : X -> Y},
    (forall x : X, f x = g x) -> f = g.

Example function_equality_ex2 :
  (fun x => plus x 1) = (fun x => plus 1 x).
Proof.
  apply functional_extensionality. intro x.
  apply add_comm. Qed.

Print Assumptions function_equality_ex2.

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

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

Compute rev_append [1;2;3] [7;8;9].
Compute tr_rev [1;2;3].
Compute rev [1;2;3].

Fixpoint app' (l1 l2 : list nat) : list nat :=
  match l1 with
  | [] => l2
  | x :: l1' => x :: (app' l1' l2)
  end.

Theorem tr_rev_correct : forall X,  @tr_rev X = @rev X.
Proof.
  intro X. apply functional_extensionality.
  intro l. induction l as [| h t IHt].
  - reflexivity.
  - unfold tr_rev. simpl.
    assert (H: forall l l1 l2 : list X, rev_append l (l1 ++ l2) = rev_append l l1 ++ l2).
    { induction l as [| h' t' IHt'].
      - reflexivity.
      - intros l1 l2. simpl. rewrite <- IHt'. reflexivity. }
    rewrite H with (l1:=[]) (l2:=[h]). f_equal. rewrite <- IHt.
    reflexivity. Qed.

Lemma evenb_double : forall k,
    even (double k) = true.
Proof.
  intro k. induction k as [| k' IHk'].
  - reflexivity.
  - simpl. apply IHk'. Qed.

Lemma evenb_double_conv : forall n, exists k,
      n = if even n then double k else S (double k).
Proof.
  intro n. induction n as [| n' IHn'].
  - exists 0. reflexivity.
  - destruct IHn' as [k H]. destruct (even n') eqn:E.
    + rewrite even_S. rewrite E. simpl. exists k.
      rewrite H. reflexivity.
    + rewrite even_S. rewrite E. simpl. exists (S k).
      simpl. rewrite H. reflexivity. Qed.

Theorem even_bool_prop : forall n : nat,
    even n = true <-> Even n.
Proof.
  split.
  - intro H. destruct (evenb_double_conv n) as [k Hn].
    rewrite H in Hn. exists k. apply Hn.
  - intros [k Hn]. rewrite Hn. apply evenb_double. Qed.

Example not_even_1001' : ~ (Even 1001).
Proof.
  rewrite <- even_bool_prop.
  unfold not.
  simpl.
  intro H.
  discriminate H.
Qed.

Lemma eqb_eq : forall n m : nat, (n =? m) = true <-> n = m.
Proof.
  split.
  - generalize dependent m. induction n as [| n' IHn'].
    + destruct m as [| m'] eqn:Em.
      * reflexivity.
      * discriminate.
    + destruct m as [| m'] eqn:Em.
      * discriminate.
      * intro H. f_equal. apply IHn'.
        simpl in H. apply H.
  - intro H. rewrite H. apply eqb_refl. Qed.

Lemma plus_eqb_example : forall n m p : nat,
    n =? m = true -> n + p =? m + p = true.
Proof.
  intros n m p H.
  rewrite eqb_eq in H.
  rewrite H.
  rewrite eqb_eq.
  reflexivity.
Qed.

Theorem andb_true_iff : forall b1 b2 : bool,
  b1 && b2 = true <-> b1 = true /\ b2 = true.
Proof.
  intros b1 b2. split.
  - intro H. split.
    + destruct b1. reflexivity. discriminate H.
    + destruct b1.
      * simpl in H. apply H.
      * simpl in H. discriminate H.
  - intros [H1 H2]. rewrite H1. rewrite H2. reflexivity. Qed.

Theorem orb_true_iff : forall b1 b2 : bool,
  b1 || b2 = true <-> b1 = true \/ b2 = true.
Proof.
  intros b1 b2. split.
  - intro H. destruct b1.
    + left. reflexivity.
    + right. simpl in H. apply H.
  - intros [H1 | H2].
    + rewrite H1. reflexivity.
    + rewrite H2. destruct b1.
      * reflexivity.
      * reflexivity. Qed.

Theorem eqb_neq : forall n m : nat, (n =? m) = false <-> n <> m.
Proof.
  intros n m. rewrite <- not_true_iff_false.
  unfold not. rewrite eqb_eq. reflexivity. Qed.

Fixpoint eqb_list {A : Type}
         (eqb : A -> A -> bool)
         (l1 l2 : list A) : bool :=
  match l1, l2 with
  | [], [] => true
  | [], _ | _, [] => false
  | h1 :: t1, h2 :: t2 =>
    (eqb h1 h2) && (eqb_list eqb t1 t2)
  end.

Theorem eqb_list_true_iff :
  forall (A : Type) (eqb : A -> A -> bool),
    (forall a1 a2 : A, eqb a1 a2 = true <-> a1 = a2) ->
    forall l1 l2 : list A, eqb_list eqb l1 l2 = true <-> l1 = l2.
Proof.
  intros A eqb H. split.
  - generalize dependent l2. induction l1 as [| h1 t1 IHt1].
    + destruct l2 as [| h2 t2] eqn:E.
      * reflexivity.
      * simpl. discriminate.
    + destruct l2 as [| h2 t2] eqn:E.
      * simpl. discriminate.
      * simpl. intro Ht. rewrite andb_true_iff in Ht.
        destruct Ht as [HEh HEt]. rewrite H in HEh.
        f_equal. apply HEh. apply IHt1. apply HEt.
  - generalize dependent l2. induction l1 as [| h1 t1 IHt1].
    + destruct l2 as [| h2 t2] eqn:E.
      * reflexivity.
      * discriminate.
    + destruct l2 as [| h2 t2] eqn:E.
      * discriminate.
      * simpl. intro HEht. injection HEht. intros HEt HEh.
        rewrite andb_true_iff. split.
        rewrite H. apply HEh.
        apply IHt1. apply HEt. Qed.

Fixpoint forallb {X : Type} (test : X -> bool) (l : list X) : bool :=
  match l with
  | [] => true
  | x :: l' => andb (test x) (forallb test l')
  end.

Theorem forallb_true_iff : forall X test (l : list X),
  forallb test l = true <-> All (fun x => test x = true) l.
Proof.
  split.
  - induction l as [| h t IHt].
    + reflexivity.
    + simpl. intro HEht. rewrite andb_true_iff in HEht.
      destruct HEht as [HEh HEt]. split.
      * apply HEh.
      * apply IHt. apply HEt.
  - induction l as [| h t IHt].
    + reflexivity.
    + simpl. intros [HEh HEt].
      rewrite andb_true_iff. split.
      * apply HEh.
      * apply IHt. apply HEt. Qed.

Definition excluded_middle := forall P : Prop,
    P \/ ~ P.

Theorem restricted_excluded_middle : forall (P : Prop) (b : bool),
    (P <-> b = true) -> P \/ ~ P.
Proof.
  intros P [] H.
  - left. rewrite H. reflexivity.
  - right. rewrite H. intros contra.
    discriminate contra. Qed.

Theorem restricted_excluded_middle_eq : forall (n m : nat),
    n = m \/ n <> m.
Proof.
  intros n m.
  apply (restricted_excluded_middle (n = m) (eqb n m)).
  symmetry. apply eqb_eq. Qed.

Theorem excluded_middle_irrefutable : forall (P : Prop),
    ~ ~ (P \/ ~ P).
Proof.
  unfold not. intros P H. Check double_neg.
  assert (HP: ~ P -> ~ ~ ~ P).
  { unfold not. intros H1 H2. apply H2. apply H1. }
  unfold not in HP. apply HP.
  - intro H1. apply H. left. apply H1.
  - intro H1. apply H. right. apply H1. Qed.

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

Theorem not_exists_dist :
  excluded_middle ->
  forall (X : Type) (P : X -> Prop),
    ~ (exists x, ~ P x) -> (forall x, P x).
Proof.
  intros EM X P. intro HNE. unfold not in HNE.
  intro x. destruct (EM (P x)).
  - (* P x *) apply H.
  - (* ~ P x *) exfalso. apply HNE.
    exists x. unfold not in H. apply H. Qed.

Definition peirce := forall P Q : Prop,
    ((P -> Q) -> P) -> P.

Definition double_negation_elimination := 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).

Theorem excluded_middle__pierce :
  excluded_middle -> peirce.
Proof.
  intro EM. intros P Q HPQP.
Abort.


(***
 * Oqarina
 * Copyright 2021 Carnegie Mellon University.
 *
 * NO WARRANTY. THIS CARNEGIE MELLON UNIVERSITY AND SOFTWARE ENGINEERING
 * INSTITUTE MATERIAL IS FURNISHED ON AN "AS-IS" BASIS. CARNEGIE MELLON
 * UNIVERSITY MAKES NO WARRANTIES OF ANY KIND, EITHER EXPRESSED OR
 * IMPLIED, AS TO ANY MATTER INCLUDING, BUT NOT LIMITED TO, WARRANTY OF
 * FITNESS FOR PURPOSE OR MERCHANTABILITY, EXCLUSIVITY, OR RESULTS
 * OBTAINED FROM USE OF THE MATERIAL. CARNEGIE MELLON UNIVERSITY DOES NOT
 * MAKE ANY WARRANTY OF ANY KIND WITH RESPECT TO FREEDOM FROM PATENT,
 * TRADEMARK, OR COPYRIGHT INFRINGEMENT.
 *
 * Released under a BSD (SEI)-style license, please see license.txt or
 * contact permission@sei.cmu.edu for full terms.
 *
 * [DISTRIBUTION STATEMENT A] This material has been approved for public
 * release and unlimited distribution.  Please see Copyright notice for
 * non-US Government use and distribution.
 *
 * This Software includes and/or makes use of the following Third-Party
 * Software subject to its own license:
 *
 * 1. Coq theorem prover (https://github.com/coq/coq/blob/master/LICENSE)
 * Copyright 2021 INRIA.
 *
 * 2. Coq JSON (https://github.com/liyishuai/coq-json/blob/comrade/LICENSE)
 * Copyright 2021 Yishuai Li.
 *
 * DM21-0762
***)

(*| .. coq:: none |*)
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Relations.Relation_Operators.
(*| .. coq::  |*)

(*|

.. index:: transitive closue, CoqExt; clos_refl_trans_1n, CoqExt; rt1n_trans'

Relations, transitive closures
==============================

For a relation :coq:`R`, :coq:`clos_refl_trans_1n` defines the notion of direct reflexive-transitive closure on the left of this relation.

We extend Coq standard library :coq:`Coq.Relations.Relation_Operators` with additional results, as suggested in the course "Mechanized semantics" given by Xavier Leroy at Collège de France in 2019-2020. Although a Coq development serves as a companion for this class, we propose a different set of definitions that builds on top of the Coq standard library.

|*)

(*| .. coq:: none |*)
Section Reflexive_Transitive_Closure_Ext.
(*| .. coq:: |*)

Variable A: Type.
Variable R: relation A.

Lemma rt1n_trans': forall (a b: A) ,
    clos_refl_trans_1n A R a b ->
        forall c, clos_refl_trans_1n A R b c ->
        clos_refl_trans_1n A R a c.
Proof.
    intros.
    induction H.
    - apply H0.
    - eapply rt1n_trans. apply H. auto.
Qed.

(*| We define the transitive closure of a relation from :coq:`clos_refl_trans_1n`. This allows one to reason on zero, one, or many steps (:coq:`clos_refl_trans_1n_star`), or one or many (:coq:`clos_refl_trans_1n_plus`). This is important for definiing equivalences between relations. |*)

Inductive clos_refl_trans_1n_plus : A -> A -> Prop :=
  | plus_trans: forall a b c,
      R a b -> clos_refl_trans_1n A R b c -> clos_refl_trans_1n_plus a c.

Lemma clos_refl_trans_1n_plus_one:
  forall a b, R a b -> clos_refl_trans_1n_plus a b.
Proof.
    intros.
    eapply plus_trans.
    - apply H.
    - apply rt1n_refl.
Qed.

Lemma clos_refl_trans_1n_plus_star: forall a b,
    clos_refl_trans_1n_plus a b -> clos_refl_trans_1n A R a b.
Proof.
    intros. inversion H.
    eapply rt1n_trans.
    - apply H0.
    - apply H1.
Qed.

(*| .. coq:: none |*)
End Reflexive_Transitive_Closure_Ext.
(*| .. coq:: |*)


Set Implicit Arguments.

Print bool. (* Inductive bool : Set :=  true : bool | false : bool *)

Inductive month : Set :=
  | January : month | February : month  | March : month
  | April : month   | May : month       | June : month
  | July : month    | August : month    | September : month
  | October : month | November : month  | December : month.

Inductive whatever : Set := | A | B | C | D. (* simpler syntax *)

Check month_ind.
(*
forall P : month -> Prop,
       P January ->
       P February ->
       P March ->
       P April ->
       P May ->
       P June ->
       P July ->
       P August ->
       P September ->
       P October -> P November -> P December -> forall m : month, P m
*)

Check month_rec.
(*
forall P : month -> Set,
       P January ->
       P February ->
       P March ->
       P April ->
       P May ->
       P June ->
       P July ->
       P August ->
       P September ->
       P October -> P November -> P December -> forall m : month, P m
*)

Inductive season : Set :=
  | Spring : season
  | Summer : season
  | Autumn : season
  | Winter : season.

Definition month_to_season : month -> season :=
  month_rec (fun m => season)
            Winter Winter Spring
            Spring Spring Summer
            Summer Summer Autumn
            Autumn Autumn Winter.

Eval compute in month_to_season January.
Eval compute in month_to_season February.
Eval compute in month_to_season March.
Eval compute in month_to_season April.
Eval compute in month_to_season May.
Eval compute in month_to_season June.
Eval compute in month_to_season July.
Eval compute in month_to_season August.
Eval compute in month_to_season September.
Eval compute in month_to_season October.
Eval compute in month_to_season November.
Eval compute in month_to_season December.

Check bool_ind. (* forall P : bool -> Prop, P true -> P false -> forall b : bool, P b *)
Check bool_rec. (* forall P : bool -> Set, P true -> P false -> forall b : bool, P b  *)
Check bool_rect. (* forall P : bool -> Type, P true -> P false -> forall b : bool, P b *)

Theorem month_equal : forall m:month,
  m=January \/ m=February \/ m=March      \/ m=April    \/ m=May      \/ m=June \/
  m=July    \/ m=August   \/ m=September  \/ m=October  \/ m=November \/ m=December.
Proof.
  induction m; auto 12.
Qed.

Reset month_equal.

Theorem month_equal : forall m:month,
  m=January \/ m=February \/ m=March      \/ m=April    \/ m=May      \/ m=June \/
  m=July    \/ m=August   \/ m=September  \/ m=October  \/ m=November \/ m=December.
Proof.
  intro m. pattern m. apply month_ind; auto 12. (* 12 sub-goals *)
Qed.

Check or_introl. (* forall A B : Prop, A -> A \/ B *)
Check or_intror. (* forall A B : Prop, B -> A \/ B *)
Check refl_equal(A:=Type).  (* forall x : Type, x = x *)
Check eq_refl(A:=Type).     (* forall x : Type, x = x *)
Check bool_ind. (* forall P : bool -> Prop, P true -> P false -> forall b : bool, P b *)

Theorem bool_equal: forall b:bool, b = true \/ b = false.
Proof.
  intro b. pattern b. apply bool_ind. apply or_introl. apply eq_refl.
  apply or_intror. apply eq_refl.
Qed.

Print bool_equal.
(*
fun b : bool =>
  bool_ind  (fun b0 : bool => b0 = true \/ b0 = false)
            (or_introl eq_refl)
            (or_intror eq_refl) b

  : forall b : bool, b = true \/ b = false
*)

Reset bool_equal.

Theorem bool_equal: forall b:bool, b = true \/ b = false.
Proof.
  exact(fun b : bool =>
          bool_ind  (fun b0 : bool => b0 = true \/ b0 = false)
                    (or_introl (true = false) (eq_refl true))
                    (or_intror (false = true) (eq_refl false))
                    b).
Qed.

Check or_introl (true = false) (eq_refl true).  (*  true = true \/ true = false *)
Check or_intror (false = true) (eq_refl false). (* false = true \/ false = false *)

Reset bool_equal.

Theorem bool_equal: forall b:bool, b = true \/ b = false.
Proof.
  intro b. pattern b. apply bool_ind. left. reflexivity. right. reflexivity.
Qed.

Check (fun b:bool => match b with true => 33 | false => 45 end).
(*
fun b : bool => if b then 33 else 45
       : bool -> nat
*)

Definition month_length (leap:bool)(m:month) : nat :=
  match m with
  | January => 31 | February  => if leap then 29 else 28
  | March   => 31 | April     => 30   | May => 31 | June  => 30
  | July    => 31 | August    => 31   | September => 30
  | October => 31 | November  => 30   | December  => 31
  end.
(*
Definition month_length2 : bool->month->nat :=
 fun (leap:bool)(m:month) => match m with January => 31 end.
Error: Non exhaustive pattern-matching: no clause found for pattern February
*)

Check month_rec.
(*
forall P : month -> Set,
       P January ->
       P February ->
       P March ->
       P April ->
       P May ->
       P June ->
       P July ->
       P August ->
       P September ->
       P October -> P November -> P December -> forall m : month, P m
*)

Definition month_length' (leap:bool) :=
  month_rec (fun m:month => nat)
  31 (if leap then 29 else 28) 31 30 31 30 31 31 30 31 30 31.

Print month_length.
Print month_length'.

Definition month_length'' (leap:bool) (m:month) : nat :=
  match m with
  | February  => if leap then 29 else 28
  | April => 30 | June  => 30 | September => 30 | November  => 30
  | other  => 31 (* lower case indicates variable name *)
  end.

Eval compute in (fun leap => month_length leap November).
(* fun _ : bool => 30
   : bool -> nat
*)

Theorem length_february : month_length false February = 28.
Proof.
  simpl. (* triggers iota reduction *)
  reflexivity.
Qed.

Definition month_even (leap:bool)(m:month) : bool :=
  match (month_length leap m) with
    | 28    => true
    | 29    => false
    | 30    => true
    | 31    => false
    | other => false
  end.

Definition bool_xor (b1:bool)(b2:bool) : bool :=
  match (b1,b2) with
  | (true, true)    => false
  | (true, false)   => true
  | (false, true)   => true
  | (false, false)  => false
  end.

Definition bool_and (b1:bool)(b2:bool) : bool :=
  match (b1,b2) with
  | (true, true)    => true
  | (true, false)   => false
  | (false, true)   => false
  | (false, false)  => false
  end.

Definition bool_or (b1:bool)(b2:bool) : bool :=
  match (b1,b2) with
  | (true, true)    => true
  | (true, false)   => true
  | (false, true)   => true
  | (false, false)  => false
  end.

Definition bool_eq (b1:bool)(b2:bool) : bool :=
  match (b1,b2) with
  | (true, true)    => true
  | (true, false)   => false
  | (false, true)   => false
  | (false, false)  => true
  end.

Definition bool_not (b:bool): bool :=
  match b with
  | true  => false
  | false => true
  end.

Theorem xor_not_eq : forall b1 b2:bool, bool_xor b1 b2 = bool_not (bool_eq b1 b2).
Proof.
  intros x y. pattern x; apply bool_ind; pattern y; apply bool_ind; reflexivity.
Qed.

Theorem not_and_or : forall x y: bool,
  bool_not(bool_and x y) = bool_or (bool_not x)(bool_not y).
Proof.
  intros x y. elim x; elim y; reflexivity.
Qed.

Theorem not_not : forall b:bool, bool_not (bool_not b) = b.
Proof.
  intro x. elim x; reflexivity.
Qed.

Theorem bool_lem : forall b:bool, bool_or b (bool_not b) = true.
Proof.
  intro x. elim x; reflexivity.
Qed.

Theorem eq_eq : forall x y:bool, bool_eq x y = true -> x = y.
Proof.
  intros x y. elim x; elim y; intro H; unfold bool_eq in H; auto.
Qed.

Theorem eq_eq_rev : forall x y:bool, x = y -> bool_eq x y = true.
Proof.
  intros x y H. rewrite H. elim y; reflexivity.
Qed.

Theorem not_or_and_not : forall x y:bool,
  bool_not (bool_or x y) = bool_and (bool_not x) (bool_not y).
Proof.
  intros x y. elim x; elim y; reflexivity.
Qed.

Theorem distr : forall x y z: bool,
  bool_or (bool_and x z) (bool_and y z) = bool_and (bool_or x y) z.
Proof.
  intros x y z. elim x; elim y; elim z; reflexivity.
Qed.

Theorem at_least_28: forall (leap:bool)(m:month), 28 <= month_length leap m.
Proof.
  intros leap m. case m; simpl; auto. case leap; auto.
Qed.

Print at_least_28.
(*
fun (leap : bool) (m : month) =>
match m as m0 return (28 <= month_length leap m0) with
| January => le_S 28 30 (le_S 28 29 (le_S 28 28 (le_n 28)))
| February =>
    if leap as b return (28 <= (if b then 29 else 28))
      then le_S 28 28 (le_n 28)
      else le_n 28
| March => le_S 28 30 (le_S 28 29 (le_S 28 28 (le_n 28)))
| April => le_S 28 29 (le_S 28 28 (le_n 28))
| May => le_S 28 30 (le_S 28 29 (le_S 28 28 (le_n 28)))
| June => le_S 28 29 (le_S 28 28 (le_n 28))
| July => le_S 28 30 (le_S 28 29 (le_S 28 28 (le_n 28)))
| August => le_S 28 30 (le_S 28 29 (le_S 28 28 (le_n 28)))
| September => le_S 28 29 (le_S 28 28 (le_n 28))
| October => le_S 28 30 (le_S 28 29 (le_S 28 28 (le_n 28)))
| November => le_S 28 29 (le_S 28 28 (le_n 28))
| December => le_S 28 30 (le_S 28 29 (le_S 28 28 (le_n 28)))
end
*)

Definition next_month (m:month) :=
  match m with
  | January => February | February  => March      | March     => April
  | April   => May      | May       => June       | June      => July
  | July    => August   | August    => September  | September => October
  | October => November | November  => December   | December  => January
end.

Theorem next_august_then_july : forall m:month,
  next_month m = August -> m = July.
Proof.
  intro m. case m; simpl; intro Hnext_eq; discriminate Hnext_eq || reflexivity.
Qed.

Check I. (* I: True *)

Theorem not_January_eq_February : January <> February.
Proof.
  unfold not. intros H.
  pose (g:=(fun (m:month) => match m with January => True | _ => False end)). (* can also define g from month_rec *)
  change (g February). rewrite <- H. simpl. apply I.
Qed.

Theorem not_true_eq_false : true <> false.
Proof.
  unfold not. intro H. pose (g:= fun (b:bool) => match b with false => False | true => True end).
  change (g false). rewrite <- H. simpl. apply I.
Qed.

Theorem next_march_shorter : forall (leap:bool)(m1 m2:month),
  next_month m1 = March -> month_length leap m1 <= month_length leap m2.
Proof.
  intros leap m1 m2 H.
  case m1. (* we are stuck *)
  Restart.
  intros leap m1 m2.
  case m1; simpl; (discriminate || (* cannot be handled by discriminate *)
    simpl; case m2; simpl; case leap; auto).
  Restart.
  intros leap m1 m2 H. generalize H. (* then can proceed with 'case' *)
  Restart.
(* negative argument to specifiy which occurence of m1 should not be replaced in abstraction *)
  intros leap m1 m2 H. generalize (eq_refl m1). pattern m1 at -1.
  case m1; intro H0; rewrite H0 in H; simpl in H; (discriminate || (* case which cannot be handled with discriminate *)
    simpl; case leap; case m2; simpl; auto).
Qed.

Ltac caseEq f := (* our first tactic definition *)
  generalize (eq_refl f); pattern f at -1; case f.

Theorem next_march_shorter' : forall (leap:bool)(m1 m2:month),
  next_month m1 = March -> month_length leap m1 <= month_length leap m2.
Proof.
  intros leap m1 m2 H.
  caseEq m1; intro H'; rewrite H' in H; simpl in H; try (discriminate H).
  case leap; simpl; case m2; simpl; auto.
Qed.


Require Import Arith.
Require Import Omega.
Require Import NPeano.
Require Import List.
Import ListNotations.
Require Import Sorting.Permutation.
Require Import VerdiTactics.

Set Implicit Arguments.

Notation member := (in_dec eq_nat_dec).

Ltac do_in_map :=
  match goal with
    | [ H : In _ (map _ _) |- _ ] => apply in_map_iff in H; break_exists; break_and
  end.

Ltac do_in_app :=
  match goal with
    | [ H : In _ (_ ++ _) |- _ ] => apply in_app_iff in H
  end.

Lemma filter_app : forall A (f : A -> bool) xs ys,
    filter f (xs ++ ys) = filter f xs ++ filter f ys.
Proof.
  induction xs; intros.
  - auto.
  - simpl. rewrite IHxs. break_if; auto.
Qed.

Section dedup.
  Variable A : Type.
  Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}.

  Fixpoint dedup (xs : list A) : list A :=
    match xs with
    | [] => []
    | x :: xs => let tail := dedup xs in
                 if in_dec A_eq_dec x xs then
                   tail
                 else
                   x :: tail
    end.

  Lemma dedup_eliminates_duplicates : forall (a : A) b c,
      (dedup (a :: b ++ a :: c) = dedup (b ++ a :: c)).
  Proof.
    intros. simpl in *.
    break_match.
    + auto.
    + exfalso. intuition.
  Qed.

  Lemma dedup_In : forall (x : A) xs,
      In x xs ->
      In x (dedup xs).
  Proof.
    induction xs; intros.
    - simpl in *. intuition.
    - simpl in *. break_if; intuition.
      + subst. auto.
      + subst. simpl. auto.
  Qed.

  Lemma filter_dedup (pred : A -> bool) :
    forall xs (p : A) ys,
      pred p = false ->
      filter pred (dedup (xs ++ ys)) = filter pred (dedup (xs ++ p :: ys)).
  Proof.
    intros. induction xs.
    - simpl. repeat (break_match; simpl; auto; try discriminate).
    - simpl. repeat (break_match; simpl; auto).
      + exfalso. apply n. apply in_app_iff. apply in_app_or in i. intuition.
      + exfalso. apply n. apply in_app_or in i. intuition.
        * simpl in *. intuition. subst. rewrite Heqb in H. discriminate.
      + rewrite IHxs. auto.
      + discriminate.
      + discriminate.
  Qed.

  Lemma dedup_app : forall (xs ys : list A),
      (forall x y, In x xs -> In y ys -> x <> y) ->
      dedup (xs ++ ys) = dedup xs ++ dedup ys.
  Proof.
    intros. induction xs; simpl; auto.
    repeat break_match.
    - apply IHxs.
      intros. apply H; intuition.
    - exfalso. specialize (H a a).
      apply H; intuition.
      do_in_app. intuition.
    - exfalso. apply n. intuition.
    - simpl. f_equal.
      apply IHxs.
      intros. apply H; intuition.
  Qed.

  Lemma in_dedup_was_in :
    forall xs (x : A),
      In x (dedup xs) ->
      In x xs.
  Proof.
    induction xs; intros.
    - simpl in *; intuition.
    - simpl in *. break_if; simpl in *; intuition.
  Qed.

  Lemma NoDup_dedup :
    forall (xs : list A),
      NoDup (dedup xs).
  Proof.
    induction xs.
    - simpl. constructor.
    - simpl. break_if; auto.
      constructor; auto.
      intro.
      apply n.
      eapply in_dedup_was_in; eauto.
  Qed.

  Lemma remove_preserve :
    forall (x y : A) xs,
      x <> y ->
      In y xs ->
      In y (remove A_eq_dec x xs).
  Proof.
    induction xs; intros.
    - intuition.
    - simpl in *.
      concludes.
      intuition; break_if; subst; try congruence; intuition.
  Qed.

  Lemma in_remove :
    forall (x y : A) xs,
      In y (remove A_eq_dec x xs) ->
      In y xs.
  Proof.
    induction xs; intros.
    - auto.
    - simpl in *. break_if; simpl in *; intuition.
  Qed.

  Lemma remove_dedup_comm : forall (x : A) xs,
      remove A_eq_dec x (dedup xs) =
      dedup (remove A_eq_dec x xs).
  Proof.
    induction xs; intros.
    - auto.
    - simpl. repeat (break_match; simpl); auto.
      + exfalso. apply n0. apply remove_preserve; auto.
      + exfalso. apply n. eapply in_remove; eauto.
      + f_equal. auto.
  Qed.

  Lemma remove_partition :
    forall xs (p : A) ys,
      remove A_eq_dec p (xs ++ p :: ys) = remove A_eq_dec p (xs ++ ys).
  Proof.
    induction xs; intros.
    - simpl. break_if; congruence.
    - simpl. break_if.
      + auto.
      + f_equal. auto.
  Qed.

  Lemma remove_not_in : forall (x : A) xs,
      ~ In x xs ->
      remove A_eq_dec x xs = xs.
  Proof.
    intros. induction xs.
    - intuition.
    - simpl. break_match.
      + exfalso. apply H.
        subst. intuition.
      + f_equal. apply IHxs.
        intro Hin.
        apply H. simpl. intuition.
  Qed.

  Lemma dedup_partition :
    forall xs (p : A) ys xs' ys',
      dedup (xs ++ p :: ys) = xs' ++ p :: ys' ->
      remove A_eq_dec p (dedup (xs ++ ys)) = xs' ++ ys'.
  Proof.
    intros.
    f_apply H (remove A_eq_dec p).
    rewrite remove_dedup_comm in *.
    rewrite remove_partition in *.
    rewrite H0.
    rewrite remove_partition.

    apply remove_not_in.
    apply NoDup_remove_2.
    rewrite <- H.
    apply NoDup_dedup.
  Qed.

  Lemma dedup_NoDup_id : forall (xs : list A),
      NoDup xs -> dedup xs = xs.
  Proof.
    induction xs; intros.
    - auto.
    - simpl. invc H. concludes. rewrite IHxs.
      break_if; congruence.
  Qed.

  Lemma dedup_not_in_cons :
    forall x xs,
      (~ In x xs) ->
      x :: dedup xs = dedup (x :: xs).
  Proof.
    induction xs; intros.
    - auto.
    - simpl in *. intuition. repeat break_match; intuition.
  Qed.
End dedup.

Lemma filter_fun_ext_eq : forall A f g xs,
                            (forall a : A, In a xs -> f a = g a) ->
                            filter f xs = filter g xs.
Proof.
  induction xs; intros.
  - auto.
  - simpl. rewrite H by intuition. rewrite IHxs by intuition. auto.
Qed.

Lemma NoDup_map_injective : forall A B (f : A -> B) xs,
                              (forall x y, In x xs -> In y xs ->
                                           f x = f y -> x = y) ->
                              NoDup xs -> NoDup (map f xs).
Proof.
  induction xs; intros.
  - constructor.
  - simpl. constructor.
    + intro.
      do_in_map.
      specialize (H a x).
      repeat conclude H intuition.
      subst.
      invc H0. auto.
    + apply IHxs. intuition. inv H0. auto.
Qed.

Lemma NoDup_disjoint_append :
  forall A (l : list A) l',
    NoDup l ->
    NoDup l' ->
    (forall a, In a l -> ~ In a l') ->
    NoDup (l ++ l').
Proof.
  induction l; intros.
  - auto.
  - simpl. constructor.
    + intro. do_in_app. intuition.
      * invc H. auto.
      * apply (H1 a); intuition.
    + invc H. apply IHl; auto.
      intros. apply H1. intuition.
Qed.

Lemma filter_NoDup :
  forall A p (l : list A),
    NoDup l ->
    NoDup (filter p l).
Proof.
  induction l; intros.
  - auto.
  - invc H. simpl. break_if.
    + constructor; auto.
      intro. apply filter_In in H. intuition.
    + auto.
Qed.

Lemma filter_true_id : forall A (f : A -> bool) xs,
                         (forall x, In x xs -> f x = true) ->
                         filter f xs = xs.
Proof.
  induction xs; intros.
  - auto.
  - simpl. rewrite H by intuition. rewrite IHxs by intuition. auto.
Qed.

Lemma map_of_map : forall A B C (f : A -> B) (g : B -> C) xs,
                     map g (map f xs) = map (fun x => g (f x)) xs.
Proof.
  induction xs.
  - auto.
  - simpl. f_equal. auto.
Qed.

Lemma filter_except_one : forall A A_eq_dec (f g : A -> bool) x xs,
                            (forall y, In y xs ->
                                       x <> y ->
                                       f y = g y) ->
                            g x = false ->
                            filter f (remove A_eq_dec x xs) = filter g xs.
Proof.
  induction xs; intros.
  - auto.
  - simpl.
    pose proof (A_eq_dec x a).
    intuition; repeat (break_match; simpl); try congruence; subst; intuition; f_equal; intuition;
    rewrite (H a) in * by intuition; congruence.
Qed.

Lemma flat_map_nil : forall A B (f : A -> list B) l,
                       flat_map f l = [] ->
                       l = [] \/ (forall x, In x l -> f x = []).
Proof.
  induction l; intros.
  - intuition.
  - right. simpl in *.
    apply app_eq_nil in H.
    intuition; subst; simpl in *; intuition.
Qed.

Fixpoint remove_first {A : Set} (A_eq_dec : forall x y : A, {x = y} + {x <> y}) (x : A) (l : list A) : list A :=
  match l with
    | [] => []
    | y::tl => if (A_eq_dec x y) then tl else y::(remove_first A_eq_dec x tl)
  end.

Fixpoint subseq {A} (xs ys : list A) : Prop :=
  match xs, ys with
    | [], _ => True
    | x :: xs', y :: ys' => (x = y /\ subseq xs' ys') \/ subseq xs ys'
    | _, _ => False
  end.

Lemma subseq_refl : forall A (l : list A), subseq l l.
Proof.
  induction l; simpl; tauto.
Qed.

Lemma subseq_trans :
  forall A (zs xs ys : list A),
    subseq xs ys ->
    subseq ys zs ->
    subseq xs zs.
Proof.
  induction zs; intros; simpl in *;
  repeat break_match; subst; simpl in *; intuition; subst; eauto;
  right; (eapply IHzs; [|eauto]); simpl; eauto.
Qed.
Lemma subseq_In :
  forall A (ys xs : list A) x,
    subseq xs ys ->
    In x xs ->
    In x ys.
Proof.
  induction ys; intros.
  - destruct xs; simpl in *; intuition.
  - simpl in *. break_match; simpl in *; intuition; subst; intuition eauto;
                right; (eapply IHys; [eauto| intuition]).
Qed.

Theorem subseq_NoDup :
  forall A (ys xs : list A),
    subseq xs ys ->
    NoDup ys ->
    NoDup xs.
Proof.
  induction ys; intros.
  - destruct xs; simpl in *; intuition.
  - simpl in *. invc H0.
    break_match.
    + constructor.
    + intuition.
      subst. constructor.
      * intro. apply H3.
        eapply subseq_In; eauto.
      * eauto.
Qed.

Theorem NoDup_Permutation_NoDup :
  forall A (l l' : list A),
    NoDup l ->
    Permutation l l' ->
    NoDup l'.
Proof.
  intros. induction H0.
  - auto.
  - invc H. constructor; auto.
    intro. apply H3. apply Permutation_in with (l := l'); auto.
    symmetry. auto.
  - invc H. invc H3. constructor.
    * simpl in *. intuition.
    * constructor; simpl in *; intuition.
  - auto.
Qed.

Theorem NoDup_append :
  forall A l (a : A),
    NoDup (l ++ [a]) <-> NoDup (a :: l).
Proof.
  intros.
  split; intro.
  - eapply NoDup_Permutation_NoDup; try eassumption.
    symmetry.
    apply Permutation_cons_append.
  - eapply NoDup_Permutation_NoDup; try eassumption.
    apply Permutation_cons_append.
Qed.

Lemma leb_false_lt : forall m n, leb m n = false -> n < m.
Proof.
  induction m; intros.
  - discriminate.
  - simpl in *. break_match; subst; auto with arith.
Qed.

Lemma leb_true_le : forall m n, leb m n = true -> m <= n.
Proof.
  induction m; intros.
  - auto with arith.
  - simpl in *. break_match; subst; auto with arith.
    discriminate.
Qed.

Lemma ltb_false_le : forall m n, m <? n = false -> n <= m.
Proof.
  induction m; intros; destruct n; try discriminate; auto with arith.
Qed.

Lemma ltb_true_lt : forall m n, m <? n = true -> m < n.
  induction m; intros; destruct n; try discriminate; auto with arith.
Qed.

Ltac do_bool :=
  repeat match goal with
    | [ H : beq_nat _ _ = true |- _ ] => apply beq_nat_true in H
    | [ H : beq_nat _ _ = false |- _ ] => apply beq_nat_false in H
    | [ H : andb _ _ = true |- _ ] => apply Bool.andb_true_iff in H
    | [ H : negb _ = true |- _ ] => apply Bool.negb_true_iff in H
    | [ H : negb _ = false |- _ ] => apply Bool.negb_false_iff in H
    | [ H : PeanoNat.Nat.ltb _ _ = true |- _ ] => apply ltb_true_lt in H
    | [ H : PeanoNat.Nat.ltb _ _ = false |- _ ] => apply ltb_false_le in H
    | [ H : leb _ _ = true |- _ ] => apply leb_true_le in H
    | [ H : leb _ _ = false |- _ ] => apply leb_false_lt in H
    | [ |- context [ andb _ _ ] ] => apply Bool.andb_true_iff
    | [ |- context [ leb _ _ ] ] => apply leb_correct
    | [ |- context [ _ <> false ] ] => apply Bool.not_false_iff_true
    | [ |- beq_nat _ _ = false ] => apply beq_nat_false_iff
    | [ |- beq_nat _ _ = true ] => apply beq_nat_true_iff
  end.

Lemma NoDup_map_elim :
  forall A B (f : A -> B) xs x y,
    f x = f y ->
    NoDup (map f xs) ->
    In x xs ->
    In y xs ->
    x = y.
Proof.
  induction xs; intros.
  - simpl in *. intuition.
  - simpl in *. invc H0. intuition; subst.
    + auto.
    + exfalso. repeat find_rewrite. apply H5. apply in_map. auto.
    + exfalso. apply H5. rewrite <- H. apply in_map. auto.
Qed.

Lemma subseq_map :
  forall A B (f : A -> B) ys xs,
    subseq xs ys ->
    subseq (map f xs) (map f ys).
Proof.
  induction ys; intros.
  - simpl in *. repeat break_match; try discriminate; auto.
  - simpl in *. repeat break_match; try discriminate; auto.
    simpl in *. find_inversion.
    intuition.
    + subst. auto.
    + right. apply IHys in H0. auto.
Qed.

Lemma subseq_cons_drop :
  forall A xs ys (a : A),
    subseq (a :: xs) ys -> subseq xs ys.
Proof.
  induction ys; intros; simpl in *; intuition; break_match; eauto.
Qed.

Lemma subseq_length :
  forall A (ys xs : list A),
    subseq xs ys ->
    length xs <= length ys.
Proof.
  induction ys; intros; simpl in *; break_match; intuition.
  subst. simpl in *. specialize (IHys l). concludes. auto with *.
Qed.

Lemma subseq_subseq_eq :
  forall A (xs ys : list A),
    subseq xs ys ->
    subseq ys xs ->
    xs = ys.
Proof.
  induction xs; intros.
  - destruct ys; auto; simpl in *; intuition.
  - destruct ys; simpl in *.
    + intuition.
    + intuition.
      * f_equal; eauto.
      * f_equal; eauto using subseq_cons_drop.
      * f_equal; eauto using subseq_cons_drop.
      * exfalso.
        apply subseq_length in H1.
        apply subseq_length in H.
        simpl in *. omega.
Qed.

Lemma subseq_filter :
  forall A (f : A -> bool) xs,
    subseq (filter f xs) xs.
Proof.
  induction xs; intros.
  - simpl. auto.
  - simpl. repeat break_match.
    + discriminate.
    + auto.
    + find_inversion. auto.
    + right. rewrite <- Heql. eauto.
Qed.

Fixpoint take A (n : nat) (xs : list A) : list A :=
  match n with
    | O => []
    | S n' => match xs with
               | [] => []
               | x :: xs' => x :: take n' xs'
             end
  end.

Lemma remove_length_not_in : forall A A_eq_dec (x : A) xs,
                               ~ In x xs ->
                               length (remove A_eq_dec x xs) = length xs.
Proof.
  induction xs; intros.
  - auto.
  - simpl in *. intuition.
    break_if; subst; simpl; intuition.
Qed.

Lemma remove_length_in : forall A A_eq_dec (x : A) xs,
                           In x xs ->
                           NoDup xs ->
                           S (length (remove A_eq_dec x xs)) = length xs.
Proof.
  induction xs; intros.
  - simpl in *. intuition.
  - simpl in *. intuition.
    + subst. break_if; try congruence.
      inv H0.
      rewrite remove_length_not_in; auto.
    + invc H0.
      break_if; subst; intuition.
Qed.

Lemma subset_size_eq :
  forall A xs,
    NoDup xs ->
    forall ys,
      NoDup ys ->
      (forall x : A, In x xs -> In x ys) ->
      length xs = length ys ->
      (forall x, In x ys -> In x xs).
Proof.
  induction xs; intros.
  - destruct ys; try discriminate. auto.
  - simpl in *. inv H. concludes.
    pose proof H1 a (or_introl eq_refl).
    apply in_split in H4. break_exists. subst.
    specialize (IHxs (x0 ++ x1)).

    forward IHxs.
    eapply NoDup_remove_1; eauto.
    concludes. clear H4.

    forward IHxs.
    intros. pose proof H1 x2 (or_intror H4).
    pose proof NoDup_remove_2 x0 x1 a H0.
    apply in_app_or in H5. simpl in *. intuition. subst. congruence.
    concludes. clear H4.

    forward IHxs. rewrite app_length in *. simpl in *. omega.
    concludes.  clear H4.

    apply in_app_or in H3. simpl in *. intuition.
Qed.

Lemma in_take : forall A n (x : A) xs,
                  In x (take n xs) -> In x xs.
Proof.
  induction n; intros.
  - simpl in *. intuition.
  - simpl in *. break_match.
    + simpl in *. intuition.
    + simpl in *. intuition.
Qed.

Lemma take_NoDup : forall A n (xs : list A),
                     NoDup xs ->
                     NoDup (take n xs).
Proof.
  induction n; intros.
  - destruct xs; simpl in *; intuition. constructor.
  - simpl. destruct xs.
    + auto.
    + invc H. constructor; auto.
      intro. apply in_take in H. auto.
Qed.

Lemma remove_NoDup :
  forall A A_eq_dec (x : A) xs,
    NoDup xs ->
    NoDup (remove A_eq_dec x xs).
Proof.
  induction xs; intros.
  - auto.
  - invc H. simpl. break_if.
    + auto.
    + constructor.
      * intro. apply H2. eapply in_remove; eauto.
      * auto.
Qed.

Lemma seq_range :
  forall n a x,
    In x (seq a n) ->
    a <= x < a + n.
Proof.
  induction n; intros.
  - simpl in *. intuition.
  - simpl in *. invc H. intuition.
    apply IHn in H0. omega.
Qed.

Lemma take_length : forall A n (xs : list A),
                      length xs >= n ->
                      length (take n xs) = n.
Proof.
  induction n; intros.
  - auto.
  - simpl. break_match.
    + simpl in *. omega.
    + simpl in *. rewrite IHn by omega. auto.
Qed.

Lemma seq_NoDup : forall n a ,
                    NoDup (seq a n).
Proof.
  induction n; intros; simpl in *.
  - constructor.
  - constructor.
    intro. apply seq_range in H. omega.
    auto.
Qed.

Lemma remove_length_ge : forall A A_eq_dec (x : A) xs,
                           NoDup xs ->
                           length (remove A_eq_dec x xs) >= length xs - 1.
Proof.
  induction xs; intros.
  - auto.
  - inv H. simpl. break_if.
    + rewrite <- minus_n_O.
      subst.
      rewrite remove_length_not_in; auto.
    + simpl. concludes. omega.
Qed.

Lemma remove_length_le :
  forall A (x : A) xs eq_dec,
    length xs >= length (remove eq_dec x xs).
Proof.
  induction xs; intros.
  - auto.
  - simpl in *.
    specialize (IHxs eq_dec).
    break_if; subst; simpl; omega.
Qed.

Lemma remove_length_lt :
  forall A (x : A) xs eq_dec,
    In x xs ->
    length xs > length (remove eq_dec x xs).
Proof.
  induction xs; intros.
  - simpl in *. intuition.
  - simpl in *.
    intuition.
    + subst.
      break_if; try congruence.
      pose proof remove_length_le x xs eq_dec.
      omega.
    + specialize (IHxs eq_dec H0).
      break_if; subst; simpl; omega.
Qed.

Lemma subset_length :
  forall A xs ys,
    (forall a b : A, {a = b} + {a <> b}) ->
    NoDup xs ->
    (forall x : A, In x xs -> In x ys) ->
    length ys >= length xs.
Proof.
  induction xs; intros.
  - simpl. omega.
  - specialize (IHxs (remove X a ys) X).
    invc H.
    concludes.

    forward IHxs.
    intros.
    apply remove_preserve.
    intro. subst. congruence.

    apply H0. intuition.
    concludes.
    pose proof remove_length_lt a ys X.
    forwards.
    apply H0. intuition. concludes.
    simpl. omega.
Qed.

Lemma take_length_ge : forall A n m (xs : list A),
                         length (take n xs) >= m ->
                         length xs >= m.
Proof.
  induction n; intros.
  - simpl in *. omega.
  - simpl in *. break_match.
    + omega.
    + simpl in *.
      destruct m; try omega.
      unfold ge in *.
      apply le_S_n in H.
      apply IHn in H. omega.
Qed.

Fixpoint fin (n : nat) : Type :=
  match n with
    | 0 => False
    | S n' => option (fin n')
  end.

Lemma fin_eq_dec : forall n (a b : fin n), {a = b} + {a <> b}.
Proof.
  induction n.
  - auto.
  - intros. destruct a, b.
    + specialize (IHn f f0). intuition.
      * subst. auto.
      * right. intros. inversion H. auto.
    + right. discriminate.
    + right. discriminate.
    + auto.
Qed.

Fixpoint all_fin (n : nat) : list (fin n) :=
  match n with
    | 0 => []
    | S n' => None :: map (fun x => Some x) (all_fin n')
  end.

Lemma all_fin_all :
  forall n (x : fin n),
    In x (all_fin n).
Proof.
  induction n; intros.
  - solve_by_inversion.
  - simpl in *. destruct x; auto using in_map.
Qed.

Lemma all_fin_NoDup :
  forall n,
    NoDup (all_fin n).
Proof.
  induction n; intros; simpl; constructor.
  - intro. apply in_map_iff in H. firstorder. discriminate.
  - apply NoDup_map_injective; auto. congruence.
Qed.

Lemma or_false :
  forall P : Prop, P -> (P \/ False).
Proof.
  firstorder.
Qed.

Ltac map_crush :=
  repeat match goal with
                   | [ H : context [ map _ (_ ++ _) ] |- _ ] => rewrite map_app in H
                   | [ |- context [ map _ (_ ++ _) ] ] => rewrite map_app
                   | [ H : context [ map _ (map _ _) ] |- _ ] => rewrite map_map in H
                   | [ |- context [ map _ (map _ _) ] ] => rewrite map_map
         end; simpl in *.

Ltac in_crush_finish :=
  repeat match goal with
    | [ |- _ \/ _ ] => try first [solve [apply or_introl; in_crush_finish]|
                                 solve [apply or_intror; in_crush_finish]]
    | [ |- In _ (_ ++ _) ] => apply in_or_app; in_crush_finish
    | [ |- In _ (map _ _) ] => apply in_map_iff; eexists; eauto
  end.
Ltac in_crush_start :=
  intuition; simpl in *;
  repeat
    (match goal with
       | [ H : In _ (map _ _) |- _ ] => apply in_map_iff in H; break_exists; break_and
       | [ H : In _ (_ ++ _) |- _ ] => apply in_app_iff in H
     end; intuition; simpl in *); subst.

Ltac in_crush := repeat (in_crush_start; in_crush_finish).

Fixpoint Prefix {A} (l1 : list A) l2 : Prop :=
  match l1, l2 with
    | a :: l1', b :: l2' => a = b /\ Prefix l1' l2'
    | [], _ => True
    | _, _ => False
  end.

Lemma app_Prefix :
  forall A (xs ys zs : list A),
    xs ++ ys = zs ->
    Prefix xs zs.
Proof.
  induction xs; intros; simpl in *.
  - auto.
  - break_match.
    + discriminate.
    + subst. find_inversion. eauto.
Qed.

Fixpoint filterMap {A B} (f : A -> option B) (l : list A) : list B :=
  match l with
    | [] => []
    | x :: xs => match f x with
                   | None => filterMap f xs
                   | Some y => y :: filterMap f xs
                 end
  end.

Lemma app_cons_singleton_inv :
  forall A xs (y : A) zs w,
    xs ++ y :: zs = [w] ->
    xs = [] /\ y = w /\ zs = [].
Proof.
  intros.
  destruct xs.
  - solve_by_inversion.
  - destruct xs; solve_by_inversion.
Qed.

Definition null {A : Type} (xs : list A) : bool :=
  match xs with
    | [] => true
    | _ => false
  end.

Lemma null_sound :
  forall A (l : list A),
    null l = true -> l = [].
Proof.
  destruct l; simpl in *; auto; discriminate.
Qed.

Lemma null_false_neq_nil :
  forall A (l : list A),
    null l = false -> l <> [].
Proof.
  destruct l; simpl in *; auto; discriminate.
Qed.

Lemma map_of_filterMap :
  forall A B C (f : A -> option B) (g : B -> C) l,
    map g (filterMap f l) = filterMap (fun x => match f x with
                                                  | Some y => Some (g y)
                                                  | None => None
                                                end) l.
Proof.
  induction l; intros; simpl in *.
  - auto.
  - repeat break_match; simpl; auto using f_equal.
Qed.

Lemma filterMap_ext :
  forall A B (f g : A -> option B) l,
    (forall x, f x = g x) ->
    filterMap f l = filterMap g l.
Proof.
  induction l; intros; simpl in *.
  - auto.
  - repeat find_higher_order_rewrite; auto.
Qed.

Lemma filterMap_defn :
  forall A B (f : A -> option B) x xs,
    filterMap f (x :: xs) = match f x with
                              | Some y => y :: filterMap f xs
                              | None => filterMap f xs
                            end.
Proof.
  simpl. auto.
Qed.

Lemma app_cons_in :
  forall A (l : list A) xs a ys,
    l = xs ++ a :: ys ->
    In a l.
Proof.
  intros. subst. auto with *.
Qed.
Hint Resolve app_cons_in.

Lemma app_cons_in_rest:
  forall A (l : list A) xs a b ys,
    l = xs ++ a :: ys ->
    In b (xs ++ ys) ->
    In b l.
Proof.
  intros. subst. in_crush.
Qed.
Hint Resolve app_cons_in_rest.

Lemma remove_filter_commute :
  forall A  (l : list A) A_eq_dec f x,
    remove A_eq_dec x (filter f l) = filter f (remove A_eq_dec x l).
Proof.
  induction l; intros; simpl in *; auto.
  repeat (break_if; subst; simpl in *; try congruence).
Qed.

Lemma filter_partition :
  forall A (l1 : list A) f l2 x l1' l2',
    NoDup (l1 ++ x :: l2) ->
    filter f (l1 ++ x :: l2) = (l1' ++ x :: l2') ->
    filter f l1 = l1' /\ filter f l2 = l2'.
Proof.
  induction l1; intros; simpl in *.
  - break_if; simpl in *.
    + invcs H.
      destruct l1'; simpl in *; intuition.
      * solve_by_inversion.
      * find_inversion.
        exfalso.
        match goal with
          | H : filter ?f ?l = _ ++ ?x :: _ |- _ =>
            assert (In x (filter f l)) by (repeat find_rewrite; in_crush)
        end.
        find_apply_lem_hyp filter_In. intuition.
      * find_inversion.
        exfalso.
        match goal with
          | H : filter ?f ?l = _ ++ ?x :: _ |- _ =>
            assert (In x (filter f l)) by (repeat find_rewrite; in_crush)
        end.
        find_apply_lem_hyp filter_In. intuition.
    + exfalso.
      match goal with
        | H : filter ?f ?l = _ ++ ?x :: _ |- _ =>
          assert (In x (filter f l)) by (repeat find_rewrite; in_crush)
      end.
      find_apply_lem_hyp filter_In. intuition. congruence.
  - break_if.
    + invcs H.
      destruct l1'; simpl in *; intuition;
      try solve [
            find_inversion; exfalso;
            match goal with
              | _ : In ?x ?l -> False |- _ =>
                assert (In x l) by in_crush; intuition
            end|
            find_inversion; f_equal;
            find_apply_hyp_hyp; intuition].
    + invcs H. eauto.
Qed.

Lemma map_inverses :
  forall A B (la : list A) (lb : list B)  (f : A -> B) g,
    (forall a, g (f a) = a) ->
    (forall b, f (g b) = b) ->
    lb = map f la ->
    la = map g lb.
Proof.
  destruct la; intros; simpl in *.
  - subst. reflexivity.
  - destruct lb; try congruence.
    simpl in *. find_inversion.
    find_higher_order_rewrite.
    f_equal.
    rewrite map_map.
    erewrite map_ext; [symmetry; apply map_id|].
    simpl in *. auto.
Qed.

Lemma if_sum_bool_fun_comm :
  forall A B C D (b : {A}+{B}) (c1 c2 : C) (f : C -> D),
    f (if b then c1 else c2) = if b then f c1 else f c2.
Proof.
  intros. break_if; auto.
Qed.

Section assoc.
  Variable K V : Type.
  Variable K_eq_dec : forall k k' : K, {k = k'} + {k <> k'}.

  Fixpoint assoc (l : list (K * V)) (k : K) : option V :=
    match l with
      | [] => None
      | (k', v) :: l' =>
        if K_eq_dec k k' then
          Some v
        else
          assoc l' k
    end.

  Definition assoc_default (l : list (K * V)) (k : K) (default : V) : V :=
    match (assoc l k) with
      | Some x => x
      | None => default
    end.

  Fixpoint assoc_set (l : list (K * V)) (k : K) (v : V) : list (K * V) :=
    match l with
      | [] => [(k, v)]
      | (k', v') :: l' =>
        if K_eq_dec k k' then
          (k, v) :: l'
        else
          (k', v') :: (assoc_set l' k v)
    end.

  Fixpoint assoc_del (l : list (K * V)) (k : K) : list (K * V) :=
    match l with
      | [] => []
      | (k', v') :: l' =>
        if K_eq_dec k k' then
          l'
        else
          (k', v') :: (assoc_del l' k)
    end.

  Lemma get_set_same :
    forall k v l,
      assoc (assoc_set l k v) k = Some v.
  Proof.
    induction l; intros; simpl; repeat (break_match; simpl); subst; congruence.
  Qed.

  Lemma get_set_diff :
    forall k k' v l,
      k <> k' ->
      assoc (assoc_set l k v) k' = assoc l k'.
  Proof.
    induction l; intros; simpl; repeat (break_match; simpl); subst; try congruence; auto.
  Qed.

  Lemma not_in_assoc :
    forall k l,
      ~ In k (map (@fst _ _) l) ->
      assoc l k = None.
  Proof.
    intros.
    induction l.
    - auto.
    - simpl in *. repeat break_match; intuition.
      subst. simpl in *. congruence.
  Qed.

  Lemma get_del_same :
    forall k l,
      NoDup (map (@fst _ _) l) ->
      assoc (assoc_del l k) k = None.
  Proof.
    induction l; intros; simpl in *.
    - auto.
    - invc H.
      repeat break_match; subst.
      + simpl in *. apply not_in_assoc. auto.
      + simpl in *. break_if; try congruence.
        auto.
  Qed.

  Lemma get_del_diff :
    forall k k' l,
      k <> k' ->
      assoc (assoc_del l k') k = assoc l k.
  Proof.
    induction l; intros; simpl in *.
    - auto.
    - repeat (break_match; simpl); subst; try congruence.
      auto.
  Qed.
End assoc.


Require Import CoqRefinements.Types.
Require Import ProofIrrelevance.
Require Import ZArith.
Require Import Lia.
Require Import CoqRefinements.Common.
Require Import CoqRefinements.Tactics.
Require Import PLF.LibTactics.
Require Import Program.Utils. (* for 'dec' *)

Open Scope Z_scope.
Section nat_lt_ind_principle.
Variable P : Nat -> Prop.

Hypothesis ind_n : forall n:Nat, (forall k:{v:Z | v >= 0 /\ v < `n}, P ltac:(upcast k)) -> P n.

Theorem nat_lt_ind (n: Nat) : P n.

  (* enough (H0: forall p, p <= n -> P p).
  - apply H0, le_n. *)
  case n; intros n_val n_ref. generalize n_ref. pattern n_val. apply Z_lt_induction.
  + intros; apply ind_n; intros; destruct k.   apply H. simpl in *.  lia.
  + lia.
Qed.
End nat_lt_ind_principle.

Section natZ_lex_ind_principle.
Variable P : Nat -> Nat -> Prop.

Hypothesis true_for_lzero : forall m n:Nat, `m = 0 -> P m n.
Hypothesis ind_m : forall m n,  `m > 0  -> (forall p q, lex_lt p q m n -> P p q) -> P m n.

Theorem nat_lex_ind (m n: Nat) :  P m n.
Proof.
  (* destruct (splitZ_zero_pos m) as [ m_zero | m_pos]. *)
  revert n; induction m as [m IHm] using nat_lt_ind.

  destruct (dec (`m =? 0)).
  + intro; apply true_for_lzero; lia.
  +  induction n as [n IHn] using nat_lt_ind. apply ind_m.
    * destruct m; simpl in *; try lia.
    * intros p q [ lt_p_m | [eq_p_m lt_q_n] ].
      ++  applys_eq (IHm ltac:(infer p) q); reft_eq.
      ++  enough (p = m) as -> by (applys_eq (IHn ltac:(infer q)); reft_eq); reft_eq.
Qed.
End natZ_lex_ind_principle.


Require Import Classical.

Theorem drinker: forall A: Type, forall P: A -> Prop,
  forall a: A,
  exists x: A, (P x -> forall y: A, P y).
Proof.
  intros A P a.
  apply NNPP.
  intro H1.
  apply H1.
  exists a.
  intros Pa y.
  apply NNPP.
  intro H2.
  apply H1.
  exists y.
  intro Py.
  contradiction.
Qed.

Lemma prenex: forall A: Type, forall P: A -> Prop,
  (forall x: A, exists y: A, P x /\ ~ P y)
  <-> ~ (exists x: A, P x -> forall y: A, P y).
Proof.
  intros A P.
  split.
    intro H1.
    apply all_not_not_ex.
    intro a.
    elim (H1 a).
    intros b H2.
    elim H2.
    intros Pa nPb H3.
    apply nPb.
    apply H3.
    exact Pa.

    intros H1 a.
    apply not_all_not_ex.
    intro H2.
    apply (H2 a).
    split.
      apply NNPP.
      intro H3.
      apply H1.
      exists a.
      intro H4.
      contradiction.

      intro H3.
      apply H1.
      exists a.
      intros _ y.
      assert (H4 := not_and_or (P a) (~ P y) (H2 y)).
      elim H4.
        intro nPa.
        contradiction.

        intro nnPy.
        apply NNPP.
        exact nnPy.
Qed.

Theorem drinker_with_prenex: forall A: Type, forall P: A -> Prop,
  forall a: A,
  exists x: A, (P x -> forall y: A, P y).
Proof.
  intros A P a.
  apply NNPP.
  intro H1.
  apply H1.
  exists a.
  intros Pa y.
  assert (H2 := proj2 (prenex A P) H1).
  assert (H3 := H2 y).
  elim H3.
  intros x H4.
  exact (proj1 H4).
Qed.

(*
Lemma all_conj: forall A: Type, forall P Q: A -> Prop,
  (forall x: A, P x) /\ (forall x: A, Q x)
  <-> (forall x: A, P x /\ Q x).
Proof.
intros A P Q.
split.
  intros H1 x.
  elim H1.
  intros H2 H3.
  split.
    exact (H2 x).

    exact (H3 x).

  intro H1.
  split.
    intro x.
    exact (proj1 (H1 x)).

    intro x.
    exact (proj2 (H1 x)).
Qed.
*)

(*
Lemma drinker1: forall A: Type, forall P: A -> Prop,
  (forall x : A, exists y : A, P x /\ ~ P y)
  -> (forall x : A, exists y : A, ~ P x \/ P y).
Proof.
intros A P H1 x.
exists x.
assert (H2 := classic (P x)).
elim H2.
  intro Px.
  right.
  exact Px.

  intro nPx.
  left.
  exact nPx.
Qed.
*)


Inductive or (A B:Prop) : Prop :=
  | or_introl : A -> A \/ B
  | or_intror : B -> A \/ B
where "A \/ B" := (or A B) : type_scope.

Goal forall P Q, P \/ Q -> Q \/ P.
Proof.
  intros.
  elim H.
  - intros.
    apply or_intror.
    trivial.
  - intros.
    apply or_introl.
    trivial.
Qed.

(* Lemma myor_ind is automatically defined. *)
(* "elim" uses it. *)


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.lemma_betweennotequal.
Require Import ProofCheckingEuclid.lemma_extensionunique.
Require Import ProofCheckingEuclid.lemma_inequalitysymmetric.
Require Import ProofCheckingEuclid.lemma_orderofpoints_ABC_BCD_ABD.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_partnotequalwhole :
	forall A B C,
	BetS A B C ->
	~ Cong A B A C.
Proof.
	intros A B C.
	intros BetS_A_B_C.

	pose proof (lemma_betweennotequal _ _ _ BetS_A_B_C) as (neq_B_C & neq_A_B & _).
	apply lemma_inequalitysymmetric in neq_A_B as neq_B_A.
	pose proof (postulate_Euclid2 B A neq_B_A) as (D & BetS_B_A_D).
	apply axiom_betweennesssymmetry in BetS_B_A_D as BetS_D_A_B.
	pose proof (lemma_orderofpoints_ABC_BCD_ABD _ _ _ _ BetS_D_A_B BetS_A_B_C) as BetS_D_A_C.
	assert (~ Cong A B A C) as nCong_AB_AC.
	{
		intro Cong_AB_AC.

		pose proof (lemma_extensionunique _ _ _ _ BetS_D_A_B BetS_D_A_C Cong_AB_AC) as eq_B_C.

		contradict eq_B_C.
		exact neq_B_C.
	}
	exact nCong_AB_AC.
Qed.

End Euclid.


Require Import LC.Util.Fin.
Require Import LC.Util.Vec.
Require Import LC.Util.Star.
Require Import LC.LC.

Fixpoint cnum_aux {n} (x : nat) : Term (S (S n)) :=
  match x with
  | 0 => Var (inl tt : Fin (S (S n)))
  | S y => App (Var (inr (inl tt) : Fin (S (S n))))
            (cnum_aux y)
  end.

Definition cnum (i : nat) {n} : Term n :=
  Lam (Lam (cnum_aux i)).

Lemma cnum_aux_normal {n} (x : nat) :
  normal (@cnum_aux n x).
Proof.
  induction x; simpl; tauto.
Qed.

#[export]
Instance cnum_Const {x} : Const (@cnum x).
Proof.
  constructor.
  unfold cnum.
  simpl.
  intros n i.
  do 2 f_equal.
  induction x.
  { reflexivity. }
  { simpl.
    now rewrite IHx.
  }
Qed.

Fixpoint iter_app {n} (M : Term n) (i : nat) (N : Term n) : Term n :=
  match i with
  | 0 => N
  | S j => M # (iter_app M j N)
  end.

Lemma cnum_reds {n} (M N : Term n) : forall i,
  reds (cnum i # M # N) (iter_app M i N).
Proof.
  unfold cnum; intro i.
  normal_order.
  induction i; simpl.
  { normal_order. }
  { normal_order.
    rewrite subst_weaken.
    apply app_reds_r.
    apply IHi.
  }
Qed.