Add LoadPath "../Basics".
Add LoadPath "../Induction".
Add LoadPath "../Lists".

(* Require Import Lists. *)
Require Import EnumTypes.
Require Import Induction.
Require Import NamingCases.
Require Export Reasoning.

(** We can make polymorphic lists *)
Inductive list (X:Type) : Type :=
   | nil : list X
   | cons : X -> list X -> list X.

Check nil.
Check cons.

(** Let's try and re-write our natlist functions, only now they will
    operate over generic, polymorphic lists *)
Fixpoint length (X:Type) (l:list X) : nat :=
   match l with
   | nil => 0
   | cons h t => S (length X t)
   end.

(* Some tests to make sure it works well *)
Example test_length1 : length nat (cons nat 1 (cons nat 2 (nil nat))) = 2.
Proof. reflexivity. Qed.
Example test_length2 : length bool (cons bool true (nil bool)) = 1.
Proof. reflexivity. Qed.

(* Remaining list processing functions *)
Fixpoint app (X:Type) (l1 l2:list X) : (list X) :=
   match l1 with
   | nil => l2
   | cons h t => cons X h (app X t l2)
   end.

Fixpoint snoc (X : Type) (l : list X) (v : X) : (list X) :=
   match l with
   | nil => cons X v (nil X)
   | cons h t => cons X h (snoc X t v)
   end.

Fixpoint rev (X : Type) (l : list X) : list X :=
   match l with
   | nil => nil X
   | cons h t => snoc X (rev X t) h
   end.

Example test_rev1 : rev nat (cons nat 1 (cons nat 2 (nil nat))) =
   (cons nat 2 (cons nat 1 (nil nat))).

Proof. reflexivity. Qed.

Example test_rev2: rev bool (nil bool) = nil bool.
Proof. reflexivity. Qed.

Module MumbleBaz.

(** EXERCISE [**]: Consider the inductively defined types below. Which
    of the given elements are well-typed elements of grumble X *)
Inductive mumble : Type :=
   | a : mumble
   | b : mumble -> nat -> mumble
   | c : mumble.

Inductive grumble (X:Type) : Type :=
   | d : mumble -> grumble X
   | e : X -> grumble X.

(** Element          | Well-typed
    ------------------------------
    d (b a 5)        |
    d mumble (b a 5) |
    d bool (b a 5)   |
    e bool true      |
    e mumble (b c 0) |
    e bool (b c 0)   |
    c                |

    TODO *)

(** EXERCISE [**]: How many elements does the following inductive type
    have?  TODO *)
Inductive baz : Type :=
   | x : baz -> baz
   | y : baz -> bool -> baz.

End MumbleBaz.

(*****************************)
(* TYPE ANNOTATION INFERENCE *)
(*****************************)

(** Let's rewrite [app] without specifying the types of any of the
    arguments *)
