Require Import FunctionalExtensionality.

Set Asymmetric Patterns.

(** Isomorphisms between types. *)
Record T { A B : Type } : Type :=
  { to      : A -> B
  ; from    : B -> A
  ; from_to : forall (a : A), from (to a) = a
  ; to_from : forall (b : B), to (from b) = b
  }.

Arguments T : clear implicits.

(** Isomorphisms form an equivalence relation: they are reflexivity,
    symmetric, and transitive. *)
Theorem Refl (A : Type) : T A A.
Proof.
refine (
  {| to   := fun x => x
   ; from := fun x => x |});
reflexivity.
Defined.

Definition Sym {A B : Type} (iso : T A B) : T B A :=
  {| to := from iso
   ; from := to iso
   ; from_to := to_from iso
   ; to_from := from_to iso
  |}.

Theorem Trans { A B C : Type } :
  T A B -> T B C -> T A C.
Proof.
intros AB BC.
refine (
{| to   := fun x => to   BC (to   AB x)
 ; from := fun y => from AB (from BC y)
|}); intros.
- rewrite (from_to BC).
  rewrite (from_to AB).
  reflexivity.
- rewrite (to_from AB).
  rewrite (to_from BC).
  reflexivity.
Defined.

(** * Sigma type isomorphisms *)
(** Isomorphisms between Sigma types with different indexing types. *)

Definition FSig {B : False -> Type} : T (sigT B) False.
Proof. refine (
{| to := @projT1 _ B
 ; from := False_rect (sigT B) |}).
intros. destruct a. contradiction.
intros. contradiction.
Defined.

Definition TSig {B : True -> Type} : T (sigT B) (B I).
Proof. refine (
{| to := fun x => match x with existT I p => p end
 ; from := existT _ I
|}).
Proof.
intros x. destruct x. destruct x. reflexivity.
intros b. reflexivity.
Defined.

Definition PlusSig {A1 A2 : Type}
  {B : (A1 + A2)%type -> Type}
  {B1 B2 : Type }
  (iso1 : T (sigT (fun x => B (inl x))) B1)
  (iso2 : T (sigT (fun x => B (inr x))) B2)
  :       T (sigT B)                 (B1 + B2)%type.
Proof.
refine (
{| to := fun x : sigT B => match x with
   | existT (inl a1) pa1 => inl (to iso1 (existT (fun x => B (inl x)) a1 pa1))
   | existT (inr a2) pa2 => inr (to iso2 (existT (fun x => B (inr x)) a2 pa2))
   end
; from := fun x => match x with
   | inl b1 => match from iso1 b1 with
     | existT a1 pa1 => existT B (inl a1) pa1
     end
   | inr b2 => match from iso2 b2 with
     | existT a2 pa2 => existT B (inr a2) pa2
     end
   end
|}).
intros a; destruct a; simpl; destruct x; simpl; rewrite from_to; reflexivity.
intros b. destruct b; simpl.
destruct (from iso1 b) eqn:beqn.
rewrite <- beqn. rewrite to_from; reflexivity.
destruct (from iso2 b) eqn:beqn.
rewrite <- beqn. rewrite to_from; reflexivity.
Defined.

Lemma sigTimes {A B : Type} : T (A * B) (sigT (fun _ : A => B)).
Proof.
refine (
{| to  := fun p => match p with (x, y) => existT (fun _ : A => B) x y end
; from := fun p => match p with existT x y => (x, y) end
|} ).
Proof.
intros. destruct a. reflexivity.
intros. destruct b. reflexivity.
Defined.

(** * Function type isomorphisms *)
(** Isomorphisms between function types with different argument types. *)

Lemma FFunc {B : Type} : T (False -> B) True.
Proof.
refine (
{| to   := fun _ => I
 ; from := fun _ => False_rect B |}); intros.
apply functional_extensionality. intros. inversion x.
destruct b. reflexivity.
Defined.

Lemma TFunc {B : Type} : T (True -> B) B.
Proof.
refine (
{| to   := fun f => f I
 ; from := fun b _ => b |}); intros.
apply functional_extensionality. intros. destruct x. reflexivity.
reflexivity.
Defined.

Lemma PlusFunc {A1 A2 B T1 T2 : Type} :
   T (A1 -> B) T1
 -> T (A2 -> B) T2
 -> T ((A1 + A2)%type -> B) (T1 * T2).
Proof.
intros I1 I2.
refine (
{| to := fun f => ( to I1 (fun a1 => f (inl a1))
                 , to I2 (fun a2 => f (inr a2)) )
 ; from := fun p => match p with
   | (x, y) => fun v => match v with
     | inl a1 => from I1 x a1
     | inr a2 => from I2 y a2
     end
   end |}); intros.
+ apply functional_extensionality; intros.
  destruct x.
   - rewrite (from_to I1). reflexivity.
   - rewrite (from_to I2). reflexivity.
+ destruct b. f_equal.
  - rewrite (@to_from _ _ I1). reflexivity.
  - rewrite (@to_from _ _ I2). reflexivity.
Defined.

Lemma TimesFunc { A1 A2 B X Y : Type } :
    T (A2 -> B) X
  -> T (A1 -> X) Y
  -> T ((A1 * A2)%type -> B) Y.
Proof.
intros IX IY.
refine (
{| to := fun f => to IY (fun a1 =>
                 to IX (fun a2 => f (a1, a2)))
 ; from := fun u p => match p with
   | (a1, a2) => let t := (from IY u) a1
                in       (from IX t) a2
   end
|}); intros.
apply functional_extensionality; intros.
destruct x.
simpl. rewrite (from_to IY). rewrite (from_to IX). reflexivity.
simpl.
assert (
(fun a1 : A1 => to IX (fun a2 : A2 => from IX (from IY b a1) a2))
 =
(fun a1 : A1 => to IX             (from IX (from IY b a1)))
).
reflexivity.
rewrite H.
assert (
(fun a1 : A1 => to IX (from IX (from IY b a1)))
=
(fun a1 : A1 =>                (from IY b a1))
).
apply functional_extensionality; intros.
rewrite (to_from IX). reflexivity.
rewrite H0.
rewrite (to_from IY).
reflexivity.
Defined.

(** * Congruences *)
(** Isomorphism is a congruence over the type forming operations
    for sums, products, and functions. *)

Theorem PlusCong {A B A' B' : Type}
 (IA : T A A')
 (IB : T B B')
 : T (A + B)%type (A' + B')%type.
Proof.
refine (
{| to := fun x => match x with
   | inl a => inl (to IA a)
   | inr b => inr (to IB b)
   end
 ; from := fun x => match x with
   | inl a' => inl (from IA a')
   | inr b' => inr (from IB b')
   end
|}).
intros x; destruct x.
rewrite (from_to IA). reflexivity.
rewrite (from_to IB). reflexivity.
intros x; destruct x.
rewrite (to_from IA). reflexivity.
rewrite (to_from IB). reflexivity.
Defined.

Theorem TimesCong {A B A' B' : Type}
 (IA : T A A')
 (IB : T B B')
 : T (A * B)%type (A' * B') %type.
Proof.
refine (
{| to := fun p => match p with | (x, y) => (to IA x, to IB y) end
 ; from := fun p => match p with | (x, y) => (from IA x, from IB y) end
|}); intros p; destruct p; f_equal.
apply (from_to IA).
apply (from_to IB).
apply (to_from IA).
apply (to_from IB).
Defined.

Theorem FuncCong { A A' B B' : Type } :
  T A A' -> T B B' -> T (A -> B) (A' -> B').
Proof.
intros IA IB.
refine (
  {| to   := fun f a' => to   IB (f (from IA a'))
   ; from := fun f a  => from IB (f (to   IA a )) |});
intros; apply functional_extensionality; intro x; simpl;
  repeat rewrite (from_to IA);
  repeat rewrite (to_from IA);
  repeat rewrite (from_to IB);
  repeat rewrite (to_from IB);
  reflexivity.
Defined.

Definition PlusComm {A B} : T (A + B) (B + A).
Proof. refine (
  {| to := fun x => match x with
  | inl a => inr a
  | inr b => inl b
  end
  ; from := fun y => match y with
  | inl b => inr b
  | inr a => inl a
  end
  |}); intros.
- destruct a; reflexivity.
- destruct b; reflexivity.
Defined.

Theorem eq_dec {A B : Type} : (forall x y : A, {x = y} + {x <> y})
  -> T A B -> forall x y : B, {x = y} + {x <> y}.
Proof.
intros dec t x y.
destruct (dec (from t x) (from t y)).
  + left.
    replace x with (to t (from t x)) by apply to_from.
    replace y with (to t (from t y)) by apply to_from.
    f_equal. assumption.
  + right. congruence.
Qed.

(** * Infinite *)
(** Cantor's diagonal arguments, which says that there is no bijection
    between natural numbers and sequences of natural numbers. *)
Theorem Cantor : T nat (nat -> nat) -> False.
Proof.
intros iso.
destruct iso.
pose (f := fun n => S (to0 n n)).
assert (forall (n : nat), f <> to0 n).
- intros n. assert (to0 n n <> f n).
  unfold f. simpl. apply n_Sn.
  intros contra. apply H. rewrite contra. reflexivity.
- pose proof (to_from0 f).
  rewrite <- H0 in H.
  apply (H (from0 f)). reflexivity.
Qed.

(** * Subsets *)

Lemma sig_eq (A : Type) (P : A -> Prop) (Pirrel : forall a (p q : P a), p = q)
  : forall (x y : sig P), projT1 x = projT1 y -> x = y.
Proof.
intros. destruct x, y. simpl in *.
induction H. rewrite (Pirrel x p p0).
reflexivity.
Qed.

Theorem subset {A B : Type} (P : A -> Prop) (Q : B -> Prop)
  (i : T A B)
  : (forall a, P a -> Q (to i a))
  -> (forall b, Q b -> P (from i b))
  -> (forall a (p q : P a), p = q)
  -> (forall b (p q : Q b), p = q)
  -> T (sig P) (sig Q).
Proof.
intros PimpQ QimpP Pirrel Qirrel.
refine (
  {| to := fun sa => match sa with
    | exist a pa => exist Q (to i a) (PimpQ a pa)
    end
  ;  from := fun sb => match sb with
    | exist b pb => exist P (from i b) (QimpP b pb)
    end
  |}
); intros inp; destruct inp; simpl;
  apply sig_eq; try assumption; simpl.
  apply from_to. apply to_from.
Defined.

Theorem subsetSelf {A : Type} (P Q : A -> Prop)
  : (forall a, P a <-> Q a)
  -> (forall a (p q : P a), p = q)
  -> (forall b (p q : Q b), p = q)
  -> T (sig P) (sig Q).
Proof.
intros. apply (subset _ _ (Refl A)); try assumption;
 intros; simpl; firstorder.
Defined.

Theorem iso_true_subset {A} : T A (sig (fun _ : A => True)).
Proof. refine (
  {| to := fun a => exist _ a I
   ; from := fun ea => let (a, _) := ea in a |}
); intros.
reflexivity. destruct b. destruct t. reflexivity.
Defined.

Theorem iso_false_subset {A} : T False (sig (fun _ : A => False)).
Proof. refine (
  {| to := False_rect _
  ; from := fun p : sig (fun _ => False) => let (x, px) := p in False_rect _ px
  |}); intros.
- contradiction.
- destruct b. contradiction.
Defined.

Definition subset_sum_distr {A B} {P : A + B -> Prop} :
  T (sig P) (sig (fun a => P (inl a)) + sig (fun b => P (inr b))).
Proof.
refine (
  {| to := fun (p : sig P) => let (x, px) := p in match x as x'
  return P x' -> sig (fun a => P (inl a)) + sig (fun b => P (inr b)) with
  | inl a => fun px' => inl (exist (fun a' => P (inl a')) a px')
  | inr b => fun px' => inr (exist (fun b' => P (inr b')) b px')
  end px
  ; from := fun p => match p with
  | inl (exist a pa) => exist _ (inl a) pa
  | inr (exist b pb) => exist _ (inr b) pb
  end
  |}
); intros.
- destruct a as (x & px). destruct x; reflexivity.
- destruct b as [s | s]; destruct s; reflexivity.
Defined.

(** Proof irrelevant-things *)

Inductive inhabited {A : Type} : Prop :=
  | elem (a : A) : inhabited.

Arguments inhabited : clear implicits.

Require Import ProofIrrelevance.

Theorem inhabited_idempotent {A : Type} :
  T A (inhabited A * A).
Proof.
refine (
  {| to := fun a => (elem a, a)
   ; from := fun p => snd p
  |}
).
- intros. reflexivity.
- intros. destruct b. simpl.
  replace (elem a) with i by apply proof_irrelevance.
  reflexivity.
Defined.

Require Import Types.Equiv.

Import EqualNotations.

Local Open Scope equal.

