From Coq Require Import Arith ZArith Psatz Bool String List.
From CDF Require Import Sequences IMP.

(** * 6.  Semantics of divergence, second part *)

(** ** 6.5.  The partiality monad *)

(** The type [delay A] represents computations that produce a result
    of type [A] if they terminate, but can also diverge. *)

CoInductive delay (A: Type) : Type :=
  | now: A -> delay A
  | later: delay A -> delay A.

Arguments now [A].
Arguments later [A].

(** The computation of type [A] that always diverges. *)

CoFixpoint omega (A: Type) : delay A := later (omega A).

(** A few technical definitions to prove equalities between computations. *)

Lemma u_delay:
  forall {A: Type} (x: delay A),
  x = match x with now v => now v | later y => later y end.
Proof. destruct x; auto. Qed.

Ltac unroll_delay X := rewrite (u_delay X); simpl.

Ltac samedelay :=
  match goal with
  [ |- ?X = ?Y ] => rewrite (u_delay X); simpl; auto
  end.

(** Terminating on a value [v] is captured by an inductive predicate
    [terminates x v].
    Diverging is captured by a coinductive predicate [diverges x]. *)

Inductive terminates {A: Type} : delay A -> A -> Prop :=
  | terminates_now:   forall v, terminates (now v) v
  | terminates_later: forall x v, terminates x v -> terminates (later x) v.

CoInductive diverges {A: Type} : delay A -> Prop :=
  | diverges_later: forall x, diverges x -> diverges (later x).

Lemma terminates_unique: forall (A: Type) (x: delay A) (v1 v2: A),
  terminates x v1 -> terminates x v2 -> v1 = v2.
Proof.
  intros until v2; intros T; revert x v1 T v2. induction 1; intros.
- inversion H; subst; auto.
- inversion H; subst; auto.
Qed.

Lemma terminates_diverges_excl: forall (A: Type) (x: delay A) (v: A),
  terminates x v -> diverges x -> False.
Proof.
  induction 1; intros D; inversion D; auto.
Qed.

(** Example of use: computing the remainder of Euclidean division. *)

CoFixpoint remainder (a b: nat) : delay nat :=
  if a <? b then now a else later (remainder (a - b) b).

Lemma remainder_terminates:
  forall a b, b > 0 ->
  exists q r, terminates (remainder a b) r /\ r < b /\ a = b * q + r.
Proof.
  induction a using (well_founded_ind lt_wf). intros.
  unroll_delay (remainder a b). destruct (Nat.ltb_spec a b).
- exists 0, a. split. constructor. split. auto. lia.
- assert (LT: a - b < a) by lia.
  destruct (H _ LT b H0) as (q & r & P & Q & R).
  exists (S q), r. split. constructor; auto. split. auto. lia.
Qed.

Lemma remainder_diverges:
  forall a, diverges (remainder a 0).
Proof.
  cofix CIH; intros a. unroll_delay (remainder a 0). constructor. apply CIH.
Qed.

(** Equitermination of two computations. *)

Section EQUITERMINATION.

Context {A: Type}.

CoInductive equi: delay A -> delay A -> Prop :=
  | equi_terminates: forall x y v, terminates x v -> terminates y v -> equi x y
  | equi_later: forall x y, equi x y -> equi (later x) (later y).

Notation "x == y" := (equi x y) (at level 70, no associativity).

Lemma equi_refl: forall x, x == x.
Proof.
  cofix COINDHYP; intros; destruct x.
- apply equi_terminates with a; constructor.
- apply equi_later. apply COINDHYP.
Qed.

Lemma equi_refl': forall x y, x = y -> x == y.
Proof.
  intros; subst; apply equi_refl.
Qed.

Lemma equi_sym: forall x y, x == y -> y == x.
Proof.
  cofix COINDHYP; intros x y E; inversion E; subst.
- apply equi_terminates with v; auto.
- apply equi_later; apply COINDHYP; auto.
Qed.

Lemma terminates_equi:
  forall x v, terminates x v -> forall y, x == y -> terminates y v.
Proof.
  induction 1; intros y E; inversion E; subst.
- inversion H; auto.
- inversion H0; subst.
  assert (v0 = v) by (eapply terminates_unique; eauto). subst v0; auto.
- constructor; eauto.
Qed.

Lemma equi_trans: forall x y z, x == y -> y == z -> x == z.
Proof.
  cofix COINDHYP; intros x y z E1 E2; inversion E1; subst.
- apply equi_terminates with v. auto. apply terminates_equi with y; auto.
- inversion E2; subst.
+ inversion H0; subst. apply equi_terminates with v; auto. constructor.
  apply terminates_equi with y0; auto using equi_sym.
+ constructor. apply COINDHYP with y0; auto.
Qed.

Lemma eq_later: forall x, later x == x.
Proof.
  cofix COINDHYP; intros x. destruct x.
- apply equi_terminates with a; repeat constructor.
- apply equi_later. apply COINDHYP.
Qed.

Lemma diverges_equi: forall x y, x == y -> diverges x -> diverges y.
Proof.
  cofix COINDHYP; intros. inversion H; subst.
- elim (terminates_diverges_excl A x v); auto.
- inversion H0; subst. constructor. eauto.
Qed.

(** Weak bisimulation is another presentation of equitermination,
    with constructors [bisim_left] and [bisim_right] that enable us
    to "skip" a [later] constructor on one side but not on the other side.
    This simplifies many proofs.  However, we must prevent
    [bisim_left] or [bisim_right] to be applied infinitely often,
    because this would make [now v] and [bottom] bisimilar.
    The extra argument of type [nat] limits the number of consecutive
    applications of the [bisim_left] and [bisim_right] rules.
    It is reset to an arbitrarily high value when [bisim_both] is applied. *)

CoInductive bisim: nat -> delay A -> delay A -> Prop :=
  | bisim_now: forall n v,
      bisim n (now v) (now v)
  | bisim_both: forall m n x y,
      bisim m x y -> bisim n (later x) (later y)
  | bisim_left: forall n x y,
      bisim n x y -> bisim (S n) (later x) y
  | bisim_right: forall n x y,
      bisim n x y -> bisim (S n) x (later y).

Lemma bisim_inv: forall n x y,
  bisim n x y ->
     (exists v, terminates x v /\ terminates y v)
  \/ (exists n' x' y', x = later x' /\ y = later y' /\ bisim n' x' y').
Proof.
  induction n using lt_wf_ind.
  intros x y B; inversion B; subst.
- left; exists v; split; constructor.
- right; exists m, x0, y0; auto.
- edestruct (H n0) as [(v & T1 & T2) | (n' & x' & y' & E1 & E2 & B')].
  lia. eauto.
  + left; exists v; auto using terminates_later.
  + right. exists (S n'), (later x'), y'; intuition auto.
    congruence. apply bisim_left; auto.