Fixpoint app' X l1 l2 : list X :=
   match l1 with
   | nil => l2
   | cons h t => cons X h (app' X t l2)
   end.

(** It works b/c coq is smart enough to infer types. *)

(***************************)
(* TYPE ARGUMENT SYNTHESIS *)
(***************************)

(** We don't have to explicitly write types everywhere. Consider the
    following statement:

      length nat (cons nat 1 (cons nat 5 (nil nat)))

   why do we have to keep throwing around nat? Turns out we don't, we
   can use implicit arguments: *)
Fixpoint length' (X:Type) (l:list X) : nat :=
   match l with
   | nil => 0
   | cons h t => S (length' _ t)
   end.

(** Compare this first definition of list123, where [nat] is explicitly
    specified, to [list123'], which uses argument synthesis *)
Definition list123 :=
   cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

Definition list123' := cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

(*****************)
(* IMPLICIT ARGS *)
(*****************)

(** As you might have guessed, we can even eliminate the underscores. We
    use the [Arguments] directive, which takes the function name, and
    a sequence of arguments to that function, with curly-braces
    indicating that the argument should be treated implicitly *)
Arguments nil {X}.
Arguments cons {X} _ _.
(* underscores are used for unnamed arguments *)
Arguments length {X} l.
Arguments app {X} l1 l2.
Arguments rev {X} l.
Arguments snoc {X} l v.

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).
Check (length list123'').

(** Another way to accomplish the same goal is by declaring an implicit
    argument in the function definition itself, using curly braces: *)
Fixpoint length'' {X:Type} (l:list X) : nat :=
   match l with
   | nil => O
   | cons h t => S (length'' t)
   end.

(** Sometimes when declaring implicit arguments, Coq will not have enough
    local information to determine a type argument. In these cases, we
    must tell Coq that we want to give the argument explicitly, even
    though the initial declaration was implicit. For example, consider
    this definition:

      Definition mynil := nil

    Uncommenting this definition wil cause an error, because Coq has
    no idea what type should be supplied to nil. We can avoid this by
    providing an explicit type declaration. *)
Definition mynil : list nat := nil.

(** Alternatively, we can force the implict arguments to be explicit by
    prefixing a function name with @ *)
Check @nil.
Definition mynil' := @nil nat.

(** Some notationz *)
Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(********************************)
(* EXERCISES: POLYMORPHIC LISTS *)
(********************************)

(** EXERCISE [**]: Fill in the definitions and complete the proofs
    below *)
Fixpoint repeat {X : Type} (n : X) (count : nat) : list X :=
   match count with
   | O => nil
   | S count' => cons n (repeat n count')
   end.

Example test_repeat1: repeat true 2 = cons true (cons true nil).
Proof. reflexivity. Qed.

Theorem nil_app : forall X : Type, forall l : list X,
   app [] l = l.

Proof.
   intros X l. reflexivity. Qed.

Theorem rev_snoc : forall X : Type, forall v : X, forall s : list X,
   rev (snoc s v) = v :: (rev s).

Proof.
   intros X v s. induction s as [| x s'].
   Case "s = []".
      reflexivity.
   Case "s = x :: s'".
      simpl. rewrite IHs'. reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
   rev (rev l) = l.

Proof.
   intros X l. induction l as [| x l'].
   Case "l = []".
      reflexivity.
   Case "l = x :: l'".
      simpl. rewrite rev_snoc. rewrite IHl'. reflexivity.
Qed.

Theorem snoc_with_append :
   forall X : Type, forall l1 l2 : list X, forall v : X,
   snoc (l1 ++ l2) v = l1 ++ (snoc l2 v).

Proof.
   intros X l1 l2 v. induction l1 as [| x l1'].
   Case "l1 = []".
      reflexivity.
   Case "l1 = x :: l1'".
      simpl. rewrite IHl1'. reflexivity.
Qed.

(*********************)
(* POLYMORPHIC PAIRS *)
(*********************)

(** Using the same pattern we used for polymorphic lists, we can create
    polymorphic pairs *)
Inductive prod (X Y : Type) : Type :=
   pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y) : type_scope.

(** The standard [fst] and [snd] function *)
Definition fst {X Y : Type} (p : X * Y) : X :=
     match p with (x,y) => x end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
     match p with (x,y) => y end.

(** The next function is [zip], but it is called [combine] for
    consistency reasons *)
Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y) : list (X*Y) :=
   match (lx,ly) with
   | ([],_) => []
   | (_,[]) => []
   | (x::tx, y::ty) => (x,y) :: (combine tx ty)
   end.

(** EXERCISE [*]: Try answering the following questions and then check
    your answers in Coq *)

(* Question: What is the type of [combine]? *)
(* Answer: list X -> list Y -> list (prod X Y) *)
Check @combine.

(* Question: What does

      Eval compute in (combine [1;2] [false;true;false;true]).

   print? *)
(* Answer: [(1,false);(2,true)] *)
Eval compute in (combine [1;2] [false;true;false;true]).

(** EXERCISE [**]: The function [split] is the right inverse of combine:
    it takes a list of pairs and returns a pair of lists. Define
    [split] *)
Fixpoint split_help_fst {X Y : Type} (l : list (X*Y)) : (list X) :=
   match l with
   | [] => []
   | h :: t => (fst h) :: (split_help_fst t)
   end.

Fixpoint split_help_snd {X Y : Type} (l : list (X*Y)) : (list Y) :=
   match l with
   | [] => []
   | h :: t => (snd h) :: (split_help_snd t)
   end.

Fixpoint split {X Y : Type} (l : list (X*Y)) : (list X)*(list Y) :=
   (split_help_fst l, split_help_snd l).

Example test_split: split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof. reflexivity. Qed.

(** A much more elegant version of [split] using a [let]-expression *)
Fixpoint split' {X Y : Type} (l : list (X * Y)) : (list X) * (list Y) :=
   match l with
   | [] => ([],[])
   | (x,y)::t => let t' := split t
                 in  (x::(fst t'), (y::(snd t')))
   end.

(***********************)
(* POLYMORPHIC OPTIONS *)
(***********************)

(** Let's make our [natoption] type polymorphic *)
Inductive option (X:Type) : Type :=
   | Some : X -> option X
   | None : option X.

Arguments Some {X} _.
Arguments None {X}.

(** Let's make the [index] function polymorphic now *)
Fixpoint index {X : Type} (n : nat) (l : list X) : option X :=
   match l with
   | [] => None
   | a :: l' => if beq_nat n O
                  then Some a
                  else index (pred n) l'
   end.

Example test_index1 : index 0 [4;5;6;7] = Some 4.
Proof. reflexivity. Qed.
Example test_index2 : index 1 [[1];[2]] = Some [2].
Proof. reflexivity. Qed.
Example test_index3 : index 2 [true] = None.
Proof. reflexivity. Qed.

(** EXERCISE [*]: Complete the definition of a polymorphic version of
    [hd_opt] function from the last chapter. *)
Fixpoint hd_opt {X : Type} (l : list X) : option X :=
   match l with
   | [] => None
   | x::l' => Some x
   end.

Check @hd_opt.

Example test_hd_opt1 : hd_opt [1;2] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_opt2 : hd_opt [[1];[2]] = Some [1].
Proof. reflexivity. Qed.


Require Import Arith.
Require Import List.
Import ListNotations.

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | [] => None
  | a :: l' => if beq_nat n O then Some a else nth_error l' (pred n)
  end.

Theorem nth_error_after_last: forall (n : nat) (X : Type) (l : list X),
     length l = n ->
     nth_error l n = None.
Proof.
  intros n X l eq1.
  (* Bring back n to the quantifier for a more general IH *)
  generalize dependent n.
  induction l.
    - (* nil *) simpl. intros n eq2. reflexivity.
    - (* cons n l' *) intros n eq2. simpl. destruct n.
      + (* zero *) inversion eq2. (* length cons n l = 0 is contra *)
      + (* S n *) simpl. apply IHl. inversion eq2. reflexivity.
Qed.


Theorem ex24: forall a b c : Prop,
               a /\ (b /\ c) <-> (a /\ b) /\ c.
Proof.
  split. intro. split. split. elim H. intro.
  intro. assumption. elim H. intros.
  elim H1. intros. assumption.
  elim H. intros. elim H1. intros. assumption.
  intro. split. elim H. intros. elim H0.
  intros. assumption. split. elim H. intros.
  elim H0. intros. assumption. elim H. intros.
  assumption.
Qed.

Theorem ex25: forall a b c : Prop,
               a \/ (b \/ c) <-> (a \/ b) \/ c.
Proof.
  split. intro. elim H. intro. left. left. assumption.
  intro. elim H0. intro. left. right. assumption.
  intro. right. assumption.
  intro. elim H. intro. elim H0. intro.
  left. assumption. intro. right. left. assumption.
  intro. right. right. assumption.
Qed.

Theorem ex26: forall a b c : Prop,
               ((a <-> b) <-> c) -> (a <-> (b <-> c)).
Proof.
  Require Import Classical.
  intros. split. intro. split. intro.
  elim H. intros. apply H. split. intro. assumption.
  intro. assumption. intro.
  elim H. intros. apply H3. assumption.
  assumption.
  intro. elim H0. elim H. intros.
  apply NNPP. intro. elim H2. intros.
  apply H5. apply H7. apply H0. apply H.
  split. intro. apply (H6 H8). assumption.
  apply H. split. intro. contradiction.
  intro. apply H2. apply (H3 H6). assumption.
Qed.

Theorem ex26_1: forall a b c : Prop,
                (a <-> (b <-> c)) -> ((a <-> b) <-> c).
Proof.
  Require Import Classical.
  intros. split. intro. elim H. elim H0. intros.
  apply NNPP. intro. apply H5. apply H3.
  apply H. split. intro. elim H3. intros.
  apply (H7 H6). apply H0. assumption.
  intro. contradiction. apply NNPP. intro.
  elim H3. intros. apply H6. apply H0. apply H. split.
  intro. contradiction. intro. contradiction.
  apply NNPP. intro. apply H7. apply H. split.
  intro. contradiction. intro. contradiction.
  intro. split. elim H. intros. elim H1. intros.
  apply (H5 H0). assumption. intro.
  elim H. intros. apply H3. split.
  intro. assumption. intro. assumption.
Qed.


Require Import Arith.
Require Import List.
Require Import FunInd.

(* obliczenie nie zostawia "sladu" w dowodzie *)

Fact triv :
forall n, 0 + n = n.
Proof.
intro n.
rewrite plus_O_n.
reflexivity.
Qed.

Print triv.

Fact triv' :
forall n, 0 + n = n.
Proof.
intro n.
reflexivity.
Qed.

Print triv'.

Inductive even : nat -> Prop :=
| evenO : even O
| evenSS : forall n, even n -> even (S (S n)).

Hint Constructors even.

Lemma even1046: even 1046.
Time repeat constructor.
Qed.

Print even1046.

(* dowod przez refleksje - slaba specyfikacja *)

Function check_even (n:nat) : bool :=
match n with
| O => true
| 1 => false
| S (S n0) => check_even n0
end.

Lemma check_even_correct :
forall n, check_even n = true -> even n.
Proof.
intro n.
functional induction (check_even n); intros; auto. discriminate.
Qed.

Ltac prove_even n :=
  exact (check_even_correct n (refl_equal true)).

Lemma even4000 :
even 4000.
Proof.
(*Time repeat constructor.*)
Time prove_even 4000.
(* wystarczy sprawdzic, czy check_even 4000 = true *)
Qed.

Print even4000.

Lemma false_even1247 :
even 1247.
Proof.
(*prove_even 1247.*)
Abort.

(* silna specyfikacja *)

Inductive option (P:Prop) : Set :=
| proof : P -> option P
| noproof : option P.

Definition get_form {P} (x: option P) : Prop :=
match x with
| proof _ p => P
| noproof _ => True
end.

Definition get_proof {P} (x: option P) : get_form x :=
match x with
| proof _ p => p
| noproof _ => I
end.

Eval compute in get_form (proof _ (refl_equal 0)).
Eval compute in get_proof (proof _ (refl_equal 0)).
Eval compute in get_form (noproof (0=0)).

Notation " x <- a1 ; a2 " :=
(match a1 with
| proof _ x => a2
| noproof _ => _
end) (at level 60).

Notation " [ x ] " := (proof _ x).
Notation " ! " := (@noproof _).

Definition check_even' : forall (n:nat), option (even n).
refine (fix check n : option (even n) :=
match n with
| 0 => [evenO]
| 1 => !
| S (S n0) =>
p <- check n0; [evenSS _ p]
end).
destruct (check n0); [repeat constructor | constructor 2]; trivial.
Defined.

Eval compute in (check_even' 32).
Eval compute in (check_even' 33).

Eval compute in (get_proof (check_even' 32)).
Eval compute in (get_form (check_even' 32)).
Eval compute in (get_proof (check_even' 33)).

Ltac prove_even_strong :=
match goal with
| [ |- even ?n ] => exact (get_proof (check_even' n))
end.

Lemma strong_even4000 :
even 4000.
Proof.
Time prove_even_strong.
Time Defined.

Print strong_even4000.
(*Eval compute in strong_even4000.*)

Lemma even17 :
even 17.
Proof.
(*prove_even_strong.*)
Abort.

Require Import Bool.
Print reflect.

Check reflect (even 2) (check_even 2).

Lemma even_reflect :
forall n, reflect (even n) (check_even n).
Proof.
intro n.
Check iff_reflect.
apply iff_reflect.
split.
- induction 1; auto.
- apply check_even_correct.
Qed.

Lemma even1046_reflect :
even 1046.
Proof.
assert (hh:=even_reflect 1046).
inversion hh.
trivial.
Time Qed.

Print even1046_reflect.


Section Inductive_types.

  Inductive bool : Type :=
  | tru : bool
  | fla : bool.

  Definition and (m : bool) (n : bool) : bool :=
    match m with
    | tru => n
    | fla => fla
    end.

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

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

  Definition or m n : bool :=
    match m with
    | tru => tru
    | fla => n
    end.

  Lemma and_eq_or :
  forall m n :bool,
  (and m n = or m n) -> m = n.
  Proof.
    intros m n.
    destruct m.
    - destruct n.
      + reflexivity.
      + simpl. intros H. rewrite -> H. reflexivity. (* inversion H. *)
    - destruct n.
      + simpl. intros H. inversion H.
      + reflexivity.
  Qed.

  Lemma and_eq_or' : forall m n :bool,
      (and m n = or m n) -> m = n.
    intros;now case m, n. Qed.

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

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

  Lemma Mzeror : forall m, mult m O = O.
    intros;now elim m. Qed.

  Axiom Msymm : forall m n, mult m n = mult n m.
  Axiom mult_dist_plus : forall m n1 n2,
      mult m (plus n1 n2) = plus (mult m n1) (mult m n2).

  Lemma exp_plus_dist_mult : forall m n1 n2,
      exp m (plus n1 n2) = mult (exp m n1) (exp m n2).
  Proof.
    induction n1;intros;simpl.
    - assert(Pidr : forall m, plus m O = m).
      {
        induction m0;simpl.
        - reflexivity.
        - rewrite -> IHm0. reflexivity.
      }
      rewrite (Pidr (exp m n2)). reflexivity.
    - rewrite IHn1.
      assert(Massoc : forall a b c, mult a (mult b c) = mult (mult a b) c).
      {
        induction b;simpl;intros.
        - rewrite Mzeror. reflexivity.
        - rewrite (Msymm a (S b)). simpl.
          rewrite (Msymm b a), (Msymm (plus a (mult a b)) c).
          do 2 rewrite mult_dist_plus. rewrite IHb.
          rewrite (Msymm c a), (Msymm c (mult a b)). reflexivity.
      }
      rewrite Massoc. reflexivity.
  Qed.

  Check nat_ind.
  Check bool_ind.

End Inductive_types.

Require Import Setoid.
Set Implicit Arguments.

Section Set_equality.

  Parameter set : Type -> Type.
  Context {A : Type}.
  Parameter eq_set : set A -> set A -> Prop.
  Axiom eq_set_refl  : forall a, eq_set a a.
  Axiom eq_set_sym   : forall a b, eq_set a b -> eq_set b a.
  Axiom eq_set_trans : forall a b c, eq_set a b -> eq_set b c -> eq_set a c.

  Add Parametric Relation : (set A) (eq_set)
      reflexivity  proved by eq_set_refl
      symmetry     proved by eq_set_sym
      transitivity proved by eq_set_trans as eq_set_rel.

End Set_equality.

Section Div_morphsim.

  Let nonzero : nat -> nat -> Prop := fun x y => x = y /\ x <> O.
  Parameter div : nat -> nat -> nat.
  Axiom div_repl : forall y x1 x2, nonzero x1 x2 -> div y x1 = div y x2.

  Add Parametric Morphism :
    div with signature eq ==> nonzero ==> eq as div_mor.
  exact div_repl. Qed.

End Div_morphsim.


(* Exercise 18 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_018 : (exists x : D, P x) \/ (exists x : D, Q x) -> (exists x : D, P x \/ Q x).
Proof.
imp_i a1.
dis_e ((exists x:D, P x) \/ (exists x:D, Q x)) a2 a2.
hyp a1.
exi_e (exists x:D, P x) y a3.
hyp a2.
exi_i y.
dis_i1.
hyp a3.
exi_e (exists x:D, Q x) y a3.
hyp a2.
exi_i y.
dis_i2.
hyp a3.

Qed.


Inductive nat : Type :=
    | u0
    | S (n: nat).

(* Thus 3 will be represented using S (S (S (u0))) *)

Fixpoint add (n: nat) (m: nat) : nat :=
    match n with
    | u0 => m
    | S n' => S (add n' m)
    end.


Variable U : Type.

Definition set := U -> Prop.

Definition element (x:U) (S:set) := S x.

Definition subset (A B : set) := forall x:U, element x A -> element x B.

Definition transitive (T:Type) (R:T -> T -> Prop) := forall x y z: T, R x y -> R y z -> R x z.

Lemma subset_transitive : transitive set subset.
unfold transitive.
unfold subset.
intro A.
intro B.
intro C.
intro AIsIncludedInB.
intro BIsIncludedInC.
intro MySet.
intro AIsIncludedInC.
apply BIsIncludedInC.
apply AIsIncludedInB.
assumption.
Qed.

Print U.
Print element.
Print subset.
Print transitive.
Print subset_transitive.


Compute (orb true false).

Definition nandb (b1 : bool) (b2 : bool) : bool :=
  if (andb b1 b2) then false else true.

Example test_nandb1 : (nandb true false) = true.
unfold nandb.
simpl.
reflexivity.
Qed.

Example test_nandb2 : (nandb false false) = true.
simpl.
reflexivity.
Qed.

Example test_nandb3 : (nandb false true) = true.
simpl.
reflexivity.
Qed.

Definition andb3 (b1 : bool) (b2 : bool) (b3 : bool) : bool :=
  andb b1 (andb b2 b3).

Example test_andb3 : andb3 true true true = true.
simpl.
reflexivity.
Qed.

Check andb3.

Fixpoint minus (n m : nat) :=
  match n, m with
  | O, _       => O
  | _ , O      => n
  | S n', S m' => minus n' m'
  end.

Compute minus 3 2.

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

Compute factorial 3.

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

Notation "x <? y" := (ltb x y) (at level 70) : nat_scope.

Compute 10 <? 5.
Compute 5 <? 5.

Example test_ltb1 : (ltb 2 2) = false.
simpl.
reflexivity.
Qed.

Theorem plus_id_example : forall (n m : nat), n = m -> n + n = m + m.
intros.
rewrite -> H.
reflexivity.
Qed.

Theorem plus_id_exercise :
  forall (n m o : nat), n = m -> m = o -> n + m = m + o.
intros.
rewrite -> H.
rewrite -> H0.
reflexivity.
Qed.

Check mult_n_O.
Check mult_n_Sm.

Compute 1 * 3.

Theorem mult_n_1 : forall (p : nat), p * 1 = p.
intros.
rewrite <- mult_n_Sm.
rewrite <- mult_n_O.
reflexivity.
Qed.

Fixpoint eqb (a b : nat) :=
  match a, b with
  | O, O       => true
  | O, _       => false
  | _, O       => false
  | S a', S b' => eqb a' b'
  end.

Notation "a =? b" := (eqb a b) (at level 70) : nat_scope.

Theorem plus_1_neq_0 :
  forall (n : nat), S n =? O = false.
intros.
destruct n as [|n'] eqn:E; simpl; reflexivity.
Qed.

Theorem and_true_elim2 :
  forall (b c : bool), andb b c = true -> c = true.
intros.
destruct b.
- unfold andb in H.
  assumption.
- unfold andb in H.
  discriminate.
Qed.

Theorem zero_nbeq_plus_1 :
  forall (n : nat), 0 =? (n + 1) = false.
intros [|n']; simpl; reflexivity.
Qed.

Fail Fixpoint failing (n : nat) (b : bool) :=
  match b with
  | false => n
  | true => failing n false
  end.

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

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = negb x) ->
  forall (b : bool), f (f b) = b.
intros.
rewrite -> H.
rewrite -> H.
destruct b; simpl; reflexivity.
Qed.

Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
intros.
destruct b.
- unfold andb in H.
  unfold orb in H.
  rewrite -> H.
  reflexivity.
- unfold andb in H.
  unfold orb in H.
  rewrite <- H.
  reflexivity.
Qed.

Inductive bin : Type :=
  | Z
  | B_0 (n : bin)
  | B_1 (n : bin).

Fixpoint incr (m : bin) : bin :=
  match m with
  | Z      => B_1 Z
  | B_0 m' => B_1 m'
  | B_1 m' => B_0 (incr m')
  end.

Compute incr Z.
Compute incr (B_0 (B_0 Z)).
Compute incr (B_0 (B_1 Z)).
Compute incr (B_1 (B_1 Z)).

Fixpoint bin2nat_rec (m : bin) (power acc : nat) : nat :=
  match m with
  | Z      => acc
  | B_0 m' => bin2nat_rec m' (2 * power) acc
  | B_1 m' => bin2nat_rec m' (2 * power) (acc + power)
  end.

Definition bin2nat (m : bin) : nat := bin2nat_rec m 1 O.

Compute bin2nat Z.
Compute bin2nat (B_0 Z).
Compute bin2nat (B_0 (B_1 Z)).
Compute bin2nat (B_1 (B_0 (B_1 Z))).


Require Import Rfunctions.
Require Import Fourier.

Lemma l1 : forall x y z : R, Rabs (x - z) <= Rabs (x - y) + Rabs (y - z).
intros; split_Rabs; fourier.
Qed.

Lemma l2 :
 forall x y : R, x < Rabs y -> y < 1 -> x >= 0 -> - y <= 1 -> Rabs x <= 1.
intros.
split_Rabs; fourier.
Qed.


Require Import Coq.Arith.Plus.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.omega.Omega.
Require Import Arith.
Require Import Peano.
Fixpoint factorial n :=
  match n with
  | 0 => 1
  | S x => n * (factorial x)
  end.

Functional Scheme factorial_ind := Induction for factorial Sort Prop.

Theorem snn_le_sn :
  forall k n, S n ^ k >= n ^ k.
Proof.
  induction k.
  intros.
  simpl.
  auto.
  intros.
  simpl.
  assert (S n ^ k >= n^k).
  apply IHk.
  assert (S n ^ k + n * S n ^ k >= n * S n ^ k).
  omega.
  assert (n * S n ^ k >= n * n ^ k).
  apply mult_le_compat_l.
  apply H.
  omega.
  Qed.

Theorem factorial_example :
  forall n, n^n >= factorial n.
Proof.
  intros.
  functional induction factorial n.
  auto.
  assert ((S x) ^ (S x) >= (S x) ^ x).
  simpl.
  assert (S x ^ x + x * S x ^ x >= S x ^ x + 0).
  apply plus_le_compat_l with (p := S x ^ x) (m := x * S x ^ x) (n := 0).
  apply le_0_n.
  omega.
  assert (S x * x^x >= S x * factorial x).
  apply mult_le_compat_l.
  apply IHn0.
  assert (S x ^ S x >= S x * x ^ x).
  assert (S x ^ x >= x ^ x).
  simpl.
  apply snn_le_sn.
  assert (S x * S x ^ x >= S x * x ^ x).
  apply mult_le_compat_l.
  apply snn_le_sn.
  apply H2.
  omega.
  Qed.


Require Import VectorStates.

(** This file contains predicates for describing the outcomes of measurement. *)

(** * Probability of outcome ϕ given input ψ *)
Definition probability_of_outcome {n} (ϕ ψ : Vector n) : R :=
  Cmod (inner_product ϕ ψ) ^2.

(** * Probability of measuring ϕ on the first m qubits given (m + n) qubit input ψ *)
Definition prob_partial_meas {m n} (ϕ : Vector (2^m)) (ψ : Vector (2^(m + n))) :=
  big_sum (fun y => probability_of_outcome (ϕ ⊗ basis_vector (2^n) y) ψ) (2^n).

Lemma probability_of_outcome_comm : forall {d} (ϕ ψ : Vector d),
  probability_of_outcome ϕ ψ = probability_of_outcome ψ ϕ.
Proof.
  intros d ψ ϕ. unfold probability_of_outcome.
  rewrite inner_product_conj_sym.
  rewrite Cmod_Cconj; easy.
Qed.

Lemma probability_of_outcome_is_norm : forall {d} (ϕ ψ : Vector d),
  probability_of_outcome ϕ ψ = ((norm (ϕ† × ψ)) ^ 2)%R.
Proof.
  intros d ψ ϕ.
  unfold probability_of_outcome, Cmod, norm.
  apply f_equal2; try reflexivity.
  apply f_equal.
  unfold Mmult, adjoint.
  simpl.
  autorewrite with R_db.
  reflexivity.
Qed.

Lemma rewrite_I_as_sum : forall m n,
  (m <= n)%nat ->
  I m = big_sum (fun i => (basis_vector n i) × (basis_vector n i)†) m.
Proof.
  intros.
  induction m.
  simpl.
  unfold I.
  prep_matrix_equality.
  bdestruct_all; reflexivity.
  simpl.
  rewrite <- IHm by lia.
  unfold basis_vector.
  solve_matrix.
  bdestruct_all; simpl; try lca.
  all: destruct m; simpl; try lca.
  all: bdestruct_all; lca.
Qed.

Lemma prob_partial_meas_alt :
  forall {m n} (ϕ : Vector (2^m)) (ψ : Vector (2^(m + n))),
  @prob_partial_meas m n ϕ ψ = ((norm ((ϕ ⊗ I (2 ^ n))† × ψ)) ^ 2)%R.
Proof.
  intros.
  rewrite kron_adjoint, id_adjoint_eq.
  unfold prob_partial_meas.
  rewrite norm_squared.
  unfold inner_product, Mmult, adjoint.
  rewrite (@big_sum_func_distr C R _ C_is_group _ R_is_group), mult_1_l.
  apply big_sum_eq_bounded; intros.
  unfold probability_of_outcome.
  assert (H' : forall c, ((Cmod c)^2)%R = fst (c^* * c)).
  { intros.
    rewrite <- Cmod_sqr.
    unfold RtoC.
    simpl; lra. }
  rewrite H'.
  apply f_equal.
  assert (H'' : forall a b, a = b -> a^* * a = b^* * b). { intros; subst; easy. }
  apply H''.
  unfold inner_product, Mmult.
  apply big_sum_eq_bounded; intros.
  apply f_equal_gen; auto.
  apply f_equal.
  unfold kron, adjoint.
  rewrite Cconj_mult_distr.
  rewrite Nat.div_0_l, Nat.mod_0_l, (Nat.div_small x (2^n)), (Nat.mod_small x); try nia.
  apply f_equal_gen; auto.
  unfold basis_vector, I.
  bdestruct_all; try lia; simpl; try lca.
  intros.
  destruct a; destruct b; easy.
Qed.

Lemma partial_meas_tensor :
  forall {m n} (ϕ : Vector (2^m)) (ψ1 : Vector (2^m)) (ψ2 : Vector (2^n)),
  Pure_State_Vector ψ2 ->
  @prob_partial_meas m n ϕ (ψ1 ⊗ ψ2) = probability_of_outcome ϕ ψ1.
Proof.
  intros ? ? ? ? ? [H H0].
  rewrite prob_partial_meas_alt.
  rewrite probability_of_outcome_is_norm.
  unfold norm, inner_product.
  apply f_equal2; try reflexivity.
  do 2 apply f_equal.
  distribute_adjoint.
  Msimpl.
  rewrite H0.
  Msimpl.
  reflexivity.
Qed.


Require Import Arith.

Definition lt_3 (n:nat) : bool :=
  match n with
  | O | 1 | 2 => true
  | _ => false
  end.

(** Tests :

Compute lt_3 45.

Compute  lt_3 2.

Print lt_3.

*)


(* Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* Lists of booleans and related theory. *)

Set Implicit Arguments.

Require Import FCF.StdNat.
Require Export List.
Require Export Bvector.
Require Import micromega.Lia.
Require Import FCF.EqDec.
Require Import FCF.Fold.
Require Import ZArith.
Local Open Scope list_scope.

Definition Blist := list bool.

Definition Blist_eq_dec := (list_eq_dec bool_dec).

Definition Bvector_eq_dec(n : nat)(v1 v2 : Bvector n) : {v1 = v2} + {v1 <> v2}.
apply (EqDec_dec (Bvector_EqDec n)).
Defined.

(* shiftOut gets bits from the head of the list. *)
(* return None when we run out *)
Fixpoint shiftOut(s : Blist)(n : nat) : option (Bvector n * Blist) :=
  match n with
    | 0 => Some ((@Vector.nil bool), s)
    | S n' =>
      match s with
        | nil => None
        | b :: s' =>
          match (shiftOut s' n') with
            | Some (v', s'') => Some (Vector.cons _ b _ v', s'')
            | None => None
          end
      end
  end.

Theorem shiftOut_app : forall (n : nat)(s1 s1' s2 : Blist) v,
  shiftOut s1 n = Some (v, s1') ->
  shiftOut (s1 ++ s2) n = Some (v, s1' ++ s2).

  induction n; simpl in *; intuition.
  destruct s1; simpl in *.
  inversion H; clear H; subst.
  destruct s2; simpl.
  trivial.
  trivial.
  inversion H; clear H; subst.
  rewrite app_comm_cons.
  trivial.

  destruct s1; simpl in *.
  discriminate.
  case_eq (shiftOut s1 n); intuition.
  rewrite H0 in H.
  destruct p.
  inversion H; clear H; subst.
  erewrite IHn; eauto.

  rewrite H0 in H.
  discriminate.

Qed.

Lemma shiftOut_lt : forall ls n,
  length ls < n ->
  shiftOut ls n = None.

  induction ls; intuition; simpl in *.
  destruct n.
  lia.
  trivial.
  destruct n.
  lia.
  rewrite IHls.
  trivial.
  lia.
Qed.

Lemma shiftOut_Some : forall (ls : Blist) n,
  length ls >= n ->
  exists p, shiftOut ls n = Some p.

  induction ls; intuition; simpl in *.
  assert (n = O).
  lia.
  subst.
  exists ([], nil).
  trivial.

  destruct n.
  exists ([], a :: ls).
  trivial.
  assert (length ls >= n).
  lia.
  destruct (IHls n).
  trivial.
  destruct x.
  econstructor.
  rewrite H1.
  eauto.
Qed.

Theorem shiftOut_None_inv : forall n ls,
  shiftOut ls n = None ->
  n > length ls.

  induction n; destruct ls; intuition; simpl in *; try discriminate.
  apply gt_n_S.
  eapply IHn.
  case_eq (shiftOut ls n); intuition; trivial.
  rewrite H0 in H.
  destruct p.
  discriminate.
Qed.

Theorem shiftOut_Some_inv : forall n ls v ls',
  shiftOut ls n = Some (v, ls') ->
  (n <= length ls)%nat.

  induction n; destruct ls; intuition; simpl in *; try discriminate.

  apply le_n_S.
  case_eq (shiftOut ls n); intuition.
  destruct p.
  eauto.

  rewrite H0 in H.
  discriminate.
Qed.

Theorem shiftOut_correct_inv : forall n ls ls' v,
  shiftOut ls n = Some (v, ls') ->
  ls = (Vector.to_list v) ++ ls'.

  induction n; destruct ls; intuition; simpl in *.

  inversion H; clear H; subst.
  simpl.
  trivial.

  inversion H; clear H; subst.
  simpl.
  trivial.

  discriminate.

  case_eq (shiftOut ls n); intuition.
  rewrite H0 in H.
  destruct p.
  inversion H; clear H; subst.
  simpl.
  f_equal.
  apply IHn in H0.
  subst.
  trivial.

  rewrite H0 in H.
  discriminate.
Qed.

Lemma to_list_length : forall (A : Set)(m : nat)(v : Vector.t A m),
  length (Vector.to_list v) = m.

  induction m; intuition.
  rewrite (vector_0 v).
  simpl.
  trivial.

  destruct (vector_S v).
  destruct H.
  subst.
  simpl.

  f_equal.
  eapply IHm.
Qed.

Definition of_list_length (A : Set)(m : nat)(ls : list A)(pf : length ls = m) : Vector.t A m :=
  match pf with
    | eq_refl => Vector.of_list ls
  end.

Definition of_sig_list (A : Set)(m : nat)(l : {ls : list A | length ls = m}) : Vector.t A m :=
  match l with
    | exist _ ls pf => (of_list_length ls pf)
  end.

Lemma vector_hd_cons_eq : forall(A : Set)(v : Vector.t A 1),
  v = Vector.cons _ (Vector.hd v) _ (Vector.nil A).

  intuition.
  destruct (vector_S v).
  destruct H.
  subst.
  destruct (vector_0 x0).
  simpl.
  trivial.
Qed.

Lemma shiftOut_0 : forall (s : Blist),
  shiftOut s 0 = Some ([], s).

  intuition.
  destruct s; simpl in *; trivial.
Qed.

Theorem shiftOut_S_None : forall (n : nat)(s s1 : Blist)(v1 : Bvector 1),
  shiftOut s 1 = Some (v1, s1) ->
  shiftOut s1 n = None ->
  shiftOut s (S n) = None.
Abort.

Theorem shiftOut_1_None : forall (n1 n2 : nat)(s : Blist),
  shiftOut s n1 = None ->
  n2 >= n1 ->
  shiftOut s n2 = None.
Abort.

(* Todo : we need a general theorem that covers these sorts of facts.  Something like:
   shiftOut s n1 = Some(_, s1) ->
   shiftOut s1 n2 = x ->
   shiftOut s (n1 + n2) = x *)

Theorem shiftOut_S : forall (n : nat)(s s1 s2 : Blist)(v1 : Bvector 1)(v2 : Bvector n),
  shiftOut s 1 = Some (v1, s1) ->
  shiftOut s1 n = Some (v2, s2) ->
  shiftOut s (S n) = Some (Vector.cons _ (Vector.hd v1) _  v2, s2).

  destruct n; intuition; simpl in *.
  eapply eq_trans.
  eapply H.
  specialize (shiftOut_0 s1); intuition.
  rewrite H0 in H1.
  inversion H1; clear H1; subst.
  f_equal.
  f_equal.
  eapply vector_hd_cons_eq.

  destruct s; intuition; simpl in *.
  discriminate.
  rewrite shiftOut_0 in H.
  inversion H; clear H; subst.
  rewrite H0.
  f_equal.
Qed.

Fixpoint oneList(n : nat) : Blist :=
  match n with
    | 0 => nil
    | S n' => true :: (oneList n')
  end.

Theorem oneList_length : forall n,
  length (oneList n) = n.

  induction n; intuition; simpl in *.
  auto.
Qed.

(* TODO: remove oneVector and replace it with Bvect_true *)
Fixpoint oneVector(n : nat) : Bvector n :=
  match n with
    | 0 => Vector.nil bool
    | S n' => Vector.cons _ true _ (oneVector n')
  end.

Theorem shiftOut_oneList : forall (n : nat),
  shiftOut (oneList n) n = Some (oneVector n, nil).

  induction n; intuition; simpl in *.
  rewrite IHn.
  trivial.
Qed.

Fixpoint getAllBlists(n : nat) : (list Blist) :=
  match n with
    | 0 => nil :: nil
    | S n' => (map (cons true) (getAllBlists n')) ++
      (map (cons false) (getAllBlists n'))
  end.

Fixpoint getAllBlists_app(n : nat) : list Blist :=
  match n with
    | 0 => nil :: nil
    | S n' => (map (fun ls => ls ++ (true :: nil)) (getAllBlists_app n')) ++
      (map (fun ls => ls ++ (false :: nil)) (getAllBlists_app n'))
  end.

Fixpoint getAllBvectors(n : nat) : (list (Bvector n)) :=
  match n with
    | 0 => (Vector.nil bool) :: nil
    | S n' => (map (Vector.cons _ true _) (getAllBvectors n')) ++
      (map (Vector.cons _ false _) (getAllBvectors n'))
  end.

Lemma getAllBvectors_length : forall n,
  length (getAllBvectors n) = (expnat 2 n).

  induction n; intuition; simpl in *.
  rewrite app_length.
  repeat rewrite map_length.
  rewrite plus_0_r.
  f_equal; eauto.
Qed.

Lemma getAllBvectors_length_nz : forall n,
  length (getAllBvectors n) > 0.

  induction n; intuition; simpl in *.
  rewrite app_length.
  repeat rewrite map_length.
  rewrite <- plus_0_r.
  eapply gt_trans.
  eapply plus_gt_compat_l.
  apply IHn.
  repeat rewrite plus_0_r.
  apply IHn.
Qed.

Theorem in_getAllBvectors : forall (n : nat)(v : Bvector n),
  In v (getAllBvectors n).

  induction v; intuition; simpl.
  auto.
  eapply in_or_app; intuition.
  destruct h.
  left.
  eapply in_map; eauto.
  right.
  eapply in_map; eauto.
Qed.

Lemma vector_tl_eq : forall (A : Set)(n : nat)(v1 v2 : Vector.t A (S n)),
  v1 = v2 ->
  Vector.tl v1 = Vector.tl v2.

  intuition.
  specialize (vector_S v1).
  specialize (vector_S v2).
  intuition.
  destruct H0. destruct H0.
  destruct H1. destruct H1.
  subst.
  simpl.
  trivial.
Qed.

Lemma vector_cons_eq : forall (A : Set)(n : nat)(v1 v2 : Vector.t A n)(a1 a2 : A),
  Vector.cons A a1 n v1 = Vector.cons A a2 n v2 ->
  v1 = v2.

  intuition.

  apply vector_tl_eq in H.
  simpl in *.
  trivial.

Qed.

Lemma vector_cons_ne : forall (A : Set)(n : nat)(a1 a2 : Vector.t A n)(a : A),
  a1 <> a2 ->
  Vector.cons A a n a1 <> Vector.cons A a n a2.

  intuition.
  eapply H.
  eapply vector_cons_eq.
  eauto.
Qed.

Lemma map_NoDup : forall (A B : Set)(ls : list A)(f : A -> B),
  NoDup ls ->
  (forall a1 a2, a1 <> a2 -> (f a1) <> (f a2)) ->
  NoDup ((map f) ls).

  induction ls; intuition; simpl in *.

  econstructor.

  inversion H; subst; clear H.
  econstructor.
  intuition.
  apply in_map_iff in H.
  destruct H.
  intuition.
  eapply H0; eauto.
  intuition.
  subst.
  intuition.

  eapply IHls; eauto.
Qed.

Lemma getAllBvectors_NoDup : forall (n : nat),
  NoDup (getAllBvectors n).

  induction n; intuition; simpl in *.
  econstructor.
  eapply in_nil.
  econstructor.

  eapply app_NoDup.
  eapply map_NoDup; eauto.
  intros.
  eapply vector_cons_ne; eauto.

  eapply map_NoDup; eauto.
  intros.

  eapply vector_cons_ne; eauto.

  intuition.
  apply in_map_iff in H.
  apply in_map_iff in H0.
  destruct H.
  destruct H0.
  intuition.
  subst.
  inversion H.

  intuition.
  apply in_map_iff in H.
  apply in_map_iff in H0.
  destruct H.
  destruct H0.
  intuition.
  subst.
  inversion H.
Qed.

Require Import Permutation.

Lemma getAllBlists_NoDup : forall n,
  NoDup (getAllBlists n).

  induction n; intuition; simpl in *.
  econstructor.
  simpl.
  intuition.
  econstructor.

  eapply app_NoDup; intuition.

  eapply map_NoDup; intuition.
  eapply H.
  inversion H0; subst; intuition.

  eapply map_NoDup; intuition.
  eapply H.
  inversion H0; subst; intuition.

  apply in_map_iff in H.
  apply in_map_iff in H0.
  destruct H.
  destruct H0.
  intuition.
  subst.
  discriminate.

  apply in_map_iff in H.
  apply in_map_iff in H0.
  destruct H.
  destruct H0.
  intuition.
  subst.
  discriminate.

Qed.

Lemma getAllBlists_app_NoDup : forall n,
  NoDup (getAllBlists_app n).

  induction n; intuition; simpl in *.
  econstructor.
  simpl.
  intuition.
  econstructor.

  eapply app_NoDup; intuition.

  eapply map_NoDup; intuition.
  eapply H.
  apply app_inj_tail in H0.
  intuition.

  eapply map_NoDup; intuition.
  eapply H.
  eapply app_inj_tail in H0.
  intuition.

  apply in_map_iff in H.
  apply in_map_iff in H0.
  destruct H.
  destruct H0.
  intuition.
  subst.
  apply app_inj_tail in H; intuition.

  apply in_map_iff in H.
  apply in_map_iff in H0.
  destruct H.
  destruct H0.
  intuition.
  subst.
  apply app_inj_tail in H; intuition.

Qed.
    Lemma ls_last_exists : forall (A : Type)(ls : list A) n,
      length ls = (S n) ->
      exists a ls', (length ls' = n /\ ls = ls' ++ (a :: nil)).

      induction ls; intuition; simpl in *.
      lia.

      destruct n.
      destruct ls; simpl in *; try lia.
      exists a. exists nil.
      simpl.
      intuition.

      inversion H; clear H.
      edestruct IHls; intuition.
      eauto.
      destruct H.
      intuition.
      exists x.
      exists (a :: x0).
      subst.
      simpl.
      intuition.
Qed.

Lemma getAllBlists_app_rel_map : forall n,
  rel_map (fun ls1 ls2 => ls1 = (rev ls2)) (getAllBlists_app n) (getAllBlists n).

  induction n; intuition; simpl in *.
  econstructor.
  econstructor.
  simpl.
  trivial.

  eapply rel_map_app.
  eapply rel_map_map2.

  eapply rel_map_impl; eauto; intuition.
  subst.
  simpl.
  trivial.

  eapply rel_map_map2.

  eapply rel_map_impl; eauto; intuition.
  subst.
  simpl.
  trivial.
Qed.

Lemma getAllBlists_rel_map : forall n,
  rel_map (fun ls1 ls2 => ls1 = (rev ls2)) (getAllBlists n) (getAllBlists_app n).

  induction n; intuition; simpl in *.
  econstructor.
  econstructor.
  trivial.

  eapply rel_map_app.
  eapply rel_map_map2.
  eapply rel_map_impl; eauto; intuition.
  subst.
  rewrite rev_unit.
  trivial.

  eapply rel_map_map2.
  eapply rel_map_impl; eauto; intuition.
  subst.
  rewrite rev_unit.
  trivial.
Qed.

Lemma getAllBlists_app_In_length : forall n ls,
  In ls (getAllBlists_app n) ->
  length ls = n.

  induction n; intuition; simpl in *.
  destruct H; subst; intuition.

  apply in_app_or in H;
  destruct H;
  apply in_map_iff in H;
  destruct H;
  intuition;

  subst;
  rewrite app_length; simpl;
  rewrite plus_comm; simpl;
  f_equal;
  eapply IHn; eauto.
Qed.

Lemma getAllBlists_app_length_In : forall n ls,
  length ls = n ->
  In ls (getAllBlists_app n).

  induction n; intuition; simpl in *;
  destruct ls; simpl in *; intuition; try lia.

  edestruct (ls_last_exists (b :: ls)).
  simpl.
  eauto.
  destruct H0.
  intuition.
  rewrite H2.
  eapply in_or_app.
  destruct x; [left | right];
  eapply in_map_iff;
  econstructor; intuition.

Qed.

Lemma getAllBlists_In_length : forall n ls,
  In ls (getAllBlists n) ->
  length ls = n.

  induction n; intuition; simpl in *.
  destruct H; subst; intuition.

  apply in_app_or in H;
  destruct H;
  apply in_map_iff in H;
  destruct H;
  intuition;

  subst;
  simpl;
  f_equal;
  eapply IHn; eauto.
Qed.

Lemma getAllBlists_length_In : forall n ls,
  length ls = n ->
  In ls (getAllBlists n).

  induction n; intuition; simpl in *;
  destruct ls; simpl in *; intuition; try lia.

  apply in_or_app.

  destruct b; [left | right];
  eapply in_map_iff; eauto.
Qed.

Lemma getAllBlists_perm : forall n,
  Permutation (getAllBlists n) (getAllBlists_app n).

  intuition.
  eapply NoDup_Permutation.

  apply getAllBlists_NoDup.
  apply getAllBlists_app_NoDup.

  intuition.

  specialize (getAllBlists_rel_map n); intuition.
  specialize (rel_map_in_inv H0 x); intuition.
  destruct H2.
  intuition.
  subst.

  eapply getAllBlists_app_length_In.
  rewrite rev_length.
  eapply getAllBlists_app_In_length.
  eauto.

  specialize (getAllBlists_app_rel_map n); intuition.
  specialize (rel_map_in_inv H0 x); intuition.
  destruct H2.
  intuition.
  subst.
  eapply getAllBlists_length_In.
  rewrite rev_length.
  eapply getAllBlists_In_length.
  eauto.
Qed.

Theorem getAllBlists_length : forall n,
  length (getAllBlists n) = (expnat 2 n).

  induction n; intuition; simpl in *.
  rewrite app_length.
  repeat rewrite map_length.
  rewrite plus_0_r.
  rewrite <- IHn.
  trivial.
Qed.

Definition tailOpt(A : Set)(n : nat)(v : Vector.t A n) : option (Vector.t A (pred n)):=
  match v with
    | [] => None
    | Vector.cons _ _ _ v => Some v
  end.

Lemma tailOpt_eq : forall (A : Set)(n : nat)(v1 v2 : Vector.t A n),
  v1 = v2 ->
  tailOpt v1 = tailOpt v2.

  intuition.
  subst.
  trivial.
Qed.

Lemma vector_cons_eq_inv : forall (A : Set)(n : nat)(a1 a2 : A)(v1 v2 : Vector.t A n),
  Vector.cons A a1 n v1 = Vector.cons A a2 n v2 ->
  a1 = a2 /\ v1 = v2.

  intuition.
  inversion H; trivial.

  assert (tailOpt (Vector.cons A a1 n v1) = tailOpt (Vector.cons A a2 n v2)).

  eapply tailOpt_eq.
  trivial.

  simpl in *.
  inversion H0; clear H0; subst.
  trivial.
Qed.

Lemma pair_eq_inv : forall (A B : Type)(a1 a2 : A)(b1 b2 : B),
  (a1, b1) = (a2, b2) ->
  a1 = a2 /\ b1 = b2.

  intros.
  inversion H; clear H; subst.
  intuition.
Qed.

Lemma opt_eq_inv : forall (A : Type)(a1 a2 : A),
  Some a1 = Some a2 ->
  a1 = a2.

  intuition.
  inversion H; clear H; subst.
  trivial.
Qed.

Lemma shiftOut_ls_eq : forall n ls1 ls2 v ls1' ls2',
  shiftOut ls1 n = Some (v, ls1') ->
  shiftOut ls2 n = Some (v, ls2') ->
  (firstn n ls1) = (firstn n ls2).

  induction n; intuition; simpl in *.
  destruct ls1; simpl in *; try discriminate.
  destruct ls2; simpl in *; try discriminate.
  case_eq (shiftOut ls1 n); intuition.
  rewrite H1 in H.
  case_eq (shiftOut ls2 n); intuition.
  rewrite H2 in H0.
  destruct p.
  destruct p0.
  inversion H; clear H; subst.

  apply opt_eq_inv in H0.
  apply pair_eq_inv in H0; intuition.
  apply vector_cons_eq_inv in H; intuition; subst.

  f_equal.
  eapply IHn.
  eapply H1.
  eapply H2.

  rewrite H2 in H0.
  discriminate.
  rewrite H1 in H.
  discriminate.
Qed.

Lemma le_refl_gen : forall n1 n2,
  (n1 = n2 ->
    n1 <= n2)%nat.

  intuition.
Qed.

Lemma app_first_eq : forall (A : Type)(ls2 ls1 ls3 : list A),
  ls1 = ls2 ++ ls3 ->
  length ls1 = length ls2 ->
  ls1 = ls2 /\ ls3 = nil.

  intros; subst.
  assert (ls3 = nil).
  rewrite app_length in H0.
  assert (length ls3 = O).
  lia.
  destruct ls3; simpl in *; try lia; trivial.
  subst.
  rewrite app_nil_r.
  intuition.
Qed.

Lemma to_list_eq_inv : forall (A : Set) n (v1 v2 : Vector.t A n),
  VectorDef.to_list v1 = VectorDef.to_list v2 ->
        v1 = v2.

  induction n; intuition.
  rewrite (vector_0 v2).
  rewrite (vector_0 v1).
  trivial.

  destruct (vector_S v1).
  destruct (vector_S v2).
  destruct H0.
  destruct H1.
  subst.
  unfold VectorDef.to_list in *.
  inversion H; clear H; subst.
  f_equal.
  eauto.
Qed.

Lemma shiftOut_to_list : forall n (v : Bvector n),
  shiftOut (VectorDef.to_list v) n = Some (v, nil).

  intuition.

  edestruct (shiftOut_Some (VectorDef.to_list v)).
  eapply le_refl_gen.
  symmetry.
  eapply (to_list_length v).
  destruct x.
  rewrite H.
  apply shiftOut_correct_inv in H.

  apply app_first_eq in H.
  intuition; subst.

  apply to_list_eq_inv in H0; subst.
  trivial.

  repeat rewrite to_list_length.
  trivial.
Qed.

Lemma shiftOut_app_None : forall ls1 ls2 n,
  shiftOut (ls1 ++ ls2) n = None ->
  shiftOut ls1 n = None.

  induction ls1; intuition; simpl in *.
  destruct n; destruct ls2; try discriminate; trivial.

  destruct n.
  discriminate.

  case_eq (shiftOut (ls1 ++ ls2) n); intuition.
  rewrite H0 in H.
  destruct p.
  discriminate.
  rewrite H0 in H.
  erewrite IHls1.
  trivial.
  eauto.

Qed.

Lemma BVxor_same_id : forall n (v : Bvector n),
  BVxor n v v = Bvect_false n.

  induction n; intuition.
  rewrite (vector_0 v).
  simpl.
  unfold Bvect_false.
  simpl.
  trivial.

  destruct (vector_S v).
  destruct H.
  rewrite H.
  unfold Bvect_false.
  simpl.
  rewrite IHn.
  rewrite xorb_nilpotent.
  trivial.

Qed.

Lemma BVxor_comm : forall n (v1 v2 : Bvector n),
  BVxor n v1 v2 = BVxor n v2 v1.

  induction n; intuition.
  rewrite (vector_0 v1).
  rewrite (vector_0 v2).
  trivial.

  destruct (vector_S v1).
  destruct H.
  destruct (vector_S v2).
  destruct H0.
  subst.
  simpl.
  rewrite IHn.
  rewrite xorb_comm.
  trivial.
Qed.

Lemma BVxor_id_r : forall n (v : Bvector n),
  BVxor n v (Bvect_false n) = v.

  induction n; intuition.
  rewrite (vector_0 v).
  unfold Bvect_false.
  simpl.
  trivial.

  destruct (vector_S v).
  destruct H.
  unfold Bvect_false.
  subst.
  simpl.
  rewrite IHn.
  rewrite xorb_false_r.
  trivial.
Qed.

Lemma BVxor_id_l : forall n (v : Bvector n),
  BVxor n (Bvect_false n) v = v.

  intuition.
  rewrite BVxor_comm.
  apply BVxor_id_r.
Qed.

Lemma BVxor_assoc : forall n (v1 v2 v3 : Bvector n),
  BVxor n (BVxor n v1 v2) v3 = BVxor n v1 (BVxor n v2 v3).

  induction n; intuition.
  rewrite (vector_0 v1).
  rewrite (vector_0 v2).
  rewrite BVxor_same_id.
  rewrite BVxor_id_l.
  rewrite (vector_0).
  rewrite (vector_0 v3).
  trivial.

  destruct (vector_S v1).
  destruct H.
  destruct (vector_S v2).
  destruct H0.
  destruct (vector_S v3).
  destruct H1.
  subst.
  simpl.
  rewrite IHn.
  rewrite xorb_assoc.
  trivial.
Qed.

Lemma BVxor_id_r_inv : forall n (v1 v2 : Bvector n),
  BVxor n v1 v2 = v1 ->
  v2 = (Bvect_false n).

  intuition.
  rewrite <- BVxor_id_l at 1.
  rewrite <- (BVxor_same_id v1).
  rewrite BVxor_assoc.
  f_equal; intuition.
Qed.

Lemma BVxor_id_inv : forall n (v1 v2 : Bvector n),
  BVxor n v1 v2 = Bvect_false n ->
  v1 = v2.

  intuition.
  rewrite <- BVxor_id_l at 1.
  rewrite <- (BVxor_id_l v2).
  rewrite <- (BVxor_same_id v2) at 1.
  rewrite BVxor_assoc.
  rewrite BVxor_comm.
  f_equal; intuition.
  rewrite BVxor_comm.
  trivial.
Qed.

Definition lognat(n : nat) : nat :=
  N.to_nat (N.size (N.of_nat n)).

Lemma lognat_monotonic : forall n1 n2,
  (n1 < n2 ->
    lognat n1 <= lognat n2)%nat.
Proof.
  intros ? ? H.
  pose proof N.log2_le_mono (N.of_nat n1) (N.of_nat n2).
  case n1, n2; try (cbn; lia); cbv [lognat]; rewrite !N.size_log2; try lia.
Qed.

Lemma lt_pow2_lognat k n : lognat k <= n -> k < 2^n.
Proof.
  cbv [lognat]; intros H; destruct k; [pose proof Nat.pow_eq_0_iff 2 n; lia|].
  enough (N.of_nat (S k) < N.of_nat (2^n))%N by lia; rewrite Nnat.Nat2N.inj_pow.
  rewrite !N.size_log2, Nnat.N2Nat.inj_succ in H by lia.
  apply N.log2_lt_pow2; lia.
Qed.

Fixpoint bvToNat(k : nat)(v : Bvector k) :=
  match v in Vector.t _ k with
  | Vector.nil _ => 0
  | Vector.cons _ b _ v => Nat.b2n b + Nat.double (bvToNat v)
  end.

Lemma bvNat_zero : forall n,
  bvToNat (Bvect_false n) = O.
Proof. induction n; cbn; rewrite ?IHn; trivial. Qed.

Fixpoint natToBv(k : nat)(v : nat) : Bvector k :=
  match k with
  | 0 => Vector.nil _
  | S k => Vector.cons _ (Nat.odd v) _ (natToBv k (Nat.div2 v))
  end.

Lemma bvToNat_natToBv : forall n k,
  bvToNat (natToBv n k) = k mod (2 ^ n).
Proof.
  induction n; cbn [bvToNat natToBv]; trivial; intros.
  cbn [Nat.pow]; rewrite Nat.Div0.mod_mul_r; setoid_rewrite Nat.bit0_mod; f_equal.
  rewrite IHn, Nat.div2_div, Nat.double_twice; trivial.
Qed.

Lemma bvToNat_natToBv_inverse : forall n k,
  n >= lognat k ->
  bvToNat (natToBv n k) = k.
Proof.
  intros; rewrite bvToNat_natToBv, Nat.mod_small; auto using lt_pow2_lognat.
Qed.

Lemma natToBv_bvToNat_inverse : forall n k,
  (natToBv n (bvToNat k)) = k.
Proof.
  symmetry.
  induction k; cbn; trivial; f_equal.
  { rewrite Nat.odd_add_even by (exists (bvToNat k); cbv[Nat.double]; lia).
    symmetry; apply Nat.b2n_bit0. }
  rewrite Nat.div2_div, Nat.double_twice, Nat.add_b2n_double_div2; trivial.
Qed.

Lemma bvToNat_natToBv_eq : forall n (v : Bvector n) k,
  bvToNat v = k ->
  v = natToBv n k.
Proof. pose proof natToBv_bvToNat_inverse. congruence. Qed.


(* Set is the type of "computational types" *)
Check nat.
Check nat -> nat.
Check bool.
Check bool -> nat.

(* Prop is the type of propositions *)
Check (forall (x : nat), x <> S x).
Check (forall (P : Prop), P -> P).
Check (true <> false).

(* Type is the type of Set and Prop (and Type of Type_n has type Type_(1 + n) *)
Check Set.
Check Prop.
Check Type.

(*
The difference between Prop and Set is that Prop is "impredicative" which means
that when quantifying over P : Prop in a Prop this quantification is quantifying
over _itself_ as well. This kind of circularity can in some cases lead to
inconsistencies (i.e. that False is provable), compare with Russels paradox. To
avoid this impredicativity in Coq is restricted to Prop (which is ok). This
means that neither Set nor Type are impredicative. Note that Agda is completely
predicative.

Nice examples of impredicativity of Prop can be found in:
   https://sympa.inria.fr/sympa/arc/coq-club/2012-07/msg00129.html

The simplest one follow below:
*)

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

 (* This is a Prop *)
Check ModusPonens_Prop.

Theorem ModusPonens_Prop_proof : ModusPonens_Prop.
Proof. unfold ModusPonens_Prop; auto. Qed.

(* It can be applied to itself, i.e., P and Q can be instantiated to
   ModusPonens_Prop. *)
Check ModusPonens_Prop_proof ModusPonens_Prop ModusPonens_Prop.

(* The same thing for Set: *)
Definition ModusPonens_Set := forall P Q : Set, (P -> Q) -> P -> Q.

(* This is a Type... *)
Check ModusPonens_Set.

Theorem ModusPonens_Set_proof : ModusPonens_Set.
Proof. unfold ModusPonens_Set; auto. Qed.

(* So the following is not possible as ModusPonens_Set is a Type, not a Set: *)
(* Check ModusPonens_Set_proof ModusPonens_Set ModusPonens_Set. *)

(* The same for Type *)
Definition ModusPonens_Type := forall P Q : Type, (P -> Q) -> P -> Q.

(* This is also a Type, but with higher level. Sadly the level cannot be seen in
   Coq... But if P and Q above have Type_m then ModusPonens_Type has Type_n with
   the constraint that m < n *)
Check ModusPonens_Type.

Theorem ModusPonens_Type_proof : ModusPonens_Type.
Proof. unfold ModusPonens_Type; auto. Qed.

(* This produces an error because ModusPonens_Type_proof is expecting things of
   type Type_m but ModusPonens_proof has type Type_n where m < n *)
(* Check ModusPonens_Type_proof ModusPonens_Type ModusPonens_Type. *)


Require Export D.

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

Definition classic := forall P:Prop,
  ~~P -> P.

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

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

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

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

Theorem classic_double_net : forall P:Prop,
  ~~P -> P.
Proof.
  intros P H. unfold not in H. intros H.
  Lemma p_false : forall P:Prop,
  (P -> False) <-> ~P.
  Proof. intros P. split.
<F2>
 unfold not in H.


Require Import prosa.classic.util.tactics.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

(* Induction lemmas for natural numbers. *)
Section NatInduction.

  Lemma strong_ind :
    forall (P: nat -> Prop),
      (forall n, (forall k, k < n -> P k) -> P n) ->
      forall n, P n.
  Proof.
    intros P ALL n; apply ALL.
    induction n; first by ins; apply ALL.
    intros k LTkSn; apply ALL.
    by intros k0 LTk0k; apply IHn, leq_trans with (n := k).
  Qed.

  Lemma leq_as_delta :
    forall x1 (P: nat -> Prop),
      (forall x2, x1 <= x2 -> P x2) <->
      (forall delta, P (x1 + delta)).
  Proof.
    ins; split; last by intros ALL x2 LE; rewrite -(subnK LE) addnC; apply ALL.
    {
      intros ALL; induction delta.
        by rewrite addn0; apply ALL, leqnn.
        by apply ALL; rewrite -{1}[x1]addn0; apply leq_add; [by apply leqnn | by ins].
    }
  Qed.

End NatInduction.


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.Lt.
Require Import Coq.Arith.Gt.
Require Import Arith.Wf_nat.
Require Import Recdef.

Open Scope nat_scope.

Import ListNotations.

(* Auxiliary definitions and lemmas *)
Definition max (a b : nat) :=
    match nat_compare a b with
    | Lt => b
    | _  => a
    end.

Inductive tree :=
    | Tip :
        nat (* height of the tree it represents *)
        -> tree
    | Bin :
        nat (* height *)
        -> tree (* left child *)
        -> tree (* right child *)
        -> tree.

(* functions on trees *)
Definition ht (t : tree) :=
    match t with
    | Tip n     => n
    | Bin n _ _ => n
    end.

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

Fixpoint flatten (t : tree) : list tree :=
    match t with
    | Tip n       => Tip n :: nil
    | Bin n t1 t2 => flatten t1 ++ flatten t2
    end.

Fixpoint siblings (t : tree) (a b : tree) : Prop :=
    match t with
    | Tip _     => False
    | Bin _ x y => a = x /\ b = y \/ siblings x a b \/ siblings y a b
    end.

(* local minimum pair *)
Inductive lmp : tree -> tree -> list tree -> Set :=
    | lmp_pair :
        forall (a b : tree), lmp a b (a :: b :: nil)

    | lmp_threel :
        forall (a b x : tree),
            (ht a < ht b /\ ht x >= ht b) \/ ht b <= ht a  ->  lmp a b (x :: a :: b :: nil)

    | lmp_threer :
        forall (a b y : tree) (l : list tree),
            (ht a < ht b /\ ht b < ht y) \/ ht b <= ht a /\ ht a < ht y
            -> lmp a b (a :: b :: y :: l)

    | lmp_left :
        forall (a b x y : tree) (l l1 l2 : list tree),
            (l = l1 ++ (x :: a :: b :: y :: l2))
            -> ht b <= ht a
            -> ht b < ht y
            -> lmp a b l

    | lmp_right :
        forall (a b x y : tree) (l l1 l2 : list tree),
            (l = l1 ++ (x :: a :: b :: y :: l2))
            -> ht a < ht b
            -> ht b < ht y
            -> ht x >= ht b
            -> lmp a b l.


From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat.

Definition id :
    forall A : Type, A -> A
:=
    fun A : Type => fun x : A => x.
Compute id bool true.
Compute id nat 34.

(* Dependent types, wow! Type of return value depends on argument *)
Check id bool : bool -> bool.
Check id nat : nat -> nat.

(* A function of type like forall x : A, B is called a dependently
   typed function from A to B(x) where B(x) meand that B may refer
   to x and B is usually called a family of types *)
Locate "->".
(* (forall _ : A, B) - independent, because of _ *)

(* type <=> implementation *)
Definition id' :
    forall A : Type , forall _ : A ,  A
:=
       fun A : Type =>   fun x : A => x.

(* Product Type *)
Inductive prodn : Type := | pairn of nat & nat.

Inductive prod (A B : Type) : Type :=
    | pair of A & B.
(* prod is a type constructor, not a type! *)
Fail Check prod : Type.
Check prod nat nat : Type.

(* 4 arguments!.. - all type parametres of prod are inherited by pair *)
Check pair.
Check pair nat bool 34 true.

(* Implicit arguments *)
Arguments id [A] _.
Arguments pair [A B] _ _.

Check id 34.
Compute id 33.
Fail Check pair nat bool 33 true : prod nat bool.
Check @pair nat bool 33 true : prod nat bool.
Set Implicit Arguments.
Check pair 42 true : prod nat bool.

(* Notations *)
Notation "A * B" :=
    (prod A B)
    (at level 40, left associativity)
    : type_scope.

Locate "*".
Fail Check nat * bool.
Check (nat * bool)%type.
Check (nat * bool) : Type.

Open Scope type_scope.
Locate "*".
Check nat * bool.
Fail Check 34 * 34.
Close Scope type_scope.

(* Left assoc example *)
Check ((nat * bool) * nat)%type.
Check (nat * bool * nat)%type.
Check (nat * (bool * nat))%type.

Notation "( p ; q )" := (pair p q).
Check (1; false).

Notation "( p , q , .. , r )" :=
    (pair .. (pair p q) .. r) : core_scope.
Check (1, false) : nat * bool.
Check (1, false, 3) : nat * bool * nat.
Check (1, false, 3, true) : nat * bool * nat * bool.

Definition fst {A B : Type} : A * B -> A :=
    fun p =>
        match p with
        | (a, _) => a
        end.
Check fst.

Definition snd {A B : Type} : A * B -> B :=
    fun p =>
        match p with
        | (_, b) => b
        end.
Notation "p .1" := (fst p).
Notation "p .2" := (snd p).
Compute (43, true).1.
Compute (43, true).2.

Definition swap {A B : Type} : A * B -> B * A :=
    fun p =>
        match p with
        | (a,b) => (b, a)
        end.
Compute swap (34, true).

(* Sum Type *)
Inductive sum (A B : Type) : Type :=
    | inl of A
    | inr of B.
Notation "A + B" :=
    (sum A B) (at level 50, left associativity)
    : type_scope.
Definition swap_sum {A B : Type} :
    A + B -> B + A :=
    fun s =>
        match s with
        | inl a => inr B a
        | inr b => inl A b
        end.


(* -----------------Description------------------------------------------

This file contains useful results about reflection techniques in Coq.
Some of the important concepts formalized are:

Definition Prop_bool_eq (P: Prop) (b: bool):= P <-> b=true.
Lemma reflect_intro (P:Prop)(b:bool): Prop_bool_eq P b -> reflect P b.

Lemma impP(p q:bool): reflect (p->q)((negb p) || q).
Lemma switch1(b:bool): b=false -> ~ b.
Lemma switch2(b:bool): ~ b -> b=false.

Some useful Ltac defined terms:

 Ltac switch:=  (apply switch1||apply switch2).
 Ltac switch_in H:= (apply switch1 in H || apply switch2 in H).
 Ltac right_ := apply /orP; right.
 Ltac left_ := apply /orP; left.
 Ltac split_ := apply /andP; split.

--------------------- ------------------- ------------------------------*)

From Coq Require Export ssreflect  ssrbool.

Require Export Omega.

Set Implicit Arguments.

Section GeneralReflections.
Definition Prop_bool_eq (P: Prop) (b: bool):= P <-> b=true.

(* Inductive reflect (P : Prop) : bool -> Set :=
   ReflectT : P -> reflect P true | ReflectF : ~ P -> reflect P false *)
Lemma reflect_elim (P:Prop)(b: bool): reflect P b -> Prop_bool_eq P b.
Proof. { intro H.
       split. case H; [ auto | discriminate || contradiction ].
       case H; [ auto | discriminate || contradiction ]. } Qed.
Lemma reflect_intro (P:Prop)(b:bool): Prop_bool_eq P b -> reflect P b.
Proof. { intros. destruct H as  [H1 H2].
         destruct b. constructor;auto.
         constructor.  intro H. apply H1 in H;inversion H. } Qed.
Hint Immediate  reflect_elim reflect_intro.
Lemma reflect_dec P: forall b:bool, reflect P b -> {P} + {~P}.
Proof. intros b H; destruct b; inversion H; auto.  Qed.
Lemma reflect_EM P: forall b:bool, reflect P b -> P \/ ~P.
Proof. intros b H. case H; tauto. Qed.
Lemma dec_EM P: {P}+{~P} -> P \/ ~P.
  Proof. intro H; destruct H as [Hl |Hr];tauto. Qed.
Lemma pbe_EM P: forall b:bool, Prop_bool_eq P b -> P \/ ~P.
Proof. { intros b H; cut( reflect P b).
         apply reflect_EM. apply reflect_intro;auto. } Qed.
Hint Immediate reflect_EM reflect_dec.

(* iffP : forall (P Q : Prop) (b : bool), reflect P b -> (P -> Q) -> (Q -> P) -> reflect Q b *)

(* idP : forall b1 : bool, reflect b1 b1 *)

(* negP
     : reflect (~ ?b1) (~~ ?b1) *)

(* andP
     : reflect (?b1 /\ ?b2) (?b1 && ?b2) *)

(*orP
     : reflect (?b1 \/ ?b2) (?b1 || ?b2) *)
Lemma impP(p q:bool): reflect (p->q)((negb p) || q).
  Proof. { case p eqn:pH; case q eqn:qH; simpl.
       constructor. auto.
       constructor. intro H2. cut (false=true). discriminate. apply H2. auto.
       constructor. auto.
       constructor. discriminate. } Qed.
Lemma impP1(P Q:Prop)(p q:bool)(HP: reflect P p)(HQ: reflect Q q):  reflect (P->Q)((negb p) || q).
Proof. { case p eqn:pH; case q eqn:qH; simpl.
       constructor. move /HP. apply /HQ.
       constructor. intro H2. absurd (Q). move /HQ. discriminate. apply H2; apply /HP;auto.
       constructor. move /HP. discriminate.
       constructor. move /HP. discriminate. } Qed.
Lemma switch1(b:bool): b=false -> ~ b.
Proof. intros H H1.  rewrite H1 in H. discriminate H. Qed.
Lemma switch2(b:bool): ~ b -> b=false.
Proof. intros H. case b eqn:H1. absurd (true);auto. auto. Qed.

Lemma bool_fun_equal (B1 B2: bool): (B1-> B2)-> (B2-> B1)-> B1=B2.
    Proof. intros H1 H2. destruct B1; destruct B2; auto.
           replace false with true. auto. symmetry; auto. Qed.

    Hint Resolve bool_fun_equal: core.

End GeneralReflections.

Hint Immediate reflect_intro reflect_elim  reflect_EM reflect_dec dec_EM: core.
Hint Resolve idP impP impP1: core.
Hint Resolve bool_fun_equal: core.

Ltac solve_dec := eapply reflect_dec; eauto.
Ltac solve_EM  := eapply reflect_EM; eauto.

Ltac switch:=  (apply switch1||apply switch2).
Ltac switch_in H:= (apply switch1 in H || apply switch2 in H).

Ltac right_ := apply /orP; right.
Ltac left_ := apply /orP; left.
Ltac split_ := apply /andP; split.

Section NaturalNumbers.

Lemma ltP (x y:nat): reflect (x < y) (Nat.ltb x y).
Proof. { apply reflect_intro. split.
       { unfold "<".  unfold "<?".
         revert y. induction x. intro y; case y. simpl.
         intro H. inversion H. simpl. auto.
         intro y;case y.
         intro H; inversion H. intros n H.
         replace (S (S x) <=?  S n) with (S x <=? n). apply IHx. omega.
         simpl. auto. }
       { unfold "<"; unfold "<?".
         revert y. induction x. intro y; case y. simpl.
         intro H. inversion H. intros; omega.
         intro y;case y. simpl. intro H; inversion H.
         intro n. replace (S (S x) <=? S n) with (S x <=? n).
         intro H; apply IHx in H. omega. simpl;auto. } } Qed.

Lemma leP (x y: nat): reflect (x <= y) (Nat.leb x y).
Proof. { apply reflect_intro. split.
       { revert y. induction x. intro y; case y; simpl; auto.
         intro y;case y.
         intro H; inversion H. intros n H.
         replace (S  x <=? S n) with ( x <=? n). apply IHx. omega.
         simpl. auto. }
       { revert y. induction x. intro y; case y; intros; omega.
         intro y;case y. simpl. intro H; inversion H.
         intro n. replace (S x <=? S n) with ( x <=? n).
         intro H; apply IHx in H. omega. simpl;auto. } } Qed.

Lemma nat_reflexive: reflexive Nat.leb.
  Proof. unfold reflexive; induction x; simpl; auto. Qed.

Lemma nat_transitive: transitive Nat.leb.
Proof. unfold transitive. intros x y z h1 h2. move /leP in h1. move /leP in h2.
         apply /leP. omega. Qed.

Hint Resolve leP ltP nat_reflexive nat_transitive: core.

End NaturalNumbers.

Hint Resolve leP ltP nat_reflexive nat_transitive: core.


Require Import ssreflect.

(**
# 第2回 証明済みの定理の利用・量化や等式を含む命題に関する証明 (2014/04/13)

http://qnighy.github.io/coqex2014/ex2.html

## 課題10 (種別:C / 締め切り : 2014/05/04)

次の定理を証明せよ。
*)

Parameter G : Set.
Parameter mult : G -> G -> G.
Notation "x * y" := (mult x y).
Parameter one : G.
Notation "1" := one.
Parameter inv : G -> G.
Notation "/ x" := (inv x).
(* Notation "x / y" := (mult x (inv y)). *) (* 使ってもよい *)

Axiom mult_assoc : forall x y z, x * (y * z) = (x * y) * z.
Axiom one_unit_l : forall x, 1 * x = x.
Axiom inv_l : forall x, / x * x = 1.

(*
証明の内容は、以下に忠実なものである。

[Coq][Math] From left unit and left inverse to right unit and inverse.

http://study-func-prog.blogspot.jp/2014/04/coqmath-from-left-unit-and-left-inverse.html
*)

Lemma inv_r : forall x, x * / x = 1.
Proof.
  move=> x.
  rewrite -{1}(one_unit_l x).
  rewrite -{1}(inv_l (inv x)).
  rewrite -[/ / x * / x * x]mult_assoc.
  rewrite (inv_l).
  rewrite -mult_assoc.
  rewrite one_unit_l.
  rewrite inv_l.
  by [].
Qed.

Lemma one_unit_r : forall x, x * 1 = x.
Proof.
  move=> x.
  rewrite -{1}(one_unit_l x).
  rewrite -{1}(inv_l (inv x)).
  rewrite -{1}(inv_l x).
  rewrite mult_assoc.
  rewrite -[/ / x * / x * x]mult_assoc.
  rewrite (inv_l).
  rewrite -mult_assoc.
  rewrite -mult_assoc.
  rewrite one_unit_l.
  rewrite mult_assoc.
  rewrite (inv_l (/ x)).
  by [].
Qed.

(* END *)