Definition toEquiv' {A B : Type} (x : T A B) :
(forall a : A, to x # from_to x a = to_from x (to x a)) -> Equiv.T A B :=
  Equiv.Build_T A B (to x) (from x) (from_to x) (to_from x).

Require Import Setoid.
Lemma toEquiv {A B} (x : T A B) : Equiv.T A B.
Proof.
destruct x as [f g eta eps].
refine (
  {| Equiv.to := f
   ; Equiv.from := g
   ; Equiv.from_to := eta
   ; Equiv.to_from := fun b =>
      eq_sym (eps (f (g b)))
    @ f # eta (g b)
    @ eps b
  |}).
intros.
pose proof (Equiv.f_equal_homotopy_commutes eta a).
simpl in H.
pose proof (Equiv.f_equal_natural (f := fun x => f (g x)) (g := fun x => x) eps
  (f # eta a)).
rewrite <- (Equiv.f_equal_compose _ _ _ f g) in H0.
rewrite (Equiv.f_equal_compose _ _ _ g f) in H0.
rewrite <- H in H0.
rewrite !Equiv.f_equal_id in H0.
rewrite <- Equiv.eq_trans_assoc.
rewrite <- H0.
rewrite Equiv.eq_trans_assoc.
rewrite Equiv.eq_sym_l.
rewrite Equiv.eq_trans_id_l. reflexivity.
Defined.

Definition fromEquiv {A B} (x : Equiv.T A B) : T A B :=
  {| to := Equiv.to x
   ; from := Equiv.from x
   ; to_from := Equiv.to_from x
   ; from_to := Equiv.from_to x
  |}.

Lemma sigmaProj1_eq : forall {A A' B} {to : A -> A'} {from : A' -> A}
  {a : A}
  (from_to : from (to a) = a),
  forall b,
         existT B (from (to a)) (Equiv.transport B (eq_sym from_to) b) =
         existT B a b.
Proof.
intros. rewrite from_to0.  simpl. reflexivity.
Defined.

Lemma sigmaProj1_eq2 : forall {A A' B} (i : Equiv.T A A')
  (a' : A') b,
       existT (fun a'0 : A' => B (Equiv.from i a'0)) (Equiv.to i (Equiv.from i a'))
         (Equiv.transport B (eq_sym (Equiv.from_to i (Equiv.from i a'))) b) =
       existT (fun a'0 : A' => B (Equiv.from i a'0)) a' b.
Proof.
intros. apply EqdepFacts.eq_sigT_iff_eq_dep.
pose proof (Equiv.lemma422 i) as eps.
simpl in eps.
rewrite <- eps.
remember (Equiv.to_from i a') as x.
induction Heqx. rewrite x. reflexivity.
Qed.

(* This is in fact "true" but, without Axiom K, the construction is a little
   bit convoluted. It is proved in the HoTT library by transferring
   isomorphisms to equivalences. *)
Lemma sigmaPropEquiv {A A' : Type} {B : A -> Type}
  (iso : Equiv.T A A')
  : T (sigT B) (sigT (fun a' => B (Equiv.from iso a'))).
Proof.
pose iso as iso'.
destruct iso.
refine (
  {| to := fun p : sigT B => let (a, b) := p in
      existT (fun a' => B (from0 a')) (to0 a) (Equiv.transport B (eq_sym (from_to0 a)) b)
  ; from := fun p : sigT (fun a' => B (from0 a')) => let (a', b) := p in
      existT B (from0 a') b
  ; from_to := fun p : sigT B => match p with
     existT a b => sigmaProj1_eq (from_to0 a) b
     end
  ; to_from := fun p : sigT (fun a' => B (from0 a')) => match p with
     existT a' b => sigmaProj1_eq2 iso' a' b
     end
  |}
).
Defined.

Definition sigmaProp {A A' : Type} {B : A -> Type}
  (iso : T A A')
  : T (sigT B) (sigT (fun a' => B (from iso a'))).
Proof.
pose (@sigmaPropEquiv A A' B (toEquiv iso)).
simpl in t.
destruct iso. apply t.
Defined.


(* ea *)

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

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

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

(* hf *)

Fixpoint iter {A:Set} (k:nat) (f:A->A) (x:A) :=
  match k with
    | 0 => x
    | S p => iter p f (f x)
  end.

Eval compute in Nat.add 0 1.

Eval compute in iter 0 (Nat.add 1) 0.
Eval compute in iter 1 (Nat.add 1) 0.
Eval compute in iter 2 (Nat.add 1) 0.

Structure CyclicGroup : Type := const_cyclic (* motto *)
{
  G :> Group;

  generator : A G ;
  n : nat ;

  op_cyclic : forall a, exists k, k < n /\ a = iter k ((op G) generator) (z G)
}.

Inductive GeneratedElement : Set :=
  | g : nat -> GeneratedElement.

Check g 0.
Check g 1.

Definition order (e:GeneratedElement) : nat := match e with | g k => k end.

Eval compute in order (g 0).
Eval compute in order (g 1).

Definition Z_n (n:nat) := {e:GeneratedElement | order e < n}.

Lemma g_0_order_lt_2 : order (g 0) < 2.
Proof.
  unfold order.
  auto.
Qed.

Definition z_2_0 := exist (fun e:GeneratedElement => order e < 2) (g 0) g_0_order_lt_2.

Eval compute in proj1_sig z_2_0.
Eval compute in proj2_sig z_2_0.

Search proj1_sig.
Search proj2_sig.
Check eq_sig.

Definition Z_n_order (n:nat) (z:Z_n n) : nat := order (proj1_sig z).

Eval compute in Z_n_order 2 z_2_0.

Lemma g_k_order_lt_n (n:nat) (k:nat) : k < n -> order (g k) < n. Proof. unfold order. auto. Qed.

Definition Z_n_const (n:nat) (k:nat) (p:k < n): Z_n n :=
  exist (fun e:GeneratedElement => order e < n) (g k) (g_k_order_lt_n n k p).

Lemma proof_0_lt_1 : 0 < 1. Proof. auto. Qed. (* FIXME: create by function; possible? *)
Lemma proof_0_lt_2 : 0 < 2. Proof. auto. Qed.
Lemma proof_1_lt_2 : 1 < 2. Proof. auto. Qed.
Lemma proof_0_lt_3 : 0 < 3. Proof. auto. Qed.
Lemma proof_1_lt_3 : 1 < 3. Proof. auto. Qed.
Lemma proof_2_lt_3 : 2 < 3. Proof. auto. Qed.

Definition z_3_0 := Z_n_const 3 0 proof_0_lt_3.
Definition z_3_1 := Z_n_const 3 1 proof_1_lt_3.
Definition z_3_2 := Z_n_const 3 2 proof_2_lt_3.

Eval compute in Z_n_order 3 z_3_0.
Eval compute in Z_n_order 3 z_3_1.
Eval compute in Z_n_order 3 z_3_2.

Lemma Z_n_order_lt_n (n:nat) : forall x:Z_n n, Z_n_order n x < n.
Proof.
  intro x.
  unfold Z_n_order.
  apply (proj2_sig x).
Qed.

SearchPattern (nat -> nat -> nat).
Print Nat.modulo.

Notation "n % m" := (Nat.modulo n m) (at level 20) : type_scope.

Eval compute in 0 % 0.
Eval compute in 1 % 2.
Eval compute in 2 % 2.

Require PeanoNat.

Lemma Z_n_op_proof (n:nat) : forall x y:Z_n n, ((Z_n_order n x) + (Z_n_order n y)) % (n) < (n).
Proof.
  induction x, y.
  unfold Z_n_order.
  apply PeanoNat.Nat.mod_upper_bound.
  cut (n > 0).
  apply PeanoNat.Nat.neq_0_lt_0.
  apply PeanoNat.Nat.lt_lt_0 in p.
  assumption.
Qed.

Definition Z_n_op (n:nat) (x:Z_n n) (y:Z_n n) : Z_n n :=
  Z_n_const n (((Z_n_order n x) + (Z_n_order n y)) % (n)) (Z_n_op_proof n x y).

Eval compute in Z_n_order 3 (Z_n_op 3 z_3_0 z_3_0).
Eval compute in Z_n_order 3 (Z_n_op 3 z_3_0 z_3_1).
Eval compute in Z_n_order 3 (Z_n_op 3 z_3_1 z_3_2).

Lemma Z_n_inv_proof (n:nat) : forall x:Z_n n, (n - (Z_n_order n x)) % (n) < (n).
Proof.
  induction x.
  unfold Z_n_order.
  apply PeanoNat.Nat.mod_upper_bound.
  cut (n > 0).
  apply PeanoNat.Nat.neq_0_lt_0.
  apply PeanoNat.Nat.lt_lt_0 in p.
  assumption.
Qed.

Definition Z_n_inv (n:nat) (x:Z_n n) : Z_n n :=
  Z_n_const n ((n - (Z_n_order n x)) % (n)) (Z_n_inv_proof n x).

Eval compute in Z_n_order 3 (Z_n_inv 3 z_3_0).
Eval compute in Z_n_order 3 (Z_n_inv 3 z_3_1).
Eval compute in Z_n_order 3 (Z_n_inv 3 z_3_2).

Axiom proof_irrelevance : (* https://github.com/coq/coq/wiki/CoqAndAxioms *)
  forall (P : Prop) (p q : P), p = q.

Lemma warmup (n:nat) (x y:{k:nat | k < n}) : proj1_sig x = proj1_sig y -> x = y.
Proof.
  destruct x as [x Hx], y as [y Hy].
  simpl.
  intro H.
  subst y.
  f_equal.
  apply proof_irrelevance.
Qed.

Lemma Z_n_eq_if_order_eq (n:nat) : forall x y:Z_n n, Z_n_order n x = Z_n_order n y -> x = y.
Proof.
  intros x y.
  destruct x as [x Hx], y as [y Hy].
  unfold Z_n_order.
  simpl.
  intro H.
  assert (order x = order y -> x = y) as H2.
  { case x, y. unfold order. intro H2. rewrite H2. reflexivity. }
  assert (x = y).
  apply H2.
  assumption.
  subst y.
  cut (Hx = Hy).
  intro H3.
  rewrite H3.
  reflexivity.
  apply proof_irrelevance.
Qed.

Lemma Z_n_eq_iff_order_eq (n:nat) : forall x y:Z_n n, x = y <-> Z_n_order n x = Z_n_order n y.
Proof.
  split.
  intro H.
  rewrite H.
  reflexivity.
  apply Z_n_eq_if_order_eq.
Qed.

Lemma nat_add_mod_assoc : forall a b c n:nat, n <> 0 ->
  (a + ((b + c) % (n))) % (n) = (((a + b) % (n)) + c) % (n).
Proof.
  Print PeanoNat.Nat.add_mod.
  Print PeanoNat.Nat.add_mod_idemp_l.
  Print PeanoNat.Nat.add_mod_idemp_r.
  intros a b c n H.
  rewrite PeanoNat.Nat.add_mod_idemp_r.
  rewrite PeanoNat.Nat.add_mod_idemp_l.
  rewrite PeanoNat.Nat.add_assoc.
  reflexivity.
  assumption.
  assumption.
Qed.

Lemma Z_n_op_eq_order (n:nat) :
  forall x y:Z_n n, Z_n_order n (Z_n_op n x y) = (((Z_n_order n x) + (Z_n_order n y)) % (n)).
Proof.
  intros x y.
  unfold Z_n_op.
  unfold Z_n_order.
  simpl.
  reflexivity.
Qed.

Lemma Z_n_inv_eq_order (n:nat) :
  forall x:Z_n n, Z_n_order n (Z_n_inv n x) = ((n) - Z_n_order n x) % (n).
Proof.
  intro x.
  unfold Z_n_inv.
  unfold Z_n_order.
  simpl.
  reflexivity.
Qed.

Theorem Z_n_group (n:nat) : n <> 0 -> Group.
Proof.
  intro H.
  assert (0 < n) as H'.
  apply PeanoNat.Nat.neq_0_lt_0.
  assumption.
  apply (const_kozos (Z_n n) (Z_n_op n) (Z_n_inv n) (Z_n_const n 0 H')).

  intros a b c.
  rewrite Z_n_eq_iff_order_eq.
  repeat rewrite Z_n_op_eq_order.
  apply nat_add_mod_assoc.
  assumption.

  intro a.
  repeat rewrite Z_n_eq_iff_order_eq.
  repeat rewrite Z_n_op_eq_order.
  assert (Z_n_order n (Z_n_const n 0 H') = 0) as H2.
  unfold Z_n_order.
  simpl.
  reflexivity.
  rewrite H2.
  rewrite PeanoNat.Nat.add_0_r.
  rewrite PeanoNat.Nat.add_0_l.
  split.
  apply PeanoNat.Nat.mod_small.
  apply Z_n_order_lt_n.
  apply PeanoNat.Nat.mod_small.
  apply Z_n_order_lt_n.

  intro a.
  repeat rewrite Z_n_eq_iff_order_eq.
  repeat rewrite Z_n_op_eq_order.
  assert (Z_n_order n (Z_n_const n 0 H') = 0) as H2.
  unfold Z_n_order.
  simpl.
  reflexivity.
  rewrite H2.

  rewrite Z_n_inv_eq_order.
  split.

  rewrite PeanoNat.Nat.add_mod_idemp_r.
  rewrite PeanoNat.Nat.add_sub_assoc.
  rewrite PeanoNat.Nat.add_sub_swap.
  rewrite PeanoNat.Nat.add_comm.
  rewrite PeanoNat.Nat.add_sub_assoc.
  rewrite PeanoNat.Nat.add_sub.
  apply PeanoNat.Nat.mod_same.
  assumption.
  apply le_n.
  apply le_n.
  assert (Z_n_order n a < n).
  apply Z_n_order_lt_n.
  apply PeanoNat.Nat.lt_le_incl.
  assumption.
  assumption.

  rewrite PeanoNat.Nat.add_mod_idemp_l.
  rewrite PeanoNat.Nat.sub_add.
  apply PeanoNat.Nat.mod_same.
  assumption.
  assert (Z_n_order n a < n).
  apply Z_n_order_lt_n.
  apply PeanoNat.Nat.lt_le_incl.
  assumption.
  assumption.
Qed.

Lemma test (n:nat) (H:n <> 0) : forall a:A (Z_n_group n H), a = a.
Proof.
  intro a.
  (* case a. *)
  reflexivity.
Qed.

(* Lemma test (n:nat) (H:n <> 0) : forall a:A (Z_n_group n H), Z_n_order n a < n. *)

Theorem Z_n_cyclic_group (n:nat) : n > 1 -> CyclicGroup.
Proof.
  intro H.
  assert (n <> 0) as H2.
  assert (n > 0) as H2'.
  apply PeanoNat.Nat.lt_trans with (p:=n) (m:=1) (n:=0).
  apply PeanoNat.Nat.lt_succ_diag_r.
  assumption.
  apply PeanoNat.Nat.neq_0_lt_0.
  assumption.
  Check (Z_n_const n 1 H).
  Check (z (Z_n_group n H2)).
  apply (const_cyclic (Z_n_group n H2) (Z_n_const n 1 H) n).
???


Require Export ZArith.
Require Export List.
Require Export Arith Lia.

Section bad_proof_example_for_Induction1.

  Theorem le_plus_minus' : forall n m:nat, m <= n -> n = m+(n-m).
  Proof.
    intros n m H;  induction n.
    -   rewrite <- le_n_O_eq with (1 := H); simpl; trivial.
    - (* dead end *)
  Abort.

End bad_proof_example_for_Induction1.

Theorem lazy_example : forall n:nat, (S n) + 0 = S n.
Proof.
  intros n; lazy beta iota zeta delta.
  fold plus.
  rewrite plus_0_r; reflexivity.
Qed.

#[export] Hint  Extern  4 (_ <> _) => discriminate : core.

#[export] Hint Resolve le_S_n : le_base.

Theorem auto_le_example :
  forall n m:nat, S (S (S n)) <= S (S (S m)) ->  n <= m.
Proof.
  intros n m H.
  auto with le_base.
Qed.

Lemma unprovable_le : forall n m:nat, n <= m.
Proof.
  Time auto with arith.
  Time auto with le_base arith.
Abort.

Section bad_proof_for_auto.

  Section Trying_auto.
    Variable l1 : forall n m:nat, S n <= S m -> n <= m.

    Theorem unprovable_le2 : forall n m:nat, n <= m.
    Proof.
      Time auto with arith.
      Time try (clear l1; auto with arith; fail).
    Abort.

  End Trying_auto.

End bad_proof_for_auto.

Section combinatory_logic.

  Variables (CL:Set)(App:CL->CL->CL)(S:CL)(K:CL).
  Hypotheses
    (S_rule :
       forall A B C:CL, App (App (App S A) B) C = App (App A C)(App B C))
    (K_rule :
       forall A B:CL, App (App K A) B = A).

  Hint Rewrite  S_rule K_rule : CL_rules.

  Theorem obtain_I : forall A:CL, App (App (App S K) K) A = A.
  Proof.
    intros; autorewrite with CL_rules.
    reflexivity.
  Qed.

End combinatory_logic.

Theorem example_for_subst :
  forall (a b c d:nat), a = b+c -> c = 1 -> a+b = d -> 2*a = d+c.
Proof.
  intros a b c d H H1 H2.
  subst a.
  subst.
  lazy delta [mult] iota zeta beta;
    rewrite  plus_0_r;
    repeat rewrite plus_assoc_reverse;
    trivial.
Qed.

Open Scope Z_scope.

Theorem ring_example1 : forall x y:Z, (x+y) * (x+y)=x*x + 2*x*y + y*y.
Proof.
  intros x y; ring.
Qed.

Definition square (z:Z) := z*z.

Theorem ring_example2 :
  forall x y:Z, square (x+y) = square x + 2*x*y + square y.
Proof.
  intros x y; unfold square; ring.
Qed.

Theorem ring_example3 :
  (forall x y:nat, (x+y)*(x+y) = x*x + 2*x*y + y*y)%nat.
Proof.
  intros x y; ring.
Qed.

Theorem ring_example4 :
  (forall x:nat, (S x)*(x+1) = x*x + (x+x+1))%nat.
Proof.
  intro x; ring_simplify.
  trivial.
Qed.

Require Omega.

Theorem omega_example1 :
  forall x y z t:Z, x <= y <= z /\  z <= t <= x -> x = t.
Proof.
  intros x y z t H; omega.
Qed.

Theorem omega_example2 :
  forall x y:Z,
    0 <= square x -> 3*(square x) <= 2*y -> square x <= y.
Proof.
  intros x y H H0; omega.
Qed.

Theorem omega_example3 :
  forall x y:Z,
    0 <= x*x -> 3*(x*x) <= 2*y -> x*x <= y.
Proof.
  intros x y H H0; omega.
Qed.

Check (fun (X y:Z) => 0 <= X -> 3*X <= 2*y  ->  X < y).

Require Export Reals.

Open Scope R_scope.

Theorem example_for_field : forall x y:R, y <> 0 ->(x+y) / y = 1  +(x/y).
Proof.
  intros x y H; field.
  assumption.
Qed.

Require Import Lra.

Theorem example_for_Lra : forall x y:R, x-y >1 -> x - 2*y < 0 -> x > 1.
Proof.
  intros x y H H0.
  lra.
Qed.

Theorem ex_tauto1 : forall A B:Prop, A/\B->A.
Proof.
  tauto.
Qed.

Theorem ex_tauto2 : forall A B:Prop, A/\~A -> B.
Proof.
  tauto.
Qed.

Open Scope Z_scope.

Theorem ex_tauto3 : forall x y:Z, x<=y -> ~(x<=y) -> x=3.
Proof.
  tauto.
Qed.

Theorem ex_tauto4 : forall A B:Prop, A\/B -> B\/A.
Proof.
  tauto.
Qed.

Theorem ex_tauto5 :
  forall A B C D:Prop, (A->B)\/(A->C)->A->(B->D)->(C->D)->D.
Proof.
  tauto.
Qed.

Open Scope nat_scope.

Theorem example_intuition :
  (forall n p q:nat,  n <= p \/ n <= q -> n <= p \/ n <= S q).
Proof.
  intros n p q; intuition auto with arith.
Qed.

Ltac autoClear h := try (clear h; auto with arith; fail).

Ltac autoAfter tac := try (tac; auto with arith; fail).

Open Scope nat_scope.

Theorem example_for_autoAfter : forall  n p:nat,
    n < p -> n <= p -> 0 < p -> S n < S p.
Proof.
  intros n p H H0 H1.
  autoAfter ltac:(clear H0 H1).
Qed.

Open Scope nat_scope.

Ltac le_S_star := apply le_n || (apply le_S; le_S_star).

Theorem le_5_25 : 5 <= 25.
Proof.
  le_S_star.
Qed.

Ltac contrapose H :=
  match goal with
  | id:(~_) |- (~_) => intro H; apply id
  end.

Theorem example_contrapose :
  forall x y:nat, x <> y -> x <= y -> ~y <= x.
Proof.
  intros x y H H0.
  contrapose H'.
  auto with arith.
Qed.

Section primes.

  Definition divides (n m:nat) := exists p:nat, p*n = m.

  Lemma divides_O : forall n:nat, divides n 0.
  Proof.
    exists 0; reflexivity.
  Qed.

  Lemma divides_plus : forall n m:nat, divides n m -> divides n (n+m).
  Proof. intros n m [q Hq]; exists (S q). subst; ring. Qed.

  Lemma not_divides_plus : forall n m:nat, ~divides n m -> ~divides n (n+m).
    intros n m H [q Hq]; apply H; red.
    destruct q.
    - exists 0. simpl in *. lia.
    -   exists q; lia.
  Qed.

  Lemma not_divides_lt : forall n m:nat, 0<m -> m<n -> ~divides n m.
  Proof.
    intros n m H H0 [q Hq].
    subst.
    destruct q.
    lia.
    cbn in H0.
    lia.
  Qed.

  Lemma not_lt_2_divides : forall n m:nat, n<>1 -> n<2 -> 0 < m -> ~ divides n m.
  Proof.
    intros n m H H0 H1 [q Hq].
    subst.
    assert (n = 0) by lia.
    subst.
    lia.
  Qed.

  Lemma le_plus_minus : forall n m:nat, le n m -> m = n+(m-n).
  Proof. intros; lia. Qed.

  Lemma lt_lt_or_eq : forall n m:nat, n < S m ->  n<m \/ n=m.
  Proof. inversion 1; auto.
  Qed.

  Ltac check_not_divides :=
    match goal with
    | |- (~divides ?X1 ?X2) =>
      cut (X1<=X2);[ idtac | le_S_star ]; intros Hle;
      rewrite (le_plus_minus _ _ Hle); apply not_divides_plus;
      simpl; clear Hle; check_not_divides
    | |- _ => apply not_divides_lt; unfold lt; le_S_star

    end.
  Open Scope nat_scope.

  #[local] Hint Resolve lt_O_Sn : core.

  Ltac check_lt_not_divides :=
    match goal with
    | Hlt:(lt ?X1 2%nat) |- (~divides ?X1 ?X2) =>
      apply not_lt_2_divides; auto
    | Hlt:(lt ?X1 ?X2) |- (~divides ?X1 ?X3) =>
      elim (lt_lt_or_eq _ _ Hlt);
      [clear Hlt; intros Hlt; check_lt_not_divides
      | intros Heq; rewrite Heq; check_not_divides]
    end.

  Definition is_prime (p:nat) : Prop :=
    forall n:nat, n <> 1 -> lt n p -> ~divides n p.

  Theorem prime37 : is_prime 37.
  Proof.
    unfold is_prime; intros.
    check_lt_not_divides.
    Time Qed.

End primes.

Ltac clear_all :=
  match goal with
  | id:_ |- _ => clear id; clear_all
  | |- _ => idtac
  end.

Theorem clear_example_thm :
  forall (x y z:nat), x<z->z=2*x->0<x->x=2*y->y<z->x>y.
Proof.
  intros x y z H H1 H2 H3.
  generalize H1 H2 H3; clear_all; intros; omega.
Qed.

Theorem S_to_plus_one : forall n:nat, S n = n+1.
Proof.
  intros; rewrite plus_comm; reflexivity.
Qed.

Ltac S_to_plus_simpl :=
  match goal with
  | |-  context [(S ?X1)] =>
    match X1 with
    | 0%nat => fail 1
    | ?X2 => rewrite (S_to_plus_one X2); S_to_plus_simpl
    end
  | |- _ => idtac
  end.

Ltac a_function X1 :=
  match X1 with
  | 0%nat => fail 1
  | ?X2 => rewrite (S_to_plus_one X2); S_to_plus_simpl
  end.

Ltac simpl_on e :=
  let v := eval simpl in e in
      match goal with
      | |- context [e] => replace e with v; [idtac | auto]
      end.

Theorem simpl_on_example :
  forall n:nat, exists m : nat, (1+n) + 4*(1+n) = 5*(S m).
Proof.
  intros n; simpl_on (1+n).
  exists n; auto with arith.
Qed.


Require Export P07.

(** **** Exercise: 3 stars (CIf_congruence)  *)
Theorem CIf_congruence : forall b b' c1 c1' c2 c2',
  bequiv b b' -> cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv (IFB b THEN c1 ELSE c2 FI)
         (IFB b' THEN c1' ELSE c2' FI).
Proof.
  unfold cequiv. intros. split; intros.
  - inversion H2; subst.
    + rewrite H in H8. rewrite H0 in H9. eapply E_IfTrue. assumption. assumption.
    + rewrite H in H8. rewrite H1 in H9. eapply E_IfFalse. assumption. assumption.
  - inversion H2; subst.
    + rewrite <- H in H8. rewrite <- H0 in H9. eapply E_IfTrue. assumption. assumption.
    + rewrite <- H in H8. rewrite <- H1 in H9. eapply E_IfFalse. assumption. assumption.
Qed.


(** * Decide: Programming with Decision Procedures *)

Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From VFA Require Import Perm.

(* ################################################################# *)
(** * Using [reflect] to characterize decision procedures *)

(** Thus far in _Verified Functional Algorithms_ we have been using
   - propositions ([Prop]) such as [a<b] (which is Notation for [lt a b])
   - booleans ([bool]) such as [a<?b] (which is Notation for [ltb a b]). *)

Check Nat.lt.  (* : nat -> nat -> Prop *)
Check Nat.ltb.  (* : nat -> nat -> bool *)

(** The [Perm] chapter defined a tactic called [bdestruct] that
    does case analysis on (x <? y) while giving you hypotheses (above
    the line) of the form (x<y).   This tactic is built using the [reflect]
    type and the [ltb_reflect] theorem. *)

Print reflect.
(* Inductive reflect (P : Prop) : bool -> Set :=
    | ReflectT : P -> reflect P true
    | ReflectF : ~ P -> reflect P false  *)

Check ltb_reflect.  (* : forall x y, reflect (x<y) (x <? y) *)

(** The name [reflect] for this type is a reference to _computational
   reflection_,  a technique in logic.  One takes a logical formula, or
   proposition, or predicate,  and designs a syntactic embedding of
   this formula as an "object value" in the logic.  That is, _reflect_ the
   formula back into the logic. Then one can design computations
   expressible inside the logic that manipulate these syntactic object
   values.  Finally, one proves that the computations make transformations
   that are equivalent to derivations (or equivalences) in the logic.

   The first use of computational reflection was by Goedel, in 1931:
   his syntactic embedding encoded formulas as natural numbers, a
   "Goedel numbering."  The second and third uses of reflection were
   by Church and Turing, in 1936: they encoded (respectively)
   lambda-expressions and Turing machines.

   In Coq it is easy to do reflection, because the Calculus of Inductive
   Constructions (CiC) has Inductive data types that can easily encode
   syntax trees.  We could, for example, take some of our propositional
   operators such as [and], [or], and make an [Inductive] type that is an
   encoding of these, and build a computational reasoning system for
   boolean satisfiability.

   But in this chapter I will show something much simpler.  When
   reasoning about less-than comparisons on natural numbers, we have
   the advantage that [nat] is already an inductive type; it is "pre-reflected,"
   in some sense.  (The same for [Z], [list], [bool], etc.)  *)

(** Now, let's examine how [reflect] expresses the coherence between
  [lt] and [ltb]. Suppose we have a value [v] whose type is
  [reflect (3<7) (3<?7)].  What is [v]?  Either it is
  - ReflectT [P] (3<?7), where [P] is a proof of [3<7],  and [3<?7] is [true], or
  - ReflectF [Q] (3<?7), where [Q] is a proof of [~(3<7)], and [3<?7] is [false].
  In the case of [3,7], we are well advised to use [ReflectT], because
   (3<?7) cannot match the [false] required by [ReflectF]. *)

Goal (3<?7 = true). Proof. reflexivity. Qed.

(** So [v] cannot be [ReflectF Q (3<?7)] for any [Q], because that would
   not type-check.  Now, the next question:  must there exist a value
   of type [reflect (3<7) (3<?7)]  ?  The answer is yes; that is the
   [ltb_reflect] theorem.  The result of [Check ltb_reflect], above, says that
   for any [x,y], there does exist a value (ltb_reflect x y) whose type
   is exactly [reflect (x<y)(x<?y)].     So let's look at that value!  That is,
   examine what [H], and [P], and [Q] are equal to at "Case 1" and "Case 2": *)

Theorem three_less_seven_1: 3<7.
Proof.
assert (H := ltb_reflect 3 7).
remember (3<?7) as b.
destruct H as [P|Q] eqn:?.
* (* Case 1: H = ReflectT (3<7) P *)
apply P.
* (* Case 2: H = ReflectF (3<7) Q *)
compute in Heqb.
inversion Heqb.
Qed.

(** Here is another proof that uses [inversion] instead of [destruct].
   The [ReflectF] case is eliminated automatically by [inversion]
   because [3<?7] does not match [false]. *)

Theorem three_less_seven_2: 3<7.
Proof.
assert (H := ltb_reflect 3 7).
inversion H as [P|Q].
apply P.
Qed.

(** The [reflect] inductive data type is a way of relating a _decision
   procedure_ (a function from X to [bool]) with a predicate (a function
   from X to [Prop]).   The convenience of [reflect], in the verification
   of functional programs, is that we can do [destruct (ltb_reflect a b)],
   which relates [a<?b] (in the program) to the [a<b] (in the proof).
   That's just how the [bdestruct] tactic works; you can go back
   to [Perm.v] and examine how it is implemented in the [Ltac]
   tactic-definition language. *)

(* ################################################################# *)
(** * Using [sumbool] to Characterize Decision Procedures *)

Module ScratchPad.

(** An alternate way to characterize decision procedures,
   widely used in Coq, is via the inductive type [sumbool].

   Suppose [Q]  is a proposition, that is, [Q: Prop].  We say [Q] is
   _decidable_ if there is an algorithm for computing a proof of
   [Q] or [~Q].  More generally, when [P] is a predicate (a function
   from some type [T] to [Prop]), we say [P] is decidable when
   [forall x:T, decidable(P)].

   We represent this concept in Coq by an inductive datatype: *)

Inductive sumbool (A B : Prop) : Set :=
 | left : A -> sumbool A B
 | right : B -> sumbool A B.

(** Let's consider [sumbool] applied to two propositions: *)

Definition t1 := sumbool (3<7) (3>2).
Lemma less37: 3<7. Proof. lia. Qed.
Lemma greater23: 3>2. Proof. lia. Qed.

Definition v1a: t1 := left (3<7) (3>2) less37.
Definition v1b: t1 := right (3<7) (3>2) greater23.

(** A value of type [sumbool (3<7) (3>2)] is either one of:
  - [left] applied to a proof of (3<7), or
  - [right] applied to a proof of (3>2).   *)

(** Now let's consider: *)

Definition t2 := sumbool (3<7) (2>3).
Definition v2a: t2 := left (3<7) (2>3) less37.

(** A value of type [sumbool (3<7) (2>3)] is either one of:
  - [left] applied to a proof of (3<7), or
  - [right] applied to a proof of (2>3).
  But since there are no proofs of 2>3, only [left] values (such as [v2a])
  exist.  That's OK. *)

(** [sumbool] is in the Coq standard library, where there is [Notation]
   for it:  the expression [ {A}+{B} ] means [sumbool A B]. *)

Notation "{ A } + { B }" := (sumbool A B) : type_scope.

(** A very common use of [sumbool] is on a proposition and its negation.
   For example, *)

Definition t4 := forall a b, {a<b}+{~(a<b)}.

(** That expression, [forall a b, {a<b}+{~(a<b)}], says that for any
 natural numbers [a] and [b], either [a<b] or [a>=b].  But it is _more_
 than that!  Because [sumbool] is an Inductive type with two constructors
 [left] and [right], then given the [{3<7}+{~(3<7)}] you can pattern-match
 on it and learn _constructively_ which thing is true.  *)

Definition v3: {3<7}+{~(3<7)} := left _ _ less37.

Definition is_3_less_7:  bool :=
 match v3 with
 | left _ _ _ => true
 | right _ _ _ => false
 end.

Eval compute in is_3_less_7. (* = true : bool *)

Print t4.  (* = forall a b : nat, {a < b} + {~ a < b} *)

(** Suppose there existed a value [lt_dec] of type [t4].  That would be a
  _decision procedure_ for the less-than function on natural numbers.
  For any nats [a] and [b], you could calculate [lt_dec a b], which would
  be either [left ...] (if [a<b] was provable) or [right ...] (if [~(a<b)] was
  provable).

  Let's go ahead and implement [lt_dec].  We can base it on the function
  [ltb: nat -> nat -> bool] which calculates whether [a] is less than [b],
  as a boolean.  We already have a theorem that this function on booleans
  is related to the proposition [a<b]; that theorem is called [ltb_reflect]. *)

Check ltb_reflect.  (* : forall x y, reflect (x<y) (x<?y) *)

(** It's not too hard to use [ltb_reflect] to define [lt_dec] *)

Definition lt_dec (a: nat) (b: nat) : {a<b}+{~(a<b)} :=
match ltb_reflect a b with
| ReflectT _ P => left (a < b) (~ a < b) P
| ReflectF _ Q => right (a < b) (~ a < b) Q
end.

(** Another, equivalent way to define [lt_dec] is to use
     definition-by-tactic: *)

Definition lt_dec' (a: nat) (b: nat) : {a<b}+{~(a<b)}.
  destruct (ltb_reflect a b) as [P|Q]. left. apply P.  right. apply Q.
Defined.

Print lt_dec.
Print lt_dec'.

Theorem lt_dec_equivalent: forall a b, lt_dec a b = lt_dec' a b.
Proof.
intros.
unfold lt_dec, lt_dec'.
reflexivity.
Qed.

(** Warning: these definitions of [lt_dec] are not as nice as the
  definition in the Coq standard library, because these are not
  fully computable.  See the discussion below. *)

End ScratchPad.

(* ================================================================= *)
(** ** [sumbool] in the Coq Standard Library *)

Module ScratchPad2.
Locate sumbool. (* Coq.Init.Specif.sumbool *)
Print sumbool.

(** The output of [Print sumbool] explains that the first two arguments
   of [left] and [right] are implicit.  We use them as follows (notice that
   [left] has only one explicit argument [P]:  *)

Definition lt_dec (a: nat) (b: nat) : {a<b}+{~(a<b)} :=
match ltb_reflect a b with
| ReflectT _ P => left P
| ReflectF _ Q => right Q
end.

Definition le_dec (a: nat) (b: nat) : {a<=b}+{~(a<=b)} :=
match leb_reflect a b with
| ReflectT _ P => left P
| ReflectF _ Q => right Q
end.

(** Now, let's use [le_dec] directly in the implementation of insertion
   sort, without mentioning [ltb] at all. *)

Fixpoint insert (x:nat) (l: list nat) :=
  match l with
  | nil => x::nil
  | h::t => if le_dec x h then x::h::t else h :: insert x t
 end.

Fixpoint sort (l: list nat) : list nat :=
  match l with
  | nil => nil
  | h::t => insert h (sort t)
end.

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

(** **** Exercise: 2 stars, standard (insert_sorted_le_dec) *)
Lemma insert_sorted:
  forall a l, sorted l -> sorted (insert a l).
Proof.
  intros a l H.
  induction H.
  - constructor.
  - unfold insert.
    destruct (le_dec a x) as [ Hle | Hgt].

   (** Look at the proof state now.  In the first subgoal, we have
      above the line, [Hle: a <= x].  In the second subgoal, we have
      [Hgt: ~ (a < x)].  These are put there automatically by the
      [destruct (le_dec a x)].  Now, the rest of the proof can proceed
      as it did in [Sort.v], but using [destruct (le_dec _ _)] instead of
      [bdestruct (_ <=? _)]. *)

(* TODO: FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Decidability and Computability *)

(** Before studying the rest of this chapter, it is helpful to study the
   [ProofObjects] chapter of _Software Foundations volume 1_ if you
   have not done so already.

   A predicate [P: T->Prop] is _decidable_ if there is a computable
   function [f: T->bool] such that, forall [x:T], [f x = true <-> P x].
   The second and most famous example of an _undecidable_ predicate
   is the Halting Problem (Turing, 1936): [T] is the type of Turing-machine
   descriptions, and [P(x)] is, Turing machine [x] halts.  The first, and not
   as famous, example is due to Church, 1936 (six months earlier): test
   whether a lambda-expression has a normal form.  In 1936-37, as a
   first-year PhD student before beginning his PhD thesis work, Turing
   proved these two problems are equivalent.

   Classical logic contains the axiom [forall P, P \/ ~P].  This is not provable
   in core Coq, that is, in the bare Calculus of Inductive Constructions.  But
   its negation is not provable either.   You could add this axiom to Coq
   and the system would still be consistent (i.e., no way to prove [False]).

   But [P \/ ~P] is a weaker statement than [ {P}+{~P} ], that is,
   [sumbool P (~P)].  From [ {P}+{~P} ] you can actually _calculate_ or
   [compute] either [left (x:P)] or [right(y: ~P)].     From [P \/ ~P] you cannot
   [compute] whether [P] is true.  Yes, you can [destruct] it in a proof,
   but not in a calculation.

   For most purposes its unnecessary to add the axiom [P \/ ~P] to Coq,
   because for specific predicates there's a specific way to prove [P \/ ~P]
   as a theorem.  For example,  less-than on natural numbers is decidable,
   and the existence of [ltb_reflect] or [lt_dec] (as a theorem, not as an axiom)
   is a demonstration of that.

   Furthermore, in this "book" we are interested in _algorithms_.  An axiom
   [P \/ ~P] does not give us an algorithm to compute whether P is true.  As
   you saw in the definition of [insert] above, we can use [lt_dec] not only as
   a theorem that either [3<7] or [~(3<7)], we can use it as a function to
   compute whether [3<7].  In Coq, you can't compute with axioms!
   Let's try it: *)

Axiom lt_dec_axiom_1:  forall i j: nat, i<j \/ ~(i<j).

(** Now, can we use this axiom to compute with?  *)

(* Uncomment and try this:
Definition max (i j: nat) : nat :=
   if lt_dec_axiom_1 i j then j else i.
*)

(** That doesn't work, because an [if] statement requires an [Inductive]
  data type with exactly two constructors; but [lt_dec_axiom_1 i j] has
  type [i<j \/ ~(i<j)],  which is not Inductive.  But let's try a different axiom: *)

Axiom lt_dec_axiom_2:  forall i j: nat, {i<j} + {~(i<j)}.

Definition max_with_axiom (i j: nat) : nat :=
   if lt_dec_axiom_2 i j then j else i.

(** This typechecks, because [lt_dec_axiom_2 i j]  belongs to type
     [sumbool (i<j) (~(i<j))]   (also written [ {i<j} + {~(i<j)} ]), which does have
     two constructors.

     Now, let's use this function: *)

Eval compute in max_with_axiom 3 7.
  (*  = if lt_dec_axiom_2 3 7 then 7 else 3
     : nat *)

(** This [compute] didn't compute very much!  Let's try to evaluate it
    using [unfold]: *)

Lemma prove_with_max_axiom:   max_with_axiom 3 7 = 7.
Proof.
unfold max_with_axiom.
try reflexivity.  (* does not do anything, reflexivity fails *)
(* uncomment this line and try it:
   unfold lt_dec_axiom_2.
*)
destruct (lt_dec_axiom_2 3 7).
reflexivity.
contradiction n. lia.
Qed.

(** It is dangerous to add Axioms to Coq: if you add one that's inconsistent,
   then it leads to the ability to prove [False].  While that's a convenient way
   to get a lot of things proved, it's unsound; the proofs are useless.

   The Axioms above, [lt_dec_axiom_1] and [lt_dec_axiom_2], are safe enough:
   they are consistent.  But they don't help in computation.  Axioms are not
   useful here. *)

End ScratchPad2.

(* ################################################################# *)
(** * Opacity of [Qed] *)

(** This lemma [prove_with_max_axiom] turned out to be _provable_, but the proof
    could not go by _computation_.  In contrast, let's use [lt_dec], which was built
    without any axioms: *)

Lemma compute_with_lt_dec:  (if ScratchPad2.lt_dec 3 7 then 7 else 3) = 7.
Proof.
compute.
(* uncomment this line and try it:
   unfold ltb_reflect.
*)
Abort.

(** Unfortunately, even though [ltb_reflect] was proved without any axioms, it
    is an _opaque theorem_  (proved with [Qed] instead of with [Defined]), and
    one cannot compute with opaque theorems.  Not only that, but it is proved with
    other opaque theorems such as [iff_sym] and [Nat.ltb_lt].  If we want to
    compute with an implementation of [lt_dec] built from [ltb_reflect], then
    we will have to rebuild [ltb_reflect] without using [Qed] anywhere, only [Defined].

    Instead, let's use the version of [lt_dec] from the Coq standard library,
    which _is_ carefully built without any opaque ([Qed]) theorems.
*)

Lemma compute_with_StdLib_lt_dec:  (if lt_dec 3 7 then 7 else 3) = 7.
Proof.
compute.
reflexivity.
Qed.

(** The Coq standard library has many decidability theorems.  You can
   examine them by doing the following [Search] command. The results
   shown here are only for the subset of the library that's currently
   imported (by the [Import] commands above); there's even more out there. *)

Search ({_}+{~_}).
(*
reflect_dec: forall (P : Prop) (b : bool), reflect P b -> {P} + {~ P}
lt_dec: forall n m : nat, {n < m} + {~ n < m}
list_eq_dec:
  forall A : Type,
  (forall x y : A, {x = y} + {x <> y}) ->
  forall l l' : list A, {l = l'} + {l <> l'}
le_dec: forall n m : nat, {n <= m} + {~ n <= m}
in_dec:
  forall A : Type,
  (forall x y : A, {x = y} + {x <> y}) ->
  forall (a : A) (l : list A), {In a l} + {~ In a l}
gt_dec: forall n m : nat, {n > m} + {~ n > m}
ge_dec: forall n m : nat, {n >= m} + {~ n >= m}
eq_nat_decide: forall n m : nat, {eq_nat n m} + {~ eq_nat n m}
eq_nat_dec: forall n m : nat, {n = m} + {n <> m}
bool_dec: forall b1 b2 : bool, {b1 = b2} + {b1 <> b2}
Zodd_dec: forall n : Z, {Zodd n} + {~ Zodd n}
Zeven_dec: forall n : Z, {Zeven n} + {~ Zeven n}
Z_zerop: forall x : Z, {x = 0%Z} + {x <> 0%Z}
Z_lt_dec: forall x y : Z, {(x < y)%Z} + {~ (x < y)%Z}
Z_le_dec: forall x y : Z, {(x <= y)%Z} + {~ (x <= y)%Z}
Z_gt_dec: forall x y : Z, {(x > y)%Z} + {~ (x > y)%Z}
Z_ge_dec: forall x y : Z, {(x >= y)%Z} + {~ (x >= y)%Z}
*)

(** The type of [list_eq_dec] is worth looking at.  It says that if you
     have  a decidable equality for an element type [A], then
    [list_eq_dec] calculates for you a decidable equality for type [list A].
    Try it out: *)

Definition list_nat_eq_dec:
    (forall al bl : list nat, {al=bl}+{al<>bl}) :=
  list_eq_dec eq_nat_dec.

Eval compute in if list_nat_eq_dec [1;3;4] [1;4;3] then true else false.
 (* = false : bool *)

Eval compute in if list_nat_eq_dec [1;3;4] [1;3;4] then true else false.
 (* = true : bool *)

(** **** Exercise: 2 stars, standard (list_nat_in)

    Use [in_dec] to build this function. *)

Definition list_nat_in: forall (i: nat) (al: list nat), {In i al}+{~ In i al}
 (* TODO: REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example in_4_pi:  (if list_nat_in 4  [3;1;4;1;5;9;2;6] then true else false) = true.
Proof.
simpl.
(* reflexivity. *)
(* TODO: FILL IN HERE *) Admitted.
(** [] *)

(** In general, beyond [list_eq_dec] and [in_dec], one can construct a
     whole programmable calculus of decidability, using the
     programs-as-proof  language of Coq.  But is it a good idea?  Read on! *)

(* ################################################################# *)
(** * Advantages and Disadvantages of [reflect] Versus [sumbool] *)

(** I have shown two ways to program decision procedures in Coq,
    one using [reflect] and the other using [{_}+{~_}], i.e., [sumbool].

   - With [sumbool], you define _two_ things: the operator in [Prop]
      such as [lt: nat -> nat -> Prop] and the decidability "theorem"
      in [sumbool], such as [lt_dec: forall i j, {lt i j}+{~ lt i j}].  I say
      "theorem" in quotes because it's not _just_ a theorem, it's also
      a (nonopaque) computable function.

   - With [reflect], you define _three_ things:  the operator in [Prop],
      the operator in [bool] (such as [ltb: nat -> nat -> bool], and the
      theorem that relates them (such as [ltb_reflect]).

   Defining three things seems like more work than defining two.
   But it may be easier and more efficient.  Programming in [bool],
   you may have more control over how your functions are implemented,
   you will have fewer difficult uses of dependent types, and you
   will run into fewer difficulties with opaque theorems.

   However, among Coq programmers, [sumbool] seems to be more
   widely used, and it seems to have better support in the Coq standard
   library.  So you may encounter it, and it is worth understanding what
   it does.   Either of these two methods is a reasonable way of programming
   with proof.  *)

(* 2022-08-08 17:36 *)


Require Import Coq.Setoids.Setoid.
Require Import Coq.Program.Equality.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.

Require Import KA.Finite.
Require Import KA.Booleans.
Require Import KA.Terms.
Require Import KA.Scope.
Local Open Scope ka_scope.

Section Vectors.
  Variable (A: Type).
  Notation term := (term A).

  Definition vector (Q: Type) := Q -> term.

  Definition matrix (Q: Type) := Q -> Q -> term.
End Vectors.

Section VectorOperations.
  Context {A: Type}.
  Notation term := (term A).
  Notation vector := (vector A).
  Notation matrix := (matrix A).

  Definition vector_sum
    {Q: Type}
    (v1 v2: vector Q)
    (q: Q)
    : term
  :=
    (v1 q + v2 q)%ka
  .

  Definition vector_chomp
    {n: nat}
    (v: vector (position (S n)))
    (p: position n)
    : term
  :=
    v (PThere p)
  .

  Equations inner_product {n: nat} (v1 v2: vector (position n)): term := {
    @inner_product 0 _ _ :=
      zero;
    @inner_product (S _) v1 v2 :=
      v1 PHere ;; v2 PHere + inner_product (vector_chomp v1) (vector_chomp v2);
  }.

  Definition matrix_vector_product
    {n: nat}
    (m: matrix (position n))
    (v: vector (position n))
    (p: position n)
  :=
    inner_product (m p) v
  .

  Definition vector_scale_left
    {Q: Type}
    (t: term)
    (v: vector Q)
    (q: Q)
  :=
    t ;; v q
  .

  Definition vector_scale_right
    {Q: Type}
    (v: vector Q)
    (t: term)
    (q: Q)
  :=
    v q ;; t
  .

  Definition vector_index
    {X: Type}
    `{Finite X}
    (v: vector X)
    (p: position (length finite_enum))
  :
    term
  :=
    v (list_lookup p)
  .

  Definition vector_lookup
    {X: Type}
    `{Finite X}
    (v: vector (position (length finite_enum)))
    (x: X)
  :
    term
  :=
    v (list_index x)
  .

  Definition matrix_index
    {X: Type}
    `{Finite X}
    (m: matrix X)
    (p p': position (length finite_enum))
  :
    term
  :=
    m (list_lookup p) (list_lookup p')
  .

  Definition matrix_lookup
    {X: Type}
    `{Finite X}
    (m: matrix (position (length finite_enum)))
    (x x': X)
  :
    term
  :=
    m (list_index x) (list_index x')
  .
End VectorOperations.

Notation "v1 <+> v2" := (vector_sum v1 v2) (at level 40) : ka_scope.
Notation "# v" := (vector_chomp v) (at level 30) : ka_scope.
Notation "v1 ** v2" := (inner_product v1 v2) (at level 40) : ka_scope.
Notation "m <*> v" := (matrix_vector_product m v) (at level 40) : ka_scope.
Notation "t & v" := (vector_scale_left t v) (at level 30) : ka_scope.
Notation "v ;;; t" := (vector_scale_right v t) (at level 35) : ka_scope.

Section VectorEquiv.
  Context {A: Type}.
  Notation term := (term A).
  Notation vector := (vector A).

  Definition equiv_vec {Q: Type} (v1 v2: vector Q): Prop :=
    forall (q: Q), v1 q == v2 q
  .

  Notation "v1 === v2" := (equiv_vec v1 v2) (at level 70).

  Lemma equiv_vec_refl {Q: Type} (v: vector Q):
    v === v
  .
  Proof.
    now intro.
  Qed.

  Lemma equiv_vec_sym {Q: Type} (v1 v2: vector Q):
    v1 === v2 -> v2 === v1
  .
  Proof.
    intro; now intro.
  Qed.

  Lemma equiv_vec_trans {Q: Type} (v1 v2 v3: vector Q):
    v1 === v2 -> v2 === v3 -> v1 === v3
  .
  Proof.
    intros; intro.
    now transitivity (v2 q).
  Qed.

  Global Add Parametric Relation (Q: Type): (vector Q) equiv_vec
    reflexivity proved by equiv_vec_refl
    symmetry proved by equiv_vec_sym
    transitivity proved by equiv_vec_trans
    as equiv_equiv_vec
  .

  Global Add Parametric Morphism (Q: Type): vector_sum
    with signature (@equiv_vec Q) ==> equiv_vec ==> equiv_vec
    as vector_sum_mor
  .
  Proof.
    intros; intro.
    unfold vector_sum.
    now rewrite (H q), (H0 q).
  Qed.

  Global Add Parametric Morphism (n: nat): vector_chomp
    with signature (@equiv_vec (position (S n))) ==> equiv_vec
    as vector_comp_mor.
  Proof.
    intros.
    intro.
    unfold vector_chomp.
    now rewrite (H (PThere q)).
  Qed.

  Global Add Parametric Morphism (n: nat): inner_product
    with signature (@equiv_vec (position n)) ==> equiv_vec ==> term_equiv
    as inner_product_mor
  .
  Proof.
    intros.
    dependent induction n.
    - autorewrite with inner_product.
      reflexivity.
    - autorewrite with inner_product.
      rewrite (H PHere), (H0 PHere).
      apply ECongPlus; try reflexivity.
      apply IHn.
      + now rewrite H.
      + now rewrite H0.
  Qed.

  Definition lequiv_vec {Q: Type} (v1 v2: vector Q): Prop :=
    forall (q: Q), v1 q <= v2 q
  .
End VectorEquiv.

Notation "v1 === v2" := (equiv_vec v1 v2) (at level 70) : ka_scope.
Notation "v1 <== v2" := (lequiv_vec v1 v2) (at level 70) : ka_scope.

Section VectorProperties.
  Context {A: Type}.
  Notation term := (term A).
  Notation vector := (vector A).

  Lemma vector_scale_left_chomp
    {n: nat}
    (t: term)
    (v: vector (position (S n)))
  :
    t & (# v) === # (t & v)
  .
  Proof.
    now intro.
  Qed.

  Lemma vector_inner_product_scale_left
    {n: nat}
    (t: term)
    (v1 v2: vector (position n))
  :
    t ;; (v1 ** v2) == (t & v1) ** v2
  .
  Proof.
    dependent induction n.
    - autorewrite with inner_product.
      now rewrite ETimesZeroLeft.
    - autorewrite with inner_product.
      rewrite EDistributeLeft.
      rewrite IHn.
      unfold vector_scale_left at 2; simpl.
      rewrite vector_scale_left_chomp.
      rewrite ETimesAssoc.
      reflexivity.
  Qed.

  Lemma vector_chomp_sum
    {n: nat}
    (v1 v2: vector (position (S n)))
  :
    # (v1 <+> v2) === # v1 <+> # v2
  .
  Proof.
    now intro.
  Qed.

  Lemma vector_inner_product_distribute_left
    {n: nat}
    (v1 v2 v3: vector (position n))
  :
    v1 ** v3 + v2 ** v3 == (v1 <+> v2) ** v3
  .
  Proof.
    dependent induction n.
    - autorewrite with inner_product.
      now rewrite EPlusIdemp.
    - autorewrite with inner_product.
      rewrite EPlusAssoc.
      rewrite <- EPlusAssoc with (t3 := v2 PHere ;; v3 PHere).
      rewrite EPlusComm with (t1 := # v1 ** # v3).
      rewrite EPlusAssoc.
      rewrite <- EDistributeRight.
      rewrite <- EPlusAssoc.
      rewrite IHn.
      unfold vector_sum at 2.
      rewrite vector_chomp_sum.
      reflexivity.
  Qed.

  Lemma vector_inner_product_contained
    {n: nat}
    (v1 v2: vector (position n))
    (p: position n)
  :
    v1 p ;; v2 p <= v1 ** v2
  .
  Proof.
    dependent induction p.
    - autorewrite with inner_product.
      apply term_lequiv_split_left.
      apply term_lequiv_refl.
    - autorewrite with inner_product.
      apply term_lequiv_split_right.
      fold ((# v1) p).
      fold ((# v2) p).
      apply IHp.
  Qed.

  Global Add Parametric Morphism (n: nat): inner_product
    with signature eq ==> (@lequiv_vec A (position n)) ==> term_lequiv
    as inner_product_mor_mono
  .
  Proof.
    unfold term_lequiv; intros.
    dependent induction n.
    - autorewrite with inner_product.
      apply term_lequiv_refl.
    - autorewrite with inner_product.
      apply term_lequiv_split.
      + rewrite <- (H PHere).
        rewrite EDistributeLeft.
        repeat apply term_lequiv_split_left.
        apply term_lequiv_refl.
      + apply term_lequiv_split_right.
        apply IHn.
        intro p.
        apply H.
  Qed.

  Lemma vector_inner_product_contained_split
    {n: nat}
    (v1 v2: vector (position n))
    (t: term)
  :
    (forall p, v1 p ;; v2 p <= t) ->
    v1 ** v2 <= t
  .
  Proof.
    intros.
    dependent induction n.
    - autorewrite with inner_product.
      rewrite EPlusComm.
      now rewrite EPlusUnit.
    - autorewrite with inner_product.
      apply term_lequiv_split.
      + apply H.
      + apply IHn; intros.
        unfold vector_chomp.
        apply H.
  Qed.

  Lemma vector_scale_right_unit
    {Q: Type}
    (v: vector Q)
  :
    v ;;; 1 === v
  .
  Proof.
    intro q.
    unfold vector_scale_right.
    now rewrite ETimesUnitRight.
  Qed.

  Lemma vector_scale_right_chomp
    {n: nat}
    (v: vector (position (S n)))
    (t: term)
  :
    (# v) ;;; t === # (v ;;; t)
  .
  Proof.
    now intro.
  Qed.

  Lemma vector_inner_product_scale_right
    {n: nat}
    (v1 v2: vector (position n))
    (t: term)
  :
    (v1 ** v2) ;; t == v1 ** (v2 ;;; t)
  .
  Proof.
    dependent induction n.
    - autorewrite with inner_product.
      now rewrite ETimesZeroRight.
    - autorewrite with inner_product.
      rewrite EDistributeRight.
      rewrite IHn.
      unfold vector_scale_right at 2; simpl.
      rewrite vector_scale_right_chomp.
      rewrite ETimesAssoc.
      reflexivity.
  Qed.

  Lemma vector_lequiv_adjunction
    {X: Type}
    `{Finite X}
    (v1: vector (position (length finite_enum)))
    (v2: vector X)
  :
    v1 <== vector_index v2 <-> vector_lookup v1 <== v2
  .
  Proof.
    split; intros.
    - intro x.
      unfold vector_lookup.
      rewrite <- list_lookup_index at 2.
      rewrite <- list_lookup_index at 3.
      apply H0.
    - intro p.
      unfold vector_index.
      rewrite <- list_index_lookup at 1.
      apply H0.
  Qed.

  Lemma vector_lequiv_squeeze
    {X: Type}
    (v1 v2: vector X)
  :
    v1 <== v2 ->
    v2 <== v1 ->
    v1 === v2
  .
  Proof.
    intros; intro x.
    apply term_lequiv_squeeze.
    - apply H.
    - apply H0.
  Qed.
End VectorProperties.

Section VectorBool.
  Context {A: Type}.
  Notation vector := (vector A).
  Notation term := (term A).

  Global Program Instance matrix_finite
    (X Y: Type)
    `{Finite X}
    `{Finite Y}
  :
    Finite (X -> Y -> bool)
  := {|
    finite_enum := map curry finite_enum
  |}.
  Next Obligation.
    destruct (finite_dec (uncurry x1) (uncurry x2)).
    - left.
      extensionality x;
      extensionality y.
      replace x1 with (curry (uncurry x1)) by reflexivity.
      replace x2 with (curry (uncurry x2)) by reflexivity.
      now rewrite e.
    - right.
      contradict n.
      extensionality xy.
      destruct xy; simpl.
      now rewrite n.
  Defined.
  Next Obligation.
    replace x with (curry (uncurry x)) by reflexivity.
    apply in_map_iff.
    exists (uncurry x).
    intuition.
    replace finite_subsets
      with (@finite_enum (prod X Y -> bool) _)
      by reflexivity.
    apply finite_cover.
  Qed.
  Next Obligation.
    apply NoDup_map.
    - intros.
      extensionality xy.
      destruct xy.
      replace x with (uncurry (curry x)).
      replace y with (uncurry (curry y)).
      + simpl.
        now rewrite H1.
      + extensionality xy.
        now destruct xy.
      + extensionality xy.
        now destruct xy.
    - replace finite_subsets
        with (@finite_enum (prod X Y -> bool) _)
        by reflexivity.
      apply finite_nodup.
  Qed.

  Definition vector_inner_product_bool
    {X: Type}
    `{Finite X}
    (v1 v2: X -> bool)
  :
    bool
  :=
    disj (map (fun x => andb (v1 x) (v2 x)) finite_enum)
  .

  Definition matrix_product_bool
    {X: Type}
    `{Finite X}
    (m1 m2: X -> X -> bool)
    (x1 x2: X)
  :
    bool
  :=
    vector_inner_product_bool (m1 x1) (fun x => m2 x x2)
  .

  Lemma matrix_product_characterise
    {Q: Type}
    `{Finite Q}
    (m1 m2: Q -> Q -> bool)
    (q1 q2: Q)
  :
    matrix_product_bool m1 m2 q1 q2 = true <->
    exists (q3: Q), m1 q1 q3 = true /\ m2 q3 q2 = true
  .
  Proof.
    unfold matrix_product_bool.
    unfold vector_inner_product_bool.
    rewrite disj_true.
    rewrite in_map_iff.
    setoid_rewrite Bool.andb_true_iff.
    split; intros.
    - destruct H0 as [q3 [? ?]].
      now exists q3.
    - destruct H0 as [q3 [? ?]].
      exists q3; intuition.
  Qed.

  Lemma matrix_product_bool_unit_left
    {Q: Type}
    `{Finite Q}
    (m: Q -> Q -> bool)
  :
    matrix_product_bool finite_eqb m = m
  .
  Proof.
    extensionality q1;
    extensionality q2.
    destruct (m _ _) eqn:?.
    - apply matrix_product_characterise.
      exists q1; intuition.
      unfold finite_eqb.
      now destruct (finite_dec _ _).
    - apply Bool.not_true_iff_false.
      apply Bool.not_true_iff_false in Heqb.
      contradict Heqb.
      apply matrix_product_characterise in Heqb.
      destruct Heqb as [q3 [? ?]].
      unfold finite_eqb in H0.
      destruct (finite_dec _ _).
      + now subst.
      + discriminate.
  Qed.

  Lemma matrix_product_bool_unit_right
    {Q: Type}
    `{Finite Q}
    (m: Q -> Q -> bool)
  :
    matrix_product_bool m finite_eqb = m
  .
  Proof.
    extensionality q1;
    extensionality q2.
    destruct (m _ _) eqn:?.
    - apply matrix_product_characterise.
      exists q2; intuition.
      unfold finite_eqb.
      now destruct (finite_dec _ _).
    - apply Bool.not_true_iff_false.
      apply Bool.not_true_iff_false in Heqb.
      contradict Heqb.
      apply matrix_product_characterise in Heqb.
      destruct Heqb as [q3 [? ?]].
      unfold finite_eqb in H1.
      destruct (finite_dec _ _).
      + now subst.
      + discriminate.
  Qed.

  Lemma matrix_product_bool_associative
    {Q: Type}
    `{Finite Q}
    (m1 m2 m3: Q -> Q -> bool)
  :
    matrix_product_bool (matrix_product_bool m1 m2) m3 =
    matrix_product_bool m1 (matrix_product_bool m2 m3)
  .
  Proof.
    extensionality q1;
    extensionality q2.
    destruct (matrix_product_bool _ _ _) eqn:?; symmetry.
    - apply matrix_product_characterise in Heqb.
      destruct Heqb as [q3 [? ?]].
      apply matrix_product_characterise in H0.
      destruct H0 as [q4 [? ?]].
      apply matrix_product_characterise.
      exists q4; intuition.
      apply matrix_product_characterise.
      exists q3; intuition.
    - apply Bool.not_true_iff_false.
      apply Bool.not_true_iff_false in Heqb.
      contradict Heqb.
      apply matrix_product_characterise in Heqb.
      destruct Heqb as [q3 [? ?]].
      apply matrix_product_characterise in H1.
      destruct H1 as [q4 [? ?]].
      apply matrix_product_characterise.
      exists q4; intuition.
      apply matrix_product_characterise.
      exists q3; intuition.
  Qed.

  Definition vector_shift_both
    {Q: Type}
    `{Finite Q}
    (v: vector (prod (Q -> Q -> bool) (Q -> Q -> bool)))
    (h: Q -> Q -> bool)
    (fg: prod (Q -> Q -> bool) (Q -> Q -> bool))
  :
    term
  :=
    v (matrix_product_bool h (fst fg), matrix_product_bool h (snd fg))
  .

  Definition vector_shift_single
    {Q: Type}
    `{Finite Q}
    (v: vector (prod (Q -> Q -> bool) (Q -> Q -> bool)))
    (h: Q -> Q -> bool)
    (fg: prod (Q -> Q -> bool) (Q -> Q -> bool))
  :
    term
  :=
    v (fst fg, matrix_product_bool (snd fg) h)
  .
End VectorBool.


(** Binary trees the nodes of which are labelled with type A *)

Require Import Omega
        Inverse_Image Wellfounded.Inclusion Wf_nat.

Section Some_type_A.
Variable A: Type.

Inductive tree  : Type :=
  | leaf
  | node (label: A)(left_son right_son : tree).

Inductive subtree  (t:tree) : tree -> Prop :=
  | subtree1 : forall t'  (x:A), subtree  t (node  x t t')
  | subtree2 : forall (t':tree) (x:A), subtree  t (node  x t' t).

Theorem well_founded_subtree :  well_founded subtree.
Proof.
 intros t; induction  t as [ | x t1 IHt1 t2 IHt2].
 - split; inversion 1.
 - split; intros y Hsub; inversion_clear Hsub; assumption.
Qed.

(** Alternate arithmetic proof

   Using several lemmas in library Wellfounded, we use tree size
  as a measure for proving well_foundedness

*)

Fixpoint size (t:tree) : nat :=
match t with leaf => 1
           | node _ t1 t2 => 1 + size t1 + size t2
end.

Lemma subtree_smaller : forall (t t': tree), subtree t t' -> size t < size t'.
Proof.
 inversion 1;simpl;omega.
Qed.

Lemma well_founded_subtree' : well_founded subtree.
Proof.
 apply wf_incl with (fun t t' => size t < size t').
 intros x y Hxy; now  apply subtree_smaller.
 apply wf_inverse_image; apply lt_wf.
Qed.

End Some_type_A.


(** * An intrinsic encoding of Goedel's System T (STLC with natural numbers) *)

(** STLC part is basically a replay of test-suites and examples from the Equations plugin (some of them, in turn, based on Chlipala's CPDT) *)
(** We add a recursion over natural numbers and notations based on [Custom Entries] *)
From Equations Require Import Equations.
Require Import PeanoNat List HList.

Import ListNotations.

Import Nat.

Set Equations Transparent.

(** ** Basic definitions *)

Inductive Ty : Set :=
| tU : Ty
| tNat : Ty
| tArr : Ty -> Ty -> Ty.

Notation "A :-> B" := (tArr A B) (at level 70).

Definition Ctx := list Ty.

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

(** The intrincic syntax for STLC *)
Inductive Exp : Ctx -> Ty -> Type :=
| Star : forall {Γ}, Exp Γ tU
| Var : forall {Γ τ},
    τ ∈ Γ ->
    Exp Γ τ
| Lam : forall {Γ} (τ σ : Ty),
    Exp (τ :: Γ) σ ->
    Exp Γ (τ :-> σ)
| App : forall {Γ} (τ σ : Ty),
    Exp Γ (τ :-> σ) -> Exp Γ τ ->
    Exp Γ σ
| Zero : forall {Γ}, Exp Γ tNat
| Suc : forall {Γ}, Exp Γ (tNat :-> tNat)
| Nat_elim : forall {Γ τ}, Exp Γ τ -> Exp Γ (tNat :-> (τ :-> τ)) -> Exp Γ (tNat :-> τ).

(** Let's create custom notations for our lambda terms *)

Declare Custom Entry ty.
Declare Custom Entry lambda.

Notation "[\ e \]" := e (e custom ty at level 2).
Notation "'*'" := tU (in custom ty).
Notation "'ℕ'" := tNat (in custom ty at level 1).
Notation "'SUC'" := Suc (in custom lambda at level 1).
Notation " A -> B" := (tArr A B) (in custom ty at level 4, right associativity,
                                    A custom ty,
                                    B custom ty at level 4).
Notation "( x )" := x (in custom ty, x at level 2).

Notation "[! e !]" := e (e custom lambda at level 2).
Notation "()" := (Star) (in custom lambda).
Notation "'v0'" := (Var (here _)) (in custom lambda).
Notation "'v1'" := (Var (there _ (here _))) (in custom lambda).
Notation "'v2'" := (Var (there _ (there _ (here _)))) (in custom lambda).
Notation " 'λ' e : τ -> σ" := (Lam τ σ e) (in custom lambda at level 1,
                                              e custom lambda at level 2,
                                              τ custom ty at level 2,
                                              σ custom ty at level 2).
Notation " 'λ' e " := (Lam _ _ e) (in custom lambda at level 1,
                                             e custom lambda at level 2).

Notation " 'ℕ_elim' ( e0 , es ) " := (Nat_elim e0 es)
                                       (in custom lambda at level 1,
                                           e0 custom lambda,
                                           es custom lambda).

Notation "e1  e2" := (App _ _ e1 e2) (in custom lambda at level 1,
                                                e1 custom lambda,
                                                e2 custom lambda at level 2
                                                (* , *)
                                                (* τ custom ty at level 2, *)
                                                (* σ custom ty at level 2 *)
                                            ).
Notation "( x )" := x (in custom lambda, x at level 2).
Notation "{ x }" := x (in custom lambda, x constr).

Definition unit_arrow2 := [\ * -> * -> * \].

Definition id_unit : Exp [] (tU :-> tU) :=
  [! λ v0 : * -> * !].

Definition id_unit_unit : Exp [] (tU :-> (tU :-> tU)) :=
  [! λ λ v0 !].

Definition id_fun_unit : Exp [] ((tU :-> tU) :-> (tU :-> tU)) :=
  [! λ v0 !].

Definition id_unit_app : Exp [] (tU :-> tU) :=
  [! {id_fun_unit} (λ v0) !].

Reserved Notation "⟦ τ ⟧" (at level 50).

Definition nat_elim : forall A : Type, A -> (nat -> A -> A) -> nat -> A :=
  fun A => nat_rect (fun _ => A).

Equations denoteTy (τ : Ty) : Set :=
  { ⟦ tU ⟧ := unit;
    ⟦ tNat ⟧ := nat;
    ⟦ tArr τ1 τ2 ⟧ := ⟦ τ1 ⟧ -> ⟦ τ2 ⟧ }

where "⟦ τ ⟧" := (denoteTy τ).

Notation "ρ ,, x" := (HCons x ρ) (at level 50).

Reserved Notation "⟦ e ⟧ ρ" (at level 50).

Definition Env Γ := hlist Ty denoteTy Γ.

Equations denoteExp {Γ τ} (ρ : Env Γ) (e : Exp Γ τ) : ⟦τ⟧ :=
  { ⟦ Star ⟧ρ := tt;
    ⟦ Var i ⟧ρ  := hget ρ i;
    ⟦ Lam τ σ e ⟧ρ := fun (x : ⟦τ⟧) => denoteExp (ρ ,, x) e;
    ⟦ App τ σ e1 e2 ⟧ρ := (⟦e1⟧ρ) (⟦e2⟧ρ);
    ⟦ Zero ⟧ρ := O;
    ⟦ Suc ⟧ρ := S;
    ⟦ Nat_elim e0 f⟧ρ := fun n => nat_elim _ (⟦e0⟧ρ) (⟦f⟧ρ) n }

where "⟦ e ⟧ ρ" := (denoteExp ρ e).

Definition idf := ⟦ id_unit ⟧HNil.

Definition my_add_syn : Exp [] (tNat :-> (tNat :-> tNat)) :=
  [! λ λ (ℕ_elim(v0, (λ λ (SUC v0))) v1) !].

Definition my_add := Eval compute in ⟦my_add_syn⟧HNil.

Compute my_add 1 2.

Lemma my_add_add n m :
  my_add n m = n + m.
Proof.
  induction n;simpl;auto.
Qed.


(** ****************************************************************

Benedikt Ahrens
started March 2015

Extended by: Anders Mörtberg. October 2015

Rewritten using displayed categories by: Kobe Wullaert. October 2022

*******************************************************************)

(** ***************************************************************

Contents :

- Category of algebras of an endofunctor

- This category is saturated if base precategory is

- Lambek's lemma: if (A,a) is an inital F-algebra then a is an iso

- The natural numbers are initial for X ↦ 1 + X

******************************************************************)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.limits.initial.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.

(* The following are used for examples *)
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.NNO.

Local Open Scope cat.

(** ** Category of algebras of an endofunctor *)

Section Algebra_Definition.

  Context {C : category} (F : functor C C).

  Definition algebra_disp_cat_ob_mor : disp_cat_ob_mor C.
  Proof.
    use tpair.
    - exact (λ x, F x --> x).
    - exact (λ x y hx hy f, hx · f = #F f · hy).
  Defined.

  Definition algebra_disp_cat_id_comp
    : disp_cat_id_comp C algebra_disp_cat_ob_mor.
  Proof.
    split.
    - intros x hx ; cbn.
      rewrite !functor_id.
      rewrite id_left, id_right.
      apply idpath.
    - intros x y z f g hx hy hz hf hg ; cbn in *.
      rewrite !functor_comp.
      rewrite !assoc.
      rewrite hf.
      rewrite !assoc'.
      rewrite hg.
      apply idpath.
  Qed.

  Definition algebra_disp_cat_data : disp_cat_data C
    := algebra_disp_cat_ob_mor ,, algebra_disp_cat_id_comp.

  Definition algebra_disp_cat_axioms
    : disp_cat_axioms C algebra_disp_cat_data.
  Proof.
    repeat split ; intros ; try (apply homset_property).
    apply isasetaprop.
    apply homset_property.
  Qed.

  Definition algebra_disp_cat : disp_cat C
    := algebra_disp_cat_data ,, algebra_disp_cat_axioms.

  Definition category_FunctorAlg : category
    := total_category algebra_disp_cat.

  Definition FunctorAlg := category_FunctorAlg.

  Definition algebra_ob : UU := ob FunctorAlg.

  (* this coercion causes confusion, and it is not inserted when parsing most of the time
   thus removing coercion globally
   *)
  Definition alg_carrier (X : algebra_ob) : C := pr1 X.
  Local Coercion alg_carrier : algebra_ob >-> ob.

  Definition alg_map (X : algebra_ob) : F X --> X := pr2 X.

(** A morphism of F-algebras (F X, g : F X --> X) and (F Y, h : F Y --> Y)
    is a morphism f : X --> Y such that the following diagram commutes:
<<
>>>>>>> master
         F f
    F x ----> F y
    |         |
    | g       | h
    V         V
    x ------> y
         f
>>
 *)
Definition is_algebra_mor (X Y : algebra_ob) (f : alg_carrier X --> alg_carrier Y) : UU
  := alg_map X · f = #F f · alg_map Y.

  Definition algebra_mor (X Y : algebra_ob) : UU := FunctorAlg⟦X,Y⟧.
  Coercion mor_from_algebra_mor {X Y : algebra_ob} (f : algebra_mor X Y) : C⟦X, Y⟧ := pr1 f.

  Lemma algebra_mor_commutes (X Y : algebra_ob) (f : algebra_mor X Y)
    : alg_map X · f = #F f · alg_map Y.
  Proof.
    exact (pr2 f).
  Qed.

(*Definition algebra_mor_id (X : algebra_ob) : algebra_mor X X.
Proof.
  exists (identity _ ).
  abstract (unfold is_algebra_mor;
            rewrite id_right ;
            rewrite functor_id;
            rewrite id_left;
            apply idpath).
Defined.

Definition algebra_mor_comp (X Y Z : algebra_ob) (f : algebra_mor X Y) (g : algebra_mor Y Z)
  : algebra_mor X Z.
Proof.
  exists (f · g).
  abstract (unfold is_algebra_mor;
            rewrite assoc;
            rewrite algebra_mor_commutes;
            rewrite <- assoc;
            rewrite algebra_mor_commutes;
            rewrite functor_comp, assoc;
            apply idpath).
Defined.

Definition precategory_alg_ob_mor : precategory_ob_mor.
Proof.
  exists algebra_ob.
  exact algebra_mor.
Defined.

Definition precategory_alg_data : precategory_data.
Proof.
  exists precategory_alg_ob_mor.
  exists algebra_mor_id.
  exact algebra_mor_comp.
Defined.*)

End Algebra_Definition.

(* Definition isaset_algebra_mor {C : category} (F : functor C C) (X Y : algebra_ob F) : isaset (algebra_mor F X Y).
Proof.
  apply (isofhleveltotal2 2).
  - apply C.
  - intro f.
    apply isasetaprop.
    apply C.
Qed.*)

Definition algebra_mor_eq' {C : category} {F : functor C C} {X Y : algebra_ob F} (f g : algebra_mor F X Y)
  : (f : alg_carrier F X --> alg_carrier F Y) = g ≃ f = g.
Proof.
  apply invweq.
  apply subtypeInjectivity.
  intro a. apply C.
Defined.

Definition algebra_mor_eq {C : category} {F : functor C C} {X Y : FunctorAlg F} (f g : (FunctorAlg F)⟦X,Y⟧)
  : ((pr1 f : alg_carrier F X --> alg_carrier F Y) = (pr1 g)) -> f = g.
Proof.
  exact (algebra_mor_eq' f g).
Defined.

(* Lemma is_precategory_precategory_alg_data {C : category} (F : functor C C)
  : is_precategory (precategory_alg_data F).
Proof.
  repeat split; intros; simpl.
  - apply algebra_mor_eq.
    apply id_left.
  - apply algebra_mor_eq.
    apply id_right.
  - apply algebra_mor_eq.
    apply assoc.
  - apply algebra_mor_eq.
    apply assoc'.
Qed.

Definition precategory_FunctorAlg {C : category} (F : functor C C)
  : precategory := tpair _ _ (is_precategory_precategory_alg_data F).

Lemma has_homsets_FunctorAlg {C : category} (F : functor C C)
  : has_homsets (precategory_FunctorAlg F).
Proof.
  intros f g.
  apply isaset_algebra_mor.
Qed.

Definition category_FunctorAlg {C : category} (F : functor C C) : category
  := make_category  (precategory_FunctorAlg F) (has_homsets_FunctorAlg F).

Notation FunctorAlg := category_FunctorAlg.*)

Section fixacategory.

  Context {C : category}
          (F : functor C C).

(** forgetful functor from FunctorAlg to its underlying category *)

(* first step of definition *)
(* Definition forget_algebras_data : functor_data (FunctorAlg F) C.
Proof.
  set (onobs := fun alg : FunctorAlg F => dialgebra_carrier alg).
  apply (make_functor_data onobs).
  intros alg1 alg2 m.
  exact (mor_from_dialgebra_mor m).
Defined. *)

(* the forgetful functor *)
Definition forget_algebras : functor (category_FunctorAlg F) C := pr1_category (algebra_disp_cat F).
(*Proof.
  Check dialgebra_pr1.

  apply (make_functor forget_algebras_data).
  abstract ( split; [intro alg; apply idpath | intros alg1 alg2 alg3 m n; apply idpath] ).
Defined.*)

End fixacategory.

(** ** This category is saturated if the base category is  *)

Section FunctorAlg_saturated.

  Context {C : category}
          (H : is_univalent C)
          (F : functor C C).

  Definition algebra_eq_type (X Y : FunctorAlg F) : UU
    := ∑ p : z_iso (pr1 X) (pr1 Y), is_algebra_mor F X Y p.

Definition algebra_ob_eq (X Y : FunctorAlg F) :
  (X = Y) ≃ algebra_eq_type X Y.
Proof.
  eapply weqcomp.
  - apply total2_paths_equiv.
  - set (H1 := make_weq _ (H (pr1 X) (pr1 Y))).
    apply (weqbandf H1).
    simpl.
    intro p.
    destruct X as [X α].
    destruct Y as [Y β]; simpl in *.
    destruct p.
    rewrite idpath_transportf.
    unfold is_algebra_mor; simpl.
    rewrite functor_id.
    rewrite id_left, id_right.
    apply idweq.
Defined.

Definition is_z_iso_from_is_algebra_iso (X Y : FunctorAlg F) (f : X --> Y)
  : is_z_isomorphism f → is_z_isomorphism (pr1 f).
Proof.
  intro p.
  set (H' := z_iso_inv_after_z_iso (make_z_iso' f p)).
  set (H'':= z_iso_after_z_iso_inv (make_z_iso' f p)).
  exists (pr1 (inv_from_z_iso (make_z_iso' f p))).
  split; simpl.
  - apply (maponpaths pr1 H').
  - apply (maponpaths pr1 H'').
Defined.

Definition inv_algebra_mor_from_is_z_iso {X Y : FunctorAlg F} (f : X --> Y)
  : is_z_isomorphism (pr1 f) → (Y --> X).
Proof.
  intro T.
  set (fiso:=make_z_iso' (pr1 f) T).
  set (finv:=inv_from_z_iso fiso).
  exists finv.
  unfold finv.
  apply pathsinv0.
  apply z_iso_inv_on_left.
  simpl.
  rewrite functor_on_inv_from_z_iso.
  rewrite <- assoc.
  apply pathsinv0.
  apply z_iso_inv_on_right.
  simpl.
  apply (pr2 f).
Defined.

Definition is_algebra_iso_from_is_z_iso {X Y : FunctorAlg F} (f : X --> Y)
  : is_z_isomorphism (pr1 f) → is_z_isomorphism f.
Proof.
  intro T.
  exists (inv_algebra_mor_from_is_z_iso f T).
  split; simpl.
  - apply algebra_mor_eq.
    apply (z_iso_inv_after_z_iso (make_z_iso' (pr1 f) T)).
  - apply algebra_mor_eq.
    apply (z_iso_after_z_iso_inv (make_z_iso' (pr1 f) T)).
Defined.

Definition algebra_iso_first_z_iso {X Y : FunctorAlg F}
  : z_iso X Y ≃ ∑ f : X --> Y, is_z_isomorphism (pr1 f).
Proof.
  apply (weqbandf (idweq _ )).
  unfold idweq. simpl.
  intro f.
  apply weqimplimpl.
  - apply is_z_iso_from_is_algebra_iso.
  - apply is_algebra_iso_from_is_z_iso.
  - apply (isaprop_is_z_isomorphism (C:=FunctorAlg F) f).
  - apply (isaprop_is_z_isomorphism (pr1 f)).
Defined.

Definition swap (A B : UU) : A × B → B × A.
Proof.
  intro ab.
  exists (pr2 ab).
  exact (pr1 ab).
Defined.

Definition swapweq (A B : UU) : (A × B) ≃ (B × A).
Proof.
  exists (swap A B).
  apply (isweq_iso _ (swap B A)).
  - abstract ( intro ab; destruct ab; apply idpath ).
  - abstract ( intro ba; destruct ba; apply idpath ).
Defined.

Definition algebra_z_iso_rearrange {X Y : FunctorAlg F}
  : (∑ f : X --> Y, is_z_isomorphism (pr1 f)) ≃ algebra_eq_type X Y.
Proof.
  eapply weqcomp.
  - apply weqtotal2asstor.
  - simpl. unfold algebra_eq_type.
    apply invweq.
    eapply weqcomp.
    + apply weqtotal2asstor.
    + simpl. apply (weqbandf (idweq _ )).
      unfold idweq. simpl.
      intro f; apply swapweq.
Defined.

Definition algebra_idtoiso (X Y : FunctorAlg F) :
  (X = Y) ≃ z_iso X Y.
Proof.
  eapply weqcomp.
  - apply algebra_ob_eq.
  - eapply weqcomp.
    + apply (invweq (algebra_z_iso_rearrange)).
    + apply (invweq algebra_iso_first_z_iso).
Defined.

Lemma isweq_idtoiso_FunctorAlg (X Y : FunctorAlg F)
  : isweq (@idtoiso _ X Y).
Proof.
  apply (isweqhomot (algebra_idtoiso X Y)).
  - intro p. induction p.
    simpl.
    apply (z_iso_eq(C:=FunctorAlg F)). apply algebra_mor_eq.
    apply idpath.
  - apply (pr2 _ ).
Defined.

Lemma is_univalent_FunctorAlg : is_univalent (FunctorAlg F).
Proof.
  intros X Y.
  apply isweq_idtoiso_FunctorAlg.
Defined.

Lemma idtomor_FunctorAlg_commutes (X Y: FunctorAlg F) (e: X = Y)
  : mor_from_algebra_mor F (idtomor _ _ e) = idtomor _ _ (maponpaths (alg_carrier F) e).
Proof.
  induction e.
  apply idpath.
Qed.

Corollary idtoiso_FunctorAlg_commutes (X Y: FunctorAlg F) (e: X = Y)
  : mor_from_algebra_mor F (morphism_from_z_iso _ _ (idtoiso e))
    = idtoiso (maponpaths (alg_carrier F) e).
Proof.
  unfold morphism_from_z_iso.
  rewrite eq_idtoiso_idtomor.
  etrans.
  2: { apply pathsinv0, eq_idtoiso_idtomor. }
  apply idtomor_FunctorAlg_commutes.
Qed.

End FunctorAlg_saturated.

(** ** Lambek's lemma: If (A,a) is an initial F-algebra then a is an iso *)

Section Lambeks_lemma.

Variables (C : category) (F : functor C C).
Variables (Aa : FunctorAlg F) (AaIsInitial : isInitial (FunctorAlg F) Aa).

Local Definition AaInitial : Initial (FunctorAlg F) :=
  make_Initial _ AaIsInitial.

Local Notation A := (alg_carrier _ Aa).
Local Notation a := (alg_map _ Aa).

(* (FA,Fa) is an F-algebra *)
Local Definition FAa : FunctorAlg F := tpair (λ X, C ⟦F X,X⟧) (F A) (# F a).
Local Definition Fa' := InitialArrow AaInitial FAa.
Local Definition a' : C⟦A,F A⟧ := mor_from_algebra_mor F Fa'.
Local Definition Ha' := algebra_mor_commutes _ _ _ Fa'.

Lemma initialAlg_is_iso_subproof : is_inverse_in_precat a a'.
Proof.
  assert (Ha'a : a' · a = identity A).
  { assert (algMor_a'a : is_algebra_mor _ _ _ (a' · a)).
    { unfold is_algebra_mor, a'; rewrite functor_comp.
      eapply pathscomp0; [|eapply cancel_postcomposition; apply Ha'].
      apply assoc. }
    apply pathsinv0; set (X := tpair _ _ algMor_a'a).
    apply (maponpaths pr1 (!@InitialEndo_is_identity _ AaInitial X)).
  }
  split; trivial.
  eapply pathscomp0; [apply Ha'|]; cbn.
  rewrite <- functor_comp.
  eapply pathscomp0; [eapply maponpaths; apply Ha'a|].
  apply functor_id.
Qed.

Lemma initialAlg_is_z_iso : is_z_isomorphism a.
Proof.
  exists a'.
  exact initialAlg_is_iso_subproof.
Defined.

End Lambeks_lemma.

(** ** The natural numbers are intial for X ↦ 1 + X *)

(** This can be used as a definition of a natural numbers object (NNO) in
    any category with binary coproducts and a terminal object. We prove
    the universal property of NNOs below. *)

Section Nats.
  Context (C : category).
  Context (bc :  BinCoproducts C).
  Context (hsC :  has_homsets C).
  Context (T : Terminal C).

  Local Notation "1" := T.
  Local Notation "f + g" := (BinCoproductOfArrows _ _ _ f g).
  Local Notation "[ f , g ]" := (BinCoproductArrow _ _ f g).

  Let F : functor C C := BinCoproduct_of_functors _ _ bc
                                                  (constant_functor _ _ 1)
                                                  (functor_identity _).

  (** F on objects: X ↦ 1 + X *)
  Definition F_compute1 : ∏ c : C, F c = BinCoproductObject (bc 1 c) :=
    fun c => (idpath _).

  (** F on arrows: f ↦ [identity 1, f] *)
  Definition F_compute2 {x y : C} : ∏ f : x --> y, # F f = (identity 1) + f :=
    fun c => (idpath _).

  Definition nat_ob : UU := Initial (FunctorAlg F).

  Definition nat_ob_carrier (N : nat_ob) : ob C :=
    alg_carrier _ (InitialObject N).
  Local Coercion nat_ob_carrier : nat_ob >-> ob.

  (** We have an arrow alg_map : (F N = 1 + N) --> N,
      so by the η-rule (UMP) for the coproduct, we can assume that it
      arises from a pair of maps [nat_ob_z,nat_ob_s] by composing with
      coproduct injections.
<<
                  in1         in2
               1 ----> 1 + N <---- N
               |         |         |
      nat_ob_z |         | alg_map | nat_ob_s
               |         V         |
               +-------> N <-------+
>>
   *)
  Definition nat_ob_z (N : nat_ob) : (1 --> N) :=
    BinCoproductIn1 (bc 1 (alg_carrier F (pr1 N))) · (alg_map _ (pr1 N)).

  Definition nat_ob_s (N : nat_ob) : (N --> N) :=
    BinCoproductIn2 (bc 1 (alg_carrier F (pr1 N))) · (alg_map _ (pr1 N)).

  Local Notation "0" := (nat_ob_z _).

  (** Use the universal property of the coproduct to make any object with a
      point and an endomorphism into an F-algebra *)
  Definition make_F_alg {X : ob C} (f : 1 --> X) (g : X --> X) : ob (FunctorAlg F).
  Proof.
    refine (X,, _).
    exact (BinCoproductArrow _ f g).
  Defined.

  (** Using make_F_alg, X will be an F-algebra, and by initiality of N, there will
      be a unique morphism of F-algebras N --> X, which can be projected to a
      morphism in C. *)
  Definition nat_ob_rec (N : nat_ob) {X : ob C} :
    ∏ (f : 1 --> X) (g : X --> X), (N --> X) :=
    fun f g => mor_from_algebra_mor F (InitialArrow N (make_F_alg f g)).

  (** When calling the recursor on 0, you get the base case.
      Specifically,

        nat_ob_z · nat_ob_rec = f
   *)
  Lemma nat_ob_rec_z (N : nat_ob) {X : ob C} :
    ∏ (f : 1 --> X) (g : X --> X), nat_ob_z N · nat_ob_rec N f g = f.
  Proof.
    intros f g.

    pose (inlN := BinCoproductIn1 (bc 1 N)).
    pose (succ := nat_ob_s N).

    (** By initiality of N, there is a unique morphism making the following
        diagram commute:
<<
               inlN         identity 1 + nat_ob_rec
            1 -----> 1 + N -------------------------> 1 + X
                       |                                |
             alg_map N |                                | alg_map X
                       V                                V
                       N   -------------------------->  X
                                   nat_ob_rec
>>

        This proof uses somewhat idiosyncratic "forward reasoning", transforming
        the term "diagram" rather than the goal.
     *)
    pose
      (diagram :=
         maponpaths
           (fun x => inlN · x)
           (algebra_mor_commutes F (pr1 N) _ (InitialArrow N (make_F_alg f g)))).
    rewrite (F_compute2 _) in diagram.

    (** Using the η-rules for coproducts, we can assume that alg_map X = [f,g]
        for f : 1 --> X, g : X --> X. *)
    rewrite (BinCoproductArrowEta C 1 X (bc _ _) _ _) in diagram.

    (** Using the β-rules for coproducts, we can simplify some of the terms *)
    (** (identity 1 + _) · [f, g] --β--> [identity 1 · f, _ · g] *)
    rewrite (precompWithBinCoproductArrow C (bc 1 N) (bc 1 X)
                                          (identity 1) _ _ _) in diagram.

    (** inl · [identity 1 · f, _ · g] --β--> identity 1 · f *)
    rewrite (BinCoproductIn1Commutes C 1 N (bc 1 _) _ _ _) in diagram.

    (** We can dispense with the identity *)
    rewrite (id_left _) in diagram.

    rewrite assoc in diagram.
    rewrite (BinCoproductArrowEta C 1 N (bc _ _) _ _) in diagram.

    refine (_ @ (BinCoproductIn1Commutes C _ _ (bc 1 _) _ f g)).
    rewrite (!BinCoproductIn1Commutes C _ _ (bc 1 _) _ 0 succ).
    unfold nat_ob_rec in *.
    exact diagram.
  Defined.

  Opaque nat_ob_rec_z.

  (** The succesor case:

        nat_ob_s · nat_ob_rec = nat_ob_rec · g

      The proof is very similar.
   *)
  Lemma nat_ob_rec_s (N : nat_ob) {X : ob C} :
    ∏ (f : 1 --> X) (g : X --> X),
    nat_ob_s N · nat_ob_rec N f g = nat_ob_rec N f g · g.
  Proof.
    intros f g.

    pose (inrN := BinCoproductIn2 (bc 1 N)).
    pose (succ := nat_ob_s N).

    (** By initiality of N, there is a unique morphism making the same diagram
        commute as above, but with "inrN" in place of "inlN". *)
    pose
      (diagram :=
         maponpaths
           (fun x => inrN · x)
           (algebra_mor_commutes F (pr1 N) _ (InitialArrow N (make_F_alg f g)))).
    rewrite (F_compute2 _) in diagram.

    rewrite (BinCoproductArrowEta C 1 X (bc _ _) _ _) in diagram.

    (** Using the β-rules for coproducts, we can simplify some of the terms *)
    (** (identity 1 + _) · [f, g] --β--> [identity 1 · f, _ · g] *)
    rewrite (precompWithBinCoproductArrow C (bc 1 N) (bc 1 X)
                                          (identity 1) _ _ _) in diagram.

    (** inl · [identity 1 · f, _ · g] --β--> identity 1 · f *)
    rewrite (BinCoproductIn2Commutes C 1 N (bc 1 _) _ _ _) in diagram.

    rewrite assoc in diagram.
    rewrite (BinCoproductArrowEta C 1 N (bc _ _) _ _) in diagram.

    refine
      (_ @ maponpaths (fun x => nat_ob_rec N f g · x)
         (BinCoproductIn2Commutes C _ _ (bc 1 _) _ f g)).
    rewrite (!BinCoproductIn2Commutes C _ _ (bc 1 _) _ 0 (nat_ob_s N)).
    unfold nat_ob_rec in *.
    exact diagram.
  Defined.

  Opaque nat_ob_rec_s.

End Nats.

(** nat_ob implies NNO *)
Lemma nat_ob_NNO {C : category} (BC : BinCoproducts C) (hsC : has_homsets C) (TC : Terminal C) :
  nat_ob _ BC TC → NNO TC.
Proof.
intros N.
use make_NNO.
- exact (nat_ob_carrier _ _ _  N).
- apply nat_ob_z.
- apply nat_ob_s.
- intros n z s.
  use unique_exists.
  + apply (nat_ob_rec _ _ _ _ z s).
  + split; [ apply nat_ob_rec_z | apply nat_ob_rec_s ].
  + intros x; apply isapropdirprod; apply hsC.
  + intros x [H1 H2].
    transparent assert (xalg : (FunctorAlg (BinCoproduct_of_functors C C BC
                                              (constant_functor C C TC)
                                              (functor_identity C))
                                              ⟦ InitialObject N, make_F_alg C BC TC z s ⟧)).
    { refine (x,,_).
      abstract (apply pathsinv0; etrans; [apply precompWithBinCoproductArrow |];
                rewrite id_left, <- H1;
                etrans; [eapply maponpaths, pathsinv0, H2|];
                now apply pathsinv0, BinCoproductArrowUnique; rewrite assoc;
                apply maponpaths).
    }
    exact (maponpaths pr1 (InitialArrowUnique N (make_F_alg C BC TC z s) xalg)).
Defined.


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

Require Import Bvector.
Require Import Setoid.

Definition byte := Bvector 8.
Definition xor  := BVxor.

Lemma xor_commut : forall n x y, @xor n x y = xor y x.
Proof.
  intros.
  unfold xor, BVxor.
  apply (Vector.rect2 (fun m v1 v2 =>
    Vector.map2 (n:=m) xorb v1 v2 = Vector.map2 xorb v2 v1)).
  - reflexivity.
  - intros; cbn.
    now rewrite xorb_comm, H.
Qed.

Lemma xor_assoc : forall n x y z, @xor n x (xor y z) = xor (xor x y) z.
Proof.
  intros.
  unfold xor, BVxor.
  (* TODO: Finish this proof. *)
Admitted.

Lemma xor_nilpotent : forall n x, xor x x = Bvect_false n.
Proof.
  intros.
  unfold xor, BVxor, Bvect_false.
  induction x.
  - reflexivity.
  - now cbn; rewrite IHx, xorb_nilpotent.
Qed.

Lemma xor_false_r : forall n x, xor x (Bvect_false n) = x.
Proof.
  induction x.
  - reflexivity.
  - now cbn; rewrite IHx, xorb_false_r.
Qed.

Lemma xor_false_l : forall n x, xor (Bvect_false n) x = x.
Proof.
  induction x.
  - reflexivity.
  - cbn; rewrite IHx.
    now destruct h.
Qed.

Definition swap (vars : byte * byte) :=
  let '(x, y) := vars in
  let x := xor x y in
  let y := xor y x in
  let x := xor x y in
      (x, y).

Theorem swap_correct : forall x y, swap (x, y) = (y, x).
Proof.
  intros; unfold swap.
  rewrite (xor_commut y (xor x y)), xor_assoc.
  rewrite xor_nilpotent, xor_false_l.
  rewrite <- xor_assoc, xor_nilpotent, xor_false_r.
  reflexivity.
Qed.


(* Exercise 123 *)

Require Import BenB.

Variables A B C D : Prop.

Theorem exercise_123 : ((A \/ (A -> B)) -> B) -> B.
Proof.
imp_i a1.
imp_e (A \/ (A -> B)).
hyp a1.
dis_e (A \/ ~A) a2 a2.
LEM.
dis_i1.
hyp a2.
dis_i2.
imp_i a3.
neg_e A.
hyp a2.
hyp a3.
Qed.


(*Axioms*)
Require Import Classical.
Require Import ClassicalChoice.
Require Import FunctionalExtensionality.
Require Import PropExtensionality.
Require Import Description.
Require Import ClassicalDescription.
Require Import List.
Require Import Psatz.
Require Import Rbase.
Require Import Rfunctions.
Require Import Sets_basics.

Load Measure_basics.

Open Scope R_scope.

Check R.

(***********)
(*Notations*)
(***********)

Definition is_open_R (A : R -> Prop) :=
  forall x, A x -> exists epsilon, 0 < epsilon /\ forall y, 0 < y -> y < epsilon -> A (x - y) /\ A (x + y).

Definition M_interesting :=
  generated_sig_alg (fun x => True) (fun A => exists (a : R), A = right_infinite_open_int a).
Definition M_reals_borelian :=
  generated_sig_alg (fun x => True) (fun A => is_open_R A).

(*We want to show that M_reals_borelian = M_interesting.*)

(*First, we want to show that any open set in R is a countable union of intervals
 of the form ]- \infty ; a [, ]a ; b[ and ]b ; + \infty[.
We will call this important_lemma.*)

(*****************)
(*Important lemma*)
(*****************)


(** ** DTMC *)
Require Import Reals.
Require Import List.
Require Import ListSet.

Open Scope R_scope.

Require Import State.
Require Import TransitionMatrix.Definitions.
Require Import TransitionMatrix.Real.
Require Import Probabilities.

Record DTMC : Type := { S:  set State;
                        s0: State;
                        P:  TransitionMatrix R;
                        T:  set State }.

(** Well-formed DTMC *)

Definition wf_DTMC (d: DTMC) : Prop :=
  (In d.(s0) d.(S))
  /\ (incl d.(T) d.(S))
  /\ (forall s: State, In s d.(S) <-> StateMaps.In s d.(P))
  /\ (is_stochastic_matrix d.(P)).

(** Probability of going from a given state to any other within a set of target states. *)

Variable pr_set: DTMC -> State -> set State -> R.

Hypothesis wf_dtmc_yields_valid_probability:
  forall (d: DTMC) (s: State) (Tgt: set State),
    (wf_DTMC d /\ In s d.(S) /\ incl Tgt d.(T)) -> is_valid_prob (pr_set d s Tgt).

(** Probability of going from a given state to another within a DTMC. *)

Definition pr (d: DTMC) (s t: State): R := pr_set d s (set_add State.eq_dec t (empty_set State)).


Require Export LL.Misc.Utils.
Require Export LL.PLL.Syntax.

Export ListNotations.
Set Implicit Arguments.

Section LL2Sequent.
  Definition multiset := list.

  Reserved Notation "n '|--' B ';' L " (at level 80).

  Inductive LL2N:  nat -> multiset oo -> multiset oo -> Prop :=
  (* axioms *)
  | ll2_init : forall B A L n, Permutation L [atom A; perp A] -> n |-- B ; L
  | ll2_one : forall B n, n |-- B ; [One]
  | ll2_top : forall B M L n, Permutation L (Top :: M) ->
      n |-- B ; L
  (* additives *)
  | ll2_plus1 : forall B M F G L n, Permutation L ((AOr F G)::M) ->
      n |-- B ; F::M -> S n |-- B ; L
  | ll2_plus2 : forall B M F G L n, Permutation L ((AOr F G)::M) ->
      n |-- B ; G::M -> S n |-- B ; L
  | ll2_with : forall B M F G L n, Permutation L ((AAnd F G)::M) ->
      n |-- B ; F :: M ->
      n |-- B ; G :: M -> S n |-- B ; L
  (* multiplicatives *)
  | ll2_bot : forall B M L n, Permutation L (Bot :: M) ->
      n |-- B ; M -> S n |-- B ; L
  | ll2_par : forall B M F G L n, Permutation L ((MOr F G) :: M) ->
      n |-- B ; F::G::M -> S n |-- B ; L
  | ll2_tensor : forall B M N F G L n, Permutation L ((MAnd F G)::(M ++ N)) ->
                                        (n |-- B ; F::M) ->
                                        (n |-- B ; G::N) ->
                                        (S n) |-- B ; L
   (* exponentials *)
  | ll2_quest : forall B M F L n, Permutation L ((Quest F) :: M) ->
      n |-- F::B ; M -> S n |-- B ; L
  | ll2_bang : forall B F n,
      n |-- B ; [F] -> S n |-- B ; [Bang F]
  (* structurals *)
  | ll2_abs : forall B L F n,
     In F B -> n |-- B ; F::L -> S n |-- B ; L

  where "n '|--' B ';' L " := (LL2N n B L).

  Reserved Notation "'|--' B ';' L" (at level 80).

  Inductive LL2S:  multiset oo -> multiset oo -> Prop :=
  (* axioms *)
  | ll2_init' : forall B A L, Permutation L [atom A; perp A] -> |-- B ; L
  | ll2_one' : forall B, |-- B ; [One]
  | ll2_top' : forall B M L, Permutation L (Top :: M) ->
      |-- B ; L
  (* additives *)
  | ll2_plus1' : forall B M F G L, Permutation L ((AOr F G)::M) ->
      |-- B ; F::M -> |-- B ; L
  | ll2_plus2' : forall B M F G L, Permutation L ((AOr F G)::M) ->
      |-- B ; G::M -> |-- B ; L
  | ll2_with' : forall B M F G L, Permutation L ((AAnd F G)::M) ->
      |-- B ; F :: M ->
      |-- B ; G :: M -> |-- B ; L
  (* multiplicatives *)
  | ll2_bot' : forall B M L, Permutation L (Bot :: M) ->
      |-- B ; M -> |-- B ; L
  | ll2_par' : forall B M F G L, Permutation L ((MOr F G) :: M) ->
      |-- B ; F::G::M -> |-- B ; L
  | ll2_tensor' : forall B M N F G L, Permutation L ((MAnd F G)::(M ++ N)) ->
                                        |-- B ; F::M ->
                                        |-- B ; G::N ->
                                        |-- B ; L
  (* exponentials *)
  | ll2_quest' : forall B M F L, Permutation L ((Quest F) :: M) ->
      |-- F::B ; M -> |-- B ; L
  | ll2_bang' : forall B F,
      |-- B ; [F] -> |-- B ; [Bang F]
  (* structurals *)
  | ll2_abs' : forall B L F,
     In F B -> |-- B ; F::L -> |-- B ; L
  where "'|--' B ';' L " := (LL2S B L).

 End LL2Sequent .

Global Hint Constructors LL2N : core .
Global Hint Constructors LL2S : core.

Notation "'LL2' n '|--' B ';' L " := (LL2N n B L)  (at level 80).
Notation "'LL2' '|--' B ';' L " := (LL2S B L)  (at level 80).