Parameter A : Prop.
Parameter E : Set.
Parameters x y : E.
Parameters P Q : E -> Prop.

(*Exercie 1*)

(*Q1*)

Goal (forall x : E, (P x) -> (Q x)) -> ((exists y : E, (P y)) -> (exists z : E, (Q z))).
Proof.
  intros.
  elim H0.
  intros.
  exists x0.
  apply H.
  assumption.
Qed.

(*Q2*)

Open Scope type_scope.
Section axioms.
Parameter o : Set.
Variables x y : Set.

Axiom Zero : x + o = x.
Axiom Sym : x + y = y + x.

End axioms. (*Insère les pour tout ds tt les axiomes*)

Goal forall x : Set, o + (x + o) = x.
Proof.
    intros.
    rewrite Sym.
    rewrite Zero.
    rewrite Zero.
    reflexivity.
Qed.

(*Exercie 2*)

Require Import Arith.
Require Import Lia.
Require Export List.
Open Scope list_scope.
Import ListNotations.

(*Question 1*)
Inductive is_even : nat -> Prop :=
| is_even_O : is_even 0
| is_even_pair : forall n : nat, is_even n -> is_even (S (S n)).

Inductive even_deer_list : list nat -> Prop :=
| even_deer_nil :  even_deer_list nil
| even_deer_one : forall a, is_even a -> even_deer_list [a]
| even_deer_many : forall a b l, is_even a -> is_even b -> a>=b -> even_deer_list (b::l) -> even_deer_list (a::(b::l)).

Goal even_deer_list [0].
Proof.
    apply even_deer_one.
    apply is_even_O.
Qed.

Goal even_deer_list[4;2;0].
Proof.
    apply even_deer_many.
    apply is_even_pair.
    apply is_even_pair.
    apply is_even_O.
    apply is_even_pair.
    apply is_even_O.
    lia.
    apply even_deer_many.
    apply is_even_pair.
    apply is_even_O.
    apply is_even_O.
    lia.
    apply even_deer_one.
    apply is_even_O.
Qed.


(* Mathematical Logic retake
   computer exercises

Your Name:

Your Neptun code:

It is enough to solve any THREE exercises.

*)

Require Import Classical.

Parameters P Q R S E U W: Prop.

Section exercise1a.
Hypothesis pr1: P /\ (Q /\ R).
Hypothesis pr2: (S /\ E) /\ U.
Hypothesis pr3: E -> W.
Goal (Q /\ P) /\ W.

(*Write your solution here.*)

Abort. (*You can replace Abort with Qed
         when finished with the proof.*)
End exercise1a.

Section exercise1b.
Hypothesis pr1: Q.
Hypothesis pr2: Q->P \/ R.
Hypothesis pr3: R->S.
Goal P\/S.

(*Write your solution here.*)

Abort.
End exercise1b.

Section exercise1c.
Hypothesis pr1: S->P.
Hypothesis pr2: Q -> E.
Goal (P->Q) -> (S->E).

(*Write your solution here.*)

Abort.
End exercise1c.

Section exercise1d.

Hypothesis pr1: (P \/ ~S) <-> (R /\ S ).
Hypothesis pr2: R->S.
Goal R -> P.

(*Write your solution here.*)

Abort.
End exercise1d.


Require Import Arith.

Fixpoint sum_odd(n:nat) : nat :=
  match n with
  | O => O
  | S m => 1 + m + m + sum_odd m
  end.

Goal forall n, sum_odd n = n * n.
Proof.
  intros.
  induction n.
  reflexivity.
  simpl.
  f_equal.
  rewrite mult_succ_r.
  rewrite plus_assoc.
  rewrite IHn.
  ring.

Qed.


Require Import Arith List Permutation Omega.
Require Import SortSpec.

Require Import Tactics.Crush.
Require Import Tactics.PermutationSolver.
Require Import Tactics.Tactics.

Module SelectSort <: Sorting.

(** Formalizing and proving selection sort based on dependent type
    and generic recursion. *)

(** The original idea is presented by Andrew Appel in OPLSS14, but his
    implementation was a little hacky, since the [selsort_aux] function only
    takes two parameters [l] and [n], but uses the assumption that
    [length l] = [n]. So I enhance his implementation by using dependent
    type and generic recursion, where we "encode" the proof of the
    equality in program. *)

(* The proof outline is very similar to quicksort. *)

