(** * Ordered types, suprema/infima, continuity, etc. *)

(** See cpo.v and aCPO.v for more order-theoretic definitions that
  build upon those here. *)

From Coq Require Import
  Basics
  Morphisms
  PeanoNat
  Relation_Definitions
  Lia
  Equivalence
  ZArith
.

Local Open Scope program_scope.
Local Open Scope equiv_scope.

From algco Require Import
  axioms
  misc
  tactics
.

Create HintDb order.

(** Ordered types. *)
Class OType (A : Type) : Type :=
  { leq : relation A
  ; leq_preorder : PreOrder leq
  }.

#[global]
  Instance OType_Reflexive A `{o : OType A} : Reflexive leq.
Proof. destruct o; typeclasses eauto. Qed.

#[global]
  Instance OType_Transitive A `{o : OType A} : Transitive leq.
Proof. destruct o; typeclasses eauto. Qed.

Definition gt {A : Type} `{OType A} : relation A := fun x y => not (leq x y).

Definition lt {A : Type} `{OType A} : relation A := fun x y => leq x y /\ not (leq y x).

#[global]
  Instance Transitive_lt A `{o : OType A} : Transitive lt.
Proof.
  destruct o as [R [Hrefl Htrans]].
  intros x y z [H0 H1] [H2 H3].
  unfold lt; simpl in *; split.
  - eapply Htrans; eauto.
  - intro HC; apply H3.
    eapply Htrans; eauto.
Qed.

Declare Scope order_scope.
Notation "x '⊑' y" := (leq x y) (at level 70, no associativity) : order_scope.
Notation "x '⊏' y" := (lt x y) (at level 70, no associativity) : order_scope.
Local Open Scope order_scope.

(** Pointed ordered types *)
Class PType (A : Type) `{o : OType A} : Type :=
  { bot : A
  ; bot_le : forall x, bot ⊑ x }.

#[global] Hint Resolve bot_le : order.

Notation "⊥" := bot.

Lemma bot_leq {A} `{PType A} :
  forall a : A, ⊥ ⊑ a.
Proof. intro; apply bot_le. Qed.
#[global] Hint Resolve bot_leq : order.

(** Ordered types with a top element *)
Class TType (A : Type) `{o : OType A} : Type :=
  { top : A
  ; le_top : forall x, x ⊑ top }.

Notation "⊤" := top.

Lemma leq_top {A} `{TType A} :
  forall a : A, a ⊑ ⊤.
Proof. intro; apply le_top. Qed.
#[global] Hint Resolve leq_top : order.

(* [a] is an upper bound of [f] *)
Definition upper_bound {I A : Type} `{OType A} (a : A) (f : I -> A) :=
  forall i, f i ⊑ a.

(* [a] is a lower bound of [f] *)
Definition lower_bound {I A : Type} `{OType A} (a : A) (f : I -> A) :=
  forall i, a ⊑ f i.

(* [a] is the least upper bound of [f]. *)
Definition supremum {I A : Type} `{OType A} (a : A) (f : I -> A) :=
  upper_bound a f /\ forall x, upper_bound x f -> a ⊑ x.

(* [a] is the greatest lower bound of [f]. *)
Definition infimum {I A : Type} `{OType A} (a : A) (f : I -> A) :=
  lower_bound a f /\ forall x, lower_bound x f -> x ⊑ a.

(* f is an ascending ω-chain *)
Definition chain {A : Type} `{o : OType A} (f : nat -> A) : Prop :=
  forall i, f i ⊑ f (S i).

(* f is a descending ω-chain *)
Definition dec_chain {A : Type} `{o : OType A} (f : nat -> A) : Prop :=
  forall i, f (S i) ⊑ f i.

(* f is upward-directed. *)
(* When the order relation is interpreted as an approximation
relation, we can think of directed sets as sets of elements that are
all ultimately approximating the same thing. *)
Definition directed {I A : Type} `{OType A} (f : I -> A) : Prop :=
  forall i j : I, exists k : I, f i ⊑ f k /\ f j ⊑ f k.

(* f is downward-directed. *)
Definition downward_directed {I A : Type} `{OType A} (f : I -> A) : Prop :=
  forall i j : I, exists k : I, f k ⊑ f i /\ f k ⊑ f j.

#[global]
  Program Instance OType_Prop : OType Prop := {| leq := impl |}.
Next Obligation. constructor; intuition. Qed.

#[global]
  Program
  Instance PType_Prop : PType Prop := {| bot := False |}.
Next Obligation. intros []. Qed.
#[global] Hint Resolve PType_Prop : order.

#[global]
  Program
  Instance TType_Prop : TType Prop := {| top := True |}.
Next Obligation. intro; apply I. Qed.

Definition bool_le (a b : bool) : Prop :=
  match a, b with
  | false, _ => True
  | _, true => True
  | _, _ => False
  end.

#[global]
  Instance Reflexive_bool_le : Reflexive bool_le.
Proof. intros []; apply I. Qed.

#[global]
  Instance Transitive_bool_le : Transitive bool_le.
Proof. intros [] [] [] [] []; constructor; etransitivity; eauto. Qed.

#[global]
  Instance PreOrder_bool_le : PreOrder bool_le.
Proof. constructor; typeclasses eauto. Qed.

#[global]
  Instance OType_bool : OType bool :=
  {| leq := bool_le |}.

#[global]
  Program
  Instance PType_bool : PType bool :=
  {| bot := false |}.

#[global]
  Program
  Instance TType_bool : TType bool :=
  {| top := true |}.
Next Obligation. destruct x; apply I. Qed.

#[global]
  Program Instance OType_arrow A B {oB : OType B} : OType (A -> B) :=
  {| leq := fun f g => forall x, leq (f x) (g x) |}.
Next Obligation.
  constructor.
  - intros f x; reflexivity.
  - intros ?; etransitivity; eauto.
Qed.

#[global]
  Program Instance PType_arrow A B `{PType B} : PType (A -> B) :=
  {| bot := const bot |}.
Next Obligation. apply bot_le. Qed.

#[global]
  Program Instance TType_arrow A B `{TType B} : TType (A -> B) :=
  {| top := const top |}.
Next Obligation. apply le_top. Qed.

#[global]
  Instance OType_nat : OType nat := {| leq := Nat.le |}.

#[global]
  Instance OType_Z : OType Z := {| leq := Z.le |}.

Definition prod_le {A B} `{OType A} `{OType B} (x y : A * B) : Prop :=
  fst x ⊑ fst y /\ snd x ⊑ snd y.

#[global]
  Instance Reflexive_prod_le {A B} `{OType A} `{OType B} : Reflexive (@prod_le A B _ _).
Proof. constructor; reflexivity. Qed.

#[global]
  Instance Transitive_prod_le {A B} `{OType A} `{OType B} : Transitive (@prod_le A B _ _).
Proof. intros [] [] [] [] []; constructor; etransitivity; eauto. Qed.

#[global]
  Instance PreOrder_prod_le {A B} `{OType A} `{OType B} : PreOrder (@prod_le A B _ _).
Proof. constructor; typeclasses eauto. Qed.

#[global]
  Instance OType_prod {A B} `{OType A} `{OType B} : OType (A * B) :=
  {| leq := prod_le |}.

Definition sum_le {A B} `{OType A} `{OType B} (x y : A + B) : Prop :=
  match (x, y) with
  | (inl a, inl a') => a ⊑ a'
  | (inr b, inr b') => b ⊑ b'
  | _ => False
  end.

#[global]
  Instance Reflexive_sum_le {A B} `{OType A} `{OType B} : Reflexive (@sum_le A B _ _).
Proof. unfold sum_le; intros []; reflexivity. Qed.

#[global]
  Instance Transitive_sum_le {A B} `{OType A} `{OType B} : Transitive (@sum_le A B _ _).
Proof. unfold sum_le; intros [a1|b1] [a2|b2] [a3|b3]; firstorder; etransitivity; eauto. Qed.

#[global]
  Instance PreOrder_sum_le {A B} `{OType A} `{OType B} : PreOrder (@sum_le A B _ _).
Proof. constructor; typeclasses eauto. Qed.

#[global]
  Instance OType_sum {A B} `{OType A} `{OType B} : OType (A + B) :=
  {| leq := sum_le |}.

Definition equ {A : Type} `{OType A} (x y : A) := x ⊑ y /\ y ⊑ x.

#[global]
  Instance Reflexive_equ A `{o : OType A} : Reflexive equ.
Proof. destruct o as [? [Hrefl ?]]; split; apply Hrefl. Qed.

#[global]
  Instance Transitive_equ A `{o : OType A} : Transitive equ.
Proof.
  intros x y z Hxy Hyz.
  destruct o as [? [? Htrans]]; split.
  - etransitivity. apply Hxy. apply Hyz.
  - etransitivity. apply Hyz. apply Hxy.
Qed.

#[global]
  Instance Symmetric_equ A `{OType A} : Symmetric equ.
Proof. unfold Symmetric, equ; intuition. Qed.

#[global]
  Program
  Instance Equivalence_equ A `{OType A} : Equivalence equ.

Lemma le_bot {A} `{PType A} (a : A) :
  a ⊑ ⊥ ->
  a === ⊥.
Proof. intro Hle; split; auto; apply bot_le. Qed.

#[global]
  Instance Proper_leq {A} `{OType A} : Proper (equ ==> equ ==> flip impl) leq.
Proof.
  intros x y [Hxy Hyx] a b [Hab Hba] Hle.
  etransitivity; eauto.
  etransitivity; eauto.
Qed.

#[global]
  Instance Proper_monotone_equ {A B} `{OType A} `{OType B} (f : A -> B)
  {pf: Proper (leq ==> leq) f} : Proper (equ ==> equ) f.
Proof. intros a b Hab; split; apply pf, Hab. Qed.

#[global]
  Instance Proper_monotone_equ2 {A B C} `{OType A} `{OType B} `{OType C} (f : A -> B -> C)
  {pf: Proper (leq ==> leq ==> leq) f} : Proper (equ ==> equ ==> equ) f.
Proof. intros a b Hab c d Hcd; split; apply pf; firstorder. Qed.

#[global]
  Instance Proper_monotone_eq_equ {A B C} `{OType A} `{OType B} `{OType C} (f : A -> B -> C)
  {pf: Proper (leq ==> eq ==> leq) f} : Proper (equ ==> eq ==> equ) f.
Proof. intros a b Hab c d Hcd; split; apply pf; firstorder. Qed.

#[global]
  Instance Proper_antimonotone_equ {A B} `{OType A} `{OType B} (f : A -> B)
  {pf: Proper (leq ==> flip leq) f} : Proper (equ ==> equ) f.
Proof. intros a b Hab; split; apply pf, Hab. Qed.

Definition incomparable {A} `{OType A} (x y : A) : Prop :=
  ~ (x ⊑ y \/ y ⊑ x).

Definition bounded_above {A B : Type} `{OType B} (f : A -> B) :=
  exists b, upper_bound b f.

Definition eventually_constant_at {A} `{OType A} (f : nat -> A) (x : A) : Prop :=
  exists n0, forall n, (n0 <= n)%nat -> f n === x.

Lemma infimum_unique {A B : Type} `{o : OType B} (x y : B) (f : A -> B) :
  infimum x f -> infimum y f -> x === y.
Proof.
  intros [H0 H1] [H2 H3]; split.
  - apply H3; auto.
  - apply H1; auto.
Qed.

Lemma supremum_unique {A B : Type} `{o : OType B} (x y : B) (f : A -> B) :
  supremum x f -> supremum y f -> x === y.
Proof.
  intros [H0 H1] [H2 H3]; split.
  - apply H1; auto.
  - apply H3; auto.
Qed.

(* [f] is monotone whenever it is order-preserving. *)
Definition monotone {A B : Type} `{OType A} `{OType B} (f : A -> B) :=
  Proper (leq ==> leq) f.
#[global] Hint Unfold monotone : order.

(* [f] is antimonotone whenever it is order-reversing. *)
Definition antimonotone {A B : Type} `{OType A} `{OType B} (f : A -> B) :=
  Proper (leq ==> flip leq) f.
#[global] Hint Unfold antimonotone : order.

Lemma monotone_chain {A B : Type} `{OType A} `{OType B} (f : A -> B) (g : nat -> A) :
  monotone f ->
  chain g ->
  chain (f ∘ g).
Proof. intros Hmono Hg i; apply Hmono, Hg. Qed.

Lemma monotone_directed {I A B : Type} `{OType A} `{OType B} (f : A -> B) (g : I -> A) :
  monotone f ->
  directed g ->
  directed (f ∘ g).
Proof.
  intros Hf Hg i j.
  specialize (Hg i j); destruct Hg as [k [Hk Hk']].
  exists k; split; eauto.
Qed.
#[global] Hint Resolve monotone_directed : order.

Lemma antimonotone_directed {I A B : Type} `{OType A} `{OType B} (f : A -> B) (g : I -> A) :
  antimonotone f ->
  downward_directed g ->
  directed (f ∘ g).
Proof.
  intros Hf Hg i j.
  specialize (Hg i j); destruct Hg as [k [Hk Hk']].
  exists k; split; apply Hf; auto.
Qed.
#[global] Hint Resolve antimonotone_directed : order.

Lemma monotone_downward_directed {I A B : Type} `{OType A} `{OType B}
  (f : A -> B) (g : I -> A) :
  monotone f ->
  downward_directed g ->
  downward_directed (f ∘ g).
Proof.
  intros Hf Hg i j.
  specialize (Hg i j); destruct Hg as [k [Hk Hk']].
  exists k; split; apply Hf; auto.
Qed.
#[global] Hint Resolve monotone_downward_directed : order.

Lemma antimonotone_downward_directed {I A B : Type} `{OType A} `{OType B}
  (f : A -> B) (g : I -> A) :
  antimonotone f ->
  directed g ->
  downward_directed (f ∘ g).
Proof.
  intros Hf Hg i j.
  specialize (Hg i j); destruct Hg as [k [Hk Hk']].
  exists k; split; apply Hf; auto.
Qed.
#[global] Hint Resolve antimonotone_downward_directed : order.

Lemma monotone_dec_chain {A B : Type} `{OType A} `{OType B} (f : A -> B) (g : nat -> A) :
  monotone f ->
  dec_chain g ->
  dec_chain (f ∘ g).
Proof. intros Hmono Hg i; apply Hmono, Hg. Qed.

Lemma antimonotone_dec_chain {A B : Type} `{OType A} `{OType B} (f : A -> B) (g : nat -> A) :
  antimonotone f ->
  chain g ->
  dec_chain (f ∘ g).
Proof. intros Hmono Hg i; apply Hmono, Hg. Qed.

Lemma antimonotone_chain {A B : Type} `{OType A} `{OType B} (f : A -> B) (g : nat -> A) :
  antimonotone f ->
  dec_chain g ->
  chain (f ∘ g).
Proof. intros Hmono Hg i; apply Hmono, Hg. Qed.

Lemma monotone_compose {A B C : Type} `{OType A} `{OType B} `{OType C}
  (f : A -> B) (g : B -> C) :
  monotone f ->
  monotone g ->
  monotone (g ∘ f).