- edestruct (H n0) as [(v & T1 & T2) | (n' & x' & y' & E1 & E2 & B')].
  lia. eauto.
  + left; exists v; auto using terminates_later.
  + right. exists (S n'), x', (later y'); intuition auto.
    congruence. apply bisim_right; auto.
Qed.

Lemma bisim_equi: forall n x y,
  bisim n x y -> x == y.
Proof.
  cofix CIH; intros.
  destruct (bisim_inv _ _ _ H)
  as [(v & T1 & T2) | (n' & x' & y' & E1 & E2 & B')].
- apply equi_terminates with v; auto.
- subst. constructor. eauto.
Qed.

End EQUITERMINATION.

Notation "x == y" := (equi x y) (at level 70, no associativity).

(** The monad structure. *)

Definition ret := now.

CoFixpoint bind {A B: Type} (x: delay A) (f: A -> delay B) : delay B :=
  match x with
  | now v => later (f v)
  | later y => later (bind y f)
  end.

Remark bind_now: forall (A B: Type) (v: A) (f: A -> delay B),
  bind (now v) f = later (f v).
Proof. intros; samedelay. Qed.

Remark bind_later: forall (A B: Type) (x: delay A) (f: A -> delay B),
  bind (later x) f = later (bind x f).
Proof. intros; samedelay. Qed.

(** The three monadic laws hold up to equitermination. *)

Lemma mon_law_1: forall (A B: Type) (v: A) (f: A -> delay B),
  bind (now v) f == f v.
Proof.
  intros. rewrite bind_now. apply eq_later.
Qed.

Lemma mon_law_2: forall (A: Type) (m: delay A),
  bind m (@ret A) == m.
Proof.
  cofix CIH; intros. destruct m.
- rewrite bind_now. apply eq_later.
- rewrite bind_later. constructor. apply CIH.
Qed.

Lemma mon_law_3: forall (A B C: Type) (m: delay A) (f: A -> delay B) (g: B -> delay C),
  bind (bind m f) g == bind m (fun x => bind (f x) g).
Proof.
  cofix CIH. intros; destruct m.
- rewrite ! bind_now, bind_later. apply equi_refl.
- rewrite ! bind_later. constructor. apply CIH.
Qed.

(** [bind] is compatible with equitermination [==]. *)

Lemma bind_terminates_l:
  forall (A: Type) (m: delay A) (v: A), terminates m v ->
  forall (B: Type) (f: A -> delay B), bind m f == f v.
Proof.
  induction 1; intros.
- apply mon_law_1.
- rewrite bind_later. eapply equi_trans. apply eq_later. apply IHterminates.
Qed.

Lemma bind_context:
  forall (A B: Type) (m1 m2: delay A) (f1 f2: A -> delay B),
  m1 == m2 ->
  (forall v, f1 v == f2 v) ->
  bind m1 f1 == bind m2 f2.
Proof.
  cofix CIH; intros. inversion H; subst.
- apply equi_trans with (f1 v). apply bind_terminates_l; auto.
  apply equi_trans with (f2 v). auto.
  apply equi_sym. apply bind_terminates_l; auto.
- rewrite ! bind_later. constructor. apply CIH; auto.
Qed.

(** ** 6.6.  The monadic metalanguage *)

(** Here is the (coinductive) abstract syntax that expresses computations
    in the partiality monad. *)

CoInductive mon (A: Type): Type :=
  | Ret: A -> mon A
  | Later: mon A -> mon A
  | Bind: forall {B: Type}, mon B -> (B -> mon A) -> mon A.

Arguments Ret [A].
Arguments Later [A].
Arguments Bind [A B].

Lemma u_mon:
  forall {A: Type} (x: mon A),
  x = match x with Ret v => Ret v | Bind y f => Bind y f | Later m => Later m end.
Proof. destruct x; auto. Qed.

(** The semantics of an abstract syntax tree (of type [mon A])
    is defined by translation to the computation (of type [delay A])
    denoted by the syntax tree. *)

CoFixpoint run {A: Type} (m: mon A) : delay A :=
  match m with
  | Ret v => now v
  | Later m => later (run m)
  | Bind (Ret v) f => later (run (f v))
  | Bind (Later m) f => later (run (Bind m f))
  | Bind (Bind m f) g => later (run (Bind m (fun x => Bind (f x) g)))
  end.

Lemma run_Ret: forall (A: Type) (v: A), run (Ret v) = now v.
Proof. intros; samedelay. Qed.

Lemma run_Later: forall (A: Type) (m: mon A), run (Later m) = later (run m).
Proof. intros; samedelay. Qed.

Lemma run_Bind_Ret: forall (A B: Type) (v: A) (f: A -> mon B),
    run (Bind (Ret v) f) = later (run (f v)).
Proof. intros; samedelay. Qed.

Lemma run_Bind_Later: forall (A B: Type) (m: mon A) (f: A -> mon B),
    run (Bind (Later m) f) = later (run (Bind m f)).
Proof. intros; samedelay. Qed.

Lemma run_Bind_Bind: forall (A B C: Type) (m: mon A) (f: A -> mon B) (g: B -> mon C),
    run (Bind (Bind m f) g) = later (run (Bind m (fun x => Bind (f x) g))).
Proof. intros; samedelay. Qed.

(** Some of our proofs use continuations, which can also be viewed as
    contexts.  A context is a list of functions [A -> mon B] that
    can be composed using the "bind" operator. *)

Inductive cont: Type -> Type -> Type :=
  | K0: forall (A: Type), cont A A
  | Kbind: forall {A B C: Type} (f: A -> mon B) (k: cont B C), cont A C.

Fixpoint insert_cont {A B: Type} (k: cont A B):
    forall {C: Type}, (B -> mon C) -> (A -> mon C) :=
  match k in cont A B
  return forall {C: Type}, (B -> mon C) -> (A -> mon C) with
  | K0 A => fun C g => g
  | Kbind f k => fun D g a => Bind (f a) (insert_cont k g)
  end.

(** The three monadic laws.  *)

Lemma Mon_law_1: forall (A B: Type) (v: A) (f: A -> mon B),
  run (Bind (Ret v) f) == run (f v).
Proof.
  intros. rewrite run_Bind_Ret; apply eq_later.
Qed.

Lemma Mon_law_3: forall (A B C: Type) (m: mon A) (f: A -> mon B) (g: B -> mon C),
  run (Bind (Bind m f) g) == run (Bind m (fun x => Bind (f x) g)).
Proof.
  intros. rewrite run_Bind_Bind; apply eq_later.
Qed.

(** The second monadic law is difficult to prove.  We use a bisimulation
    approach based on the following relation. *)

Inductive eta_match: forall {A: Type}, nat -> mon A -> mon A -> Prop :=
| eta_match_1: forall {A: Type} (m: mon A),
    eta_match 1%nat (Bind m (@Ret _)) m
| eta_match_2: forall {A B C: Type} (m: mon A) (k: cont A B) (g: B -> mon C),
    eta_match 0%nat (Bind m (insert_cont k (fun x => Bind (g x) (@Ret _))))
                    (Bind m (insert_cont k g)).

Lemma Mon_law_2_aux:
  forall (A: Type) n (x y: mon A),
  eta_match n x y -> bisim n (run x) (run y).
Proof.
  cofix CIH; destruct 1.
  - destruct m.
    + rewrite run_Bind_Ret, run_Ret.
      apply bisim_left. apply bisim_now.
    + rewrite run_Bind_Later, run_Later.
      eapply bisim_both. apply CIH. apply eta_match_1.
    + rewrite run_Bind_Bind.
      apply bisim_left. apply CIH.
      apply eta_match_2 with (k := K0 _).
  - destruct m.
    + rewrite ! run_Bind_Ret. destruct k; simpl.
      * eapply bisim_both. apply CIH. apply eta_match_1.
      * eapply bisim_both. apply CIH. apply eta_match_2.
    + rewrite ! run_Bind_Later.
      eapply bisim_both. apply CIH. apply eta_match_2.
    + rewrite ! run_Bind_Bind.
      eapply bisim_both. apply CIH.
      apply eta_match_2 with (k0 := Kbind m0 k).
Qed.

Lemma Mon_law_2:
  forall (A: Type) (m: mon A), run (Bind m (@Ret A)) == run m.
Proof.
  intros. eapply bisim_equi. apply Mon_law_2_aux. apply eta_match_1.
Qed.

(** It follows that the denotation of a [Bind] is the [bind] of the
    denotations. *)

Lemma run_Bind_aux:
  forall (A B C: Type) (m: mon A) (k: cont A B) (f: B -> mon C),
  run (Bind m (insert_cont k f)) ==
  bind (run (Bind m (insert_cont k (@Ret _)))) (fun x => run (f x)).
Proof.
  cofix CIH; intros.
  destruct m.
  - rewrite ! run_Bind_Ret. destruct k; cbn.
    + rewrite run_Ret, bind_later, bind_now.
      constructor. apply equi_sym; apply eq_later.
    + rewrite bind_later. apply equi_later. apply CIH.
  - rewrite ! run_Bind_Later, bind_later.
    apply equi_later. apply CIH.
  - rewrite ! run_Bind_Bind, bind_later.
    apply equi_later. apply CIH with (k := Kbind m0 k).
Qed.

Theorem run_Bind:
  forall (A B: Type) (m: mon A) (f: A -> mon B),
  run (Bind m f) == bind (run m) (fun x => run (f x)).
Proof.
  intros.
  change (Bind m f) with (Bind m (insert_cont (K0 _) f)).
  eapply equi_trans. apply run_Bind_aux. apply bind_context.
  apply Mon_law_2.
  intros; apply equi_refl.
Qed.

(** ** 6.7.  Application: an interpreter / denotational semantics for IMP *)

CoFixpoint cinterp (c: com) (s: store) : mon store :=
  match c with
  | SKIP => Ret s
  | ASSIGN x a => Ret (update x (aeval a s) s)
  | SEQ c1 c2 => Bind (cinterp c1 s) (cinterp c2)
  | IFTHENELSE b c1 c2 =>
      Later (cinterp (if beval b s then c1 else c2) s)
  | WHILE b c =>
      if beval b s then Bind (cinterp c s) (cinterp (WHILE b c))
                   else Ret s
  end.

(** The denotation of a command is the execution of its interpretation. *)

Definition denot (c: com) (s: store) : delay store := run (cinterp c s).

(** The denotational equations for IMP are satisfied, up to equitermination. *)

Lemma denot_skip: forall s,
  denot SKIP s == now s.
Proof.
  intros. unroll_delay (denot SKIP s). apply equi_refl.
Qed.

Lemma denot_assign: forall x a s,
  denot (ASSIGN x a) s == now (update x (aeval a s) s).
Proof.
  intros. unroll_delay (denot (ASSIGN x a) s). apply equi_refl.
Qed.

Lemma denot_seq: forall c1 c2 s,
  denot (SEQ c1 c2) s == bind (denot c1 s) (denot c2).
Proof.
  unfold denot; intros. rewrite (u_mon (cinterp (c1;;c2) s)); cbn.
  apply run_Bind.
Qed.

Lemma denot_ifthenelse: forall b c1 c2 s,
  denot (IFTHENELSE b c1 c2) s == if beval b s then denot c1 s else denot c2 s.
Proof.
  unfold denot; intros. rewrite (u_mon (cinterp (IFTHENELSE b c1 c2) s)); cbn.
  rewrite run_Later. destruct (beval b s); apply eq_later.
Qed.

Lemma denot_while: forall b c s,
  denot (WHILE b c) s ==
  if beval b s then bind (denot c s) (denot (WHILE b c)) else now s.
Proof.
  unfold denot; intros. rewrite (u_mon (cinterp (WHILE b c) s)); cbn.
  destruct (beval b s).
- apply run_Bind.
- rewrite run_Ret. apply equi_refl.
Qed.


(** a small plugin to derive a list of all constructors of an inductive type **)

Require Import MetaCoq.Template.All.

Require Import List String.
Import ListNotations MonadNotation Nat.
Require Import MetaCoq.Template.Pretty.

Require Import List String.
Open Scope string.

Unset Strict Unquote Universe Mode.

Definition getCtorsSimpl {A} (ind:A) : TemplateMonad unit :=
  tm <- tmQuote ind;;
  match tm with
  | tInd (mkInd kername idx as induct) _ =>
      mbody <- tmQuoteInductive kername;;
      match nth_error mbody.(ind_bodies) idx with
      | Some ibody =>
          ctors <- monad_map
            (fun '(na,t,count) =>
              tmUnquoteTyped Type (subst10 tm t)
            )
            ibody.(ind_ctors);;
          tmPrint ctors
      | None => tmFail "the mutual inductive index was wrong" (* can't happen *)
      end
  | _ => tmFail "argument has to be an inductive type"
  end.

MetaCoq Run (getCtorsSimpl nat).
Fail MetaCoq Run (getCtorsSimpl list).

Definition listCtors : list ({ T : Type & T}).
  apply cons.
  2: apply cons.
  3: apply nil.
  - exists (forall (A:Type), list A).
    exact @nil.
  - exists (forall (A:Type), A -> list A -> list A).
    exact @cons.
Defined.

(* Set Printing Universes. *)
Print listCtors.
About listCtors.

Definition natCtors : list ({ T : Type & T}).
  apply cons.
  - exists nat.
    exact O.
  - apply cons.
    + exists (nat->nat).
      exact S.
    + apply nil.
Defined.

Print natCtors.

Definition getCtors {A} (ind:A) : TemplateMonad unit :=
  tm <- tmQuote ind;;
  match tm with
  | tInd (mkInd kername idx as induct) _ =>
      mbody <- tmQuoteInductive kername;;
      match nth_error mbody.(ind_bodies) idx with
      | Some ibody =>
          ctors <- monad_map_i
            (fun i '(na,t,count) =>
              ctorType <- tmUnquoteTyped Type (subst10 tm t);;
              ctor <- tmUnquoteTyped ctorType (tConstruct induct i []);;
              tmEval lazy ((ctorType;ctor):∑ T : Type, T)
            )
            ibody.(ind_ctors);;
          tmDefinition (append ibody.(ind_name) "_ctors") ctors;;
          tmPrint ctors
      | None => tmFail "the mutual inductive index was wrong" (* can't happen *)
      end
  | _ => tmFail "argument has to be an inductive type"
  end.

MetaCoq Run (getCtors nat).
Print nat_ctors.

MetaCoq Run (getCtors Acc).
MetaCoq Run (getCtors or).
MetaCoq Run (getCtors sig).
Print or_ctors.
Print sig_ctors.
MetaCoq Run (getCtors option).
MetaCoq Run (getCtors term).
(* MetaCoq Run (getCtorsSimpl list). *)


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* $Id: Ascii.v 14641 2011-11-06 11:59:10Z herbelin $ *)

(** Contributed by Laurent Théry (INRIA);
    Adapted to Coq V8 by the Coq Development Team *)

Require Import Bool BinPos BinNat Nnat.
Declare ML Module "ascii_syntax_plugin".

(** * Definition of ascii characters *)

(** Definition of ascii character as a 8 bits constructor *)

Inductive ascii : Set := Ascii (_ _ _ _ _ _ _ _ : bool).

Delimit Scope char_scope with char.
Bind Scope char_scope with ascii.

Definition zero := Ascii false false false false false false false false.

Definition one := Ascii true false false false false false false false.

Definition shift (c : bool) (a : ascii) :=
  match a with
    | Ascii a1 a2 a3 a4 a5 a6 a7 a8 => Ascii c a1 a2 a3 a4 a5 a6 a7
  end.

(** Definition of a decidable function that is effective *)

Definition ascii_dec : forall a b : ascii, {a = b} + {a <> b}.
  decide equality; apply bool_dec.
Defined.

(** * Conversion between natural numbers modulo 256 and ascii characters *)

(** Auxillary function that turns a positive into an ascii by
   looking at the last 8 bits, ie z mod 2^8 *)

Definition ascii_of_pos : positive -> ascii :=
 let loop := fix loop n p :=
   match n with
     | O => zero
     | S n' =>
       match p with
         | xH => one
         | xI p' => shift true (loop n' p')
         | xO p' => shift false (loop n' p')
       end
   end
 in loop 8.

(** Conversion from [N] to [ascii] *)

Definition ascii_of_N (n : N) :=
  match n with
    | N0 => zero
    | Npos p => ascii_of_pos p
  end.

(** Same for [nat] *)

Definition ascii_of_nat (a : nat) := ascii_of_N (N_of_nat a).

(** The opposite functions *)

Local Open Scope list_scope.

Fixpoint N_of_digits (l:list bool) : N :=
 match l with
  | nil => 0
  | b :: l' => (if b then 1 else 0) + 2*(N_of_digits l')
 end%N.

Definition N_of_ascii (a : ascii) : N :=
 let (a0,a1,a2,a3,a4,a5,a6,a7) := a in
 N_of_digits (a0::a1::a2::a3::a4::a5::a6::a7::nil).

Definition nat_of_ascii (a : ascii) : nat := nat_of_N (N_of_ascii a).

(** Proofs that we have indeed opposite function (below 256) *)

Theorem ascii_N_embedding :
  forall a : ascii, ascii_of_N (N_of_ascii a) = a.
Proof.
  destruct a as [[|][|][|][|][|][|][|][|]]; vm_compute; reflexivity.
Qed.

Theorem N_ascii_embedding :
  forall n:N, (n < 256)%N -> N_of_ascii (ascii_of_N n) = n.
Proof.
destruct n.
reflexivity.
do 8 (destruct p; [ | | intros; vm_compute; reflexivity ]);
 intro H; vm_compute in H; destruct p; discriminate.
Qed.

Theorem ascii_nat_embedding :
  forall a : ascii, ascii_of_nat (nat_of_ascii a) = a.
Proof.
  destruct a as [[|][|][|][|][|][|][|][|]]; compute; reflexivity.
Qed.

Theorem nat_ascii_embedding :
  forall n : nat, n < 256 -> nat_of_ascii (ascii_of_nat n) = n.
Proof.
 intros. unfold nat_of_ascii, ascii_of_nat.
 rewrite N_ascii_embedding.
 apply nat_of_N_of_nat.
 unfold Nlt.
 change 256%N with (N_of_nat 256).
 rewrite <- N_of_nat_compare.
 rewrite <- Compare_dec.nat_compare_lt. auto.
Qed.

(** * Concrete syntax *)

(**
  Ascii characters can be represented in scope char_scope as follows:
  - ["c"]   represents itself if c is a character of code < 128,
  - [""""]  is an exception: it represents the ascii character 34
            (double quote),
  - ["nnn"] represents the ascii character of decimal code nnn.

  For instance, both ["065"] and ["A"] denote the character `uppercase
  A', and both ["034"] and [""""] denote the character `double quote'.

  Notice that the ascii characters of code >= 128 do not denote
  stand-alone utf8 characters so that only the notation "nnn" is
  available for them (unless your terminal is able to represent them,
  which is typically not the case in coqide).
*)

Open Local Scope char_scope.

Example Space := " ".
Example DoubleQuote := """".
Example Beep := "007".


From Cat Require Export Cat.
From Cat.Universal Require Import Initial Terminal Zero Product Coproduct Biproduct.
From Cat.Instances Require Import SETOID Mon CMon Grp.

Set Implicit Arguments.

Class AbGrp : Type :=
{
  grp :> Grp;
  op_comm : forall x y : grp, op x y == op y x;
}.

Coercion grp : AbGrp >-> Grp.

#[export]
Instance AbGrp2Mon (A : AbGrp) : CMon :=
{
  mon := A;
  op_comm := op_comm;
}.

Coercion AbGrp2Mon : AbGrp >-> CMon.

#[refine]
#[export]
Instance AbGrpCat : Cat :=
{
  Ob := AbGrp;
  Hom := MonHom;
  HomSetoid := MonHomSetoid;
  comp := MonComp;
  id := MonId;
}.
Proof.
  - intros A B C f1 f2 Hf g1 g2 Hg x; cbn in *.
    now rewrite Hf, Hg.
  - now cbn.
  - now cbn.
  - now cbn.
Defined.

#[refine]
#[export]
Instance AbGrp_zero : AbGrp :=
{
  grp := Grp_zero;
}.
Proof. all: easy. Defined.

#[refine]
#[export]
Instance HasInit_AbGrp : HasInit AbGrpCat :=
{
  init := AbGrp_zero;
  create := Mon_create;
}.
Proof.
  unfold isInitial; cbn; intros.
  now apply HasInit_Grp.
Defined.

#[refine]
#[export]
Instance HasTerm_AbGrp : HasTerm AbGrpCat :=
{
  term := AbGrp_zero;
  delete := Mon_delete;
}.
Proof. easy. Defined.

#[refine]
#[export]
Instance HasZero_AbGrp : HasZero AbGrpCat :=
{
  HasInit_HasZero := HasInit_AbGrp;
  HasTerm_HasZero := HasTerm_AbGrp;
}.
Proof. now cbn. Defined.

#[refine]
#[export]
Instance AbGrp_product (X Y : AbGrp) : AbGrp :=
{
  grp := Grp_product X Y;
}.
Proof. now cbn; split; apply op_comm. Defined.

#[refine]
#[export]
Instance HasProducts_AbGrp : HasProducts AbGrpCat :=
{
  product := AbGrp_product;
  outl    := Mon_outl;
  outr    := Mon_outr;
  fpair   := Mon_fpair;
}.
Proof.
  split; cbn.
  - easy.
  - easy.
  - now split.
Defined.

Definition AbGrp_coproduct (A B : AbGrp) : AbGrp := AbGrp_product A B.

Definition AbGrp_finl {A B : AbGrp} : MonHom A (AbGrp_coproduct A B) :=
  @CMon_finl A B.

Definition AbGrp_finr {A B : AbGrp} : MonHom B (AbGrp_coproduct A B) :=
  @CMon_finr A B.

Definition AbGrp_copair
  {A B X : AbGrp} (f : MonHom A X) (g : MonHom B X) : MonHom (AbGrp_coproduct A B) X :=
    @CMon_copair A B X f g.

#[refine]
#[export]
Instance HasCoproducts_AbGrp : HasCoproducts AbGrpCat :=
{
  coproduct := @AbGrp_coproduct;
  finl      := @CMon_finl;
  finr      := @CMon_finr;
  copair    := @CMon_copair;
}.
Proof.
  split; cbn.
  - now intros; rewrite pres_neutr, neutr_r.
  - now intros; rewrite pres_neutr, neutr_l.
  - intros P' h1 h2 HA HB [a b]; cbn.
    assert (Heq' : @equiv _ (Mon_product A B) (a, b) (op a neutr, op neutr b))
      by now cbn; rewrite neutr_l, neutr_r.
    apply (Proper_func h1) in Heq'.
    assert (Heq :
        h1 (@op (CMon_coproduct A B) (a, neutr) (neutr, b))
          ==
        h2 (@op (CMon_coproduct A B) (a, neutr) (neutr, b)))
      by now rewrite !pres_op; f_equiv.
    rewrite Heq', Heq.
    apply (Proper_func h2); cbn.
    now rewrite neutr_l, neutr_r.
Defined.

#[refine]
#[export]
Instance HasBiproducts'_AbGrp : HasBiproducts' AbGrpCat :=
{
  biproduct := AbGrp_product;
  bioutl    := Mon_outl;
  bioutr    := Mon_outr;
  bipair    := Mon_fpair;
  binl      := @CMon_finl;
  binr      := @CMon_finr;
  bicopair  := @CMon_copair;
}.
Proof.
  - now apply HasProducts_AbGrp.
  - now apply HasCoproducts_AbGrp.
  - now cbn.
  - now cbn.
  - now cbn.
Defined.

#[refine]
#[export]
Instance AbGrp_equalizer {A B : AbGrp} (f g : MonHom A B) : AbGrp :=
{
  grp := Grp_equalizer f g;
}.
Proof.
  intros [x Hx] [y Hy]; cbn.
  now apply op_comm.
Defined.

#[refine]
#[export]
Instance HasEqualizers_AbGrp : HasEqualizers AbGrpCat :=
{
  equalizer := @AbGrp_equalizer;
  equalize  := @Mon_equalize;
  factorize := @Mon_factorize;
}.
Proof.
  split; cbn.
  - now intros [x H]; cbn.
  - easy.
  - easy.
Defined.

#[refine]
#[export]
Instance AbGrp_coequalizer {A B : AbGrp} (f g : MonHom A B) : AbGrp :=
{
  grp := Grp_coequalizer f g;
}.
Proof.
  now cbn; intros; apply SgrCE_refl, op_comm.
Defined.

#[refine]
#[export]
Instance HasCoequalizers_AbGrp : HasCoequalizers AbGrpCat :=
{
  coequalizer := @AbGrp_coequalizer;
  coequalize  := @Mon_coequalize;
  cofactorize := @Mon_cofactorize;
}.
Proof.
  split; cbn.
  - now constructor.
  - easy.
  - easy.
Defined.

#[refine]
#[export]
Instance AbGrp_pullback
  {A B X : AbGrp} (f : MonHom A X) (g : MonHom B X) : AbGrp :=
{
  grp := Grp_pullback f g;
}.
Proof.
  intros [a1 b1 ok1] [a2 b2 ok2]; cbn.
  now split; apply op_comm.
Defined.

#[refine]
#[export]
Instance HasPullbacks_AbGrp : HasPullbacks AbGrpCat :=
{
  pullback := @AbGrp_pullback;
  pullL    := @Mon_pullL;
  pullR    := @Mon_pullR;
  triple   := @Mon_triple;
}.
Proof.
  split; cbn.
  - now apply ok.
  - easy.
  - easy.
  - now split.
Defined.

(* We construct pushouts from coproducts and coequalizers. *)
#[export] Instance HasPushouts_AbGrp : HasPushouts AbGrpCat :=
  HasPushouts_HasCoproducts_HasCoequalizers HasCoproducts_AbGrp HasCoequalizers_AbGrp.


(** * CCMisc.v: Extensions to the Coq Standard Library *)

Set Implicit Arguments.

Require Import Bool.
Require Export BoolEquality.
Require Export List.
Require Import Heap.
Require Export Sorting.
Require Export Permutation.
Require Export NArith.
Require Export Ndec.
Require Export ZArith.
Require Export Arith.

Open Scope nat_scope.

(* List *)
Definition is_nil (A:Type) (l:list A) : bool :=
 match l with
  | nil => true
  | _ => false
 end.

Lemma find_In : forall (A:Type) (f:A -> bool) l a,
 find f l = Some a -> In a l /\ f a.
Proof.
 induction l; simpl; intro; try (intros; discriminate).
 case_eq (f a); intros.
 inversion H0; subst; auto.
 destruct (IHl _ H0); intuition.
Qed.

Lemma find_notIn : forall (A:Type) (f:A -> bool) l,
 find f l = None ->
 forall a, In a l -> f a = false.
Proof.
 induction l; simpl; intros.
 elim H0.
 destruct H0; subst.
 destruct (f a0); try discriminate; trivial.
 destruct (f a); try discriminate; auto.
Qed.

Lemma length_nil : forall A (l:list A), length l = O -> l = nil.
Proof.
 destruct l; intros; [trivial | discriminate].
Qed.

Lemma fold_right_rev_left: forall (A B:Type) (f:B -> A -> B) (l:list A) (i:B),
 fold_left f (rev l) i = fold_right (fun (x:A) (y:B) => f y x) i l.
Proof.
 intros.
 induction l; simpl; trivial.
 rewrite fold_left_app, IHl; simpl; trivial.
Qed.

Fixpoint lfalse (n:nat) :=
 match n with
  | O => nil
  | S n => false :: lfalse n
 end.

Lemma length_lfalse : forall n, length (lfalse n) = n.
Proof.
 induction n; simpl; intros; trivial.
 rewrite IHn; trivial.
Qed.

Lemma list_prod_nil t1 t2 (l1 : list t1) (l2 : list t2) :
  l1 <> nil -> l2 <> nil -> list_prod l1 l2 <> nil.
Proof.
 intros t1 t2 l1 l2 H1 H2 H.
 assert (length (list_prod l1 l2) = 0%nat).
 rewrite H; trivial.
 rewrite prod_length in H0.
 apply mult_is_O in H0; destruct H0;
   apply length_nil in H0; subst; tauto.
Qed.

Hint Constructors NoDup.

Lemma NoDup_dec: forall A,
 (forall x y:A, sumbool (x = y) (x <> y)) ->
 forall l:list A, sumbool (NoDup l) (~ NoDup l).
Proof.
 intros A eq_dec; induction l.
 left; constructor.
 destruct (in_dec eq_dec a l).
 right; intro H; inversion_clear H; tauto.
 destruct IHl.
 left; constructor; assumption.
 right; intro H; inversion_clear H; tauto.
Qed.

Lemma NoDup_snd : forall A B (l:list (A * B)),
 NoDup (map (@snd _ _) l) ->
 forall a1 a2 b,
  In (a1,b) l ->
  In (a2,b) l ->
  a1 = a2.
Proof.
 induction l; simpl; intros.
 elim H1.
 inversion_clear H.
 destruct H0; destruct H1; subst.
 injection H0; trivial.
 apply (in_map (@snd _ _)) in H0; tauto.
 apply (in_map (@snd _ _)) in H; tauto.
 apply IHl with b; trivial.
Qed.

Lemma NoDup_map_inj : forall A B (f:A -> B) l,
 (forall x y, In x l -> In y l -> f x = f y -> x = y) ->
 NoDup l ->
 NoDup (map f l).
Proof.
 clear.
 induction l; simpl; intros; constructor.
 intro H1; apply in_map_iff in H1.
 destruct H1 as [y [H3 H4] ].
 apply H in H3; [ | right; trivial | left; trivial].
 inversion_clear H0; subst; tauto.
 apply IHl.
 intros; apply H; auto.
 inversion H0; trivial.
Qed.

Lemma NoDup_app : forall A (l1 l2:list A),
 NoDup l1 ->
 NoDup l2 ->
 (forall x, In x l2 -> ~In x l1) ->
 NoDup (l1 ++ l2).
Proof.
 induction l1; simpl; intros; trivial.
 inversion_clear H.
 constructor; auto.
 intro H4; apply in_app_or in H4; destruct H4; auto.
 elim (H1 a); auto.
 apply IHl1; auto.
 firstorder.
Qed.

Lemma NoDup_app_inv : forall A (l1 l2:list A),
 NoDup (l1 ++ l2) -> NoDup l1 /\ NoDup l2.
Proof.
 induction l1; simpl; intros.
 split; [constructor | trivial].
 inversion_clear H.
 destruct (IHl1 _ H1); split; [ constructor; trivial | trivial].
 intro; apply H0; apply in_or_app; auto.
Qed.

Lemma NoDup_rev : forall A (l:list A),
 NoDup l ->
 NoDup (rev l).
Proof.
 induction l; intros.
 constructor.
 inversion_clear H.
 simpl; apply NoDup_app.
 auto.
 auto.
 intros x Hx Hin.
 apply In_rev in Hin.
 destruct Hx; subst; auto.
Qed.

Lemma NoDup_list_prod : forall A B (l1:list A) (l2:list B),
 NoDup l1 -> NoDup l2 -> NoDup (list_prod l1 l2).
Proof.
 induction l1.
 constructor.

 intros; simpl.
 apply NoDup_app.
 apply NoDup_map_inj; trivial.
 intros ? ? _ _ H3; injection H3; trivial.
 apply IHl1; trivial.
 inversion H; trivial.

 intros (x,y) H3 Hin.
 apply in_prod_iff in H3; destruct H3.
 apply in_map_iff in Hin; destruct Hin as [x' [? ?] ].
 injection H3; intros; subst.
 contradict H; intro; inversion H; subst.
 absurd (In x l1); trivial.
Qed.

Lemma Permutation_NoDup : forall A (l l': list A),
 Permutation l l' -> NoDup l -> NoDup l'.
Proof.
 induction 1; intros; trivial.
 inversion_clear H0; constructor; auto.
 intro; apply H1.
 apply Permutation_in with l'; trivial.
 apply Permutation_sym; trivial.
 inversion_clear H.
 inversion_clear H1.
 simpl in H0; constructor.
 simpl; intros [H1 | H1]; auto.
 constructor; auto.
 auto.
Qed.

Lemma NoDup_app_comm: forall A (l1 l2 :list A),
 NoDup (l1 ++ l2) -> NoDup (l2 ++ l1).
Proof.
 intros.
 refine (@Permutation_NoDup _ (l1 ++ l2) _ _ H).
 apply Permutation_app_swap.
Qed.

Lemma NoDup_app_cons_r : forall A (l l' : list A) (x':A),
 NoDup (l ++ x'::l') ->
 NoDup l /\ NoDup l' /\ not (In x' l) /\ not (In x' l').
Proof.
 intros.
 destruct (NoDup_app_inv _ _ H) as [H1 H2].
 inversion_clear H2.
 repeat split; try assumption.
 apply NoDup_app_comm in H.
 rewrite <- app_comm_cons in H.
 inversion_clear H; clear H4.
 intro H4; elim H2.
 apply in_or_app; auto.
Qed.

Lemma Sorted_le_lt : forall l,
 NoDup l ->
 Sorted le l ->
 Sorted lt l.
Proof.
 induction l; intros.
 trivial.
 constructor.
 inversion_clear H0; subst.
 apply IHl in H1; trivial.
 inversion H; trivial.
 inversion H0; subst.
 apply IHl in H3; trivial.
 inversion H; subst.
 destruct l.
 trivial.
 constructor.
 assert (a <> n).
 intro; subst; elim H5; simpl; auto.
 inversion H4; subst; omega.
 inversion H; trivial.
Qed.

Lemma Forall2_eq : forall A (l1 l2:list A), Forall2 eq l1 l2 -> l1 = l2.
Proof.
 intros; induction H; subst; trivial.
Qed.

Lemma Sorted_lt_NoDup : forall l,
 NoDup l ->
 exists l', Sorted lt l' /\ Permutation l l'.
Proof.
 intros.
 destruct (treesort nat le eq le_ge_dec eq_nat_dec le_trans l) as (l',H0,H1).
 apply PermutSetoid.permutation_Permutation in H1.
 destruct H1 as [l1 [ ? ? ] ].
 apply Forall2_eq in H2; subst.
 exists l'; split; trivial.
 apply Permutation_NoDup in H1; trivial.
 apply Sorted_le_lt; trivial.
 apply eq_equivalence.
Qed.

Lemma nth_cons : forall A (l:list A) a b n i,
 Compare_dec.leb (S n) i ->
 nth (i - S n) l b = nth (i - n) (a :: l) b.
Proof.
 intros.
 change (b :: l) with (b :: nil ++ l).
 rewrite (app_nth2 (a :: nil) l); [ | apply leb_complete in H; simpl; omega].
 simpl; replace (i - S n) with (i - n - 1) by omega; trivial.
Qed.

Lemma nth_app : forall A (l:list A) a b,
 nth (length l) (l ++ a :: nil) b = a.
Proof.
 intros; rewrite app_nth2, minus_diag; auto.
Qed.

Lemma In_nth_inv : forall A (a b:A) l,
 In a l ->
 exists n, (n < length l)%nat /\ a = nth n l b.
Proof.
 induction l; destruct 1.
 subst; exists O; split; simpl; auto with arith.
 destruct (IHl H) as [j [? ?] ]; exists (S j); split.
 simpl; omega.
 trivial.
Qed.

Fixpoint cexistsb (A:Type) (f:A->bool*nat) (l:list A) (n:nat) {struct l} :
 bool * nat :=
 match l with
  | nil => (false, n)
  | a::l0 => let (b, n0) := f a in
    if b then (true, n + n0) else cexistsb f l0 (n + n0)
 end.

Lemma existsb_cexistsb : forall A f g,
 (forall x, f x = fst (g x)) ->
 forall (l:list A) n, existsb f l = fst (cexistsb g l n).
Proof.
 intros A f g Hfg; induction l.
 trivial.
 simpl; generalize (Hfg a).
 case (f a); case (g a); intros b n H n0; simpl in H; rewrite <- H; trivial.
Qed.

Lemma existsb_app : forall A (f:A -> bool) l1 l2,
 existsb f (l1 ++ l2) = orb (existsb f l1) (existsb f l2).
Proof.
 induction l1; simpl; intros; trivial.
 rewrite IHl1, orb_assoc; trivial.
Qed.

Fixpoint cforallb (A:Type)(f:A->bool*nat)(l:list A)(n:nat) {struct l} : bool * nat :=
 match l with
 | nil => (true, n)
 | a::l0 => let (b, n0) := f a in
  if b then cforallb f l0 (n + n0) else (false, n + n0)
 end.

Lemma forallb_cforallb : forall A f g,
 (forall x, f x = fst (g x)) ->
 forall (l:list A) n, forallb f l = fst (cforallb g l n).
Proof.
 intros A f g Hfg; induction l.
 trivial.
 simpl; generalize (Hfg a).
 case (f a); case (g a); intros b n H n0; simpl in H; rewrite <- H; trivial.
Qed.

Definition find_default (A:Type) (f:A->bool) l default :=
  match List.find f l with
  | Some a => a
  | None => default
  end.

Fixpoint cfind (A:Type) (f:A->bool*nat) l n {struct l} : option A * nat :=
  match l with
  | nil => (None, n)
  | a :: tl => let (b, n0) := f a in
    if b then (Some a, n + n0) else cfind f tl (n + n0)
  end.

Definition cfind_default (A:Type) (f:A->bool*nat) l n default :=
  match cfind f l n with
  | (Some a, n0) => (a, n0)
  | (None, n0) => (default, n0)
  end.

Lemma find_cfind : forall A f g,
 (forall x, f x = fst (g x)) ->
 forall (l:list A) n, find f l = fst (cfind g l n).
Proof.
 intros A f g Hfg; induction l.
 trivial.
 simpl; generalize (Hfg a).
 case (f a); case (g a); intros b n H n0; simpl in H; rewrite <- H; trivial.
Qed.

Lemma find_cfind_default : forall A f g default,
 (forall x, f x = fst (g x)) ->
 forall (l:list A) n, find_default f l default = fst (cfind_default g l n default).
Proof.
 unfold find_default, cfind_default; intros.
 rewrite (find_cfind f g H l n).
 destruct (cfind g l n).
 destruct o; trivial.
Qed.

Section FOLD.

  Definition opt_app (A B:Type) (f : A -> option B) (a:option A) : option B :=
   match a with
   | Some a => f a
   | None => None
   end.

  Variable A B : Type.
  Variable f : A -> B -> option A.

  Fixpoint fold_left_opt  (l : list B) (a0 : A) {struct l} : option A :=
   match l with
   | nil => Some a0
   | b :: t => opt_app (fold_left_opt t) (f a0 b)
   end.

  Definition spec_opt (P:A->Prop) (a:option A) : Prop :=
   match a with
   | Some a => P a
   | None => True
   end.

End FOLD.

(* Nat *)
Fixpoint pow (n m:nat) {struct m} : nat :=
 match m with
 | O => S O
 | S m' => n * (pow n m')
 end.

Infix "^" := pow : nat_scope.

Definition pow_N (n m:N) : N :=
 Nnat.N_of_nat (pow (Nnat.nat_of_N n) (Nnat.nat_of_N m)).

Lemma pow_lt_0 : forall n c, 0 < n -> 0 < n ^ c.
Proof.
 intros; induction c.
 auto.
 apply lt_le_trans with (1:=IHc).
 rewrite <- (mult_1_l (n ^ c)).
 simpl pow; apply mult_le_compat_r; trivial.
Qed.

Lemma pow_2_le : forall c, exists k, c <= 2 ^ k.
Proof.
 induction c; intros.
 exists 0; simpl; auto.
 destruct IHc as [k Hle].
 exists (S k).
 apply le_trans with (1 + (2 ^ k)).
 apply le_n_S; trivial.
 simpl pow; rewrite plus_0_r.
 apply plus_le_compat.
 apply pow_lt_0; auto.
 trivial.
Qed.

Lemma pow_monotone_1 : forall k n m, n <= m -> n ^ k <= m ^ k.
Proof.
 induction k; intros; simpl.
 trivial.
 apply mult_le_compat; auto.
Qed.

Lemma pow_monotone_2 : forall k1 k2 n, 0 < n -> k1 <= k2 -> n ^ k1 <= n ^ k2.
Proof.
 induction k1; intros; simpl.
 apply le_trans with (1 ^ k2).
 apply pow_lt_0; auto.
 apply pow_monotone_1; trivial.
 inversion H0; subst.
 trivial.
 simpl; apply mult_le_compat.
 trivial.
 apply IHk1.
 trivial.
 auto with arith.
Qed.

Lemma pow_mult_plus : forall k1 k2 n, n ^ k1 * n ^ k2 = n ^ (k1 + k2).
Proof.
 induction k1; destruct k2; simpl; intros.
 trivial.
 ring.
 rewrite plus_0_r, mult_1_r; trivial.
 rewrite <- plus_n_Sm.
 simpl; rewrite <- IHk1; ring.
Qed.

Definition Nminus n1 n2 :=
 match n1, n2 with
 | N0, _ => N0
 | _, N0 =>  n1
 | Npos p1, Npos p2 =>
   match Pminus_mask p1 p2 with
   | IsPos p1 => Npos p1
   | _ => N0
   end
 end.

(* REMARK: There exist a [beq_nat] in EqNat *)
Fixpoint nat_eqb (n1 n2:nat) {struct n1} : bool :=
 match n1, n2 with
  | O, O => true
  | O, S _ => false
  | S _, O => false
  | S n1, S n2 => nat_eqb n1 n2
 end.

Lemma nat_eqb_spec : forall n1 n2, if nat_eqb n1 n2 then n1 = n2 else n1 <> n2.
Proof.
 induction n1; destruct n2; simpl; trivial; try (intro; discriminate).
 generalize (IHn1 n2); destruct (nat_eqb n1 n2); auto.
Qed.

Lemma nat_eqb_true : forall n1 n2, nat_eqb n1 n2 = true -> n1 = n2.
Proof.
 induction n1; destruct n2; simpl; trivial; try (intro; discriminate).
 auto.
Qed.

Implicit Arguments nat_eqb_true [n1 n2].

Lemma nat_eqb_refl : forall n, nat_eqb n n = true.
Proof.
 induction n; trivial.
Qed.

Lemma nat_eqb_sym : forall n m, nat_eqb n m = nat_eqb m n.
Proof.
 induction n; destruct m; simpl; trivial.
Qed.

Lemma nat_eqb_trans: forall (n m p: nat),
 nat_eqb n m -> nat_eqb m p -> nat_eqb n p.
Proof.
 intros.
 apply nat_eqb_true in H.
 apply nat_eqb_true in H0.
 subst; apply nat_eqb_refl.
Qed.

Lemma eqb_sym : forall x y, eqb x y = eqb y x.
Proof.
 intros; case x; case y; trivial.
Qed.

Lemma eqb_spec : forall (x y:bool), if eqb x y then x = y else x <> y.
Proof.
 intros.
 case_eq (eqb x y).
 apply eqb_prop.
 intros H1 H2; subst.
 rewrite eqb_reflx in H1.
 inversion H1.
Qed.

Definition eq_dec_nat (n m:nat) : sumbool (n = m) True :=
 match eq_nat_dec n m with
  | left i => left _ i
  | right _ => right _ I
 end.

Lemma eq_dec_nat_r : forall n m i, eq_dec_nat n m = right _ i -> n <> m.
Proof.
 intros n m; simpl; intro i.
 unfold eq_dec_nat; case (eq_nat_dec n m); intros.
 discriminate.
 trivial.
Qed.

(* Sum of the first [p] natural numbers *)

Fixpoint sum_k_p (k p:nat) {struct p} : nat :=
 if Compare_dec.leb k p then
  match p with
   | O => O
   | S p' => sum_k_p k p' + p
  end
  else 0.

Lemma sum_k_p_plus : forall p1 p2 p3,
 p1 <= p2 ->
 p2 <= p3 ->
 sum_k_p p1 p2 + sum_k_p (S p2) p3 = sum_k_p p1 p3.
Proof.
 induction p3; simpl; intros.
 assert (W:p2 = 0) by omega; rewrite W, plus_0_r; trivial.
 assert (W:p1 <= S p3) by apply le_trans with (1:=H) (2:=H0).
 rewrite (leb_correct _ _ W).
 case_eq (Compare_dec.leb p2 p3); intros.
 rewrite plus_assoc, IHp3; auto using leb_complete.
 apply leb_complete_conv in H1.
 assert (W1:p2 = S p3) by omega; rewrite plus_0_r, W1; simpl.
 rewrite (leb_correct _ _ W); trivial.
Qed.

Lemma sum_k_p_lt : forall k p, p < k -> sum_k_p k p = 0.
Proof.
 destruct p; simpl; intros.
 destruct (Compare_dec.leb k 0); trivial.
 rewrite leb_correct_conv; auto with arith.
Qed.

Lemma sum_k_p_eq : forall k, sum_k_p k k = k.
Proof.
 destruct k; trivial.
 simpl.
 rewrite leb_correct; auto with arith.
 rewrite sum_k_p_lt; auto with arith.
Qed.

Lemma sum_Sk_p : forall k p,
 k <= p ->
 sum_k_p k p = k + sum_k_p (S k) p.
Proof.
 intros k p H; destruct (le_lt_dec (S k) p).
 assert (W:k <= S k) by auto with arith.
 rewrite <- (@sum_k_p_plus k k p); trivial.
 rewrite sum_k_p_eq; trivial.
 assert (W: k = p) by omega.
 rewrite (sum_k_p_lt l), plus_0_r, W; apply sum_k_p_eq.
Qed.

Lemma sum_k_Sp : forall k p,
 k <= S p ->
 sum_k_p k (S p) = sum_k_p k p + S p.
Proof.
 intros; simpl; rewrite leb_correct; trivial.
Qed.

Lemma sum_0_n : forall n, 2 * sum_k_p 0 n = n * (n + 1).
Proof.
 induction n; trivial.
 rewrite sum_k_Sp; [ | auto with arith].
 rewrite mult_plus_distr_l, IHn; ring.
Qed.

(* New Datatypes *)

Inductive triple (A B C:Type) : Type :=
| Triple : A -> B -> C -> triple A B C.

Inductive quadruple (A B C D:Type) : Type :=
| Quad : A -> B -> C -> D -> quadruple A B C D.

Section PERMUTATION.

 Variables A B : Type.
 Variable  P : A -> B -> Prop.

 Inductive PermutP : list A -> list B -> Prop :=
 | permP_nil : PermutP nil nil
 | permP_swap : forall x x' l l1' l2',
    P x x' -> PermutP l (l1' ++ l2') -> PermutP (x :: l) (l1' ++ x' :: l2').

 Lemma PermutP_length : forall l1 l2,
  PermutP l1 l2 -> length l1 = length l2.
 Proof.
  induction 1; simpl; intros; trivial.
  rewrite IHPermutP; repeat rewrite app_length; simpl; auto with arith.
 Qed.

 Lemma PermutP_app : forall l1 l1',
  PermutP l1 l1' ->
  forall l2 l2',
   PermutP l2 l2' -> PermutP (l1++l2) (l1'++l2').
 Proof.
  induction 1; intros; simpl; trivial.
  rewrite app_ass; simpl; constructor; trivial.
  rewrite <- app_ass; auto.
 Qed.

 Lemma PermutP_cons : forall a b la lb,
  P a b ->
  PermutP la lb ->
  PermutP (a::la) (b::lb).
 Proof.
  intros; change (b::lb) with (nil++b::lb); constructor; trivial.
 Qed.

 Lemma PermutP_cons_r_inv : forall x l1 l2,
  PermutP l1 (x::l2) ->
  exists x', exists l, exists l',
   l1 = l ++ x' :: l' /\
   P x' x /\
   PermutP (l++l') l2.
 Proof.
  induction l1; intros l2 H; inversion H; clear H; subst.
  destruct l1'; simpl in *.
  injection H2; clear H2; intros; subst.
  exists a; exists nil; exists l1; repeat split; trivial.
  injection H2; clear H2; intros; subst.
  destruct (IHl1 _ H4) as (x'' , (l, (l', (W1,(W2,W3))))); clear H4; subst.
  exists x''; exists (a::l); exists l'; repeat split; trivial.
  simpl; constructor; trivial.
 Qed.

 Lemma PermutP_cons_r : forall a b l l' l2,
  PermutP (l++l') l2 ->
  P a b ->
  PermutP (l ++ a :: l') (b::l2).
 Proof.
  induction l; simpl; intros l' l2 H Hp.
  apply PermutP_cons; trivial.
  inversion H; clear H; subst.
  change (b :: l1' ++ x' :: l2') with ((b :: l1') ++ x' :: l2');
   constructor; simpl; auto.
 Qed.

 Lemma PermutP_app_cons_inv : forall x l2 l1 l3,
  PermutP (l1 ++ x :: l2) l3 ->
  exists l4, exists l5, exists x',
   l3 = l4 ++ (x'::l5) /\
   P x x' /\
   PermutP (l1++l2) (l4++l5) .
 Proof.
  induction l1; simpl; intros.
  inversion H.
  exists l1'; exists l2'; exists x'; auto.
  inversion H; clear H; subst.
  destruct (IHl1 _ H4) as (l4, (l5, (x'', (Heq, (HP, HPr))))).
  clear IHl1 H4.
  generalize l1' l2' l1 l2 l4 l5 Heq HPr.
  clear HPr Heq l1' l2' l4 l5 l1 l2.
  induction l1'; simpl; intros.
  rewrite Heq; exists (x'::l4); exists l5; exists x''; repeat split; trivial.
  simpl; apply PermutP_cons; trivial.
  destruct l4; simpl in Heq; injection Heq; clear Heq; intros; subst; simpl in *.
  exists nil; exists (l1' ++ x' :: l2'); exists x''; repeat split; trivial.
  simpl; constructor; trivial.
  destruct (PermutP_cons_r_inv HPr) as (b', (l6, (l7, (W1,(W2,W3))))).
  destruct (IHl1' _ _ _ _ _ H W3) as (l8, (l9, (y, (W4, (W5,W6))))).
  rewrite W4, W1.
  exists (b::l8); exists l9; exists y; repeat split; trivial.
  simpl; inversion W6; clear W6; subst.
  change (b :: l1'0 ++ x'0 :: l2'0) with ((b:: l1'0) ++ x'0 :: l2'0).
  constructor; trivial.
  simpl; apply PermutP_cons_r; trivial.
 Qed.

End PERMUTATION.

Section PERMUTATION_PROP.

 Lemma PermutP_trans : forall (A B:Type) (P:A -> B -> Prop) l1 l2,
  PermutP P l1 l2 ->
  forall l3, PermutP (@eq _) l2 l3 -> PermutP P l1 l3.
 Proof.
  induction 1; simpl; intros.
  inversion H; constructor.
  destruct (PermutP_app_cons_inv (B:= B) (P:= @eq B) _ _ _ H1) as
   (l4, (l5, (x'', (W1, (W2, W3))))); clear H1; subst.
  constructor; auto.
 Qed.

 Lemma PermutP_refl : forall A (R:A -> A -> Prop) (l:list A),
  (forall x, In x l -> R x x) ->
  PermutP R l l.
 Proof.
  induction l; intros.
  constructor.
  apply PermutP_cons.
  apply H; apply in_eq.
  apply IHl; intros x Hx; exact (H x (in_cons  a _ _  Hx)).
 Qed.

 Lemma PermutP_sym : forall A B R (la:list A) (lb:list B),
  PermutP (fun b a => R a b) lb la ->
  PermutP R la lb.
 Proof.
  induction 1.
  constructor.
  apply PermutP_cons_r; trivial.
 Qed.

 Lemma PermutP_eq : forall A (l:list A), PermutP (@eq A) l l.
 Proof.
  induction l.
  constructor.
  apply PermutP_cons; trivial.
 Qed.

 Lemma PermutP_app_comm : forall A (l1 l2:list A),
  PermutP (@eq _) (l1++l2) (l2++l1).
 Proof.
  induction l1; simpl; intros.
  rewrite <- app_nil_end; apply PermutP_refl; unfold reflexive; trivial.
  constructor; trivial.
 Qed.

 Lemma PermutP_In : forall (A:Type) (d1 d2:list A) (x:A),
  PermutP (@eq _) d1 d2 -> In x d1 -> In x d2.
 Proof.
  intros A d1 d2 x Hperm.
  induction Hperm.
  tauto.
  intro Hx; simpl in Hx; destruct Hx as [Hx | Hx].
  rewrite <- Hx; rewrite H.
  apply in_or_app; right; simpl; tauto.
  apply in_or_app.
  destruct (@in_app_or _ _ _ _ (IHHperm Hx)).
  left; assumption.
  right; simpl; right; assumption.
 Qed.

 Lemma PermutP_rev : forall (A:Type) (l:list A),
  PermutP (@eq _) l (rev l).
 Proof.
  induction l; simpl; try constructor; auto.
  rewrite <- app_nil_end; trivial.
 Qed.

 Lemma PermutP_map : forall A B C (R:A -> C -> Prop) (f:B -> C) la lb,
  PermutP (fun a b => R a (f b)) la lb <->
  PermutP R la (map f lb).
 Proof.
  intros A B C R f la lb; split.
  induction 1; simpl.
  constructor.
  rewrite map_app; simpl; constructor; trivial.
  rewrite <- map_app; trivial.
  generalize la; clear la.
  induction lb; intros la H; simpl in H; inversion H; subst.
  constructor.
  destruct l1'; discriminate.
  destruct (PermutP_cons_r_inv H) as [b [lla [llb [W1 [W2 W3] ] ] ] ]; subst.
  rewrite W1.
  apply PermutP_sym; constructor; trivial.
  apply PermutP_sym; auto.
 Qed.

 Lemma PermutP_weaken : forall A B (R1 R2:A -> B -> Prop) la lb,
  (forall a b, In a la -> In b lb -> R1 a b -> R2 a b) ->
  PermutP R1 la lb -> PermutP R2 la lb.
 Proof.
  induction la; intros.
  (* base case *)
  inversion H0; constructor.
  (* inductive case *)
  induction lb; inversion H0; subst.
  elim (app_cons_not_nil l1' l2' x' (eq_sym H3)).
  apply permP_swap.
  apply H; auto using in_eq.
  rewrite <-H3; apply in_or_app; right; apply in_eq.
  apply IHla.
  intros; apply H; auto using in_cons, in_eq.
  rewrite <-H3; destruct (in_app_or _ _ _  H2);
  auto using in_or_app, in_cons.
  trivial.
 Qed.

 Lemma Permut_seq_R : forall (R:nat -> nat -> Prop) k a b,
  (forall i, 0 <= i < k -> R (i + a) (i + b)) ->
  PermutP R (seq a k) (seq b k).
 Proof.
  induction k; simpl; intros.
  constructor.
  apply PermutP_cons.
  refine (H 0 _); auto with arith.
  apply IHk; intros.
  repeat rewrite <- plus_n_Sm.
  refine (H (S i) _); omega.
 Qed.

 Lemma PermutP_seq_shift : forall n i1 i2 g ,
  PermutP (fun v1 v2 => v1 = g v2) (seq (S i1)  n) (seq (S i2) n) ->
  PermutP (fun v1 v2 => S v1 = g (S v2)) (seq i1 n) (seq i2 n).
 Proof.
  intros.
  rewrite (PermutP_map (fun v1 v2 => S v1 = g v2) S).
  apply PermutP_sym.
  apply PermutP_weaken with (fun v1 v2 => g v1 = S v2); [ auto | ].
  rewrite (PermutP_map (fun v1 v2 => g v1 = v2) S).
  rewrite seq_shift, seq_shift.
  apply PermutP_sym.
  apply PermutP_weaken with (fun v1 v2 => v1 = g v2); auto.
 Qed.

End PERMUTATION_PROP.

Section PERMUTP_BIJECTION.

 Variable T : Type.

 Variables f f_inv : T -> T.

 Lemma PermutP_NoDup : forall (l1:list T) (l2:list T),
  NoDup l1 ->
  NoDup l2 ->
  (forall x, In x l1 -> f (f_inv x) = x) ->
  (forall x, In x l2 -> f_inv (f x) = x) ->
  (forall x, In x l2 -> In (f x) l1) ->
  (forall x, In x l1 -> In (f_inv x) l2) ->
  PermutP (fun v1 v2 => v1 = f v2) l1 l2.
 Proof.
  induction l1; intros l2 H H0 f_inv_spec f_spec H1 H2.
  destruct l2.
  constructor.
  elim (H1 t); simpl; auto.
  destruct (In_split (f_inv a) l2) as (hd, (tl, H3)).
  apply H2; simpl; auto.

  subst; constructor.
  rewrite f_inv_spec; simpl; auto.

  inversion_clear H.
  apply IHl1; clear IHl1; trivial; intros.
  apply NoDup_remove_1 with (f_inv a); trivial.
  intros; apply f_inv_spec; simpl; auto.
  intros; apply f_spec.
  apply in_app_or in H; destruct H; apply in_or_app; simpl; auto.

  assert (In (f x) (a::l1)).
   apply H1; apply in_app_or in H; apply in_or_app; simpl; destruct H; auto.
  simpl in H5; destruct H5; trivial.
  elim (@NoDup_remove_2 _ _ _ _ H0); rewrite H5; rewrite f_spec; trivial.
  apply in_app_or in H.
  apply in_or_app; simpl; destruct H; auto.

  assert (H6:In (f_inv x) (hd ++ f_inv a :: tl)) by (apply H2; simpl; auto).
  apply in_or_app.
  destruct (in_app_or _ _ _ H6).
  auto.
  destruct H5; [ | auto].
  elim H3; clear H3.

  apply (f_equal f) in H5.
  rewrite f_inv_spec in H5; [ | simpl; auto].
  rewrite H5, f_inv_spec; simpl; auto.
 Qed.

End PERMUTP_BIJECTION.

(** Sequences *)

Lemma seq_append : forall k1 k2 n,
 seq n (k1 + k2) = seq n k1 ++ seq (n + k1) k2.
Proof.
 induction k1; simpl; intros.
 rewrite plus_0_r; trivial.
 rewrite <- plus_n_Sm, IHk1; trivial.
Qed.

Lemma seq_S : forall m n,
 seq n (S m) = seq n m ++ (n + m :: nil).
Proof.
 induction m; intros.
 rewrite plus_0_r; trivial.
 change (S (S m)) with (1 + (S m)).
 rewrite seq_append, IHm.
 replace (seq n (S m)) with (seq n 1 ++ seq (n + 1) m)
  by (rewrite IHm, <- seq_append, IHm; trivial).
 rewrite app_ass, <- plus_assoc; trivial.
Qed.

Lemma le_In_seq : forall n m i,
 m <= i < n + m ->
 In i (seq m n).
Proof.
 induction n; intros m i [Hge Hle].
 elimtype False; omega.

 case (le_lt_or_eq _ _ Hle); clear Hle; intro.
 change (S n) with (1 + n).
 rewrite seq_append.
 apply in_or_app.
 case (le_lt_or_eq _ _ Hge); clear Hge; intro.
 right.
 rewrite plus_comm.
 change (1 + m) with (S m).
 rewrite <- seq_shift.
 destruct i; [elim (lt_n_O _ H0) | ].
 apply in_map; apply IHn; omega.

 simpl; auto.

 simpl in H; injection H; intro.
 clear H Hge; subst.
 destruct n.
 simpl; auto.

 simpl plus.
 change (S (S n)) with (1 + (S n)).
 rewrite seq_append.
 rewrite (plus_comm m 1).
 change (1 + m) with (S m).
 rewrite <- seq_shift.
 apply in_or_app.

 right; simpl plus.
 apply in_map.
 apply IHn; omega.
Qed.

Lemma In_seq_le : forall n m i,
 In i (seq m n) ->
 m <= i < n + m.
Proof.
 induction n; intros m i Hi.
 elim Hi.
 simpl in Hi.
 case Hi; clear Hi; intro Hi.
 rewrite <- Hi; omega.
 rewrite <- seq_shift in Hi.
 rewrite in_map_iff in Hi.
 destruct Hi as [i0 [H1 H2] ].
 rewrite <- H1.
 generalize (IHn _ _ H2); omega.
Qed.

Lemma seq_PermutP : forall k p,
 p <= k ->
 PermutP (@eq _) (seq 0 k) (seq p (k - p) ++ seq 0 p).
Proof.
 intros k p H.
 pattern k at 1; replace k with (p + (k - p)); auto with arith.
 rewrite seq_append, plus_0_l.
 apply PermutP_app_comm.
Qed.

(** Sorted lists *)

Definition monotone (A B:Type) (R1:A -> A -> Prop) (R2:B -> B -> Prop) (f:A -> B) :=
 forall a1 a2, R1 a1 a2 -> R2 (f a1) (f a2).

Hint Unfold monotone.

Lemma sorted_map : forall (A B:Type) (R1:A -> A -> Prop) (R2:B -> B -> Prop) (f:A -> B)
 (l:list A),
 monotone R1 R2 f ->
 sort R1 l ->
 sort R2 (map f l).
Proof.
 induction l; intros; simpl.
 constructor.
 apply sort_inv in H0.
 constructor.
 firstorder.
 induction l; constructor.
 apply H.
 destruct H0 as [? H1].
 apply lelistA_inv in H1; trivial.
Qed.

Lemma lelistA_filter : forall (A:Type) (R:A -> A -> Prop) (P:A -> bool)
 (a:A) (l:list A),
 transitive A R ->
 sort R l ->
 lelistA R a l ->
 lelistA R a (filter P l).
Proof.
 induction l; intros.
 constructor.
 apply sort_inv in H0.
 apply lelistA_inv in H1.
 simpl; case (P a0).
 constructor; trivial.
 apply IHl.
 trivial.
 firstorder.
 destruct l.
 constructor.
 destruct H0.
 apply lelistA_inv in H2.
 constructor.
 apply H with a0; trivial.
Qed.

Lemma sorted_filter : forall (A:Type) (R:A -> A -> Prop) (P:A -> bool)
 (l:list A),
 transitive A R ->
 sort R l ->
 sort R (filter P l).
Proof.
 induction l; intros.
 constructor.
 apply sort_inv in H0; simpl; firstorder.
 case (P a); [ | trivial].
 constructor; trivial.
 apply lelistA_filter; trivial.
Qed.

Lemma sorted_cons : forall l a,
 sort lt l ->
 (forall b, In b l -> a < b) ->
 sort lt (a :: l).
Proof.
 induction l; intros; constructor.
 trivial.
 constructor.
 trivial.
 constructor.
 apply H0.
 apply in_eq.
Qed.

Lemma sorted_seq : forall n a, sort lt (seq a n).
Proof.
 induction n; simpl; intros.
 constructor.
 apply sorted_cons.
 trivial.
 intros.
 apply In_seq_le in H.
 omega.
Qed.

Lemma NoDup_seq : forall a b, NoDup (seq a b).
Proof.
 induction b.
 constructor.
 rewrite seq_S.
 apply NoDup_app with (1:=IHb).
 constructor; [intro H; elim H | constructor].
 intros x [H | H] Hin.
 subst; apply In_seq_le in Hin; omega.
 elim H.
Qed.

Lemma eqb_spec_beg A (a_beq : A -> A -> bool):
  (forall x : A,
    (fun x0 : A => forall y : A, a_beq x0 y = true -> x0 = y) x) ->
  (forall x : A,
    (fun x0 : A => forall y : A, x0 = y -> a_beq x0 y = true) x) ->
  (forall (x y : A), if a_beq x y then x = y else x <> y).
Proof.
 intros.
 case_eq (a_beq x y); intros.
 apply H; trivial.
 intro.
 rewrite (H0 x y H2) in H1.
 discriminate.
Qed.


(** * Complete partial orders and suprema/infima operators. *)

From Coq Require Import
  Basics
  PeanoNat
  Equivalence
  ClassicalChoice
  IndefiniteDescription (* for suprema/infima *)
  Lia
.

Local Open Scope program_scope.
Local Open Scope equiv_scope.

From algco Require Import
  axioms
  misc
  order
  tactics
.

Local Open Scope order_scope.

(** [A] is a CPO (complete partial order) when suprema of ω-chains
    exist. *)
Class CPO (A : Type) `{OType A} : Prop :=
  { exists_sup : forall f : nat -> A, directed f -> exists s, supremum s f }.

(** [A] is a lCPO (lower-complete partial order) when infima of
    decreasing ω-chains exist. *)
Class lCPO (A : Type) `{OType A} : Prop :=
  { exists_inf : forall f : nat -> A, downward_directed f -> exists s, infimum s f }.

(** [A] is a d-lattice when it has suprema and infima for all directed
    sets and downward-directed sets. *)
Class dLattice (A : Type) {o : OType A} `{@CPO A o} `{@lCPO A o} : Prop := {}.

(** Pointed lattice.  For convenience -- deviates slightly from
    standard definition of complete lattice by quantifying over only
    countable collections. Every pLattice is automatically a
    dLattice. *)
Class pLattice (A : Type) {o : OType A} {p : @PType _ o} : Prop := {
    lattice_exists_sup : forall f : nat -> A, exists s, supremum s f
  ; lattice_exists_inf : forall f : nat -> A, exists s, infimum s f
  }.

#[global]
  Instance pLattice_CPO {A} `{pLattice A} : CPO A.
Proof. firstorder. Qed.
#[global] Hint Resolve pLattice_CPO : order.

#[global]
  Instance pLattice_lCPO {A} `{pLattice A} : lCPO A.
Proof. firstorder. Qed.
#[global] Hint Resolve pLattice_lCPO : order.

#[global]
  Instance pLattice_wLattice {A} `{pLattice A} : dLattice A.
Qed.
#[global] Hint Resolve pLattice_wLattice : order.

Lemma ex_ex_supremum {A} `{OType A} (f : nat -> A) :
  exists x : A, (exists b : A, supremum b f) -> supremum x f.
Proof.
  destruct (classic (exists a, supremum a f)).
  - destruct H0 as [a Ha]; exists a; intros; auto.
  - exists (f O); intros [a Ha]; exfalso; apply H0; exists a; auto.
Qed.

(** Primitive non-constructive supremum operation for ordered type
    [A]. Given a countable collection [f] of elements of type [A],
    produce an element [a] such that [a] is the supremum of [f]
    whenever such a supremum provably exists. Derived from excluded
    middle + indefinite description. *)
Definition sup_prim {A} `{OType A} (f : nat -> A)
  : { a : A | (exists b, supremum b f) -> supremum a f } :=
  constructive_indefinite_description _ (ex_ex_supremum _).

Lemma ex_ex_infimum {A} `{OType A} (f : nat -> A) :
  exists x : A, (exists b : A, infimum b f) -> infimum x f.
Proof.
  destruct (classic (exists a, infimum a f)).
  - destruct H0 as [a Ha]; exists a; intros; auto.
  - exists (f O); intros [a Ha]; exfalso; apply H0; exists a; auto.
Qed.

(* See above. *)
Definition inf_prim {A} `{OType A} (f : nat -> A)
  : { a : A | (exists b, infimum b f) -> infimum a f } :=
  constructive_indefinite_description _ (ex_ex_infimum _).

(* Take the supremum of countable collection [f]. *)
Definition sup {A} `{OType A} (f : nat -> A) : A := proj1_sig (sup_prim f).

(* [sup f] is the supremum of [f] whenever [A] is a dCPO and [f] is
   a chain. *)
Lemma sup_spec {A} `{CPO A} (f : nat -> A) :
  directed f -> supremum (sup f) f.
Proof. intro Hf; unfold sup; destruct sup_prim; simpl; apply s, H0; auto. Qed.

Lemma lattice_sup_spec {A} `{pLattice A} (f : nat -> A) :
  supremum (sup f) f.
Proof. unfold sup; destruct sup_prim; simpl; apply s; firstorder. Qed.

(* Take the infimum of countable collection [f]. *)
Definition inf {A} `{OType A} (f : nat -> A) : A := proj1_sig (inf_prim f).

(* [inf f] is the infimum of [f] whenever [A] is an lCPO and [f] is
   downward-directed. *)
Lemma inf_spec {A} `{lCPO A} (f : nat -> A) :
  downward_directed f -> infimum (inf f) f.
Proof. intro Hf; unfold inf; destruct inf_prim; simpl; apply i, H0; auto. Qed.

Lemma lattice_inf_spec {A} `{pLattice A} (f : nat -> A) :
  infimum (inf f) f.
Proof. unfold inf; destruct inf_prim; simpl; apply i; firstorder. Qed.

#[global]
  Instance pLattice_arrow {A B} `{pLattice B} : pLattice (A -> B).
Proof.
  constructor; intro f.
  - exists (fun x => sup (fun i => f i x)).
    apply supremum_apply.
    intro a; apply lattice_sup_spec.
  - exists (fun x => inf (fun i => f i x)).
    apply infimum_apply.
    intro a; apply lattice_inf_spec.
Qed.
#[global] Hint Resolve pLattice_arrow : order.

(** [Prop] has suprema and infima. *)

(* #[global] *)
(*   Instance dCPO_Prop : dCPO Prop. *)
(* Proof. *)
(*   constructor; intro f; exists (exists i, f i); split. *)
(*   - intros i Hi; exists i; auto. *)
(*   - intros ub Hub [i Hi]; eapply Hub; eauto. *)
(* Qed. *)
(* #[global] Hint Resolve dCPO_Prop : order. *)

(* #[global] *)
(*   Instance lCPO_Prop : lCPO Prop. *)
(* Proof. *)
(*   constructor; intros f; exists (forall i, f i); split. *)
(*   - intros i Hi; auto. *)
(*   - intros ub Hub x i; apply Hub; auto. *)
(* Qed. *)
(* #[global] Hint Resolve lCPO_Prop : order. *)

(* #[global] *)
(*   Instance dLattice_Prop : dLattice Prop. Qed. *)
(* #[global] Hint Resolve dLattice_Prop : order. *)

#[global]
  Instance Lattice_Prop : pLattice Prop.
Proof.
  constructor; intro f.
  - exists (exists i, f i); split.
    + intros i Hi; exists i; auto.
    + intros ub Hub [i Hi]; eapply Hub; eauto.
  - exists (forall i, f i); split.
    + intros i Hi; auto.
    + intros ub Hub x i; apply Hub; auto.
Qed.
#[global] Hint Resolve Lattice_Prop : order.

(* #[global] *)
(*   Instance dCPO_bool : dCPO bool. *)
(* Proof. *)
(*   constructor; intro f. *)
(*   destruct (classic (exists i, f i = true)). *)
(*   - exists true; split. *)
(*     + intro i; simpl; unfold bool_le; destruct (f i); auto. *)
(*     + intros x Hx; destruct x; try reflexivity. *)
(*       destruct H as [i H]; specialize (Hx i). *)
(*       rewrite H in Hx; destruct Hx. *)
(*   - exists false; split. *)
(*     + intro i; destruct (f i) eqn:Hfi; try reflexivity. *)
(*       exfalso; apply H; exists i; auto. *)
(*     + intros x Hx; destruct x; reflexivity. *)
(* Qed. *)
(* #[global] Hint Resolve dCPO_bool : order. *)

(* #[global] *)
(*   Instance lCPO_bool : lCPO bool. *)
(* Proof. *)
(*   constructor; intro f. *)
(*   destruct (classic (exists i, f i = false)). *)
(*   - exists false; split. *)
(*     + intro i; simpl; unfold bool_le; destruct (f i); auto. *)
(*     + intros x Hx; destruct x; try reflexivity. *)
(*       destruct H as [i H]; specialize (Hx i). *)
(*       rewrite H in Hx; destruct Hx. *)
(*   - exists true; split. *)
(*     + intro i; destruct (f i) eqn:Hfi; try reflexivity. *)
(*       exfalso; apply H; exists i; auto. *)
(*     + intros x Hx; destruct x; reflexivity. *)
(* Qed. *)
(* #[global] Hint Resolve lCPO_bool : order. *)

(* #[global] *)
(*   Instance dLattice_bool : dLattice bool. Qed. *)
(* #[global] Hint Resolve dLattice_bool : order. *)

#[global]
  Instance Lattice_bool : pLattice bool.
Proof.
  constructor; intro f.
  - destruct (classic (exists i, f i = true)).
    + exists true; split.
      * intro i; simpl; unfold bool_le; destruct (f i); auto.
      * intros x Hx; destruct x; try reflexivity.
        destruct H as [i H]; specialize (Hx i).
        rewrite H in Hx; destruct Hx.
    + exists false; split.
      * intro i; destruct (f i) eqn:Hfi; try reflexivity.
        exfalso; apply H; exists i; auto.
      * intros x Hx; destruct x; reflexivity.
  - destruct (classic (exists i, f i = false)).
    + exists false; split.
      * intro i; simpl; unfold bool_le; destruct (f i); auto.
      * intros x Hx; destruct x; try reflexivity.
        destruct H as [i H]; specialize (Hx i).
        rewrite H in Hx; destruct Hx.
    + exists true; split.
      * intro i; destruct (f i) eqn:Hfi; try reflexivity.
        exfalso; apply H; exists i; auto.
      * intros x Hx; destruct x; reflexivity.
Qed.
#[global] Hint Resolve Lattice_Prop : order.

#[global]
  Instance lCPO_arrow {A B} `{lCPO B} : lCPO (A -> B).
Proof.
  constructor; intros f Hf.
  exists (fun x => inf (fun n => f n x)).
  assert (Hf': forall x, downward_directed (fun i => f i x)).
  { intros x j k.
    specialize (Hf j k); destruct Hf as [l [Hl Hl']].
    exists l; auto. }
  split.
  - intros i x; specialize (Hf' x).
    apply inf_spec in Hf'; apply Hf'.
  - intros g Hlb x.
    specialize (Hf' x).
    apply inf_spec in Hf'.
    apply Hf'; intro; apply Hlb.
Qed.

#[global]
  Instance CPO_arrow {A B} `{CPO B} : CPO (A -> B).
Proof.
  constructor; intros f Hf.
  exists (fun x => sup (fun n => f n x)).
  assert (Hf': forall x, directed (fun i => f i x)).
  { intros x j k.
    specialize (Hf j k); destruct Hf as [l [Hl Hl']].
    exists l; auto. }
  split.
  - intros i x; specialize (Hf' x).
    apply sup_spec in Hf'; apply Hf'.
  - intros g Hub x.
    specialize (Hf' x).
    apply sup_spec in Hf'.
    apply Hf'; intro; apply Hub.
Qed.

#[global]
  Instance CPO_prod {A B} `{CPO A} `{CPO B} : CPO (A * B).
Proof.
  constructor; intros ch Hch.
  destruct H0.
  specialize (exists_sup0 (fst ∘ ch) (directed_fst _ Hch)).
  destruct exists_sup0 as [a Ha].
  destruct H2.
  specialize (exists_sup0 (snd ∘ ch) (directed_snd _ Hch)).
  destruct exists_sup0 as [b Hb].
  exists (a, b); apply supremum_prod; auto.
Qed.

#[global]
  Instance CPO_sum {A B} `{CPO A} `{CPO B} : CPO (A + B).
Proof.
  constructor; intros ch Hch.
  destruct (classic (exists i a, ch i = inl a)) as [Ha|Ha].
  { destruct Ha as [i [a Ha]].
    set (ch_a := fun j => match (ch j) with
                       | inl x => x
                       | inr _ => a
                       end).
    assert (Hch_a: directed ch_a).
    { intros j k; specialize (Hch j k); destruct Hch as [z [Hiz Hjz]].
      unfold ch_a.
      exists z; split.
      - destruct (ch j) eqn:Hchj.
        + destruct (ch z) eqn:Hchz; auto; inv Hiz.
        + destruct (ch z) eqn:Hchz; try reflexivity; inv Hiz.
      - destruct (ch k) eqn:Hchk.
        + destruct (ch z) eqn:Hchz; auto; inv Hjz.
        + destruct (ch z) eqn:Hchz; try reflexivity; inv Hjz. }
    destruct H0; apply exists_sup0 in Hch_a; clear exists_sup0.
    destruct (classic (exists i b, ch i = inr b)).
    { destruct H0 as [j [b Hb]].
      specialize (Hch i j).
      destruct Hch as [k [Hik Hjk]].
      rewrite Ha in Hik.
      rewrite Hb in Hjk.
      destruct (ch k).
      - inv Hjk.
      - inv Hik. }
    destruct Hch_a as [x Hx].
    exists (inl x).
    destruct Hx as [Hub Hlub].
    split.
    - intro j.
      specialize (Hub j).
      unfold ch_a in Hub.
      destruct (ch j) eqn:Hchj; auto.
      exfalso; apply H0; exists j, b; auto.
    - intros [y|y] Hy.
      + apply Hlub; intro j; specialize (Hy j).
        unfold ch_a; destruct (ch j) eqn:Hchj; auto; inv Hy; simpl in *.
      + specialize (Hy i); rewrite Ha in Hy; inv Hy. }
  destruct (ch O) eqn:Hch0.
  { exfalso; apply Ha; exists O, a; auto. }
  set (ch_b := fun j => match (ch j) with
                     | inl _ => b
                     | inr y => y
                     end).
  assert (Hch_b: directed ch_b).
  { intros j k; specialize (Hch j k); destruct Hch as [z [Hiz Hjz]].
    unfold ch_b.
    exists z; split.
    - destruct (ch j) eqn:Hchj.
      + destruct (ch z) eqn:Hchz; try reflexivity; inv Hiz.
      + destruct (ch z) eqn:Hchz; auto; inv Hiz.
    - destruct (ch k) eqn:Hchk.
      + destruct (ch z) eqn:Hchz; try reflexivity; inv Hjz.
      + destruct (ch z) eqn:Hchz; auto; inv Hjz. }
  destruct H2; apply exists_sup0 in Hch_b; clear exists_sup0.
  destruct Hch_b as [y [Hub Hlub]].
  exists (inr y); split.
  - intro i; specialize (Hub i).
    unfold ch_b in Hub.
    destruct (ch i) eqn:Hchi; auto.
    destruct (Hch O i) as [k [HOk Hik]].
    rewrite Hch0 in HOk.
    rewrite Hchi in Hik.
    destruct (ch k).
    + inv HOk.
    + inv Hik.
  - intros x Hx.
    destruct x.
    + specialize (Hx O); rewrite Hch0 in Hx; inv Hx.
    + apply Hlub; intro i.
      specialize (Hx i).
      unfold ch_b.
      destruct (ch i); auto; inv Hx.
Qed.

Lemma le_sup {A} `{CPO A} (f : nat -> A) (a : A) (i : nat) :
  directed f ->
  a ⊑ f i ->
  a ⊑ sup f.
Proof.
  intros Hf Hleq.
  generalize (sup_spec f); intros [Hub Hlub]; auto.
  etransitivity; eauto.
Qed.

Lemma lattice_le_sup {A} `{pLattice A} (f : nat -> A) (a : A) (i : nat) :
  a ⊑ f i ->
  a ⊑ sup f.
Proof.
  intros Hleq.
  generalize (lattice_sup_spec f); intros [Hub Hlub]; auto.
  etransitivity; eauto.
Qed.

Lemma le_inf {A} `{lCPO A} (f : nat -> A) (a : A) :
  downward_directed f ->
  lower_bound a f ->
  a ⊑ inf f.
Proof.
  intros Hf Hbound; generalize (inf_spec f); intros [Hlb Hglb]; auto.
Qed.

Lemma lattice_le_inf {A} `{pLattice A} (f : nat -> A) (a : A) :
  lower_bound a f ->
  a ⊑ inf f.
Proof.
  intros Hbound; generalize (lattice_inf_spec f); intros [Hlb Hglb]; auto.
Qed.

Lemma ge_sup {A} `{CPO A} (f : nat -> A) (a : A) :
  directed f ->
  upper_bound a f ->
  sup f ⊑ a.
Proof.
  intros Hf Hbound; generalize (sup_spec f); intros [Hub Hlub]; auto.
Qed.

Lemma lattice_ge_sup {A} `{pLattice A} (f : nat -> A) (a : A) :
  upper_bound a f ->
  sup f ⊑ a.
Proof.
  intros Hbound; generalize (lattice_sup_spec f); intros [Hub Hlub]; auto.
Qed.

Lemma ge_inf {A} `{lCPO A} (f : nat -> A) (a : A) (i : nat) :
  downward_directed f ->
  f i ⊑ a ->
  inf f ⊑ a.
Proof.
  intros Hf Hleq.
  generalize (inf_spec f); intros [Hub Hlub]; auto.
  etransitivity; eauto.
Qed.

Lemma lattice_ge_inf {A} `{pLattice A} (f : nat -> A) (a : A) (i : nat) :
  f i ⊑ a ->
  inf f ⊑ a.
Proof.
  intros Hleq.
  generalize (lattice_inf_spec f); intros [Hub Hlub]; auto.
  etransitivity; eauto.
Qed.

Lemma supremum_sup {A} `{CPO A} (f : nat -> A) (a : A) :
  supremum a f ->
  sup f === a.
Proof.
  intros Hsup; eapply supremum_unique; eauto.
  unfold sup; destruct (sup_prim f); apply s; exists a; auto.
Qed.

Lemma infimum_inf {A} `{lCPO A} (f : nat -> A) (a : A) :
  infimum a f ->
  inf f === a.
Proof.
  intros Hinf; eapply infimum_unique; eauto.
  unfold inf; destruct (inf_prim f); apply i; exists a; auto.
Qed.

Lemma sup_apply {A B} `{CPO B} (f : nat -> A -> B) (x : A) :
  directed f ->
  sup f x === sup (fun i => f i x).
Proof.
  intro Hf; symmetry; apply supremum_sup, apply_supremum, sup_spec; auto.
Qed.

Lemma lattice_sup_apply {A B} `{pLattice B} (f : nat -> A -> B) (x : A) :
  sup f x === sup (fun i => f i x).
Proof.
  symmetry; apply supremum_sup, apply_supremum, lattice_sup_spec; auto.
Qed.

Lemma inf_apply {A B} `{lCPO B} (f : nat -> A -> B) (x : A) :
  downward_directed f ->
  inf f x === inf (fun i => f i x).
Proof.
  symmetry; apply infimum_inf; auto with order.
  apply apply_infimum, inf_spec; auto.
Qed.

Lemma lattice_inf_apply {A B} `{pLattice B} (f : nat -> A -> B) (x : A) :
  inf f x === inf (fun i => f i x).
Proof.
  symmetry; apply infimum_inf; auto with order.
  apply apply_infimum, lattice_inf_spec; auto.
Qed.

Lemma continuous_sup {A B} `{CPO A} `{CPO B} (f : A -> B) (ch : nat -> A) :
  continuous f ->
  directed ch ->
  f (sup ch) === sup (f ∘ ch).
Proof.
  intros Hf Hch; symmetry.
  apply supremum_sup, Hf; auto.
  apply sup_spec; auto.
Qed.

Lemma cocontinuous_sup {A B} `{CPO A} `{lCPO B} (f : A -> B) (ch : nat -> A) :
  cocontinuous f ->
  directed ch ->
  f (sup ch) === inf (f ∘ ch).
Proof.
  intros Hf Hch; symmetry.
  apply infimum_inf, Hf; auto.
  apply sup_spec; auto.
Qed.

Lemma wcontinuous_sup {A B} `{CPO A} `{CPO B} (f : A -> B) (ch : nat -> A) :
  wcontinuous f ->
  chain ch ->
  f (sup ch) === sup (f ∘ ch).
Proof.
  intros Hf Hch; symmetry.
  apply supremum_sup, Hf; auto.
  apply sup_spec; auto with order.
Qed.

Lemma dec_continuous_inf {A B} `{lCPO A} `{lCPO B} (f : A -> B) (ch : nat -> A) :
  dec_continuous f ->
  downward_directed ch ->
  f (inf ch) === inf (f ∘ ch).
Proof.
  intros Hf Hch; symmetry.
  apply infimum_inf, Hf; auto.
  apply inf_spec; auto.
Qed.

Lemma dec_cocontinuous_inf {A B} `{lCPO A} `{CPO B} (f : A -> B) (ch : nat -> A) :
  dec_cocontinuous f ->
  downward_directed ch ->
  f (inf ch) === sup (f ∘ ch).
Proof.
  intros Hf Hch; symmetry.
  apply supremum_sup, Hf; auto.
  apply inf_spec; auto.
Qed.

Lemma dec_wcontinuous_inf {A B} `{lCPO A} `{lCPO B} (f : A -> B) (ch : nat -> A) :
  dec_wcontinuous f ->
  dec_chain ch ->
  f (inf ch) === inf (f ∘ ch).
Proof.
  intros Hf Hch; symmetry.
  apply infimum_inf, Hf; auto.
  apply inf_spec; auto with order.
Qed.

Lemma Proper_sup {A} `{CPO A} (f g : nat -> A) :
  directed f ->
  directed g ->
  f === g ->
  sup f === sup g.
Proof.
  intros Hf Hg Hfg.
  eapply supremum_unique.
  - apply sup_spec; auto.
  - rewrite Hfg; apply sup_spec; auto.
Qed.

Lemma sup_shift {A} `{CPO A} (f : nat -> A) :
  chain f ->
  sup (shift f) === sup f.
Proof.
  intro Hf; apply supremum_sup; auto with order.
  apply supremum_shift; auto.
  apply sup_spec; auto with order.
Qed.

Lemma sup_shift' {A} `{CPO A} (f g : nat -> A) :
  chain f ->
  g === shift f ->
  sup f === sup g.
Proof.
  intros Hch Heq; subst.
  symmetry.
  apply supremum_sup.
  rewrite Heq; apply supremum_shift, sup_spec; auto with order.
Qed.

Lemma inf_shift' {A} `{lCPO A} (f g : nat -> A) :
  dec_chain f ->
  g === shift f ->
  inf f === inf g.
Proof.
  intros Hch Heq; subst.
  symmetry.
  apply infimum_inf.
  rewrite Heq; apply infimum_shift, inf_spec; auto with order.
Qed.

Lemma sup_intro (P : nat -> Prop) (i : nat) :
  directed P ->
  P i ->
  sup P.
Proof.
  intros Hdir HP.
  generalize (sup_spec _ Hdir); intros [Hub Hlub].
  eapply Hub; eauto.
Qed.

Lemma sup_elim (P : nat -> Prop) :
  directed P ->
  sup P ->
  exists i, P i.
Proof.
  intros Hdir HP.
  generalize (sup_spec _ Hdir); intros [Hub Hlub].
  apply Hlub; auto.
  intros i H'; exists i; apply H'.
Qed.

(** Compute the least fixed point of F by taking the supremum of the
    chain obtained by repeated iteration of F starting from z. *)
Definition iter {A} `{OType A} (F : A -> A) (z : A) : A :=
  sup (iter_n F z).

(** Compute the greatest fixed point of F by taking the infimum of the
    decreasing chain obtained by repeated iteration of F starting from z. *)
Definition dec_iter {A} `{OType A} (F : A -> A) (z : A) : A :=
  inf (iter_n F z).

(** [iter F z] is a fixed point of [F]. *)
Lemma iter_unfold {A} `{CPO A} (F : A -> A) (z : A) :
  wcontinuous F ->
  z ⊑ F z ->
  iter F z === F (iter F z).
Proof.
  unfold iter.
  intros HF Hle.
  assert (Hchain: chain (iter_n F z)).
  { apply chain_iter_n'; auto.
    apply wcontinuous_monotone; auto. }
  eapply wcontinuous_sup in HF.
  2: { eauto. }
  rewrite HF; clear HF Hle.
  unfold compose.
  apply sup_shift'; auto.
  apply equ_arrow; intro i; reflexivity.
Qed.

(** [dec_iter F z] is a fixed point of [F]. *)
Lemma dec_iter_unfold {A} `{lCPO A} (F : A -> A) (z : A) :
  dec_wcontinuous F ->
  F z ⊑ z ->
  dec_iter F z === F (dec_iter F z).
Proof.
  unfold dec_iter.
  intros HF Hle.
  assert (Hchain: dec_chain (iter_n F z)).
  { apply dec_chain_iter_n'; auto.
    apply dec_wcontinuous_monotone; auto. }
  eapply dec_wcontinuous_inf in HF; eauto.
  rewrite HF; clear HF Hle.
  unfold compose.
  apply inf_shift'; auto.
  apply equ_arrow; intro i; reflexivity.
Qed.

Lemma sup_apply_ext {A B} `{CPO B} {_ : ExtType B} (f : nat -> A -> B) (x : A) :
  directed f ->
  sup f x = sup (fun i => f i x).
Proof.
  intro Hf; symmetry; apply ext, supremum_sup, apply_supremum, sup_spec; auto.
Qed.

Lemma monotone_sup {A} `{CPO A} (f g : nat -> A) :
  directed f ->
  directed g ->
  (forall i, f i ⊑ g i) ->
  sup f ⊑ sup g.
Proof.
  intros Hf Hg Hfg; apply ge_sup; auto.
  intro i; etransitivity; eauto; apply sup_spec; auto.
Qed.

Lemma monotone_inf {A} `{lCPO A} (f g : nat -> A) :
  downward_directed f ->
  downward_directed g ->
  (forall i, f i ⊑ g i) ->
  inf f ⊑ inf g.
Proof.
  intros Hf Hg Hfg; apply le_inf; auto.
  intro i; etransitivity; eauto; apply inf_spec; auto.
Qed.

Lemma Proper_inf {A} `{lCPO A} (f g : nat -> A) :
  downward_directed f ->
  downward_directed g ->
  f === g ->
  inf f === inf g.
Proof.
  intros Hf Hg Hfg; split; apply monotone_inf; auto; intro i; apply Hfg.
Qed.

Lemma continuous_supP {A} `{CPO A} (f : A -> Prop) (ch : nat -> A) :
  continuous f ->
  directed ch ->
  f (sup ch) <-> sup (f ∘ ch).
Proof.
  intros Hf Hch.
  apply equ_iff, continuous_sup; auto.
Qed.

Lemma sup_const {A} `{CPO A} (a : A) :
  sup (fun _ => a) === a.
Proof.
  eapply supremum_unique.
  { apply sup_spec; auto with order. }
  apply supremum_const.
Qed.

Lemma sup_const' {A} `{CPO A} (f : nat -> A) (a : A) :
  f === const a ->
  sup f === a.
Proof.
  intro Hf.
  rewrite equ_arrow in Hf.
  unfold const in Hf.
  eapply supremum_unique.
  - apply sup_spec; intros ? j; exists j; split; rewrite !Hf; reflexivity.
  - apply supremum_const'; apply equ_arrow; intro i; apply Hf.
Qed.

Lemma sup_true_exists_i (f : nat -> bool) :
  sup f = true ->
  exists i, f i = true.
Proof.
  intro Hsup.
  contra H.
  assert (f = const false).
  { ext i; unfold const; apply not_ex_all_not with (n:=i) in H.
    destruct (f i); congruence. }
  subst.
  apply eq_equ in Hsup.
  unfold const in Hsup.
  rewrite sup_const in Hsup.
  apply ext in Hsup; congruence.
Qed.