Lemma Forall_Permutation :
  forall A (l l' : list A) P, Forall P l -> Permutation l l' -> Forall P l'.
Proof.
  intros. apply Forall_forall.
  intros. apply Permutation_sym in H0.
  eapply Permutation_in in H0; eauto.
  rewrite Forall_forall in H.
  apply H. apply H0.
Qed.

Definition AllLe (x : nat) (l : list nat) : Prop := Forall (fun y => x <= y) l.

Definition lengthOrder (l1 l2 : list nat) :=
  length l1 < length l2.

Lemma lengthOrder_wf' :
  forall len l, length l <= len -> Acc lengthOrder l.
Proof.
  unfold lengthOrder; induction len; intros; constructor; intros.
  + destruct l; crush.
  + apply IHlen; crush.
Qed.

(** [lengthOrder] is well-founded relation. *)
Theorem lengthOrder_wf : well_founded lengthOrder.
Proof.
  Hint Constructors Acc.
  unfold lengthOrder; intro; eapply lengthOrder_wf'; eauto.
Qed.

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

Lemma select_spec :
  forall l x h t,
    select x l = (h, t) -> AllLe h (x :: l) /\ Permutation (x :: l) (h :: t).
Proof.
  intro l; induction l; crush.
  - constructor; auto.
  - bdestruct (x <? a); crush.
    destruct (select x l) eqn:Hs; apply IHl in Hs; inversion H; crush.
    inversion H1; subst; repeat constructor; crush.
    destruct (select a l) eqn:Hs; apply IHl in Hs; inversion H; crush.
    inversion H1; subst; repeat constructor; crush.
  - bdestruct (x <? a); crush.
    destruct (select x l) eqn:Hs; apply IHl in Hs; inversion H; crush.
    permutation_solver.
    destruct (select a l) eqn:Hs; apply IHl in Hs; inversion H; crush.
    permutation_solver.
Qed.

Lemma select_spec' :
  forall l x h t,
    select x l = (h, t) -> AllLe h t /\ Permutation (x :: l) (h :: t).
Proof.
  intros; pose proof (select_spec l x h t H); crush.
  unfold AllLe in *.
  assert (Forall (fun y : nat => h <= y) (h :: t)).
  { eapply Forall_Permutation; eauto. }
  inversion H0; auto.
Qed.

Lemma select_len :
  forall l x h t,
    select x l = (h, t) -> length t = length l.
Proof.
  intros; pose proof (select_spec l x h t H); crush.
  apply Permutation_length in H2; crush.
Qed.

(* Use the idea of "convey pattern" mentioned by Adam Chlipala in
   http://coq-club.inria.narkive.com/Jz4riTaq/equations-from-match-case-unifiers-under-refine-tactic *)
Definition selsort : list nat -> list nat.
  refine (Fix lengthOrder_wf (fun _ => list nat)
    (fun (l : list nat) =>
      match l return (forall l' : list nat, lengthOrder l' l -> list nat) -> list nat with
      | nil => fun H => nil
      | h :: t =>
          fun (selsort : forall l' : list nat, lengthOrder l' (h :: t) -> list nat) =>
            fst (select h t) :: selsort (snd (select h t)) _
      end
	  )
	); unfold lengthOrder; destruct (select h t) eqn:H; pose proof (select_len t h n l0 H); crush.
Defined.

Theorem selsort_eq : forall l,
  selsort l =
    match l with
    | nil => nil
    | h :: t => fst (select h t) :: selsort (snd (select h t))
    end.
Proof.
  intros; destruct l;
  apply (Fix_eq lengthOrder_wf (fun _ => list nat)); auto; intros;
  destruct x; simpl; repeat f_equal; auto.
Qed.

Definition sort := selsort.

Example selsort_pi :
  sort [3; 1; 4; 1; 5; 9; 2; 6; 5; 3; 5] = [1; 1; 2; 3; 3; 4; 5; 5; 5; 6; 9].
Proof.
  repeat (rewrite selsort_eq; simpl).
  reflexivity.
Qed.

Theorem sort_algorithm : forall (l : list nat),
  Sorted (sort l) /\ Permutation l (sort l).
Proof.
  unfold sort.
  intros.
  apply (well_founded_ind lengthOrder_wf
    (fun l => Sorted (selsort l) /\ Permutation l (selsort l))
  ).
  intros; rewrite selsort_eq; destruct x; auto.
  destruct (select n x) eqn:Heq; simpl.
  pose proof (select_len x n n0 l0 Heq).
  assert (Hl: lengthOrder l0 (n :: x)). { unfold lengthOrder; crush. }
  pose proof (H l0 Hl).
  apply select_spec' in Heq; crush.
  assert (AllLe n0 (selsort l0)). { eapply Forall_Permutation; eauto. }
  destruct (selsort l0); auto.
  constructor; inversion H1; crush.
Qed.

End SelectSort.


Require Import ssreflect ssrbool ssrnat eqtype seq bigop.

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

Theorem sommation n : 2 * sumn (iota 1 n) = n * (n + 1).
Proof.
  elim: n => [//= | n IHn].
  (* rewrite -{1 3}[n.+1]addn1. *)
  rewrite -(addn1 n) iota_add /= sumn_cat !mulnDr IHn /= mulnC -!addnA.
  congr (_ + _).
  by rewrite muln0 !muln1 /= !add0n addn0 [RHS]addnA [RHS]addnC [n + 1]addnC.
Qed.


From LF Require Export Basics.

Theorem plus_n_O_firsttry : forall n:nat,
  n = n + 0.
Proof.
intros n.
induction n as [| n' IHn'].
- reflexivity.
- simpl. rewrite <- IHn'. reflexivity.
Qed.

Theorem minus_diag : forall n,
  minus n n = 0.
Proof.
intros n.
induction n as [| n' IHn'].
- reflexivity.
- simpl. rewrite <- IHn'. reflexivity.
Qed.

Theorem mult_0_r : forall n:nat,
  n * 0 = 0.
Proof.
intros n.
induction n as [| n' IHn'].
- reflexivity.
- simpl. rewrite -> IHn'. reflexivity.
Qed.

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

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

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

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

Theorem mult_comm : forall m n : nat,
  m * n = n * m.
Proof.
  intros m n.
  induction n as [| n IHn'].
  - simpl. rewrite -> mult_0_r. reflexivity.
  - induction m as [| m IHm'].
  -- simpl. rewrite -> mult_0_r. reflexivity.
  -- simpl. rewrite <- IHn'.


From mathcomp Require Import ssreflect.

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

Section Logic.

Lemma contrap : forall (A B:Prop),
  (A -> B) -> (~B -> ~A).
Proof.
  rewrite /not. (*定義を紐解く*)
  move=> A B AtoB notB.
  by move /AtoB.
Qed.

(*B に apply (A->B) をすると A になる*)
(*A->C に move /(A->B) をすると B->C になる*)

Variables A B C : Prop.

Lemma AndOrDistL : (A /\ C) \/ (B /\ C) <-> (A \/ B) /\ C.
Proof.
  rewrite /iff.
  apply: conj.
  -case.
   +case=> AisTrue CisTrue. (*case. move=> _ _*)
    by apply: conj; [apply: or_introl |]. (*apply conj. apply or_introl. by []*)
    case=> BisTrue CisTrue.
    by apply: conj; [apply: or_intror |].
  -case=> AorBisTrue CisTrue.
  (*move: AorBisTrue. case. move=> AisTrue. apply or_introl. by [].
  move=> BisTrue. apply or_intror. by [].*)
   case: AorBisTrue => [AisTrue | BisTrue].
   +by apply: or_introl.
   +by apply: or_intror.
Qed.

Inductive ex' (A:Type) (P:A -> Prop) : Prop :=
  ex_intro' : forall x:A, (P x -> ex' (A:=A) P).
Check ex_intro'.

Lemma JDM (T:Type) (P:T->Prop):
  ~(exists (x:T), P x) <-> forall x, ~(P x).
Proof.
  apply: conj => Hyp. (*apply:conj. move=> Hyp.*)
  -move=> x0 HPx0.
  apply: Hyp.
  (*Print ex.*)
  by apply: (ex_intro P x0).
  by case.
Qed.

Hypothesis ExMidLaw : forall P : Prop, P \/ ~P.

Lemma notnotEq (P : Prop): ~~P -> P.
Proof.
  move=> HnotnotP.
  move: (ExMidLaw (~P)).
  case.
  move=> /HnotnotP.
  by [].
  move: (ExMidLaw P).
  case. move=> H1 H2. apply H1.
  move=> H1.
  apply HnotnotP in H1.
  inversion H1.
Qed.

Search (_ /\ _).
From mathcomp Require Import ssrnat.
Search _ (_ + _ = _).

Locate and_comm.
Locate conj.
Locate "+".
Locate "^".
Locate "/\".

Section AxiomTest.

Variables Q : Prop.
Axiom a_axiom : Q.
Hypothesis a_hypo : Q.

End AxiomTest.

Check a_axiom.
(*Check AxiomTest.a_hypo.*)
End Logic.

Record magma : Type := Magma {
  carrier : Type ;
  operator : carrier -> carrier -> carrier
}.

Check magma.
Check Magma.

Definition prop_and_magma := Magma and.
Print prop_and_magma.
Definition nat_plus_magma := Magma plus.
Print nat_plus_magma.

Check (operator).
Lemma PropMagmaFalse (x y:carrier prop_and_magma) :
  (operator x False) -> y.

  Abort.

Record semigroup : Type := Semigroup {
  scarrier : magma ;
  assoc : forall a b c : carrier scarrier,
    operator a (operator b c)
    = operator (operator a b) c
}.

Check addnA. Check addn.
Locate "+".
Theorem plus_comm : forall (a b c : carrier nat_plus_magma),
  (operator a (operator b c))=operator (operator a b) c.
Proof.
  apply addnA.
Qed.

Canonical nat_plus_magma.
Definition nat_plus_semigroup := Semigroup
  addnA.

(* Definition nat_plus_semigroup := Semigroup
  plus_comm. *)

Notation "a ^ b" := (operator a b).
Canonical nat_plus_semigroup.
Lemma natPlusExample1 (x y z : carrier nat_plus_magma) :
  x ^ (y ^ z) = (x ^ y) ^ z.
Proof. by rewrite assoc. Qed.

From mathcomp Require Import ssrbool.

Check addbb. Check ssrfun.self_inverse.
Print addbb.
Locate "==>".

From mathcomp Require Import eqtype.

Print eqType.
About eqType.
Locate ".+4".
Eval simpl in (muln 3 4).
Compute (muln 3 4).
Check ex_minn.
Check pred nat.


Require Import MyTactics.
Require Import LCSyntax.
Require Import LCValues.
Require Import LCReduction.
Require Import STLCDefinition.

(*|
---------------------------
Renamings of term variables
---------------------------
|*)

(*|

The typing judgement is preserved by a renaming `xi` that maps
term variables to term variables. Note that `xi` need not be
injective.

|*)

Lemma jt_te_renaming:
  forall Gamma t U,
  jt Gamma t U ->
  forall Gamma' xi,
  Gamma = xi >>> Gamma' ->
  jt Gamma' t.[ren xi] U.
Proof.
  dup 2.
  {
    (* A detailed proof, where every case is dealt with explicitly: *)
    induction 1; intros; subst.
    (* JTVar *)
    { asimpl. econstructor. eauto. }
    (* JTLam *)
    { asimpl. econstructor. eapply IHjt. autosubst. }
    (* JTApp *)
    { asimpl. econstructor. eauto. eauto. }
    { asimpl. econstructor. }
    { asimpl. econstructor. eauto. }
    { asimpl. econstructor. eauto. eauto.
      eapply IHjt3. autosubst. }
  }
  (* A shorter script, where all cases are dealt with uniformly: *)
  induction 1; intros; subst; asimpl;
  econstructor; eauto with autosubst.
Qed.

(*|

As a corollary, `jt` is preserved by the renaming `(+1)`.

|*)

Lemma jt_te_renaming_0:
  forall Gamma t T U,
  jt Gamma t U ->
  jt (T .: Gamma) (lift 1 t) U.
Proof.
  intros. eapply jt_te_renaming. eauto. autosubst.
Qed.

(*|
-----------------------------------------
Substitutions of terms for term variables
-----------------------------------------
|*)

(*|

The typing judgement is extended to substitutions of terms for term
variables.

With respect to a type environment `Gamma`, a substitution `sigma` has
type `Delta` if and only if, for every variable `x`, the term `sigma
x` has type `Delta x`.

This auxiliary judgement encourages us to think of terms of *total*
substitutions, where *every* variable is replaced by a term. This
concept turns out to be easier to understand and manipulate,
especially during proofs by induction. Of course one always later
consider the special case of a substitution that seems to affect just
one variable, say variable 0. (In reality, such a substitution affects
all variables, as the variables other than 0 are renumbered.)

|*)

Definition js Gamma sigma Delta :=
  forall x : var,
  jt Gamma (sigma x) (Delta x).

(*|

The following are basic lemmas about `js`.

The identity substitution has type `Gamma` in environment `Gamma`.

|*)

Lemma js_ids:
  forall Gamma,
  js Gamma ids Gamma.
Proof.
  unfold js. eauto with jt.
Qed.

(*|

The typing judgement `js` behaves like an infinite list of typing judgements
`jt`. So, one can prepend one more `jt` judgement in front of it.

|*)

Lemma js_cons:
  forall Gamma t sigma T Delta,
  jt Gamma t T ->
  js Gamma sigma Delta ->
  js Gamma (t .: sigma) (T .: Delta).
Proof.
  intros. intros [|x]; asimpl; eauto.
Qed.

(*|

The typing judgement `js` is preserved by the introduction of a new term
variable. That is, a typing judgement `js` can be pushed under a
lambda-abstraction.

|*)

Lemma js_up:
  forall Gamma sigma Delta T,
  js Gamma sigma Delta ->
  js (T .: Gamma) (up sigma) (T .: Delta).
Proof.
  intros. eapply js_cons.
  { eauto with jt. }
  { intro x. asimpl. eauto using jt_te_renaming_0. }
Qed.

(*|

The typing judgement is preserved by a well-typed substitution `sigma`
of (all) term variables to terms.

|*)

Lemma jt_te_substitution:
  forall Delta t U,
  jt Delta t U ->
  forall Gamma sigma,
  js Gamma sigma Delta ->
  jt Gamma t.[sigma] U.
Proof.
  (* A short script, where all cases are dealt with in the same way: *)
  induction 1; intros; subst; asimpl; eauto using js_up with jt.
  * econstructor; eauto.
    - eauto using js_up, IHjt3.
Qed.

(*|

As a corollary, the typing judgement is preserved by a well-typed
substitution of one term for one variable, namely variable 0.

This property is exploited in the proof of subject reduction, in the
case of beta-reduction.

|*)

Lemma jt_te_substitution_0:
  forall Gamma t1 t2 T U,
  jt (T .: Gamma) t1 U ->
  jt Gamma t2 T ->
  jt Gamma t1.[t2/] U.
Proof.
(*
  (* One can do the proof step by step as follows: *)
  intros. eapply jt_te_substitution.
  { eauto. }
  { eapply js_cons.
    { eauto. }
    { eapply js_ids. } }
  (* Of course one can also let Coq find the proof by itself: *)
  Restart.*) eauto using jt_te_substitution, js_ids, js_cons.
Qed.


(** * Logic: Logic in Coq *)

Require Export MoreCoq.

(** Coq's built-in logic is very small: the only primitives are
    [Inductive] definitions, universal quantification ([forall]), and
    implication ([->]), while all the other familiar logical
    connectives -- conjunction, disjunction, negation, existential
    quantification, even equality -- can be encoded using just these.

    This chapter explains the encodings and shows how the tactics
    we've seen can be used to carry out standard forms of logical
    reasoning involving these connectives. *)

(* ########################################################### *)
(** * Propositions *)

(** In previous chapters, we have seen many examples of factual
    claims (_propositions_) and ways of presenting evidence of their
    truth (_proofs_).  In particular, we have worked extensively with
    _equality propositions_ of the form [e1 = e2], with
    implications ([P -> Q]), and with quantified propositions
    ([forall x, P]).
*)

(** In Coq, the type of things that can (potentially)
    be proven is [Prop]. *)

(** Here is an example of a provable proposition: *)

Check (3 = 3).
(* ===> Prop *)

(** Here is an example of an unprovable proposition: *)

Check (forall (n:nat), n = 2).
(* ===> Prop *)

(** Recall that [Check] asks Coq to tell us the type of the indicated
  expression. *)

(* ########################################################### *)
(** * Proofs and Evidence *)

(** In Coq, propositions have the same status as other types, such as
    [nat].  Just as the natural numbers [0], [1], [2], etc. inhabit
    the type [nat], a Coq proposition [P] is inhabited by its
    _proofs_.  We will refer to such inhabitants as _proof term_ or
    _proof object_ or _evidence_ for the truth of [P].

    In Coq, when we state and then prove a lemma such as:

Lemma silly : 0 * 3 = 0.
Proof. reflexivity. Qed.

    the tactics we use within the [Proof]...[Qed] keywords tell Coq
    how to construct a proof term that inhabits the proposition.  In
    this case, the proposition [0 * 3 = 0] is justified by a
    combination of the _definition_ of [mult], which says that [0 * 3]
    _simplifies_ to just [0], and the _reflexive_ principle of
    equality, which says that [0 = 0].

*)

(** *** *)

Lemma silly : 0 * 3 = 0.
Proof. reflexivity. Qed.

(** We can see which proof term Coq constructs for a given Lemma by
using the [Print] directive: *)

Print silly.
(* ===> silly = eq_refl : 0 * 3 = 0 *)

(** Here, the [eq_refl] proof term witnesses the equality. (More on equality later!)*)

(** ** Implications _are_ functions *)

(** Just as we can implement natural number multiplication as a
function:

[
mult : nat -> nat -> nat
]

The _proof term_ for an implication [P -> Q] is a _function_ that takes evidence for [P] as input and produces evidence for [Q] as its output.
*)

Lemma silly_implication : (1 + 1) = 2  ->  0 * 3 = 0.
Proof. intros H. reflexivity. Qed.

(** We can see that the proof term for the above lemma is indeed a
function: *)

Print silly_implication.
(* ===> silly_implication = fun _ : 1 + 1 = 2 => eq_refl
     : 1 + 1 = 2 -> 0 * 3 = 0 *)

(** ** Defining Propositions *)

(** Just as we can create user-defined inductive types (like the
    lists, binary representations of natural numbers, etc., that we
    seen before), we can also create _user-defined_ propositions.

    Question: How do you define the meaning of a proposition?
*)

(** *** *)

(** The meaning of a proposition is given by _rules_ and _definitions_
    that say how to construct _evidence_ for the truth of the
    proposition from other evidence.

    - Typically, rules are defined _inductively_, just like any other datatype.

    - Sometimes a proposition is declared to be true without substantiating evidence.  Such propositions are called _axioms_.

    In this, and subsequence chapters, we'll see more about how these
    proof terms work in more detail.
*)

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

(** The logical conjunction of propositions [P] and [Q] can be
    represented using an [Inductive] definition with one
    constructor. *)

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

(** The intuition behind this definition is simple: to
    construct evidence for [and P Q], we must provide evidence
    for [P] and evidence for [Q].  More precisely:

    - [conj p q] can be taken as evidence for [and P Q] if [p]
      is evidence for [P] and [q] is evidence for [Q]; and

    - this is the _only_ way to give evidence for [and P Q] --
      that is, if someone gives us evidence for [and P Q], we
      know it must have the form [conj p q], where [p] is
      evidence for [P] and [q] is evidence for [Q].

   Since we'll be using conjunction a lot, let's introduce a more
   familiar-looking infix notation for it. *)

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

(** (The [type_scope] annotation tells Coq that this notation
    will be appearing in propositions, not values.) *)

(** Consider the "type" of the constructor [conj]: *)

Check conj.
(* ===>  forall P Q : Prop, P -> Q -> P /\ Q *)

(** Notice that it takes 4 inputs -- namely the propositions [P]
    and [Q] and evidence for [P] and [Q] -- and returns as output the
    evidence of [P /\ Q]. *)

(** ** "Introducing" Conjuctions *)
(** Besides the elegance of building everything up from a tiny
    foundation, what's nice about defining conjunction this way is
    that we can prove statements involving conjunction using the
    tactics that we already know.  For example, if the goal statement
    is a conjuction, we can prove it by applying the single
    constructor [conj], which (as can be seen from the type of [conj])
    solves the current goal and leaves the two parts of the
    conjunction as subgoals to be proved separately. *)

Theorem and_example :
  (0 = 0) /\ (4 = mult 2 2).
Proof.
  apply conj.
  Case "left". reflexivity.
  Case "right". reflexivity.  Qed.

(** Just for convenience, we can use the tactic [split] as a shorthand for
    [apply conj]. *)

Theorem and_example' :
  (0 = 0) /\ (4 = mult 2 2).
Proof.
  split.
    Case "left". reflexivity.
    Case "right". reflexivity.  Qed.

(** ** "Eliminating" conjunctions *)
(** Conversely, the [inversion] tactic can be used to take a
    conjunction hypothesis in the context, calculate what evidence
    must have been used to build it, and add variables representing
    this evidence to the proof context. *)

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

(** **** Exercise: 1 star, optional (proj2) *)
Theorem proj2 : forall P Q : Prop,
  P /\ Q -> Q.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

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

Theorem and_assoc : forall P Q R : Prop,
  P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R H.
  inversion H as [HP [HQ HR]].
(* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################### *)
(** * Iff *)

(** The handy "if and only if" connective is just the conjunction of
    two implications. *)

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

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

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

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

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

Theorem iff_refl : forall P : Prop,
  P <-> P.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem iff_trans : forall P Q R : Prop,
  (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
  (* FILL IN HERE *) Admitted.

(** Hint: If you have an iff hypothesis in the context, you can use
    [inversion] to break it into two separate implications.  (Think
    about why this works.) *)
(** [] *)

(** Some of Coq's tactics treat [iff] statements specially, thus
    avoiding the need for some low-level manipulation when reasoning
    with them.  In particular, [rewrite] can be used with [iff]
    statements, not just equalities. *)

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

(** ** Implementing Disjunction *)

(** Disjunction ("logical or") can also be defined as an
    inductive proposition. *)

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

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

(** Consider the "type" of the constructor [or_introl]: *)

Check or_introl.
(* ===>  forall P Q : Prop, P -> P \/ Q *)

(** It takes 3 inputs, namely the propositions [P], [Q] and
    evidence of [P], and returns, as output, the evidence of [P \/ Q].
    Next, look at the type of [or_intror]: *)

Check or_intror.
(* ===>  forall P Q : Prop, Q -> P \/ Q *)

(** It is like [or_introl] but it requires evidence of [Q]
    instead of evidence of [P]. *)

(** Intuitively, there are two ways of giving evidence for [P \/ Q]:

    - give evidence for [P] (and say that it is [P] you are giving
      evidence for -- this is the function of the [or_introl]
      constructor), or

    - give evidence for [Q], tagged with the [or_intror]
      constructor. *)

(** *** *)
(** Since [P \/ Q] has two constructors, doing [inversion] on a
    hypothesis of type [P \/ Q] yields two subgoals. *)

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

(** From here on, we'll use the shorthand tactics [left] and [right]
    in place of [apply or_introl] and [apply or_intror]. *)

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

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

(** **** Exercise: 2 stars (or_distributes_over_and_2) *)
Theorem or_distributes_over_and_2 : forall P Q R : Prop,
  (P \/ Q) /\ (P \/ R) -> P \/ (Q /\ R).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star, optional (or_distributes_over_and) *)
Theorem or_distributes_over_and : forall P Q R : Prop,
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

(** We've already seen several places where analogous structures
    can be found in Coq's computational ([Type]) and logical ([Prop])
    worlds.  Here is one more: the boolean operators [andb] and [orb]
    are clearly analogs of the logical connectives [/\] and [\/].
    This analogy can be made more precise by the following theorems,
    which show how to translate knowledge about [andb] and [orb]'s
    behaviors on certain inputs into propositional facts about those
    inputs. *)

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

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

(** **** Exercise: 2 stars, optional (bool_prop) *)
Theorem andb_false : forall b c,
  andb b c = false -> b = false \/ c = false.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem orb_prop : forall b c,
  orb b c = true -> b = true \/ c = true.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem orb_false_elim : forall b c,
  orb b c = false -> b = false /\ c = false.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################### *)
(** * Falsehood *)

(** Logical falsehood can be represented in Coq as an inductively
    defined proposition with no constructors. *)

Inductive False : Prop := .

(** Intuition: [False] is a proposition for which there is no way
    to give evidence. *)

(** Since [False] has no constructors, inverting an assumption
    of type [False] always yields zero subgoals, allowing us to
    immediately prove any goal. *)

Theorem False_implies_nonsense :
  False -> 2 + 2 = 5.
Proof.
  intros contra.
  inversion contra.  Qed.

(** How does this work? The [inversion] tactic breaks [contra] into
    each of its possible cases, and yields a subgoal for each case.
    As [contra] is evidence for [False], it has _no_ possible cases,
    hence, there are no possible subgoals and the proof is done. *)

(** *** *)
(** Conversely, the only way to prove [False] is if there is already
    something nonsensical or contradictory in the context: *)

Theorem nonsense_implies_False :
  2 + 2 = 5 -> False.
Proof.
  intros contra.
  inversion contra.  Qed.

(** Actually, since the proof of [False_implies_nonsense]
    doesn't actually have anything to do with the specific nonsensical
    thing being proved; it can easily be generalized to work for an
    arbitrary [P]: *)

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

(** The Latin _ex falso quodlibet_ means, literally, "from
    falsehood follows whatever you please."  This theorem is also
    known as the _principle of explosion_. *)

(* #################################################### *)
(** ** Truth *)

(** Since we have defined falsehood in Coq, one might wonder whether
    it is possible to define truth in the same way.  We can. *)

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

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

(** However, unlike [False], which we'll use extensively, [True] is
    used fairly rarely. By itself, it is trivial (and therefore
    uninteresting) to prove as a goal, and it carries no useful
    information as a hypothesis. But it can be useful when defining
    complex [Prop]s using conditionals, or as a parameter to
    higher-order [Prop]s. *)

(* #################################################### *)
(** * Negation *)

(** The logical complement of a proposition [P] is written [not
    P] or, for shorthand, [~P]: *)

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

(** The intuition is that, if [P] is not true, then anything at
    all (even [False]) follows from assuming [P]. *)

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

Check not.
(* ===> Prop -> Prop *)

(** It takes a little practice to get used to working with
    negation in Coq.  Even though you can see perfectly well why
    something is true, it can be a little hard at first to get things
    into the right configuration so that Coq can see it!  Here are
    proofs of a few familiar facts about negation to get you warmed
    up. *)

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

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

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

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

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

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

(** **** Exercise: 2 stars (contrapositive) *)
Theorem contrapositive : forall P Q : Prop,
  (P -> Q) -> (~Q -> ~P).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star (not_both_true_and_false) *)
Theorem not_both_true_and_false : forall P : Prop,
  ~ (P /\ ~P).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

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

(** *** Constructive logic *)
(** Note that some theorems that are true in classical logic are _not_
    provable in Coq's (constructive) logic.  E.g., let's look at how
    this proof gets stuck... *)

Theorem classic_double_neg : forall P : Prop,
  ~~P -> P.
Proof.
  (* WORKED IN CLASS *)
  intros P H. unfold not in H.
  (* But now what? There is no way to "invent" evidence for [~P]
     from evidence for [P]. *)
  Abort.

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

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

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

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

Theorem excluded_middle_irrefutable:  forall (P:Prop), ~ ~ (P \/ ~ P).
Proof.
  (* FILL IN HERE *) Admitted.

(* ########################################################## *)
(** ** Inequality *)

(** Saying [x <> y] is just the same as saying [~(x = y)]. *)

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

(** Since inequality involves a negation, it again requires
    a little practice to be able to work with it fluently.  Here
    is one very useful trick.  If you are trying to prove a goal
    that is nonsensical (e.g., the goal state is [false = true]),
    apply the lemma [ex_falso_quodlibet] to change the goal to
    [False].  This makes it easier to use assumptions of the form
    [~P] that are available in the context -- in particular,
    assumptions of the form [x<>y]. *)

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

(** *** *)

(** *** *)

(** *** *)

(** *** *)

(** *** *)

(** **** Exercise: 2 stars (false_beq_nat) *)
Theorem false_beq_nat : forall n m : nat,
     n <> m ->
     beq_nat n m = false.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

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

(* $Date: 2014-06-05 07:22:21 -0400 (Thu, 05 Jun 2014) $ *)


Load ch1_ref.

(* Chapter 1 Exercises *)
Section Chapter_1_Exercises.
  (* 1.1. Define Function Composition
          and show associativity *)
  Definition fc {A B C} (g : B -> C) (f : A -> B) : A -> C
    := (* fill in here... *) .
  Lemma fc_assoc {A B C D : Type}
    (* fill in full theorem statement here... *)
  .
  Proof. trivial. Qed. (* the proof should be trivial *)

  (* 1.2 Derive pair_recursion from fst/snd projections
         and    sigma_recursion from proj1/proj2 *)
  Definition pair_recursion_alt {A B}
             (C : Type)
             (g : A -> B -> C)
             (p : prod A B)
    : C
    := (* fill in here... *) .
  Definition sigma_recursion_alt {A B}
             (C : Type)
             (g : forall x : A, B x -> C)
             (p : exists x : A, B x )
    : C
    := (* fill in here... *) .

  (* 1.3 Derive pair_induction from fst/snd projedtions
         and    sigma_induction from proj1/proj2 *)
  Print uniq_prod. (* recall this lemma *)
  (* use the lemma, but not induction on pairs *)
  Definition pair_induction {A B}
             (C : (prod A B) -> Type)
             (g : forall (x:A) (y:B), (C (pair x y)))
             (x : prod A B)
    : C x
    := (* fill in here... *) .
  (* here's a similar lemma to use.
     use it, but not induction on dependent pairs *)
  Lemma uniq_sigma {A B}
        (x : exists a:A, B a)
    : { x.1 ; x.2 } = x.
  Proof. destruct x. trivial. Qed.
  Definition sigma_induction {A B}
             (C : (sigma x : A, B x) -> Type)
             (g : forall (a : A) (b : B a), C {a;b})
             (p : sigma x : A, B x )
    : C p
    := (* fill in here... *) .

  (* 1.4 Derive nat recursion from iteration *)
  Fixpoint iter (C:Type) (c0:C) (cs:C->C) (n:nat) : C
    := match n with
       | O   => c0
       | S n => cs (iter C c0 cs n)
       end.
  Definition nat_recursion_iter (C:Type) :
    C -> (nat -> C -> C) -> nat -> C
    := (* fill in here... *) .
  Lemma Def_Eq_nat_recursion {C:Type} {c0 cs} (n:nat)
    : (nat_recursion_iter C c0 cs O = c0) *
      (nat_recursion_iter C c0 cs (S n)
       =
       cs n (nat_recursion_iter C c0 cs n)).
  Proof.
    (* fill in here... *)
    (* Hint: I had to use 'assert' to claim a sub-lemma *)
    (* Hint: you can use the 'pose' tactic to name a subexpression *)
    (* Hint: the tactics 'fold' and 'unfold' help manage
             named expressions *)
  Qed.

  (* 1.5 Bool Sum *)
  Definition BSum (A B : UU) :=
    exists x:bool, bool_rect (fun y : bool => UU) A B x.
  Definition Binl {A B} (a:A) : BSum A B := {true ; a}.
  Definition Binr {A B} (b:B) : BSum A B := {false ; b}.
  Definition BSum_induction {A B}
             (C : BSum A B -> UU)
             (f : forall a:A, C (Binl a))
             (g : forall b:B, C (Binr b))
             (x : BSum A B)
    : C x
    := (* fill in here... *) (* use sig_rect *) .
  Lemma DefEq_BSum_induction {A B} {C f g} :
    (forall a:A, BSum_induction C f g (Binl a) = f a) *
    (forall b:B, BSum_induction C f g (Binr b) = g b).
  Proof. split; trivial. Qed. (* should verify trivially *)

  (* 1.6 Bool Prod *)
  Definition BProd (A B : UU) :=
    forall x:bool, bool_rect (fun x:bool => UU) A B x.
  Definition Bpair {A B} (a : A) (b : B) : BProd A B :=
    fun x:bool => match x with
      | false => a
      | true  => b
    end.
  Axiom funext :
    forall (A : Type) (B : A -> Type)
           (f g : forall x:A, B x),
    (forall x : A, (f x) = (g x)) -> f = g.
  Definition Bfst {A B} (x : BProd A B) : A := x true.
  Definition Bsnd {A B} (x : BProd A B) : B := x false.
  Definition uniq_BProd {A B} {x : BProd A B}
    : Bpair (Bfst x) (Bsnd x) = x
    := (* fill in here... *) .
  Definition BProd_induction {A B}
             (C : BProd A B -> Type)
             (f : forall (a:A) (b:B), C (Bpair a b))
             (x : BProd A B)
    : C x
    := (* fill in here... *) .
  (* I skipped over this one *)
  (*Lemma DefEq_BProd_induction {A B} {C g} :
    forall (a:A) (b:B),
      BProd_induction C g (Bpair a b) = g a b.*)

  (* 1.7 Alternative Path Induction *)
    (* skipping *)

  (* 1.8 Multiplication and Exponentiation of nat;
         (nat, +, 0, *, 1) is a semi-ring *)
    (* define using nat_recursion *)
  Definition times (x y : nat) : nat :=
    (* fill in here... *) .
  Definition exp   (x y : nat) : nat :=
    (* fill in here... *) .

  Definition is_a_semiring (A : Type) :=
    exists
      (plus        : A -> A -> A)
      (zero        : A)
      (times       : A -> A -> A)
      (one         : A)
      (* fill in properties here... *)
      (plus_assoc  : (*...*) )

    , unit.

  (* this tactic helps name properties in the proof *)
  Ltac show_exists nm := match goal with
                         | |- exists (_ : ?T), _ =>
                           assert T as nm; [ | exists nm]
                         end.

  Theorem nat_is_a_semiring :
    is_a_semiring nat.
  Proof. (* fill in here... *)
    unfold is_a_semiring.
    exists plus.
    exists 0.
    exists times.
    exists 1.
    show_exists plus_assoc.
  Defined.

  (* 1.9 Define the type family Fin *)
    (* unsure how to do this *)

  (* 1.11 Triple not is constructively just not *)
  Definition intro_double_not {A:Prop} : A -> ~~A :=
    (* fill in here... *) .
  Definition triple_not {A:Prop} : ~~~A -> ~A :=
    (* fill in here... *) .

  (* 1.12 More Simple Logic Problems as Types *)
  Definition if_a_then_if_b_then_a {A B}
    : A -> (B -> A)
    := (* fill in here... *) .
  Definition if_not_a_or_not_b_then_not_a_and_b {A B}
    : ((~A) + (~B))%type -> ~(A * B)%type
    := (* fill in here... *) .

  (* 1.13 Not Not Excluded Middle *)
  Definition not_not_excluded_middle {P} :
    ~~(P + ~P)%type
    := (* fill in here... *) .

  (* 1.14 *)
    (* skipping for now; no formal work? *)

  (* 1.15 indiscernability from path induction *)
    (* see inline earlier *)

  (* 1.16 commutativity of addition of natural numbers *)
  Lemma nat_commutativity :
    forall i j : nat, i+j = j+i.
  Proof. (* fill in here... *)
  Qed.
End Chapter_1_Exercises.


Require Import Bool Arith Coq.Arith.Div2 List.
Require Import BellantoniCook.Lib.

Notation bs := (list bool).

Definition unary (v : bs) := forallb id v.

(** * Boolean interpretation of bitstrings *)

Definition bs2bool (v:bs) : bool := hd false v.

Definition bool2bs (b:bool) : bs :=
  if b then true::nil else nil.

Lemma bs_nat2bool_true : forall v,
  bs2bool v = true -> length v <> 0.
Proof.
 intro v; case v; simpl; auto; intros; discriminate.
Qed.

Lemma bs_nat2bool_true_conv : forall v,
  unary v = true ->
  length v <> 0 -> bs2bool v = true.
Proof.
 intro v; case v; simpl; intros.
 elim H0; trivial.
 rewrite andb_true_iff in H.
 decompose [and] H; destruct b; trivial.
Qed.

Lemma bs_nat2bool_false v :
  unary v = true ->
  bs2bool v = false -> length v = 0.
Proof.
 destruct v; simpl; trivial; intros.
 rewrite andb_true_iff in H.
 decompose [and] H; destruct b; discriminate.
Qed.

Lemma bs_nat2bool_false_conv v :
  length v = 0 ->
  bs2bool v = false.
Proof.
 destruct v; simpl; trivial; intros.
 discriminate.
Qed.

(** * Binary interpretation of bitstrings *)

Fixpoint bs2nat (v:bs) : nat :=
  match v with
  | nil => 0
  | false :: v' => 2 * bs2nat v'
  | true  :: v' => S (2 * bs2nat v')
  end.

Fixpoint succ_bs (v : bs) : bs :=
  match v with
    | nil => [true]
    | false :: v' => true :: v'
    | true :: v' => false :: succ_bs v'
  end.

Lemma succ_bs_correct v : bs2nat (succ_bs v) = bs2nat v + 1.
Proof.
 induction v; simpl; trivial; case a; simpl; ring [IHv].
Qed.

Fixpoint nat2bs (n:nat) : bs :=
  match n with
  | 0 => nil
  | S n' => succ_bs (nat2bs n')
  end.

Lemma bs2nat_nil :
  bs2nat nil = 0.
Proof. trivial. Qed.

Lemma bs2nat_false v :
  bs2nat (false :: v) = 2 * bs2nat v.
Proof. trivial. Qed.

Lemma bs2nat_true v :
  bs2nat (true :: v) = 1 + 2 * bs2nat v.
Proof. trivial. Qed.

Lemma bs2nat_tl : forall v, bs2nat (tl v) = div2 (bs2nat v).
Proof.
 destruct v; simpl; [ trivial | ].
 replace (bs2nat v + (bs2nat v + 0)) with (2 * bs2nat v) by omega.
 case b;[ rewrite div2_double_plus_one | rewrite div2_double]; trivial.
Qed.

Lemma bs2nat_nat2bs : forall n, bs2nat (nat2bs n) = n.
Proof.
 induction n as [ | n' IHn]; simpl; auto.
 rewrite succ_bs_correct; ring [IHn].
Qed.


(** Calculation of the simple arithmetic language. *)

Require Import List.
Require Import Tactics.

(** * Syntax *)

Inductive Expr : Set :=
| Val : nat -> Expr
| Add : Expr -> Expr -> Expr.

(** * Semantics *)

Fixpoint eval (x: Expr) : nat :=
  match x with
    | Val n => n
    | Add x1 x2 => eval x1 + eval x2
  end.

(** * Compiler *)

Inductive Code : Set :=
| PUSH : nat -> Code -> Code
| ADD : Code -> Code
| HALT : Code.

Fixpoint comp' (x : Expr) (c : Code) : Code :=
  match x with
    | Val n => PUSH n c
    | Add x1 x2 => comp' x1 (comp' x2 (ADD c))
  end.

Definition comp (x : Expr) : Code := comp' x HALT.

(** * Virtual Machine *)

Definition Stack : Set := list nat.

Definition Conf : Set := prod Code  Stack.

Reserved Notation "x ==> y" (at level 80, no associativity).
Inductive VM : Conf -> Conf -> Prop :=
| vm_push n c s : (PUSH n c , s) ==> (c , n :: s)
| vm_add c s m n : (ADD c, m :: n :: s) ==> (c, (n + m) :: s)
where "x ==> y" := (VM x y).

(** * Calculation *)

(** Boilerplate to import calculation tactics *)

Module VM <: Preorder.
Definition Conf := Conf.
Definition VM := VM.
End VM.
Module VMCalc := Calculation VM.
Import VMCalc.

(** Specification of the compiler *)

Theorem spec x c s : (comp' x c, s) =>> (c , eval x :: s).

(** Setup the induction proof *)

Proof.
  intros.
  generalize dependent c.
  generalize dependent s.
  induction x;intros.

(** Calculation of the compiler *)

(** - [x = Val n]: *)

  begin
  (c, n :: s).
  <== { apply vm_push }
  (PUSH n c, s).
  [].

(** - [x = Add x1 x2]: *)

  begin
  (c, eval x1 + eval x2 :: s).
  <== { apply vm_add}
  (ADD c, eval x2 :: eval x1 :: s).
  <<= { apply IHx2}
  (comp' x2 (ADD c), eval x1 :: s).
  <<= { apply IHx1}
  (comp' x1 (comp' x2 (ADD c)), s).
  [].
Qed.

(** * Soundness *)

(** Since the VM is defined as a small step operational semantics, we
have to prove that the VM is deterministic and does not get stuck in
order to derive soundness from the above theorem. *)

Lemma determ_vm : determ VM.
  intros C C1 C2 V. induction V; intro V'; inversion V'; subst; reflexivity.
Qed.

Theorem sound x s C : (comp x, s) =>>! C -> C = (HALT , eval x :: s).
Proof.
  intros.
  pose (spec x HALT) as H'. unfold comp in *. pose (determ_trc determ_vm) as D.
  unfold determ in D. eapply D. apply H. split. apply H'. intro Contra. destruct Contra.
  inversion H0.
Qed.


(* The addition of the natural numbers is associative *)
Theorem plus_associates : forall n m p : nat, (n + m) + p = n + (m + p).
Proof.
  intros n m p.
  induction n as [| n' IHn].
    reflexivity.

    simpl.
    rewrite IHn.
    reflexivity.
Qed.


Structure Group : Type := const_kozos
{
A :> Set;

op : A -> A -> A ;
inv : A -> A ;
z : A ;

op_assoc : forall a b c, op a (op b c) = op (op a b) c;
op_z : forall a, op a z = a /\ op z a = a ;
op_inverse : forall a, op a (inv a) = z /\ op (inv a) a = z
}.

Inductive Z6 : Set :=
|z0 : Z6
|z1 : Z6
|z2 : Z6
|z3 : Z6
|z4 : Z6
|z5 : Z6.

Definition Z6_succ (x:Z6) : Z6 :=
match x with
| z0 => z1
| z1 => z2
| z2 => z3
| z3 => z4
| z4 => z5
| z5 => z0
end.

Definition Z6_add (x : Z6) (y : Z6) : Z6 :=
match x with
|z0 => y
|z1 => Z6_succ y
|z2 => Z6_succ (Z6_succ y)
|z3 => Z6_succ (Z6_succ (Z6_succ y))
|z4 => Z6_succ (Z6_succ (Z6_succ (Z6_succ y)))
|z5 => Z6_succ (Z6_succ (Z6_succ (Z6_succ (Z6_succ y))))
end.

Definition Z6_inv (x:Z6) : Z6 :=
match x with
| z0 => z0
| z1 => z5
| z2 => z4
| z3 => z3
| z4 => z2
| z5 => z1
end.

Theorem Z6_group : Group.
Proof.
  apply (const_kozos Z6 Z6_add Z6_inv z0).
  induction a,b,c ; auto.
  induction a; auto.
  induction a; auto.
  Show Proof.
Defined.


Require Export P01.

(** Complete the definitions of the following functions. Make sure
    that the corresponding unit tests pass by proving them with
    [reflexivity]. *)

(** Successor of a natural number: *)

Print c_nat.

Definition c_succ (n : c_nat) : c_nat  :=
  fun (X : Type) (f : X -> X) (x : X) => f (n X f x).

Example c_succ_1 : c_succ c_zero = c_one.
Proof. reflexivity. Qed.

Example c_succ_2 : c_succ c_one = c_two.
Proof. reflexivity. Qed.

Example c_succ_3 : c_succ c_two = c_three.
Proof. reflexivity. Qed.


Theorem DeMorgan1 : forall P Q : Prop, ~P \/ ~Q -> ~(P /\ Q).
Proof.
  intros.
  intro.
  destruct H as [ H1 | H2 ].
  absurd P.
  assumption.
  apply H0.
  absurd Q.
  assumption.
  apply H0.
Qed.

Theorem DeMorgan2 : forall P Q : Prop, ~P /\ ~Q -> ~(P \/ Q).
Proof.
  intros.
  intro.
  destruct H0 as [ H1 | H2 ].
  absurd P.
  apply H.
  assumption.
  absurd Q.
  apply H.
  assumption.
Qed.

Theorem DeMorgan3 : forall P Q : Prop, ~(P \/ Q) -> ~P /\ ~Q.
Proof.
  intros.
  split.
  intro.
  absurd (P \/ Q).
  assumption.
  left.
  assumption.
  intro.
  absurd (P \/ Q).
  assumption.
  right.
  assumption.
Qed.


Require Import Arith.
Require Import NatMisc.
Require Import DecidableEquivalences.
Require Import Fin.
Require Import Vector.
Require Import FinVectorMisc.
Import VectorNotations.
Require Import SigmaMisc.
Require Import NotationsMisc.
Require Import DPF.
From Equations Require Import Equations.
Set Equations Transparent.
Unset Equations WithK.

(** Equivalence relations on {0,1,...,n-1} **)

(* To build a type of all equivalence relations on {0,1,...,n-1}, just
   describe the process of putting elements into their classes one by one:

   - start with an empty list of classes
   - assuming {0,1,...,n-1} have been put into classes already, either
     + the element n is not related to any of the lower elements,
       thus forming a new class, or
     + n belongs to one of the existing classes.

   This translates into an inductive type family indexed by the number
   of elements and the number of classes: *)

Inductive ER : nat -> nat -> Type :=
  | EREmpty             :                      ER O O
  | ERNew   {n c : nat} :            ER n c -> ER (S n) (S c)
  | ERPut   {n c : nat} : Fin.t c -> ER n c -> ER (S n) c.

Notation "#"        :=  EREmpty.
Notation "'+>' e"   := (ERNew e)   (at level 70).
Notation "x '>>' e" := (ERPut x e) (at level 69, right associativity).

(* Notes
   - unfortunately, [+>] and [>>]  cannot be used in patterns
     of "Equations", this seems to be a limitation of the library itself
   - Formerly, to be consistent with the explanation above, we interpreted
     the largest or last element in Fin.t (S n) as the "new" element to be
     placed into a class. As a consequence, instead of matching against F1 and
     FS, we had to match against "last" and "previous", which became incon-
     venient. So now, in [ERNew e] and [ERPut t e], we interpret e as an
     equivalence on {FS F1, ...} and F1 as the "new" element to be put into
     a new class or in class t, respectively.
*)

(* the type of all equivalence relations on {0,...,n-1} becomes: *)
Definition EqR (n : nat) : Type := { c : nat & ER n c }.

(* the embedding of [ER n c] into [EqR n] *)
Definition erEqr {n c : nat} (e : ER n c) : EqR n := {| c ; e |}.

(* since we have [EqDec] for [nat] and [Fin.t], [EqDec] for [ER] is derivable *)
Derive EqDec for ER.

(* and thus we also have UIP *)
Equations uipER {n c : nat} {e1 : ER n c} (eq : e1 = e1) : eq = eq_refl :=
  uipER eq_refl := eq_refl.

(* derive wellfounded subterm relation for wf recursion *)
Derive Signature Subterm for ER.

(** special equivalence relations **)

(* the identity relation *)
Equations idER {n : nat} : ER n n :=
  idER {n:=O}     := #;
  idER {n:=(S m)} := +> idER.

Definition idEqr {n : nat} : EqR n := {| n ; idER |}.

(* the all relation *)
Equations allER {n : nat} : ER (S n) 1 :=
  allER {n:=O}     := +> # ;
  allER {n:=(S m)} := F1 >> allER.

Equations allEqr {n : nat} : EqR n :=
  allEqr {n:=0}     := {| 0 ; # |};
  allEqr {n:=(S _)} := {| 1 ; allER  |}.

(** elementary properties of [ER] **)

(* any element of [ER 0 0] is equal to EREmpty *)
Equations er00Empty (e : ER 0 0) : e = # :=
  er00Empty # := eq_refl.

Hint Rewrite @er00Empty : eqr.

(* if [ER n c] is inhabited, then [c <= n] *)
Equations erCLeN {n c : nat} (e : ER n c) : c <= n :=
  erCLeN  #          := @le_n 0;
  erCLeN (ERNew e)   := leNS (erCLeN e);
  erCLeN (ERPut t e) := le_S _ _ (erCLeN e).

(* [idER n] is the only element of [ER n n] *)
Equations ernnIdER {n : nat} (e : ER n n) : e = idER :=
  ernnIdER {n:=0}      #          := eq_refl;
  ernnIdER {n:=(S _)} (ERNew e)   := f_equal ERNew (ernnIdER e);
  ernnIdER {n:=(S _)} (ERPut t e) := False_rect _ (nleSuccDiagL _ (erCLeN e)).

Hint Rewrite @ernnIdER : eqr.

(* any equivalence relation with only one class is [allER] *)
Equations ern1AllER {n : nat} (e : ER (S n) 1) : e = allER :=
  ern1AllER {n:=0}     (ERNew #)           :=  eq_refl;
  ern1AllER {n:=(S _)} (ERNew (ERPut t _)) :=! t;
  ern1AllER {n:=(S _)} (ERPut F1 e)        :=  f_equal (ERPut F1) (ern1AllER e).

Hint Rewrite @ern1AllER : eqr.

(** elementary properties of [EqR] **)

(* the only element in [EqR] 0 is [idEqr] ( which is [{| 0 ; # |}]) *)
Equations eqr0Id (e : EqR 0) : e = idEqr :=
  eqr0Id {| 0 ; # |} := eq_refl.

Hint Rewrite @eqr0Id : eqr.

(** [erMap] **)

(* [erMap e] is the Vector of length [n], with the [e]-class of the [i]th
   element of [Fin.t n] at the [i]th position. I.e., it is the tabulation
   of the map sending an element to its equivalence class. *)
Equations erMap {n c : nat} (e : ER n c) : Vector.t (Fin.t c) n :=
  erMap  #          := [];
  erMap (ERNew e)   := F1 :: (map FS (erMap e));
  erMap (ERPut t e) := t  ::         (erMap e).

Notation "e '@v' t" := (Vector.nth (erMap e) t)
                       (at level 61, right associativity).

Hint Rewrite @nthMapLemma : eqr.
Obligation Tactic := repeat (simp eqr || program_simpl).

(* computation lemmata for [@v] *)

Equations erMapNewF1 {n c : nat} (e : ER n c) :
                     (+> e) @v F1 = F1 :=
  erMapNewF1 _ := _.
Hint Rewrite @erMapNewF1 : eqr.

Equations erMapNewFS {n c : nat} (e : ER n c) (y : Fin.t n) :
                     (ERNew e) @v (FS y) = FS (e @v y) :=
  erMapNewFS _ _ := _.
Hint Rewrite @erMapNewFS : eqr.

Equations erMapPutF1 {n c : nat} (e : ER n c) (t : Fin.t c) :
                     (t >> e) @v F1 = t :=
  erMapPutF1 _ _ := _.
Hint Rewrite @erMapPutF1 : eqr.

Equations erMapPutFS {n c : nat} (e : ER n c) (t : Fin.t c) (y : Fin.t n) :
                     (t >> e) @v (FS y) = (e @v y) :=
  erMapPutFS _ _ _ := _.
Hint Rewrite @erMapPutFS : eqr.

(** properties of [@v] **)

(* erMap of idER is the identity *)
Equations(noind) idERId {n : nat} (x : Fin.t n) : idER @v x = x :=
  idERId  F1     := _;
  idERId (FS x)  with (idERId x) := { | IH := _}.
Next Obligation. congruence. Defined.
Hint Rewrite @idERId : eqr.

(** erSection **)

(* [erSection e] maps each class to its largest representative
   (w.r.t. the order F1 < (FS F1) < ... *)
Equations erSection {n c : nat} (e : ER n c) : Vector.t (Fin.t n) c :=
  erSection  #          := [];
  erSection (ERNew e)   := F1 :: (map FS (erSection e));
  erSection (ERPut _ e) :=       (map FS (erSection e)).

Notation "e '@^' cl" := (Vector.nth (erSection e) cl)
                        (at level 61, right associativity).

(* computation lemmata for [@^] *)

Equations erSectionNewF1 {n c : nat} (e : ER n c) :
                         (+>e) @^ F1 = F1 :=
  erSectionNewF1 _ := _.
Hint Rewrite @erSectionNewF1 : eqr.

Equations erSectionNewFS {n c : nat} (e : ER n c) (y : Fin.t c) :
                         (+>e) @^ (FS y) = FS (e @^ y) :=
  erSectionNewFS _ _ := _.
Hint Rewrite @erSectionNewFS : eqr.

Equations erSectionPut {n c : nat} (e : ER n c) (t x : Fin.t c) :
                       (t >> e) @^ x = FS (e @^ x) :=
  erSectionPut _ _ _ := _.
Hint Rewrite @erSectionPut   : eqr.

(* [erSection e] is a section of [erMap e] *)
Lemma erSectionIsSection {n c : nat} (e : ER n c) (y : Fin.t c) :
                          e @v e @^ y = y.
Proof. induction e; dependent destruction y; simp eqr; congruence.
Defined.
Hint Rewrite @erSectionIsSection : eqr.

(* thus it is injective *)
(* we write this as an iff so that simp eqr can use it for rewrites ... *)

Lemma erSectionIsInjective {n c : nat} (e : ER n c) (y1 y2 : Fin.t c) :
                           e @^ y1 = e @^ y2 <-> y1 = y2.
Proof.
  split; intro eq.
  + pose (f_equal (fun y => e @v y) eq) as eq'; simpl in eq'; simp eqr in eq'.
  + congruence.
Defined.
Hint Rewrite @erSectionIsInjective : eqr.

(* idER @^ also acts the identity. *)
Equations(noind) idERSId {n : nat} (x : Fin.t n) : idER @^ x = x :=
  idERSId  F1     := _;
  idERSId (FS x)  with (idERSId x) := { | IH := _}.
Next Obligation. congruence. Defined.
Hint Rewrite @idERSId : eqr.

(** [erClassMax] **)

(* [erMap e] followed by [erSection e] maps an element to the largest element
   in its equivalence class *)
Definition erClassMax {n c : nat} (e : ER n c) :
                       Vector.t (Fin.t n) n :=
  Vector.map (fun x => e @^ x) (erMap e).
Notation "e '@>' x" := (Vector.nth (erClassMax e) x)
                       (at level 61, right associativity).

(* [e @>] is [e @v] followed by [e @^] *)
Equations erClassMaxExpand {n c : nat} (e : ER n c) (x : Fin.t n) :
                           e @> x = e @^ e @v x :=
  erClassMaxExpand _ _ := _.
Hint Rewrite @erClassMaxExpand : eqr.

(* [e @>] is idempotent *)
Lemma erClassMaxIsIdempotent {n c : nat} (e : ER n c) (x : Fin.t n) :
                              e @> e @> x = e @> x.
Proof. simp eqr. Defined.
Hint Rewrite @erClassMaxIsIdempotent : eqr.

(* computation lemmata for [@>] *)

Equations erClassMaxNewF1 {n c : nat} (e : ER n c) :
                          (+>e) @> F1 = F1 :=
  erClassMaxNewF1 _ := _.
Hint Rewrite @erClassMaxNewF1 : eqr.

Equations erClassMaxNewFS {n c : nat} (e : ER n c) (y : Fin.t n) :
                          (+>e) @> (FS y) = FS ( e @> y ) :=
  erClassMaxNewFS _ _ := _.
Hint Rewrite @erClassMaxNewFS : eqr.

Equations erClassMaxPutF1 {n c : nat} (e : ER n c) (t : Fin.t c) :
                          (t >> e) @> F1 = FS (e @^ t) :=
  erClassMaxPutF1 _ _ := _.
Hint Rewrite @erClassMaxPutF1 : eqr.

Equations erClassMaxPutFS {n c : nat} (e : ER n c) (t : Fin.t c) (x : Fin.t n) :
                          (t >> e) @> (FS x) = FS (e @> x) :=
  erClassMaxPutFS _ _ _ := _.
Hint Rewrite @erClassMaxPutFS : eqr.

(** [eqrClassMax] **)

(* the result type of [erClassMax e] is not dependent on c, so we can define *)
Definition eqrClassMax {n : nat} (e : EqR n) :
                        Vector.t (Fin.t n) n :=
  erClassMax (e.2).
Notation "e '@@' x" := (Vector.nth (eqrClassMax e) x)
                       (at level 61, right associativity).

(* trivial computation lemma for [@@] *)
Equations eqrClassMaxCompute {n c : nat} (e : ER n c) (x : Fin.t n) :
                             {| c ; e |} @@ x = e @> x :=
  eqrClassMaxCompute _ _ := _.
Hint Rewrite @eqrClassMaxCompute : eqr.

(* [e @@] is idempotent *)
Equations eqrClassMaxIsIdempotent {n : nat} (e : EqR n) (x : Fin.t n) :
                                  e @@ e @@ x = e @@ x :=
  eqrClassMaxIsIdempotent _ _ := _.
Hint Rewrite @eqrClassMaxIsIdempotent : eqr.

(* Restrict equivalence on [n+1] elements to the first [n] elements
   Just take the constructor argument of the 2nd component and repack it.
   Needed only to shorten statements. *)

Equations eqrShrink {n : nat} (e : EqR (S n)) : EqR n :=
  eqrShrink {|_ ;   +> e |} := {|_ ; e |};
  eqrShrink {|_ ; _ >> e |} := {|_ ; e |}.

(* on the higher elements, [eqrShrink e] does "essentially the same" as [e] *)

Lemma eqrShrinkClassMax {n : nat} (e : EqR (S n)) (x : Fin.t n) :
                        FS ((eqrShrink e) @@ x) = e @@ (FS x).
Proof.
  destruct e as [k e]; dependent induction e; repeat (program_simpl || simp eqr).
Defined.
Hint Rewrite @eqrShrinkClassMax : eqr.

(* lift the constructors of ER to Eqr *)

Equations eqrNew {n : nat} (e : EqR n) : EqR (S n) :=
  eqrNew {|_; e |} := {|_; +> e |}.

Equations eqrPut {n : nat} (e : EqR n) (x : Fin.t e.1) : EqR (S n) :=
  eqrPut {|_; e |} x := {|_; x >> e |}.

(* useful in cases with [n : nat] and [x : Fin.t n] among the hypotheses *)
Ltac handleFinCase0 n := try (destruct n; [> apply Fin.case0; trivial | idtac]).

(* computation rules for @@ *)

Equations eqrMapNewF1 {n : nat} (e : EqR n) :
                      (eqrNew e) @@ F1 = F1 :=
  eqrMapNewF1 e := _.
Next Obligation. dependent destruction e; simp eqr. Defined.
Hint Rewrite @eqrMapNewF1 : eqr.

Equations eqrMapNewFS {n : nat} (e : EqR n) (y : Fin.t n) :
                      (eqrNew e) @@ (FS y) = FS (e @@ y) :=
  eqrMapNewFS e y := _.
Next Obligation. handleFinCase0 n. destruct e; simp eqr. Defined.
Hint Rewrite @eqrMapNewFS : eqr.

Lemma eqrNewShrink {n : nat} (e : EqR n) : eqrShrink (eqrNew e) = e.
Proof. destruct e; program_simpl. Defined.
Hint Rewrite @eqrNewShrink : eqr.

Lemma eqrPutShrink {n : nat} (e : EqR n) (x : Fin.t e.1) :
                   eqrShrink (eqrPut e x) = e.
Proof. destruct e; program_simpl. Defined.
Hint Rewrite @eqrNewShrink : eqr.

(* insert here eqrShrink and computation rules using it...
   also [idEqr @@] = identity function  *)

(** the decidable equivalence relation on [Fin.t n] defined by [e : EqR n] *)

(* The relation on [Fin.t n] defined by [e : EqR] is just the kernel of
   [eqrClassMax], i.e. the pullback of equality along [eqrClassMax].
   It is a decidable equivalence on [Fin.t n], as equality has this property
   and pullback preserves it.  *)

Definition eqrToDecEq {n : nat} (e : EqR n) :
                       DecidableEquivalence (Fin.t n) :=
  pullbackDecidableEquivalence (fun x => e @@ x) eqFinDecidableEquivalence.
Notation "x '~(' e ')~' y" := (relationOfDecidableEquivalence (eqrToDecEq e) x y)
                              (at level 62).

(* needed to shorten proofs *)

Lemma eqrToDecEqCompute {n : nat} (e : EqR n) (x y : Fin.t n) :
                        x ~(e)~ y  <-> e @@ x = e @@ y.
Proof. unfold eqrToDecEq; simpl; unfold pullbackRelation; reflexivity.
Defined.
Hint Rewrite @eqrToDecEqCompute : eqr.

(** composition **)

(* this operation is called composition since it corresponds to the
   composition of classMaps (see below). It is NOT what one usually
   calls the composition of relations, namely x ~(r ○ s)~ y  <=>
   ∃ z. x ~(r)~ z ∧ z ~(s)~ y  *)

Equations erCompose {n c d: nat} (e1 : ER n c) (e2 : ER c d) : ER n d :=
  erCompose  #             #            :=  #;
  erCompose (ERNew e1)    (ERNew e2)    :=            +> (erCompose e1 e2);
  erCompose (ERNew e1)    (ERPut t2 e2) :=         t2 >> (erCompose e1 e2);
  erCompose (ERPut t1 e1)  e2           := (e2 @v t1) >> (erCompose e1 e2).
Notation  "e1 '**' e2" := (@erCompose _ _ _ e1 e2)
                          (at level 60, right associativity).

(** properties of [erCompose] **)

(* [idER] is left unit for [**] *)
Equations idERLeft1 {n c : nat} (e : ER n c) : idER ** e = e :=
  idERLeft1   #          := eq_refl;
  idERLeft1  (ERNew e)   := f_equal  ERNew    (idERLeft1 e);
  idERLeft1  (ERPut t e) := f_equal (ERPut t) (idERLeft1 e).
Hint Rewrite @idERLeft1 : eqr.

(* [idER] is right unit for [**] *)
Equations idERRight1 {n c : nat} (e : ER n c) : e ** idER = e :=
idERRight1  #          :=  eq_refl;
idERRight1 (ERNew e)   := (f_equal ERNew (idERRight1 e));
idERRight1 (ERPut t e) :=
  (t >> e) ** idER
     ={ erCompose_equation_4 _ _ _ _ _ _ }=
  (idER @@ t) >> (e ** idER)
     ={ f_equal (fun s => s >> (e ** idER)) (idERId t) }=
  t >> (e ** idER)
     ={ f_equal (ERPut t) (idERRight1 e ) }=
  (t >> e) QED.
Hint Rewrite @idERRight1 : eqr.

(* postcomposing with [allER] maps to [allER] *)
Definition allERRight {n d : nat} (e : ER (S n) (S d)) : e ** allER = allER.
Proof. apply ern1AllER. Defined.
Hint Rewrite @allERRight : eqr.

Equations(noind) erMapCompose {n m l : nat} (e1 : ER n m) (e2 : ER m l)
                              (x : Fin.t n) :
                              (e1 ** e2) @v x = e2 @v (e1 @v x) :=
  erMapCompose {n:=0}      #            #             x          :=! x;
  erMapCompose {n:=(S _)} (ERNew e1)   (ERNew e2)     F1         := eq_refl;
  erMapCompose {n:=(S _)} (ERNew e1)   (ERNew e2)    (FS y)
                             with erMapCompose e1 e2 y := { | IH := _};
  erMapCompose {n:=(S _)} (ERNew e1)   (ERPut t2 e2)  F1         := _;
  erMapCompose {n:=(S _)} (ERNew e1)   (ERPut t2 e2) (FS y)
                             with erMapCompose e1 e2 y := { | IH := _};
  erMapCompose {n:=(S _)} (ERPut t1 e1) e2            F1         := _;
  erMapCompose {n:=(S _)} (ERPut t1 e1) e2           (FS y)
                             with erMapCompose e1 e2 y := { | IH := _}.
(* above typechecks, but takes between 2 and 3 minutes on 1.9GHz I3 *)
Hint Rewrite @erMapCompose : eqr.

(* [erSection] of [e1 ** e2] is composition of [erSection]s.
   Note the order! Typechecks, but takes 1 to 2 minutes on 1.9GHz I3... *)
Equations(noind) erSectionCompose {n m l : nat} (e1 : ER n m) (e2 : ER m l)
                                  (x : Fin.t l) :
                                  (e1 ** e2) @^ x = e1 @^ (e2 @^ x) :=
  erSectionCompose {n:=0}      #           #            x     :=! x;
  erSectionCompose {n:=(S _)} (ERNew e1)  (ERNew e2)    F1    := eq_refl;
  erSectionCompose {n:=(S _)} (ERNew e1)  (ERNew e2)   (FS y)
                                with erSectionCompose e1 e2 y := { | IH := _ };
  erSectionCompose {n:=(S _)} (ERNew e1)  (ERPut _ e2)  x
                                with erSectionCompose e1 e2 x := { | IH := _ };
  erSectionCompose {n:=(S _)} (ERPut _ e1) e2           x
                                with erSectionCompose e1 e2 x := { | IH := _ }.
Hint Rewrite @erSectionCompose : eqr.

(* giving explicit right hand sides doesn't help to speed things up ...
Equations(noind) erSectionCompose {n m l : nat} (e1 : ER n m) (e2 : ER m l)
                                  (x : Fin.t l) :
                                  (e1 ** e2) @^ x = e1 @^ (e2 @^ x) :=
  erSectionCompose {n:=0}      #           #            x     :=! x;
  erSectionCompose {n:=(S _)} (ERNew e1)  (ERNew e2)    F1    := eq_refl;
  erSectionCompose {n:=(S _)} (ERNew e1)  (ERNew e2)   (FS y)
                                with erSectionCompose e1 e2 y := {
     | IH := (+>e1 ** +>e2) @^ (FS y)
             ={ f_equal (fun e => e @^ (FS y))
                        (erCompose_equation_2 _ _ _ e1 e2) }=
             (+> (e1 ** e2)) @^ (FS y)
             ={ erSectionNewFS (e1 ** e2) y }=
             FS ((e1 ** e2) @^ y)
             ={ f_equal FS IH }=
             FS (e1 @^ (e2 @^ y))
             ={ eq_sym (erSectionNewFS e1 (e2 @^ y)) }=
             (+>e1) @^ (FS (e2 @^ y))
             ={ f_equal (fun x => (+>e1) @^ x)
                        (eq_sym (erSectionNewFS e2 y)) }=
             (+>e1) @^ (+>e2) @^ (FS y) QED                      };
  erSectionCompose {n:=(S _)} (ERNew e1)  (ERPut t e2)  x
                                with erSectionCompose e1 e2 x := {
     | IH := (+>e1 ** t>>e2) @^ x
             ={ f_equal (fun e => e @^ x)
                        (erCompose_equation_3 _ _ _ e1 t e2) }=
             (t >> (e1 ** e2)) @^ x
             ={ erSectionPut (e1 ** e2) t x }=
             FS ((e1 ** e2) @^ x)
             ={ f_equal FS IH }=
             FS (e1 @^ (e2 @^ x))
             ={ eq_sym (erSectionNewFS e1 (e2 @^ x)) }=
             (+>e1) @^ (FS (e2 @^ x))
             ={ f_equal (fun x => (+>e1) @^ x)
                        (eq_sym (erSectionPut e2 t x)) }=
             (+>e1) @^ (t>>e2) @^ x  QED                         };
  erSectionCompose {n:=(S _)} (ERPut t e1) e2           x
                                with erSectionCompose e1 e2 x := {
     | IH := (t>>e1 ** e2) @^ x
             ={ f_equal (fun e => e @^ x)
                        (erCompose_equation_4 _ _ _ t e1 e2) }=
             ((e2 @v t) >> (e1 ** e2)) @^ x
             ={ erSectionPut (e1 ** e2) (e2 @v t) x }=
             FS ((e1 ** e2) @^ x)
             ={ f_equal FS IH }=
             FS (e1 @^ (e2 @^ x))
             ={ eq_sym (erSectionPut e1 t (e2 @^ x)) }=
             (t>>e1) @^ e2 @^ x  QED                             }.
*)

(* [**] is associative *)

Lemma erComposeAssociative {n m l k : nat}
                           (e1 : ER n m) (e2 : ER m l) (e3 : ER l k) :
                           (e1 ** e2) ** e3 = e1 ** e2 ** e3.
Proof.
  funelim (e1 ** e2).
  - funelim (# ** e3); reflexivity.
  - funelim ((+> (e ** e0)) ** e3); simp eqr; rewrite H1; trivial.
  - repeat (simp eqr || program_simpl || intuition || rewrite H).
  - repeat (simp eqr || program_simpl || intuition || rewrite H).
Defined.

(** containment **)

(* [f] is contained in [e]
   <=> any equivalence class of [f] is contained in an equivalence class of [e],
   <=> the classes of [e] are unions of certain classes of [f],
   <=> there is an equivalence [d] on the set of classes of [f] s.t. the union
       of all classes of [f] in a class of [d] is a class of e ( ;-) ),
   <=> there exists [d] such that  [f ** d = e]  *)

Definition erContains {n m l : nat} (f: ER n m) (e: ER n l) : Type :=
                      { d : ER m l & f ** d = e }.
Notation "f '[='  e" := (erContains f e) (at level 50).

Definition eqrContains {n : nat} (f e : EqR n) : Type := f.2 [= e.2.
Notation "e 'C='  f" := (eqrContains e f) (at level 50).

(** properties of [[=] and [C=] **)

(* [[=] is Reflexive and Transitive *)
Definition erContainsReflexive {n m : nat} (e : ER n m) :
                               e [= e :=
  {| idER ; (idERRight1 e) |}.

Definition erContainsTransitive {n c1 c2 c3 : nat} (e1 : ER n c1)
                                (e2 : ER n c2) (e3 : ER n c3) :
                                (e1 [= e2) -> (e2 [= e3) -> (e1 [= e3).
Proof.
  intros [d1 eq1] [d2 eq2].
  exists (d1 ** d2).
  rewrite <- erComposeAssociative.
  program_simpl.
Defined.

(* [C=]  is a partial order i.e. reflexive, transitive and antisymmetric *)
Definition eqrContainsReflexive {n : nat} (e : EqR n) :
                                 e C= e := erContainsReflexive e.2.

Definition eqrContainsTransitive {n : nat} (e1 e2 e3 : EqR n) :
                                 (e1 C= e2) -> (e2 C= e3) -> (e1 C= e3).
Proof. apply erContainsTransitive. Defined.

Lemma eqrContainsAntiSymmetric {n : nat} (e1 e2 : EqR n) :
                               (e1 C= e2) -> (e2 C= e1) -> e1 = e2.
Proof.
  destruct e1 as [c1 e1]; destruct e2 as [c2 e2].
  intros [d1 eq1] [d2 eq2]; simpl in *.
  destruct (leAntiSymmetric _ _ (conj (erCLeN d2) (erCLeN d1))).
  rewrite (ernnIdER d1) in eq1.
  simp eqr in eq1; program_simpl.
Defined.

(* [idEqr] is minimal for [C=] *)
Equations idEqrMin {n : nat} (e : EqR n) : idEqr C= e :=
  idEqrMin {|_; e |} := {| e; idERLeft1 e |}.

(* [allEqr] is maximal for [C=] *)
Equations allEqrMax {n : nat} (e : EqR n) : e C= allEqr :=
  allEqrMax {n:=0}     {| 0 ; # |}      := eqrContainsReflexive _;
  allEqrMax {n:=(S _)} {| 0 ; t >> _ |} :=! t;
  allEqrMax {n:=(S _)} {|(S _); e |}    := {| allER ; allERRight e |}.

(** [eqrToDecEq] preserves and reflects containment **)

(* rewrite to expand definition of [c=] ... just to shorten proofs *)
Lemma eqrToDecEqContainsRewrite {n : nat} (e f : EqR n) :
                  (eqrToDecEq e) c= (eqrToDecEq f) <->
                  (forall x y : Fin.t n, e @@ x = e @@ y -> f @@ x = f @@ y).
Proof.
  unfold "c=", Relations_1.contains, eqrToDecEq, pullbackDecidableEquivalence,
         pullbackRelation; reflexivity.
Defined.

Hint Rewrite @eqrToDecEqContainsRewrite :eqr .

(* containment is preserved by [eqrToDecEq] *)
Lemma eqrToDecEqPreservesContains {n : nat} (e f : EqR n) (p : e C= f) :
                                  (eqrToDecEq e) c= (eqrToDecEq f).
Proof.
  destruct e as [c e], f as [d f], p as [g eq]; simpl in *; simp eqr.
  intros x y; simp eqr; intro.
  repeat rewrite <- eq; simp eqr; program_simpl.
Defined.

(* to show that [eqrToDec] also reflects containment, we first show that
   [(eqrToDecEq e) c= (eqrToDecEq f)]  is equivalent to have
   [(e @@ x) ~(f)~ x]  for any [x]  *)

Definition eqrMaxMapCondition {n : nat} (e f : EqR n) : Prop :=
  forall (x : Fin.t n), (e @@ x) ~(f)~ x.

Lemma eqrMaxMapConditionIffEqrToDecEqContains
                  {n : nat} (e f : EqR n) :
                  eqrMaxMapCondition e f <-> (eqrToDecEq e) c= (eqrToDecEq f).
Proof.
  destruct e as [k e], f as [l f]; split; simp eqr.
  + congruence.
  + unfold eqrMaxMapCondition; intros ec x.
    apply ec.
    apply eqrClassMaxIsIdempotent.
Defined.

(* If [e C= f], [eqrMaxMapCondition e f] holds *)
Lemma eqrContainsToEqrMaxMapCondition
                          {n : nat} (e f : EqR n) (cont: e C= f) :
                          eqrMaxMapCondition e f.
Proof.
  intro x; handleFinCase0 n.
  simp eqr.
  destruct e as [c1 e], f as [c3 f], cont as [c eq]; simpl in *.
  rewrite <- eq.
  simp eqr.
Defined.

(* that [eqrMaxMapCondition e f] implies [e C= f] is a little more difficult *)

Lemma eqrShrinkPreservesEqrMaxMapCondition
                        {n : nat} (e f : EqR (S n))
                        (emms : eqrMaxMapCondition e f) :
                        eqrMaxMapCondition (eqrShrink e) (eqrShrink f).
Proof.
  unfold eqrMaxMapCondition, eqrToDecEq in *; simpl in *;
  unfold pullbackRelation in *.
  intro x.
  apply FS_inj.
  repeat rewrite eqrShrinkClassMax.
  apply emms.
Defined.

(* [eqrShrink] preserves containment *)

Equations eqrShrinkPreservesContains {n : nat} (e f : EqR (S n)) (p : e C= f) :
                                     (eqrShrink e) C= (eqrShrink f) :=
  eqrShrinkPreservesContains {|_;+>_|}  {|_;+>_ |} {|+>d ;eq|} := {|d;sigmaNat2 _|};
  eqrShrinkPreservesContains {|_;+>_|}  {|_;+>_ |} {|_>>_;eq|} :=! eq;
  eqrShrinkPreservesContains {|_;+>_|}  {|_;t>>_|} {|+>_ ;eq|} :=! eq;
  eqrShrinkPreservesContains {|_;+>_|}  {|_;t>>_|} {|_>>d;eq|} := {|d;sigmaNat2 _|};
  eqrShrinkPreservesContains {|_;_>>_|} {|_;+>_ |} {|_   ;eq|} :=! eq;
  eqrShrinkPreservesContains {|_;_>>_|} {|_;_>>_|} {|d   ;eq|} := {|d;sigmaNat2 _|}.

(* to prove [e C= f], it is enough to have containment of the shrinks and
   [eqrMaxMapCondition e f F1]  *)

Obligation Tactic := idtac.

Equations(noind) eqrBuildContains {n : nat} (e f :  EqR (S n))
                           (shrinkCond : (eqrShrink e) C= (eqrShrink f))
                           (f1Cond     : f @@ e @@ F1 = f @@ F1) :
                            e C= f :=
  eqrBuildContains {|_; +>e   |} {|_; +>f   |} {|c; eq |} _   := {|+>c   ;_|};
  eqrBuildContains {|_; +>e   |} {|_; t2>>f |} {|c; eq |} _   := {|t2>>c ;_|};
  eqrBuildContains {|_; t1>>e |} {|_; +>f   |} shrinkC    f1C :=! f1C;
  eqrBuildContains {|_; t1>>e |} {|_; t2>>f |} {|c; eq |} f1C := {|c ;_|}.
Next Obligation.
  repeat (program_simpl || simp eqr).
Defined.
Next Obligation.
  repeat (program_simpl || simp eqr).
Defined.
Next Obligation.
  intros.
  handleFinCase0 wildcard1.
  handleFinCase0 wildcard4.
  simp eqr in *; simpl in *.
  apply FS_inj in f1C.
  rewrite <- eq in f1C.
  simp eqr in f1C.
  program_simpl.
Defined.
Next Obligation.
  intros.
  handleFinCase0 c0.
  simp eqr in f1Cond.
  inversion f1Cond.
Defined.
Next Obligation.
  intros.
  handleFinCase0 c0.
  apply False_rect.
  simp eqr in f1Cond.
  inversion f1Cond.
Defined.

(* thus, [erqMaxMapCondition e f] implies [e C= f] *)
Lemma eqrContainsFromEqrMaxMapCondition {n : nat} (e f : EqR n)
                                        (emmc : eqrMaxMapCondition e f) :
                                         e C= f.
Proof.
  induction n.
  - rewrite (eqr0Id e). apply idEqrMin.
  - apply eqrBuildContains.
    + apply IHn.
      apply eqrShrinkPreservesEqrMaxMapCondition.
      exact emmc.
    + apply emmc.
Defined.

(* and we have that [eqrToDecEq] reflects containment *)

Lemma eqrToDecEqReflectsContains {n : nat} (e f : EqR n)
                                 (etdeContains : (eqrToDecEq e) c= (eqrToDecEq f)) :
                                 e C= f.
Proof.
  apply eqrContainsFromEqrMaxMapCondition.
  rewrite eqrMaxMapConditionIffEqrToDecEqContains.
  exact etdeContains.
Defined.


Require Import VectorStates.

(** Facts about permutations and matrices that implement them. *)

Local Open Scope nat_scope.

(** * Permutations on (0,...,n-1) *)
Definition permutation (n : nat) (f : nat -> nat) :=
  exists g, forall x, x < n -> (f x < n /\ g x < n /\ g (f x) = x /\ f (g x) = x).

Lemma permutation_is_injective : forall n f,
  permutation n f ->
  forall x y, x < n -> y < n -> f x = f y -> x = y.
Proof.
  intros n f [g Hbij] x y Hx Hy H.
  destruct (Hbij x Hx) as [_ [_ [H0 _]]].
  destruct (Hbij y Hy) as [_ [_ [H1 _]]].
  rewrite <- H0.
  rewrite <- H1.
  rewrite H.
  reflexivity.
Qed.

Lemma permutation_compose : forall n f g,
  permutation n f ->
  permutation n g ->
  permutation n (f ∘ g)%prg.
Proof.
  intros n f g [finv Hfbij] [ginv Hgbij].
  exists (ginv ∘ finv)%prg.
  unfold compose.
  intros x Hx.
  destruct (Hgbij x) as [? [_ [? _]]]; auto.
  destruct (Hfbij (g x)) as [? [_ [Hinv1 _]]]; auto.
  destruct (Hfbij x) as [_ [? [_ ?]]]; auto.
  destruct (Hgbij (finv x)) as [_ [? [_ Hinv2]]]; auto.
  repeat split; auto.
  rewrite Hinv1.
  assumption.
  rewrite Hinv2.
  assumption.
Qed.

Lemma fswap_at_boundary_permutation : forall n f x,
  permutation (S n) f ->
  (x < S n)%nat -> f x = n ->
  permutation n (fswap f x n).
Proof.
  intros n f x Hf Hx Hfx.
  assert (Hneq: forall x0, x0 < S n -> x0 <> x -> f x0 <> n).
  { intros x0 Hx0 Hneq contra.
    rewrite <- Hfx in contra.
    eapply permutation_is_injective in contra.
    contradiction.
    apply Hf.
    assumption.
    assumption. }

  destruct Hf as [g Hg].
  exists (compose (fswap (fun x : nat => x) x n) g).
  intros x0 Hx0.
  unfold fswap, compose.
  bdestructΩ (x0 =? n).
  repeat split.
  - bdestruct (x0 =? x).
    subst x0.
    assert (f n <> n).
    apply Hneq; lia.
    destruct (Hg n) as [? _]; lia.
    assert (f x0 <> n).
    apply Hneq; lia.
    destruct (Hg x0) as [? _]; lia.
  - assert (g x0 <> x).
    intro contra.
    rewrite <- contra in Hfx.
    destruct (Hg x0) as [_ [_ [_ ?]]]; lia.
    bdestruct_all.
    lia.
    destruct (Hg x0) as [_ [? _]]; lia.
  - bdestruct (x0 =? x).
    subst x0.
    destruct (Hg n) as [_ [_ [H1 _]]]; try lia.
    rewrite H1.
    bdestruct_all; trivial.
    destruct (Hg x0) as [_ [_ [H1 _]]]; try lia.
    rewrite H1.
    bdestruct_all; trivial.
  - assert (g x0 <> x).
    intro contra.
    rewrite <- contra in Hfx.
    destruct (Hg x0) as [_ [_ [_ ?]]]; lia.
    bdestructΩ (g x0 =? x).
    bdestruct (g x0 =? n).
    bdestructΩ (x =? x).
    destruct (Hg x0) as [_ [_ [_ ?]]]; try lia.
    rewrite <- H2.
    assumption.
    bdestruct_all.
    destruct (Hg x0) as [_ [_ [_ ?]]]; lia.
Qed.

(** vsum terms can be arbitrarily reordered *)
Lemma vsum_reorder : forall {d} n (v : nat -> Vector d) f,
  permutation n f ->
  big_sum v n = big_sum (fun i => v (f i)) n.
Proof.
  intros.
  generalize dependent f.
  induction n.
  reflexivity.
  intros f [g Hg].
  destruct (Hg n) as [_ [H1 [_ H2]]]; try lia.
  rewrite (vsum_eq_up_to_fswap _ f _ (g n) n) by auto.
  repeat rewrite <- big_sum_extend_r.
  rewrite fswap_simpl2.
  rewrite H2.
  specialize (IHn (fswap f (g n) n)).
  rewrite <- IHn.
  reflexivity.
  apply fswap_at_boundary_permutation; auto.
  exists g. auto.
Qed.

(** * Permutation matrices *)

Definition perm_mat n (p : nat -> nat) : Square n :=
  (fun x y => if (x =? p y) && (x <? n) && (y <? n) then C1 else C0).

Lemma perm_mat_WF : forall n p, WF_Matrix (perm_mat n p).
Proof.
  intros n p.
  unfold WF_Matrix, perm_mat.
  intros x y [H | H].
  bdestruct (x =? p y); bdestruct (x <? n); bdestruct (y <? n); trivial; lia.
  bdestruct (x =? p y); bdestruct (x <? n); bdestruct (y <? n); trivial; lia.
Qed.
#[export] Hint Resolve perm_mat_WF : wf_db.

Lemma perm_mat_unitary : forall n p,
  permutation n p -> WF_Unitary (perm_mat n p).
Proof.
  intros n p [pinv Hp].
  split.
  apply perm_mat_WF.
  unfold Mmult, adjoint, perm_mat, I.
  prep_matrix_equality.
  destruct ((x =? y) && (x <? n)) eqn:H.
  apply andb_prop in H as [H1 H2].
  apply Nat.eqb_eq in H1.
  apply Nat.ltb_lt in H2.
  subst.
  apply big_sum_unique.
  exists (p y).
  destruct (Hp y) as [? _]; auto.
  split; auto.
  split.
  bdestruct_all; simpl; lca.
  intros.
  bdestruct_all; simpl; lca.
  apply (@big_sum_0 C C_is_monoid).
  intros z.
  bdestruct_all; simpl; try lca.
  subst.
  rewrite andb_true_r in H.
  apply beq_nat_false in H.
  assert (pinv (p x) = pinv (p y)) by auto.
  destruct (Hp x) as [_ [_ [H5 _]]]; auto.
  destruct (Hp y) as [_ [_ [H6 _]]]; auto.
  contradict H.
  rewrite <- H5, <- H6.
  assumption.
Qed.

Lemma perm_mat_Mmult : forall n f g,
  permutation n g ->
  perm_mat n f × perm_mat n g = perm_mat n (f ∘ g)%prg.
Proof.
  intros n f g [ginv Hgbij].
  unfold perm_mat, Mmult, compose.
  prep_matrix_equality.
  destruct ((x =? f (g y)) && (x <? n) && (y <? n)) eqn:H.
  apply andb_prop in H as [H H3].
  apply andb_prop in H as [H1 H2].
  apply Nat.eqb_eq in H1.
  apply Nat.ltb_lt in H2.
  apply Nat.ltb_lt in H3.
  subst.
  apply big_sum_unique.
  exists (g y).
  destruct (Hgbij y) as [? _]; auto.
  split; auto.
  split.
  bdestruct_all; simpl; lca.
  intros.
  bdestruct_all; simpl; lca.
  apply (@big_sum_0 C C_is_monoid).
  intros z.
  bdestruct_all; simpl; try lca.
  subst.
  rewrite 2 andb_true_r in H.
  apply beq_nat_false in H.
  contradiction.
Qed.

Lemma perm_mat_I : forall n f,
  (forall x, x < n -> f x = x) ->
  perm_mat n f = I n.
Proof.
  intros n f Hinv.
  unfold perm_mat, I.
  prep_matrix_equality.
  bdestruct_all; simpl; try lca.
  rewrite Hinv in H1 by assumption.
  contradiction.
  rewrite Hinv in H1 by assumption.
  contradiction.
Qed.

(** Given a permutation p over n qubits, construct a permutation over 2^n indices. *)
Definition qubit_perm_to_nat_perm n (p : nat -> nat) :=
  fun x:nat => funbool_to_nat n ((nat_to_funbool n x) ∘ p)%prg.

Lemma qubit_perm_to_nat_perm_bij : forall n p,
  permutation n p -> permutation (2^n) (qubit_perm_to_nat_perm n p).
Proof.
  intros n p [pinv Hp].
  unfold qubit_perm_to_nat_perm.
  exists (fun x => funbool_to_nat n ((nat_to_funbool n x) ∘ pinv)%prg).
  intros x Hx.
  repeat split.
  apply funbool_to_nat_bound.
  apply funbool_to_nat_bound.
  unfold compose.
  erewrite funbool_to_nat_eq.
  2: { intros y Hy.
       rewrite funbool_to_nat_inverse.
       destruct (Hp y) as [_ [_ [_ H]]].
       assumption.
       rewrite H.
       reflexivity.
       destruct (Hp y) as [_ [? _]]; auto. }
  rewrite nat_to_funbool_inverse; auto.
  unfold compose.
  erewrite funbool_to_nat_eq.
  2: { intros y Hy.
       rewrite funbool_to_nat_inverse.
       destruct (Hp y) as [_ [_ [H _]]].
       assumption.
       rewrite H.
       reflexivity.
       destruct (Hp y) as [? _]; auto. }
  rewrite nat_to_funbool_inverse; auto.
Qed.

(** Transform a (0,...,n-1) permutation into a 2^n by 2^n matrix. *)
Definition perm_to_matrix n p :=
  perm_mat (2 ^ n) (qubit_perm_to_nat_perm n p).

Lemma perm_to_matrix_permutes_qubits : forall n p f,
  permutation n p ->
  perm_to_matrix n p × f_to_vec n f = f_to_vec n (fun x => f (p x)).
Proof.
  intros n p f [pinv Hp].
  rewrite 2 basis_f_to_vec.
  unfold perm_to_matrix, perm_mat, qubit_perm_to_nat_perm.
  unfold basis_vector, Mmult, compose.
  prep_matrix_equality.
  destruct ((x =? funbool_to_nat n (fun x0 : nat => f (p x0))) && (y =? 0)) eqn:H.
  apply andb_prop in H as [H1 H2].
  rewrite Nat.eqb_eq in H1.
  rewrite Nat.eqb_eq in H2.
  apply big_sum_unique.
  exists (funbool_to_nat n f).
  split.
  apply funbool_to_nat_bound.
  split.
  erewrite funbool_to_nat_eq.
  2: { intros. rewrite funbool_to_nat_inverse. reflexivity.
  destruct (Hp x0) as [? _]; auto. }
  specialize (funbool_to_nat_bound n f) as ?.
  specialize (funbool_to_nat_bound n (fun x0 : nat => f (p x0))) as ?.
  bdestruct_all; lca.
  intros z Hz H3.
  bdestructΩ (z =? funbool_to_nat n f).
  lca.
  apply (@big_sum_0 C C_is_monoid).
  intros z.
  bdestruct_all; simpl; try lca.
  rewrite andb_true_r in H.
  apply beq_nat_false in H.
  subst z.
  erewrite funbool_to_nat_eq in H2.
  2: { intros. rewrite funbool_to_nat_inverse. reflexivity.
  destruct (Hp x0) as [? _]; auto. }
  contradiction.
Qed.

Lemma perm_to_matrix_unitary : forall n p,
  permutation n p ->
  WF_Unitary (perm_to_matrix n p).
Proof.
  intros.
  apply perm_mat_unitary.
  apply qubit_perm_to_nat_perm_bij.
  assumption.
Qed.

Lemma qubit_perm_to_nat_perm_compose : forall n f g,
  permutation n f ->
  (qubit_perm_to_nat_perm n f ∘ qubit_perm_to_nat_perm n g =
    qubit_perm_to_nat_perm n (g ∘ f))%prg.
Proof.
  intros n f g [finv Hbij].
  unfold qubit_perm_to_nat_perm, compose.
  apply functional_extensionality.
  intro x.
  apply funbool_to_nat_eq.
  intros y Hy.
  rewrite funbool_to_nat_inverse.
  reflexivity.
  destruct (Hbij y) as [? _]; auto.
Qed.

Lemma perm_to_matrix_Mmult : forall n f g,
  permutation n f ->
  permutation n g ->
  perm_to_matrix n f × perm_to_matrix n g = perm_to_matrix n (g ∘ f)%prg.
Proof.
  intros.
  unfold perm_to_matrix.
  rewrite perm_mat_Mmult.
  rewrite qubit_perm_to_nat_perm_compose by assumption.
  reflexivity.
  apply qubit_perm_to_nat_perm_bij.
  assumption.
Qed.

Lemma perm_to_matrix_I : forall n f,
  permutation n f ->
  (forall x, x < n -> f x = x) ->
  perm_to_matrix n f = I (2 ^ n).
Proof.
  intros n f g Hbij.
  unfold perm_to_matrix.
  apply perm_mat_I.
  intros x Hx.
  unfold qubit_perm_to_nat_perm, compose.
  erewrite funbool_to_nat_eq.
  2: { intros y Hy. rewrite Hbij by assumption. reflexivity. }
  apply nat_to_funbool_inverse.
  assumption.
Qed.

Lemma perm_to_matrix_WF : forall n p, WF_Matrix (perm_to_matrix n p).
Proof. intros. apply perm_mat_WF. Qed.
#[export] Hint Resolve perm_to_matrix_WF : wf_db.


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := nil : Lst | cons : Nat -> Lst -> Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Theorem theorem0 : forall (x : Lst) (y : Lst) (z : Lst), eq (append (append x y) z) (append x (append y z)).
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.


(* Exercise 23 *)

Require Import BenB.

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

Theorem exercise_023 :
  ((exists x : D, P x) -> (forall x : D, Q x))
->
  (forall y : D, P y -> Q y).
Proof.
imp_i a1.
all_i a.
imp_i a2.
all_e (forall x:D, Q x) a.
imp_e (exists x:D, P x).
hyp a1.
exi_i a.
hyp a2.
Qed.


Theorem plus_id_exercise : forall n m o : nat,
    n = m -> m = o -> n + m = m + o.
Proof.
    intros n m o.
    intros H0 H1.
    rewrite -> H0, H1.
    reflexivity. Qed.


(** Prove that Stdlib's function Min is primitive recursive *)
(** this is a variant of the exercise MinPR *)

From hydras Require Import  primRec extEqualNat.
From Coq Require Import ArithRing Lia Compare_dec.

(** Define an n-ary if-then-else *)

Fixpoint naryIf (n:nat) :
  naryRel n -> naryFunc n -> naryFunc n -> naryFunc n
  :=
    match n return (naryRel n -> naryFunc n -> naryFunc n -> naryFunc n) with
      0 => (fun b x y =>  if b then x else y)
    | S m => fun (p': naryRel (S m)) (g h: naryFunc (S m)) =>
               fun x => naryIf m (p' x) (g x) (h x)
    end.

Lemma If2IsPR (p: naryRel 2)(f g : naryFunc 2):
  isPRrel 2 p -> isPR 2 f -> isPR 2 g ->
  isPR 2 (naryIf 2 p f g).
Proof.
  unfold naryIf; cbn.
  intros [x Hx] [y Hy] [z Hz].
  assert (H: isPR 2  (fun a b => charFunction 2 p a b * f a b +
                                 (1- charFunction 2 p a b) * g a b)).
  {
    apply   compose2_2IsPR.
    - apply compose2_2IsPR.
      + exists x; auto.
      + exists y; auto.
      + apply multIsPR.
    - apply   compose2_2IsPR.
      +  apply compose2_2IsPR.
         *   apply filter01IsPR.
             apply const1_NIsPR.
         *  exists x; auto.
         *  apply minusIsPR.
      +  exists z; auto.
      +  apply multIsPR.
    -   apply plusIsPR.
  }
  destruct H as [t Ht]; exists t;  eapply extEqualTrans.
  -   apply Ht.
  -  intros a b; case_eq (p a b).
     + intro H0; unfold charFunction.
       rewrite H0.
       replace (1 - 1) with 0; ring_simplify; reflexivity.
     +  intro H1; unfold charFunction; rewrite H1; cbn; lia.
Qed.

Section Proof_of_MinIsPR.

  Let minPR : naryFunc 2 :=
    naryIf 2 leBool
           (fun x _ => x)
           (fun _ y => y).

  Lemma minPR_correct : extEqual 2 minPR PeanoNat.Nat.min.
  Proof.
    intros a b; unfold minPR, naryIf, leBool.
    destruct  (le_lt_dec a b).
    -    rewrite PeanoNat.Nat.min_l; auto; reflexivity.
    - rewrite PeanoNat.Nat.min_r; auto with arith; reflexivity.
  Qed.

  Lemma minPR_PR : isPR 2 minPR.
  Proof.
    unfold minPR;apply If2IsPR.
   -  apply leIsPR.
   -  apply pi1_2IsPR.
   -  apply pi2_2IsPR.
  Qed.

  Lemma minIsPR : isPR 2 min.
  Proof.
    destruct minPR_PR as [f Hf].
    exists f; eapply extEqualTrans with (1:= Hf).
    apply minPR_correct.
  Qed.

End Proof_of_MinIsPR.


(* ***** examples: intuitionistic logic ***** *)

(* The logical connectives for true, false, conjunction,
disjunction are defined by means of inductive predicates.
Roughly the constructors correspond to the introduction
rules, and the induction principle corresponds to the
elimination rules. *)

Print True.
(* True_ind states that P holds if we can prove True from it *)
Check True_ind.

Print False.
(* False_ind gives the elimination rule for False:
any P follows from False *)
Check False_ind.

Parameters A B C : Prop.
Lemma about_false: False -> A.

Proof.
intro x.
elim x.
(* alternative:
elimtype False.
assumption.      *)
(* alternative:
apply False_ind.
assumption.      *)
Qed.

Print and.
Check and_ind.

Lemma about_intro_and : A -> B -> A /\ B.

Proof.
intro x.
intro y.
split.
assumption.
assumption.
(* alternative:
apply conj.
assumption.
assumption.      *)
Qed.

Lemma about_elim_and : A /\ B -> C -> A.
(* elim or apply and_ind *)

Proof.
intros x y.
apply and_ind with A B.
intros.
assumption.
assumption.
Qed.

(* ***** examples: even ***** *)

(* an inductive definition of even *)
Inductive even : nat -> Prop :=
| evenO : even O
| evenSS : forall n:nat , even n -> even (S (S n)).

Check evenO.
Check (even O).
Check (even 1).
Check (evenSS O evenO).
Check (even 2).
Check (evenSS 2 (evenSS O evenO)).
Check (even 4).

(* example *)
Theorem evenzero : (even O).

Proof.
apply evenO.
Qed.

(* example *)
Theorem evenss : forall n:nat , (even n) -> (even (S (S n))).

Proof.
exact evenSS.
Qed.

(*
alternative proof:
intro n.
intro H.
apply evenSS.
exact H.
Qed.
*)

(* ***** examples: le ***** *)

Inductive le (n:nat) : nat -> Prop :=
| le_n : le n n
| le_S : forall m:nat , le n m -> le n (S m).

Check (le O O).
Check (le_n O).
Check (le_n O).
Check (le_S O O (le_n O)).
Definition zero_smaller_than_one := (le_S O O (le_n O)).
Check zero_smaller_than_one.
Check (le_n 7).

(* examples: sorted *)

(* an inductive type for finite lists of natural numbers *)
Inductive natlist : Set :=
| nil : natlist
| cons : nat -> natlist -> natlist.

(* an inductive predicate sorted *)
Inductive sorted : natlist -> Prop :=
| sorted0 : sorted nil
| sorted1 : forall n:nat , sorted (cons n nil)
| sorted2 : forall n h:nat , forall t:natlist ,
            le n h -> sorted (cons h t) -> sorted (cons n (cons h t)).

Check (sorted1 1).
Definition list_one_sorted := (sorted1 1).
Check list_one_sorted.
Check (sorted2 O 1 nil zero_smaller_than_one list_one_sorted).
Definition list_zero_one_sorted := (sorted2 O 1 nil zero_smaller_than_one list_one_sorted).
Check list_zero_one_sorted.

(* ***** examples: inversion ***** *)
Parameter P : nat -> Prop.
Parameter Q : nat -> nat -> Prop.
Parameter R : natlist -> Prop.

Lemma one : forall n : nat, even n -> P n.

Proof.
intros n H.
inversion H.
Abort.

Lemma two : forall n m : nat, le n m -> Q n m.

intros n m H.
inversion H.
Abort.

Lemma three : forall l : natlist, sorted l -> R l.

Proof.
intros l H.
inversion H.
Abort.

(* *************** now the exercises start ********** *)
(* *************** we use definition given above **** *)

(* exercise 1 *)
Theorem even2 : (even 2 ).
Proof.
(*! proof *)

Qed.

(* a few checks *)
Check evenO.
Check evenzero.
Print evenzero.
Check evenSS.
Check even2.
Print even2.

(* exercise 2
   use inversion *)
Theorem noteven1 : ~(even 1).
Proof.
(*! proof *)

Qed.

(* exercise 3
   you may want to use an earlier proved result *)
Theorem even4 : even 4.
Proof.
(*! proof *)

Qed.

(* exercise 4 *)
Theorem noteven3 : ~(even 3).
Proof.
(*! proof *)

Qed.

(* an inductive definition of even and odd *)
Inductive ev : nat -> Prop :=
| evO : ev O
| evS : forall n:nat , odd n -> ev (S n)
with odd : nat -> Prop :=
| oddS : forall n:nat , ev n -> odd (S n).

(* example *)
Theorem evzero : ev O.
Proof.
exact evO.
Qed.

(* example *)
Theorem odd1 : odd 1.
Proof.
exact (oddS O evzero).
Qed.

(* exercise 5 *)
Theorem ev2 : ev 2.
Proof.
(*! proof *)

Qed.

(* exercise 6 *)
Theorem notodd2 : ~ odd 2.
Proof.
(*! proof *)

Qed.

(* exercise 7
   use induction *)
Theorem evorodd : forall n:nat, ev n \/ odd n.
Proof.
(*! proof *)

Qed.

(* exercise 8 *)
Theorem zero_and_zero : le O O.
Proof.
(*! proof *)

Qed.

(* exercise 9 *)
Theorem zero_and_one  : le 0 1.
Proof.
(*! proof *)

Qed.

(* some checks *)
Print zero_and_one.
Check zero_and_one.

(* exercise 10 *)
Theorem one_and_zero : ~ (le 1 0).
Proof.
(*! proof *)

Qed.

(* exercise 11 *)
Theorem sortednil : sorted nil.
Proof.
(*! proof *)

Qed.

(* exercise 12 *)
Theorem sortedone : sorted (cons 0 nil).
Proof.
(*! proof *)

Qed.

(* exercise 13 *)
Theorem sorted_one_two_three :
  sorted (cons 1 (cons 2 (cons 3 nil))).
Proof.
(*! proof *)

Qed.

(* exercise 14 *)
Theorem sorted_tail :
  forall (n : nat) (l : natlist),
  sorted (cons n l) ->
  sorted l.
Proof.
(*! proof *)

Qed.

(* given for exercise 15
   without_last n k l holds if
   n is the last element of k
   and
   l is k without the last element *)
Inductive without_last (n:nat) : natlist -> natlist -> Prop :=
| without_last_one :
  without_last n (cons n nil) nil
| without_last_more :
    forall m:nat, forall l k : natlist,
    without_last n k l -> without_last n (cons m k) (cons m l).

(* exercise 15 *)
(* define a predicate palindrome : natlist -> Prop
   that holds exactly if the input list is equal to its reverse.
   use three clauses: for the empty list, for a list of one
   element, for a list of two or more elements *)

Inductive palindrome : natlist -> Prop := (*! term *)
  .