Proof. intros Hf Hg x y Hleq; apply Hg, Hf; auto. Qed.
#[global] Hint Resolve monotone_compose : order.

Lemma monotone_compose' {A B C : Type} `{OType A} `{OType B} `{OType C}
  (f : A -> B) (g : B -> C) :
  monotone f ->
  monotone g ->
  monotone (fun x => g (f x)).
Proof. intros Hf Hg x y Hleq; apply Hg, Hf; auto. Qed.
#[global] Hint Resolve monotone_compose' : order.

Lemma monotone_antimonotone_compose {A B C : Type} `{OType A} `{OType B} `{OType C}
  (f : A -> B) (g : B -> C) :
  monotone f ->
  antimonotone g ->
  antimonotone (g ∘ f).
Proof. intros Hf Hg x y Hleq; apply Hg, Hf; auto. Qed.

Lemma antimonotone_monotone_compose {A B C : Type} `{OType A} `{OType B} `{OType C}
  (f : A -> B) (g : B -> C) :
  antimonotone f ->
  monotone g ->
  antimonotone (g ∘ f).
Proof. intros Hf Hg x y Hleq; apply Hg, Hf; auto. Qed.

Lemma antimonotone_compose {A B C : Type}
  `{OType A} `{OType B} `{OType C} (f : A -> B) (g : B -> C) :
  antimonotone f ->
  antimonotone g ->
  monotone (g ∘ f).
Proof. intros Hf Hg x y Hleq; apply Hg, Hf; auto. Qed.
#[global] Hint Resolve antimonotone_compose : order.

Lemma chain_leq {A : Type} `{o : OType A} (f : nat -> A) (n m : nat) :
  chain f ->
  (n <= m)%nat ->
  leq (f n) (f m).
