(* ***************************************************************** *)
(*                                                                   *)
(* Released: 2020/05/29.                                             *)
(* Due: 2020/06/02, 23:59:59, CST.                                   *)
(*                                                                   *)
(* 0. Read instructions carefully before start writing your answer.  *)
(*                                                                   *)
(* 1. You should not add any hypotheses in this assignment.          *)
(*    Necessary ones have been provided for you.                     *)
(*                                                                   *)
(* 2. In order to check whether you have finished all tasks or not,  *)
(*    just see whether all "Admitted" has been replaced.             *)
(*                                                                   *)
(* 3. You should submit this file (Assignment9.v) on CANVAS.         *)
(*                                                                   *)
(* 4. Only valid Coq files are accepted. In other words, please      *)
(*    make sure that your file does not generate a Coq error. A      *)
(*    way to check that is: click "compile buffer" for this file     *)
(*    and see whether an "Assignment9.vo" file is generated.         *)
(*                                                                   *)
(* 5. Do not copy and paste others' answer.                          *)
(*                                                                   *)
(* 6. Using any theorems and/or tactics provided by Coq's standard   *)
(*    library is allowed in this assignment, if not specified.       *)
(*                                                                   *)
(* 7. When you finish, answer the following question:                *)
(*                                                                   *)
(*      Who did you discuss with when finishing this                 *)
(*      assignment? Your answer to this question will                *)
(*      NOT affect your grade.                                       *)
(*      (* FILL IN YOUR ANSWER HERE AS COMMENT *)                    *)
(*                                                                   *)
(* ***************************************************************** *)

Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import PL.ImpExt4.
Require Import PL.Lambda.

(* ################################################################# *)
(** * Task 1: Mix Typed Expressions *)

Module Task1.
Local Open Scope Z.

(** This is our definition of mix typed expressions. In this task, you need to
    answer questions about their evaluation process and type checking results. *)

Definition var: Type := nat.

Definition state: Type := var -> Z.

Inductive mexp : Type :=
  | MNum (n : Z)
  | MId (X : var)
  | MPlus (a1 a2 : mexp)
  | MMinus (a1 a2 : mexp)
  | MMult (a1 a2 : mexp)
  | MTrue
  | MFalse
  | MEq (a1 a2 : mexp)
  | MLe (a1 a2 : mexp)
  | MNot (b : mexp)
  | MAnd (b1 b2 : mexp)
.

(** Here is some coercion and notations for pretty printing. *)

Declare Scope mexp.
Delimit Scope mexp with mexp.
Local Open Scope mexp.

Coercion MNum : Z >-> mexp.
Coercion MId : var >-> mexp.
Notation "x + y" := (MPlus x y) (at level 50, left associativity) : mexp.
Notation "x - y" := (MMinus x y) (at level 50, left associativity) : mexp.
Notation "x * y" := (MMult x y) (at level 40, left associativity) : mexp.
Notation "x <= y" := (MLe x y) (at level 70, no associativity) : mexp.
Notation "x == y" := (MEq x y) (at level 70, no associativity) : mexp.
Notation "x && y" := (MAnd x y) (at level 40, left associativity) : mexp.
Notation "'!' b" := (MNot b) (at level 39, right associativity) : mexp.
Notation "[ x ; .. ; y ]" := (@cons mexp x .. (@cons mexp y (@nil mexp)) ..).

Module Task1_Examples.

Parameter X: var.
Parameter S: var.

(** Suppose [X] and [S] are program variables and [st: state] satisfies:

    - [st X = 0]

    - [st S = 0].

    Please describe the evaluation process of

    - [S + (X == 0)]

    on [st] using a Coq list. Specifically, this Coq list must demonstrate the
    result of every step (see lecture notes: run time error 2) from the
    beginning to the end. The ending expression can be a evaluation result (an
    integer constant or a boolean constant) or a stuck state (no step can be
    taken since an error occurs).
*)

Definition my_answer_1: list mexp :=
  [ S + (X == 0);
    0 + (X == 0);
    0 + (0 == 0);
    0 + MTrue;
    0 + 1;
    1 ]
.

(** Suppose [X] and [S] are program variables and [st: state] satisfies:

    - [st X = 0]

    - [st S = 0].

    Please describe the evaluation process of

    - [S && (X == 0)]

    on [st] using a Coq list. Specifically, this Coq list must demonstrate the
    result of every step (see lecture notes: run time error 2) from the
    beginning to the end. The ending expression can be a evaluation result (an
    integer constant or a boolean constant) or a stuck state (no step can be
    taken since an error occurs).
*)

Definition my_answer_2: list mexp :=
  [ S && (X == 0);
    0 && (X == 0) ]
.

End Task1_Examples.

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

Parameter P: var.
Parameter X: var.

(** Suppose [P] and [X] are program variables and [st: state] satisfies:

    - [st P = 0]

    - [st X = 1].

    Please describe the evaluation process of

    - [(P == 0) && (X && (X + 1))]

    on [st] using a Coq list. Specifically, this Coq list must demonstrate the
    result of every step (see lecture notes: run time error 2) from the
    beginning to the end. The ending expression can be a evaluation result (an
    integer constant or a boolean constant) or a stuck state (no step can be
    taken since an error occurs).
*)

Definition my_answer_1_1: list mexp :=
  [(P == 0) && (X && (X + 1));
   (0 == 0) && (X && (X + 1));
   MTrue && (X && (X + 1));
   X && (X + 1);
   1 && (X + 1)].
(** [] *)

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

(** This time, consider a slightly different situation. Suppose [st: state]
    satisfies:

    - [st P = 1]

    - [st X = 1].

    Please describe the evaluation process of

    - [(P == 0) && (X && (X + 1))]

    on [st] using a Coq list. Specifically, this Coq list must demonstrate the
    result of every step (see lecture notes: run time error 2) from the
    beginning to the end. The ending expression can be a evaluation result (an
    integer constant or a boolean constant) or a stuck state (no step can be
    taken since an error occurs).
*)

Definition my_answer_1_2: list mexp :=
  [(P == 0) && (X && (X + 1));
   (1 == 0) && (X && (X + 1));
   MFalse && (X && (X + 1));
   MFalse].
(** [] *)

(** **** Exercise: 1 star, standard  *)

(** Does [(P == 0) && (X && (X + 1))] type check?
    1. Yes. 2. No.
*)

Definition my_answer_1_3: Z := 2.
(** [] *)

(** **** Exercise: 1 star, standard  *)

(** Does [(P == 0) && (P == 1) && (X && (X + 1))] type check?
    1. Yes. 2. No.
*)

Definition my_answer_1_4: Z := 2.
(** [] *)

Import ListNotations.

(** **** Exercise: 1 star, standard  *)

(** Which of the following statements are correct about [mexp]'s small step
    semantics and type checking function?

    1. Its semantics is type safe since it has the progress property and
       the preservation property.

    2. Every legal expression (according the type checking function) can be
       evaluated safely to the end on any program state and the evaluation
       process will either end in an integer constant or a boolean constant.

    3. If an expression [m: mexp] can be safely evaluated on a state [st],
       then [m] must be a well-typed expression.

    4. If an expression [m: mexp] can be safely evaluated on any state [st],
       then [m] must be a well-typed expression.

    This is a multiple-choice problem. You should use an ascending Coq list to
    describe your answer, e.g. [1; 2; 3], [1; 3], [2]. *)

Definition my_answer_1_5: list Z := [1;2].
(** [] *)

End Task1.

(* ################################################################# *)
(** * Task 2: Lambda Expressions *)

Module Task2.
Import LambdaIB.
Local Open Scope Z.
Local Open Scope string.
Notation "[ x ; .. ; y ]" := (@cons tm x .. (@cons tm y (@nil tm)) ..).

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

(** Please describe the evaluation process of

    - [app
         (app
            (abs "f" (abs "x" (app "f" "x")))
            (abs "x" (app (app Omult "x") "x")))
         2].

    If writing this expression in python, it is:

    - [(lambda f: lambda x: f (x)) (lambda x: x * x) (2)].

*)

Definition process_2_1: list tm :=
  [app
     (app
        (abs "f" (abs "x" (app "f" "x")))
        (abs "x" (app (app Omult "x") "x")))
     2;
  (app
     (abs "x" (app (abs "x" (app (app Omult "x") "x")) "x"))
     2);
   app (abs "x" (app (app Omult "x") "x")) 2;
   app (app Omult 2) 2;
   4].

(** [] *)

(** **** Exercise: 1 star, standard  *)

(** Now you know the evaluation result is 4. Please prove it in Coq. *)

Example result_2_1:
  clos_refl_trans step
    (app
       (app (abs "f" (abs "x" (app "f" "x")))
            (abs "x" (app (app Omult "x") "x")))
       2)
    4.
Proof.
  etransitivity_1n.
  { apply S_app1. apply S_beta. constructor. }
  simpl subst. etransitivity_1n.
  { apply S_beta. constructor. }
  simpl subst. etransitivity_1n.
  { apply S_beta. constructor. }
  simpl subst. etransitivity_1n.
  { apply S_base. constructor. }
  reflexivity.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard  *)

(** We usually call [ abs "f" (abs "x" (app "f" "x")) ] the "apply" function. In
    other words, it APPLIES function "f" on "x". Please prove that it is
    well-typed. *)

Example type_2_1: forall T1 T2: ty,
  empty_context |-
    (abs "f" (abs "x" (app "f" "x"))) \in ((T1 ~> T2) ~> T1 ~> T2).
Proof.
  intros.
  apply T_abs.
  apply T_abs.
  eapply T_app;apply T_var;reflexivity.
Qed.

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

(** Please describe the evaluation process of

    - [app
         (abs "x"
            (app (app (app Oifthenelse (app (app Oeq "x") 0)) 0) 1))
         2].

    If writing this expression in Coq, it is like:

    - [ (fun x => if x ?= 0 then 0 else 1) 2 ].

*)

Definition process_2_2: list tm :=
  [app
     (abs "x"
        (app (app (app Oifthenelse (app (app Oeq "x") 0)) 0) 1))
     2;
   app (app (app Oifthenelse (app (app Oeq 2) 0)) 0) 1;
   app (app (app Oifthenelse false) 0) 1;
   1 ].
(** [] *)

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

(** In the example above, the function

    - [ abs "x" (app (app (app Oifthenelse (app (app Oeq "x") 0)) 0) 1) ]

    is usually called the "test_zero" function. If it applies to zero, the
    result is zero. If it applies to non-zero, the result is one. Of course,
    it has type [TInt ~> TInt]. But, if you write it in a wrong way, you can
    easily make it ill-typed. For example, the following expression writes:
    if "x" is non-zero, return false instead of one. This must cause a chaos
    in types.

    Hint: in order to prove the following property, you need to use [inversion]
    to trace back through the type derivation. You may use

    - [deduce_types_from_head]

    to speed up. But it will only solve parts, but not all, of the problem. *)

Lemma ill_typed_example: forall Gamma T,
  Gamma |-
    abs "x" (app (app (app Oifthenelse (app (app Oeq "x") 0)) 0) false) \in T ->
  False.
Proof.
  intros.
  inversion H;subst.
  deduce_types_from_head H4.
  inversion H3;subst.
  inversion H1;subst.
  inversion H5;subst.
  inversion H7.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard  *)

(** It is a nice property that the small step semantics of lambda expressions
    (as we introduced in lectures) are type safe. In other words, for any
    [t: tm] and [T: ty], if

    - [empty_context |- t \in T]

    then evaluating [t] must be safe. But, is the reverse direction also true?
    In other words, is there such an expression [t] that evaluating [t] is safe
    but no type [T] makes [empty_context |- t \in T] true.

    1. There exists such [t].

    2. There does not exist such [t]. *)

Definition my_choice: Z := 1.
(** [] *)

(** You should start your proof with either one of the following:

    - [ left; split; [reflexivity |] ]

    - [ right; reflexivity ]

*)

Lemma reverse_of_type_safe:
  (my_choice = 1 /\
   exists t t', clos_refl_trans step t t' /\ tm_halt t' /\
                (forall T, empty_context |- t \in T -> False)) \/
  (my_choice = 2).
Proof.
  left; split; [reflexivity |].
  exists (app
            (abs "x" (app (app (app Oifthenelse (app (app Oeq "x") 0)) 0) false))
            5), false.
  repeat split;[|constructor|].
  - etransitivity_1n.
    { apply S_beta. constructor. }
    simpl subst. etransitivity_1n.
    { apply S_app1. apply S_app1.
      apply S_app2. constructor.
      apply S_base. apply BS_eq_false. omega. }
    etransitivity_1n.
    { apply S_base. apply BS_if_false. }
    reflexivity.
  - intros. inversion H;subst.
    apply (ill_typed_example _ _ H3).
Qed.

End Task2.

(* Fri May 29 22:59:47 CST 2020 *)


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

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list utils_nat
                 fin_base.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

Set Implicit Arguments.

(* This files gathers all constructivelly valid choice principles *)

(* This is standart constructive strong choice, no finiteness assumptions here *)

Theorem constructive_choice X (T : X -> Type) (R : forall x, T x -> Prop) :
          (forall x, sig (R x))
       -> { f : forall x, T x | forall x, R x (f x) }.
Proof.
  intros f.
  exists (fun x => proj1_sig (f x)).
  intros x; apply (proj2_sig (f x)).
Qed.

Theorem constructive_choice' X Y (R : X -> Y -> Prop) :
          (forall x, sig (R x))
       -> { f | forall x, R x (f x) }.
Proof.
  apply constructive_choice.
Qed.

Theorem constructive_dep_choice X Y (P : X -> Prop) (R : X -> Y -> Prop) :
          (forall x, P x -> sig (R x))
       -> { f : forall x, P x -> Y | forall x Hx, R x (f x Hx) }.
Proof.
  intros f.
  exists (fun x Hx => proj1_sig (f x Hx)).
  intros x Hx; apply (proj2_sig (f x Hx)).
Qed.

Fact list_reif_t X Y (R : X -> Y -> Prop) l :
          (forall x, In x l -> sig (R x))
       -> { f | forall x (Hx : In x l), R x (f x Hx) }.
Proof. apply constructive_dep_choice. Qed.

Fact pos_reif_t X n (R : pos n -> X -> Prop) : (forall p, { x | R p x }) -> { f | forall p, R p (f p) }.
Proof. apply constructive_choice. Qed.

Fact vec_reif_t X n (R : pos n -> X -> Prop) : (forall p, sig (R p)) -> { v | forall p, R p (vec_pos v p) }.
Proof.
  intros H.
  apply pos_reif_t in H.
  destruct H as (f & Hf).
  exists (vec_set_pos f).
  intro; rewrite vec_pos_set; trivial.
Qed.

(* Now weak choice principles that assume some finiteness and discreteness *)

Section finite_discrete_choice.

  Variable (X Y : Type) (R : X -> Y -> Prop)
           (X_discrete : forall x y : X, { x = y } + { x <> y }).

  Theorem list_discrete_choice l :
            (forall x, In x l -> ex (R x))
         -> exists f, forall x (Hx : In x l), R x (f x Hx).
  Proof using X_discrete.
    induction l as [ | x l IHl ]; intros Hl.
    + exists (fun x (Hx : @In X x nil) => False_rect Y Hx).
      intros _ [].
    + destruct (Hl x) as (y & Hy); simpl; auto.
      destruct IHl as (f & Hf).
      * intros; apply Hl; simpl; auto.
      * assert (forall z, In z (x::l) -> x <> z -> In z l) as H1.
        { intros z [ -> | ] ?; tauto. }
        exists (fun z Hz =>
          match X_discrete x z with
            | left   _ => y
            | right  H => f z (H1 _ Hz H)
          end).
        intros z Hz.
        destruct (X_discrete x z); subst; auto.
  Qed.

  Fact finite_discrete_choice :
         finite X
      -> (forall x, ex (R x)) -> exists f, forall x, R x (f x).
  Proof using X_discrete.
    intros (l & Hl) H.
    destruct list_discrete_choice with (l := l) as (f & Hf); auto.
    exists (fun x => f x (Hl x)); auto.
  Qed.

End finite_discrete_choice.

Local Hint Resolve finite_t_pos finite_t_finite : core.

Fact pos_reification X n (R : pos n -> X -> Prop) : (forall p, exists x, R p x) -> exists f, forall p, R p (f p).
Proof.
  apply finite_discrete_choice; auto.
  apply pos_eq_dec.
Qed.

Notation pos_reif := pos_reification.

Fact vec_reif X n (R : pos n -> X -> Prop) : (forall p, ex (R p)) -> exists v, forall p, R p (vec_pos v p).
Proof.
  intros H.
  apply pos_reification in H.
  destruct H as (f & Hf).
  exists (vec_set_pos f).
  intro; rewrite vec_pos_set; trivial.
Qed.

Section finite_t_dec_choose_one.

  (* This compares to Constructive Epsilon but here over a finite type
      instead of nat *)

  Variable (X : Type) (P Q : X -> Prop)
           (HX : finite_t X)
           (HQ : fin_t Q)
           (Pdec : forall x, { P x } + { ~ P x }).

  Fact list_dec_choose_one l : (exists x, In x l /\ P x) -> { x | In x l /\ P x }.
  Proof using Pdec.
    clear HX Q HQ.
    induction l as [ | x l IHl ]; intros H.
    + exfalso; destruct H as (_ & [] & _).
    + destruct (Pdec x) as [ H1 | H1 ].
      * exists x; simpl; auto.
      * destruct IHl as (y & H2 & H3).
        - destruct H as (y & [ -> | Hy ] & ?); firstorder.
        - exists y; simpl; auto.
  Qed.

  Fact fin_t_dec_choose_one :
         (exists x, Q x /\ P x) -> { x | Q x /\ P x }.
  Proof using HQ Pdec.
    revert HQ; intros (l & Hl) H.
    destruct (list_dec_choose_one l) as (x & H1 & H2).
    + destruct H as (x & ? & ?); exists x; rewrite <- Hl; auto.
    + exists x; rewrite Hl; auto.
  Qed.

  Fact finite_t_dec_choose_one : ex P -> sig P.
  Proof using HX Pdec.
    clear Q HQ.
    revert HX; intros (l & Hl) H.
    destruct (list_dec_choose_one l) as (x & H1 & H2); firstorder.
  Qed.

End finite_t_dec_choose_one.

(* Reification of a total relation into a function,
    ie this is relational choice over a finite co-domain
    with a decidable relation *)

Definition finite_t_dec_choice X Y (R : X -> Y -> Prop) :
        finite_t Y
     -> (forall x y, { R x y } + { ~ R x y })
     -> (forall x, ex (R x))
     -> { f | forall x, R x (f x) }.
Proof.
  intros H2 H1 H3.
  exists (fun x => proj1_sig (finite_t_dec_choose_one H2 (H1 x) (H3 x))).
  intros x; apply (proj2_sig (finite_t_dec_choose_one H2 (H1 x) (H3 x))).
Qed.

Fact pos_dec_reif n (P : pos n -> Prop) (HP : forall p, { P p } + { ~ P p }) : ex P -> sig P.
Proof. apply finite_t_dec_choose_one; auto. Qed.

(* This is needed to reify a computable binary relation representing a unary function
    into an actual function *)

Fact pos_dec_rel2fun n (R : pos n -> pos n -> Prop) :
         (forall a b, { R a b } + { ~ R a b })
      -> (forall p, ex (R p)) -> { f | forall p, R p (f p) }.
Proof. apply finite_t_dec_choice; auto. Qed.


(* Author : Maciej Bendkowski <maciej.bendkowski@tcs.uj.edu.pl> *)
Section LambdaUpsilon.

Require Import Arith.
Require Import Omega.

(* binary trees *)
Inductive btree : Set :=
| Leaf
| Left  : btree -> btree
| Right : btree -> btree
| BNode : btree -> btree -> btree.

Hint Constructors btree.

(* natural size of btrees *)
Fixpoint btree_size (bt : btree) : nat :=
  match bt with
    | Leaf         => 1
    | Left t       => S (btree_size t)
    | Right t      => S (btree_size t)
    | BNode lt rt  => S (btree_size lt + btree_size rt)
  end.

(* de Bruijn indices *)
Inductive index : Set :=
| Z
| Succ : index -> index.

Hint Constructors index.

(* appropriate index <-> nat conversions *)
Fixpoint index_to_nat (idx : index) : nat :=
  match idx with
    | Z      => 0
    | Succ n => 1 + index_to_nat n
  end.

Fixpoint nat_to_index (n : nat) : index :=
  match n with
    | 0 => Z
    | S n' => Succ (nat_to_index n')
  end.

Lemma nat_index_inv : forall (n : nat),
  index_to_nat (nat_to_index n) = n.
Proof.
induction n.
- trivial.
- simpl; auto.
Qed.

(* natural size of indices *)
Fixpoint index_size (idx : index) : nat :=
  match idx with
    | Z      => 1
    | Succ n => S (index_size n)
  end.

(* The size of index n is n + 1 *)
Lemma index_size_conv : forall (n : nat),
  index_size (nat_to_index n) = S n.
Proof.
induction n.
- trivial.
- simpl; auto.
Qed.

(* lambda upsilon terms *)
Inductive term : Set :=
| Abs     : term -> term
| Index   : index -> term
| App     : term -> term -> term
| Closure : term -> subs -> term

with

(* explicit substitutions *)
subs : Set :=
| Lift   : subs -> subs
| Slash  : term -> subs
| Shift.

Hint Constructors term.
Hint Constructors subs.

(* natural size of terms *)
Fixpoint term_size (t : term) : nat :=
  match t with
    | Index idx   => index_size idx
    | Abs t'      => S (term_size t')
    | App lt rt   => S (term_size lt + term_size rt)
    | Closure t s => S (term_size t + subs_size s)
  end

with

(* natural size of substitutions *)
subs_size (s : subs) : nat :=
  match s with
    | Lift s' => S (subs_size s')
    | Slash t => S (term_size t)
    | Shift   => 1
  end.

