(** Data and Functions *)

(* Days of the Week *)
Inductive day : Type :=
| monday
| tuesday
| wednesday
| thursday
| friday
| saturday
| sunday.

Definition next_weekday (d: day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Compute (next_weekday friday).
Compute (next_weekday (next_weekday saturday)).

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.

Proof. simpl. reflexivity. Qed.

(** Booleans *)
Inductive bool : Type :=
| true
| false.

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

Definition andb (b₁ : bool) (b₂ : bool) : bool :=
  match b₁ with
  | true => b₂
  | false => false
  end.

Definition orb (b₁ : bool) (b₂ : bool) : bool :=
  match b₁ with
  | true => true
  | false => b₂
  end.

Example test_orb1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.
Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4: (orb true true) = true.
Proof. simpl. reflexivity. Qed.

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

Example test_orb5: false || false || true = true.
Proof. simpl. reflexivity. Qed.

Definition negb' (b : bool) : bool :=
  if b then false
  else true.
Definition andb' (b₁ : bool) (b₂ : bool) : bool :=
  if b₁ then b₂
  else false.
Definition orb' (b₁ : bool) (b₂ : bool) : bool :=
  if b₁ then true
  else b₂.

(*** Exercise 1 star, standard (nandb) *)
Definition nandb (b₁ : bool) (b₂ : bool) : bool :=
  match b₁ with
  | true => match b₂ with
            | true => false
            | false => true
            end
  | false => true
  end.

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

(** Types *)
Check true.
Check true : bool.
Check (negb true) : bool.
Check negb : bool -> bool.

(** New Types from Old *)
Inductive rgb : Type :=
| red
| green
| blue.

Inductive color : Type :=
| black
| white
| primary (p : rgb).

Definition monochrome (c : color) : bool :=
  match c with
  | black => true
  | white => true
  | primary p => false
  end.

Definition isred (c : color) : bool :=
  match c with
  | black => false
  | white => false
  | primary red => true
  | primary _ => false
  end.

(** Modules *)
Module Playground.
  Definition b : rgb := blue.
End Playground.

Definition b : bool := true.

Check Playground.b : rgb.
Check b : bool.

(** Tuples *)
Module TuplePlayground.
  Inductive bit : Type :=
  | B₀
  | B₁.

  Inductive nybble : Type :=
  | bits (b₀ b₁ b₂ b₃ : bit).

  Check (bits B₁ B₀ B₁ B₀) : nybble.

  Definition all_zero (nb : nybble) : bool :=
    match nb with
    | (bits B₀ B₀ B₀ B₀) => true
    | (bits _ _ _ _) => false
    end.

  Compute (all_zero (bits B₁ B₀ B₁ B₀)).
  Compute (all_zero (bits B₀ B₀ B₀ B₀)).
End TuplePlayground.

(** Numbers *)
Module NatPlayground.
  Inductive nat : Type :=
  | O
  | S (n : nat).

  Inductive nat' : Type :=
  | stop
  | tick (foo : nat').

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

Check (S (S (S (S O)))).

Definition minustwo (n : nat) : nat :=
  match n with
  | O => O
  | S O => O
  | S (S n') => n'
  end.

Compute (minustwo 4).

Check S : nat -> nat.
Check pred : nat -> nat.
Check minustwo : nat -> nat.

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

Definition odd (n : nat) : bool :=
  negb (even n).

Example test_odd1: odd 1 = true.
Proof. simpl. reflexivity. Qed.
Example test_odd2: odd 4 = false.
Proof. simpl. reflexivity. Qed.

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

  Compute (plus 3 2).

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

  Example test_mult1: (mult 3 3) = 9.
  Proof. simpl. reflexivity. Qed.

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

Fixpoint exp (base power : nat) : nat :=
  match power with
  | O => S O
  | S p => mult base (exp base p)
  end.

Notation "x + y" := (plus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x - y" := (minus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x * y" := (mult x y)
                       (at level 40, left associativity)
                       : nat_scope.
Check ((0 + 1) + 1) : nat.

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

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

Example test_leb1: leb 2 2 = true.
Proof. simpl. reflexivity. Qed.
Example test_leb2: leb 2 4 = true.
Proof. simpl. reflexivity. Qed.
Example test_leb3: leb 4 2 = false.
Proof. simpl. reflexivity. Qed.

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

Example test_leb3': (4 <=? 2) = false.
Proof. simpl. reflexivity. Qed.

(*** Exercise: 1 star, standard (ltb) *)
Definition ltb (n m : nat) : bool :=
  negb (m <=? n).

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

Example test_ltb1: (ltb 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_ltb2: (ltb 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_ltb3: (ltb 4 2) = false.
Proof. simpl. reflexivity. Qed.

(* Proof by Simplification *)
Theorem plus_O_n : forall n : nat, 0 + n = n.
Proof. intros n. simpl. reflexivity. Qed.

Theorem plus_O_n' : forall n : nat, 0 + n = n.
Proof. intros n. reflexivity. Qed.

Theorem plus_1_l : forall n : nat, 1 + n = S n.
Proof. intros n. reflexivity. Qed.
Theorem mult_0_l : forall n : nat, 0 * n = 0.
Proof. intros n. reflexivity. Qed.

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

Check mult_n_O.
Check mult_n_Sm.

Theorem mult_n_0_m_0 : forall p q : nat,
  (p * 0) + (q * 0) = 0.
Proof.
  intros p q.
  rewrite <- mult_n_O.
  rewrite <- mult_n_O.
  reflexivity. Qed.

(* Proof by Case Analysis *)
Theorem plus_1_neq_0_firsttry : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros n.
  simpl.
Abort.

Theorem plus_1_neq_0 : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros n. destruct n as [| n'] eqn:E.
  - reflexivity.
  - reflexivity. Qed.

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b. destruct b eqn:E.
  - reflexivity.
  - reflexivity. Qed.

Theorem andb_commutative : forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b eqn:Eb.
  - destruct c eqn:Ec.
    + reflexivity.
    + reflexivity.
  - destruct c eqn:Ec.
    + reflexivity.
    + reflexivity.
Qed.

Theorem andb_commutative' : forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b eqn:Eb.
  { destruct c eqn:Ec.
    { reflexivity. }
    { reflexivity. } }
  { destruct c eqn:Ec.
    { reflexivity. }
    { reflexivity. } }
Qed.

Theorem andb3_exchange :
  forall b c d, andb (andb b c) d = andb (andb b d) c.
Proof.
  intros b c d. destruct b eqn:Eb.
  - destruct c eqn:Ec.
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
  - destruct c eqn:Ec.
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
Qed.

(*** Exercise: 2 stars, standard (andb_true_elim2) *)
Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros b c. destruct b eqn:Eb.
  - { destruct c eqn:Ec.
    - intros H. reflexivity.
    - intros H. rewrite <- H. reflexivity. }
  - { destruct c eqn:Ec.
    - intros H. rewrite <- H. reflexivity.
    - intros H. rewrite <- H. reflexivity. }
Qed.

Theorem plus_1_neq_0' : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros [|n].
  - reflexivity.
  - reflexivity. Qed.

Theorem andb_commutative'' : forall b c,
  andb b c = andb c b.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

(* More Exercises *)

(*** Exercise: 3 stars, standard, optional (andb_eq_orb) *)
Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
  intros b c. destruct b eqn:Eb.
  - { destruct c eqn:Ec.
      - reflexivity.
      - simpl. intros H. rewrite <- H. reflexivity. }
  - { destruct c eqn:Ec.
      - simpl. intros H. rewrite <- H. reflexivity.
      - intros H. reflexivity. }


(* week-15_two-by-two-matrices.v *)
(* YSC3236 2017-2018, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of Tue 21 Nov 2017 *)

(* ********** *)

(*
   name: Oishik Ganguly
   student ID number: A0138306J
   e-mail address: oishik.ganguly@u.yale-nus.edu.sg
 *)

(* ******** Paraphernalia ******** *)

Ltac unfold_tactic name :=
  intros;
  unfold name; (* fold name; *)
  reflexivity.

Require Import Arith Bool.

Inductive m22 : Type :=
| M22 : nat -> nat -> nat -> nat -> m22.

Notation "A =n= B" :=
  (beq_nat A B) (at level 70, right associativity).

Notation "A =b= B" :=
  (eqb A B) (at level 70, right associativity).

(* Definition to capture the equality of 2*2 matrices *)
Definition eq_matrices (matrix_a : m22) (matrix_b : m22) :=
  match matrix_a with
  | M22 a11 a12 a21 a22 =>
    match matrix_b with
    | M22 b11 b12 b21 b22 =>
      (a11 =n= b11) && (a12 =n= b12) && (a21 =n= b21) && (a22 =n= b22)
    end
  end.

(* User defined induction principle for two base cases *)
Lemma nat_ind2 :
  forall P : nat -> Prop,
    P 0 ->
    P 1 ->
    (forall i : nat,
      P i -> P (S i) -> P (S (S i))) ->
    forall n : nat,
      P n.
Proof.
  intros P H_bc0 H_bc1 H_ic n.
  assert (H_Pn_PSn : P n /\ P (S n)).
    induction n as [ | n' [IH_n' IH_Sn']].

    split.

      apply H_bc0.

    apply H_bc1.

    split.

      apply IH_Sn'.

    apply (H_ic n' IH_n' IH_Sn').

  destruct H_Pn_PSn as [H_Pn _].
  apply H_Pn.
Qed.

(* We define a special notation to capture the equality of matrices. Two 2*2 matrices
 * are equal if every ijth term of the matrices are equal *)
Notation "A =m= B" :=
  (eq_matrices A B) (at level 70, right associativity).

(* This lemma allow us to substitute S n = n+1. This is useful in proving the theorem *)
Lemma Sn_is_n_plus_1:
  forall (n : nat),
    S n = n + 1.
Proof.
  intro n.
  Check (plus_n_Sm).
  rewrite <- (plus_n_Sm).
  Search (_+ 0 = _).
  rewrite -> (plus_0_r n).
  reflexivity.
Qed.

(* ********** *)

(* The goal of this project is to study 2x2 matrices,
   along the lines of Section 5 of
     http://users-cs.au.dk/danvy/more-about-induction-proofs.pdf
 *)

(* implement Definition 9 (i.e., the multiplication of 2*2-matrices) *)
Definition m22_multiplication (matrix_a : m22) (matrix_b : m22) : m22 :=
  match matrix_a with
  | M22 a11 a12 a21 a22 =>
    match matrix_b with
    | M22 b11 b12 b21 b22 =>
      M22 (a11*b11 + a12*b21) (a11*b12 + a12*b22) (a21*b11 + a22*b21) (a21*b12 + a22*b22)
    end
  end.

(* Unit tests for m22_multiplication() *)
Definition unit_test_for_m22_multiplication : bool :=
  (m22_multiplication (M22 1 1 1 1) (M22 2 2 2 2) =m= M22 4 4 4 4)
    &&
    (m22_multiplication (M22 1 5 6 7) (M22 3 2 0 1) =m= M22 3 7 18 19)
    &&
    (m22_multiplication (M22 1 2 3 4) (M22 4 3 2 1) =m= M22 8 5 20 13)
    &&
    (m22_multiplication (M22 1 0 1 1) (M22 4 0 4 1) =m= M22 4 0 8 1)
    &&
    (m22_multiplication (M22 9 8 1 1) (M22 4 5 2 3) =m= M22 52 69 6 8).

Compute (unit_test_for_m22_multiplication).

(* implement the addition of 2*2-matrices *)
Definition m22_addition (matrix_a : m22) (matrix_b : m22) : m22 :=
  match matrix_a with
  | M22 a11 a12 a21 a22 =>
    match matrix_b with
    | M22 b11 b12 b21 b22 =>
      M22 (a11 + b11) (a12 + b12) (a21 + b21) (a22 + b22)
    end
  end.

(* Unit tests for m22_addition() *)
Definition unit_test_for_m22_addition : bool :=
  (m22_addition (M22 1 1 1 1) (M22 2 2 2 2) =m= M22 3 3 3 3)
    &&
    (m22_addition (M22 1 5 6 7) (M22 3 2 0 1) =m= M22 4 7 6 8)
    &&
    (m22_addition (M22 1 2 3 4) (M22 4 3 2 1) =m= M22 5 5 5 5)
    &&
    (m22_addition (M22 1 0 1 1) (M22 4 0 4 1) =m= M22 5 0 5 2)
    &&
    (m22_addition (M22 9 8 1 1) (M22 4 5 2 3) =m= M22 13 13 3 4).

Compute (unit_test_for_m22_addition).

(* implement Definitions 11 and 13 *)

(* Definition 11: The identity matrix *)
Definition m22_identity : m22 :=
  M22 1 0 0 1.

(* define the identity multiplication lemmas *)
Lemma m22_mult_identity_r :
  forall (matrix_a : m22),
    m22_multiplication matrix_a m22_identity = matrix_a.
Proof.
  intro matrix_a.
  unfold m22_identity.
  induction matrix_a as [a11 a12 a21 a22].
  unfold m22_multiplication.
  do 4 ( rewrite -> mult_1_r ; rewrite -> mult_0_r).
  do 2 ( rewrite -> plus_0_r ; rewrite -> plus_0_l).
  reflexivity.
Qed.

Lemma m22_mult_identity_l :
  forall (matrix_a : m22),
    m22_multiplication m22_identity matrix_a = matrix_a.
Proof.
  intro matrix_a.
  unfold m22_identity.
  induction matrix_a as [a11 a12 a21 a22].
  unfold m22_multiplication.
  do 4 ( rewrite -> mult_1_l ; rewrite -> mult_0_l).
  do 2 ( rewrite -> plus_0_l ; rewrite -> plus_0_r).
  reflexivity.
Qed.

(* Definition 13: Exponentiation of a matrix. We take two arguments for this defintion
 * , namely the matrix, and the exponent *)

Fixpoint m22_exponentiation (matrix_a : m22) (exponent : nat) : m22 :=
  match exponent with
  | 0 =>
    m22_identity
  | S n =>
    m22_multiplication (m22_exponentiation matrix_a n) matrix_a
  end.

(* Unfold lemmas *)
Lemma unfold_m22_exponentiation_0 :
  forall (matrix_a : m22),
    m22_exponentiation matrix_a 0 = m22_identity.
Proof.
  unfold_tactic m22_exponentiation.
Qed.

Lemma unfold_m22_exponentiation_S :
  forall (matrix_a : m22) (n :  nat),
    m22_exponentiation matrix_a (S n) =
    m22_multiplication (m22_exponentiation matrix_a n) matrix_a.
Proof.
  unfold_tactic m22_exponentiation.
Qed.

(* quick unit test for the exponentiation definition *)
Definition unit_test_for_m22_exponentiation : bool :=
  (m22_exponentiation (M22 2 3 4 5) 2 =m= M22 16 21 28 37)
    &&
    (m22_exponentiation (M22 0 3 2 5) 5 =m= M22 1110 3333 2222 6665)
    &&
    (m22_exponentiation (M22 1 3 2 1) 3 =m= M22 19 27 18 19)
    &&
    (m22_exponentiation (M22 1 0 9 7) 3 =m= M22 1 0 513 343)
    &&
    (m22_exponentiation (M22 1 2 2 1) 5 =m= M22 121 122 122 121).

Compute (unit_test_for_m22_exponentiation).

(* prove Properties 10 and 12 *)

(* Property 10: 2*2 multiplication is associative *)

Proposition m22_multiplication_is_associative :
  forall (matrix_a matrix_b matrix_c : m22),
    m22_multiplication matrix_a (m22_multiplication matrix_b matrix_c) =
    m22_multiplication (m22_multiplication matrix_a matrix_b) matrix_c.
Proof.
  intros matrix_a matrix_b matrix_c.
  (* use the inductive structure of a matrix for the proof *)
  induction matrix_a as [a11 a12 a21 a22].
  induction matrix_b as [b11 b12 b21 b22].
  induction matrix_c as [c11 c12 c21 c22].
  (* unfold matrix multiplication; since we are using the inductive structures,
   * match statements are exectued *)
  unfold m22_multiplication.
  Search ( _ * (_ + _) = _).
  (* now we must simplify each of the natural numbers nested in the M22 constructor.
   * since the same set of tactics must be used for each of the four natural values
   * on the left and right hand side, we use coq's loop facility to reduce the
   * amount of code *)
  do 4
     (
       rewrite -> mult_plus_distr_l;
       rewrite -> mult_assoc;
       rewrite -> mult_assoc;
       rewrite -> mult_plus_distr_l;
       rewrite -> mult_assoc;
       rewrite -> mult_assoc;
       rewrite -> plus_assoc
     ).
  do 4
     (
       rewrite -> mult_plus_distr_r;
       rewrite -> mult_plus_distr_r;
       rewrite -> plus_permute_2_in_4;
       rewrite -> plus_assoc
     ).
  reflexivity.
Qed.

(* Before formalizing proposition 14, we define the special matrix we are dealing with
 * ; we call this matrix M1 *)
Definition M1 : m22 := M22 1 1 0 1.

(* formalize Proposition 14 and its proof in Coq *)
Proposition about_M1 :
  forall (n : nat),
    m22_exponentiation M1  n = M22 1 n 0 1.
Proof.
  intro n.
  unfold M1.
  induction n as [ | n' IH_n'].

  (* base case *)
  rewrite -> (unfold_m22_exponentiation_0 (M22 1 1 0 1) ).
  unfold m22_identity.
  reflexivity.

  (* inductive case *)
  rewrite -> (unfold_m22_exponentiation_S (M22 1 1 0 1) n').
  rewrite -> IH_n'.
  unfold m22_multiplication.
  Search (1*_ = _).
  (* some algebraic manipulation to reach the required goal *)
  rewrite mult_0_l.
  do 2 (rewrite -> mult_0_r ; rewrite -> mult_1_r ; rewrite -> plus_0_r).
  rewrite -> plus_0_l.
  rewrite -> (plus_comm 1 n').
  rewrite <- (Sn_is_n_plus_1 n').
  reflexivity.
Qed.

(* implement Definition 27 *)
Fixpoint m22_exponentiation_alternative (matrix_a : m22) (exponent :nat) : m22 :=
  match exponent with
  | 0 =>
    m22_identity
  | S n =>
    m22_multiplication (matrix_a) (m22_exponentiation_alternative matrix_a n)
  end.

(* We use the same unit tests as in the first definition of exponentiation *)
Definition unit_test_for_m22_exponentiation_alternative : bool :=
  (m22_exponentiation_alternative (M22 2 3 4 5) 2 =m= M22 16 21 28 37)
    &&
    (m22_exponentiation_alternative (M22 0 3 2 5) 5 =m= M22 1110 3333 2222 6665)
    &&
    (m22_exponentiation_alternative (M22 1 3 2 1) 3 =m= M22 19 27 18 19)
    &&
    (m22_exponentiation_alternative (M22 1 0 9 7) 3 =m= M22 1 0 513 343)
    &&
    (m22_exponentiation_alternative (M22 1 2 2 1) 5 =m= M22 121 122 122 121).

Compute (unit_test_for_m22_exponentiation_alternative).

(* Standard unfold lemmas *)
Lemma unfold_m22_exponentiation_alternative_0 :
  forall (matrix_a : m22) ,
    m22_exponentiation_alternative matrix_a 0 = m22_identity.
Proof.
  unfold_tactic m22_exponentiation_alternative.
Qed.

Lemma unfold_m22_exponentiation_alternative_S :
  forall (matrix_a : m22) (n : nat),
    m22_exponentiation_alternative matrix_a (S n) =
    m22_multiplication (matrix_a) (m22_exponentiation_alternative matrix_a n).
Proof.
  unfold_tactic m22_exponentiation_alternative.
Qed.

(* solve Exercise 28 : reproving proposition 14 using this definition *)
Proposition about_M1_alternative :
  forall (n : nat),
    m22_exponentiation_alternative M1 n = M22 1 n 0 1.
Proof.
  intro n.
  unfold M1.
  induction n as [ | n' IH_n'].

  (* base case *)
  rewrite -> (unfold_m22_exponentiation_alternative_0 (M22 1 1 0 1)).
  unfold m22_identity.
  reflexivity.

  (* inductive case *)
  rewrite -> (unfold_m22_exponentiation_alternative_S (M22 1 1 0 1) n').
  rewrite -> IH_n'.
  unfold m22_multiplication.
  (* some algebraic manipulation to get to the requried goal *)
  rewrite -> mult_0_r.
  do 2 (rewrite -> mult_0_l ; rewrite -> mult_1_l ; rewrite -> plus_0_l).
  rewrite -> plus_0_r.
  rewrite <- (Sn_is_n_plus_1 n').
  reflexivity.
Qed.

(* formalize Proposition 29 and its proof in Coq *)
Proposition m22_exponentiation_is_commutative :
  forall (matrix_a : m22) (n : nat),
    m22_multiplication (matrix_a) (m22_exponentiation matrix_a n) =
    m22_multiplication (m22_exponentiation matrix_a n) (matrix_a).
Proof.
  intros matrix_a n.
  induction n as [ | n' IH_n'].

  (* base case *)
  rewrite -> unfold_m22_exponentiation_0.
  (* using the lemmas we had already defined *)
  rewrite -> m22_mult_identity_l.
  rewrite -> m22_mult_identity_r.
  reflexivity.

  (* inductive case *)
  rewrite -> unfold_m22_exponentiation_S.
  (* use the associativity of matrix multiplication *)
  rewrite -> m22_multiplication_is_associative.
  rewrite -> IH_n'.
  reflexivity.
Qed.

(* solve Exercise 31 *)
Proposition m22_exponentiation_alternative_is_commutative :
  forall (matrix_a : m22) (n : nat),
    m22_multiplication matrix_a (m22_exponentiation_alternative matrix_a n) =
    m22_multiplication (m22_exponentiation_alternative matrix_a n) matrix_a.
Proof.
  intros matrix_a n.
  induction n as [ |n' IH_n'].

  (* base case *)
  rewrite -> unfold_m22_exponentiation_alternative_0.
  (* using the lemmas we had already defined *)
  rewrite -> m22_mult_identity_l.
  rewrite -> m22_mult_identity_r.
  reflexivity.

   (* inductive case *)
  rewrite -> unfold_m22_exponentiation_alternative_S.
  (* use the associativity of matrix multiplication *)
  rewrite <-  m22_multiplication_is_associative.
  rewrite -> IH_n'.
  reflexivity.
Qed.

(* implement Corollary 32 *)
Corollary m22_exponentiation_is_equivalent_to_m22_exponentiation_alternative :
  forall (matrix_a : m22) (n : nat),
    m22_exponentiation matrix_a n = m22_exponentiation_alternative matrix_a n.
Proof.
  intros matrix_a n.

  (* base case *)
  induction n as [ |n' IH_n'].
  rewrite -> unfold_m22_exponentiation_0.
  rewrite -> unfold_m22_exponentiation_alternative_0.
  reflexivity.

  (* inductive case *)
  rewrite -> unfold_m22_exponentiation_S.
  rewrite -> unfold_m22_exponentiation_alternative_S.
  rewrite <-  m22_exponentiation_is_commutative.
  rewrite -> IH_n'.
  reflexivity.
Qed.

(* Before solving 34, we will define the matrix in it, and call it M2 *)
Definition M2 : m22 := M22 1 0 1 1.
(* solve Exercise 34 *)

(* We will use the first definition of exponentiation (def 13) *)
Proposition about_M2 :
  forall (n : nat),
    m22_exponentiation M2 n = M22 1 0 n 1.
Proof.
  intro n.
  unfold M2.
  induction n as [ | n' IH_n'].

  (* base case *)
  rewrite -> unfold_m22_exponentiation_0.
  unfold m22_identity.
  reflexivity.

  (* inductive case *)
  rewrite -> unfold_m22_exponentiation_S.
  rewrite -> IH_n'.
  unfold m22_multiplication.
  rewrite -> mult_0_l.
  do 2 (rewrite -> mult_0_r; rewrite -> mult_1_r; rewrite -> plus_0_l).
  rewrite -> plus_0_r.
  rewrite <- Sn_is_n_plus_1.
  reflexivity.
Qed.

(* implement Definition 35 *)

(* defining the transpose a 2*2 matrix *)
Definition m22_transpose (matrix_a : m22) : m22 :=
  match matrix_a with
  | M22 a11 a12 a21 a22 =>
    M22 a11 a21 a12 a22
  end.

(* prove Property 36 *)
Proposition m22_transposition_is_involutive :
  forall (matrix_a : m22),
    m22_transpose (m22_transpose matrix_a) = matrix_a.
Proof.
  intro matrix_a.
  induction matrix_a as [a11 a12 a21 a22].
  unfold m22_transpose.
  reflexivity.
Qed.

(* formalize Proposition 37 and its proof in Coq *)
Proposition m22_transpose_of_product :
  forall (matrix_x : m22) (matrix_y : m22),
    m22_transpose (m22_multiplication matrix_x matrix_y) =
    m22_multiplication (m22_transpose matrix_y) (m22_transpose matrix_x).
Proof.
  intros matrix_x matrix_y.
  induction matrix_x as [x11 x12 x21 x22].
  induction matrix_y as [y11 y12 y21 y22].
  unfold m22_multiplication.
  unfold m22_transpose.
  (* now we do some algebraic manipulation *)
  Search (_*_ = _*_).
  rewrite -> (mult_comm x11 y11);
    rewrite -> (mult_comm x12 y21);
    rewrite -> (mult_comm x21 y11);
    rewrite -> (mult_comm x22 y21);
    rewrite -> (mult_comm x11 y12);
    rewrite -> (mult_comm x12 y22);
    rewrite -> (mult_comm x21 y12);
    rewrite -> (mult_comm x22 y22).
  reflexivity.
Qed.

(* before proving proposition 38, we prove a simple lemma about the tranpose of the
 * identity matrix *)
Lemma tranpose_of_m22_identity_is_identity :
  m22_transpose (m22_identity) = m22_identity.
Proof.
  unfold m22_identity.
  unfold m22_transpose.
  reflexivity.
Qed.

(* formalize Proposition 38 and its proof in Coq *)
Proposition m22_transposition_and_exponentiation_commute :
  forall (matrix_a : m22) (n : nat),
    m22_transpose (m22_exponentiation matrix_a n) =
    m22_exponentiation (m22_transpose matrix_a) n.
Proof.
  intros matrix_a n.
  induction n as [ |n' IH_n'].

  (* base case *)
  do 2 (rewrite -> unfold_m22_exponentiation_0).
  rewrite -> tranpose_of_m22_identity_is_identity.
  reflexivity.

  (* inductive case *)
  rewrite -> (unfold_m22_exponentiation_S (matrix_a) n').
  rewrite -> m22_transpose_of_product.
  rewrite -> IH_n'.
  (* Rewrite L.H.S. using the alternative definiton of exponentiation *)
  rewrite -> (m22_exponentiation_is_equivalent_to_m22_exponentiation_alternative
                (m22_transpose matrix_a) n').
  Check (unfold_m22_exponentiation_alternative_S (m22_transpose matrix_a) n').
  rewrite <- (unfold_m22_exponentiation_alternative_S (m22_transpose matrix_a) n').
  (* since both definitions of exponentiation are equivalent, we use this equivalence
   * to reach our goal *)
  rewrite -> (m22_exponentiation_is_equivalent_to_m22_exponentiation_alternative
                (m22_transpose matrix_a) (S n')).

  reflexivity.
Qed.

(* We prove a very quick lemma about the two matrices dealt with in proposition 40 *)
Lemma M2_is_the_tranpose_of_M1 :
  M2 = m22_transpose M1.
Proof.

  unfold m22_transpose.
  reflexivity.
Qed.

(* solve Exercise 40 *)
Proposition about_M2_without_induction :
  forall (n : nat),
    m22_exponentiation M2 n = M22 1 0 n 1.
Proof.
  intro n.
  rewrite -> M2_is_the_tranpose_of_M1.
  rewrite <- m22_transposition_and_exponentiation_commute.
  (* now we use the theorem about m22_1101 *)
  rewrite -> (about_M1 n).
  reflexivity.
Qed.

(* solve Exercise 25 *)

(* We will use the fixpoint defintion for exponentiation to check F^0, ..., F^n *)
Definition F : m22 := M22 1 1 1 0.

Compute (m22_exponentiation F 0).
Compute (m22_exponentiation F 1).
Compute (m22_exponentiation F 2).
Compute (m22_exponentiation F 3).
Compute (m22_exponentiation F 4).

(* We observe that for all n >= 0, F^n returns a matrix with the nth element of the
 * fibonacci sequence in row 1 column 2. Furthermore, we find that forall n,
 * F^ (S (S n)) = F^(S n) + F^n. Thus the function (m22_exponentiation F)
 * which takes n as input, satisfies the specifcation for a fibonacci function *)

(* To prove this, we initially defined and tried to prove a lemma that formalized
 * the above characterization of F. However, we soon realized that we would
 * first have to prove that F^(n+2) = F^(n+1) + F^n to proceed with our proof.
 * We completed the subsidiary characterization for function F below first *)

(*Subsidiary question for Exercise 25:
   characterize the result of adding F^n and F^(n+1), for any n : nat *)

(* Clearly, exponentiating F has the following property :
 * F^0 = M22 1 0 0 1
 * F^1 = M22 1 1 1 0
 * F^n + F^(n+1) = F^(n+2) *)

(* We will now show this characterization holds; but first, we define two auxiliary
 * lemmas concerning the distributive properties of matrices *)

Lemma  m22_distr_mult_l :
  forall (matrix_a matrix_b matrix_c : m22),
    m22_multiplication matrix_a (m22_addition matrix_b matrix_c) =
    m22_addition (m22_multiplication matrix_a matrix_b)
                 (m22_multiplication matrix_a matrix_c).
Proof.
  intros matrix_a matrix_b matrix_c.
  induction matrix_a as [a11 a12 a21 a22];
    induction matrix_b as [b11 b12 b21 b22];
    induction matrix_c as [c11 c12 c21 c22].
  unfold m22_multiplication; unfold m22_addition.
  Search (_* (_ + _) = _).
  do 8 (rewrite -> mult_plus_distr_l).
  Check (plus_permute_2_in_4).
  rewrite -> (plus_permute_2_in_4 (a11*b11) _ _ _).
  rewrite -> (plus_permute_2_in_4 (a11*b12) _ _ _).
  rewrite -> (plus_permute_2_in_4 (a21*b11) _ _ _).
  rewrite -> (plus_permute_2_in_4 (a21*b12) _ _ _).
  reflexivity.
Qed.

Lemma  m22_distr_mult_r :
  forall (matrix_a matrix_b matrix_c : m22),
    m22_multiplication (m22_addition matrix_b matrix_c) matrix_a =
    m22_addition (m22_multiplication matrix_b matrix_a)
                 (m22_multiplication matrix_c matrix_a).
Proof.
  intros matrix_a matrix_b matrix_c.
  induction matrix_a as [a11 a12 a21 a22];
    induction matrix_b as [b11 b12 b21 b22];
    induction matrix_c as [c11 c12 c21 c22].
  unfold m22_multiplication; unfold m22_addition.
  Search (_* (_ + _) = _).
  do 8 (rewrite -> mult_plus_distr_r).
  Check (plus_permute_2_in_4).
  rewrite -> (plus_permute_2_in_4 (b11*a11) _ _ _).
  rewrite -> (plus_permute_2_in_4 (b11*a12) _ _ _).
  rewrite -> (plus_permute_2_in_4 (b21*a11) _ _ _).
  rewrite -> (plus_permute_2_in_4 (b21*a12) _ _ _).
  reflexivity.
Qed.

(* Armed with these lemmas, we now show that the above characterization of F holds *)
Proposition about_F :
  forall (n : nat),
    m22_addition (m22_exponentiation F n) (m22_exponentiation F (S n)) =
    m22_exponentiation F (S (S n)).
Proof.
  intro n.
  induction n as [ | | n' IH_n' IH_Sn'] using nat_ind2.

  (* base case 0 *)
  do 3 (rewrite -> unfold_m22_exponentiation_S).
  rewrite -> unfold_m22_exponentiation_0.
  rewrite -> m22_mult_identity_l.
  unfold F; unfold m22_identity; unfold m22_addition; unfold m22_multiplication.
  (* Simplifying L.H.S. *)
  rewrite -> plus_0_l.
  rewrite -> plus_0_r.
  rewrite <- Sn_is_n_plus_1.
  (* Simplifying R.H.S. *)
  rewrite -> mult_1_l.
  do 2 (rewrite -> mult_0_r).
  rewrite -> mult_0_l.
  rewrite -> plus_0_r.
  rewrite <- Sn_is_n_plus_1.
  reflexivity.

  (* base case 1 *)
  do 6 (rewrite -> unfold_m22_exponentiation_S).
  rewrite -> unfold_m22_exponentiation_0.
  rewrite -> m22_mult_identity_l.
  unfold F; unfold m22_identity; unfold m22_addition; unfold m22_multiplication.
  (* Simplifying the L.H.S *)
  rewrite -> mult_1_l.
  do 2 (rewrite -> mult_0_r).
  rewrite -> mult_0_l.
  rewrite -> plus_0_r.
  rewrite -> plus_0_l.
  rewrite <- Sn_is_n_plus_1.
  rewrite -> (plus_comm 1 2).
  rewrite <- Sn_is_n_plus_1.
  (* Simplifying R.H.S. *)
  do 2 (rewrite -> mult_1_l).
    rewrite -> mult_1_r.
  do 2 (rewrite -> plus_0_r).
  do 2 (rewrite <- Sn_is_n_plus_1).
  reflexivity.

  (* inductive case *)
    (* factorize the L.H.S. as follows: F^(n+2) + F^(n+2) = (F^(n+1) + F^(n+2)).F *)
  rewrite -> (unfold_m22_exponentiation_S F (S n')).
  rewrite -> (unfold_m22_exponentiation_S F (S (S n'))).
  rewrite <- m22_distr_mult_r.
  (* Now use the inductive hypothesis *)
  rewrite -> IH_Sn'.
  rewrite <- unfold_m22_exponentiation_S.
  reflexivity.
Qed.

(* With this characterization proved, we may now prove our hypothesis about the
 * exponentiation of F, namely that F^n returns a matrix such that the
 * element in the 1st row, 2nd column (a12) is the nth element of the Fibonacci
 * sequence *)

(* To do so, we first define a function that accepts a nat value n and returns
 * the nth element of the fibonacci function, and the unfold lemmas that come
 * with it *)

Fixpoint fib_v0 (n : nat) : nat :=
  match n with
  | O => 0
  | S n' => match n' with
            | O => 1
            | S n'' => (fib_v0 n') + (fib_v0 n'')
            end
  end.

(* Unit tests for fib_v0 *)
Definition unit_test_for_fib_v0 :=
  (fib_v0 0 =n= 0)
    &&
    (fib_v0 1 =n= 1)
    &&
    (fib_v0 2 =n= 1)
    &&
    (fib_v0 3 =n= 2)
    &&
    (fib_v0 4 =n= 3)
    &&
    (fib_v0 5 =n= 5)
    &&
    (fib_v0 6 =n= 8).

Compute (unit_test_for_fib_v0).

(* The standard mandatory unfold lemmas: *)

Lemma unfold_fib_v0_O :
  fib_v0 O = 0.
Proof.
  unfold_tactic fib_v0.
Qed.

Lemma unfold_fib_v0_1 :
  fib_v0 1 = 1.
Proof.
  unfold_tactic fib_v0.
Qed.

Lemma unfold_fib_v0_SS :
  forall n'' : nat,
    fib_v0 (S (S n'')) = (fib_v0 (S n'')) + (fib_v0 n'').
Proof.
  unfold_tactic fib_v0.
Qed.

(* We now define our hypothesis about F's fibonacci characteristic as a lemma, and
 * prove it *)
Lemma the_fiboncci_character_of_F :
  forall (n : nat),
    (match m22_exponentiation F n with
    | M22 _ a12 _ _ =>
      a12
     end) = fib_v0 n.
Proof.
  intro n.
  induction n as [ | | n' IH_n' IH_Sn'] using nat_ind2.

  (* base case 0 *)
  rewrite -> unfold_m22_exponentiation_0.
  unfold m22_identity.
  symmetry.
  exact unfold_fib_v0_O.

  (* base case 1 *)
  rewrite -> (unfold_m22_exponentiation_S F 0).
  rewrite -> unfold_m22_exponentiation_0.
  rewrite -> m22_mult_identity_l.
  unfold F.
  symmetry.
  exact unfold_fib_v0_1.

  (* inductive case *)
  rewrite -> unfold_fib_v0_SS.
  rewrite <- IH_n'.
  rewrite <- IH_Sn'.
  (* use the lemma about_F here to simplify the F^(S (S n)) *)
  rewrite <- about_F.
  (* use the inductive structure of the matrix to get past the match statement *)
  induction (m22_exponentiation F n') as [x11 x12 x21 x22].
  induction (m22_exponentiation F (S n')) as [y11 y12 y21 y22].
  unfold m22_addition.
  rewrite -> plus_comm.
  reflexivity.
Qed.

(* ********** *)

(* end of week-15_two-by-two-matrices.v *)


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Lia List Permutation.

Require Import measure_ind.

Set Implicit Arguments.

Infix "~p" := (@Permutation _) (at level 80).

Section incl.

  Variable X : Type.

  Implicit Type l : list X.

  Fact incl_cons_linv l m x : incl (x::m) l -> In x l /\ incl m l.
  Proof.
    intros H; split.
    apply H; left; auto.
    intros ? ?; apply H; right; auto.
  Qed.

  Fact incl_app_rinv l m p : incl m (l++p) -> exists m1 m2, m ~p m1++m2 /\ incl m1 l /\ incl m2 p.
  Proof.
    induction m as [ | x m IHm ].
    exists nil, nil; simpl; repeat split; auto; intros ? [].
    intros H.
    apply incl_cons_linv in H.
    destruct H as (H1 & H2).
    destruct (IHm H2) as (m1 & m2 & H3 & H4 & H5).
    apply in_app_or in H1; destruct H1 as [ H1 | H1 ].
    exists (x::m1), m2; repeat split; auto.
    constructor 2; auto.
    intros ? [ ? | ? ]; subst; auto.
    exists m1, (x::m2); repeat split; auto.
    apply Permutation_cons_app; auto.
    intros ? [ ? | ? ]; subst; auto.
  Qed.

  Fact incl_cons_rinv x l m : incl m (x::l) -> exists m1 m2, m ~p m1 ++ m2 /\ (forall a, In a m1 -> a = x) /\ incl m2 l.
  Proof.
    intros H.
    apply (@incl_app_rinv (x::nil) _ l) in H.
    destruct H as (m1 & m2 & H1 & H2 & H3).
    exists m1, m2; repeat split; auto.
    intros a Ha; apply H2 in Ha; destruct Ha as [ | [] ]; auto.
  Qed.

End incl.

Section Permutation_tools.

  Variable X : Type.

  Implicit Types (l : list X).

  Theorem Permutation_In_inv l1 l2: l1 ~p l2 -> forall x, In x l1 -> exists l, exists r, l2 = l++x::r.
  Proof.
    intros H x Hx.
    apply in_split.
    apply Permutation_in with (1 := H).
    auto.
  Qed.

  Fact perm_in_head x l : In x l -> exists m, l ~p x::m.
  Proof.
    induction l as [ | y l IHl ].
    destruct 1.
    intros [ ? | H ]; subst.
    exists l; apply Permutation_refl.
    destruct (IHl H) as (m & Hm).
    exists (y::m).
    apply Permutation_trans with (2 := perm_swap _ _ _).
    constructor 2; auto.
  Qed.

End Permutation_tools.

Definition list_prefix X (ll : list X) n : n <= length ll -> { l : _ & { r | ll = l++r /\ length l = n } }.
Proof.
  revert n; induction ll as [ | x ll IH ].
  intros [ | n ] Hn; exists nil, nil; split; auto.
  exfalso; simpl in Hn; lia.
  intros [ | n ] Hn.
  exists nil, (x::ll); auto.
  simpl in Hn.
  destruct (IH n) as (l & r & H1 & H2).
  lia.
  subst.
  exists (x::l), r; auto.
Qed.

Section finite_php.

  (** That proof DOES NOT rely on decidable equality *)

  Variable (X : Type).

  Implicit Types (l m : list X).

  Inductive list_has_dup : list X -> Prop :=
    | in_list_hd0 : forall l x, In x l -> list_has_dup (x::l)
    | in_list_hd1 : forall l x, list_has_dup l -> list_has_dup (x::l).

  Fact list_has_dup_cons_inv x l : list_has_dup (x::l) -> In x l \/ list_has_dup l.
  Proof. inversion 1; subst; auto. Qed.

  Fact list_has_dup_app_left l m : list_has_dup m -> list_has_dup (l++m).
  Proof. induction l; simpl; auto; constructor 2; auto. Qed.

  Fact list_has_dup_app_right l m : list_has_dup l -> list_has_dup (l++m).
  Proof.
    induction 1; simpl.
    constructor 1; apply in_or_app; left; auto.
    constructor 2; auto.
  Qed.

  Fact list_has_dup_equiv l : list_has_dup l <-> exists x aa bb cc, l = aa++x::bb++x::cc.
  Proof.
    split.

    induction 1 as [ l x Hx | l x Hl (y & aa & bb & cc & IHl) ].

    apply in_split in Hx.
    destruct Hx as (bb & cc & ?); subst.
    exists x, nil, bb, cc; auto.

    exists y, (x::aa), bb, cc; subst; auto.

    intros (x & aa & bb & cc & ?); subst.
    apply list_has_dup_app_left.
    constructor 1.
    apply in_or_app; simpl; auto.
  Qed.

  Fact list_hd_eq_perm l m : l ~p m -> list_has_dup l -> list_has_dup m.
  Proof.
    induction 1 as [ | x l m H1 IH1 | x y l | ]; auto.
    intros H.
    apply list_has_dup_cons_inv in H.
    destruct H as [ H | H ].
    apply Permutation_in with (1 := H1) in H.

    apply in_list_hd0; auto.
    apply in_list_hd1; auto.
    intros H.
    apply list_has_dup_cons_inv in H.
    destruct H as [ [ H | H ] | H ]; subst.
    apply in_list_hd0; left; auto.
    apply in_list_hd1, in_list_hd0; auto.
    apply list_has_dup_cons_inv in H.
    destruct H as [ H | H ].
    apply in_list_hd0; right; auto.
    do 2 apply in_list_hd1; auto.
  Qed.

  Fact incl_right_cons_choose x l m : incl m (x::l) -> In x m \/ incl m l.
  Proof.
    intros H.
    apply incl_cons_rinv in H.
    destruct H as ( m1 & m2 & H1 & H2 & H3 ); simpl in H1.
    destruct m1 as [ | y m1 ].
    right.
    intros u H; apply H3; revert H.
    apply Permutation_in; auto.
    left.
    apply Permutation_in with (1 := Permutation_sym H1).
    rewrite (H2 y); left; auto.
  Qed.

  Fact repeat_choice_two (x : X) m : (forall a, In a m -> a = x) -> (exists m', m = x::x::m') \/ m = nil \/ m = x::nil.
  Proof.
    intros H.
    destruct m as [ | a [ | b m ] ].
    right; left; auto.
    right; right; rewrite (H a); auto; left; auto.
    left; rewrite (H a), (H b).
    exists m; auto.
    right; left; auto.
    left; auto.
  Qed.

  Fact incl_right_cons_incl_or_lhd_or_perm m x l : incl m (x::l) -> incl m l
                                                                 \/ list_has_dup m
                                                                 \/ exists m', m ~p x::m' /\ incl m' l.
  Proof.
    intros H.
    apply incl_cons_rinv in H.
    destruct H as (m1 & m2 & H1 & H2 & H3).
    destruct (repeat_choice_two _ H2) as [ (m3 & H4) | [ H4 | H4 ] ];
      subst m1; simpl in H1; clear H2.

    apply Permutation_sym in H1.
    right; left.
    apply list_hd_eq_perm with (1 := H1).
    apply in_list_hd0; left; auto.

    left.
    intros ? H; apply H3; revert H.
    apply Permutation_in; auto.

    right; right.
    exists m2; auto.
  Qed.

  Fact length_le_and_incl_implies_dup_or_perm l :
               forall m, length l <= length m
                      -> incl m l
                      -> list_has_dup m \/ m ~p l.
  Proof.
    induction on l as IHl with measure (length l).
    destruct l as [ | x l ].
    + intros [ | x ] _ H.
      * right; auto.
      * specialize (H x); simpl in H; contradict H; left; auto.
    + intros [ | y m ] H1 H2.
      * apply le_Sn_0 in H1; destruct H1.
      * simpl in H1; apply le_S_n in H1.
        apply incl_cons_linv in H2.
        destruct H2 as [ [ H3 | H3 ] H4 ].
        - subst y.
          apply incl_right_cons_choose in H4.
          destruct H4 as [ H4 | H4 ].
          ++ left; apply in_list_hd0; auto.
          ++ destruct IHl with (3 := H4); auto.
             left; apply in_list_hd1; auto.
        - apply incl_right_cons_incl_or_lhd_or_perm in H4.
          destruct H4 as [ H4 | [ H4 | (m' & H4 & H5) ] ].
          ++ destruct IHl with (3 := H4) as [ H5 | H5 ]; auto.
             ** left; apply in_list_hd1; auto.
             ** left; apply in_list_hd0; revert H3.
                apply Permutation_in, Permutation_sym; auto.
          ++ left; apply in_list_hd1; auto.
          ++ apply Permutation_sym in H4.
             apply perm_in_head in H3.
             destruct H3 as (l' & Hl').
             assert (incl m' (y::l')) as H6.
             { intros ? ?; apply Permutation_in with (1 := Hl'), H5; auto. }
             clear H5.
             apply incl_right_cons_choose in H6.
             destruct H6 as [ H6 | H6 ].
             ** left; apply in_list_hd0, Permutation_in with (1 := H4); right; auto.
             ** apply IHl in H6.
                -- destruct H6 as [ H6 | H6 ].
                   +++ left; apply list_hd_eq_perm in H4; apply in_list_hd1; auto.
                   +++ right.
                       apply Permutation_trans with (y::x::m').
                       *** apply perm_skip, Permutation_sym; auto.
                       *** apply Permutation_trans with (1 := perm_swap _ _ _),
                           perm_skip, Permutation_sym,
                           Permutation_trans with (1 := Hl'),
                           perm_skip, Permutation_sym; auto.
                -- apply Permutation_length in Hl'; simpl in Hl' |- *; lia.
                -- apply Permutation_length in Hl'.
                   apply Permutation_length in H4.
                   simpl in Hl', H4; lia.
  Qed.

  Theorem finite_pigeon_hole l m : length l < length m -> incl m l -> list_has_dup m.
  Proof.
    intros H1 H2.
    destruct (@length_le_and_incl_implies_dup_or_perm l m) as [ | H5 ];
      auto; [ | apply Permutation_length in H5 ]; lia.
  Qed.

End finite_php.


Require Import Bool List.

Set Implicit Arguments.

Inductive exp: Set :=
| Nat: nat -> exp
| Bool: bool -> exp
| Plus: exp -> exp -> exp
| And: exp -> exp -> exp.

Check Plus (Bool true) (Nat 8).

Inductive type := TNat | TBool.

Inductive hasType : exp -> type -> Prop :=
| HtNat : forall n, hasType (Nat n) TNat
| HtPlus : forall e1 e2,
   hasType e1 TNat ->
   hasType e2 TNat ->
   hasType (Plus e1 e2) TNat
| HtBool : forall b, hasType (Bool b) TBool
| HtAnd : forall e1 e2,
   hasType e1 TBool ->
   hasType e2 TBool ->
   hasType (And e1 e2) TBool.

Hint Constructors hasType.

Definition eq_type_dec :
    forall t1 t2 : type, {t1 = t2} + {t1 <> t2}.
  decide equality.
Defined.

Lemma hasType_det : forall e t1,
    hasType e t1 -> forall t2, hasType e t2 -> t1 = t2.
  induction 1; inversion 1; auto.
Qed.

Hint Resolve hasType_det.

(* Awful completely unstructured proof *)
Definition typeCheck_awful : forall e , {t | hasType e t} + {forall t, ~ hasType e t}.
  induction e.
  left.
  exists TNat. auto.
  left.
  exists TBool. auto.
  destruct IHe1; destruct IHe2.
  destruct s. destruct x. destruct s0. destruct x.

  left. exists TNat. auto.

  right. intros. intro. inversion H.
  assert(TNat = TBool). eauto. discriminate.

  right. intros. intro. inversion H.
  assert(TNat = TBool). eauto. discriminate.

  right. intros. intro. inversion H. eapply n. apply H4.

  right. intros. intro. inversion H. eapply n. apply H2.

  right. intros. intro. inversion H. eapply n. apply H2.

  destruct IHe1; destruct IHe2.
  destruct s. destruct x. destruct s0.  destruct x.

  right. intros. intro. inversion H.
  assert (TBool=TNat). eauto. discriminate.

  right. intros. intro. inversion H.
  assert (TBool=TNat). eauto. discriminate.

  destruct s0. destruct x.

  right. intros. intro. inversion H.
  assert (TBool=TNat). eauto. discriminate.

  left. exists TBool. auto.

  right. intros. intro. inversion H. eapply n. eapply H4.

  right. intros. intro. inversion H. eapply n. eapply H2.

  right. intros. intro. inversion H. eapply n. eapply H2.
Defined.

Definition typeCheck :
   forall e , {t | hasType e t} + {forall t, ~ hasType e t}.
refine(fix F (e:exp): {t | hasType e t} + {forall t, ~ hasType e t} :=
   match e return {t | hasType e t} + {forall t, ~ hasType e t} with
  | Nat n => inleft _ (exist _ TNat _)
  | Bool b => inleft _ (exist _ TBool _)
  | Plus e1 e2 =>
    match F e1 with
    | inright _ => inright _ _
    | inleft (exist t1 _) =>
        match F e2 with
        | inright _ => inright _ _
        | inleft (exist t2 _) =>
           match eq_type_dec t1 TNat with
           | left _ => match eq_type_dec t2 TNat with
                       | left _ => inleft _ (exist _ TNat _)
                       | right _ => inright _ _
                       end
           | right _ => inright _ _
           end
        end
    end
  | And e1 e2 => _
  end).
  auto. auto.
  rewrite e0 in h.
  rewrite e3 in h0.
  auto.

  intros. intro. inversion H. apply n.
  inversion h0. auto. auto.
  inversion H4; inversion h0; congruence.
  inversion H4; inversion h0; congruence.
  auto.
  intros. intro. apply n.
  inversion H; inversion h; auto.
  inversion H2; inversion h; congruence.
  inversion H2; inversion h; congruence.

  intros. intro. eapply n. inversion H. apply H4.
  intros. intro. eapply n. inversion H. apply H2.

Admitted.

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

Eval compute in typeCheck (Plus (Bool true) (Nat 8)).

Eval compute in typeCheck (Plus (Nat 6) (Nat 8)).

Notation "e1 ;;; e2" := (if e1 then e2 else !!)
  (right associativity, at level 60).

Notation "x <-- e1 ; e2" := (match e1 with
                               | inright _ => !!
                               | inleft (exist x _) => e2
                             end)
(right associativity, at level 60).

Definition typeCheck' : forall e : exp, {t : type | hasType e t} + {forall t, ~ hasType e t}.
  refine (fix F (e : exp) : {t : type | hasType e t} + {forall t, ~ hasType e t} :=
    match e return {t : type | hasType e t} + {forall t, ~ hasType e t} with
      | Nat _ => [||TNat||]
      | Plus e1 e2 =>
        t1 <-- F e1;
        t2 <-- F e2;
        eq_type_dec t1 TNat;;;
        eq_type_dec t2 TNat;;;
        [||TNat||]
      | Bool _ => [||TBool||]
      | And e1 e2 =>
        t1 <-- F e1;
        t2 <-- F e2;
        eq_type_dec t1 TBool;;;
        eq_type_dec t2 TBool;;;
        [||TBool||]
    end).

Admitted.


Require Import Coq.Classes.Morphisms.
Require Import Coq.setoid_ring.Ring.
Require Import Coq.setoid_ring.Ring_theory.
Require Import Coq.Setoids.Setoid.

Require Import CoqStock.DubStep.
Require Import CoqStock.Invs.
Require Import CoqStock.List.
Require Import CoqStock.Listerine.
Require Import CoqStock.Untie.
Require Import CoqStock.WreckIt.

Require Import Brzozowski.Alphabet.
Require Import Brzozowski.Language.
Require Import Brzozowski.LogicOp.
Require Import Brzozowski.Regex.
Require Import Brzozowski.Setoid.
Require Import Brzozowski.Simplify.

(* TODOs in this file
   Some are theorems that need to be proven or simply applied from Simplify.v
   Other parts are uncommentable once the theorems are proven.
*)

Theorem or_lang_emptyset_l:
  forall n : lang, or_lang emptyset_lang n {<->} n.
Proof.
exact or_lang_emptyset_l_is_r.
Qed.

Theorem or_lang_comm:
  forall n m : lang, or_lang n m {<->} or_lang m n.
Proof.
intros.
split; intros; constructor; invs H; invs H0; auto.
Qed.

Theorem or_lang_assoc:
  forall n m p : lang, or_lang n (or_lang m p) {<->} or_lang (or_lang n m) p.
Proof.
intros.
split; intros; invs H. invs H0; apply mk_or.
- left. apply mk_or. auto.
- invs H. invs H0.
  + left. apply mk_or. auto.
  + right. assumption.
- apply mk_or.
  invs H0.
  + invs H.
    invs H0.
    * left. assumption.
    * right. apply mk_or. auto.
  + right. apply mk_or. auto.
Qed.

Theorem and_lang_neg_emptyset_l:
  forall n : lang, and_lang (neg_lang emptyset_lang) n {<->} n.
Proof.
intros.
split; intros.
- invs H. invs H0. assumption.
- constructor. split.
  + constructor.
    untie.
  + assumption.
Qed.

Theorem and_lang_emptyset_l:
  forall n : lang, and_lang emptyset_lang n {<->} emptyset_lang.
Proof.
intros.
split; intros.
- invs H.
  invs H0.
  invs H.
- invs H.
Qed.

Theorem and_lang_comm:
  forall n m : lang, and_lang n m {<->} and_lang m n.
Proof.
intros.
split; intros.
- constructor.
  invs H.
  invs H0.
  constructor; assumption.
- constructor.
  invs H.
  invs H0.
  constructor; assumption.
Qed.

Theorem and_lang_assoc:
  forall n m p : lang,
  and_lang n (and_lang m p) {<->} and_lang (and_lang n m) p.
Proof.
intros.
split; intros.
- invs H.
  invs H0.
  invs H1.
  invs H0.
  constructor.
  split.
  + split.
    auto.
  + assumption.
- invs H.
  invs H0.
  invs H.
  invs H0.
  constructor.
  split.
  + assumption.
  + constructor.
    split; assumption.
Qed.

Theorem and_lang_or_lang_distrib_l:
  forall n m p : lang,
  and_lang (or_lang n m) p {<->} or_lang (and_lang n p) (and_lang m p).
Proof.
intros. split; intros.
- invs H. invs H0. invs H.
  constructor.
  invs H0.
  + left.
    constructor.
    auto.
  + right.
    constructor.
    auto.
- invs H.
  constructor.
  invs H0.
  + split.
    * constructor.
      left.
      invs H.
      invs H0.
      assumption.
    * invs H.
      invs H0.
      assumption.
  + invs H.
    invs H0.
    split.
    * constructor.
      right.
      assumption.
    * assumption.
Qed.

Lemma lang_semi_ring:
  semi_ring_theory emptyset_lang (neg_lang emptyset_lang) or_lang and_lang (lang_iff).
Proof.
constructor.
- exact or_lang_emptyset_l.
- exact or_lang_comm.
- exact or_lang_assoc.
- exact and_lang_neg_emptyset_l.
- exact and_lang_emptyset_l.
- exact and_lang_comm.
- exact and_lang_assoc.
- exact and_lang_or_lang_distrib_l.
Qed.

Lemma Eq_lang_s_ext: sring_eq_ext or_lang and_lang lang_iff.
Proof.
constructor.
- exact or_lang_morph_Proper.
- exact and_lang_morph_Proper.
Qed.

Add Ring lang_semi_ring: lang_semi_ring
  (abstract, setoid lang_setoid Eq_lang_s_ext).

Lemma or_lang_diag: forall b: lang,
  or_lang b b {<->} b.
Proof.
intros.
split; intros.
- invs H.
  invs H0; assumption.
- constructor.
  left.
  assumption.
Qed.

Lemma or_lang_false_r: forall b:lang,
  or_lang b emptyset_lang {<->} b.
Proof.
intros.
split; intros.
- invs H. invs H0.
  + assumption.
  + invs H.
- constructor.
  left.
  assumption.
Qed.

Lemma or_lang_false_l: forall b:lang,
  or_lang emptyset_lang b {<->} b.
Proof.
intros.
split; intros.
- invs H.
  invs H0.
  + invs H.
  + assumption.
- constructor.
  right.
  assumption.
Qed.

Lemma or_lang_true_r: forall b:lang,
  or_lang b (neg_lang emptyset_lang) {<->} neg_lang emptyset_lang.
Proof.
intros.
split; intros.
- constructor.
  untie.
- constructor.
  right.
  constructor.
  untie.
Qed.

Lemma or_lang_true_l: forall b:lang,
  or_lang (neg_lang emptyset_lang) b {<->} neg_lang emptyset_lang.
Proof.
intros.
split; intros.
- constructor.
  untie.
- constructor.
  left.
  constructor.
  untie.
Qed.

(*
truthy is a tactic that repeatedly applies:
  - the semi ring with or_lang tactic
  - removes duplicates in or_lang expressions
  - removes all emptyset values in or_lang expressions
  - returns neg (emptyset), if a neg (emptyset) is found in an or expression
*)
Ltac truthy := repeat
  ( ring
  || rewrite or_lang_diag
  || rewrite or_lang_false_r
  || rewrite or_lang_false_l
  || rewrite or_lang_true_r
  || rewrite or_lang_true_l
  ).

Example example_or_lang_commutativity: forall (a b: lang),
  or_lang a b {<->} or_lang b a.
Proof.
intros.
ring.
Qed.

Example example_or_lang_idempotency_1: forall (a b: lang),
  or_lang a (or_lang a b) {<->} or_lang a b.
Proof.
intros.
(* TODO: Help Wanted
   ring/truthy does not solve this,
   but does solve it in CoqStock/Truthy.v
*)
Abort.

Example example_or_lang_idempotency_2: forall (a b: lang),
  or_lang (or_lang a b) a {<->} or_lang a b.
Proof.
intros.
(* TODO: Help Wanted
   ring/truthy does not solve this,
   but does solve it in CoqStock/Truthy.v
*)
Abort.

Example example_or_associativity_1: forall (a b c: lang),
  or_lang (or_lang a b) c {<->} or_lang a (or_lang b c).
Proof.
intros.
ring.
Qed.

Example example_or_associativity_2: forall (a b c: lang),
  or_lang a (or_lang b c) {<->} or_lang b (or_lang a c).
Proof.
intros.
ring.
Qed.

Example example_or_3: forall (a b c: lang),
  or_lang a (or_lang b (or_lang a c)) {<->} or_lang a (or_lang b c).
Proof.
intros.
(* TODO: Help Wanted
   ring/truthy does not solve this,
   but does solve it in CoqStock/Truthy.v
*)
Abort.

Example example_or_4: forall (a b c d: lang),
  or_lang a (or_lang b (or_lang c d)) {<->}
  or_lang a (or_lang d (or_lang b (or_lang c d ))).
Proof.
intros.
(* TODO: Help Wanted
   ring/truthy does not solve this,
   but does solve it in CoqStock/Truthy.v
*)
Abort.

Example example_or_false: forall (a: lang),
  or_lang a emptyset_lang {<->} a.
Proof.
intros.
ring.
Qed.

Example example_or_true: forall (a: lang),
  or_lang (neg_lang emptyset_lang) a {<->} neg_lang emptyset_lang.
Proof.
intros.
truthy.
Qed.


(* 4.1 enum: 値の列挙 に関連して *)

From mathcomp Require Import all_ssreflect.

(* mem_pred の引数は T ではないようだ。 *)
Definition enum_mem' T (mA : mem_pred _) := filter mA (Finite.EnumDef.enum T).

(*
Definition enum' A := (enum_mem' _ (mem A)).
これはエラーになる。「_」に A を書いてはいけない。
 *)
Notation enum' A := (enum_mem' _ (mem A)).

Check enum_mem' : forall T : finType, mem_pred T -> seq T.
(*
Check enum' : forall A : finType, seq A.
*)

Compute enum bool_finType.
Compute enum (ordinal_finType 3).

Check (enum_mem (mem [:: false])).
Check enum [:: false].

Compute enum' bool_finType.
Compute enum' (ordinal_finType 3).

Check (enum_mem' _ (mem [:: false])).
Check enum' [:: false].

(* END *)

(* #|T| = size (enum T) *)
Lemma cardT : forall A : finType, card (mem A) = size (enum A).
Proof.
  move=> A.
  by rewrite cardE.
Qed.

Check @inord 4 3 : 'I_5.
Check inord 3 : 'I_5.

(* ord_enum の定義について *)
Definition ord_enum (n : nat) : seq 'I_n := pmap insub (iota 0 n).
Check ord_enum 5.

Check @insub : forall (T : Type) (P : pred T) (sT : subType (T:=T) P), T -> option sT.
Check (fun i => i < 3) : pred nat.

Definition test (n : nat) : option 'I_n :=
  @insub nat (fun i => i < n) (ordinal_subType n) n.
Definition test' (n : nat) : option 'I_n := insub n.

Print test.
Check test 3. (* option 'I_3. *)

(* END *)


From mathcomp Require Import all_ssreflect all_algebra.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Import GRing.Theory.
Local Open Scope ring_scope.

(** -------------------------------------------- *)
(** #
#

* Linear algebra in mathematical components

Extensive documentation in the header of:
 - the library #matrix#
 - and the library #mxalgebra#

* Roadmap for the lesson:
 - definition of matrices
 - main theorems
 - help with depend types
 - vector spaces as matrices

*)
Module DefinitionMatrices.
(** #
# *)
(** -------------------------------------------- *)
(** #
#

* Defining Matrices

(Credits "ITP 2013 tutorial: The Mathematical Components library" by Enrico Tassi and Assia Mahboubi #material here#)

*)
Reserved Notation "''M[' R ]_ n"    (at level 8, n at level 2, format "''M[' R ]_ n").
Reserved Notation "''M[' R ]_ ( m , n )" (at level 8, format "''M[' R ]_ ( m ,  n )").

Reserved Notation "\matrix_ ( i , j ) E"
  (at level 36, E at level 36, i, j at level 50,
   format "\matrix_ ( i ,  j )  E").

Reserved Notation "x %:M"   (at level 8, format "x %:M").
Reserved Notation "A *m B" (at level 40, left associativity, format "A  *m  B").
Reserved Notation "A ^T"    (at level 8, format "A ^T").
Reserved Notation "\tr A"   (at level 10, A at level 8, format "\tr  A").
(**

** A matrix is a 2-dimension array

*)
Inductive matrix (R : Type) (m n : nat) : Type :=
  Matrix of {ffun 'I_m * 'I_n -> R}.
(**

Some notations : size inside parentheses, type of coefficients inside
square brackets. NB: In the library, the type of coefficients can also
be ommitted.

*)
Notation "''M[' R ]_ ( m , n )" := (matrix R m n) : type_scope.
Notation "''M[' R ]_ n" := 'M[R]_(n, n) : type_scope.

(* Test *)
Check 'M[nat]_(2,3).
Check 'M[nat]_2.
(**

"matrix" is just a tag over ffun: it inherits from its structure We
can "transfer" automatically all structures from the type of finite
functions by "trivial subTyping".

*)
Definition mx_val R m n (A : 'M[R]_(m,n)) : {ffun 'I_m * 'I_n -> R} :=
  let: Matrix g := A in g.

Canonical matrix_subType R m n :=
  Eval hnf in [newType for @mx_val R m n].

Definition matrix_eqMixin (R : eqType) m n :=
  Eval hnf in [eqMixin of 'M[R]_(m, n) by <:].
Canonical matrix_eqType (R : eqType) m n:=
  Eval hnf in EqType 'M[R]_(m, n) (matrix_eqMixin R m n).
Definition matrix_choiceMixin (R : choiceType) m n :=
  [choiceMixin of 'M[R]_(m, n) by <:].
Canonical matrix_choiceType (R : choiceType) m n :=
  Eval hnf in ChoiceType 'M[R]_(m, n) (matrix_choiceMixin R m n).
Definition matrix_countMixin (R : countType) m n :=
  [countMixin of 'M[R]_(m, n) by <:].
Canonical matrix_countType (R : countType) m n :=
  Eval hnf in CountType 'M[R]_(m, n) (matrix_countMixin R m n).
Canonical matrix_subCountType (R : countType) m n :=
  Eval hnf in [subCountType of 'M[R]_(m, n)].
Definition matrix_finMixin (R : finType) m n :=
  [finMixin of 'M[R]_(m, n) by <:].
Canonical matrix_finType (R : finType) m n :=
  Eval hnf in FinType 'M[R]_(m, n) (matrix_finMixin R m n).

(**
Test overloaded "_ == _" notation
*)
Check [eqType of 'M[nat]_2].
Check forall A : 'M[nat]_2, A == A.
(**

Since matrices over nat are comparable with _ == _, matrices over
matrices over nat are also comparable

*)
Check forall AA : 'M[ 'M[nat]_3 ]_2, AA == AA.
(**

We define a coercion in order to access elements as if matrices were
functions.

*)
Definition fun_of_mx R m n (A : 'M[R]_(m,n)) : 'I_m -> 'I_n -> R :=
fun i j => mx_val A (i, j).  Coercion fun_of_mx : matrix >-> Funclass.

Check forall (A : 'M[nat]_3) i j, A i j == 37.
(**

We provide a notation to build matrices from a general term.

*)
Definition mx_of_fun R m n (F : 'I_m -> 'I_n -> R) : 'M[R]_(m,n) :=
  Matrix [ffun ij => F ij.1 ij.2].
Notation "\matrix_ ( i , j ) E" := (mx_of_fun (fun i j => E))
  (at level 36, E at level 36, i, j at level 50) : ring_scope.

Check \matrix_(i,j) (i - j)%N  :  'M[nat]_(3,4).

End DefinitionMatrices.

Module MatrixProperties.
(** #
# *)
(** -------------------------------------------- *)
(** #
#

* Main Theorems

We now show the most used theorems for matrix manipulation.

** mxE

mxE is an equation to compute a term in the matrix at given
coordinates: it extracts the general term of the matrix and compute
the substitution of indexes. It is generally the right move when you
have
(A complicated matrix) i j
 in your goal.

*)
Check mxE.
(**

** matrixP

matrixP is the "extensionality theorem" for matrices, it says two
matrices are equal if and only if all their coefficients are pairwise
equal.

*)
Check matrixP.
(** #
# *)
(** -------------------------------------------- *)
(** #
#

** operations on matrices

*** specific operation: trace and transpose

(do not confuse the names)

*)
Print mxtrace.
Locate "\tr".

Print trmx.
Locate "^T".
(**

*** specific operation scalar matrix

*)
Print scalar_mx.
Locate "%:M".
(**

*** matrices on rings are provided with a R-module canonical structure.

But not a ring as the multiplication is heterogeneous.

*)
Lemma test1 (R : ringType) m n (A B : 'M[R]_(m,n)) : A + B = B + A.
Proof. exact: addrC. Qed.

Print mulmx.

Lemma test2 (R : ringType) m n (a : R) (A : 'M[R]_(m,n)) : a *: A = a%:M *m A.
Proof. by rewrite mul_scalar_mx. Qed.
(**

*** square matrices with explicit non zero size have a ring canonical structure.

This ring product coincides with the matrix product.

*)
Lemma test3 (R : ringType) n (A B : 'M[R]_n.+1) : A * B = A *m B.
Proof. reflexivity. Qed.
(**

*** specific operation: the determinant.

*)
Print determinant.
Locate "\det".
(**

*** square matrices on a commutative unit ring with explicit non zero size have a unit ring canonical structure.

and these notions of inversibility are definitionally equivalent.
*)
Lemma test4 (R : comUnitRingType) n (A : 'M[R]_n.+1) :
  (unitmx A) = (A \is a GRing.unit)
  /\ (A \is a GRing.unit) = (\det A \is a GRing.unit).
Proof. split; reflexivity. Qed.

End MatrixProperties.
(** #
# *)
(** -------------------------------------------- *)
(** #
#

* SUB VECTOR SPACES AS MATRICES

** General understanding

 - A specificity of the mathematical components library is to allow to
  reason on matrices as if they represented their own image.

 - The doc and the code are in #mxalgebra#)

 - rows can be seen as vectors, and matrix can be seen as the familiy
  of its row vectors.

 - #WARNING# Following the english convention (which is
    opposite to the french convention), composition/application of
    linear maps represented by matrices should be done left to right:
    applying A to u is
u *m A
.

 - the scope MS (matrix space) contains all notions about this vision
   of matrices (comparison, addition, intersection of spaces).

 - as a consequence, membership to a space is the same operation as
   comparison of spaces.

*** the rank of a matrix is also the dimension of the space it represents

*)
Locate "\rank".
About mxrank.
(**

*** Inclusion can be used both for elements (row vectors) and subspaces (matrices).

*)
Locate "_ <= _".
About submx.
(**

*** The total space is represented by 1, and the trivial space by 0.

*)
About submx1.
About sub1mx.
About sub0mx.
About submx0.
(**

*** Addition of subspaces is not the same thing as addition of matrices.
(In Coq: same notation, different scope)

*)
Locate "_ + _".
About addsmx.
(**

*** Intersection of subspaces

*)
Locate "_ :&: _".
About capmx.
About sub_capmx.
(**

*** Equality of subspaces is double inclusion.

Alternatively, the library provides an equivalent definition (via
eqmxP) that can be used for rewriting in inclusion statements or rank.

*)
Locate "_ == _".
Check (_ == _)%MS.

Locate "_ :=: _".
About eqmx.
Print eqmx.

About mxdirectE.
About mxdirect_addsP.
(** #
# *)
(** -------------------------------------------- *)
(** #
#

** Usage.

 - Im A is represented by the matrix A itself.

 - vectors of a space represented by the matrix A are linear
   combinations of the rows of A, which amount to making a product by
   an element (i.e. row of coefficients, or coordinates in the family
   generated by A) on the left.

*)
About submxP.
About row_subP.
About submxMl.
(**

 - Ker A is represented by the square matrix kermx A.
*)
About kermx.
About sub_kermxP.
(** #
# *)
(** -------------------------------------------- *)
(** #
#
Let's do an example together

*)
Section ex_6_12.

Variables (F : fieldType) (n' : nat).
Let n := n'.+1.
Variable (u : 'M[F]_n) (S : 'M[F]_n).
Hypothesis eq_keru_imu : (kermx u :=: u)%MS.
Hypothesis S_u_direct : (S :&: u)%MS = 0.
Hypothesis S_u_eq1 : (S + u :=: 1)%MS.
Implicit Types (x y z : 'rV[F]_n).

Lemma Su_rect x : exists2 yz, x = yz.1 + yz.2 *m u
                              & (yz.1 <= S)%MS && (yz.2 <= S)%MS.
Proof.
pose y := x *m proj_mx S u.
have /submxP [z'] := proj_mx_sub u S x => xpu.
pose z := z' *m proj_mx S u.
exists (y, z) => /=; last by rewrite !proj_mx_sub.
rewrite -{1}(@add_proj_mx _ _ _ S u x) ?S_u_direct ?S_u_eq1 ?submx1 //.
congr (_ + _); apply/eqP; rewrite xpu -subr_eq0 -mulmxBl.
apply/eqP/sub_kermxP.
by rewrite eq_keru_imu proj_mx_compl_sub ?S_u_eq1 ?submx1.
Qed.

Lemma Su_dec_eq0 y z : (y <= S)%MS -> (z <= S)%MS ->
  (y + z *m u == 0) = (y == 0) && (z == 0).
Proof.
move=> yS zS; apply/idP/idP; last first.
  by move=> /andP[/eqP -> /eqP ->]; rewrite add0r mul0mx.
rewrite addr_eq0 -mulNmx => /eqP eq_y_Nzu.
have : (y <= S :&: u)%MS by rewrite sub_capmx yS eq_y_Nzu submxMl.
rewrite S_u_direct // submx0 => /eqP y_eq0.
move/eqP: eq_y_Nzu; rewrite y_eq0 eq_sym mulNmx oppr_eq0 eqxx /= => /eqP.
move=> /sub_kermxP; rewrite eq_keru_imu => z_keru.
have : (z <= S :&: u)%MS by rewrite sub_capmx zS.
by rewrite S_u_direct // submx0.
Qed.

End ex_6_12.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** Decidability results about lists *)

Require Import List Decidable.
Set Implicit Arguments.

Definition decidable_eq A := forall x y:A, decidable (x=y).

Section Dec_in_Prop.
Variables (A:Type)(dec:decidable_eq A).

Lemma In_decidable x (l:list A) : decidable (In x l).
Proof using A dec.
 induction l as [|a l IH].
 - now right.
 - destruct (dec a x).
   + left. now left.
   + destruct IH; simpl; [left|right]; tauto.
Qed.

Lemma incl_decidable (l l':list A) : decidable (incl l l').
Proof using A dec.
 induction l as [|a l IH].
 - left. inversion 1.
 - destruct (In_decidable a l') as [IN|IN].
   + destruct IH as [IC|IC].
     * left. destruct 1; subst; auto.
     * right. contradict IC. intros x H. apply IC; now right.
   + right. contradict IN. apply IN; now left.
Qed.

Lemma NoDup_decidable (l:list A) : decidable (NoDup l).
Proof using A dec.
 induction l as [|a l IH].
 - left; now constructor.
 - destruct (In_decidable a l).
   + right. inversion_clear 1. tauto.
   + destruct IH.
     * left. now constructor.
     * right. inversion_clear 1. tauto.
Qed.

End Dec_in_Prop.

Section Dec_in_Type.
Variables (A:Type)(dec : forall x y:A, {x=y}+{x<>y}).

Definition In_dec := List.In_dec dec. (* Already in List.v *)

Lemma incl_dec (l l':list A) : {incl l l'}+{~incl l l'}.
Proof using A dec.
 induction l as [|a l IH].
 - left. inversion 1.
 - destruct (In_dec a l') as [IN|IN].
   + destruct IH as [IC|IC].
     * left. destruct 1; subst; auto.
     * right. contradict IC. intros x H. apply IC; now right.
   + right. contradict IN. apply IN; now left.
Qed.

Lemma NoDup_dec (l:list A) : {NoDup l}+{~NoDup l}.
Proof using A dec.
 induction l as [|a l IH].
 - left; now constructor.
 - destruct (In_dec a l).
   + right. inversion_clear 1. tauto.
   + destruct IH.
     * left. now constructor.
     * right. inversion_clear 1. tauto.
Qed.

End Dec_in_Type.

(** An extra result: thanks to decidability, a list can be purged
    from redundancies. *)

Lemma uniquify_map A B (d:decidable_eq B)(f:A->B)(l:list A) :
 exists l', NoDup (map f l') /\ incl (map f l) (map f l').
Proof.
 induction l.
 - exists nil. simpl. split; [now constructor | red; trivial].
 - destruct IHl as (l' & N & I).
   destruct (In_decidable d (f a) (map f l')).
   + exists l'; simpl; split; trivial.
     intros x [Hx|Hx]. now subst. now apply I.
   + exists (a::l'); simpl; split.
     * now constructor.
     * intros x [Hx|Hx]. subst; now left. right; now apply I.
Qed.

Lemma uniquify A (d:decidable_eq A)(l:list A) :
 exists l', NoDup l' /\ incl l l'.
Proof.
 destruct (uniquify_map d id l) as (l',H).
 exists l'. now rewrite !map_id in H.
Qed.


Require Import Function.
Require Import Functor.

Class Applicative (F: Type -> Type) := {
    (* It must also be a functor *)
    is_functor :> Functor F;

    (* functions *)
    unit : forall {A : Type}, A -> F A;
    apply : forall {A B : Type}, F (A -> B) -> F A -> F B;

    (* laws *)
    unit_identity
        : forall (A : Type) (x : F A), apply (unit id) x = x;

    unit_compose
        : forall (A B C : Type) (u : F (B -> C)) (v : F (A -> B)) (w : F A)
        , apply (apply (apply (unit compose) u) v) w = apply u (apply v w);

    unit_homomorphism
        : forall (A B : Type) (f : A -> B) (x : A)
        , apply (unit f) (unit x) = unit (f x);

    unit_interchange
        : forall (A B : Type) (u : F (A -> B)) (x : A)
        , apply u (unit x) = apply (unit (fun (f : A -> B) => f x)) u;

    unit_fmap
        : forall (A B : Type) (f : A -> B) (x : F A)
        , fmap f x = apply (unit f) x
}.

Notation "v <*> w" := (apply v w) (at level 50).

Theorem fmap_unit
    : forall (F : Type -> Type) (app_dict : Applicative F) (A B : Type) (f : A -> B) (x : A)
    , fmap f (unit x) = unit (f x).
Proof.
    intros.
    rewrite -> unit_fmap.
    rewrite -> unit_interchange.
    rewrite -> unit_homomorphism.
    reflexivity.
Qed.


(******************************************************************************)
(** This file provide a theory for simultaneous games

   1. Profiles
   A profile assign a strategy (ai : A i) to each player (i : I)
   We distinguish:
   - Profiles for complete games : forall i, A i
   - Profiles for incomplete games : forall i, T i -> A i
   - Local profiles for HG games: forall i, P i -> A i

   cprofile A          == {dffun forall i : I, A i}
   iprofile A T        == cprofile (fun i => {ffun T i -> A i})
   local_cprofile P A  == {ffun forall (s : {i : I | P i}), A (val s)}

   We then define:
   change_strategy A p i ai       == the cprofile p where (p i) has changed to ai
   change_istrategy T A p i ti ai == the iprofile p where (p i ti) has changed to ai,
   And prove:
   change_strategy_id A p i :       p = change_strategy p (p i).
   change_istrategy_id T A p i ti : p = change_istrategy p ti (p i ti).

   Finally, we cast/project profiles with:
   iprofile_flatten T A p          == flatten (p : iprofile T A) to a cprofile
                                      {dffun forall s : {i : I & T i}, A i}
   proj_iprofile T A p t :         == project (p : iprofile T A) according to (t : cprofile T)
                                      i.e. proj_iprofile T A p t i = p (t i) i
   proj_flatprofile T A p :        == project the flat profile p according to (t : cprofile T)
                                      i.e. proj_flatprofile T A p t i = p (existT T i (t i))
   proj_flatlocalprofile T A P f p == project the flat local profile p according to f
                                      i.e. proj_flatlocalprofile T A P f p i = p (f i)

   And we prove:
   proj_iprof_flatprof T Y p t :
     proj_iprofile p t = proj_flatprofile (iprofile_flatten p) t.
   change_strat_istrat T A p i_ti ai :
     change_strategy (iprofile_flatten p) ai = iprofile_flatten (change_istrategy p (projT2 i_ti) ai).

   2. Games
   2.1. Complete games -- they are fully specified by their utility functions
   cgame R A                       == cprofile A -> I -> R (the type of complete games)
   Nash_equilibrium_bool G p       == true iff there is no (i : I) such as there is no (ai : A i)
                                      such that (G p i) < (G p (change_strategy p i ai))
   Nash_equilibrium G p            == True iff there is no (i : I) such as there is no (ai : A i)
                                      such that (G p i) < (G p (change_strategy p i ai))
   Nash_equilibriumP G p           == reflect (Nash_equilibrium G p) (Nash_equilibrium_bool G p)

   2.2. Hypergraphical games -- Particular sort of complete game where utility functions are
        decomposed into several local games. We index local games with (local_game : finType)
        and check whether (i : I) plays in (lg : local_game) using (plays_in : lg -> pred I).
        let localprof := (fun lg : localgame => local_cprofile action (plays_in lg))
        and localagent := (fun lg => {i | plays_in lg i}) in

   hg_game (u : forall lg, localprof lg -> localagent lg -> R)
      == fun a i => \sum_(s : {lg : localgame | plays_in lg i})
                      u (tag s) [ffun i => a (val i)] (exist _ i (tagged s)).
      == the complete game where utility functions are defined locally according to u

   Then we prove:
   hg_gameE u a i == \sum_(lg | plays_in lg i)
                         match boolP (plays_in lg i) with
                         | AltTrue h => u lg [ffun j => a (val j)] (exist (plays_in lg) i h)
                         | AltFalse _ => 0
                         end.

   3. BelGames -- Incomplete games where the knowledge is captured by a belief function.
   belgame R T                == ((bpa R (cprofile T)) * (profile -> (cprofile T) -> i -> R))
   proper_belgame G cond      == One can condition given (ti : T i) for all agent (i : I)
                                 according to (cond : conditioning (cprofile T))
   belgame_utility G cond xeu H p i == utility of p for i, according to the scoring function xeu,
                                 given that (H : proper_belgame G cond)
   BelG_Nash_equilibrium_bool G cond xeu H p
                              == true iff p is a Nash equilibrium according to (belgame_utility G cond xeu H p)
                                 i.e. there is no (i : I) such that there is no (ti : T i) such
                                 that there is no (ai : A i) such that (belgame_utility G cond xeu H p i)
                                 < (belgame_utility G cond xeu H (change_istrategy T A p i ti ai) i)
  BelG_Nash_equilibrium G cond xeu H p
  BelG_Nash_equilibriumP G cond xeu H p

  4. Mixed strategy profiles
  We show that they are descriptible by their mixed-extension
 *)
(******************************************************************************)
From Coq Require Import ssreflect.
From mathcomp Require Import all_ssreflect. (* .none *)
From mathcomp Require Import all_algebra. (* .none *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing GRing.Theory.
Import Num.Theory.

Require Import general_lemmas bel.

Local Open Scope ring_scope.

Section Profile.

  Implicit Types I : finType.

  Definition cprofile I (A : I -> eqType)
    := {dffun forall i : I, A i}.

  Definition iprofile I (A : I -> eqType) (T : I -> finType)
    := cprofile (fun i => [eqType of {ffun T i -> A i}]).

  Definition change_strategy I A (p : cprofile A) (i : I) (a'_i : A i) : cprofile A
    := [ffun j => match boolP (i == j) with
                  | AltTrue h => eq_rect _ A a'_i _ (eqP h)
                  | AltFalse _ => p j
                  end].

  Lemma change_strategy_id I A (p : cprofile A) (i : I) :
    p = change_strategy p (p i).
  Proof.
  apply ffunP => j ; rewrite ffunE.
  case (boolP (i == j)) => // H.
  by rewrite f_equal_dep.
  Qed.

  Definition local_cprofile I (A : I -> eqType) (P : pred I) :=
    {ffun forall (s : {x : I | P x}), A (val s)}.

  (*| Transform an iprofile to a profile such as support is the set of dependent pairs (i,t_i) |*)
  Definition iprofile_flatten I (T : I -> finType) A (p : iprofile A T)
    : cprofile (fun i_ti => A (projT1 i_ti)) :=
    [ffun i_ti => p (projT1 i_ti) (projT2 i_ti)].

  (*| Profile that will be played if player's types are known |*)
  Definition proj_iprofile I (T : I -> finType) A (p : iprofile A T)
    : cprofile T -> cprofile A :=
    fun theta => [ffun i => p i (theta i)].

  Definition proj_flatprofile I (T : I -> finType) A
             (p : cprofile (fun i_ti => A (projT1 i_ti)))
    : cprofile T -> cprofile A :=
    fun theta => [ffun i => p (existT _ i (theta i))].

  Definition proj_flatlocalprofile
             I (T : I -> finType) (A : I -> eqType) (P : pred {i : I & T i})
             (HP : forall i : I, {ti : T i | P (existT _ i ti)})
             (p : local_cprofile (fun i_ti => A (projT1 i_ti)) P) : cprofile A
    := [ffun i : I =>
        let (ti, Hi_ti) := HP i in
        let x : sig_finType P := (exist P (existT T i ti) Hi_ti) in
        let ai : A i := p x in
        ai
       ].

  Lemma proj_iprof_flatprof I (T : I -> finType) A (p : iprofile A T) theta :
    (proj_iprofile p theta) = (proj_flatprofile (iprofile_flatten p) theta).
  Proof.
    by apply: eq_dffun => i; rewrite ffunE.
  Qed.

  Definition change_istrategy I T A (p : iprofile A T) (i : I) ti ai
    : iprofile A T :=
    [ffun j => [ffun tj => match boolP (i == j) with
                         | AltTrue h =>
                           let ti' := eq_rect _ T ti _ (eqP h) in
                           if ti' == tj
                           then eq_rect i A ai j (eqP h)
                           else p j tj
                         | AltFalse _ => p j tj
                         end]].

  Lemma change_istrategy_id I T A (p : iprofile A T) (i : I) (ti : T i) :
    p = change_istrategy p ti (p i ti).
  Proof.
  apply ffunP => j ; rewrite ffunE.
  apply ffunP => tj ; rewrite ffunE.
  case (boolP (i == j)) => Hj //=.
  case (boolP (eq_rect i _ ti j (eqP Hj) == tj)) => //= Htj.
  by rewrite (map_subst (fun j tj => p j tj)) (eqP Htj).
  Qed.

  Lemma change_strat_istrat I T A (p : iprofile A T) (i_ti : {i : I & T i})
        (ai : A (projT1 i_ti)) :
    (change_strategy (iprofile_flatten p) ai)
    = (iprofile_flatten (change_istrategy p (projT2 i_ti) ai)).
  Proof.
  apply eq_dffun => j_tj //=.
  rewrite !ffunE.
  case (boolP (@eq_op (Finite.eqType (tag_finType T)) i_ti j_tj)) => H1;
                   case (boolP (projT1 i_ti == projT1 j_tj)) => H2 //=.
  - case (boolP ((eq_rect _ _ (projT2 i_ti) (projT1 j_tj)  (@elimT
      (@eq (Finite.sort I) _ _) _ eqP H2)) == (projT2 j_tj))) => H3.
    + rewrite (rew_map A _ (eqP H1) ai).
      by rewrite (Eqdep_dec.eq_proofs_unicity
                    (@eqType_dec_prop I) (f_equal _ (eqP H1))(eqP H2)).
    + move/eqP in H3.
      have Hcontra := projT2_eq (eqP H1).
      by rewrite (Eqdep_dec.eq_proofs_unicity (@eqType_dec_prop I)
           (projT1_eq (eqP H1)) (eqP H2)) in Hcontra.
  - move/eqP in H2.
    by rewrite (eqP H1) in H2.
  - case (boolP ((eq_rect _ _ (projT2 i_ti) (projT1 j_tj)  (@elimT
        (@eq (Finite.sort I) _ _) _ eqP H2)) == (projT2 j_tj))) => H3 //.
    have Hcontra := eq_sigT i_ti j_tj (eqP H2) (eqP H3).
    by move/eqP in H1.
  Qed.

End Profile.

Section Games.

  Variable R : realFieldType.
  Variable I : finType. (* agents *)
  Implicit Type A : forall i : I, eqType.
  Implicit Type fA T : forall i : I, finType.

  Definition cgame A := cprofile A -> I -> R.

  Definition best_response_bool fA (G : cgame fA) (a : cprofile fA) (i : I) : bool
    := [forall ai : fA i, ~~ (G a i < G (change_strategy a ai) i)].

  Definition best_response A (G : cgame A) (a : cprofile A) (i : I) : Prop
    := forall ai : A i, ~ (G a i < G (change_strategy a ai) i).

  Lemma best_responseP fA (G : cgame fA) a i :
    reflect (best_response G a i) (best_response_bool G a i).
  Proof.
  case (boolP (best_response_bool G a i)) => H ; constructor.
  - move=> ai.
    move/forallP in H.
    exact: negP (H ai).
  - move=> Hcontra ; move: H.
    rewrite negb_forall => /existsP H.
    destruct H as [h Hx].
    move => /negPn in Hx.
    contradiction (Hcontra h).
  Qed.

  Definition Nash_equilibrium_bool fA (G : cgame fA) (a : cprofile fA) : bool :=
    [forall i : I,
      [forall ai : fA i,
        ~~ (G a i < G (change_strategy a ai) i)]].

  Definition Nash_equilibrium A (G : cgame A) (a : cprofile A) : Prop :=
    forall i : I, forall ai : A i, ~ (G a i < G (change_strategy a ai) i).

  Lemma Nash_equilibriumP fA G (a : cprofile fA) :
    reflect (Nash_equilibrium G a) (Nash_equilibrium_bool G a).
  Proof.
  case (boolP (Nash_equilibrium_bool G a)) => H ; constructor.
  - move => i ai.
    exact: negP (forallP (forallP H i) ai).
  - rewrite /Nash_equilibrium => Hcontra.
    destruct (forallPn H) as [i Hi].
    destruct (forallPn Hi) as [ai Hai].
    move /negPn in Hai.
    have Hcontra' := Hcontra i ai ; contradiction.
  Qed.

  Lemma Nash_equilibrium_best_response A G (a : cprofile A) :
    Nash_equilibrium G a <-> forall i, best_response G a i.
  Proof.
  by rewrite /Nash_equilibrium /best_response.
  Qed.

  Lemma Nash_equilibrium_best_response_bool fA G (a : cprofile fA) :
    Nash_equilibrium_bool G a = [forall i, best_response_bool G a i].
  Proof. by []. Qed.

  Section HypergraphicalGame.

    Variable A : I -> eqType.
    Variable localgame : finType.
    Variable plays_in : localgame -> pred I.
    Notation localprof := (fun lg : localgame => local_cprofile A (plays_in lg)).
    Notation localagent := (fun lg => {i | plays_in lg i}).

    Definition hg_game (u : forall lg, localprof lg -> localagent lg -> R) : cgame A
      := fun a i => \sum_(s : {lg : localgame | plays_in lg i}) u (tag s) [ffun i => a (val i)] (exist _ i (tagged s)).

    Lemma hg_gameE u a i :
      hg_game u a i = \sum_(lg : localgame | plays_in lg i)
                        match boolP (plays_in lg i) with
                        | AltTrue h => u lg [ffun i => a (val i)] (exist _ i h)
                        | AltFalse _ => 0
                        end.
    Proof.
    by rewrite /hg_game (sig_big_dep2 (fun t Ht => u t [ffun j => a (val j)] (exist _ i Ht))).
    Qed.

  End HypergraphicalGame.

  Section BelGame.

    Variable A : forall i : I, eqType.
    Variable T : forall i : I, finType.

    Notation Tn := [finType of {dffun forall i : I, T i}].

    Notation xeu_function W := ({ffun W -> R} -> {ffun {set W} -> R}) (only parsing).

    Definition belgame :=
      (bpa R Tn * (cprofile A -> Tn -> I -> R))%type.

    Definition proper_belgame (G : belgame) (cond : conditioning R Tn) : bool :=
      [forall i : I, [forall ti : T i, revisable cond G.1 (event_ti ti)]].

    Definition is_revisable (G : belgame) (cond : conditioning R Tn) (HG : proper_belgame G cond) i (ti : T i) :
      revisable cond G.1 (event_ti ti)
      := (forallP ((forallP HG) i)) ti.

    Definition belgame_utility (G : belgame) (cond : conditioning R Tn) (fXEU : xeu_function _) (HG : proper_belgame G cond) (p : iprofile A T) (i : I) (ti : T i) : R :=
        let kn := cond G.1 (event_ti ti) (is_revisable HG ti) in
        XEU kn (fXEU [ffun t => G.2 (proj_iprofile p t) t i]).

    Definition BelG_Nash_equilibrium (G : belgame) (cond : conditioning R Tn) fXEU (HG : proper_belgame G cond) (p : iprofile A T) : Prop :=
      forall i : I,
      forall ti : T i,
      forall ai : A i,
        ~ (belgame_utility fXEU HG p ti < belgame_utility fXEU HG (change_istrategy p ti ai) ti).

  End BelGame.

  Section BelGame2. (* assuming finite sets of actions *)

    Variable fA : forall i : I, finType.
    Variable T : forall i : I, finType.

    Notation Tn := [finType of {dffun forall i : I, T i}].

    Definition BelG_Nash_equilibrium_bool (G : belgame fA T) (cond : conditioning R Tn) fXEU (HG : proper_belgame G cond) (p : iprofile fA T) : bool :=
      [forall i : I,
        [forall ti : T i,
          [forall ai : fA i,
            ~~ (belgame_utility fXEU HG p ti < belgame_utility fXEU HG (change_istrategy p ti ai) ti)]]].

    Lemma BelG_Nash_equilibriumP (G : belgame fA T) cond fXEU (HG : proper_belgame G cond) p :
      reflect (BelG_Nash_equilibrium fXEU HG p) (BelG_Nash_equilibrium_bool fXEU HG p).
    Proof.
      case (boolP (BelG_Nash_equilibrium_bool fXEU HG p)) => H ; constructor.
      - move => i ti ai.
        exact: negP (forallP (forallP (forallP H i) ti) ai).
      - rewrite /BelG_Nash_equilibrium => Hcontra.
        destruct (forallPn H) as [i Hi].
        destruct (forallPn Hi) as [ti Hti].
        destruct (forallPn Hti) as [ai Hai].
        move /negPn in Hai.
        have Hcontra' := Hcontra i ti ai ; contradiction.
    Qed.

  End BelGame2.

  Section BGame.

    Notation Tconfig := (fun T => [finType of {ffun forall i : I, T i}]).

    Variable A : forall i : I, eqType.
    Variable T : forall i : I, finType.

    Notation Tn := [finType of {dffun forall i : I, T i}].

    Definition bgame :=
      (proba R Tn * (cprofile A -> Tn -> I -> R))%type.

    Definition proper_bgame (G : bgame) : bool :=
      [forall i : I, [forall ti : T i, Pr_revisable G.1 (event_ti ti)]].

    Definition is_Pr_revisable (G : bgame) (HG : proper_bgame G) i (ti : T i) :
      Pr_revisable G.1 (event_ti ti)
      := (forallP ((forallP HG) i)) ti.

    Definition belgame_of_bgame (G : bgame) : {G' : belgame A T | 1%N.-additive G'.1}
      := let (p,u) := G in match p with {| proba_val := m ; proba_ax := H|} => exist _ (m,u) H end.

    Definition bgame_of_belgame (sG : {G : belgame A T | 1%N.-additive G.1}) : bgame
      := let (G,H) := sG in let (m,u) := G in ({|proba_ax:=H|}, u).

    Lemma bgame_of_belgame_cancel :
      cancel bgame_of_belgame belgame_of_bgame.
    Proof. by do 2 case. Qed.

    Lemma belgame_of_bgame_cancel :
      cancel belgame_of_bgame bgame_of_belgame.
    Proof. by do 2 case. Qed.

    Definition bgame_utility (G : bgame) (HG : proper_bgame G) (p : iprofile A T) (i : I) (ti : T i) : R
      :=
      let kn := Pr_conditioning (is_Pr_revisable HG ti) in
      [EU of [ffun t => G.2 (proj_iprofile p t) t i] wrt kn].

  End BGame.
End Games.

Section MixedStrategies.

  Variable R : realFieldType.
  Variable I : finType.
  Variable A : I -> finType.

  Variable witnessI : I.

  Definition mixed_cprofile := cprofile (fun i => [eqType of proba R (A i)]).

  Definition ms_util (G : cgame R A) (mp : mixed_cprofile) (i : I) : R :=
    let pr := prod_proba mp witnessI in
    [EU of [ffun p => G p i] wrt pr].

  Definition ms_Nash_equilibrium (G : cgame R A) (mp : mixed_cprofile) : Prop :=
    forall i (si : proba R (A i)),
      ~ ms_util G mp i < ms_util G (change_strategy mp si) i.

  Definition mixed_cgame (G : cgame R A) : cgame R (fun i => [eqType of proba R (A i)])
    := fun mp i => ms_util G mp i.

  Lemma mixed_cgameE G mp i : ms_util G mp i = (mixed_cgame G) mp i.
  Proof. by []. Qed.

  Lemma ms_NashE (G : cgame R A) (mp : mixed_cprofile) :
    ms_Nash_equilibrium G mp <-> Nash_equilibrium (mixed_cgame G) mp.
  Proof.
  split => H i si.
  - by rewrite -!mixed_cgameE.
  - by rewrite mixed_cgameE.
  Qed.

End MixedStrategies.


Require Import Rat.

Local Open Scope rat.

Definition x := (1/2) * (3/4).
Print StdNat.posnat.

Definition rat_noproof r :=
match r with
RatIntro a b => (a, StdNat.posnatToNat b)
end.


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Problem(s):
    Provability in Hilbert-style calculi (HSC_PRV)
    Recognizing axiomatizations of Hilbert-style calculi (HSC_AX)

  HSC_PRV:
    Fix a list s₁,...,sₙ of formulae.
    Given a formula s, is [s₁,...,sₙ] ⊢ s derivable?

  HSC_AX:
    Given a list s₁,...,sₙ of formulae such that
    [a → b → a] ⊢ sᵢ is derivable for i = 1...n,
    is [s₁,...,sₙ] ⊢ a → b → a derivable?

  References:
    [1] Grigoriy V. Bokov: Undecidable problems for propositional calculi with implication.
      Logic Journal of the IGPL, 24(5):792–806, 2016. doi:10.1093/jigpal/jzw013
    [2] Andrej Dudenhefner, Jakob Rehof: Lower End of the Linial-Post Spectrum.
      TYPES 2017: 2:1-2:15. doi: 10.4230/LIPIcs.TYPES.2017.2
*)

Require Import List.
Import ListNotations.

(* propositional formulae s, t ::= a | s → t *)
Inductive formula : Set :=
  | var : nat -> formula
  | arr : formula -> formula -> formula.

(* substitute ζ t replaces each variable n in t by ζ n *)
Fixpoint substitute (ζ: nat -> formula) (t: formula) : formula :=
  match t with
  | var n => ζ n
  | arr s t => arr (substitute ζ s) (substitute ζ t)
  end.

(* Hilbert-style calculus *)
Inductive hsc (Gamma: list formula) : formula -> Prop :=
  | hsc_var : forall (ζ: nat -> formula) (t: formula), In t Gamma -> hsc Gamma (substitute ζ t)
  | hsc_arr : forall (s t : formula), hsc Gamma (arr s t) -> hsc Gamma s -> hsc Gamma t.

(* is the formula s derivable from the fixed list of formulae Gamma? *)
Definition HSC_PRV (Gamma: list formula) (s: formula) := hsc Gamma s.

(* the formula a → b → a *)
Definition a_b_a : formula := arr (var 0) (arr (var 1) (var 0)).

(* list of formulae derivable from a → b → a *)
Definition HSC_AX_PROBLEM := { Gamma: list formula | forall s, In s Gamma -> hsc [a_b_a] s}.

(* is the formula a → b → a derivable? *)
Definition HSC_AX (l: HSC_AX_PROBLEM) := hsc (proj1_sig l) a_b_a.


Require Import ZArith.
Require Import String.
Require Import Ascii.
Require Import Structures.Orders.
Require Import Structures.OrdersEx.
Require Import Lists.List.

Definition lt_not_eq_prop {X : Type} (eq lt : X -> X -> Prop) : Prop :=
  forall (x y : X),
    lt x y -> ~(eq x y).

Module list_as_EqualityType (X : EqualityType) <: EqualityType.

  Definition t := list X.t.

  Inductive eq_dummy : t -> t -> Prop :=
    | eq_nil :
      eq_dummy nil nil
    | eq_more :
      forall h0 h1 t0 t1,
      X.eq h0 h1 -> eq_dummy t0 t1 -> eq_dummy (h0 :: t0) (h1 :: t1).

  Definition eq := eq_dummy.

  Theorem eq_refl : reflexive t eq.
  Proof.
    intros l.
    induction l.
    - apply eq_nil.
    - apply eq_more.
      + apply Equivalence_Reflexive.
      + apply IHl.
  Qed.

  Theorem eq_sym : symmetric t eq.
  Proof.
    intros l.
    induction l.
    - intros x Hx.
      inversion Hx.
      apply eq_refl.
    - intros y Hy.
      destruct y.
      + inversion Hy.
      + inversion Hy;
          subst.
        apply eq_more.
        * apply Equivalence_Symmetric.
          auto.
        * apply IHl.
          auto.
  Qed.

  Definition eq_trans : transitive t eq.
  Proof.
    intros x y z H_xy.
    generalize z.
    induction H_xy.
    - intros z0 H_yz.
      auto.
    - intros z0 H_yz.
      inversion H_yz;
        subst.
      apply eq_more.
      + apply Equivalence_Transitive with h1;
          auto.
      + apply IHH_xy.
        auto.
  Qed.

  Theorem eq_equiv : Equivalence eq.
    split.
    - apply eq_refl.
    - apply eq_sym.
    - apply eq_trans.
  Qed.

End list_as_EqualityType.

Module list_as_DecStrOrder (X : OrderedType) <: DecStrOrder.

  Include list_as_EqualityType X.

  Inductive lt_dummy : t -> t -> Prop :=
    | lt_nil :
      forall h t,
        lt_dummy nil (h :: t)
    | lt_h :
      forall h0 h1 t0 t1,
        X.lt h0 h1 -> lt_dummy (h0 :: t0) (h1 :: t1)
    | lt_t :
      forall h0 h1 t0 t1,
        X.eq h0 h1 -> lt_dummy t0 t1 -> lt_dummy (h0 :: t0) (h1 :: t1).

  Definition lt := lt_dummy.

  Theorem lt_irreflexive : Irreflexive lt.
  Proof.
    unfold Irreflexive.
    unfold Reflexive.
    intros.
    intros Hinv.
    induction x.
    - inversion Hinv.
    - inversion Hinv; subst.
      + apply StrictOrder_Irreflexive with a.
        auto.
      + auto.
  Qed.

  Lemma lt_compat_easy :
    forall x0 x1 y0 y1, X.eq x0 x1 -> X.eq y0 y1 -> (X.lt x0 y0 <-> X.lt x1 y1).
  Proof.
    intros.
    apply X.lt_compat;
      auto.
  Qed.

  Theorem lt_transitive : Transitive lt.
  Proof.
    intros x y z H_xy.
    generalize z.
    induction H_xy.
    - intros z0 H_yz.
      inversion H_yz;
        apply lt_nil.
    - intros z0 H_yz.
      inversion H_yz;
        subst.
      + apply lt_h.
        apply StrictOrder_Transitive with h1;
          auto.
      + apply lt_h.
        apply lt_compat_easy with h0 h1.
        * apply Equivalence_Reflexive.
        * apply Equivalence_Symmetric.
          auto.
        * auto.
    - intros.
      destruct z0.
      + inversion H0.
      + inversion H0;
          subst.
        * apply lt_h.
          apply lt_compat_easy with h1 t2;
            auto.
          apply Equivalence_Reflexive.
        * apply lt_t.
          { apply Equivalence_Transitive with h1;
              auto. }
          { apply IHH_xy.
            auto. }
  Qed.

  Theorem lt_strorder : StrictOrder lt.
    split.
    - apply lt_irreflexive.
    - apply lt_transitive.
  Qed.

  Theorem lt_compat_half :
    forall x0 x1 y0 y1,
      eq x0 y0 -> eq x1 y1 -> lt x0 x1 -> lt y0 y1.
    intros x0.
    induction x0.
    - intros x1 y0 y1 Heq0 Heq1.
      inversion Heq0;
        subst.
      inversion Heq1;
        subst.
      + intro.
        auto.
      + intro.
        apply lt_nil.
    - intros x1 y0 y1 Heq0 Heq1.
      inversion Heq0;
        subst.
      inversion Heq1;
        subst.
      + intro H;
          inversion H.
      + intro Hlt.
        inversion Hlt;
          subst.
          * apply lt_h.
            apply lt_compat_easy with a h0.
            { apply Equivalence_Symmetric.
              auto. }
            { apply Equivalence_Symmetric.
              auto. }
            { auto. }
          * apply lt_t.
            { apply Equivalence_Transitive with a.
              - apply Equivalence_Symmetric.
                auto.
              - apply Equivalence_Transitive with h0;
                  auto. }
            { apply IHx0 with t0;
                auto. }
  Qed.

  Theorem lt_compat : Proper (eq==>eq==>iff) lt.
    intros x0 y0 Heq0 x1 y1 Heq1.
    split.
    - apply lt_compat_half;
        auto.
    - apply lt_compat_half.
      + apply (@Equivalence_Symmetric t eq eq_equiv).
        * auto.
      + apply (@Equivalence_Symmetric t eq eq_equiv).
        * auto.
  Qed.

  Fixpoint compare (x y : t) : comparison :=
    match x, y with
    | nil, nil => Eq
    | nil, _ :: _ => Lt
    | _ :: _, nil => Gt
    | xh :: xt, yh :: yt => match X.compare xh yh with
      | Lt => Lt
      | Gt => Gt
      | Eq => compare xt yt
      end
    end.

  Theorem compare_spec : forall x y, CompareSpec (eq x y) (lt x y) (lt y x) (compare x y).
    induction x as [| hx tx IH].
    - destruct y.
      + apply CompEq.
        apply eq_nil.
      + apply CompLt.
        apply lt_nil.
    - destruct y as [| hy ty].
      + apply CompGt.
        apply lt_nil.
      + simpl.
        pose proof (X.compare_spec hx hy) as Hhcomp.
        inversion Hhcomp;
          subst.
        * pose proof (IH ty) as IHt.
          inversion IHt;
            subst.
          { apply CompEq.
            apply eq_more;
              auto. }
          { apply CompLt.
            apply lt_t;
              auto. }
          { apply CompGt.
            apply lt_t.
            - apply Equivalence_Symmetric.
              auto.
            - auto. }
        * apply CompLt.
          apply lt_h.
          auto.
        * apply CompGt.
          apply lt_h.
          auto.
  Qed.

End list_as_DecStrOrder.

Module list_as_OrderedType (X : OrderedType) <: OrderedType.
  Module DSO := list_as_DecStrOrder X.
  Include DSO_to_OT DSO.
End list_as_OrderedType.

Module Type mapped_OT (Y : OrderedType).
  Parameter Inline t : Type.

  Parameter Inline f : t -> Y.t.

  Definition eq (x y : t) : Prop :=
    Y.eq (f x) (f y).

  Definition lt (x y : t) : Prop :=
    Y.lt (f x) (f y).
End mapped_OT.

Module mapped_to_DecStrOrder (Y : OrderedType) (M : mapped_OT Y) <: DecStrOrder.

  Definition t := M.t.

  Definition eq := M.eq.

  Definition lt := M.lt.

  Definition f := M.f.

  Theorem eq_refl : reflexive t eq.
  Proof.
    intros x.
    unfold eq.
    unfold M.eq.
    apply Equivalence_Reflexive.
  Qed.

  Theorem eq_sym : symmetric t eq.
  Proof.
    intros x y.
    unfold eq.
    unfold M.eq.
    apply Equivalence_Symmetric.
  Qed.

  Theorem eq_trans : transitive t eq.
  Proof.
    intros x y z.
    unfold eq.
    unfold M.eq.
    apply Equivalence_Transitive.
  Qed.

  Theorem eq_equiv : Equivalence eq.
    split.
    - apply eq_refl.
    - apply eq_sym.
    - apply eq_trans.
  Qed.

  Theorem lt_irreflexive : Irreflexive lt.
    intros x Hinv.
    unfold lt in Hinv.
    unfold M.lt in Hinv.
    apply (StrictOrder_Irreflexive (M.f x)).
    auto.
  Qed.

  Theorem lt_transitive : Transitive lt.
    unfold lt.
    intros x y z Hxy Hyz.
    unfold M.lt.
    apply (StrictOrder_Transitive (M.f x) (M.f y) (M.f z)).
    - auto.
    - auto.
  Qed.

  Theorem lt_strorder : StrictOrder lt.
    split.
    - apply lt_irreflexive.
    - apply lt_transitive.
  Qed.

  Theorem lt_compat : Proper (eq==>eq==>iff) lt.
    intros x0 x1 Heqx y0 y1 Heqy.
    unfold lt.
    unfold M.lt.
    apply Y.lt_compat.
    - auto.
    - auto.
  Qed.

  Definition compare x y := Y.compare (f x) (f y).

  Theorem compare_spec : forall x y, CompareSpec (eq x y) (lt x y) (lt y x) (compare x y).
  Proof.
    intros x y.
    unfold compare.
    remember (Y.compare_spec (f x) (f y)) as Yc.
    inversion Yc.
    - apply CompEq.
      auto.
    - apply CompLt.
      auto.
    - apply CompGt.
      auto.
  Qed.

End mapped_to_DecStrOrder.

Module mapped_to_OT (Y : OrderedType) (M : mapped_OT Y) <: OrderedType.
  Module DSO := mapped_to_DecStrOrder Y M.
  Include DSO_to_OT DSO.
End mapped_to_OT.

Module ascii_as_OT <: OrderedType.
  Module ascii_as_OT_local.
    Module as_mapped_OT <: mapped_OT N_as_OT.
      Definition t := ascii.
      Definition f := N_of_ascii.
      Definition eq (x y : t) : Prop :=
        N_as_OT.eq (f x) (f y).
      Definition lt (x y : t) : Prop :=
        N_as_OT.lt (f x) (f y).
    End as_mapped_OT.
    Module as_OT := mapped_to_OT N_as_OT as_mapped_OT.
    End ascii_as_OT_local.
  Include ascii_as_OT_local.as_OT.
End ascii_as_OT.

Module string_as_OT <: OrderedType.
  Module string_as_OT_local.
    Module ascii_list_os_OT := list_as_OrderedType ascii_as_OT.
    Module as_mapped_OT <: mapped_OT ascii_list_os_OT.
      Definition t := string.
      Fixpoint f (s : string) : ascii_list_os_OT.t :=
        match s with
        | EmptyString => nil
        | String a s' => a :: f s'
        end.
      Definition eq (x y : t) : Prop :=
        ascii_list_os_OT.eq (f x) (f y).
      Definition lt (x y : t) : Prop :=
        ascii_list_os_OT.lt (f x) (f y).
    End as_mapped_OT.
    Module as_OT := mapped_to_OT ascii_list_os_OT as_mapped_OT.
  End string_as_OT_local.
  Include string_as_OT_local.as_OT.
End string_as_OT.

(* An expression might evaluate to reference to single variable or array element.
   Reference to single variable is label with empty subscrtip list. *)
(* Reference may olso refer to an array with no or incomplete subscript list.
   For such reference, valid state will always return "None", but the reference
   can be used in subscript expression to form reference with extended subscrpt
   list. Subscript operations can be repeated until the subscript list is
   complete. *)
Inductive reference :=
  | ref_variable : string -> list Z -> reference.

Module reference_as_OT <: OrderedType.
  Module reference_as_OT_local.
    Module list_Z_as_OT := list_as_OrderedType Z_as_OT.
    Module pair_as_OT := PairOrderedType string_as_OT list_Z_as_OT.
    Module as_mapped_OT : mapped_OT pair_as_OT.
      Definition t := reference.
      Definition f (x : t) : pair_as_OT.t :=
        match x with
        | ref_variable s l => (s, l)
        end.
      Definition eq (x y : t) : Prop :=
        pair_as_OT.eq (f x) (f y).
      Definition lt (x y : t) : Prop :=
        pair_as_OT.lt (f x) (f y).
    End as_mapped_OT.
    Module as_OT := mapped_to_OT pair_as_OT as_mapped_OT.
  End reference_as_OT_local.
  Include reference_as_OT_local.as_OT.
End reference_as_OT.

Definition state := reference -> option Z.

Definition empty_state (ref : reference) : option Z := None.

Example state_ex0 :
  empty_state (ref_variable "terefere" nil) = None.
Proof. reflexivity. Qed.