Proof.
  intros Hchain Hle; induction m.
  - assert (n = O). lia. subst; reflexivity.
  - destruct (Nat.eqb_spec n (S m)); subst.
    + reflexivity.
    + assert (H': (n <= m)%nat). lia.
      etransitivity. apply IHm; auto.
      apply Hchain.
Qed.

Lemma dec_chain_leq {A : Type} `{o : OType A} (f : nat -> A) (n m : nat) :
  dec_chain f ->
  (n <= m)%nat ->
  leq (f m) (f n).
Proof.
  intros Hchain Hle; induction m.
  - assert (n = O). lia. subst; reflexivity.
  - destruct (Nat.eqb_spec n (S m)); subst.
    + reflexivity.
    + assert (H': (n <= m)%nat). lia.
      etransitivity. apply Hchain. apply IHm; auto.
Qed.

Lemma const_infimum {A : Type} {o : OType A} (ch : nat -> A) (c : A) :
  (forall i, ch i === c) -> infimum c ch.
Proof.
  intros Hequ; split.
  - intro; apply Hequ.
  - intros lb Hlb.
    specialize (Hlb O); specialize (Hequ O).
    etransitivity; eauto; apply Hequ.
Qed.

Lemma const_supremum {A : Type} {o : OType A} (f : nat -> A) (x : A) :
  (forall i, f i === x) -> supremum x f.
Proof.
  intros Hequ; split.
  - intro; apply Hequ.
  - intros ub Hub.
    specialize (Hub O); specialize (Hequ O).
    etransitivity; eauto; apply Hequ.
Qed.

Lemma const_supremum'' {A : Type} `{o : OType A} (f : nat -> A) (x : A) :
  upper_bound x f ->
  (exists n, f n === x) ->
  supremum x f.
Proof.
  intros Hx [n0 Hequ].
  split; auto.
  - intros ub Hub.
    transitivity (f n0).
    apply Hequ; auto.
    apply Hub.
Qed.

#[global]
  Instance Proper_infimum {A B : Type} {oB : OType B}
  : Proper (equ ==> equ ==> iff) (@infimum A B oB).
Proof.
  intros x y [Hequ0 Hequ1] f g [Hequ0' Hequ1'].
  split; intros [Hlb Hglb].
  - split.
    + intro z.
      transitivity x; auto.
      transitivity (f z); auto.
    + intros lb Hlb'.
      transitivity x; auto.
      apply Hglb.
      intro z; transitivity (g z); auto.
  - split.
    + intro z.
      transitivity y; auto.
      transitivity (g z); auto.
    + intros lb Hlb'.
      transitivity y; auto.
      apply Hglb.
      intro z; transitivity (f z); auto.
Qed.

#[global]
  Instance Proper_supremum {A B : Type} {oB : OType B}
  : Proper (equ ==> equ ==> iff) (@supremum A B oB).
Proof.
  intros x y [Hequ0 Hequ1] f g [Hequ0' Hequ1'].
  split; intros [Hub Hlub].
  - split.
    + intro z.
      transitivity x; auto.
      transitivity (f z); auto.
    + intros ub Hub'.
      transitivity x; auto.
      apply Hlub.
      intro z; transitivity (g z); auto.
  - split.
    + intro z.
      transitivity y; auto.
      transitivity (g z); auto.
    + intros lb Hub'.
      transitivity y; auto.
      apply Hlub.
      intro z; transitivity (f z); auto.
Qed.

Definition continuous {A B : Type} `{OType A} `{OType B} (f : A -> B) :=
  forall g : nat -> A,
    directed g ->
    forall a : A,
      supremum a g ->
      supremum (f a) (f ∘ g).

(* A function is cocontinuous when it is continuous wrt the opposite
   order relation. *)
Definition cocontinuous {A B : Type} `{OType A} `{OType B} (f : A -> B) :=
  forall g : nat -> A,
    directed g ->
    forall a : A,
      supremum a g ->
      infimum (f a) (f ∘ g).

(* ω-continuity is a weaker notion in general than directed-continuity
   (e.g., in the CPO of reals). In general, a function that is
   d-continuous is also ω-continuous, but the converse may not
   hold. *)
Definition wcontinuous {A B : Type} `{OType A} `{OType B} (f : A -> B) :=
  forall g : nat -> A,
    chain g ->
    forall a : A,
      supremum a g ->
      supremum (f a) (f ∘ g).

(* Definition wcontinuous2 {A B C : Type} `{OType A} `{OType B} `{OType C} (f : A -> B -> C) := *)
(*   forall (g : nat -> A) (h : nat -> B), *)
(*     chain g -> *)
(*     chain h -> *)
(*     forall (a : A) (b : B), *)
(*       supremum a g -> *)
(*       supremum b h -> *)
(*       supremum (f a b) (fun i => f (g i) (h i)). *)

Definition wcocontinuous {A B : Type} `{OType A} `{OType B} (f : A -> B) :=
  forall g : nat -> A,
    chain g ->
    forall a : A,
      supremum a g ->
      infimum (f a) (f ∘ g).

Definition dec_continuous {A B : Type} `{OType A} `{OType B} (f : A -> B) :=
  forall g : nat -> A,
    downward_directed g ->
    forall a : A,
      infimum a g ->
      infimum (f a) (f ∘ g).

Definition dec_cocontinuous {A B : Type} `{OType A} `{OType B} (f : A -> B) :=
  forall g : nat -> A,
    downward_directed g ->
    forall a : A,
      infimum a g ->
      supremum (f a) (f ∘ g).

Definition dec_wcontinuous {A B : Type} `{OType A} `{OType B} (f : A -> B) :=
  forall g : nat -> A,
    dec_chain g ->
    forall inf : A,
      infimum inf g ->
      infimum (f inf) (f ∘ g).

Lemma chain_directed {A} `{OType A} (f : nat -> A) :
  chain f ->
  directed f.
Proof.
  intros Hch i j.
  exists (max i j); split; apply chain_leq; auto.
  - apply Nat.le_max_l.
  - apply Nat.le_max_r.
Qed.
#[global] Hint Resolve chain_directed : order.

Lemma dec_chain_downward_directed {A} `{OType A} (f : nat -> A) :
  dec_chain f ->
  downward_directed f.
Proof.
  intros Hch i j.
  exists (max i j); split; apply dec_chain_leq; auto.
  - apply Nat.le_max_l.
  - apply Nat.le_max_r.
Qed.
#[global] Hint Resolve dec_chain_downward_directed : order.

Lemma continuous_wcontinuous {A B} `{OType A} `{OType B} (f : A -> B) :
  continuous f ->
  wcontinuous f.
Proof.
  intros Hf ch Hch s Hs; apply Hf; auto; apply chain_directed; auto.
Qed.
#[global] Hint Resolve continuous_wcontinuous : order.

Lemma dec_continuous_dec_wcontinuous {A B} `{OType A} `{OType B} (f : A -> B) :
  dec_continuous f ->
  dec_wcontinuous f.
Proof.
  intros Hf ch Hch s Hs; apply Hf; auto; apply dec_chain_downward_directed; auto.
Qed.
#[global] Hint Resolve continuous_wcontinuous : order.

Lemma upper_bound_const {A B} `{OType A} (a : A) :
  upper_bound a (@const A B a).
Proof. intro b; reflexivity. Qed.

Lemma lower_bound_const {A B} `{OType A} (a : A) :
  lower_bound a (@const A B a).
Proof. intro b; reflexivity. Qed.

Lemma supremum_const {A B} `{OType A} `{Inhabited B} (a : A) :
  supremum a (fun _ : B => a).
Proof.
  split.
  - apply upper_bound_const.
  - unfold upper_bound.
    unfold const. intros x H1.
    destruct H0; apply H1; auto.
Qed.
#[global] Hint Resolve supremum_const : order.

Lemma supremum_const' {A B} `{OType A} `{Inhabited B} (a : A) (f : nat -> A) :
  f === const a ->
  supremum a f.
Proof. intros ->; apply supremum_const. Qed.

Lemma infimum_const {A B} `{OType A} `{Inhabited B} (a : A) :
  infimum a (fun _ : B => a).
Proof.
  split.
  - apply lower_bound_const.
  - unfold const; intros x H1.
    destruct H0; apply H1; auto.
Qed.
#[global] Hint Resolve infimum_const : order.

Lemma infimum_const' {A B} `{OType A} `{Inhabited B} (a : A) (f : nat -> A) :
  f === const a ->
  infimum a f.
Proof. intros ->; apply infimum_const. Qed.

Lemma leq_arrow {A B} `{OType B} (f g : A -> B) :
  f ⊑ g -> forall x, f x ⊑ g x.
Proof. auto. Qed.

Lemma equ_arrow {A B} `{OType B} (f g : A -> B) :
  f === g <-> forall x, f x === g x.
Proof.
  split.
  - intros [Hfg Hgf] x; split; auto.
  - intros Hfg; split; intro x; apply Hfg.
Qed.

Lemma directed_const {I A} `{OType A} (x : A) :
  directed (fun _ : I => x).
Proof. intros _ j; exists j; split; reflexivity. Qed.
#[global] Hint Resolve directed_const : order.

Lemma downward_directed_const {I A} `{OType A} (x : A) :
  downward_directed (fun _ : I => x).
Proof. intros _ j; exists j; split; reflexivity. Qed.
#[global] Hint Resolve downward_directed_const : order.

Lemma eq_equ {A} `{OType A} x y :
  x = y -> x === y.
Proof. intro; subst; reflexivity. Qed.

Lemma pointwise_le_supremum_le {A} `{OType A} (f g : nat -> A) (a b : A) :
  (forall i, f i ⊑ g i) ->
  supremum a f ->
  supremum b g ->
  a ⊑ b.
Proof.
  intros Hle [Ha Ha'] [Hb Hb'].
  eapply Ha'; intro i; etransitivity; eauto.
Qed.

Lemma pointwise_le_infimum_le {A} `{OType A} (f g : nat -> A) (a b : A) :
  (forall i, f i ⊑ g i) ->
  infimum a f ->
  infimum b g ->
  a ⊑ b.
Proof.
  intros Hle [Ha Ha'] [Hb Hb'].
  eapply Hb'; intro i; etransitivity; eauto.
Qed.

Lemma apply_supremum {I A B} `{OType B}
  (f : A -> B) (ch : I -> A -> B) (x : A) :
  supremum f ch -> supremum (f x) (fun i => ch i x).
Proof.
  intros [Hub Hlub]; split.
  - intro i; apply Hub.
  - intros y Hy.
    simpl in Hlub.
    unfold upper_bound in Hy.
    simpl in *.
    destruct (classicT (f x ⊑ y)); auto.
    set (f' := fun a => if classicT (a = x) then y else f a).
    assert (Hf': upper_bound f' ch).
    { intros i a; unfold f'; simpl.
      destruct_classic; subst; auto; apply Hub. }
    specialize (Hlub f' Hf' x); unfold f' in Hlub.
    destruct_classic; auto; congruence.
Qed.

Corollary wcontinuous_apply {A B} `{OType B} (x : A) :
  wcontinuous (fun f : A -> B => f x).
Proof. intros ch Hch s Hs; apply apply_supremum; auto. Qed.

Lemma supremum_apply {I A B} `{Inhabited I} `{OType B} (f : A -> B) (ch : I -> A -> B) :
  (forall x, supremum (f x) (fun i => ch i x)) -> supremum f ch.
Proof.
  intro Hsup; split.
  - intros i x; apply Hsup.
  - intros g Hg x; apply Hsup; intro i; apply Hg.
Qed.

Lemma infimum_apply {I A B} `{Inhabited I} `{OType B} (f : A -> B) (ch : I -> A -> B) :
  (forall x, infimum (f x) (fun i => ch i x)) -> infimum f ch.
Proof.
  intro Hsup; split.
  - intros i x; apply Hsup.
  - intros g Hg x; apply Hsup; intro i; apply Hg.
Qed.

Lemma apply_infimum {I A B} `{Inhabited I} `{OType B}
  (f : A -> B) (ch : I -> A -> B) (x : A) :
  infimum f ch -> infimum (f x) (fun i => ch i x).
Proof.
  intros [Hlb Hglb]; split.
  - intro i; apply Hlb.
  - intros y Hy.
    simpl in Hglb.
    unfold lower_bound in Hy.
    simpl in *.
    destruct (classicT (y ⊑ f x)); auto.
    set (f' := fun a => if classicT (a = x) then y else f a).
    assert (Hf': lower_bound f' ch).
    { intros i a; unfold f'; simpl.
      destruct_classic; subst; auto; apply Hlb. }
    specialize (Hglb f' Hf' x); unfold f' in Hglb.
    destruct_classic; auto; congruence.
Qed.

Lemma continuous_monotone {A B} `{OType A} `{OType B} (f : A -> B) :
  continuous f ->
  Proper (leq ==> leq) f.
Proof.
  unfold continuous, monotone, Proper, respectful.
  intros Hf x y Hxy.
  set (ch := fun i => match i with
                   | O => x
                   | _ => y
                   end).
  assert (Hch: directed ch).
  { intros i j; unfold ch; exists (max i j); split;
      destruct i, j; simpl; auto; reflexivity. }
  assert (supremum y ch).
  { split.
    - intro i; unfold ch; destruct i; auto; reflexivity.
    - intros z Hz; specialize (Hz (S O)); auto. }
  apply Hf in H1; auto.
  destruct H1 as [Hub Hlub]; apply (Hub O).
Qed.
#[global] Hint Resolve continuous_monotone : order.

Lemma cocontinuous_antimonotone {A B} `{OType A} `{OType B} (f : A -> B) :
  cocontinuous f ->
  Proper (leq ==> flip leq) f.
Proof.
  unfold cocontinuous, antimonotone, Proper, respectful.
  intros Hf x y Hxy.
  set (ch := fun i => match i with
                   | O => x
                   | _ => y
                   end).
  assert (Hch: directed ch).
  { intros i j; unfold ch; exists (max i j); split;
      destruct i, j; simpl; auto; reflexivity. }
  assert (supremum y ch).
  { split.
    - intro i; unfold ch; destruct i; auto; reflexivity.
    - intros z Hz; specialize (Hz (S O)); auto. }
  apply Hf in H1; auto.
  destruct H1 as [Hub Hlub]; apply (Hub O).
Qed.
#[global] Hint Resolve cocontinuous_antimonotone : order.

Lemma wcontinuous_monotone {A B} `{OType A} `{OType B} (f : A -> B) :
  wcontinuous f ->
  Proper (leq ==> leq) f.
Proof.
  unfold wcontinuous, monotone, Proper, respectful.
  intros Hf x y Hxy.
  set (ch := fun i => match i with
                      | O => x
                      | _ => y
                      end).
  assert (Hch: chain ch).
  { intros []; auto; reflexivity. }
  assert (supremum y ch).
  { split.
    - intro i; unfold ch; destruct i; auto; reflexivity.
    - intros z Hz; specialize (Hz (S O)); auto. }
  apply Hf in H1; auto.
  destruct H1 as [Hub Hlub]; apply (Hub O).
Qed.
#[global] Hint Resolve wcontinuous_monotone : order.

Lemma dec_continuous_monotone {A B} `{OType A} `{OType B} (f : A -> B) :
  dec_continuous f ->
  Proper (leq ==> leq) f.
Proof.
  unfold dec_continuous, monotone, Proper, respectful.
  intros Hf x y Hxy.
  set (ch := fun i => match i with
                   | O => y
                   | _ => x
                   end).
  assert (Hch: downward_directed ch).
  { intros i j; unfold ch; exists (max i j); split;
      destruct i, j; simpl; auto; reflexivity. }
  assert (infimum x ch).
  { split.
    - intro i; unfold ch; destruct i; auto; reflexivity.
    - intros z Hz; specialize (Hz (S O)); auto. }
  apply Hf in H1; auto.
  destruct H1 as [Hlb Hglb]; apply (Hlb O).
Qed.
#[global] Hint Resolve dec_continuous_monotone : order.

Lemma dec_wcontinuous_monotone {A B} `{OType A} `{OType B} (f : A -> B) :
  dec_wcontinuous f ->
  Proper (leq ==> leq) f.
Proof.
  unfold dec_continuous, monotone, Proper, respectful.
  intros Hf x y Hxy.
  set (ch := fun i => match i with
                   | O => y
                   | _ => x
                   end).
  assert (Hch: dec_chain ch).
  { intros []; auto; reflexivity. }
  assert (infimum x ch).
  { split.
    - intro i; unfold ch; destruct i; auto; reflexivity.
    - intros z Hz; specialize (Hz (S O)); auto. }
  apply Hf in H1; auto.
  destruct H1 as [Hlb Hglb]; apply (Hlb O).
Qed.
#[global] Hint Resolve dec_wcontinuous_monotone : order.

Lemma continuous_compose {A B C} `{OType A} `{OType B} `{OType C}
  (f : A -> B) (g : B -> C) :
  continuous f ->
  continuous g ->
  continuous (g ∘ f).
Proof.
  unfold continuous.
  intros Hf Hg ch Hch x Hx; unfold compose in *.
  apply Hg.
  - apply monotone_directed; auto.
    apply continuous_monotone; auto.
  - apply Hf; auto.
Qed.
#[global] Hint Resolve continuous_compose : order.

Lemma supremum_eventually_constant_at {A} `{OType A} (f : nat -> A) (x : A) :
  chain f ->
  eventually_constant_at f x ->
  supremum x f.
Proof.
  intros Hch [n0 Hn0]; split.
  - intro i.
    destruct (Nat.leb_spec n0 i).
    + specialize (Hn0 i H0); apply Hn0.
    + specialize (Hn0 n0 (le_n n0)).
      rewrite <- Hn0.
      apply chain_leq; auto; lia.
  - intros ub Hub.
    specialize (Hub n0).
    specialize (Hn0 n0 (le_n n0)); rewrite <- Hn0; auto.
Qed.

Lemma infimum_eventually_constant_at {A} `{OType A} (f : nat -> A) (x : A) :
  dec_chain f ->
  eventually_constant_at f x ->
  infimum x f.
Proof.
  intros Hch [n0 Hn0]; split.
  - intro i.
    destruct (Nat.leb_spec n0 i).
    + specialize (Hn0 i H0); apply Hn0.
    + specialize (Hn0 n0 (le_n n0)).
      rewrite <- Hn0.
      apply dec_chain_leq; auto; lia.
  - intros ub Hub.
    specialize (Hub n0).
    specialize (Hn0 n0 (le_n n0)); rewrite <- Hn0; auto.
Qed.

Lemma supremum_shift {A} `{OType A} (f : nat -> A) (a : A) :
  chain f ->
  supremum a f ->
  supremum a (shift f).
Proof.
  intros Hf [Hub Hlub]; split.
  - intro i; apply Hub.
  - intros x Hx; apply Hlub; intro i; etransitivity; eauto.
Qed.

Lemma Proper_compose_l {A B C} `{OType A} `{OType B} `{OType C}
  (f f' : A -> B) (g g' : B -> C) :
  Proper (equ ==> equ) g ->
  f === f' ->
  g === g' ->
  g ∘ f === g' ∘ f'.
Proof.
  intros Hg Hf' Hg'.
  unfold compose; apply equ_arrow; intro x.
  rewrite equ_arrow in Hf'.
  rewrite Hf'.
  rewrite equ_arrow in Hg'.
  apply Hg'.
Qed.

Lemma infimum_shift {A} `{OType A} (a : A) (f : nat -> A) :
  dec_chain f ->
  infimum a f ->
  infimum a (shift f).
Proof.
  unfold shift; intros Hch [Hlb Hglb]; split.
  - intro i; apply Hlb.
  - intros x Hx; apply Hglb; intro i; etransitivity; eauto.
Qed.

Lemma shift_supremum {A} `{OType A} (a : A) (f : nat -> A) :
  f 0 ⊑ a ->
  supremum a (shift f) ->
  supremum a f.
Proof.
  unfold shift; intros Hf0 [Hub Hlub]; split.
  - intros []; auto.
  - intros x Hx; apply Hlub; intro i; apply Hx.
Qed.

Lemma shift_supremum' {A} `{OType A} (a : A) (f g : nat -> A) :
  (exists i, g 0 ⊑ g (S i)) ->
  supremum a f ->
  shift g === f ->
  supremum a g.
Proof.
  intros Hg01 Ha Hgf.
  rewrite <- Hgf in Ha.
  apply shift_supremum; auto.
  destruct Hg01 as [i Hi].
  etransitivity; eauto.
  apply Ha.
Qed.

Corollary shift_supremum'' {A} `{OType A} (a : A) (f g : nat -> A) :
  g 0 ⊑ g 1 ->
  supremum a f ->
  shift g === f ->
  supremum a g.
Proof. intros Hg01 Ha Hgf; eapply shift_supremum'; eauto. Qed.

Lemma shift_infimum {A} `{OType A} (a : A) (f : nat -> A) :
  a ⊑ f 0 ->
  infimum a (shift f) ->
  infimum a f.
Proof.
  unfold shift; intros Hf0 [Hub Hlub]; split.
  - intros []; auto.
  - intros x Hx; apply Hlub; intro i; apply Hx.
Qed.

Lemma shift_infimum' {A} `{OType A} (a : A) (f g : nat -> A) :
  (exists i, g (S i) ⊑ g O) ->
  infimum a f ->
  shift g === f ->
  infimum a g.
Proof.
  intros Hg01 Ha Hgf.
  rewrite <- Hgf in Ha.
  apply shift_infimum; auto.
  destruct Hg01 as [i Hi].
  etransitivity; eauto.
  apply Ha.
Qed.

Corollary shift_infimum'' {A} `{OType A} (a : A) (f g : nat -> A) :
  g 1 ⊑ g 0 ->
  infimum a f ->
  shift g === f ->
  infimum a g.
Proof. intros Hg01 Ha Hgf; eapply shift_infimum'; eauto. Qed.

#[global]
  Instance monotone_id {A} `{OType A} : Proper (leq ==> leq) id.
Proof. intros ? ? Hle; apply Hle. Qed.
#[global] Hint Resolve monotone_id : order.

Lemma continuous_id {A} `{OType A} : continuous id.
Proof. intros ch Hch s Hs; apply Hs. Qed.
#[global] Hint Resolve continuous_id : order.

Lemma dec_continuous_id {A} `{OType A} : dec_continuous id.
Proof. intros ch Hch s Hs; apply Hs. Qed.
#[global] Hint Resolve dec_continuous_id : order.

Fixpoint iter_n {A} (F : A -> A) (z : A) (n : nat) : A :=
  match n with
  | O => z
  | S n' => F (iter_n F z n')
  end.

Lemma chain_iter_n' {A} `{OType A} (f : A -> A) (z : A) :
  z ⊑ f z ->
  monotone f ->
  chain (iter_n f z).
Proof. intros Hz Hf i; induction i; simpl; auto. Qed.

Lemma dec_chain_iter_n' {A} `{OType A} (f : A -> A) (z : A) :
  f z ⊑ z ->
  monotone f ->
  dec_chain (iter_n f z).
Proof. intros Hz Hf i; induction i; simpl; auto. Qed.

Lemma monotone_iter_n {A} `{OType A} (f g : A -> A) (x y : A) (i : nat) :
  (forall x y, x ⊑ y -> f x ⊑ g y) ->
  x ⊑ y ->
  iter_n f x i ⊑ iter_n g y i.
Proof. revert f g x y; induction i; intros f g x y; simpl; auto. Qed.

Lemma leq_impl (P Q : Prop) :
  P ⊑ Q ->
  P -> Q.
Proof. intro H; apply H. Qed.

Lemma equ_iff (P Q : Prop) :
  P === Q ->
  P <-> Q.
Proof. firstorder. Qed.

Lemma iter_n_eq {A} `{OType A} (F G : A -> A) (a b : A) (i : nat) :
  (forall x y, x === y -> F x === G y) ->
  a === b ->
  iter_n F a i === iter_n G b i.
Proof. revert F G a b; induction i; intros F G a b HFG Hab; simpl; auto. Qed.

Lemma chain_id : chain (fun i : nat => i).
Proof. intro i; simpl; lia. Qed.
#[global] Hint Resolve chain_id : order.

Lemma supremum_cond {A} `{OType A} (b : bool) (x y : A) (f g : nat -> A) :
  supremum x f ->
  supremum y g ->
  supremum (if b then x else y) (fun i => if b then f i else g i).
Proof. intros Hf Hg; destruct b; auto. Qed.

Lemma infimum_cond {A} `{OType A} (b : bool) (x y : A) (f g : nat -> A) :
  infimum x f ->
  infimum y g ->
  infimum (if b then x else y) (fun i => if b then f i else g i).
Proof. intros Hf Hg; destruct b; auto. Qed.

Lemma iter_n_const {A} `{OType A} (F : A -> A) (z : A) (n : nat) :
  Proper (leq ==> leq) F ->
  F z === z ->
  iter_n F z n === z.
Proof.
  intros Hmono HFz.
  induction n; simpl; try reflexivity.
  rewrite IHn; auto.
Qed.

(* Pointwise variant for function spaces. *)
Corollary iter_n_const' {A B} `{OType B}
  (F : (A -> B) -> A -> B) (z : A -> B) (n : nat) (x : A) :
  Proper (leq ==> leq) F ->
  F z === z ->
  iter_n F z n x === z x.
Proof. intros Hmono HFz; apply equ_arrow; apply iter_n_const; auto. Qed.

Lemma iter_n_bounded {A} `{OType A} (F : A -> A) (z ub : A) (n : nat) :
  z ⊑ ub ->
  (forall x, x ⊑ ub -> F x ⊑ ub) ->
  iter_n F z n ⊑ ub.
Proof. revert z ub; induction n; intros z ub Hz HF; simpl; auto. Qed.

(** Types for which the symmetric closure of the order relation
    coincides with propositional equality. Obviously, depends on the
    choice of order relation. *)
Class ExtType (A : Type) `{OType A} : Type :=
  { ext : forall (a b : A), a === b -> a = b }.

#[global]
  Instance ExtType_Proper {A B} `{ExtType A} `{OType B} (f : A -> B)
  : Proper (equ ==> equ) f.
Proof. intros x y Hxy; eapply ext in Hxy; subst; reflexivity. Qed.

#[global]
  Instance ExtType_bool : ExtType bool.
Proof. constructor. intros [] [] []; auto; destruct H. Qed.

#[global]
  Instance ExtType_arrow {A B} `{ExtType B} : ExtType (A -> B).
Proof.
  constructor; intros f g Hfg.
  ext x; rewrite equ_arrow in Hfg; specialize (Hfg x); apply ext; auto.
Qed.

(* #[global] *)
(*   Instance ExtType_Prop : ExtType Prop. *)
(* Proof. constructor; apply propositional_extensionality. Qed. *)

#[global]
  Instance ExtType_nat : ExtType nat.
Proof.
  constructor; intros a b Hab.
  unfold equiv, equ in Hab; simpl in Hab; lia.
Qed.

Lemma continuous_cocontinuous_compose {A B C} `{OType A} `{OType B} `{OType C}
  (f : A -> B) (g : B -> C) :
  continuous f ->
  cocontinuous g ->
  cocontinuous (g ∘ f).
Proof.
  unfold continuous, cocontinuous.
  intros Hf Hg ch Hch x Hx; unfold compose in *.
  apply Hg.
  - apply monotone_directed; auto.
    apply continuous_monotone; auto.
  - apply Hf; auto.
Qed.

Lemma supremum_Prop (P : Prop) (f : nat -> Prop) :
  (P <-> exists i, f i) ->
  supremum P f.
Proof.
  intros [H0 H1]; split.
  - intros i Hfi; apply H1; exists i; auto.
  - intros Q HQ HP.
    apply H0 in HP.
    destruct HP as [i Hfi].
    eapply HQ; eauto.
Qed.

Lemma supremum_Prop' (P : Prop) (f : nat -> Prop) :
  supremum P f ->
  (P <-> exists i, f i).
Proof.
  intros [Hub Hlub]; split.
  - intro pf.
    contra H.
    assert (Hf: forall i, ~ f i).
    { intros i HC; apply H; exists i; auto. }
    clear H.
    eapply Hlub; auto.
  - intros [i Hi].
    eapply Hub; eauto.
Qed.

Lemma infimum_Prop (P : Prop) (f : nat -> Prop) :
  (P <-> forall i, f i) ->
  infimum P f.
Proof.
  intros [H0 H1]; split.
  - intros i Hfi; apply H0; auto.
  - intros Q HQ HP; apply H1; intro i; apply HQ; auto.
Qed.

(* Lemma equ_list {A} (l1 l2 : list A) : *)
(*   l1 === l2 -> l1 = l2. *)
(* Proof. intros []; apply is_prefix_antisym; auto. Qed. *)

Lemma continuous_ite {A B} `{OType A} `{OType B} (b : bool) (f g : A -> B) :
  continuous f ->
  continuous g ->
  continuous (fun x => if b then f x else g x).
Proof.
  intros Hf Hg ch Hch a Hsup; unfold compose; destruct b.
  - apply Hf; auto.
  - apply Hg; auto.
Qed.
#[global] Hint Resolve continuous_ite : order.

Lemma leq_refl {A} `{OType A} (x : A) :
  x ⊑ x.
Proof. reflexivity. Qed.
#[global] Hint Resolve leq_refl : order.

Lemma continuous_disj (P : Prop) :
  continuous (fun x : Prop => P \/ x).
Proof.
  intros ch Hch Q Hsup; unfold compose.
  split.
  - intros i [H|H]; auto.
    destruct Hsup as [Hub Hlub].
    right; apply (Hub i); auto.
  - intros R HR [HP|HQ].
    + apply (HR O); auto.
    + destruct Hsup as [Hub Hlub]; eapply Hlub; auto.
      intros i y; eapply HR; right; eauto.
Qed.

Lemma dec_continuous_conj (P : Prop) :
  dec_continuous (fun x : Prop => P /\ x).
Proof.
  intros ch Hch Q Hinf; unfold compose.
  split.
  - intros i [H0 H1]; split; auto; apply Hinf; auto.
  - intros R HR x; split.
    + apply (HR O); auto.
    + destruct Hinf as [Hlb Hglb].
      eapply Hglb.
      2: { apply x. }
      intros i y; apply HR; auto.
Qed.

Lemma continuous_exists {I} :
  continuous (fun f : I -> Prop => exists i : I, f i).
Proof.
  intros ch Hch f [Hub Hlub]; unfold compose; split.
  - intros i [j Hj]; exists j; eapply Hub; eauto.
  - intros x Hx [j Hj]; eapply Hlub; eauto.
    intros k l Hkl; eapply Hx; exists l; eauto.
Qed.

Lemma dec_continuous_forall {I} :
  dec_continuous (fun f : I -> Prop => forall i : I, f i).
Proof.
  intros ch Hch f [Hlb Hglb]; unfold compose; split.
  - intros n H i; apply Hlb; auto.
  - intros P HP H i.
    unfold lower_bound in HP; simpl in HP; unfold impl in HP.
    eapply Hglb.
    + intros m j Hj.
      apply HP; auto.
    + apply (HP O); auto.
Qed.

Lemma continuous_const {A B} `{OType A} `{OType B} (b : B) :
  continuous (fun _ : A => b).
Proof. intros ? ? ? ?; apply supremum_const. Qed.
#[global] Hint Resolve continuous_const : order.

Lemma cocontinuous_const {A B} `{OType A} `{OType B} (b : B) :
  cocontinuous (fun _ : A => b).
Proof. intros ? ? ? ?; apply infimum_const. Qed.

#[global]
  Instance monotone_fst {A B} `{OType A} `{OType B}
  : Proper (leq ==> leq) (@fst A B).
Proof. intros [] [] []; auto. Qed.
#[global] Hint Resolve monotone_fst : order.

#[global]
  Instance monotone_snd {A B} `{OType A} `{OType B}
  : Proper (leq ==> leq) (@snd A B).
Proof. intros [] [] []; auto. Qed.
#[global] Hint Resolve monotone_snd : order.

Lemma supremum_fst {A B} `{OType A} `{OType B} (a : A) (b : B) (f : nat -> A * B) :
  supremum (a, b) f ->
  supremum a (fst ∘ f).
Proof.
  intros [Hub Hlub]; split.
  - intro i; specialize (Hub i); inv Hub; auto.
  - unfold compose; intros x Hx.
    specialize (Hlub (x, b)).
    apply Hlub.
    intro i; specialize (Hx i); simpl in Hx.
    specialize (Hub i).
    inv Hub.
    destruct (f i); constructor; auto.
Qed.

Lemma infimum_fst {A B} `{OType A} `{OType B} (a : A) (b : B) (f : nat -> A * B) :
  infimum (a, b) f ->
  infimum a (fst ∘ f).
Proof.
  intros [Hub Hlub]; split.
  - intro i; specialize (Hub i); inv Hub; auto.
  - unfold compose; intros x Hx.
    specialize (Hlub (x, b)).
    apply Hlub.
    intro i; specialize (Hx i); simpl in Hx.
    specialize (Hub i).
    inv Hub.
    destruct (f i); constructor; auto.
Qed.

Lemma supremum_snd {A B} `{OType A} `{OType B} (a : A) (b : B) (f : nat -> A * B) :
  supremum (a, b) f ->
  supremum b (snd ∘ f).
Proof.
  intros [Hub Hlub]; split.
  - intro i; specialize (Hub i); inv Hub; auto.
  - unfold compose; intros x Hx.
    specialize (Hlub (a, x)).
    apply Hlub.
    intro i; specialize (Hx i); simpl in Hx.
    specialize (Hub i).
    inv Hub.
    destruct (f i); constructor; auto.
Qed.

Lemma infimum_snd {A B} `{OType A} `{OType B} (a : A) (b : B) (f : nat -> A * B) :
  infimum (a, b) f ->
  infimum b (snd ∘ f).
Proof.
  intros [Hub Hlub]; split.
  - intro i; specialize (Hub i); inv Hub; auto.
  - unfold compose; intros x Hx.
    specialize (Hlub (a, x)).
    apply Hlub.
    intro i; specialize (Hx i); simpl in Hx.
    specialize (Hub i).
    inv Hub.
    destruct (f i); constructor; auto.
Qed.

Lemma chain_fst {A B} `{OType A} `{OType B} (f : nat -> A * B) :
  chain f ->
  chain (fst ∘ f).
Proof. firstorder. Qed.

Lemma directed_fst {A B} `{OType A} `{OType B} (f : nat -> A * B) :
  directed f ->
  directed (fst ∘ f).
Proof.
  intros Hf i j; specialize (Hf i j); destruct Hf as [k [Hk Hk']].
  exists k; split; apply monotone_fst; auto.
Qed.

Lemma chain_snd {A B} `{OType A} `{OType B} (f : nat -> A * B) :
  chain f ->
  chain (snd ∘ f).
Proof. firstorder. Qed.

Lemma directed_snd {A B} `{OType A} `{OType B} (f : nat -> A * B) :
  directed f ->
  directed (snd ∘ f).
Proof.
  intros Hf i j; specialize (Hf i j); destruct Hf as [k [Hk Hk']].
  exists k; split; apply monotone_snd; auto.
Qed.

Lemma supremum_prod {A B} `{OType A} `{OType B} (a : A) (b : B) (f : nat -> A * B) :
  supremum a (fst ∘ f) ->
  supremum b (snd ∘ f) ->
  supremum (a, b) f.
Proof.
  intros [Ha Ha'] [Hb Hb']; split.
  - intro i; specialize (Ha i); specialize (Hb i).
    unfold compose in *; destruct (f i); split; auto.
  - intros [x y] Hxy; split; simpl.
    + apply Ha'; intro i; specialize (Hxy i); unfold compose;
        destruct (f i); destruct Hxy; auto.
    + apply Hb'; intro i; specialize (Hxy i); unfold compose;
        destruct (f i); destruct Hxy; auto.
Qed.

Lemma infimum_prod {A B} `{OType A} `{OType B} (a : A) (b : B) (f : nat -> A * B) :
  infimum a (fst ∘ f) ->
  infimum b (snd ∘ f) ->
  infimum (a, b) f.
Proof.
  intros [Ha Ha'] [Hb Hb']; split.
  - intro i; specialize (Ha i); specialize (Hb i).
    unfold compose in *; destruct (f i); split; auto.
  - intros [x y] Hxy; split; simpl.
    + apply Ha'; intro i; specialize (Hxy i); unfold compose;
        destruct (f i); destruct Hxy; auto.
    + apply Hb'; intro i; specialize (Hxy i); unfold compose;
        destruct (f i); destruct Hxy; auto.
Qed.

Lemma infimum_conj (f g : nat -> Prop) (P Q : Prop) :
  infimum P f ->
  infimum Q g ->
  infimum (P /\ Q) (fun i => f i /\ g i).
Proof.
  intros [HP HP'] [HQ HQ']; split.
  - intro i; intros [a b]; split.
    + apply HP; auto.
    + apply HQ; auto.
  - intros R HR z; split.
    + eapply HP'.
      2: { apply z. }
      intros i r; apply HR; auto.
    + eapply HQ'.
      2: { apply z. }
      intros i r; apply HR; auto.
Qed.

Lemma inl_supremum {A B} `{OType A} `{OType B} (a : A) (f : nat -> A + B) :
  supremum (inl a) f ->
  supremum a (fun i : nat => match f i with
                        | inl x => x
                        | inr _ => a
                        end).
Proof.
  intros [Hub Hlub]; split.
  - intro i; destruct (f i) eqn:Hfi.
    + specialize (Hub i); rewrite Hfi in Hub; apply Hub.
    + reflexivity.
  - intros x Hx.
    assert (Hxf: upper_bound (inl x) f).
    { intro i; specialize (Hx i); simpl in *.
      unfold sum_le.
      destruct (f i) eqn:Hfi; auto.
      assert (HC: inr b ⊑ inl a).
      { rewrite <- Hfi; apply Hub. }
      inv HC. }
    apply Hlub in Hxf; apply Hxf.
Qed.

Lemma inr_supremum {A B} `{OType A} `{OType B} (b : B) (f : nat -> A + B) :
  supremum (inr b) f ->
  supremum b (fun i : nat => match f i with
                        | inl _ => b
                        | inr y => y
                        end).
  intros [Hub Hlub]; split.
  - intro i; destruct (f i) eqn:Hfi.
    + reflexivity.
    + specialize (Hub i); rewrite Hfi in Hub; apply Hub.
  - intros x Hx.
    assert (Hxf: upper_bound (inr x) f).
    { intro i; specialize (Hx i); simpl in *.
      unfold sum_le.
      destruct (f i) eqn:Hfi; auto.
      assert (HC: inl a ⊑ inr b).
      { rewrite <- Hfi; apply Hub. }
      inv HC. }
    apply Hlub in Hxf; apply Hxf.
Qed.

Lemma supremum_inl {A B} `{OType A} `{OType B} (ch : nat -> A) (a : A) :
  supremum a ch ->
  supremum (inl a) (fun i : nat => inl (ch i)).
Proof.
  intros [Hub Hlub]; split.
  - intro i; apply Hub.
  - intros [a'|b] Ha'.
    + eapply Hlub; auto.
    + destruct (Ha' O).
Qed.

Lemma supremum_inr {A B} `{OType A} `{OType B} (ch : nat -> B) (b : B) :
  supremum b ch ->
  supremum (@inr A B b) (fun i : nat => inr (ch i)).
Proof.
  intros [Hub Hlub]; split.
  - intro i; apply Hub.
  - intros [a|b'] Hb'.
    + destruct (Hb' O).
    + eapply Hlub; auto.
Qed.

(* (** Hmm.. need the fancier OType on function spaces for this to work.. *) *)
(* Lemma monotone_2 {A B C} `{OType A} `{OType B} `{OType C} (f : A -> B -> C) (a : A) : *)
(*   Proper (leq ==> leq) f -> *)
(*   Proper (leq ==> leq) (f a). *)
(* Proof. *)
(*   intros Hf x y Hxy. *)
(*   specialize (Hf a a (leq_refl a)). *)
(*   simpl in Hf. *)

(*   intros Hf ch Hch b [Hub Hlub]. *)
(*   unfold compose. *)
(*   split. *)
(*   - intro i. *)
(*     apply  *)

(* Lemma continuous_2 {A B C} `{OType A} `{OType B} `{OType C} (f : A -> B -> C) (a : A) : *)
(*   continuous f -> *)
(*   continuous (f a). *)
(* Proof. *)
(*   intros Hf ch Hch b [Hub Hlub]. *)
(*   unfold compose. *)
(*   split. *)
(*   - intro i. *)
(*     apply  *)

(* Definition ofun (A B : Type) `{OType A} `{OType B} : Type := *)
(*   { f : A -> B | Proper (leq ==> leq) f }. *)

(* Program *)
(*   Instance OType_arrow' {A B} `{OType A} `{OType B} : OType (ofun A B) := *)
(*   {| leq := fun f g => forall x y, x ⊑ y -> f x ⊑ g y |}. *)
(* Next Obligation. *)
(*   constructor. *)
(*   - intros f x y Hxy; destruct f; auto. *)
(*   - intros [f] [g] [h] Hfg Hgh x y Hxy; simpl in *. *)
(*     etransitivity. *)
(*     apply Hfg; eauto. *)
(*     apply Hgh; reflexivity. *)
(* Qed. *)

(* Definition ocontinuous {A B : Type} `{OType A} `{OType B} (f : ofun A B) := *)
(*   forall g : nat -> A, *)
(*     directed g -> *)
(*     forall a : A, *)
(*       supremum a g -> *)
(*       supremum (proj1_sig f a) (proj1_sig f ∘ g). *)

(* Lemma continuous_2 {A B C} `{OType A} `{OType B} `{OType C} (f : ofun A (ofun B C)) (a : A) : *)
(*   ocontinuous f -> *)
(*   ocontinuous (proj1_sig f a). *)
(* Proof. *)
(*   intros Hf ch Hch b Hsup. *)
(*   specialize (Hf (const a) (directed_const a) a (supremum_const a)). *)
(*   destruct Hf as [Hub Hlub]. *)
(*   unfold compose, const in *. *)
(*   simpl in *. *)
(*   destruct Hsup as [Hub' Hlub']. *)
(*   destruct f as [f]; simpl in *. *)
(*   destruct (f a) as [g]; simpl in *. *)
(*   split. *)
(*   - intro i; apply p0; auto. *)
(*   - intros x Hx. *)
(*     clear Hub. *)
(*     specialize (Hlub (exist _ g p0)). *)
(*     simpl in Hlub. *)

(*   intros Hf ch Hch b [Hub Hlub]. *)
(*   destruct f as [f]. *)
(*   unfold compose. *)
(*   split. *)
(*   - intro i. *)
(*     simpl. *)
(*     destruct (f a) as [g]; simpl. *)
(*     apply p0. *)
(*     apply Hub. *)
(*   - intros x Hx; simpl in *. *)
(*     destruct (f a) as [g]; simpl.     *)
(*     simpl in *. *)
(*     specialize (Hf (const a)). *)
(*     simpl in Hf. *)


(* infotheo: information theory and error-correcting codes in Coq             *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later            *)
From mathcomp Require Import all_ssreflect ssralg fingroup finalg matrix.
Require Import Reals Lra.
From mathcomp Require Import Rstruct.
Require Import ssrR Reals_ext Ranalysis_ext logb ln_facts Rbigop fdist entropy.
Require Import channel_code channel divergence conditional_divergence.
Require Import variation_dist pinsker.

(******************************************************************************)
(*                         Error exponent bound                               *)
(*                                                                            *)
(* Lemmas:                                                                    *)
(*   out_entropy_dist_ub == Distance from the output entropy of one channel   *)
(*                          to another                                        *)
(* joint_entropy_dist_ub == Distance from the joint entropy of one channel    *)
(*                          to another                                        *)
(*      mut_info_dist_ub == Distance from the mutual information of one       *)
(*                          channel to another                                *)
(*  error_exponent_bound == intermediate step in the proof of the converse of *)
(*                          the channel coding theorem                        *)
(*                                                                            *)
(* For details, see Reynald Affeldt, Manabu Hagiwara, and Jonas Sénizergues.  *)
(* Formalization of Shannon's theorems. Journal of Automated Reasoning,       *)
(* 53(1):63--103, 2014                                                        *)
(******************************************************************************)

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

Local Open Scope divergence_scope.
Local Open Scope fdist_scope.
Local Open Scope entropy_scope.
Local Open Scope channel_scope.
Local Open Scope reals_ext_scope.
Local Open Scope R_scope.

Section mutinfo_distance_bound.

Variables (A B : finType) (V W : `Ch(A, B)) (P : fdist A).
Hypothesis V_dom_by_W : P |- V << W.
Hypothesis cdiv_ub : D(V || W | P) <= (exp(-2)) ^ 2 * / 2.

Let cdiv_bounds : 0 <= sqrt (2 * D(V || W | P)) <= exp (-2).
Proof.
split; first exact: sqrt_pos.
apply pow2_Rle_inv; [ exact: sqrt_pos | exact/ltRW/exp_pos | ].
rewrite [in X in X <= _]/= mulR1 sqrt_sqrt; last first.
  apply mulR_ge0; [lra | exact: cdiv_ge0].
apply/leRP; rewrite -(leR_pmul2r' (/ 2)); last exact/ltRP/invR_gt0.
by rewrite -mulRA mulRCA mulRV ?mulR1; [exact/leRP | exact/gtR_eqF].
Qed.

Local Open Scope variation_distance_scope.

Lemma out_entropy_dist_ub : `| `H(P `o V) - `H(P `o W) | <=
  / ln 2 * #|B|%:R * - xlnx (sqrt (2 * D(V || W | P))).
Proof.
rewrite 2!xlnx_entropy.
rewrite -addR_opp -mulRN -mulRDr normRM gtR0_norm; last exact/invR_gt0/ln2_gt0.
rewrite -mulRA; apply leR_pmul2l; first exact/invR_gt0/ln2_gt0.
rewrite oppRK big_morph_oppR -big_split /=.
apply: leR_trans; first exact: leR_sumR_Rabs.
rewrite -iter_addR -big_const; apply leR_sumR => b _; rewrite addRC.
apply: Rabs_xlnx => //.
rewrite 2!fdist_outE -addR_opp big_morph_oppR -big_split /=.
apply: leR_trans; first exact: leR_sumR_Rabs.
apply: (@leR_trans (d((P `X V), (P `X W)))).
- rewrite /var_dist /=.
  apply (@leR_trans (\sum_a \sum_b `| ((P `X V)) (a, b) - ((P `X W)) (a, b) | )); last first.
    by apply Req_le; rewrite pair_bigA /=; apply eq_bigr => -[].
  apply: leR_sumR => a _.
  rewrite (bigD1 b) //= distRC -[X in X <= _]addR0.
  rewrite 2!fdist_prodE /= !(mulRC (P a)) addR_opp.
  by apply/leR_add2l/sumR_ge0 => ? _; exact/normR_ge0.
- rewrite cdiv_is_div_joint_dist => //.
  exact/Pinsker_inequality_weak/joint_dominates.
Qed.

Lemma joint_entropy_dist_ub : `| `H(P , V) - `H(P , W) | <=
  / ln 2 * #|A|%:R * #|B|%:R * - xlnx (sqrt (2 * D(V || W | P))).
Proof.
rewrite 2!xlnx_entropy.
rewrite -addR_opp -mulRN -mulRDr normRM gtR0_norm; last exact/invR_gt0/ln2_gt0.
rewrite -2!mulRA; apply leR_pmul2l; first exact/invR_gt0/ln2_gt0.
rewrite oppRK big_morph_oppR -big_split /=.
apply: leR_trans; first exact: leR_sumR_Rabs.
rewrite -2!iter_addR -2!big_const pair_bigA /=.
apply: leR_sumR; case => a b _; rewrite addRC /=.
apply Rabs_xlnx => //.
apply (@leR_trans (d(P `X V, P `X W))).
- rewrite /var_dist /R_dist (bigD1 (a, b)) //= distRC.
  rewrite -[X in X <= _]addR0.
  by apply/leR_add2l/sumR_ge0 => ? _; exact/normR_ge0.
- rewrite cdiv_is_div_joint_dist => //.
  exact/Pinsker_inequality_weak/joint_dominates.
Qed.

Lemma mut_info_dist_ub : `| `I(P, V) - `I(P, W) | <=
  / ln 2 * (#|B|%:R + #|A|%:R * #|B|%:R) * - xlnx (sqrt (2 * D(V || W | P))).
Proof.
rewrite /mutual_info_chan.
rewrite (_ : _ - _ = `H(P `o V) - `H(P `o W) + (`H(P, W) - `H(P, V))); last by field.
apply: leR_trans; first exact: Rabs_triang.
rewrite -mulRA mulRDl mulRDr.
apply leR_add.
- by rewrite mulRA; apply out_entropy_dist_ub.
- by rewrite distRC 2!mulRA; apply joint_entropy_dist_ub.
Qed.

End mutinfo_distance_bound.

Section error_exponent_lower_bound.
Variables A B : finType.
Hypothesis Bnot0 : (0 < #|B|)%nat.
Variables (W : `Ch(A, B)) (minRate : R).
Hypothesis minRate_cap : minRate > capacity W.
Hypothesis set_of_I_has_ubound :
  classical_sets.has_ubound (fun y => exists P, `I(P, W) = y).

Lemma error_exponent_bound : exists Delta, 0 < Delta /\
  forall P : fdist A, forall V : `Ch(A, B),
    P |- V << W ->
    Delta <= D(V || W | P) +  +| minRate - `I(P, V) |.
Proof.
set gamma := / (#|B|%:R + #|A|%:R * #|B|%:R) * (ln 2 * ((minRate - capacity W) / 2)).
have : min(exp (-2), gamma) > 0.
  apply Rmin_Rgt_r; split; apply Rlt_gt; first exact: exp_pos.
  apply mulR_gt0.
  - by apply/invR_gt0/addR_gt0wl; [exact/ltR0n | apply/mulR_ge0; exact/leR0n].
  - by apply mulR_gt0 => //; apply mulR_gt0; [rewrite subR_gt0|exact:invR_gt0].
move/(continue_xlnx 0) => [] /= mu [mu_gt0 mu_cond].
set x := min(mu / 2, exp (-2)).
have x_gt0 : 0 < x.
  by apply: Rmin_pos; [apply: mulR_gt0 => //; exact: invR_gt0|exact: exp_pos].
have /mu_cond : D_x no_cond 0 x /\ R_dist x 0 < mu.
  split.
  - by split => //; exact/eqP/ltR_eqF.
  - rewrite /R_dist subR0 gtR0_norm // /x.
    apply (@leR_ltR_trans (mu * / 2)); first exact/geR_minl.
    by rewrite ltR_pdivr_mulr //; lra.
rewrite /R_dist {2}/xlnx ltRR' subR0 ltR0_norm; last first.
  apply xlnx_neg; split => //; rewrite /x.
  exact: leR_ltR_trans (geR_minr _ _) ltRinve21.
move=> Hx.
set Delta := min((minRate - capacity W) / 2, x ^ 2 / 2).
exists Delta; split.
  apply Rmin_case.
  - by apply mulR_gt0; [exact/subR_gt0 | exact/invR_gt0].
  - by apply mulR_gt0; [exact: expR_gt0 | exact: invR_gt0].
move=> P V v_dom_by_w.
case/boolP : (Delta <b= D(V || W | P)) => [/leRP| /leRP/ltRNge] Hcase.
  apply (@leR_trans (D(V || W | P))) => //.
  by rewrite -{1}(addR0 (D(V || W | P))); exact/leR_add2l/leR_maxl.
suff HminRate : (minRate - capacity W) / 2 <= minRate - (`I(P, V)).
  clear -Hcase v_dom_by_w HminRate.
  apply (@leR_trans +| minRate - `I(P, V) |); last first.
    by rewrite -[X in X <= _]add0R; exact/leR_add2r/cdiv_ge0.
  apply: leR_trans; last exact: leR_maxr.
  by apply: (leR_trans _ HminRate); exact: geR_minl.
have : `I(P, V) <= capacity W + / ln 2 * (#|B|%:R + #|A|%:R * #|B|%:R) *
                               (- xlnx (sqrt (2 * D(V || W | P)))).
  apply (@leR_trans (`I(P, W) + / ln 2 * (#|B|%:R + #|A|%:R * #|B|%:R) *
                               - xlnx (sqrt (2 * D(V || W | P))))); last first.
    apply/leR_add2r/Rstruct.RleP/Rstruct.Rsup_ub; last by exists P.
    split; first by exists (`I(P, W)), P.
    case: set_of_I_has_ubound => y Hy.
    by exists y => _ [Q _ <-]; apply Hy; exists Q.
  rewrite addRC -leR_subl_addr.
  apply (@leR_trans `| `I(P, V) + - `I(P, W) |); first exact: Rle_abs.
  suff : D(V || W | P) <= exp (-2) ^ 2 * / 2 by apply mut_info_dist_ub.
  clear -Hcase x_gt0.
  apply/ltRW/(ltR_leR_trans Hcase).
  apply (@leR_trans (x ^ 2 * / 2)); first exact: geR_minr.
  apply leR_wpmul2r; first exact/invR_ge0.
  by apply pow_incr; split; [exact: ltRW | exact: geR_minr].
rewrite -[X in _ <= X]oppRK => /leR_oppr/(@leR_add2l minRate).
move/(leR_trans _); apply.
suff x_gamma : - xlnx (sqrt (2 * (D(V || W | P)))) <= gamma.
  rewrite oppRD addRA addRC -leR_subl_addr.
  rewrite [X in X <= _](_ : _ = - ((minRate + - capacity W) / 2)); last by field.
  rewrite leR_oppr oppRK -mulRA mulRC.
  rewrite leR_pdivr_mulr // mulRC -leR_pdivl_mulr; last first.
    by apply addR_gt0wl; [exact/ltR0n|rewrite -natRM; exact/leR0n].
  by rewrite [in X in _ <= X]mulRC /Rdiv (mulRC _ (/ (_ + _))).
suff x_D : xlnx x <= xlnx (sqrt (2 * (D(V || W | P)))).
  clear -Hx x_D.
  rewrite leR_oppl; apply (@leR_trans (xlnx x)) => //.
  rewrite leR_oppl; apply/ltRW/(ltR_leR_trans Hx).
  by rewrite /gamma; exact: geR_minr.
apply/ltRW/Rgt_lt.
have ? : sqrt (2 * D(V || W | P)) < x.
  apply pow2_Rlt_inv; [exact: sqrt_pos | exact: ltRW | ].
  rewrite [in X in X < _]/= mulR1 sqrt_sqrt; last first.
    by apply mulR_ge0; [exact/ltRW | exact/cdiv_ge0].
  by rewrite mulRC -ltR_pdivl_mulr //; exact/(ltR_leR_trans Hcase)/geR_minr.
have ? : x <= exp (- 1).
  apply (@leR_trans (exp (-2))); first exact: geR_minr.
  by apply/ltRW/exp_increasing; lra.
apply xlnx_sdecreasing_0_Rinv_e => //.
- by split; [exact/sqrt_pos|exact: (@leR_trans x _ _ (ltRW _))].
- by split => //; exact: ltRW.
Qed.

End error_exponent_lower_bound.


Require Import Coq.Init.Peano.
Require Import HoTT.Basics HoTT.Truncations HoTT.HProp HoTT.Types HoTT.Spaces.Nat HoTT.DProp.

Section bounded_search.

  Context `{Funext}.
  Context (P : nat -> Type)
          {P_hprop : forall n, IsHProp (P n)}
          (P_dec : forall n, Decidable (P n))
          (P_inhab : hexists (fun n => P n)).
  (** We reopen these scopes so they take precedence over nat_scope; otherwise, now that we have [Coq.Init.Peano], we'd get [* : nat -> nat -> nat] rather than [* : Type -> Type -> Type]. *)
  Global Open Scope type_scope.
  Global Open Scope core_scope.

  (** But in this file, we want to be able to use the usual symbols for natural number arithmetic. *)
  Local Open Scope nat_scope.

  Local Definition minimal (n : nat) : Type := forall m : nat, P m -> n <= m.
  Local Definition ishprop_minimal (n : nat) : IsHProp (minimal n).
  Proof.
    apply _.
  Qed.
  Local Definition min_n_Type : Type := { n : nat & ((P n) * (minimal n))%type}.

  Local Definition ishpropmin_n : IsHProp min_n_Type.
  Proof.
    apply ishprop_sigma_disjoint.
    intros n n' [p m] [p' m'].
    apply leq_antisym.
    - exact (m n' p').
    - exact (m' n p).
  Qed.

  (* Local Definition min_n : hProp := hProppair min_n_UU isapropmin_n. *)

  Local Definition smaller (n : nat) := { l : nat & (P l * minimal l * (l <= n))%type}.

  Local Definition smaller_S (n : nat) (k : smaller n) : smaller (S n).
  Proof.
    induction k as [l [[p m] z]].
    exists l.
    repeat split; try assumption.
    refine (leq_trans _ _ _ _ _).
    - exact z.
    - apply leqnSn.
  Qed.

  Local Definition bounded_search (n : nat) : smaller n + forall l : nat, (l <= n) -> not (P l).
  Proof.
    induction n as [|n IHn].
    - assert (P 0 + not (P 0)) as X; [apply P_dec |].
      induction X as [h|].
      + left.
        refine (0;(h,_,_)).
        * intros ? ?. apply leq0n.
        * reflexivity.
      + right.
        intros l lleq0.
        assert (l0 : l = 0).
        {
          apply leq_antisym; try assumption.
          apply leq0n.
        }
        rewrite l0; assumption.
    - induction IHn as [|n0].
      + left. apply smaller_S. assumption.
      + assert (P (n.+1) + not (P (n.+1))) as X by apply P_dec.
        induction X as [h|].
        * left.
          refine (n.+1;(h,_,_)).
          -- intros m pm.
             assert ((n.+1 <= m)+(n.+1>m))%type as X by apply leqdichot.
             destruct X as [leqSnm|ltmSn].
             ++ assumption.
             ++ unfold lt in ltmSn.
                assert (m <= n) as X by assumption.
                destruct (n0 m X pm).
          -- apply leq_refl.
        * right. intros l q.
          assert ((l <= n) + (l > n)) as X by apply leqdichot.
          induction X as [h|h].
          -- exact (n0 l h).
          -- unfold lt in h.
             assert (eqlSn : l = n.+1).
             {
               apply leq_antisym; assumption.
             }
             rewrite eqlSn; assumption.
  Qed.

  Local Definition n_to_min_n (n : nat) (Pn : P n) : min_n_Type.
  Proof.
    assert (smaller n + forall l, (l <= n) -> not (P l)) as X by apply bounded_search.
    induction X as [[l [[Pl ml] leqln]]|none].
    - exact (l;(Pl,ml)).
    - destruct (none n (leq_refl n) Pn).
  Defined.

  Local Definition prop_n_to_min_n : min_n_Type.
  Proof.
    refine (Trunc_rec _ P_inhab).
    - exact ishpropmin_n.
    - induction 1 as [n Pn]. exact (n_to_min_n n Pn).
  Defined.

  Definition minimal_n : { n : nat & P n }.
  Proof.
    induction prop_n_to_min_n as [n pl]. induction pl as [p _].
    exact (n;p).
  Defined.

End bounded_search.


(* Check forward dependencies *)

Check
  (fun (P : nat -> Prop) Q (A : P 0 -> Q) (B : forall n : nat, P (S n) -> Q)
     x =>
   match x return Q with
   | exist O H => A H
   | exist (S n) H => B n H
   end).

(* Check dependencies in anonymous arguments (from FTA/listn.v) *)

Inductive listn (A : Set) : nat -> Set :=
  | niln : listn A 0
  | consn : forall (a : A) (n : nat), listn A n -> listn A (S n).

Section Folding.
Variable B C : Set.
Variable g : B -> C -> C.
Variable c : C.

Fixpoint foldrn (n : nat) (bs : listn B n) {struct bs} : C :=
  match bs with
  | niln => c
  | consn b _ tl => g b (foldrn _ tl)
  end.
End Folding.

(* -------------------------------------------------------------------- *)
(*   Example to test patterns matching on dependent families            *)
(* This exemple extracted from the developement done by Nacira Chabane  *)
(* (equipe Paris 6)                                                     *)
(* -------------------------------------------------------------------- *)

Require Import Prelude.
Require Import Logic_Type.

Section Orderings.
   Variable U : Type.

   Definition Relation := U -> U -> Prop.

   Variable R : Relation.

   Definition Reflexive : Prop := forall x : U, R x x.

   Definition Transitive : Prop := forall x y z : U, R x y -> R y z -> R x z.

   Definition Symmetric : Prop := forall x y : U, R x y -> R y x.

   Definition Antisymmetric : Prop := forall x y : U, R x y -> R y x -> x = y.

   Definition contains (R R' : Relation) : Prop :=
     forall x y : U, R' x y -> R x y.
  Definition same_relation (R R' : Relation) : Prop :=
    contains R R' /\ contains R' R.
Inductive Equivalence : Prop :=
    Build_Equivalence : Reflexive -> Transitive -> Symmetric -> Equivalence.

   Inductive PER : Prop :=
       Build_PER : Symmetric -> Transitive -> PER.

End Orderings.

(***** Setoid  *******)

Inductive Setoid : Type :=
    Build_Setoid :
      forall (S : Type) (R : Relation S), Equivalence _ R -> Setoid.

Definition elem (A : Setoid) := let (S, R, e) := A in S.

Definition equal (A : Setoid) :=
  let (S, R, e) as s return (Relation (elem s)) := A in R.

Axiom prf_equiv : forall A : Setoid, Equivalence (elem A) (equal A).
Axiom prf_refl : forall A : Setoid, Reflexive (elem A) (equal A).
Axiom prf_sym : forall A : Setoid, Symmetric (elem A) (equal A).
Axiom prf_trans : forall A : Setoid, Transitive (elem A) (equal A).

Section Maps.
Variable A B : Setoid.

Definition Map_law (f : elem A -> elem B) :=
  forall x y : elem A, equal _ x y -> equal _ (f x) (f y).

Inductive Map : Type :=
    Build_Map : forall (f : elem A -> elem B) (p : Map_law f), Map.

Definition explicit_ap (m : Map) :=
  match m return (elem A -> elem B) with
  | Build_Map f p => f
  end.

Axiom pres : forall m : Map, Map_law (explicit_ap m).

Definition ext (f g : Map) :=
  forall x : elem A, equal _ (explicit_ap f x) (explicit_ap g x).

Axiom Equiv_map_eq : Equivalence Map ext.

Definition Map_setoid := Build_Setoid Map ext Equiv_map_eq.

End Maps.

Notation ap := (explicit_ap _ _).

(* <Warning> : Grammar is replaced by Notation *)

Definition ap2 (A B C : Setoid) (f : elem (Map_setoid A (Map_setoid B C)))
  (a : elem A) := ap (ap f a).

(*****    posint     ******)

Inductive posint : Type :=
  | Z : posint
  | Suc : posint -> posint.

Axiom
  f_equal : forall (A B : Type) (f : A -> B) (x y : A), x = y -> f x = f y.
Axiom eq_Suc : forall n m : posint, n = m -> Suc n = Suc m.

(* The predecessor function *)

Definition pred (n : posint) : posint :=
  match n return posint with
  | Z => (* Z *)  Z
      (* Suc u *)
  | Suc u => u
  end.

Axiom pred_Sucn : forall m : posint, m = pred (Suc m).
Axiom eq_add_Suc : forall n m : posint, Suc n = Suc m -> n = m.
Axiom not_eq_Suc : forall n m : posint, n <> m -> Suc n <> Suc m.

Definition IsSuc (n : posint) : Prop :=
  match n return Prop with
  | Z => (* Z *)  False
      (* Suc p *)
  | Suc p => True
  end.
Definition IsZero (n : posint) : Prop :=
  match n with
  | Z => True
  | Suc _ => False
  end.

Axiom Z_Suc : forall n : posint, Z <> Suc n.
Axiom Suc_Z : forall n : posint, Suc n <> Z.
Axiom n_Sucn : forall n : posint, n <> Suc n.
Axiom Sucn_n : forall n : posint, Suc n <> n.
Axiom eqT_symt : forall a b : posint, a <> b -> b <> a.

(*******  Dsetoid *****)

Definition Decidable (A : Type) (R : Relation A) :=
  forall x y : A, R x y \/ ~ R x y.

Record DSetoid : Type :=
  {Set_of : Setoid; prf_decid : Decidable (elem Set_of) (equal Set_of)}.

(* example de Dsetoide d'entiers *)

Axiom eqT_equiv : Equivalence posint (eq (A:=posint)).
Axiom Eq_posint_deci : Decidable posint (eq (A:=posint)).

(* Dsetoide des posint*)

Definition Set_of_posint := Build_Setoid posint (eq (A:=posint)) eqT_equiv.

Definition Dposint := Build_DSetoid Set_of_posint Eq_posint_deci.

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

(* Definition des signatures *)
(* une signature est un ensemble d'operateurs muni
 de l'arite de chaque operateur *)

Section Sig.

Record Signature : Type :=
  {Sigma : DSetoid; Arity : Map (Set_of Sigma) (Set_of Dposint)}.

Variable S : Signature.

Variable Var : DSetoid.

Inductive TERM : Type :=
  | var : elem (Set_of Var) -> TERM
  | oper :
      forall op : elem (Set_of (Sigma S)), LTERM (ap (Arity S) op) -> TERM
with LTERM : posint -> Type :=
  | nil : LTERM Z
  | cons : TERM -> forall n : posint, LTERM n -> LTERM (Suc n).

(* -------------------------------------------------------------------- *)
(*                  Examples                                            *)
(* -------------------------------------------------------------------- *)

Parameter t1 t2 : TERM.

Type
  match t1, t2 with
  | var v1, var v2 => True
  | oper op1 l1, oper op2 l2 => False
  | _, _ => False
  end.

Parameter n2 : posint.
Parameter l1 l2 : LTERM n2.

Type
  match l1, l2 with
  | nil, nil => True
  | cons v m y, nil => False
  | _, _ => False
  end.

Type
  match l1, l2 with
  | nil, nil => True
  | cons u n x, cons v m y => False
  | _, _ => False
  end.

Definition equalT (t1 t2 : TERM) : Prop :=
  match t1, t2 with
  | var v1, var v2 => True
  | oper op1 l1, oper op2 l2 => False
  | _, _ => False
  end.

Definition EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint)
  (l2 : LTERM n2) : Prop :=
  match l1, l2 with
  | nil, nil => True
  | cons t1 n1' l1', cons t2 n2' l2' => False
  | _, _ => False
  end.

Reset equalT.
(* ------------------------------------------------------------------*)
(*          Initial exemple (without patterns)                       *)
(*-------------------------------------------------------------------*)

Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
  match t1 return (TERM -> Prop) with
  | var v1 =>
      (*var*)
      fun t2 : TERM =>
      match t2 return Prop with
      | var v2 =>
          (*var*) equal _ v1 v2
          (*oper*)
      | oper op2 _ => False
      end
      (*oper*)
  | oper op1 l1 =>
      fun t2 : TERM =>
      match t2 return Prop with
      | var v2 =>
          (*var*) False
          (*oper*)
      | oper op2 l2 =>
          equal _ op1 op2 /\
          EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2
      end
  end

 with EqListT (n1 : posint) (l1 : LTERM n1) {struct l1} :
 forall n2 : posint, LTERM n2 -> Prop :=
  match l1 in (LTERM _) return (forall n2 : posint, LTERM n2 -> Prop) with
  | nil =>
      (*nil*)
      fun (n2 : posint) (l2 : LTERM n2) =>
      match l2 in (LTERM _) return Prop with
      | nil =>
          (*nil*) True
          (*cons*)
      | cons t2 n2' l2' => False
      end
      (*cons*)
  | cons t1 n1' l1' =>
      fun (n2 : posint) (l2 : LTERM n2) =>
      match l2 in (LTERM _) return Prop with
      | nil =>
          (*nil*)  False
          (*cons*)
      | cons t2 n2' l2' => equalT t1 t2 /\ EqListT n1' l1' n2' l2'
      end
  end.

(* ---------------------------------------------------------------- *)
(*                Version with simple patterns                      *)
(* ---------------------------------------------------------------- *)
Reset equalT.

Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
  match t1 with
  | var v1 =>
      fun t2 : TERM =>
      match t2 with
      | var v2 => equal _ v1 v2
      | oper op2 _ => False
      end
  | oper op1 l1 =>
      fun t2 : TERM =>
      match t2 with
      | var _ => False
      | oper op2 l2 =>
          equal _ op1 op2 /\
          EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2
      end
  end

 with EqListT (n1 : posint) (l1 : LTERM n1) {struct l1} :
 forall n2 : posint, LTERM n2 -> Prop :=
  match l1 return (forall n2 : posint, LTERM n2 -> Prop) with
  | nil =>
      fun (n2 : posint) (l2 : LTERM n2) =>
      match l2 with
      | nil => True
      | _ => False
      end
  | cons t1 n1' l1' =>
      fun (n2 : posint) (l2 : LTERM n2) =>
      match l2 with
      | nil => False
      | cons t2 n2' l2' => equalT t1 t2 /\ EqListT n1' l1' n2' l2'
      end
  end.

Reset equalT.

Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
  match t1 with
  | var v1 =>
      fun t2 : TERM =>
      match t2 with
      | var v2 => equal _ v1 v2
      | oper op2 _ => False
      end
  | oper op1 l1 =>
      fun t2 : TERM =>
      match t2 with
      | var _ => False
      | oper op2 l2 =>
          equal _ op1 op2 /\
          EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2
      end
  end

 with EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint)
 (l2 : LTERM n2) {struct l1} : Prop :=
  match l1 with
  | nil => match l2 with
           | nil => True
           | _ => False
           end
  | cons t1 n1' l1' =>
      match l2 with
      | nil => False
      | cons t2 n2' l2' => equalT t1 t2 /\ EqListT n1' l1' n2' l2'
      end
  end.

(* ---------------------------------------------------------------- *)
(*                  Version with multiple patterns                  *)
(* ---------------------------------------------------------------- *)
Reset equalT.

Fixpoint equalT (t1 t2 : TERM) {struct t1} : Prop :=
  match t1, t2 with
  | var v1, var v2 => equal _ v1 v2
  | oper op1 l1, oper op2 l2 =>
      equal _ op1 op2 /\ EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2
  | _, _ => False
  end

 with EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint)
 (l2 : LTERM n2) {struct l1} : Prop :=
  match l1, l2 with
  | nil, nil => True
  | cons t1 n1' l1', cons t2 n2' l2' =>
      equalT t1 t2 /\ EqListT n1' l1' n2' l2'
  | _, _ => False
  end.

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

End Sig.

(* Exemple soumis par Bruno *)

Definition bProp (b : bool) : Prop := if b then True else False.

Definition f0 (F : False) (ty : bool) : bProp ty :=
  match ty as _, ty return (bProp ty) with
  | true, true => I
  | _, false => F
  | _, true => I
  end.

(* Simplification of bug/wish #1671 *)

Inductive I : unit -> Type :=
| C : forall a, I a -> I tt.

(*
Definition F (l:I tt) : l = l :=
match l return l = l with
| C tt (C _ l')  => refl_equal (C tt (C _ l'))
end.

one would expect that the compilation of F (this involves
some kind of pattern-unification) would produce:
*)

Definition F (l:I tt) : l = l :=
match l return l = l with
| C tt l' => match l' return C _ l' = C _ l' with C _ l''  => refl_equal (C tt (C _ l'')) end
end.

Inductive J : nat -> Type :=
| D : forall a, J (S a) -> J a.

(*
Definition G (l:J O) : l = l :=
match l return l = l with
| D O (D 1 l')  => refl_equal (D O (D 1 l'))
| D _ _  => refl_equal _
end.

one would expect that the compilation of G (this involves inversion)
would produce:
*)

Definition G (l:J O) : l = l :=
match l return l = l with
| D 0 l'' =>
    match l'' as _l'' in J n return
      match n return forall l:J n, Prop with
      | O => fun _ => l = l
      | S p => fun l'' => D p l'' = D p l''
      end _l'' with
    | D 1 l'  => refl_equal (D O (D 1 l'))
    | _ => refl_equal _
    end
| _ => refl_equal _
end.

Fixpoint app {A} {n m} (v : listn A n) (w : listn A m) : listn A (n + m) :=
  match v with
    | niln => w
    | consn a n' v' => consn _ a _ (app v' w)
  end.

(* Testing regression of bug 2106 *)

Set Implicit Arguments.
Require Import List.

Inductive nt := E.
Definition root := E.
Inductive ctor : list nt -> nt -> Type :=
 Plus : ctor (cons E (cons E nil)) E.

Inductive term : nt -> Type :=
| Term : forall s n, ctor s n -> spine s -> term n
with spine : list nt -> Type :=
| EmptySpine : spine nil
| ConsSpine : forall n s, term n -> spine s -> spine (n :: s).

Inductive step : nt -> nt -> Type :=
  | Step : forall l n r n' (c:ctor (l++n::r) n'), spine l -> spine r -> step n
n'.

Definition test (s:step E E) :=
  match s with
    | Step nil _ (cons E nil) _ Plus l l' => true
    | _ => false
  end.

(* Testing regression of bug 2454 ("get" used not be type-checkable when
   defined with its type constraint) *)

Inductive K : nat -> Type := KC : forall (p q:nat), K p.

Definition get : K O -> nat := fun x => match x with KC p q => q end.


(*begin hide*)
Require Import String. Open Scope string_scope.
Require Import Program.

From mathcomp Require Import ssreflect ssrnat ssrbool eqtype fintype.
Import ssreflect ssrnat ssrbool ssrfun eqtype fintype.

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

Add LoadPath "./" as Top.
Require Import Top.CaseTactic.
Require Import Top.Syntax.

Require Import Vector.
Require Import ZArith.

(*end hide*)

(*
  No es suficiente con utilizar el tipo bool de Coq, ya que necesitamos
  dar semántica al "para todo" y el "existe", por lo tanto utilizamos Prop y
  lo renombramos para seguir la notación de la materia.
*)
Notation bool := Prop.

(** *)
(*** Semántica del lenguaje ***)
(** *)

(** *Semántica de los operadores de orden *)
Definition SemOrdOp (op : OrdOp) : Z -> Z -> bool :=
  match op with
  | EqOP => Zeq_bool
  | LeOP => Z.leb
  end
.

(** *Semántica de los operadores booleanos *)
Definition SemBoolOp (op : BoolOp) : bool -> bool -> bool :=
  match op with
  | AndOP => fun a b => a /\ b
  | OrOP =>  fun a b => a \/ b
  end
.

(** *Semántica de los cuantificadores *)
Definition SemQuant (op : QOp) : (Z -> bool) -> bool :=
  match op with
  | ForallOP => fun f => forall (z : Z), f z
  | ExistOP => fun f => exists (z : Z), f z
  end
.

(** *Semántica de los operadores aritmeticos *)
Definition SemZOp (op : ZOp) : Z -> Z -> Z :=
  match op with
  | PlusOP  => Z.add
  | MinusOP => Z.sub
  end
.

Infix "⦃ op '⦄≤'" := (SemOrdOp op) (at level 1).
Infix "⦃ op '⦄∧'" := (SemBoolOp op) (at level 1).
Infix "⦃ op '⦄+'" := (SemZOp op) (at level 1).
Notation "⦃ op '⦄∀'" := (SemQuant op) (at level 1).

(** *Semántica de los entornos *)
(* Dado un entorno E, su semántica será un vector de enteros tamaño E *)
Definition SemEnv (E : Env) := Vector.t Z E.

(*
   Utilizando la notación de la materia la semántica de un entorno E
   será un subconjunto de Σ tal que los estados están definidos solo
   para las variables de 0 a E; lo denotamos entonces como Σ(E)
*)
Notation "'Σ(' E )" := (SemEnv E) (at level 1, no associativity).

(* Diferentes formas de escribir los estados *)
Notation "[ ]" := (nil _) (format "[ ]").
Notation "z :: σ" := (cons _ z _ σ) (at level 60, right associativity).
Notation "[ x , .. , y ]" := (cons _ x _ .. (cons _ y _ (nil _)) ..).

(** *Semántica de las variables *)
Definition SemVar (E : Env) (v : Var E) : Σ(E) -> Z.
  intros σ.
  apply (@nth_order _ _ σ (var_to_nat v)).
  apply var_to_nat_prop.
Defined.

(** *Notation *)
Notation "σ ! v" := (@SemVar _ v σ) (at level 1, no associativity).

(** *Propiedades de los estados *)
(* Utilizando variables con nombre y la notación de la materia este lema es
   equivalente a:
   [σ | x : z] x = z
*)
Lemma State_Prop_ZVAR : forall (E : Env) (v : Var E) (z : Z) (σ : Σ(E)),
    (z :: σ) ! (ZVAR E) = z.
Proof. auto. Qed.

(* Utilizando variables con nombre y la notación de la materia este lema es
   equivalente a:
   [σ | x : z] w = σ w
*)
Lemma State_Prop_SVAR : forall (E : Env) (z : Z) (σ : Σ(E)) (w : Var E),
    (z :: σ) ! (SVAR w) = σ ! w.
Proof.
  intros E z σ w.
  dependent destruction w; unfold "_ ! _", nth_order in *; simpl. by auto.
  erewrite -> Fin.of_nat_ext. reflexivity.
Qed.

(* Utilizando variables con nombre y la notación de la materia este lema es
   equivalente a:
   Dado algún conjunto de variables V,
   si para toda w ∈ V, σ w = σ' w
   entonces
   para toda w ∈ V, [σ | x : z] w = [σ' | x : z] w
*)
Lemma State_Prop_Extension : forall (E : Env) (z : Z) (σ σ' : Σ(E)),
    (forall w : Var E, σ ! w = σ' ! w) ->
    (forall w : Var (succn E), (z :: σ) ! w = (z :: σ') ! w).
Proof.
  intros E z σ σ' H w.
  dependent destruction w.
  + Case "w = ZVAR". by cbn.
  + Case "w = SVAR w".
    unfold "_ ! _", nth_order in *. simpl.
    erewrite -> Fin.of_nat_ext. by apply H.
Qed.

(** *Notation *)
Reserved Notation "⟦ ie '⟧ᵢ'" (at level 1, no associativity).
Reserved Notation "⟦ ae '⟧ₐ'" (at level 1, no associativity).

(** *Semántica de las expresiones enteras *)
Fixpoint SemI E (ie : IntExp E) : Σ(E) -> Z :=
  match ie with
  | VAR v           => fun σ => σ ! v
  | NAT n           => fun _ => Z.of_nat n
  | Neg ie          => fun σ => (- ⟦ ie ⟧ᵢ σ )%Z
  | BNOp zop ie ie' => fun σ => (⟦ ie ⟧ᵢ σ) ⦃zop⦄+ (⟦ ie' ⟧ᵢ σ)
  end
where "⟦ ie '⟧ᵢ'" := (SemI ie).

(** *Semántica de las expresiones booleanas *)
Fixpoint SemA E (ae : Assert E) : Σ(E) -> bool :=
  match ae with
  | BOOL b          => fun σ => b
  | Not ae          => fun σ => ~ (⟦ ae ⟧ₐ σ)
  | OOp oop ie ie'  => fun σ => (⟦ ie ⟧ᵢ σ) ⦃oop⦄≤ (⟦ ie' ⟧ᵢ σ)
  | BBOp bop ae ae' => fun σ => (⟦ ae ⟧ₐ σ) ⦃bop⦄∧ (⟦ ae' ⟧ₐ σ)
  | Quant qop ae    => fun σ => ⦃qop⦄∀ (fun z => ⟦ ae ⟧ₐ (z :: σ))
  end
where "⟦ ae '⟧ₐ'" := (SemA ae).

(** *Propiedades de la semántica denotacional *)
(*
   Si denotamos a la substitución que substituye cualquier índice i por su
   su sucesor (i+1) como (n ↦ n+1) entonces vale:

             ⟦ ie / (n ↦ n+1) ⟧ᵢ (z :: σ) = ⟦ ie ⟧ᵢ σ

   Notar que la expresión entera "ie / (n ↦ n+1)" que es el resultado de
   aplicarle la substitución a "ie" no tiene índice "0" como variable libre, por
   lo tanto su semántica en un estado extendido que asigna el valor z al índice
   0 es la misma que evaluarla en el estado sin extender.
*)
Lemma Lift_Prop : forall (E : Env) (ie : IntExp E) (z : Z) (σ : Σ(E)),
    ⟦ renI [eta SVAR (E:=E)] ie ⟧ᵢ (z :: σ)
    =
    ⟦ ie ⟧ᵢ σ.
Proof.
  dependent induction ie; intros z' σ.
  + Case "Var".
    simpl. by apply State_Prop_SVAR.
  + Case "Nat". by simpl.
  + Case "Neg". simpl. by rewrite -> IHie.
  + Case "BNOp".
    simpl. rewrite -> IHie1. by rewrite -> IHie2.
Qed.


(* Exercise 21 *)

Require Import BenB.

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

Theorem exercise_021 : ~((forall x : D, P x) /\ (exists x : D, ~ P x)).
Proof.
neg_i (1=1) a1.
exi_e (exists x:D, ~P x) a a2.
con_e2 (forall x:D, P x).
hyp a1.
neg_e (P a).
hyp a2.
all_e (forall x:D, P x) a.
con_e1 (exists x:D, ~P x).
hyp a1.
lin_solve.
Qed.


Require Import UniMath.Combinatorics.Lists.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.Algebra.Monoids_and_Groups.

Infix "::" := cons (at level 60, right associativity) : lists_scope.
Delimit Scope lists_scope with lists.
Bind Scope lists_scope with list.

Infix "++" := concatenate (right associativity, at level 60) : lists_scope.

Local Open Scope lists_scope.

Module ListsNotations.
Notation " [ ] " := nil (format "[ ]") : lists_scope.
Notation " [ x ] " := (cons x nil) : lists_scope.
Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) : lists_scope.
End ListsNotations.

Import ListsNotations.
Open Scope lists_scope.

Section ListFacts.
  Context (A : hSet).

  Fact list_preserve_hset : isaset (list A).
  Proof.
    unfold list.
    eapply (@isofhleveltotal2 2).
    - pose isasetnat.
      exact i.
    - intros.
      induction x.
      + apply (isasetunit).
      + apply isofhleveldirprod.
        * exact (setproperty A).
        * exact IHx.
  Qed.

  Definition setlist : hSet.
    use hSetpair.
    - exact (list A).
    - apply list_preserve_hset.
  Defined.

  Definition concatenate_nil_runit (l : list A) : concatenate l [ ] = l.
    use (list_ind (λ l, concatenate l nil = l)).
    - reflexivity.
    - intros.
      simpl.
      simpl in X.
      rewrite (concatenateStep).
      rewrite X.
      reflexivity.
  Defined.

  Definition concatenate_nil_lunit {X : UU} : forall (l : list X), concatenate nil l = l.
  Proof.
    reflexivity.
  Defined.

  Definition concatenate_assoc (l1 l2 l3 : list A) :
    concatenate (concatenate l1 l2) l3 = concatenate l1 (concatenate l2 l3).
  Proof.
    revert l1.
    use list_ind.
    - simpl.
      rewrite !concatenate_nil_lunit.
      reflexivity.
    - simpl ; intros x xs IH.
      rewrite !concatenateStep.
      rewrite IH.
      reflexivity.
  Defined.

  Definition reverse {X : UU} : list X -> list X.
  Proof.
    use list_ind.
    - apply nil.
    - intros x ? rev.
      exact (rev ++ (cons x nil)).
  Defined.

  Definition reverse_cons {X : UU} (x : X) (l : list X)
    : reverse (x :: l) = (reverse l) ++ [x].
  Proof.
    reflexivity.
  Defined.

  Definition list_ind_on (xs : list A) :
    ∏ (P : list A → UU), P nil → (∏ (x : A) (xs : list A), P xs → P (x :: xs)) → P xs.
    intros P X X0.
    exact (list_ind P X X0 xs).
  Defined.

  Lemma reverse_concatenate_distr : forall x y:list A, reverse (x ++ y) = reverse y ++ reverse x.
  Proof.
    intros x.
    apply (list_ind_on x).
    - simpl. intros y.
      apply (list_ind_on y).
      + apply idpath.
      + intros x0 xs X.
        now rewrite concatenate_nil_runit.
    - intros x0 xs IHl.
      simpl in *.
      intros y.
      clear x. rename x0 into a. rename xs into l.
      simpl.
      replace ((a :: l) ++ y) with (a :: (l ++ y)) by reflexivity.
      repeat rewrite reverse_cons.
      rewrite (IHl y).
      rewrite concatenate_assoc.
      apply idpath.
  Defined.

  Definition reverse_involutive (l : list A) : reverse (reverse l) = l.
  Proof.
    revert l.
    apply list_ind.
    - cbn. reflexivity.
    - intros x xs IH.
      replace (reverse (x :: xs)) with (reverse xs ++ [x]) by easy.
      rewrite (reverse_concatenate_distr (reverse xs) [x]).
      now rewrite IH.
  Defined.

End ListFacts.

Arguments reverse {_} _.
Arguments concatenate_assoc {_} _ _ _.


Set Warnings "-notation-overridden, -parsing".

From mathcomp Require Import ssreflect ssrbool eqtype.
Require Import Arith List String Lia.
From QuickChick Require Import QuickChick.
Import ListNotations.

(* Types *)

Inductive type : Type :=
| N : type
| Arrow : type -> type -> type.

Derive (Arbitrary, Show, EnumSized) for type.
#[local] Instance dec_type (t1 t2 : type) : Dec (t1 = t2).
Proof. dec_eq. Defined.

(* Terms *)

Definition var := nat.

Inductive term : Type :=
| Const : nat -> term
| Id : var -> term
| App : term -> term -> term
| Abs : type -> term -> term.

Derive Arbitrary for term.

(* Environments *)

Definition env := list type.

Inductive bind : env -> nat -> type -> Prop :=
| BindNow   : forall t G, bind (t :: G) 0 t
| BindLater : forall t t' x G,
    bind G x t -> bind (t' :: G) (S x) t.

(* Generate variables of a specific type in an env. *)
Derive ArbitrarySizedSuchThat for (fun x => bind G x t).
(* Get the type of a given variable in an env. *)
Derive EnumSizedSuchThat for (fun t => bind G x t).
(* Check whether a variable has a given type in an env. *)
Derive DecOpt for (bind G e t).

(* Typing *)

Inductive typing (G : env) : term -> type -> Prop :=
| TId :
    forall x t,
      bind G x t ->
      typing G (Id x) t
| TConst :
    forall n,
      typing G (Const n) N
| TAbs :
    forall e t1 t2,
      typing (t1 :: G) e t2 ->
      typing G (Abs t1 e) (Arrow t1 t2)
| TApp :
    forall e1 e2 t1 t2,
      typing G e2 t1 ->
      typing G e1 (Arrow t1 t2) ->
      typing G (App e1 e2) t2.

Fixpoint typeOf G e : option type :=
  match e with
  | Id x => nth_error G x
  | Const n => Some N
  | Abs t e' =>
    match typeOf (t::G) e' with
    | Some t' => Some (Arrow t t')
    | None => None
    end
  | App e1 e2 =>
    match typeOf G e1, typeOf G e2 with
    | Some (Arrow t1 t2), Some t1' =>
      if t1 = t1'? then Some t2 else None
    | _, _ => None
    end
  end.

Definition vars (Γ : env) (t : type) (g : G term) : G term :=
  let vs :=
    map (fun p => Id (snd p))
        (filter (fun p => t = fst p?)
                (combine Γ (seq 0 (List.length Γ))))
  in
  match vs with
  | [] => g
  | _ => oneOf_ (ret (Const 0)) [elems_ (Const 0) vs; g]
  end.

Fixpoint gen_base (Γ : env) (t : type) : G term :=
  match t with
  | N => vars Γ t (bindGen (choose (0,10)) (fun n => returnGen (Const n)))
  | Arrow t1 t2 =>
      bindGen (gen_base (t1::Γ) t2) (fun e =>
      returnGen (Abs t1 e))
  end.

Fixpoint gen_typed (sz : nat) (Γ : env) (t : type) : G term :=
  match sz with
  | O => gen_base Γ t
  | S sz' =>
      let app :=
        bindGen (@arbitrarySized type _ 3) (fun t' =>
        bindGen (gen_typed sz' Γ (Arrow t' t)) (fun e1 =>
        bindGen (gen_typed sz' Γ t') (fun e2 =>
        returnGen (App e1 e2)))) in
      match t with
      | N => vars Γ t (oneOf_ app [app; liftGen Const arbitrary])
      | Arrow t1 t2 => vars Γ t (oneOf_ app [app; liftGen (Abs t1) (gen_typed sz' Γ t2)])
      end
  end.

(* Generate terms of a specific type in an env. *)
Derive ArbitrarySizedSuchThat for (fun e => typing G e t).
Derive EnumSizedSuchThat for (fun t => typing G e t).

(* Check whether a variable has a given type in an env. *)
Derive DecOpt for (typing G e t).

(* Small step CBV semantics *)
Inductive value : term -> Prop :=
| VConst : forall n, value (Const n)
| VAbs   : forall t e, value (Abs t e).

Derive DecOpt for (value e).

Definition is_value (e : term) : bool :=
  match e with
  | Const _ | Abs _ _ => true
  | _ => false
  end.

Fixpoint subst (y : var) (e1 : term) (e2 : term) : term :=
  match e2 with
  | Const n => Const n
  | Id x =>
      (*! *)
      if eq_nat_dec x y then e1 else e2
      (*!! SUBST-swap *)
      (*! if eq_nat_dec x y then e2 else e1 *)
  | App e e' =>
      App (subst y e1 e) (subst y e1 e')
  | Abs t e =>
      (*! *)
      Abs t (subst (S y) e1 e)
      (*!! SUBST-no-lift *)
      (*! Abs t (subst y e1 e) *)
  end.

Fixpoint step (e : term) : option term :=
  match e with
    | Const _ | Id _ => None | Abs _ x => None
    | App (Abs t e1) e2 =>
      if is_value e2 then Some (subst 0 e2 e1)
      else
        match step e2 with
        | Some e2' => Some (App (Abs t e1) e2')
        | None => None
        end
    | App e1 e2 =>
      match step e1 with
      | Some e1' => Some (App e1' e2)
      | None => None
      end
  end.

(*
Eval compute in (step (App (Abs N (Id 0)) (Const 42))).
Eval compute in (step (App (Abs N (Abs N (Id 0))) (Const 42))).
Eval compute in (subst 0 (Const 42) (Abs N (Id 0))).
*)

(* Printing *)

Open Scope string.

Fixpoint show_type (tau : type) :=
  match tau with
    | N => "N"
    | Arrow tau1 tau2 =>
      "(Arrow " ++ show_type tau1 ++ " -> " ++ show_type tau2 ++ ")"
  end.

#[local] Instance showType : Show type := { show := show_type }.

Fixpoint show_term (e : term) :=
  match e with
    | Const n => "(Const " ++ show n ++ ")"
    | Id x => "(Id " ++ show x ++ ")"
    | App e1 e2 => "(App " ++ show_term e1 ++ " " ++ show_term e2 ++ ")"
    | Abs t e => "(Abs " ++ show t ++ " " ++ show_term e ++ ")"
  end.

Close Scope string.

#[local] Instance showTerm : Show term := { show := show_term }.

#[local] Instance dec_eq_opt_type : Dec_Eq (option type).
Proof. dec_eq. Defined.

Definition preservation (e : term) (t: type) : Checker :=
  match step e with
  | Some e' => checker ((typeOf nil e' = Some t)?)
  | None => checker true
  end.

Definition preservation_derived (e : term) (t: type) : Checker :=
  match step e with
  | Some e' => checker (typing nil e' t ?? 10)
  | None => checker true
  end.

Definition preservation_check (e : term) : Checker :=
  match typeOf nil e, step e with
  | Some t, Some e' => checker ((typeOf nil e' = Some t)?)
  | None, _ => checker tt
  | _, _ => checker true
  end.

Extract Constant defNumTests => "100000".

(*! Section base *)

Definition prop_preservation :=
  forAll (@arbitrary type _) (fun t =>
  forAll (gen_typed 5 nil t) (fun e =>
  preservation e t)).

(*! QuickChick prop_preservation. *)

(*! Section derived-dec *)

Definition prop_preservation_derived_checker :=
  forAll (@arbitrary type _) (fun t =>
  forAll (gen_typed 5 nil t) (fun e =>
  preservation_derived e t)).

(*! QuickChick prop_preservation_derived_checker. *)

(*! Section derived-gen *)

Definition prop_preservation_derived_gen :=
  forAll (@arbitrary type _) (fun t =>
  forAllMaybe (@arbitrarySizeST _ (fun e => typing nil e t) _ 5) (fun e =>
  preservation e t)).

(*! QuickChick prop_preservation_derived_gen. *)

(*! Section naive-gen *)

Definition prop_preservation_naive_gen :=
  forAll (@arbitrary term _) (fun e =>
  preservation_check e).

(*! QuickChick prop_preservation_naive_gen. *)