(* auxiliary lifts helper *)
Fixpoint lifts (n : nat) (s : subs) : subs :=
  match n with
    | 0    => s
    | S n' => Lift (lifts n' s)
  end.

(* auxiliary lifts lemmas *)
Lemma lifts_size : forall (n : nat) (s : subs),
  subs_size (lifts n s) = n + subs_size s.
Proof.
induction n, s.
(* base cases *)
- simpl; trivial.
- simpl; trivial.
- simpl; trivial.
(* successor cases *)
- simpl; rewrite IHn; auto.
- simpl; rewrite IHn; auto.
- simpl; rewrite IHn; auto.
Qed.

Lemma lifts_ind : forall (n : nat) (s : subs),
  lifts (S n) s = lifts n (Lift s).
Proof.
induction n.
- intros. simpl. trivial.
- intros. simpl lifts. f_equal.
  rewrite <- IHn. simpl. trivial.
Qed.

Hint Resolve lifts_ind.

Lemma lifts_diff : forall (n : nat) (s : subs) (t : term),
  Lift (lifts n s) <> lifts n (Slash t).
Proof.
induction n.
- intros. simpl. discriminate.
- intros. simpl. injection; intros.
  specialize (IHn s t). injection H; intro.
  contradiction.
Qed.

(* lifts is injective *)
Lemma lifts_inj : forall (n : nat) (s s' : subs),
  lifts n s = lifts n s' -> s = s'.
Proof.
induction n.
- intros. simpl lifts in H. auto.
- intros. simpl lifts in H. injection H; intros.
  specialize (IHn s s'). auto.
Qed.

(* translation from btrees to terms *)
Fixpoint btree_to_term (bt : btree) : term :=
  match bt with
    | Leaf         => Index Z
    | Left t       => btree_to_term' 1 t
    | Right t      => Abs (btree_to_term t)
    | BNode lt rt  => App (btree_to_term lt) (btree_to_term rt)
  end

with

btree_to_term' (n : nat) (bt : btree) : term :=
  match bt with
    | Leaf         => Index (nat_to_index n)
    | Left t       => btree_to_term' (S n) t
    | Right t      => Closure (btree_to_term t) (lifts (n-1) Shift)
    | BNode lt rt  => Closure (btree_to_term rt) (lifts (n-1) (Slash (btree_to_term lt)))
  end.

(* translation preserves the structure size *)
Theorem size_prop : forall (bt : btree) (n : nat),
  term_size (btree_to_term bt) = btree_size bt /\
  term_size (btree_to_term' (S n) bt) = (S n) + btree_size bt.
Proof.
induction bt, n.
(* Leaf cases *)
- auto.
- split. auto.
  simpl. rewrite index_size_conv. omega.
(* Left cases *)
- simpl. split.
  apply IHbt. apply IHbt.
- simpl. split.
  apply IHbt.
  specialize (IHbt (S (S n))). omega.
(* Right cases *)
- simpl. specialize (IHbt 0).
  split. omega. omega.
- simpl. split. specialize (IHbt 0). omega.
  rewrite lifts_size. simpl. specialize (IHbt (n+1)). omega.
(* BNode cases *)
- simpl. split.
  specialize (IHbt1 0). specialize (IHbt2 0). omega.
  specialize (IHbt1 0). specialize (IHbt2 0). omega.
- simpl. split.
  specialize (IHbt1 0). specialize (IHbt2 0). omega.
  specialize (IHbt1 0). specialize (IHbt2 0).
  rewrite lifts_size. simpl. omega.
Qed.

(* structural invariant of btree_to_term' *)
Lemma btree_to_term'_inv : forall (bt : btree),
  (forall (n : nat),
    btree_to_term' (S n) bt = Index (nat_to_index (n + btree_size bt))) \/
  (forall (n : nat),
    exists t s, btree_to_term' (S n) bt = Closure t (lifts n s)).
Proof.
induction bt.
- left. intro. simpl.
  induction n.
    * auto.
    * simpl. injection IHn.
      intro. rewrite H. auto.
- destruct IHbt.
  * left. intro. simpl. rewrite H.
    f_equal. auto with zarith.
  * right. intro. simpl btree_to_term'.
    specialize (H (S n)).
    do 2 destruct H.
    exists x. exists (Lift x0).
    rewrite H. f_equal. eauto.
- repeat (destruct IHbt;
    right; intro; simpl;
    exists (btree_to_term bt);
    exists Shift;
    replace (n - 0) with n;
    trivial; omega).
- repeat (destruct IHbt1; destruct IHbt2;
    right; intro; simpl;
    exists (btree_to_term bt2);
    exists (Slash (btree_to_term bt1));
    replace (n - 0) with n;
    trivial; omega).
Qed.

(* auxiliary size lemmas *)
Lemma contrapositive: forall (P Q : Prop),
  (P -> Q) -> (~ Q -> ~ P).
Proof.
tauto.
Qed.

(* auxiliary proof arguments *)
Lemma diff_term_size : forall (t t' : term),
  term_size t <> term_size t' -> t <> t'.
Proof.
intros t t'.
apply contrapositive.
intro. rewrite H. trivial.
Qed.

Hint Resolve diff_term_size.

Lemma diff_subs_size : forall (s s' : subs),
  subs_size s <> subs_size s' -> s <> s'.
Proof.
intros s s'.
apply contrapositive.
intro. rewrite H. trivial.
Qed.

Hint Resolve diff_subs_size.

(* positive size lemmas *)
Lemma positive_btree_size : forall (bt : btree),
  btree_size bt > 0.
Proof.
repeat (induction bt;
        simpl; omega).
Qed.

Hint Resolve positive_btree_size.

Lemma positive_index_size : forall (i : index),
  index_size i > 0.
Proof.
intros.
repeat (destruct i;
        simpl; omega).
Qed.

Hint Resolve positive_index_size.

Lemma positive_term_size : forall (t : term),
  term_size t > 0.
Proof.
repeat (induction t;
        simpl; auto with arith).
Qed.

Hint Resolve positive_term_size.

(* additional structural invariants of btree_to_term' *)
Lemma btree_to_term'_abs : forall (bt bt' : btree) (n : nat),
  btree_to_term' (S n) bt <> Abs (btree_to_term bt').
Proof.
intros.
destruct (btree_to_term'_inv bt).
intuition. rewrite H in H0. discriminate H0.
intuition. specialize (H n). do 2 destruct H.
rewrite H in H0. discriminate H0.
Qed.

Lemma btree_to_term'_app : forall (bt bt' bt'' : btree) (n : nat),
  btree_to_term' (S n) bt <> App (btree_to_term bt') (btree_to_term bt'').
Proof.
intros.
destruct (btree_to_term'_inv bt).
intuition. rewrite H in H0. discriminate H0.
intuition. specialize (H n). do 2 destruct H.
rewrite H in H0. discriminate H0.
Qed.

Lemma btree_to_term'_left_right : forall (n : nat) (bt bt' : btree),
  btree_to_term' (S n) (Left bt) <> btree_to_term' (S n) (Right bt').
Proof.
intros. simpl.
destruct (btree_to_term'_inv bt).
rewrite (H (S n)). discriminate.
specialize (H (S n)). do 2 destruct H.
rewrite H. injection; intros.
destruct x0.
- apply (f_equal subs_size) in H1.
  simpl subs_size in H1.
  do 2 (rewrite lifts_size in H1).
  simpl subs_size in H1.
  omega.
- apply (f_equal subs_size) in H1.
  simpl subs_size in H1.
  do 2 (rewrite lifts_size in H1).
  simpl subs_size in H1.
  omega.
- injection H0; intros.
  apply (f_equal subs_size) in H3.
  simpl subs_size in H3.
  do 2 (rewrite lifts_size in H3).
  simpl subs_size in H3.
  omega.
Qed.

Lemma btree_to_term'_left_bnode : forall (n : nat) (bt bt'1 bt'2 : btree),
  btree_to_term' (S n) (Left bt) <> btree_to_term' (S n) (BNode bt'1 bt'2).
Proof.
intros. simpl.
destruct (btree_to_term'_inv bt).
rewrite (H (S n)). discriminate.
specialize (H (S n)). do 2 destruct H.
rewrite H. injection; intros.
contradict H1. replace (n-0) with n.
apply lifts_diff. omega.
Qed.

Lemma btree_to_term'_right_bnode : forall (n : nat) (bt bt'1 bt'2 : btree),
  btree_to_term' (S n) (Right bt) <> btree_to_term' (S n) (BNode bt'1 bt'2).
Proof.
intros. simpl.
injection; intros.
contradict H0. replace (n-0) with n.
apply diff_subs_size.
rewrite lifts_size. simpl.
rewrite lifts_size. simpl.
pose proof (positive_term_size (btree_to_term bt'1)).
omega. omega.
Qed.

(* main proof: translation is injective *)
Theorem injection_prop : forall (bt bt' : btree),
  (btree_to_term bt = btree_to_term bt' -> bt = bt') /\
  (forall (n : nat),
    btree_to_term' (S n) bt = btree_to_term' (S n) bt' -> bt = bt').
Proof.
induction bt.
(* Leaf cases *)
- intros. destruct bt'.
  * split. trivial.
    intro. trivial.
  * split.
      intro. contradict H. apply diff_term_size.
      simpl. pose proof (size_prop bt' 0) as H. destruct H.
      rewrite H0. pose proof (positive_btree_size bt'). omega.

      intros. contradict H. apply diff_term_size.
      simpl. rewrite index_size_conv.
      pose proof (size_prop bt' (S n)) as H. destruct H.
      rewrite H0. pose proof (positive_btree_size bt'). omega.
  * split.
      intro. contradict H. apply diff_term_size.
      simpl. pose proof (size_prop bt' 0) as H. destruct H.
      rewrite H. pose proof (positive_btree_size bt'). omega.

      intros. contradict H. apply diff_term_size.
      simpl. rewrite index_size_conv. rewrite lifts_size. simpl.
      pose proof (size_prop bt' 0) as H. destruct H.
      rewrite H. pose proof (positive_btree_size bt'). omega.
  * split.
      intro. contradict H. apply diff_term_size. simpl.
      pose proof (size_prop bt'1 0) as H1. destruct H1. rewrite H.
      pose proof (size_prop bt'2 0) as H2. destruct H2. rewrite H1.
      pose proof (positive_btree_size bt'1).
      pose proof (positive_btree_size bt'2).
      omega.

      intros. contradict H. apply diff_term_size.
      simpl. rewrite index_size_conv. rewrite lifts_size. simpl.
      pose proof (size_prop bt'1 0) as H1. destruct H1. rewrite H.
      pose proof (size_prop bt'2 0) as H2. destruct H2. rewrite H1.
      pose proof (positive_btree_size bt'1).
      pose proof (positive_btree_size bt'2).
      omega.
(* Left cases *)
- intros. destruct bt'.
  * split.
    intro. contradict H. apply diff_term_size. simpl.
    pose proof (size_prop bt 0) as H. destruct H.
    rewrite H0. pose proof (positive_btree_size bt). omega.

    intros. simpl btree_to_term' in H at 1.
    apply (f_equal term_size) in H.
    pose proof (size_prop bt (S n)) as P. destruct P.
    rewrite H in H1.
    simpl btree_to_term' in H1.
    simpl term_size in H1.
    rewrite index_size_conv in H1.
    contradict H1. pose proof (positive_btree_size bt).
    omega.
  * split.  (* both are Left *)
    intros. simpl btree_to_term in H.
    specialize (IHbt bt'). destruct IHbt.
    specialize (H1 0). cut (bt = bt').
    intros. apply (f_equal Left) in H2. auto. auto.

    intros. simpl btree_to_term' in H.
    specialize (IHbt bt'). destruct IHbt.
    specialize (H1 (S n)). cut (bt = bt').
    intros. apply (f_equal Left) in H2. auto. auto.
  * split.
    intros. simpl btree_to_term in H.
    contradict H. apply btree_to_term'_abs.

    intros.
    pose proof (btree_to_term'_left_right n bt bt').
    contradiction.
  * split.
    intros. simpl btree_to_term in H.
    contradict H. apply btree_to_term'_app.

    intros.
    pose proof (btree_to_term'_left_bnode n bt bt'1 bt'2).
    contradiction.
(* Right cases *)
- intros. destruct bt'.
  * split.
    intro. contradict H. apply diff_term_size. simpl.
    pose proof (size_prop bt 0) as H. destruct H.
    rewrite H. pose proof (positive_btree_size bt). omega.

    intros. simpl btree_to_term' in H.
    discriminate H.
  * split.
    intros. symmetry in H. simpl btree_to_term in H.
    contradict H. apply btree_to_term'_abs.

    intros.
    pose proof (btree_to_term'_left_right n bt' bt).
    symmetry in H. contradiction.
  * split. (* both are Right *)
    intros. simpl btree_to_term in H.
    specialize (IHbt bt'). destruct IHbt. cut (bt = bt').
    intros. apply (f_equal Right) in H2. auto. injection H. auto.

    intros. simpl btree_to_term' in H.
    specialize (IHbt bt'). destruct IHbt.
    specialize (H1 (S n)). cut (bt = bt').
    intros. apply (f_equal Right) in H2. auto.
    injection H. auto.
  * split.
    intros. simpl btree_to_term in H.
    discriminate H.

    intros.
    pose proof (btree_to_term'_right_bnode n bt bt'1 bt'2).
    contradiction.
(* BNode cases *)
- intros. split.
  * intros. simpl btree_to_term in H. destruct bt'.
    + simpl btree_to_term in H. discriminate H.
    + simpl btree_to_term in H.
      pose proof (btree_to_term'_app bt' bt1 bt2 0).
      symmetry in H. contradiction.
    + simpl btree_to_term in H. discriminate H.
    + simpl btree_to_term in H. injection H. intros.
      specialize (IHbt1 bt'1). destruct IHbt1.
      specialize (IHbt2 bt'2). destruct IHbt2.
      assert (bt1 = bt'1). auto.
      assert (bt2 = bt'2). auto.
      f_equal. auto. auto.
  * intros. destruct bt'.
    + simpl btree_to_term' in H. discriminate H.
    + symmetry in H.
      pose proof (btree_to_term'_left_bnode n bt' bt1 bt2).
      contradiction.
    + symmetry in H.
      pose proof (btree_to_term'_right_bnode n bt' bt1 bt2).
      contradiction.
    + simpl btree_to_term' in H. (* both are BNode *)
      injection H; intros.
      specialize (IHbt2 bt'2). destruct IHbt2.
      replace (n-0) with n in H0.
      apply lifts_inj in H0.
      injection H0; intros.
      specialize (IHbt1 bt'1). destruct IHbt1.
      f_equal. auto. auto.
      omega.
Qed.

End LambdaUpsilon.

Extraction Language Haskell.
Extraction "LambdaUpsilonCert.hs" btree_to_term.


Load monoids_and_groups.
Open Scope nat_scope.

(* The inclusion of natural numbers in integers *)
Definition nat_to_int : nat -> Int.
Proof.
  intro n.
  destruct n.
  - exact Int.zero.
  - apply pos.
    induction n.
    + exact Int.one.
    + exact (Int.succ_pos IHn).
Defined.

(* The inclusion preserves sum *)
Definition nat_to_int_succ : forall m : nat, nat_to_int (m.+1) = succ_int (nat_to_int m).
Proof.
  destruct m; reflexivity.
Defined.

(* succ_int and pred_int are inverses *)
Definition Int_succ_pred : forall a : Int, succ_int (pred_int a) = a.
Proof.
  induction a; try induction p; try reflexivity.
Defined.

Definition Int_pred_succ : forall a : Int, pred_int (succ_int a) = a.
Proof.
  destruct a; try destruct p; try reflexivity.
Defined.

(* Multiplying with -1 *)
Definition Int_minus (a : Int) : Int :=
  match a with
  |neg p => pos p
  |Int.zero => Int.zero
  |pos p => neg p
  end.

(* Int_minus is its own inverse *)
Definition Int_minus_minus (a : Int) : Int_minus (Int_minus a) = a.
Proof.
  destruct a; reflexivity.
Defined.

(* Successor of minus is minus of predecessor *)
Definition Int_succ_minus (a : Int) : succ_int (Int_minus a) = Int_minus (pred_int a).
Proof.
  destruct a; try destruct p; try reflexivity.
Defined.

(* (* Add a positive integer to an integer *) *)
(* Fixpoint Int_sum_pos (p : Pos) : Int -> Int. *)
(*   destruct p. *)
(*   - exact succ_int. *)
(*   - exact (succ_int o (Int_sum_pos p)). *)
(* Defined. *)

(* Sum of two integers *)
Definition Int_sum (a : Int) : Int -> Int.
Proof.
  destruct a.
  (* a is negative *)
  - induction p.
    + exact pred_int.           (* -1 + n *)
    + exact (pred_int o IHp). (* (-1-p) + n = -1 + (-p + n) *)
  (* a is zero *)
  - exact idmap.
  (* a is positive *)
  - induction p.
    + exact succ_int.           (* 1+n *)
    + exact (succ_int o IHp). (* (1+p) + n = 1 + (p+n) *)
Defined.

(* Sum of two positive integers *)
Fixpoint pos_sum (p : Pos) : Pos -> Pos.
Proof.
  destruct p.
  + exact succ_pos.
  + exact (succ_pos o (pos_sum p)).
Defined.

(* Sum of positives is positive *)
Lemma Int_sum_pos (p q : Pos) : Int_sum (pos p) (pos q) = pos (pos_sum p q).
Proof.
  induction p.
  - reflexivity.
  - change (Int_sum (pos (succ_pos p)) (pos q)) with (succ_int (Int_sum (pos p) (pos q))).
    rewrite IHp. reflexivity.
Qed.

(* Sum of negatives are negative *)
Lemma int_sum_neg (p q : Pos) : Int_sum (neg p) (neg q) = neg (pos_sum p q).
Proof.
  induction p.
  - reflexivity.
  - change (Int_sum (neg (succ_pos p)) (neg q)) with (pred_int (Int_sum (neg p) (neg q))).
    rewrite IHp. reflexivity.
Qed.

(* Sum preserves mines *)
Lemma Int_sum_minus (a b: Int) : Int_sum (Int_minus a) (Int_minus b) = Int_minus (Int_sum a b).
Proof.
  destruct a; destruct b; try reflexivity.
  - rewrite int_sum_neg. apply Int_sum_pos.
  -
    + apply Int_succ_minus.
    + intro b. admit.
  - reflexivity.
  -

  simpl.

  unfold Int_minus. simpl.

  simpl.
  destruct a,b; try reflexivity. simpl.

(* Sum preserves successor (in first variable) *)
Definition Int_sum_succ : forall a b : Int, Int_sum (succ_int a) b = succ_int (Int_sum a b).
Proof.
  intros a b.
  destruct a.
  (* a is negative *)
  - destruct p.
    + simpl. apply inverse. apply Int_succ_pred.
    + (* change (neg (succ_pos p)) with (pred_int (neg p)). *)
      rewrite (Int_succ_pred (neg p)).

    (* rewrite Int_succ_minus. rewrite Int_pred_succ. rewrite Int_minus_minus. reflexivity. *)
    (* simpl. rewrite Int_succ_minus. rewrite Int_pred_succ. reflexivity. *) admit.
  (* a is zero *)
  - reflexivity.
  - reflexivity.
Qed.

(* The inclusion [nat -> Integer] preserves sum *)
Definition ishom_nat_to_int : forall m n : nat, nat_to_int (m + n) = Int_sum (nat_to_int m) (nat_to_int n).
Proof.
  intros m n.
  induction m; try reflexivity.
  rewrite nat_to_int_succ. transitivity (succ_int (nat_to_int (m+n))).
  { apply nat_to_int_succ. }
  rewrite Int_sum_succ. exact (ap succ_int IHm).
Qed.

(* Sum of integers is associative *)
Definition Int_sum_assoc : associative Int_sum.
Proof.
  intros a b c.
  destruct a.
  - simpl. admit.               (* a is negative *)
  - reflexivity.                (* a is zero *)
  - simpl. induction p.
    simpl. apply inverse. apply Int_sum_succ.
    simpl.

    induction a.
  (* a is negative *)
  - admit. (* induction p. *)
  (* (* a is -1 *) *)
  (* + simpl. *)
  (*   induction b as [q | q | q]; try reflexivity. *)
  (*   (* b is positive *) *)
  (*   * induction q. *)
  (*     (* b is 1 *) *)
  (*     { simpl. induction c; try reflexivity. induction p; reflexivity. } *)
  (*     (* b is q+1 *) *)
  (*     { simpl.  } *)

  (* a is zero *)
  - reflexivity.
  (* a is positive *)
  - induction p.
    simpl.  Admitted.


(** * Algebraic CPOs, comorphisms, and their proof principles. *)

From Coq Require Import
  Basics
  Morphisms
  Equivalence
.

Local Open Scope program_scope.
Local Open Scope equiv_scope.

From algco Require Import
  axioms
  cpo
  order
  tactics
.

Local Open Scope order_scope.

Create HintDb aCPO.

(** The reason we don't use sigma types for monotone and continuous
    functions is that you have to use weird syntax for function
    application. Besides that, it would be pretty cool I think.. maybe
    still worth it? *)

(** Just as the continuous functions are the approximable functions,
    the (co)continuous properties are the approximable properties. A
    continuous property is true globally whenever it is true locally
    *somewhere*. A cocontinuous property is true globally whenever it
    is true locally *everywhere*. *)

Definition compact {A} `{OType A} (x : A) : Prop :=
  forall f : nat -> A, directed f -> supremum x f -> exists i, f i === x.

(** A space [A] is compact whenever none of its elements can be
    non-trivially approximated. *)
Class Compact (A : Type) `{OType A} : Prop :=
  { compact_spec : forall x : A, compact x }.

(** [B] is dense in [A] when there is an injective inclusion map and a
    way to map an element [a : A] to a chain of elements of [B] that
    converges to [a] (through the inclusion map). *)
Class Dense (A B : Type) `{OType A} `{OType B} : Type :=
  { incl : B -> A
  ; ideal : A -> nat -> B
  }.

(** A is a CPO with basis B (B is compact and dense in A). *)
Class aCPO (A B : Type) `{oA : OType A} `{oB : OType B}
  { compact : Compact B} {dense : Dense A B} {cpoA : CPO A} : Prop :=
  { incl_order : forall x y : B, x ⊑ y <-> incl x ⊑ incl y
  ; chain_ideal : forall a : A, chain (ideal a)
  ; monotone_ideal : monotone (@ideal _ _ _ _ dense)
  ; continuous_ideal : forall n, continuous (flip (@ideal _ _ _ _ dense) n)
  ; supremum_ideal : forall a : A, supremum a (incl ∘ ideal a)
  }.

#[global] Hint Resolve chain_ideal : aCPO.

#[global]
  Instance Compact_bool : Compact bool.
Proof.
  constructor; intros [] f Hf Ha.
  - contra HC.
    assert (upper_bound false f).
    { intro i.
      destruct (f i) eqn:Hfi.
      - exfalso; apply HC; exists i; rewrite Hfi; reflexivity.
      - constructor. }
    apply Ha in H; inv H.
  - exists O; split.
    + apply Ha.
    + constructor.
Qed.

(** Any monotone function on a compact space is continuous. *)
Lemma continuous_compact {A B} `{Compact A} `{OType B} (f : A -> B) :
  monotone f ->
  continuous f.
Proof.
  intros Hmono ch Hch x Hx; unfold compose.
  destruct H0 as [H0].
  split.
  - intro i; apply Hmono, Hx.
  - intros ub Hub.
    specialize (H0 x ch Hch Hx).
    destruct H0 as [i Hi].
    unfold monotone in Hmono.
    rewrite <- Hi.
    apply Hub.
Qed.
#[global] Hint Resolve continuous_compact : aCPO.

(** Any antimonotone function on a compact space is cocontinuous. *)
Lemma cocontinuous_compact {A B} `{Compact A} `{OType B} (f : A -> B) :
  antimonotone f ->
  cocontinuous f.
Proof.
  intros Hmono ch Hch x Hx; unfold compose.
  destruct H0 as [H0].
  split.
  - intro i; apply Hmono, Hx.
  - intros ub Hub.
    specialize (H0 x ch Hch Hx).
    destruct H0 as [i Hi].
    unfold antimonotone in Hmono.
    rewrite <- Hi.
    apply Hub.
Qed.
#[global] Hint Resolve cocontinuous_compact : aCPO.

(** Shorthand for referring to the basis of an aCPO. *)
Definition basis (A : Type) {B : Type} `{aCPO A B} : Type := B.
#[global] Hint Transparent basis : aCPO.

Section aCPO.
  Context {A B : Type} `{aCPO A B}.

  (** Continuous comorphism. *)
  Definition co {C} `{OType C} (f : basis A -> C) (a : A) : C :=
    sup (f ∘ ideal a).

  (** Need decreasing version of ideal for this. *)
  (* Definition dec_co {C} `{OType C} (f : basis A -> C) (a : A) : C := *)
  (*   inf (f ∘ ideal a). *)

  (** Co-continuous comorphism. *)
  Definition coop {C} `{OType C} (f : basis A -> C) (a : A) : C :=
    inf (f ∘ ideal a).

  Lemma chain_f_ideal {C} `{OType C} (f : basis A -> C) (a : A) :
    monotone f ->
    chain (fun i => f (ideal a i)).
  Proof. intro Hf; apply monotone_chain; auto; apply chain_ideal. Qed.

  Lemma dec_chain_f_ideal {C} `{OType C} (f : basis A -> C) (a : A) :
    antimonotone f ->
    dec_chain (fun i => f (ideal a i)).
  Proof. intro Hf; apply antimonotone_dec_chain; auto; apply chain_ideal. Qed.

  Lemma directed_f_ideal {C} `{OType C} (f : basis A -> C) (a : A) :
    monotone f ->
    directed (fun i => f (ideal a i)).
  Proof.
    intro Hf.
    apply monotone_directed; auto.
    apply chain_directed, chain_ideal.
  Qed.
  Hint Resolve directed_f_ideal : aCPO.

  Lemma downward_directed_f_ideal {C} `{OType C} (f : basis A -> C) (a : A) :
    antimonotone f ->
    downward_directed (fun i => f (ideal a i)).
  Proof.
    intro Hf.
    apply antimonotone_downward_directed; auto.
    apply chain_directed, chain_ideal.
  Qed.

  Lemma supremum_ideal_incl (b : basis A) :
    supremum b (ideal (incl b)).
  Proof.
    unfold basis in *.
    destruct H as [Hincl ? ? ? Hsup].
    specialize (Hsup (incl b)); destruct Hsup as [Hub Hlub].
    split.
    - intro i.
      specialize (Hub i); unfold compose in Hub.
      apply Hincl; auto.
    - intros x Hx.
      apply Hincl.
      apply Hlub.
      intro i; unfold compose.
      apply Hincl; auto.
  Qed.

  Lemma ideal_incl_le a i :
    ideal (incl a) i ⊑ a.
  Proof.
    generalize (supremum_ideal_incl a); intros [Hub ?]; apply Hub.
  Qed.

  Lemma incl_ideal_le (a : A) i :
    incl (ideal a i) ⊑ a.
  Proof.
    destruct H.
    specialize (supremum_ideal0 a).
    destruct supremum_ideal0 as [Hub Hlub].
    apply Hub.
  Qed.

  (** [co f] is the unique morphism (continuous function) satisfying
      this equation. [co f] is equal to f on all basis elements for
      which f was originally defined. *)
  Theorem co_incl {C} `{CPO C} (f : basis A -> C) :
    monotone f ->
    co f ∘ incl === f.
  Proof.
    intro Hmono.
    apply equ_arrow; intro b.
    unfold co, compose.
    apply supremum_sup.
    apply continuous_compact; auto.
    - apply chain_directed, chain_ideal.
    - apply supremum_ideal_incl.
  Qed.

  (** Pointwise variant. *)
  Corollary co_incl' {C} `{CPO C} (f : basis A -> C) (b : basis A) :
    monotone f ->
    co f (incl b) === f b.
  Proof. intro Hmono; revert b; apply equ_arrow, co_incl; auto. Qed.

  (** Pointwise variant. *)
  Corollary co_incl'_ext {C} `{o : OType C} `{@CPO C o} `{@ExtType C o}
    (f : basis A -> C) (b : basis A) :
    monotone f ->
    co f (incl b) = f b.
  Proof. intro Hf; apply ext, co_incl'; auto. Qed.

  (** [coop f] is the unique morphism (continuous function) satisfying
      this equation. [coop f] is equal to f on all basis elements for
      which f was originally defined. *)
  Theorem coop_incl {C} `{lCPO C} (f : basis A -> C) :
    antimonotone f ->
    coop f ∘ incl === f.
  Proof.
    intro Hmono.
    apply equ_arrow; intro b.
    unfold coop, compose.
    apply infimum_inf.
    apply cocontinuous_compact; auto.
    - apply chain_directed, chain_ideal.
    - apply supremum_ideal_incl.
  Qed.

  (** Pointwise variant. *)
  Corollary coop_incl' {C} `{lCPO C} (f : basis A -> C) (b : basis A) :
    antimonotone f ->
    coop f (incl b) === f b.
  Proof. intro Hmono; revert b; apply equ_arrow, coop_incl; auto. Qed.

  (** The co-version of any monotone basis function is monotone. *)
  #[global]
    Instance monotone_co {C} `{CPO C}
    (f : basis A -> C) {_ : Proper (leq ==> leq) f}
    : Proper (leq ==> leq) (co f).
  Proof.
    intros a b Hab.
    apply ge_sup.
    { apply directed_f_ideal; auto. }
    intro i.
    apply le_sup with i.
    { apply directed_f_ideal; auto. }
    apply H2, monotone_ideal; auto.
  Qed.
  Hint Resolve monotone_co : aCPO.

  (** The coop-version of any antimonotone basis function is antimonotone. *)
  #[global]
    Instance antimonotone_coop {C} `{lCPO C}
    (f : basis A -> C) {_ : Proper (leq ==> flip leq) f}
    : Proper (leq ==> flip leq) (coop f).
  Proof.
    intros a b Hab.
    unfold flip.
    unfold co.
    eapply monotone_inf.
    { apply downward_directed_f_ideal; auto. }
    { apply downward_directed_f_ideal; auto. }
    intro i; apply H2, monotone_ideal; auto.
  Qed.
  Hint Resolve antimonotone_coop : aCPO.

  (** The approximate co-version of any monotone basis function is continuous. *)
  Lemma continuous_f_ideal {C} `{OType C} (f : basis A -> C) (n : nat) :
    monotone f ->
    continuous (f ∘ flip ideal n).
  Proof.
    intro Hmono.
    apply continuous_compose.
    - apply continuous_ideal.
    - apply continuous_compact; auto.
  Qed.

  (** The approximate co-version of any antimonotone basis function is cocontinuous. *)
  Lemma cocontinuous_f_ideal {C} `{OType C} (f : basis A -> C) (n : nat) :
    antimonotone f ->
    cocontinuous (f ∘ flip ideal n).
  Proof.
    intro Hmono.
    apply continuous_cocontinuous_compose.
    - apply continuous_ideal.
    - apply cocontinuous_compact; auto.
  Qed.

  (** The co-version of any monotone basis function is continuous. *)
  Theorem continuous_co {C} `{CPO C} (f : B -> C) :
    monotone f ->
    continuous (co f).
  Proof.
    intros Hmono ch Hch t Hsup; unfold compose; split.
    - intro i; apply monotone_co; auto; apply Hsup.
    - intros x Hx.
      apply ge_sup.
      { apply directed_f_ideal; auto. }
      intro i.
      eapply continuous_f_ideal; eauto.
      unfold flip, compose; intro j; specialize (Hx j).
      etransitivity; eauto.
      generalize (sup_spec (fun x0 : nat => f (ideal (ch j) x0))).
      intro Hwsup.
      assert (Hch': directed (fun x0 : nat => f (ideal (ch j) x0))).
      { apply directed_f_ideal; auto. }
      apply Hwsup in Hch'.
      destruct Hch' as [Hub Hlub].
      apply Hub.
  Qed.
  Hint Resolve continuous_co : aCPO.

  (** The coop-version of any antimonotone basis function is cocontinuous. *)
  Theorem cocontinuous_coop {C} `{lCPO C} (f : basis A -> C) :
    antimonotone f ->
    cocontinuous (coop f).
  Proof.
    intros Hmono ch Hch t Hsup; unfold compose; split.
    - intro i; apply antimonotone_coop; auto; apply Hsup.
    - intros x Hx.
      apply le_inf.
      { apply downward_directed_f_ideal; auto. }
      intro i.
      eapply cocontinuous_f_ideal; eauto.
      unfold flip, compose; intro j; specialize (Hx j).
      etransitivity; eauto.
      generalize (inf_spec (fun x0 : nat => f (ideal (ch j) x0))).
      intro Hinf.
      assert (Hch': downward_directed (fun x0 : nat => f (ideal (ch j) x0))).
      { apply downward_directed_f_ideal; auto. }
      apply Hinf in Hch'.
      destruct Hch' as [Hub Hlub].
      apply Hub.
  Qed.
  Hint Resolve cocontinuous_coop : aCPO.

  Lemma monotone_incl : monotone incl.
  Proof.
    intros i j Hij.
    destruct H as [Hincl _ _ _ _].
    apply Hincl; auto.
  Qed.
  Hint Resolve monotone_incl : aCPO.

  Theorem co_le {C} `{CPO C} (f : basis A -> C) (g : A -> C) :
    monotone f ->
    wcontinuous g ->
    f ⊑ g ∘ incl ->
    co f ⊑ g.
  Proof.
    unfold basis, compose in *; intros Hf Hg Hgf.
    intro a.
    apply ge_sup.
    { apply directed_f_ideal; auto. }
    intro i; unfold compose.
    simpl in *.
    etransitivity; eauto.
    apply wcontinuous_monotone; auto.
    destruct H as [? ? ? ? Hsup].
    destruct (Hsup a) as [Hub _].
    apply Hub.
Qed.

  (** Uniqueness property. This is the primary proof principle. *)
  Theorem co_unique {C} `{CPO C} (f : basis A -> C) (g : A -> C) :
    monotone f ->
    wcontinuous g ->
    g ∘ incl === f ->
    g === co f.
  Proof.
    unfold basis, compose in *; intros Hf Hg [Hgf Hfg].
    apply equ_arrow.
    intro a.
    symmetry.
    apply supremum_sup.
    split.
    - intro i; unfold compose.
      simpl in *.
      etransitivity; eauto.
      apply wcontinuous_monotone; auto.
      destruct H as [? ? ? ? Hsup].
      destruct (Hsup a) as [Hub _].
      apply Hub.
    - intros c Hc.
      simpl in *.
      destruct H as [? ? ? ? Hsup].
      pose proof (Hsup a) as Ha.
      apply Hg in Ha.
      2: { apply chain_f_ideal; auto.
           apply monotone_incl. }
      destruct Ha as [Hub Hlub].
      apply Hlub.
      intro i; unfold compose.
      etransitivity; eauto.
  Qed.

  (* (** Uniqueness property. This is the primary proof principle. *) *)
  (* Theorem co_unique {C} `{CPO C} (f : basis A -> C) (g : A -> C) : *)
  (*   monotone f -> *)
  (*   continuous g -> *)
  (*   g ∘ incl === f -> *)
  (*   g === co f. *)
  (* Proof. *)
  (*   unfold basis, compose in *; intros Hf Hg [Hgf Hfg]. *)
  (*   apply equ_arrow. *)
  (*   intro a. *)
  (*   symmetry. *)
  (*   apply supremum_sup. *)
  (*   split. *)
  (*   - intro i; unfold compose. *)
  (*     simpl in *. *)
  (*     etransitivity; eauto. *)
  (*     apply continuous_monotone; auto. *)
  (*     destruct H as [? ? ? ? Hsup]. *)
  (*     destruct (Hsup a) as [Hub _]. *)
  (*     apply Hub. *)
  (*   - intros c Hc. *)
  (*     simpl in *. *)
  (*     destruct H as [? ? ? ? Hsup]. *)
  (*     pose proof (Hsup a) as Ha. *)
  (*     apply Hg in Ha. *)
  (*     2: { apply directed_f_ideal; auto. *)
  (*          apply monotone_incl. } *)
  (*     destruct Ha as [Hub Hlub]. *)
  (*     apply Hlub. *)
  (*     intro i; unfold compose. *)
  (*     etransitivity; eauto. *)
  (* Qed. *)

  Corollary co_unique_ext {C} `{o : OType C} `{@CPO C o} `{@ExtType C o}
    (f : basis A -> C) (g : A -> C) :
    monotone f ->
    wcontinuous g ->
    g ∘ incl = f ->
    g = co f.
  Proof.
    intros Hf Hg Heq; apply ext, co_unique; auto; rewrite Heq; reflexivity.
  Qed.

  Lemma continuous_incl_ideal (P : A -> Prop) (a : A) :
    continuous P ->
    P a ->
    exists i, P (incl (ideal a i)).
  Proof.
    intros HP HPa.
    unfold continuous in HP.
    assert (Ha: supremum a (incl ∘ ideal a)).
    { apply supremum_ideal. }
    apply HP in Ha.
    2: { apply directed_f_ideal, monotone_incl. }
    apply supremum_Prop' in Ha; intuition.
  Qed.

  Lemma cocontinuous_incl_ideal (P : A -> Prop) (a : A) (i : nat) :
    cocontinuous P ->
    P a ->
    P (incl (ideal a i)).
  Proof.
    intros HP HPa.
    unfold cocontinuous in HP.
    assert (Ha: supremum a (incl ∘ ideal a)).
    { apply supremum_ideal. }
    apply HP in Ha.
    2: { apply directed_f_ideal, monotone_incl. }
    unfold compose in *.
    destruct Ha as [Hlb Hglb].
    apply Hlb; auto.
  Qed.

  (* (** Continuously constrained uniqueness principle (more powerful). *) *)
  (* Theorem co_unique_continuous_P {C} `{CPO C} (P : A -> Prop) (f : basis A -> C) (g : A -> C) (a : A) : *)
  (*   continuous P -> *)
  (*   monotone f -> *)
  (*   continuous g -> *)
  (*   P a -> *)
  (*   ((exists i, P (incl (ideal a i))) -> *)
  (*    forall i, g (incl (ideal a i)) === f (ideal a i)) -> *)
  (*   g a === co f a. *)
  (* Proof. *)
  (*   unfold basis, compose in *; intros HP Hf Hg HPa Hgf. *)
  (*   symmetry. *)
  (*   apply supremum_sup. *)
  (*   split. *)
  (*   - intro i; unfold compose. *)
  (*     apply continuous_incl_ideal in HPa; auto. *)
  (*     specialize (Hgf HPa). *)
  (*     rewrite <- Hgf. *)
  (*     apply continuous_monotone; auto. *)
  (*     apply incl_ideal_le. *)
  (*   - intros c Hc. *)
  (*     simpl in *. *)
  (*     destruct H as [? ? ? ? Hsup]. *)
  (*     pose proof (Hsup a) as Ha. *)
  (*     apply Hg in Ha. *)
  (*     2: { apply directed_f_ideal; auto. *)
  (*          apply monotone_incl. } *)
  (*     destruct Ha as [Hub Hlub]. *)
  (*     apply Hlub. *)
  (*     intro i; unfold compose. *)
  (*     unfold compose in *. *)
  (*     rewrite Hgf. *)
  (*     2: { apply continuous_incl_ideal; auto. } *)
  (*     eauto. *)
  (* Qed. *)

  (* (** Cocontinuously constrained uniqueness principle (more powerful). *) *)
  (* Theorem co_unique_cocontinuous_R {C} `{CPO C} *)
  (*   (R : A -> A -> Prop) (f : basis A -> C) (g : A -> C) (a b : A) : *)
  (*   cocontinuous R -> *)
  (*   monotone f -> *)
  (*   continuous g -> *)
  (*   R a b -> *)
  (*   ((forall i, R (incl (ideal a i)) (incl (ideal b i))) -> *)
  (*    forall i, g (incl (ideal a i)) === f (ideal b i)) -> *)
  (*   g a === co f b. *)
  (* Proof. *)
  (*   unfold basis, compose in *; intros HP Hf Hg HPa Hgf. *)
  (*   symmetry. *)
  (*   apply supremum_sup. *)
  (*   split. *)
  (*   - intro i; unfold compose. *)
  (*     rewrite <- Hgf. *)
  (*     2: { intro n. *)
  (*          apply cocontinuous_incl_ideal. *)
  (*     2: { intro; apply cocontinuous_incl_ideal; auto. } *)
  (*     apply continuous_monotone; auto. *)
  (*     apply incl_ideal_le. *)
  (*   - intros c Hc. *)
  (*     simpl in *. *)
  (*     destruct H as [? ? ? ? Hsup]. *)
  (*     pose proof (Hsup a) as Ha. *)
  (*     apply Hg in Ha. *)
  (*     2: { apply directed_f_ideal; auto. *)
  (*          apply monotone_incl. } *)
  (*     destruct Ha as [Hub Hlub]. *)
  (*     apply Hlub. *)
  (*     intro i; unfold compose. *)
  (*     unfold compose in *. *)
  (*     rewrite Hgf. *)
  (*     2: { intro; apply cocontinuous_incl_ideal; auto. } *)
  (*     eauto. *)
  (* Qed. *)

  (* (** Cocontinuously constrained uniqueness principle (more powerful). *) *)
  (* Theorem co_unique_cocontinuous_P {C} `{CPO C} *)
  (*   (P : A -> Prop) (f : basis A -> C) (g : A -> C) (a : A) : *)
  (*   cocontinuous P -> *)
  (*   monotone f -> *)
  (*   continuous g -> *)
  (*   P a -> *)
  (*   ((forall i, P (incl (ideal a i))) -> *)
  (*    forall i, g (incl (ideal a i)) === f (ideal a i)) -> *)
  (*   g a === co f a. *)
  (* Proof. *)
  (*   unfold basis, compose in *; intros HP Hf Hg HPa Hgf. *)
  (*   symmetry. *)
  (*   apply supremum_sup. *)
  (*   split. *)
  (*   - intro i; unfold compose. *)
  (*     rewrite <- Hgf. *)
  (*     2: { intro; apply cocontinuous_incl_ideal; auto. } *)
  (*     apply continuous_monotone; auto. *)
  (*     apply incl_ideal_le. *)
  (*   - intros c Hc. *)
  (*     simpl in *. *)
  (*     destruct H as [? ? ? ? Hsup]. *)
  (*     pose proof (Hsup a) as Ha. *)
  (*     apply Hg in Ha. *)
  (*     2: { apply directed_f_ideal; auto. *)
  (*          apply monotone_incl. } *)
  (*     destruct Ha as [Hub Hlub]. *)
  (*     apply Hlub. *)
  (*     intro i; unfold compose. *)
  (*     unfold compose in *. *)
  (*     rewrite Hgf. *)
  (*     2: { intro; apply cocontinuous_incl_ideal; auto. } *)
  (*     eauto. *)
  (* Qed. *)

  (* (** Cocontinuously constrained uniqueness principle (more powerful). *) *)
  (* Theorem co_unique_cocontinuous_P {C} `{CPO C} (P : A -> Prop) (f : basis A -> C) (g : A -> C) : *)
  (*   cocontinuous P -> *)
  (*   monotone f -> *)
  (*   continuous g -> *)
  (*   (forall b, P (incl b) -> g (incl b) === f b) -> *)
  (*   forall a, P a -> g a === co f a. *)
  (* Proof. *)
  (*   unfold basis, compose in *; intros HP Hf Hg Hgf a HPa. *)
  (*   symmetry. *)
  (*   apply supremum_sup. *)
  (*   split. *)
  (*   - intro i; unfold compose. *)
  (*     specialize (Hgf (ideal a i)). *)
  (*     apply cocontinuous_incl_ideal with (i:=i) in HPa; auto. *)
  (*     apply Hgf in HPa. *)
  (*     rewrite <- HPa. *)
  (*     apply continuous_monotone; auto. *)
  (*     apply incl_ideal_le. *)
  (*   - intros c Hc. *)
  (*     simpl in *. *)
  (*     destruct H as [? ? ? ? Hsup]. *)
  (*     pose proof (Hsup a) as Ha. *)
  (*     apply Hg in Ha. *)
  (*     2: { apply directed_f_ideal; auto. *)
  (*          apply monotone_incl. } *)
  (*     destruct Ha as [Hub Hlub]. *)
  (*     apply Hlub. *)
  (*     intro i; unfold compose. *)
  (*     unfold compose in *. *)
  (*     rewrite Hgf. *)
  (*     2: { apply cocontinuous_incl_ideal; auto. } *)
  (*     eauto. *)
  (* Qed. *)

  (** The comorphism lemma. *)
  Lemma co_exists_unique {C} `{CPO C} (f : basis A -> C) :
    monotone f ->
    co f ∘ incl === f /\ forall g, continuous g -> g ∘ incl === f -> g === co f.
  Proof.
    intro Hf; split.
    - apply co_incl; auto.
    - intros; apply co_unique; auto with order.
  Qed.

  (** Useful variant. *)
  Corollary co_unique' {C} `{CPO C} (f : basis A -> C) (g : A -> C) (a : A) :
    monotone f ->
    continuous g ->
    (forall b, g (incl b) === f b) ->
    g a === co f a.
  Proof.
    intros Hf Hg Hgf.
    revert a; apply equ_arrow.
    apply co_unique; auto with order.
    apply equ_arrow; auto.
  Qed.

  Corollary Proper_coop {C} `{lCPO C} (f g : basis A -> C) :
    antimonotone f ->
    antimonotone g ->
    f === g ->
    coop f === coop g.
  Proof.
    intros Hf Hg Hfg.
    unfold coop; unfold compose.
    apply equ_arrow; intro x.
    apply Proper_inf; eauto with order aCPO.
    apply equ_arrow; intro i.
    split; apply Hfg.
  Qed.

  Corollary Proper_coop' {C} `{lCPO C} (f g : basis A -> C) (x y : A) :
    antimonotone f ->
    antimonotone g ->
    f === g ->
    x === y ->
    coop f x === coop g y.
  Proof.
    intros Hf Hg Hfg Hxy.
    unfold antimonotone in Hf.
    rewrite Hxy; clear Hxy.
    revert y; apply equ_arrow, Proper_coop; auto.
  Qed.

  Theorem coop_unique {C} `{lCPO C} (f : basis A -> C) (g : A -> C) :
    antimonotone f ->
    cocontinuous g ->
    g ∘ incl === f ->
    g === coop f.
  Proof.
    intros Hf Hg Hfg.
    etransitivity.
    2: { apply Proper_coop; auto.
         2: { apply Hfg. }
         apply monotone_antimonotone_compose; auto with order aCPO. }
    apply equ_arrow.
    intro x.
    unfold coop.
    assert (x === sup (incl ∘ ideal x)).
    { symmetry; apply supremum_sup, supremum_ideal. }
    assert (Hgx: g x === g (sup (incl ∘ ideal x))).
    { apply Proper_antimonotone_equ; auto.
      apply cocontinuous_antimonotone; auto. }
    rewrite Hgx.
    rewrite cocontinuous_sup; auto.
    - reflexivity.
    - apply directed_f_ideal, monotone_incl.
  Qed.

  Corollary coop_unique_ext {C} `{o : OType C} `{@lCPO C o} `{@ExtType C o}
    (f : basis A -> C) (g : A -> C) :
    antimonotone f ->
    cocontinuous g ->
    g ∘ incl = f ->
    g = coop f.
  Proof.
    intros Hf Hg Heq; apply ext, coop_unique; auto; rewrite Heq; reflexivity.
  Qed.

  (* (** Cocontinuously constrained uniqueness principle (more powerful). *) *)
  (* Theorem coop_unique_constrained {C} `{lCPO C} (P : A -> Prop) (f : basis A -> C) (g : A -> C) : *)
  (*   cocontinuous P -> *)
  (*   antimonotone f -> *)
  (*   cocontinuous g -> *)
  (*   (forall b, P (incl b) -> g (incl b) === f b) -> *)
  (*   forall a, P a -> g a === coop f a. *)
  (* Proof. *)
  (*   unfold basis, compose in *; intros HP Hf Hg Hgf a HPa. *)
  (*   symmetry. *)
  (*   apply infimum_inf. *)
  (*   split. *)
  (*   - intro i; unfold compose. *)
  (*     specialize (Hgf (ideal a i)). *)
  (*     apply cocontinuous_incl_ideal with (i:=i) in HPa; auto. *)
  (*     apply Hgf in HPa. *)
  (*     rewrite <- HPa. *)
  (*     apply cocontinuous_antimonotone; auto. *)
  (*     apply incl_ideal_le. *)
  (*   - intros c Hc. *)
  (*     simpl in *. *)
  (*     destruct H as [? ? ? ? Hsup]. *)
  (*     pose proof (Hsup a) as Ha. *)
  (*     apply Hg in Ha. *)
  (*     2: { apply directed_f_ideal; auto. *)
  (*          apply monotone_incl. } *)
  (*     destruct Ha as [Hub Hlub]. *)
  (*     apply Hlub. *)
  (*     intro i; unfold compose. *)
  (*     unfold compose in *. *)
  (*     rewrite Hgf. *)
  (*     2: { apply cocontinuous_incl_ideal; auto. } *)
  (*     eauto. *)
  (* Qed. *)

  Corollary coop_unique' {C} `{lCPO C} (f : basis A -> C) (g : A -> C) (a : A) :
    antimonotone f ->
    cocontinuous g ->
    (forall b, g (incl b) === f b) ->
    g a === coop f a.
  Proof.
    intros Hf Hg Hgf.
    revert a; apply equ_arrow.
    apply coop_unique; auto.
    apply equ_arrow; auto.
  Qed.

  (** The anticomorphism lemma. *)
  Lemma coop_exists_unique {C} `{lCPO C} (f : basis A -> C) :
    antimonotone f ->
    coop f ∘ incl === f /\ forall g, cocontinuous g -> g ∘ incl === f -> g === coop f.
  Proof.
    intro Hf; split.
    - apply coop_incl; auto.
    - intros; apply coop_unique; auto.
  Qed.

  Lemma monotone_co_f {C} `{CPO C} (f g : basis A -> C) :
    monotone f ->
    monotone g ->
    f ⊑ g ->
    co f ⊑ co g.
  Proof.
    intros Hf Hg Hfg t.
    apply ge_sup.
    { apply directed_f_ideal; auto. }
    intro i.
    apply le_sup with (i:=i).
    { apply directed_f_ideal; auto. }
    apply Hfg.
  Qed.

  Lemma monotone_coop_f {C} `{lCPO C} (f g : basis A -> C) :
    antimonotone f ->
    antimonotone g ->
    f ⊑ g ->
    coop f ⊑ coop g.
  Proof.
    intros Hf Hg Hfg t.
    apply le_inf.
    { apply downward_directed_f_ideal; auto. }
    intro i.
    apply ge_inf with (i:=i).
    { apply downward_directed_f_ideal; auto. }
    apply Hfg.
  Qed.

  (** Two comorphisms are equal whenever their initial morphisms
      are. Alternate version of the uniqueness property that is
      sometimes useful. *)
  Corollary Proper_co {C} `{CPO C} (f g : basis A -> C) :
    monotone f ->
    monotone g ->
    f === g ->
    co f === co g.
  Proof.
    intros Hf Hg Hfg.
    apply co_unique; auto with order aCPO.
    rewrite <- Hfg.
    apply equ_arrow; intro b.
    apply co_incl'; auto.
  Qed.

  Corollary Proper_co' {C} `{CPO C} (f g : basis A -> C) (x y : A) :
    monotone f ->
    monotone g ->
    f === g ->
    x === y ->
    co f x === co g y.
  Proof.
    intros Hf Hg Hfg Hxy.
    unfold monotone in Hf.
    rewrite Hxy; clear Hxy.
    revert y; apply equ_arrow, Proper_co; auto.
  Qed.

  Corollary Proper_co_ext {C} `{oC: OType C} `{@CPO _ oC} `{@ExtType _ oC}
    (f g : basis A -> C) (x : A) :
    monotone f ->
    monotone g ->
    f = g ->
    co f x = co g x.
  Proof.
    intros Hf Hg Hfg.
    apply ext, Proper_co'; auto.
    - rewrite Hfg; reflexivity.
    - reflexivity.
  Qed.

  Theorem co_intro (P : basis A -> Prop) (a : A) (i : nat) :
    monotone P ->
    P (ideal a i) ->
    co P a.
  Proof.
    intros Hmono HP; unfold co.
    assert (Hch: directed (P ∘ ideal a)).
    { apply directed_f_ideal; auto. }
    generalize (sup_spec (P ∘ ideal a) Hch).
    intros [Hub Hlub].
    eapply Hub; eauto.
  Qed.

  Theorem coop_intro (P : basis A -> Prop) (a : A) :
    antimonotone P ->
    (forall i, P (ideal a i)) ->
    coop P a.
  Proof.
    intros Hmono HP; unfold coop.
    assert (Hch: downward_directed (P ∘ ideal a)).
    { apply downward_directed_f_ideal; auto. }
    generalize (inf_spec (P ∘ ideal a) Hch).
    intros [Hub Hlub].
    unfold lower_bound in Hub.
    simpl in *; unfold flip, impl in *.
    eapply Hlub; eauto.
    intro i; simpl; unfold flip, impl.
    intro Hx; apply HP.
  Qed.

  Theorem co_elim (P : basis A -> Prop) (a : A) :
    monotone P ->
    co P a ->
    exists i, P (ideal a i).
  Proof.
    intros Hmono HP; unfold co.
    assert (Hch: directed (P ∘ ideal a)).
    { apply directed_f_ideal; auto. }
    generalize (sup_spec (P ∘ ideal a) Hch).
    intros [Hub Hlub].
    apply Hlub; auto.
    intros i Hi; exists i; auto.
  Qed.

  Theorem coop_elim (P : basis A -> Prop) (a : A) :
    antimonotone P ->
    coop P a ->
    forall i, P (ideal a i).
  Proof.
    intros Hmono HP; unfold coop.
    assert (Hch: downward_directed (P ∘ ideal a)).
    { apply downward_directed_f_ideal; auto. }
    generalize (inf_spec (P ∘ ideal a) Hch).
    intros [Hub Hlub] i.
    apply Hub, HP.
  Qed.

  Theorem co_intro2 {C} (R : basis A -> C -> Prop) (a : A) (c : C) (i : nat) :
    monotone R ->
    R (ideal a i) c ->
    co R a c.
  Proof.
    intros Hmono HR; unfold co.
    assert (Hch: directed (R ∘ ideal a)).
    { apply directed_f_ideal; auto. }
    generalize (sup_spec (R ∘ ideal a) Hch).
    intros [Hub Hlub].
    eapply Hub; eauto.
  Qed.

  Theorem coop_intro2 {C} (R : basis A -> C -> Prop) (a : A) (c : C) :
    antimonotone R ->
    (forall i, R (ideal a i) c) ->
    coop R a c.
  Proof.
    intros Hmono HR; unfold coop.
    assert (Hch: downward_directed (R ∘ ideal a)).
    { apply downward_directed_f_ideal; auto. }
    generalize (inf_spec (R ∘ ideal a) Hch).
    intros [Hub Hlub].
    unfold upper_bound in Hub.
    simpl in *; unfold flip, impl in *.
    eapply Hlub with (x := (fun x => forall i, R (ideal a i) x)).
    { intros i x Hx; apply Hx. }
    auto.
  Qed.

  Theorem co_elim2 {C} (R : basis A -> C -> Prop) (a : A) (c : C) :
    monotone R ->
    co R a c ->
    exists i, R (ideal a i) c.
  Proof.
    intros Hmono HR; unfold co.
    assert (Hch: directed (R ∘ ideal a)).
    { apply directed_f_ideal; auto. }
    generalize (sup_spec (R ∘ ideal a) Hch).
    intros [Hub Hlub].
    unfold upper_bound in Hub.
    assert (Hx: upper_bound (fun c => exists i, R (ideal a i) c) (R ∘ ideal a)).
    { intro i; exists i; auto. }
    apply Hlub in Hx.
    apply Hx; auto.
  Qed.

  Theorem coop_elim2 {C} (R : basis A -> C -> Prop) (a : A) (c : C) :
    antimonotone R ->
    coop R a c ->
    forall i, R (ideal a i) c.
  Proof.
    intros Hmono HR; unfold coop.
    assert (Hch: downward_directed (R ∘ ideal a)).
    { apply downward_directed_f_ideal; auto. }
    generalize (inf_spec (R ∘ ideal a) Hch).
    intros [Hub Hlub] i.
    apply Hub, HR.
  Qed.

  Lemma coop_elim2' {C} (R : basis A -> C -> Prop) (a : A) (c : C) :
    antimonotone R ->
    coop R a c ->
    forall i, R (ideal a i) c.
  Proof.
    intros Hmono HR; unfold coop.
    assert (Hch: downward_directed (R ∘ ideal a)).
    { apply downward_directed_f_ideal; auto. }
    generalize (inf_spec (R ∘ ideal a) Hch).
    intros [Hub Hlub] i.
    apply Hub, HR.
  Qed.

  (** Every continuous function is a comorphism that is fully
      determined by its behavior on basis elements. *)
  Corollary continuous_co_incl {C} `{CPO C} (g : A -> C) :
    continuous g ->
    g === co (g ∘ incl).
  Proof.
    intro Hg.
    apply equ_arrow; intro a.
    unfold co, compose.
    symmetry; apply supremum_sup.
    apply Hg.
    { apply directed_f_ideal, monotone_incl. }
    apply supremum_ideal.
  Qed.

  Theorem cocontinuous_coop_incl {C} `{lCPO C} (g : A -> C) :
    cocontinuous g ->
    g === coop (g ∘ incl).
  Proof.
    intro Hg.
    apply equ_arrow; intro a.
    unfold coop, compose.
    symmetry; apply infimum_inf.
    apply Hg.
    { apply directed_f_ideal, monotone_incl. }
    apply supremum_ideal.
  Qed.

  Corollary continuous_ind {C} `{CPO C} (f : A -> C) (g : A -> C) :
    continuous f ->
    continuous g ->
    f ∘ incl === g ∘ incl ->
    f === g.
  Proof.
    intros Hf Hg Hfg.
    pose proof Hf as Hf'.
    apply continuous_co_incl in Hf'.
    rewrite Hf'.
    rewrite Proper_co.
    { symmetry; apply continuous_co_incl; auto. }
    { apply monotone_compose.
      - apply monotone_incl.
      - apply continuous_monotone; auto. }
    { apply monotone_compose.
      - apply monotone_incl.
      - apply continuous_monotone; auto. }
    auto.
  Qed.

  Corollary cocontinuous_ind {C} `{lCPO C} (f : A -> C) (g : A -> C) :
    cocontinuous f ->
    cocontinuous g ->
    f ∘ incl === g ∘ incl ->
    f === g.
  Proof.
    intros Hf Hg Hfg.
    pose proof Hf as Hf'.
    apply cocontinuous_coop_incl in Hf'.
    rewrite Hf'.
    rewrite Proper_coop.
    { symmetry; apply cocontinuous_coop_incl; auto. }
    { apply monotone_antimonotone_compose.
      - apply monotone_incl.
      - apply cocontinuous_antimonotone; auto. }
    { apply monotone_antimonotone_compose.
      - apply monotone_incl.
      - apply cocontinuous_antimonotone; auto. }
    auto.
  Qed.

  (* Corollary Proper_co_R {C} `{CPO C} (f g : basis A -> C) (R : basis A -> A -> Prop) (a b : A) : *)
  (*   antimonotone R -> *)
  (*   monotone f -> *)
  (*   monotone g -> *)
  (*   (forall i, P b -> f b === g b) -> *)
  (*   coop P a -> *)
  (*   co f a === co g b. *)
  (* Proof. *)
  (*   intros HP Hf Hg Hfg HPa. *)
  (*   eapply co_unique_cocontinuous_P; eauto with aCPO order. *)
  (*   intros Hi i. *)
  (*   rewrite co_incl'; auto. *)
  (*   apply Hfg. *)
  (*   eapply coop_elim in HPa; eauto. *)
  (* Qed. *)

  (* Corollary Proper_co_P {C} `{CPO C} (f g : basis A -> C) (P : basis A -> Prop) (a : A) : *)
  (*   antimonotone P -> *)
  (*   monotone f -> *)
  (*   monotone g -> *)
  (*   (forall b, P b -> f b === g b) -> *)
  (*   coop P a -> *)
  (*   co f a === co g a. *)
  (* Proof. *)
  (*   intros HP Hf Hg Hfg HPa. *)
  (*   eapply co_unique_cocontinuous_P; eauto with aCPO order. *)
  (*   intros Hi i. *)
  (*   rewrite co_incl'; auto. *)
  (*   apply Hfg. *)
  (*   eapply coop_elim in HPa; eauto. *)
  (* Qed. *)

  (* Corollary Proper_co_P_ext {C} `{oC: OType C} `{@CPO _ oC} `{@ExtType _ oC} *)
  (*   (f g : basis A -> C) (P : basis A -> Prop) (a : A) : *)
  (*   antimonotone P -> *)
  (*   monotone f -> *)
  (*   monotone g -> *)
  (*   (forall b, P b -> f b = g b) -> *)
  (*   coop P a -> *)
  (*   co f a = co g a. *)
  (* Proof. *)
  (*   intros HP Hf Hg Hfg HPa. *)
  (*   apply ext; eapply Proper_co_P; eauto. *)
  (*   intros b HPb; rewrite Hfg; auto; reflexivity. *)
  (* Qed. *)
End aCPO.

#[global] Hint Resolve directed_f_ideal : aCPO.
#[global] Hint Resolve monotone_incl : aCPO.
#[global] Hint Resolve monotone_co : aCPO.
#[global] Hint Resolve continuous_co : aCPO.
#[global] Hint Resolve antimonotone_coop : aCPO.
#[global] Hint Resolve cocontinuous_coop : aCPO.

(** Fusion rule for comorphism composition. A comorphism can be
    extended by a continuous function at the front, resulting in a new
    comorphism. I.e., given monotone f and continuous g:

    [ g ∘ co f = co (g ∘ f) ]

    An immediate consequence is that any chain of continuous function
    compositions can be written as a single comorphism as long as the
    rightmost (the one directly receiving the input) function in the
    chain is a comorphism. We only need to maintain an algebraic hold
    over the input space.  *)

Theorem co_co {A aB B C} `{aCPO A aB} `{CPO B} `{CPO C}
  (f : basis A -> B) (g : B -> C) :
  monotone f ->
  wcontinuous g ->
  g ∘ co f === co (g ∘ f).
Proof.
  intros Hf Hg.
  unfold co, compose.
  apply equ_arrow; intro t.
  assert (Heq: g (sup (fun x : nat => f (ideal t x))) ===
                 sup (fun i => g (f (ideal t i)))).
  { apply wcontinuous_sup; auto; apply chain_f_ideal; auto. }
  rewrite Heq; clear Heq.
  reflexivity.
Qed.

(** Pointwise variant of the fusion rule. *)
Corollary co_co' {A aB B C} `{aCPO A aB} `{CPO B} `{CPO C}
  (f : basis A -> B) (g : B -> C) (x : A) :
  monotone f ->
  wcontinuous g ->
  g (co f x) === co (g ∘ f) x.
Proof.
  intros Hf Hg; revert x; apply equ_arrow, co_co; auto with aCPO.
Qed.

(** ExtType variant of fusion rule. *)
Corollary co_co_ext {A aB B C} `{aCPO A aB} `{CPO B}
  `{oC : OType C} `{@CPO _ oC} `{@ExtType _ oC}
  (f : basis A -> B) (g : B -> C) (x : A) :
  monotone f ->
  wcontinuous g ->
  g (co f x) = co (g ∘ f) x.
Proof. intros Hf Hg; apply ext, co_co'; auto. Qed.

Corollary co_co'' {A aB B bB C} `{aCPO A aB} `{aCPO B bB} `{CPO C}
  (f : basis A -> B) (g : basis B -> C) (x : A) :
  monotone f ->
  monotone g ->
  co g (co f x) === co (co g ∘ f) x.
Proof.
  intros Hf Hg; revert x; apply equ_arrow, co_co; auto with aCPO order.
Qed.

Theorem coop_coop {A aB B C} `{aCPO A aB} `{lCPO B} `{lCPO C}
  (f : basis A -> B) (g : B -> C) :
  antimonotone f ->
  dec_continuous g ->
  g ∘ coop f === coop (g ∘ f).
Proof.
  intros Hf Hg.
  unfold co, coop, compose.
  apply equ_arrow; intro t.
  assert (Heq: g (inf (fun x : nat => f (ideal t x))) ===
                 inf (fun i => g (f (ideal t i)))).
  { apply dec_continuous_inf; auto.
    apply downward_directed_f_ideal; auto. }
  rewrite Heq; clear Heq.
  reflexivity.
Qed.

Theorem co_coop {A aB B C} `{aCPO A aB} `{CPO B} `{lCPO C}
  (f : basis A -> B) (g : B -> C) :
  monotone f ->
  cocontinuous g ->
  g ∘ co f === coop (g ∘ f).
Proof.
  intros Hf Hg.
  unfold co, coop, compose.
  apply equ_arrow; intro t.
  assert (Heq: g (sup (fun x : nat => f (ideal t x))) ===
                 inf (fun i => g (f (ideal t i)))).
  { apply cocontinuous_sup; auto.
    apply directed_f_ideal; auto. }
  rewrite Heq; clear Heq.
  reflexivity.
Qed.

(** Pointwise variant. *)
Corollary co_coop' {A aB B C} `{aCPO A aB} `{CPO B} `{lCPO C}
  (f : basis A -> B) (g : B -> C) (a : A) :
  monotone f ->
  cocontinuous g ->
  g (co f a) === coop (g ∘ f) a.
Proof.
  intros Hf Hg; revert a; apply equ_arrow.
  apply co_coop; auto with aCPO.
Qed.

Theorem coop_co {A aB B C} `{aCPO A aB} `{lCPO B} `{CPO C}
  (f : basis A -> B) (g : B -> C) :
  antimonotone f ->
  dec_cocontinuous g ->
  g ∘ coop f === co (g ∘ f).
Proof.
  intros Hf Hg.
  unfold co, coop, compose.
  apply equ_arrow; intro t.
  assert (Heq: g (inf (fun x : nat => f (ideal t x))) ===
                 sup (fun i => g (f (ideal t i)))).
  { apply dec_cocontinuous_inf; auto.
    apply downward_directed_f_ideal; auto. }
  rewrite Heq; clear Heq.
  reflexivity.
Qed.

(** Pointwise variant. *)
Corollary coop_co' {A aB B C} `{aCPO A aB} `{lCPO B} `{CPO C}
  (f : basis A -> B) (g : B -> C) (a : A) :
  antimonotone f ->
  dec_cocontinuous g ->
  g (coop f a) === co (g ∘ f) a.
Proof.
  intros Hf Hg; revert a; apply equ_arrow.
  apply coop_co; auto with aCPO.
Qed.

Corollary co_coP {A aB B} `{aCPO A aB} `{CPO B}
  (f : basis A -> B) (g : B -> Prop) (x : A) :
  monotone f ->
  continuous g ->
  g (co f x) <-> co (g ∘ f) x.
Proof. intros Hf Hg; apply equ_iff, co_co'; auto with order. Qed.

Theorem co_coopP {A aB B C} `{aCPO A aB} `{CPO B} `{lCPO C}
  (f : basis A -> B) (g : B -> Prop) (a : A) :
  monotone f ->
  cocontinuous g ->
  g (co f a) <-> coop (g ∘ f) a.
Proof. intros Hf Hg; apply equ_iff, co_coop'; auto. Qed.

Corollary coop_coP {A aB B} `{aCPO A aB} `{lCPO B}
  (f : basis A -> B) (g : B -> Prop) (x : A) :
  antimonotone f ->
  dec_cocontinuous g ->
  g (coop f x) <-> co (g ∘ f) x.
Proof.
  intros Hf Hg.
  cut (g (coop f x) === co (g ∘ f) x).
  { firstorder. }
  revert x; apply equ_arrow.
  apply coop_co; auto.
Qed.

Lemma co_incl_id {A B} `{aCPO A B} :
  co incl === @id A.
Proof.
  symmetry; apply co_unique; auto with order.
  - apply monotone_incl.
  - reflexivity.
Qed.

Lemma co_incl_id' {A B} `{aCPO A B} (x : A) :
  co incl x === x.
Proof. revert x; apply equ_arrow, co_incl_id. Qed.

Ltac cointro := try eapply co_intro; try eapply coop_intro.
Ltac cointro2 := try eapply co_intro2; try eapply coop_intro2.
Ltac coelim H := try eapply co_elim in H; try eapply coop_elim in H.
Ltac coelim2 := try eapply co_elim2; try eapply coop_elim2.


Require Import Coq.Bool.Bool.
Require Import Coq.Classes.RelationClasses.
Require Import ExtLib.Tactics.Consider.

Set Implicit Arguments.
Set Strict Implicit.

Class CmpDec (T : Type) (equ : T -> T -> Prop) (ltu : T -> T -> Prop) : Type :=
{ cmp_dec : T -> T -> comparison }.

Class CmpDec_Correct T (equ ltu : T -> T -> Prop) (ED : CmpDec equ ltu) : Prop :=
{ cmp_dec_correct : forall x y : T,
  match cmp_dec x y with
    | Eq => equ x y
    | Lt => ltu x y
    | Gt => ltu y x
  end }.

Inductive cmp_case (P Q R : Prop) : comparison -> Prop :=
| CaseEq : P -> cmp_case P Q R Eq
| CaseLt : Q -> cmp_case P Q R Lt
| CaseGt : R -> cmp_case P Q R Gt.

Section pair.
  Variable T U : Type.
  Variables eqt ltt : T -> T -> Prop.
  Variables equ ltu : U -> U -> Prop.

  Definition eq_pair (a b : T * U) : Prop :=
    eqt (fst a) (fst b) /\ equ (snd a) (snd b).

  Definition lt_pair (a b : T * U) : Prop :=
    ltt (fst a) (fst b) \/ (eqt (fst a) (fst b) /\ ltu (snd a) (snd b)).

  Variable cdt : CmpDec eqt ltt.
  Variable cdu : CmpDec equ ltu.

  Instance CmpDec_pair : CmpDec eq_pair lt_pair :=
  { cmp_dec := fun a b =>
    let '(al,ar) := a in
    let '(bl,br) := b in
    match cmp_dec al bl with
      | Eq => cmp_dec ar br
      | x => x
    end }.

  Variable cdtC : CmpDec_Correct cdt.
  Variable cduC : CmpDec_Correct cdu.
  Variable Symmetric_eqt : Symmetric eqt.

  Instance CmpDec_Correct_pair : CmpDec_Correct CmpDec_pair.
  Proof.
    constructor. destruct x; destruct y; unfold eq_pair, lt_pair; simpl in *.
    generalize (cmp_dec_correct t t0); destruct (cmp_dec t t0); simpl; intros; auto.
    generalize (cmp_dec_correct u u0); destruct (cmp_dec u u0); simpl; intros; auto.
  Qed.
End pair.


Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.ssrbool.
Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.ssrnat.

Section HilbertSaxiom.
  Variables A B C : Prop.
  Lemma HilbertS : (A -> B -> C) -> (A -> B) -> A -> C.
  Proof.
    (* move => is equivalent to move=>,
     * equivalent to intros hAiBiC hAiB hA
     * moves hypotheses into context
     * move is a tactic, => is a tactical
     * move does nothing, *)
    move => hAiBiC hAiB hA.
    (* move : is equivalent to move:,
     * equivalent to revert hAiBiC
     * almost equivalent to generalize hAiBiC (which leaves in context) *)
    move : hAiBiC.
    apply.
      by [].
    (* apply : hAiB. is equivalent to move : hAiB. apply. *)
    (* move: hAiB; apply. *)
      (* move : hAiB. apply. by []. is equivalent to the below. *)
    by apply: hAiB.
  Qed.

  Hypotheses (hAiBiC : A -> B -> C) (hAiB : A -> B) (hA : A).
  Lemma HilbertS2 : C.
  Proof.
    (* only apply: hA to first subgoal generated. *)
    apply: hAiBiC; first by apply: hA.
    (* exact is kind of equivalent to apply. by []. *)
    (* below is equivalent to move: hAiB; exact. *)
    exact : hAiB.
  Qed.

  Lemma HilbertS3 : C.
  Proof.
    (* apply: hAiBiC; last exact: hAiB; exact. *)
    by [apply: hAiBiC; last exact: hAiB].
  Qed.

  Lemma HilbertS4 : C.
  Proof.
    exact: (hAiBiC _ (hAiB _)).
  Qed.

  Lemma HilbertS5 : C.
  Proof.
    exact: hAiBiC (hAiB _).
  Qed.

  Lemma HilbertS6 : C.
  Proof.
    exact: HilbertS5.
  Qed.

End HilbertSaxiom.

Section Symmetric_Conjunction_Disjunction.
  Lemma andb_sym : forall A B : bool, A && B -> B && A.
  Proof.
    case.
    (* case; by []. is equivalent to below. *)
    by case.
      by [].
  Qed.

  Lemma andb_sym2 : forall A B : bool, A && B -> B && A.
  Proof.
    by [case; case].
  Qed.

  Lemma andb_sym3 : forall A B : bool, A && B -> B && A.
  Proof.
    by do 2! case.
  Qed.

  Lemma and_sym : forall A B : Prop, A /\ B -> B /\ A.
  Proof.
    (* move => A1 B; case. is equvialent to move => A1 B []. wtf??? *)
    by [move => A1 B []].
  Qed.

  Lemma or_sym : forall A B : Prop, A \/ B -> B \/ A.
  Proof.
    (* move => A B; case => [hA | hB]. is equivalent to
     * move=> A B [hA | hB]. *)
    (* move : or_intror. apply. is equivalent to apply : or_intror. *)
    by move=> A B [hA | hB]; [apply: or_intror | apply: or_introl].
  Qed.

  Lemma or_sym2 : forall A B : bool, A \/ B -> B \/ A.
  Proof.
    (* apply / orP.  the / means apply it to the goal. *)
    (* move: AorB; move/orP. is equivalent to  move/orP : AorB. *)
      by move=> [] [] AorB; apply/orP; move/orP : AorB.
  Qed.

End Symmetric_Conjunction_Disjunction.

Section R_sym_trans.
  Variables (D : Type) (R : D -> D -> Prop).
  Hypothesis R_sym : forall x y, R x y -> R y x.
  Hypothesis R_trans : forall x y z, R x y -> R y z -> R x z.

  Lemma refl_if : forall x : D, (exists y, R x y) -> R x x.
  Proof.
    (* move=> x; case=> y Rxy. equivalent to below *)
    move=> x [y Rxy].
      by apply: R_trans _ _ _ _ (R_sym _ y _).
  Qed.
End R_sym_trans.

Section Smullyan_drinker.
  Variables (D : Type)(P : D -> Prop).
  Hypothesis (d : D) (EM : forall A, A \/ ~A).

  Lemma drinker : exists x, P x -> forall y, P y.
  Proof.
    (* case: (EM (exists y, ~P y)) is equivalent to move: (EM (exists y, ~P y)); case. *)
    case: (EM (exists y, ~P y)) => [[y notPy]| nonotPy]; first by exists y.
    (*
      exists d => _ y.
      case : (EM (P y)).
        done.
        move => notPy.
    *)
    exists d => _ y; case: (EM (P y)) => // notPy.
    by case: nonotPy; exists y.
  Qed.

  Lemma drinker2 : exists x, P x -> forall y, P y.
  Proof.
    case: (EM (exists y, ~P y)) => [[y notPy]| nonotPy]; first by exists y.
    exists d => _ y.
    case : (EM (P y)).
    + done.
    + move => notPy.
      by case: nonotPy; exists y.
  Qed.

  Lemma drinker_unfold : exists x, P x -> forall y, P y.
  Proof.
    (* case: (EM (exists y, ~P y)) is equivalent to move: (EM (exists y, ~P y)); case. *)
    (* case: (EM (exists y, ~P y)) => [[y notPy]| nonotPy]; first by exists y. *)
    move : (EM (exists y, ~P y)).
    case.
    + move => [y notPy].
      exists y.
        by [].
    + move => nonotPy.

      (* exists d => _ y; case: (EM (P y)) => // notPy. *)
      exists d.
      move => foo y.
      move : (EM (P y)).
      case => // notPy.

      (* by case: nonotPy; exists y. *)
      move : nonotPy.
      case.
      exists y.
        by [].
  Qed.
End Smullyan_drinker.

Section Equality.
  Variable f : nat -> nat.

  Hypothesis f00 : f 0 = 0.
  Lemma fkk : forall k, k = 0 -> f k = k.
  Proof.
    move => k k0.
    by rewrite k0.
  Qed.

  Lemma fkk2 : forall k, k = 0 -> f k = k.
  Proof.
    (* move=> k hyp; rewrite {} hyp. by []. *)
    by move=> k ->.
  Qed.

  Variables (D : eqType) (x y : D).
  Lemma eq_prop_bool : x = y -> x == y.
  Proof.
      by move/eqP.
  Qed.

  Lemma eq_bool_prop : x == y -> x = y.
  Proof. by move/eqP. Qed.
End Equality.

Section Using_Definition.
  Variable U : Type.
  Definition set := U -> Prop.
  Definition subset (A B : set) := forall x, A x -> B x.
  Definition transitive (T : Type) (R : T -> T -> Prop) :=
    forall x y z, R x y -> R y z -> R x z.

  Lemma subset_trans : transitive set subset.
  Proof.
    (* rewrite /transitive /subset. equivalent to unfold transitive, subset *)
    (* rewrite /transitive /subset; move=> x y z subxy subyz t xt. *)
    (*
    rewrite / transitive.
    rewrite / subset.
    move => x y z subxy subyz t xt.
    *)
    rewrite /transitive /subset => x y z subxy subyz t xt.
      by apply: subyz; apply: subxy.
  Qed.

  Lemma subset_trans2 : transitive set subset.
  Proof.
    (* move forces unfolding *)
    move=> x y z subxy subyz t.
      by move/subxy; move/subyz.
  Qed.
End Using_Definition.


Require Export GeoCoq.Elements.OriginalProofs.lemma_congruenceflip.
Require Export GeoCoq.Elements.OriginalProofs.lemma_lessthancongruence.
Require Export GeoCoq.Elements.OriginalProofs.lemma_outerconnectivity.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_trichotomy1 :
   forall A B C D,
   ~ Lt A B C D -> ~ Lt C D A B -> neq A B -> neq C D ->
   Cong A B C D.
Proof.
intros.
assert (neq B A) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists P, (BetS B A P /\ Cong A P A B)) by (conclude lemma_extension);destruct Tf as [P];spliter.
assert (BetS P A B) by (conclude axiom_betweennesssymmetry).
assert (neq A P) by (forward_using lemma_betweennotequal).
assert (neq P A) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists E, (BetS P A E /\ Cong A E C D)) by (conclude lemma_extension);destruct Tf as [E];spliter.
assert (~ BetS A B E).
 {
 intro.
 assert (Cong A B A B) by (conclude cn_congruencereflexive).
 assert (Lt A B A E) by (conclude_def Lt ).
 assert (Lt A B C D) by (conclude lemma_lessthancongruence).
 contradict.
 }
assert (~ BetS A E B).
 {
 intro.
 assert (Lt C D A B) by (conclude_def Lt ).
 contradict.
 }
assert (eq E B) by (conclude lemma_outerconnectivity).
assert (Cong A B A B) by (conclude cn_congruencereflexive).
assert (Cong A B A E) by (conclude cn_equalitysub).
assert (Cong A B C D) by (conclude lemma_congruencetransitive).
close.
Qed.

End Euclid.


Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Maps.

Definition state := total_map nat.

Definition empty_state : state := t_empty 0.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Definition X : id := Id 0.
Definition Y : id := Id 1.
Definition Z : id := Id 2.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2  => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2   => leb (aeval st a1) (aeval st a2)
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  end.

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).

(* Examples *)

Definition fact_in_coq : com :=
  Z ::= AId X;;
  Y ::= ANum 1;;
  WHILE BNot (BEq (AId Z) (ANum 0)) DO
    Y ::= AMult (AId Y) (AId Z);;
    Z ::= AMinus (AId Z) (ANum 1)
  END.

Definition plus2 : com :=
  X ::= (APlus (AId X) (ANum 2)).

Definition XtimesYinZ : com :=
  Z ::= (AMult (AId X) (AId Y)).

Definition subtract_slowly_body : com :=
  Z ::= AMinus (AId Z) (ANum 1) ;;
  X ::= AMinus (AId X) (ANum 1).

Definition subtract_slowly : com :=
  WHILE BNot (BEq (AId X) (ANum 0)) DO
    subtract_slowly_body
  END.

Definition subtract_3_from_5_slowly : com :=
  X ::= ANum 3 ;;
  Z ::= ANum 5 ;;
  subtract_slowly.

Definition infinite_loop : com :=
  WHILE BTrue DO
    SKIP
  END.

(* ----------------------------------------------------------------- *)
(** *** Operational Semantics *)
(*

                           ----------------                            (E_Skip)
                           SKIP / st \\ st

                           aeval st a1 = n
                   --------------------------------                     (E_Ass)
                   x := a1 / st \\ (t_update st x n)

                           c1 / st \\ st'
                          c2 / st' \\ st''
                         -------------------                            (E_Seq)
                         c1;;c2 / st \\ st''

                          beval st b1 = true
                           c1 / st \\ st'
                -------------------------------------                (E_IfTrue)
                IF b1 THEN c1 ELSE c2 FI / st \\ st'

                         beval st b1 = false
                           c2 / st \\ st'
                -------------------------------------               (E_IfFalse)
                IF b1 THEN c1 ELSE c2 FI / st \\ st'

                         beval st b = false
                    ------------------------------                 (E_WhileEnd)
                    WHILE b DO c END / st \\ st

                          beval st b = true
                           c / st \\ st'
                  WHILE b DO c END / st' \\ st''
                  ---------------------------------               (E_WhileLoop)
                    WHILE b DO c END / st \\ st''
*)

Reserved Notation "c1 '/' st '\\' st'"
                  (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st \\ st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      (x ::= a1) / st \\ (t_update st x n)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  \\ st' ->
      c2 / st' \\ st'' ->
      (c1 ;; c2) / st \\ st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      c1 / st \\ st' ->
      (IFB b THEN c1 ELSE c2 FI) / st \\ st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      c2 / st \\ st' ->
      (IFB b THEN c1 ELSE c2 FI) / st \\ st'
  | E_WhileEnd : forall b st c,
      beval st b = false ->
      (WHILE b DO c END) / st \\ st
  | E_WhileLoop : forall st st' st'' b c,
      beval st b = true ->
      c / st \\ st' ->
      (WHILE b DO c END) / st' \\ st'' ->
      (WHILE b DO c END) / st \\ st''
  where "c1 '/' st '\\' st'" := (ceval c1 st st').

Example ceval_example1:
    (X ::= ANum 2;;
     IFB BLe (AId X) (ANum 1)
       THEN Y ::= ANum 3
       ELSE Z ::= ANum 4
     FI)
   / empty_state
   \\ (t_update (t_update empty_state X 2) Z 4).
Proof.
  apply E_Seq with (t_update empty_state X 2).
    apply E_Ass. reflexivity.
    apply E_IfFalse.
      reflexivity.
      apply E_Ass. reflexivity.
Qed.

Example ceval_example2:
    (X ::= ANum 0;; Y ::= ANum 1;; Z ::= ANum 2) / empty_state \\
    (t_update (t_update (t_update empty_state X 0) Y 1) Z 2).
Proof.
  (* FILL IN HERE *) Admitted.

Theorem ceval_deterministic: forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2.
  induction E1;
           intros st2 E2; inversion E2; subst.
  - (* E_Skip *) reflexivity.
  - (* E_Ass *) reflexivity.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption.
  - (* E_IfTrue, b1 evaluates to true *)
      apply IHE1. assumption.
  - (* E_IfTrue,  b1 evaluates to false (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_IfFalse, b1 evaluates to true (contradiction) *)
    rewrite H in H5. inversion H5.
  - (* E_IfFalse, b1 evaluates to false *)
      apply IHE1. assumption.
  - (* E_WhileEnd, b1 evaluates to false *)
    reflexivity.
  - (* E_WhileEnd, b1 evaluates to true (contradiction) *)
    rewrite H in H2. inversion H2.
  - (* E_WhileLoop, b1 evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* E_WhileLoop, b1 evaluates to true *)
      assert (st' = st'0) as EQ1.
      { (* Proof of assertion *) apply IHE1_1; assumption. }
      subst st'0.
      apply IHE1_2. assumption.  Qed.

Theorem plus2_spec : forall st n st',
  st X = n ->
  plus2 / st \\ st' ->
  st' X = n + 2.
Proof.
  intros st n st' HX Heval.
  inversion Heval. subst. clear Heval. simpl.
  apply t_update_eq.
Qed.

Theorem loop_never_stops : forall st st',
  ~(infinite_loop / st \\ st').
Proof.
  intros st st' contra. unfold infinite_loop in contra.
  remember (WHILE BTrue DO SKIP END) as loopdef
           eqn:Heqloopdef.
  (* FILL IN HERE *) Admitted.

Fixpoint no_whiles (c : com) : bool :=
  match c with
  | SKIP => true
  | _ ::= _ => true
  | c1 ;; c2 => andb (no_whiles c1) (no_whiles c2)
  | IFB _ THEN ct ELSE cf FI => andb (no_whiles ct) (no_whiles cf)
  | WHILE _ DO _ END  => false
  end.


From Undecidability.Synthetic Require Import DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts.
From Undecidability.Shared Require Import Dec.

Require Import List.
Import ListNotations.

#[local] Coercion dec2bool P (d: dec P) := if d then true else false.

Lemma enumerable_enum {X} {p : X -> Prop} :
  enumerable p <-> list_enumerable p.
Proof.
  split. eapply enumerable_list_enumerable. eapply list_enumerable_enumerable.
Qed.

Lemma enumerable_disj X (p q : X -> Prop) :
  enumerable p -> enumerable q -> enumerable (fun x => p x \/ q x).
Proof.
  intros [Lp H] % enumerable_enum [Lq H0] % enumerable_enum.
  eapply enumerable_enum.
  exists (fix f n := match n with 0 => [] | S n => f n ++ (Lp n) ++ (Lq n) end).
  intros x. split.
  - intros [H1 | H1].
    * eapply H in H1 as [m]. exists (1 + m). cbn.
      apply in_or_app. right. apply in_or_app. now left.
    * eapply H0 in H1 as [m]. exists (1 + m). cbn.
      apply in_or_app. right. apply in_or_app. now right.
  - intros [m]. induction m.
    * inversion H1.
    * apply in_app_iff in H1.
      destruct H1 as [?|H1]; [now auto|].
      apply in_app_iff in H1.
      unfold list_enumerator in *; firstorder easy.
Qed.

Lemma enumerable_conj X (p q : X -> Prop) :
  discrete X -> enumerable p -> enumerable q -> enumerable (fun x => p x /\ q x).
Proof.
  intros [] % discrete_iff [Lp] % enumerable_enum [Lq] % enumerable_enum.
  eapply enumerable_enum.
  exists (fix f n := match n with 0 => [] | S n => f n ++ (filter (fun x => Dec (In x (cumul Lq n))) (cumul Lp n)) end).
  intros x. split.
  + intros []. eapply (list_enumerator_to_cumul H) in H1 as [m1].
    eapply (list_enumerator_to_cumul H0) in H2 as [m2].
    exists (1 + m1 + m2). cbn. apply in_or_app. right.
    apply filter_In. split.
    * eapply cum_ge'; eauto; lia.
    * eapply Dec_auto. eapply cum_ge'; eauto; lia.
  + intros [m]. induction m.
    * inversion H1.
    * apply in_app_iff in H1. destruct H1 as [?|H1]; [now auto|].
      apply filter_In in H1. destruct H1 as [? H1].
      split.
      ** eapply (list_enumerator_to_cumul H). eauto.
      ** destruct (Dec _) in H1; [|easy].
         eapply (list_enumerator_to_cumul H0). eauto.
Qed.

Lemma projection X Y (p : X * Y -> Prop) :
  enumerable p -> enumerable (fun x => exists y, p (x,y)).
Proof.
  intros [f].
  exists (fun n => match f n with Some (x, y) => Some x | None => None end).
  intros; split.
  - intros [y ?]. eapply H in H0 as [n]. exists n. now rewrite H0.
  - intros [n ?]. destruct (f n) as [ [] | ] eqn:E; inversion H0; subst.
    exists y. eapply H. eauto.
Qed.

Lemma projection' X Y (p : X * Y -> Prop) :
  enumerable p -> enumerable (fun y => exists x, p (x,y)).
Proof.
  intros [f].
  exists (fun n => match f n with Some (x, y) => Some y | None => None end).
  intros y; split.
  - intros [x ?]. eapply H in H0 as [n]. exists n. now rewrite H0.
  - intros [n ?]. destruct (f n) as [ [] | ] eqn:E; inversion H0; subst.
    exists x. eapply H. eauto.
Qed.


From Hammer Require Export Tactics Reflect.
Require Import Recdef.

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

Class DecTotalOrder (A : Type) := {
  leb : A -> A -> bool;
  leb_total : forall x y, leb x y \/ leb y x;
  leb_antisym : forall x y, leb x y -> leb y x -> x = y;
  leb_trans : forall x y z, leb x y -> leb y z -> leb x z }.

Lemma leb_refl `{DecTotalOrder} : forall x, leb x x.
Proof.
  intro x; destruct (leb_total x x); auto.
Qed.

Lemma lem_neg_leb `{DecTotalOrder} :
  forall x y, ~ (leb x y) -> leb y x.
Proof.
  qauto use: leb_total.
Qed.

Definition leb_total_dec `{DecTotalOrder} : forall x y, {leb x y}+{leb y x}.
  intros x y.
  sdestruct (leb x y).
  - left; constructor.
  - right; destruct (leb_total x y); auto.
Defined.

Definition eq_dec {A} `{DecTotalOrder A} : forall x y : A, {x = y}+{x <> y}.
  intros x y.
  sdestruct (leb x y).
  - sdestruct (leb y x).
    + auto using leb_antisym.
    + sauto.
  - sdestruct (leb y x).
    + sauto.
    + destruct (leb_total_dec x y); auto.
Defined.

Definition eqb `{DecTotalOrder} x y : bool :=
  if eq_dec x y then
    true
  else
    false.

Definition ltb `{DecTotalOrder} x y : bool :=
  leb x y && negb (eqb x y).

Definition leb_ltb_dec `{DecTotalOrder} x y : {leb x y}+{ltb y x}.
  destruct (leb_total_dec x y).
  - left; sauto.
  - unfold ltb, negb, eqb.
    destruct (eq_dec y x).
    + left; sauto.
    + right; sauto brefl: on.
Defined.

Lemma lem_ltb_leb_incl `{DecTotalOrder} :
  forall x y : A, ltb x y -> leb x y.
Proof.
  sauto brefl: on unfold: ltb.
Qed.

Function lexb `{DecTotalOrder} l1 l2 :=
  match l1 with
  | [] => true
  | x :: l1' =>
    match l2 with
    | [] => false
    | y :: l2' =>
      if eq_dec x y then
        lexb l1' l2'
      else
        leb x y
    end
  end.

Instance dto_list {A} `{DecTotalOrder A} : DecTotalOrder (list A).
Proof.
  apply Build_DecTotalOrder with (leb := lexb).
  - induction x; sauto.
  - intros x y.
    functional induction (lexb x y).
    + sauto inv: list.
    + sauto.
    + sauto.
    + sauto inv: - use: leb_antisym.
  - intros x y.
    functional induction (lexb x y); sauto.
Defined.

Instance dto_nat : DecTotalOrder nat.
Proof.
  apply Build_DecTotalOrder with (leb := Nat.leb);
    induction x; sauto.
Defined.