Require Import FunctionalExtensionality.

(* Comment conserver les notations en dehors de la définition ?
   Utilise les univers polymorphiques pour permettre d'avoir une catégorie de catégories.
*)
Reserved Notation "a ~> b" (at level 90, right associativity).
Reserved Notation "f >> g" (at level 40, left associativity).
Reserved Notation "a ≃ b" (at level 90, right associativity).

Cumulative Polymorphic Class Category := {
    ob : Type;
    hom : ob -> ob -> Type where "a ~> b" := (hom a b);
    id (a: ob) : a~>a;
    comp {a b c: ob} : a~>b -> b~>c -> a~>c where "f >> g" := (comp f g);

    cat_id_r {a b: ob} (f: a~>b) : f >> (id b) = f;
    cat_id_l {a b: ob} (f: a~>b) : (id a) >> f = f;
    cat_comp_assoc {a b c d: ob} (f: a~>b) (g: b~>c) (h: c~>d) : (f >> g) >> h = f >> (g >> h);
}.
Notation "a ~> b" := (hom a b).
Notation "f >> g" := (comp f g).
Notation "[ C ]" := (@ob C) (at level 90, no associativity).

Instance op_cat (C: Category) : Category.
apply (Build_Category ob (fun a b => b ~> a) id (fun _ _ _ f g => comp g f)) ; intros.
- apply cat_id_l.
- apply cat_id_r.
- apply eq_sym, cat_comp_assoc.
Defined.

Notation "C ^op" := (op_cat C) (at level 9, no associativity).

Lemma cat_op_involutive (C: Category) : (C^op)^op = C.
unfold op_cat. destruct C. simpl. f_equal.
repeat (apply functional_extensionality_dep ; intro).
apply eq_sym_involutive.
Qed.

Instance unit_cat : Category.
apply (Build_Category unit (fun _ _ => unit) (fun x => x) (fun _ _ _ _ _ => tt))
  ; intros ; induction f ; trivial.
Defined.

Notation "'*" := unit_cat (at level 5, no associativity).

(* We should be able to avoid duplicates by defining duals with op_cat *)

Definition is_section    {C: Category} {a b: ob} (f: a ~> b) (g: b ~> a) := g >> f = id b.
Definition is_retraction {C: Category} {a b: ob} (f: a ~> b) (g: b ~> a) := f >> g = id a.
Definition is_inverse    {C: Category} {a b: ob} (f: a ~> b) (g: b ~> a) := is_section f g /\ is_retraction f g.

Definition is_mono {C: Category} {a b: ob} (f: a ~> b) :=
    forall (x: ob) (g g': x ~> a), (g >> f = g' >> f) -> (g = g').

Definition is_epi {C: Category} {a b: ob} (f: a ~> b) :=
    forall (x: ob) (g g': b ~> x), (f >> g = f >> g') -> (g = g').

Definition is_iso {C: Category} {a b: ob} (f: a ~> b) :=
    exists g : b ~> a, (f >> g = id a) /\ (g >> f = id b).

Lemma retraction_implies_mono {C: Category} {a b: ob} (f: a ~> b) (g: b ~> a) : is_retraction f g -> is_mono f.
Proof.
unfold is_retraction, is_mono.
intros e_fg x h h' e_hf.
assert (hfg : h >> f >> g = h' >> f >> g).
now rewrite e_hf.
now rewrite !cat_comp_assoc, e_fg, !cat_id_r in hfg.
Qed.

Lemma section_implies_epi {C: Category} {a b: ob} (f: a ~> b) (g: b ~> a) : is_section f g -> is_epi f.
Proof.
unfold is_section, is_epi.
intros e_gh x h h' e_fh.
assert (hfg : g >> (f >> h) = g >> (f >> h')).
now rewrite e_fh.
now rewrite <-!cat_comp_assoc, e_gh, !cat_id_l in hfg.
Qed.

Lemma iso_to_mono {C: Category} {a b: ob} (f: a ~> b) (h : is_iso f) : is_mono f.
Proof.
unfold is_mono. intros. destruct h as [f']. destruct H0.
now rewrite <- cat_id_r, <- (cat_id_r g), <- H0, <- cat_comp_assoc, H, cat_comp_assoc.
Qed.

Lemma iso_to_epi {C: Category} {a b: ob} (f: a ~> b) (h : is_iso f) : is_epi f.
Proof.
unfold is_epi. intros. destruct h as [f']. destruct H0.
now rewrite <- cat_id_l, <- (cat_id_l g), <- H1, cat_comp_assoc, H, <- cat_comp_assoc.
Qed.

Lemma comp_iso_is_iso {C: Category} {a b c : ob} (f: a ~> b) (g : b ~> c) (iso_f : is_iso f) (iso_g : is_iso g) :
    is_iso (f >> g).
Proof.
destruct iso_f as [f']. destruct iso_g as [g']. exists (g' >> f'). destruct H, H0.
rewrite cat_comp_assoc, cat_comp_assoc, <- (cat_comp_assoc _ g' _), <- (cat_comp_assoc _ f _), H0, H1.
now rewrite !cat_id_l, H, H2.
Qed.

Definition ob_isom {C: Category} (a b: ob) := exists g : a ~> b, is_iso g.
Notation "a ≃ b" := (ob_isom a b) (at level 90, right associativity).

Lemma isom_sym {C: Category} (a b: ob) : a ≃ b -> b ≃ a.
Proof.
intro. destruct H as [f]. destruct H as [f']. exists f'. unfold is_iso. exists f. easy.
Qed.

Lemma iso_refl {C: Category} (a : ob) : a ≃ a.
Proof.
exists (id a). unfold is_iso. exists (id a).
now rewrite !cat_id_l.
Qed.

Lemma iso_trans {C: Category} (a b c : ob) : a ≃ b -> b ≃ c -> a ≃ c.
Proof.
intros. destruct H as [f], H0 as [g]. exists (f >> g).
now apply comp_iso_is_iso.
Qed.

Definition is_inv {C: Category} {a b: ob} (f: a ~> b) (g : b ~> a ):= f >> g = id a /\ g >> f = id b.

Lemma unique_inv {C: Category} {a b: ob} (f: a ~> b) (g h: b ~> a ) :
    is_inv f g -> is_inv f h -> g = h.
Proof.
intros. destruct H, H0.
now rewrite <- cat_id_r, <- H, <- cat_comp_assoc, H2, cat_id_l.
Qed.

Lemma op_isom_iff_isom {C: Category} (a b: [C]) :
    @ob_isom C^op a b <-> a ≃ b.
Proof.
split; intro; destruct H as [f]; destruct H as [f']; exists f'; unfold is_iso; exists f; easy.
Qed.


From VFA Require Import Perm.

Module Type PRIQUEUE.
  Parameter priqueue: Type.
  Definition key := nat.
  Parameter empty: priqueue.
  Parameter insert: key -> priqueue -> priqueue.
  Parameter delete_max: priqueue -> option (key * priqueue).
  Parameter merge: priqueue -> priqueue -> priqueue.

  Parameter priq: priqueue -> Prop.
  Parameter Abs: priqueue -> list key -> Prop.

  Axiom can_relate: forall p, priq p -> exists al, Abs p al.
  Axiom abs_perm: forall p al bl,
   priq p -> Abs p al -> Abs p bl -> Permutation al bl.
  Axiom empty_priq: priq empty.
  Axiom empty_relate: Abs empty nil.
  Axiom insert_priq: forall k p, priq p -> priq (insert k p).
  Axiom insert_relate:
        forall p al k, priq p -> Abs p al -> Abs (insert k p) (k::al).
  Axiom delete_max_None_relate:
        forall p, priq p -> (Abs p nil <-> delete_max p = None).
  Axiom delete_max_Some_priq:
      forall p q k, priq p -> delete_max p = Some(k,q) -> priq q.
  Axiom delete_max_Some_relate:
  forall (p q: priqueue) k (pl ql: list key), priq p ->
   Abs p pl ->
   delete_max p = Some (k,q) ->
   Abs q ql ->
   Permutation pl (k::ql) /\ Forall (ge k) ql.
  Axiom merge_priq: forall p q, priq p -> priq q -> priq (merge p q).
  Axiom merge_relate:
    forall p q pl ql al,
       priq p -> priq q ->
       Abs p pl -> Abs q ql -> Abs (merge p q) al ->
       Permutation al (pl++ql).
End PRIQUEUE.

Module List_Priqueue <: PRIQUEUE.

  Fixpoint select (i: nat) (l: list nat) : (nat * list nat) :=
  match l with
  | nil    => (i, nil)
  | h :: t => if i >=? h
                 then let (j, l') := select i t in (j, h::l')
                 else let (j, l') := select h t in (j, i::l')
  end.

  Lemma select_perm: forall i l,
    let (j,r) := select i l in Permutation (i::l) (j::r).
  Proof.
  intros i l; revert i.
  induction l; intros; simpl in *.
  - constructor.
    constructor.
  - bdestruct (i >=? a).
    + destruct (select i l) eqn:E.
      change (i :: a :: l) with ([i] ++ [a] ++ l).
      change (n :: a :: l0) with ([n] ++ [a] ++ l0).
      apply perm_trans with ([a] ++ [i] ++ l).
      * apply Permutation_app_swap_app.
      * apply perm_trans with ([a] ++ [n] ++ l0).
        ** simpl.
           apply perm_skip.
           specialize (IHl i).
           rewrite E in IHl.
           apply IHl.
        ** apply Permutation_app_swap_app.
    + destruct (select a l) eqn:E.
           specialize (IHl a).
           rewrite E in IHl.
      change (n :: i :: l0) with ([n] ++ [i] ++ l0).
      apply perm_trans with ([i] ++ [n] ++ l0).
      * simpl.
        apply perm_skip.
        apply IHl.
      * apply Permutation_app_swap_app.
  Qed.

  Lemma select_biggest_aux: forall i al j bl,
      Forall (fun x => j >= x) bl ->
      select i al = (j, bl) ->
      j >= i.
  Proof.
    intros i al. revert i.
    induction al; simpl; intros i j bl Hall H.
    - injection H as Hl Hr; subst.
      lia.
    - bdestruct (i >=? a).
      + destruct (select i al) eqn:E.
        injection H as Hl Hr; subst.
        inversion Hall; subst.
        eapply IHal.
          apply H3.
          apply E.
      + destruct (select a al) eqn:E.
        injection H as Hl Hr; subst.
        inversion Hall; subst.
        assumption.
  Qed.

  Theorem select_biggest: forall i al j bl,
    select i al = (j, bl) ->
    Forall (fun x => j >= x) bl.
  Proof.
    intros i al; revert i; induction al; intros; simpl in *.
    - injection H as ? ?; subst.
      constructor.
    - bdestruct (i >=? a).
      + destruct (select i al) eqn:E.
        injection H as ? ?; subst.
        constructor.
        * assert (G: j >= i). {
            eapply select_biggest_aux.
            eapply IHal.
            apply E.
            apply E.
          }
          lia.
        * eapply IHal.
          apply E.
      + destruct (select a al) eqn:E.
        injection H as ? ?; subst.
        constructor.
        * assert (G: j >= a). {
            eapply select_biggest_aux.
            eapply IHal.
            apply E.
            apply E.
          }
          lia.
        * eapply IHal.
          apply E.
  Qed.

  Definition key := nat.
  Definition priqueue := list key.
  Definition empty : priqueue := nil.
  Definition insert (k: key) (p: priqueue) := k :: p.
  Definition delete_max (p: priqueue) :=
    match p with
    | nil     => None
    | i :: p' => Some (select i p')
    end.
  Definition merge (p q: priqueue) : priqueue := p ++ q.

  Definition priq (p: priqueue) := True.

  Inductive Abs': priqueue -> list key -> Prop :=
    | Abs_intro: forall p, Abs' p p.

  Definition Abs := Abs'.

  Lemma can_relate : forall p, priq p -> exists al, Abs p al.
  Proof.
    intros. exists p; constructor.
  Qed.

  Lemma delete_max_None_relate: forall p,
        priq p ->
        (Abs p nil <-> delete_max p = None).
  Proof.
    intros. split; intros.
    - inversion H0; subst. reflexivity.
    - unfold delete_max in *.
      destruct p.
      + constructor.
      + discriminate.
  Qed.

  Lemma delete_max_Some_relate: forall (p q: priqueue) k (pl ql: list key),
     priq p ->
     Abs p pl ->
     delete_max p = Some (k,q) ->
     Abs q ql ->
     Permutation pl (k::ql) /\ Forall (ge k) ql.
  Proof.
    intros.
    clear H.
    inversion H0; subst. inversion H2; subst. clear H0 H2.
    unfold delete_max in *.
    destruct pl; try discriminate.
    injection H1 as H1.
    split.
    - assert (G: let (k, ql) := select k0 pl in Permutation (k0 :: pl) (k :: ql)). {
        apply select_perm.
      }
      rewrite H1 in G.
      assumption.
    - eapply select_biggest.
      apply H1.
  Qed.

  Lemma merge_priq: forall p q,
    priq p -> priq q -> priq (merge p q).
  Proof. intros. constructor. Qed.

  Lemma merge_relate: forall p q pl ql al,
         priq p -> priq q ->
         Abs p pl -> Abs q ql -> Abs (merge p q) al ->
         Permutation al (pl ++ ql).
  Proof.
    intros.
    inversion H1; subst.
    inversion H2; subst.
    inversion H3; subst.
    unfold merge.
    apply Permutation_refl.
  Qed.

  Lemma abs_perm: forall p al bl,
    priq p -> Abs p al -> Abs p bl -> Permutation al bl.
  Proof.
    intros.
    inv H0. inv H1. apply Permutation_refl.
  Qed.

  Lemma empty_priq: priq empty.
  Proof. constructor. Qed.

  Lemma empty_relate: Abs empty nil.
  Proof. constructor. Qed.

  Lemma insert_priq: forall k p, priq p -> priq (insert k p).
  Proof. intros; constructor. Qed.

  Lemma insert_relate: forall p al k,
    priq p -> Abs p al -> Abs (insert k p) (k :: al).
  Proof. intros. unfold insert. inv H0. constructor. Qed.

  Lemma delete_max_Some_priq: forall p q k,
    priq p -> delete_max p = Some(k, q) -> priq q.
  Proof. constructor. Qed.

End List_Priqueue.


Add LoadPath "~/fcf/src".
Add LoadPath "./Dist".
Require Import CpdtTactics.
Require Import List.
Require Import FCF.Rat.
Require Import FCF.Fold.

Require Import Coq.Lists.ListSet.
Require Import SetLems.
Require Import PIOA.
Require Import PIOARel.
Require Import Dist.
Require Import DistRel.
Require Import Program.
Require Import FCF.EqDec.

(* make Labels an open sum *)
Inductive Lab {L : Set} : Set :=
  | Recv :  Lab
  | Send :  bool -> Lab
  | Other : L -> Lab .

Definition tst_trans {L : Set} (n : option bool) (l : @Lab L) :=
  match n, l with
  | None, Recv =>
    Some (x <- ((1/2, true) :: (1/2, false) :: nil); ret (Some x))
  | Some m, Recv => Some (ret (Some m))
  | Some m, Send m' =>
    if eqb m m' then Some (ret (Some m)) else None
  | None, Send _ => None
  | _, Other _ => None
  end.

Definition tst {L : Set} :=
  @mkPIOA (@Lab L) (option bool) (fun l => match l with | Recv => true | _ => false end)
          (fun l => match l with | Send _ => true | _ => false end)
          (fun _ => false) None tst_trans.

Definition tst2_trans {L : Set} (n : option bool) (l : @Lab L) :=
  match n, l with
  | None, Recv =>
    Some (x <- ((1/2, true) :: (1/2, false) :: nil); ret (Some (negb x)))
  | Some m, Recv => Some (ret (Some m))
  | Some m, Send m' =>
    if eqb m m' then Some (ret (Some m)) else None
  | None, Send _ => None
  | _, Other _ => None
  end.

Definition tst2 {L : Set} :=
  @mkPIOA (@Lab L) (option bool) (fun l => match l with | Recv => true | _ => false end)
          (fun l => match l with | Send _ => true | _ => false end)
          (fun _ => false) None tst2_trans.

Lemma impltst {L : Set} : implement (@tst L) (@tst2 L).

  eapply simpl_implement.

  (* Labels match up. *)
  crush.
  crush.
  crush.

  (* Start states match up. *)
  instantiate (1 := fun s => match s with
                             | Some b => Some b
                             | None => None
                             end).
  crush.

  (* Transition function lines up. *)
  simpl.
  unfold option_lift; simpl.
  intros.

  (* Case analysis on label and state *)
  induction l.

  (* Recv *)
  induction s.
  simpl.
  right.
  exists (ret Some a).
  exists (ret Some a).
  crush.
  rewrite bind_ret.
  unfold distEquiv; crush.
  simpl.
  right.
  exists ((x <- [(1 / 2, true); (1 / 2, false)]; ret Some x)).
  exists ((x <- [(1 / 2, true); (1 / 2, false)]; ret Some (negb x))).
  crush.
  rewrite bindAssoc.
  unfold distBind; simpl.
  unfold distJoin; simpl.
  unfold distEquiv; crush.
  unfold integ.
  repeat rewrite sumList_cons; simpl.
  unfold sumList; simpl.
  repeat rewrite ratMult_1_r.
  repeat rewrite <- ratAdd_0_r.
  rewrite ratAdd_comm.
  reflexivity.

  (* Send *)
  induction s.
  simpl.
  destruct (eqb a b).
  right.
  exists (ret Some a), (ret Some a).
  crush.
  rewrite bind_ret.
  unfold distEquiv; crush.
  left; crush.
  simpl.
  left; crush.

  (* Other *)
  destruct s; simpl;
  left; crush.

Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable oS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defsameside_1 : (forall P Q A B : Universe, (exists X U V : Universe, (oS_ P Q A B -> (col_ A B U /\ (col_ A B V /\ (betS_ P U X /\ (betS_ Q V X /\ (~(col_ A B P) /\ ~(col_ A B Q))))))))).
Variable defsameside2_2 : (forall P Q A B X U V : Universe, ((col_ A B U /\ (col_ A B V /\ (betS_ P U X /\ (betS_ Q V X /\ (~(col_ A B P) /\ ~(col_ A B Q)))))) -> oS_ P Q A B)).
Variable lemma_NCdistinct_3 : (forall A B C : Universe, (~(col_ A B C) -> (A <> B /\ (B <> C /\ (A <> C /\ (B <> A /\ (C <> B /\ C <> A))))))).
Variable defcollinear_4 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_5 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_6 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_7 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_8 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_9 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_10 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_NChelper_11 : (forall A B C P Q : Universe, ((~(col_ A B C) /\ (col_ A B P /\ (col_ A B Q /\ P <> Q))) -> ~(col_ P Q C))).
Variable lemma_collinearorder_12 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_inequalitysymmetric_13 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_collinear4_14 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).

Theorem lemma_samesidecollinear_15 : (forall A B C P Q : Universe, ((oS_ P Q A B /\ (col_ A B C /\ A <> C)) -> oS_ P Q A C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e383m421_17limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


(* Calculation for a language with interrupts and (global) state. *)
Require Import List.
Require Import Tactics.

Require Import ZArith.
Local Open Scope Z_scope.

Inductive Expr : Set := Val (n : Z) | Add (e1 e2 : Expr) | Throw | Catch (e h : Expr)
                      | Seqn (e1 e2 : Expr) | Block (e : Expr) | Unblock (e : Expr)
                      | Put (e : Expr) | Get.

Reserved Notation "x ⇓[ i , q , p ] y" (at level 70, no associativity).
Inductive Status : Set := B | U.

Definition State := Z.

Inductive eval : Expr -> State -> Status -> option Z -> State -> Prop :=
| eval_val n i p : Val n ⇓[i,p,p] Some n
| eval_throw i p : Throw ⇓[i,p,p] None
| eval_add1 x y n m i q p r : x ⇓[i,p,q] Some n -> y ⇓[i,q,r] Some m
                              -> Add x y ⇓[i,p,r] Some (n + m)
| eval_add2 x y i q p : x ⇓[i,p,q] None -> Add x y ⇓[i,p,q] None
| eval_add3 x y n i q p r : x ⇓[i,p,q] Some n -> y ⇓[i,q,r] None -> Add x y ⇓[i,p,r] None
| eval_seq1 x y n v i q p r : x ⇓[i,p,q] Some n -> y ⇓[i,q,r] v -> Seqn x y ⇓[i,p,r] v
| eval_seq2  x y i q p : x ⇓[i,p,q] None -> Seqn x y ⇓[i,p,q] None
| eval_catch1 x y n i q p: x ⇓[i,p,q] Some n -> Catch x y ⇓[i,p,q] Some n
| eval_catch2 x y v i q p r : x ⇓[i,p,q] None -> y ⇓[i,q,r] v -> Catch x y ⇓[i,p,r] v
| eval_block x v i q p : x ⇓[B,p,q] v -> Block x ⇓[i,p,q] v
| eval_unblock x v i q p : x ⇓[U,p,q] v -> Unblock x ⇓[i,p,q] v
| eval_int x p : x ⇓[U,p,p] None
| eval_put1 x n i q p  : x ⇓[i,p,q] Some n -> Put x ⇓[i,p,n] Some n
| eval_put2 x i q p  : x ⇓[i,p,q] None -> Put x ⇓[i,p,q] None
| eval_get i p  : Get ⇓[i,p,p] Some p
where "x ⇓[ i , q , p ] y" := (eval x q i y p).

Hint Constructors eval.

Inductive Instr : Set := PUSH (n : Z) | ADD | THROW | UNMARK | MARK (h : list Instr)
                       | POP | RESET | BLOCK | UNBLOCK | PUT | GET.

Definition Code := list Instr.

Import ListNotations.

Fixpoint comp' (e : Expr) (c : Code) : Code :=
  match e with
    | Val n => PUSH n :: c
    | Add x y => comp' x (comp' y (ADD :: c))
    | Throw => [THROW]
    | Catch e1 e2 => MARK (comp' e2 c) :: comp' e1 (UNMARK :: c)
    | Seqn e1 e2 => comp' e1 (POP :: comp' e2 c)
    | Block e => BLOCK :: comp' e (RESET :: c)
    | Unblock e => UNBLOCK :: comp' e (RESET :: c)
    | Put e => comp' e (PUT :: c)
    | Get => GET :: c
  end.

Definition comp (e : Expr) : Code := comp' e nil.

Inductive Elem : Set := VAL (n : Z) | HAN (c : Code) | INT (s  : Status).

Definition Stack : Set := list Elem.

Inductive Conf : Set := conf (c : Code) (s : Stack) (q : State) (i : Status)
                      | fail (s : Stack) (q : State) (i : Status).

Notation "⟨ c , s , q , i ⟩" := (conf c s q i).
Notation "⟪ s , q , i ⟫" := (fail s q i ).

Reserved Notation "x ==> y" (at level 80, no associativity).
Inductive VM : Conf -> Conf -> Prop :=
 | vm_push n c s q i : ⟨PUSH n :: c, s, q, i⟩ ==> ⟨ c , VAL n :: s, q, i ⟩
 | vm_push_int n c s q: ⟨PUSH n :: c, s, q, U⟩ ==> ⟪s, q, U⟫
 | vm_add c s m n p i : ⟨ADD :: c, VAL m :: VAL n :: s,p, i⟩ ==> ⟨c, VAL (n + m) :: s, p, i⟩
 | vm_fail_val  m s p i : ⟪VAL m :: s, p, i⟫ ==> ⟪s, p, i⟫
 | vm_throw c s p i : ⟨ THROW :: c, s, p, i⟩ ==> ⟪s, p, i⟫
 | vm_fail_han s h p i : ⟪HAN h :: s, p, i⟫ ==> ⟨h,s,p,i⟩
 | vm_unmark c n h p s i : ⟨UNMARK :: c, VAL n :: HAN h :: s, p, i⟩ ==> ⟨c, VAL n :: s, p, i⟩
 | vm_mark h c p s i : ⟨MARK h :: c, s, p, i⟩ ==> ⟨c, HAN h :: s, p, i⟩
 | vm_pop c n s p i : ⟨POP :: c, VAL n :: s, p, i⟩ ==> ⟨c, s, p, i⟩
 | vm_reset c s n p i j : ⟨RESET :: c, VAL n :: INT i :: s, p, j⟩ ==> ⟨c, VAL n :: s, p, i⟩
 | vm_block c s p i : ⟨BLOCK :: c, s, p, i⟩ ==> ⟨c, INT i :: s, p, B⟩
 | vm_block_int c s p : ⟨BLOCK :: c, s, p, U⟩ ==> ⟪s, p, U⟫
 | vm_unblock c s p i : ⟨UNBLOCK :: c, s, p, i⟩ ==> ⟨c, INT i :: s, p, U⟩
 | vm_fail_int i j s p : ⟪INT i :: s, p, j⟫ ==> ⟪s, p, i⟫
 | vm_put c n s p i : ⟨PUT :: c, VAL n :: s, p, i⟩ ==> ⟨c, VAL n :: s, n, i⟩
 | vm_get c s p i : ⟨GET :: c, s, p, i⟩ ==> ⟨c, VAL p :: s, p, i⟩
 | vm_get_int c s p : ⟨GET :: c, s, p, U⟩ ==> ⟪s, p, U⟫
where "x ==> y" := (VM x y).

Hint Constructors VM.

(* Boilerplate to import calculation tactics *)
Module VM <: Machine.
Definition Conf := Conf.
Definition Rel := VM.
End VM.
Module VMCalc := Calculation VM.
Import VMCalc.

Ltac by_eval := eval_inv (eval).

Theorem spec e P c :  { s p i, ⟨comp' e c , s, p, i⟩ | P s p i} =|>
                        { s p q i n, ⟨c, VAL n :: s, q, i⟩ | e ⇓[i,p,q] Some n /\ P s p i}
                        ∪ { s p q i, ⟪s, q, i⟫ | e ⇓[i,p,q] None /\ P s p i}.
Proof.
  intros.
  generalize dependent c.
  generalize dependent P.
  induction e;intros.

   begin
    ({ s p q i n', ⟨c, VAL n' :: s, q, i⟩ | Val n ⇓[i,p, q] Some n' /\ P s p i} ∪
     { s p q i, ⟪s, q, i⟫ | Val n ⇓[i,p,q] None /\ P s p i }).
   = {by_eval}
    ({ s p i , ⟨c, VAL n :: s, p, i⟩ |  P s p i} ∪
     { s p , ⟪s, p, U⟫ | P s p U }).
  <== {apply vm_push}
    ({ s p i, ⟨ PUSH n :: c, s, p, i⟩ | P s p i } ∪
     { s p , ⟪s, p, U⟫ | P s p U }).
  <== {apply vm_push_int}
    ({ s p i, ⟨ PUSH n :: c, s, p, i⟩ | P s p i } ∪
     { s p, ⟨ PUSH n :: c, s, p, U⟩ | P s p U }).
  = {auto}
    ({ s p i, ⟨ PUSH n :: c, s, p, i⟩ | P s p i }).
  [].

  begin
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | Add e1 e2 ⇓[i,p,q] Some n /\ P s p i }
    ∪ { s p q i , ⟪s, q, i⟫ | Add e1 e2 ⇓[i,p,q] None /\ P s p i }) .
  = {by_eval}
    ({s p q r i n m, ⟨c, VAL (n+m) :: s, q, i⟩ | e1 ⇓[i,p,r] Some n /\ e2 ⇓[i,r,q] Some m /\ P s p i }
    ∪ { s p q r n i , ⟪s, q, i⟫ | e1 ⇓[i,p,r] Some n /\ e2 ⇓[i,r,q] None /\ P s p i }
    ∪ { s p q i , ⟪s, q, i⟫ | e1 ⇓[i,p,q] None /\ P s p i }).
  <== {apply vm_add}
    ({s p q r i n m, ⟨ADD :: c, VAL m :: VAL n :: s, q, i⟩ | e1 ⇓[i,p,r] Some n /\ e2 ⇓[i,r,q] Some m /\ P s p i }
    ∪ { s p q r n i , ⟪s, q, i⟫ | e1 ⇓[i,p,r] Some n /\ e2 ⇓[i,r,q] None /\ P s p i }
    ∪ { s p q i , ⟪s, q, i⟫ | e1 ⇓[i,p,q] None /\ P s p i }).
  <== {apply vm_fail_val}
    ({s p q r i n m, ⟨ADD :: c, VAL m :: VAL n :: s, q, i⟩ | e1 ⇓[i,p,r] Some n /\ e2 ⇓[i,r,q] Some m /\ P s p i }
    ∪ { s p q r n i , ⟪VAL n :: s, q, i⟫ | e1 ⇓[i,p,r] Some n /\ e2 ⇓[i,r,q] None /\ P s p i }
    ∪ { s p q i , ⟪s, q, i⟫ | e1 ⇓[i,p,q] None /\ P s p i }).
  = { eauto }
    ({s' r q i m, ⟨ADD :: c, VAL m :: s', q, i⟩ | e2 ⇓[i,r,q] Some m /\
             (exists s p n, s' = VAL n :: s /\ e1 ⇓[i,p,r] Some n /\ P s p i) }
    ∪ { s' r q i , ⟪s', q, i⟫ | e2 ⇓[i,r,q] None /\
                        (exists s p n, s' = VAL n :: s /\ e1 ⇓[i,p,r] Some n /\ P s p i) }
    ∪ { s p q i , ⟪s, q, i⟫ | e1 ⇓[i,p,q] None /\ P s p i }).
  <|= {apply IHe2}
    ({s' r i, ⟨comp' e2 (ADD :: c), s', r, i⟩ | (exists s p n, s' = VAL n :: s /\ e1 ⇓[i,p,r] Some n /\ P s p i) }
    ∪ { s p q i , ⟪s, q, i⟫ | e1 ⇓[i,p,q] None /\ P s p i }).
  = {eauto}
    ({s p r i n, ⟨comp' e2 (ADD :: c), VAL n :: s, r, i⟩ | e1 ⇓[i,p,r] Some n /\ P s p i }
    ∪ { s p r i , ⟪s, r, i⟫ | e1 ⇓[i,p,r] None /\ P s p i }).
  <|= { apply IHe1 }
  ({ s p i, ⟨comp' e1 (comp' e2 (ADD :: c)), s, p, i⟩ | P s p i}).
  [].

  begin
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | Throw ⇓[i,p,q] Some n /\ P s p i} ∪
    { s p q i , ⟪s, q, i⟫ | Throw ⇓[i,p,q] None /\ P s p i}).
  = {by_eval}
    ({ s p i , ⟪s, p, i⟫ | P s p i}).
  <== {apply vm_throw}
    ({ s p i , ⟨[THROW], s, p, i⟩ | P s p i}).
  [].

  begin
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | Catch e1 e2 ⇓[i,p,q] Some n /\ P s p i } ∪
    { s p q i , ⟪s, q, i⟫ | Catch e1 e2 ⇓[i, p, q] None /\ P s p i }).
  = {by_eval}
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | e1 ⇓[i,p,q] Some n /\ P s p i } ∪
    {s p q r i n, ⟨c, VAL n :: s, q, i⟩ | e1 ⇓[i,p,r] None /\ e2 ⇓[i,r,q] Some n /\ P s p i } ∪
    { s p q r i , ⟪s, q, i⟫ | e1 ⇓[i,p,r] None /\ e2 ⇓[i,r,q] None /\ P s p i }).
  = {eauto}
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | e1 ⇓[i,p,q] Some n /\ P s p i } ∪
    ({s r q i n, ⟨c, VAL n :: s, q, i⟩ | e2 ⇓[i,r,q] Some n /\ (exists p, e1 ⇓[i,p,r] None /\ P s p i) } ∪
    { s r q i , ⟪s, q, i⟫ | e2 ⇓[i,r,q] None /\ (exists p, e1 ⇓[i,p,r] None /\ P s p i) })).
  <|= { apply IHe2 }
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | e1 ⇓[i,p,q] Some n /\ P s p i } ∪
    {s r i, ⟨comp' e2 c, s, r, i⟩ | exists p, e1 ⇓[i,p,r] None /\ P s p i }).
  <== { apply vm_fail_han }
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | e1 ⇓[i,p,q] Some n /\ P s p i } ∪
    {s r i, ⟪HAN (comp' e2 c) :: s, r, i⟫ | exists p, e1 ⇓[i,p,r] None /\ P s p i }).
  <== { apply vm_unmark }
    ({s p q i n, ⟨UNMARK :: c, VAL n :: HAN (comp' e2 c) :: s, q, i⟩ | e1 ⇓[i,p,q] Some n /\ P s p i } ∪
    {s r i, ⟪HAN (comp' e2 c) :: s, r, i⟫ | exists p, e1 ⇓[i,p,r] None /\ P s p i }).
  = { eauto }
    ({s' p q i n, ⟨UNMARK :: c, VAL n :: s', q, i⟩ | e1 ⇓[i,p,q] Some n /\
                                      (exists s, s' = HAN (comp' e2 c) :: s /\ P s p i) } ∪
    {s' p q i, ⟪s', q, i⟫ | e1 ⇓[i,p,q] None /\ (exists s, s' = HAN (comp' e2 c) :: s /\ P s p i) }).
  <|= {apply IHe1}
    ({s' p i, ⟨comp' e1 (UNMARK :: c), s', p, i⟩ | exists s, s' = HAN (comp' e2 c) :: s /\ P s p i }).
  = {auto}
    ({s p i, ⟨comp' e1 (UNMARK :: c), HAN (comp' e2 c) :: s, p, i⟩ | P s p i }).
  <== {apply vm_mark}
    ({s p i, ⟨MARK (comp' e2 c) :: comp' e1 (UNMARK :: c), s, p, i⟩ | P s p i }).
  [].

  begin
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | Seqn e1 e2 ⇓[i,p,q] Some n /\ P s p i } ∪
    { s p q i , ⟪s, q, i⟫ | Seqn e1 e2 ⇓[i,p,q] None /\ P s p i }).
  = {by_eval}
    ({s p q i n m r, ⟨c, VAL n :: s, q, i⟩ | e1 ⇓[i,p,r] Some m /\ e2 ⇓[i,r,q] Some n /\ P s p i }
     ∪ { s p q i m r , ⟪s, q, i⟫ | e1 ⇓[i,p,r] Some m /\ e2 ⇓[i,r,q] None /\ P s p i }
     ∪ { s p q i , ⟪s, q, i⟫ | e1 ⇓[i,p,q] None /\ P s p i }).
  = {eauto}
    ({s r q i n, ⟨c, VAL n :: s, q, i⟩ | e2 ⇓[i,r,q] Some n /\ (exists p m, e1 ⇓[i,p,r] Some m /\ P s p i) }
     ∪ { s r q i , ⟪s, q, i⟫ | e2 ⇓[i,r,q] None /\ (exists p m, e1 ⇓[i,p,r] Some m /\ P s p i) }
     ∪ { s p q i , ⟪s, q, i⟫ | e1 ⇓[i,p,q] None /\ P s p i }).
  <|= {apply IHe2}
    ({s r i, ⟨comp' e2 c, s, r, i⟩ | exists p m, e1 ⇓[i,p,r] Some m /\ P s p i }
     ∪ { s p q i , ⟪s, q, i⟫ | e1 ⇓[i,p,q] None /\ P s p i }).
  = {eauto}
    ({s p r i m, ⟨comp' e2 c, s, r, i⟩ | e1 ⇓[i,p,r] Some m /\ P s p i }
     ∪ { s p r i , ⟪s, r, i⟫ | e1 ⇓[i,p,r] None /\ P s p i }).
  <== {apply vm_pop}
    ({s p r i m, ⟨POP :: comp' e2 c, VAL m :: s, r, i⟩ | e1 ⇓[i,p,r] Some m /\ P s p i }
     ∪ { s p r i , ⟪s, r, i⟫ | e1 ⇓[i,p,r] None /\ P s p i }).
  <|= {apply IHe1}
    ({s p i, ⟨comp' e1 (POP :: comp' e2 c), s, p, i⟩ | P s p i }).
  [].

  begin
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | Block e ⇓[i,p,q] Some n /\ P s p i } ∪
    { s p q i, ⟪s, q, i⟫ | Block e ⇓[i,p,q] None /\ P s p i }).
  = {by_eval}
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | e ⇓[B,p,q] Some n /\ P s p i } ∪
    { s p q i, ⟪s, q, i⟫ | e ⇓[B,p,q] None /\ P s p i } ∪
    { s p, ⟪s, p, U⟫ | P s p U }).
  <== {apply vm_reset}
    ({s p q i n, ⟨RESET :: c, VAL n :: INT i :: s, q, B⟩ | e ⇓[B,p,q] Some n /\ P s p i } ∪
    { s p q i, ⟪s, q, i⟫ | e ⇓[B,p,q] None /\ P s p i } ∪
    { s p, ⟪s, p, U⟫ | P s p U }).
  <== {apply vm_fail_int}
    ({s p q i n, ⟨RESET :: c, VAL n :: INT i :: s, q, B⟩ | e ⇓[B,p,q] Some n /\ P s p i } ∪
    { s p q i, ⟪INT i :: s, q, B⟫ | e ⇓[B,p,q] None /\ P s p i } ∪
    { s p, ⟪s, p, U⟫ | P s p U }).
  = {eauto}
    ({s' p q i' n, ⟨RESET :: c, VAL n :: s', q, i'⟩ | e ⇓[i',p,q] Some n /\
                    (exists s i, i' = B /\ s' = INT i :: s /\ P s p i) } ∪
    { s' p q i', ⟪s', q, i'⟫ | e ⇓[i',p,q] None /\ (exists s i, i' = B /\ s' = INT i :: s /\ P s p i) } ∪
    { s p, ⟪s, p, U⟫ | P s p U }).
  <|= {apply IHe}
    ({s' p i', ⟨comp' e (RESET :: c), s', p, i'⟩ |  exists s i, i' = B /\ s' = INT i :: s /\ P s p i }
    ∪  { s p, ⟪s, p, U⟫ | P s p U }).
  = {auto}
    ({s p i, ⟨comp' e (RESET :: c), INT i :: s, p, B⟩ | P s p i }
    ∪  { s p, ⟪s, p, U⟫ | P s p U }).
  <== {apply vm_block}
    ({s p i, ⟨BLOCK :: comp' e (RESET :: c), s, p, i⟩ | P s p i }
    ∪  { s p, ⟪s, p, U⟫ | P s p U }).
  <== {apply vm_block_int}
    ({s p i, ⟨BLOCK :: comp' e (RESET :: c), s, p, i⟩ | P s p i } ∪
    {s p, ⟨BLOCK :: comp' e (RESET :: c), s, p, U⟩ | P s p U }).
  = {auto}
    ({s p i, ⟨BLOCK :: comp' e (RESET :: c), s, p, i⟩ | P s p i }).
  [].

  begin
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | Unblock e ⇓[i,p,q] Some n /\ P s p i } ∪
    { s p q i, ⟪s, q, i⟫ | Unblock e ⇓[i,p,q] None /\ P s p i }).
  = {by_eval}
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | e ⇓[U,p,q] Some n /\ P s p i } ∪
    { s p q i, ⟪s, q, i⟫ | e ⇓[U,p,q] None /\ P s p i } ∪
    { s p, ⟪s, p, U⟫ | P s p U }).
  = {auto}
    ({s p q i n, ⟨c, VAL n :: s, q, i⟩ | e ⇓[U,p,q] Some n /\ P s p i } ∪
    { s p q i, ⟪s, q, i⟫ | e ⇓[U,p,q] None /\ P s p i }).
  <== {apply vm_reset}
    ({s p q i n, ⟨RESET :: c, VAL n :: INT i :: s, q, U⟩ | e ⇓[U,p,q] Some n /\ P s p i } ∪
    { s p q i, ⟪s, q, i⟫ | e ⇓[U,p,q] None /\ P s p i }).
  <== {apply vm_fail_int}
    ({s p q i n, ⟨RESET :: c, VAL n :: INT i :: s, q, U⟩ | e ⇓[U,p,q] Some n /\ P s p i } ∪
    { s p q i, ⟪INT i :: s, q, U⟫ | e ⇓[U,p,q] None /\ P s p i }).
  = {eauto}
    ({s' p q i' n, ⟨RESET :: c, VAL n :: s', q, i'⟩ | e ⇓[i',p,q] Some n /\
                    (exists s i, i' = U /\ s' = INT i :: s /\ P s p i) } ∪
    { s' p q i', ⟪s', q, i'⟫ | e ⇓[i',p,q] None /\ (exists s i, i' = U /\ s' = INT i :: s /\ P s p i) }).
  <|= {apply IHe}
    ({s' p i', ⟨comp' e (RESET :: c), s', p, i'⟩ |  exists s i, i' = U /\ s' = INT i :: s /\ P s p i }).
  = {auto}
    ({s p i, ⟨comp' e (RESET :: c), INT i :: s, p, U⟩ | P s p i }).
  <== {apply vm_unblock}
    ({s p i, ⟨UNBLOCK :: comp' e (RESET :: c), s, p, i⟩ | P s p i }).
  [].

  begin
    ({s p q i n, ⟨c, VAL n :: s, q, i ⟩ | Put e ⇓[ i, p, q] Some n /\ P s p i}
    ∪ {s p q i, ⟪s, q, i ⟫ | Put e ⇓[ i, p, q] None /\ P s p i}).
  = {by_eval}
    ({s p q i n, ⟨c, VAL n :: s, n, i ⟩ | e ⇓[ i, p, q] Some n /\ P s p i}
    ∪ {s p q i, ⟪s, q, i ⟫ | e ⇓[ i, p, q] None /\ P s p i}).
  <== {apply vm_put}
    ({s p q i n, ⟨PUT :: c, VAL n :: s, q, i ⟩ | e ⇓[ i, p, q] Some n /\ P s p i}
    ∪ {s p q i, ⟪s, q, i ⟫ | e ⇓[ i, p, q] None /\ P s p i}).
  <|= {apply IHe}
    ({s p i, ⟨comp' e (PUT :: c), s, p, i ⟩ | P s p i}).
  [].

  begin
    ({s p q i n, ⟨c, VAL n :: s, q, i ⟩ | Get ⇓[ i, p, q] Some n /\ P s p i}
     ∪ {s p q i, ⟪s, q, i ⟫ | Get ⇓[ i, p, q] None /\ P s p i}).
  = {by_eval}
    ({s p i , ⟨c, VAL p :: s, p, i ⟩ | P s p i}
     ∪ {s p , ⟪s, p, U ⟫ |  P s p U}).
  <== {apply vm_get}
    ({s p i , ⟨GET :: c, s, p, i ⟩ | P s p i}
     ∪ {s p , ⟪s, p, U ⟫ |  P s p U}).
  <== {apply vm_get_int}
    ({s p i , ⟨GET :: c, s, p, i ⟩ | P s p i}
     ∪ {s p , ⟨GET :: c, s, p, U ⟩ |  P s p U}).
  = {auto}
    ({s p i , ⟨GET :: c, s, p, i ⟩ | P s p i}).
  [].
Qed.


(** Implementation of a functor for lexicographic
    decidable orders *)

Require Import Relations.
Require Import DecOrder MoreDecOrder.

Module Lexico (D1 : DEC_ORDER) (D2 : DEC_ORDER) <: DEC_ORDER
                                                   with Definition A := (D1.A * D2.A)%type.
  Open Scope type_scope.
  Module M1 := More_Dec_Orders D1.
  Module M2 := More_Dec_Orders D2.

  Definition A := D1.A * D2.A.

 Definition le (a b:A) : Prop :=
   let (a1, a2) := a in
   let (b1, b2) := b in D1.lt a1 b1 \/ a1 = b1 /\ D2.le a2 b2.

 Definition lt (a b:A) : Prop :=
   let (a1, a2) := a in
   let (b1, b2) := b in D1.lt a1 b1 \/ a1 = b1 /\ D2.lt a2 b2.

 Theorem ordered : order A le.
 Proof.
  split.
  unfold reflexive in |- *; intros.
  unfold le in |- *; case x.
  right.
  split; [ trivial | apply M2.le_refl; auto ].
  unfold le, transitive in |- *.
  simple destruct x; simple destruct y; simple destruct z.
  simple destruct 1; intro H1.
  simple destruct 1.
  left.
  eapply M1.lt_trans.
  eexact H1.
  assumption.
  simple destruct 1.
  simple destruct 1.
  auto.
  simple destruct 1.
  intro.
  case H1; intros e H3; rewrite e; auto.
  case H1; intros e H3; rewrite e; auto.
  simple destruct 1.
  simple destruct 1.
  right.
  split; try auto.
  eapply M2.le_trans; eauto.
  unfold antisymmetric, A, le in |- *.
  simple destruct x; simple destruct y.
  simple destruct 1; simple destruct 2.
  intro.
  absurd (D1.lt a1 a1).
  apply M1.lt_irreflexive.
  eapply M1.lt_trans; eauto.
  simple destruct 1; intros e H3.
  rewrite e in H0.
  case (M1.lt_irreflexive a H0).
  case H0; intros e H3.
  rewrite e; intro H2.
  case (M1.lt_irreflexive a1 H2).
  simple destruct 1; intros e H3; rewrite e.
  case (M2.le_antisym a2 a0).
  auto.
  case H0; auto.
  auto.
 Qed.

 Theorem lt_le_weak : forall a b:A, lt a b -> le a b.
 Proof.
  unfold A, lt, le in |- *; intros a b; case a; case b.
  simple destruct 1; intros; auto.
  right; case H0; split; auto.
  apply D2.lt_le_weak; trivial.
 Qed.

 Theorem lt_diff : forall a b:A, lt a b -> a <> b.
 Proof.
  unfold A, lt, le in |- *; intros a b; case a; case b.
  simple destruct 1.
  intro H0; red in |- *; injection 1.
  intros e1 e2; rewrite e2 in H0.
  case (M1.lt_irreflexive a0 H0).
  simple destruct 1.
  simple destruct 1.
  intro H2; red in |- *; injection 1.
  intro e; rewrite e in H2; case (M2.lt_irreflexive _ H2).
 Qed.

 Theorem le_lt_or_eq : forall a b:A, le a b -> lt a b \/ a = b.
 Proof.
  unfold A, lt, le in |- *; intros a b; case a; case b.
  simple destruct 1; auto.
  simple destruct 1.
  simple destruct 1.
  intro H2; case (D2.le_lt_or_eq _ _ H2).
  auto.
  simple destruct 1.
  auto.
 Qed.

 Definition lt_eq_lt_dec : forall a b:A, {lt a b} + {a = b} + {lt b a}.
  Proof.
   unfold A, lt in |- *; intros.
   case a; case b.
   intros a0 a1 a2 a3.
   case (D1.lt_eq_lt_dec a0 a2).
   simple destruct 1.
   right.
   auto.
   simple destruct 1.
   case (D2.lt_eq_lt_dec a1 a3).
   simple destruct 1.
   right.
   auto.
   simple destruct 1.
   left; right; trivial.
   left; left; auto.
   left.
   left; auto.
  Defined.
End Lexico.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.Preservation.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.Core.Examples.StructuredCategories.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.EndoMap.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sub1Cell.
Require Import UniMath.Bicategories.Monads.Examples.MonadsInBicatOfUnivCats.
Require Import UniMath.Bicategories.Monads.Examples.MonadsInBicatOfCats.
Require Import UniMath.Bicategories.Monads.Examples.MonadsInTotalBicat.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Actegories.Actegories.
Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories.
Require Import UniMath.Bicategories.MonoidalCategories.BicatOfActegories.

(**
 1. Monads in the bicategory of categories with a terminal object
 *)
Definition make_mnd_univ_cat_with_terminal_obj
           (C : univalent_category)
           (M : Monad C)
           (TC : Terminal C)
           (MT : preserves_terminal M)
  : mnd univ_cat_with_terminal_obj.
Proof.
  use make_mnd_total_bicat.
  - apply disp_2cells_isaprop_subbicat.
  - use Monad_to_mnd_bicat_of_univ_cats.
    + exact C.
    + exact M.
  - use make_disp_mnd.
    + exact (tt ,, TC).
    + exact (MT ,, tt).
    + exact (tt ,, tt).
    + exact (tt ,, tt).
Defined.

(**
 2. Monads in the bicategory of categories with binary products
 *)
Definition make_mnd_univ_cat_with_binprod
           (C : univalent_category)
           (M : Monad C)
           (BC : BinProducts C)
           (MB : preserves_binproduct M)
  : mnd univ_cat_with_binprod.
Proof.
  use make_mnd_total_bicat.
  - apply disp_2cells_isaprop_subbicat.
  - use Monad_to_mnd_bicat_of_univ_cats.
    + exact C.
    + exact M.
  - use make_disp_mnd.
    + exact (tt ,, BC).
    + exact (MB ,, tt).
    + exact (tt ,, tt).
    + exact (tt ,, tt).
Defined.

(**
 3. Monads in the bicategory of categories with pullbacks
 *)
Definition make_mnd_univ_cat_with_pb
           (C : univalent_category)
           (M : Monad C)
           (PC : Pullbacks C)
           (MP : preserves_pullback M)
  : mnd univ_cat_with_pb.
Proof.
  use make_mnd_total_bicat.
  - apply disp_2cells_isaprop_subbicat.
  - use Monad_to_mnd_bicat_of_univ_cats.
    + exact C.
    + exact M.
  - use make_disp_mnd.
    + exact (tt ,, PC).
    + exact (MP ,, tt).
    + exact (tt ,, tt).
    + exact (tt ,, tt).
Defined.

(**
 4. Monads in the bicategory of categories with finite limits
 *)
Definition make_mnd_univ_cat_with_finlim
           (C : univalent_category)
           (M : Monad C)
           (TC : Terminal C)
           (PC : Pullbacks C)
           (MT : preserves_terminal M)
           (MP : preserves_pullback M)
  : mnd univ_cat_with_finlim.
Proof.
  use make_mnd_total_bicat.
  - apply disp_2cells_isaprop_prod ; apply disp_2cells_isaprop_subbicat.
  - use Monad_to_mnd_bicat_of_univ_cats.
    + exact C.
    + exact M.
  - use make_disp_mnd.
    + exact ((tt ,, TC) ,, (tt ,, PC)).
    + exact ((MT ,, tt) ,, (MP ,, tt)).
    + cbn.
      exact ((tt ,, tt) ,, (tt ,, tt)).
    + cbn.
      exact ((tt ,, tt) ,, (tt ,, tt)).
Defined.

(**
 5. Monads in the bicategory of categories with an initial object
 *)
Definition make_mnd_univ_cat_with_initial
           (C : univalent_category)
           (M : Monad C)
           (IC : Initial C)
           (MI : preserves_initial M)
  : mnd univ_cat_with_initial.
Proof.
  use make_mnd_total_bicat.
  - apply disp_2cells_isaprop_subbicat.
  - use Monad_to_mnd_bicat_of_univ_cats.
    + exact C.
    + exact M.
  - use make_disp_mnd.
    + exact (tt ,, IC).
    + exact (MI ,, tt).
    + exact (tt ,, tt).
    + exact (tt ,, tt).
Defined.

(**
 6. Monads in the bicategory of categories with binary coproducts
 *)
Definition make_mnd_univ_cat_with_bincoprod
           (C : univalent_category)
           (M : Monad C)
           (SC : BinCoproducts C)
           (MS : preserves_bincoproduct M)
  : mnd univ_cat_with_bincoprod.
Proof.
  use make_mnd_total_bicat.
  - apply disp_2cells_isaprop_subbicat.
  - use Monad_to_mnd_bicat_of_univ_cats.
    + exact C.
    + exact M.
  - use make_disp_mnd.
    + exact (tt ,, SC).
    + exact (MS ,, tt).
    + exact (tt ,, tt).
    + exact (tt ,, tt).
Defined.

(**
 7. Monads in the bicategory of actegories
 *)
Definition make_mnd_actegory
           (V : category)
           (Mon_V : monoidal V)
           (C : category)
           (M : Monad C)
           (Act : actegory Mon_V C)
           (Ml : lineator_lax Mon_V Act Act M)
           (ηlinear : is_linear_nat_trans (identity_lineator_lax Mon_V Act) Ml (η M))
           (μlinear : is_linear_nat_trans (comp_lineator_lax Mon_V Ml Ml) Ml (μ M))
  : mnd (actbicat Mon_V).
Proof.
  use make_mnd_total_bicat.
  - apply actbicat_disp_2cells_isaprop.
  - use Monad_to_mnd_bicat_of_cats.
    + exact C.
    + exact M.
  - use make_disp_mnd.
    + exact Act.
    + exact Ml.
    + exact ηlinear.
    + exact μlinear.
Defined.


(**********************************************************************************
 * PredomLift.v                                                                   *
 * Formalizing Domains, Ultrametric Spaces and Semantics of Programming Languages *
 * Nick Benton, Lars Birkedal, Andrew Kennedy and Carsten Varming                 *
 * Jan 2012                                                                       *
 * Build with Coq 8.3pl2 plus SSREFLECT                                           *
 **********************************************************************************)

(*==========================================================================
  Lifting
  ==========================================================================*)

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

(** ** Lifting *)

Section Lift_type.

(** ** Definition of underlying stream type *)

(** printing Eps %\eps% *)
(** printing Val %\val% *)
(** printing Stream %\Stream% *)
Variable D : Type.

(*=Stream *)
CoInductive Stream := Eps : Stream -> Stream | Val : D -> Stream.
(*=End *)

Lemma DL_inv : forall d, d = match d with Eps x => Eps x | Val d => Val d end.
destruct d; auto.
Save.
Hint Resolve DL_inv.

(** ** Removing Eps steps *)

Definition pred d : Stream := match d with Eps x => x | Val _ => d end.

Fixpoint pred_nth (d:Stream) (n:nat) {struct n} : Stream :=
    match n with 0 => d
              |S m => match d with Eps x => pred_nth x m
                                 | Val _ => d
                      end
    end.

Lemma pred_nth_val : forall x n, pred_nth (Val x) n = Val x.
destruct n; simpl; trivial.
Save.
Hint Resolve pred_nth_val.

Lemma pred_nth_Sn_acc : forall n d, pred_nth d (S n) = pred_nth (pred d) n.
destruct d; simpl; auto.
Save.

Lemma pred_nth_Sn : forall n d, pred_nth d (S n) = pred (pred_nth d n).
induction n; intros; auto.
destruct d.
exact (IHn d).
rewrite pred_nth_val; rewrite pred_nth_val; simpl; trivial.
Save.

Lemma pred_nth_sum : forall x m n, pred_nth x (m+n) = pred_nth (pred_nth x m) n.
induction m.
simpl.
intuition.
intro n; replace (S m + n)%N with (m + S n)%N; intuition ; last by rewrite addSn ; rewrite addnS.
rewrite IHm.
rewrite (@pred_nth_Sn_acc n (pred_nth x m)).
rewrite pred_nth_Sn.
reflexivity.
Qed.

End Lift_type.

Section Lift_ord.

Variable D : ordType.

(** ** Order *)
(*=DLle *)
CoInductive DLle : Stream D -> Stream D -> Prop :=
 |  DLleEps : forall x y,  DLle x y -> DLle (Eps x) (Eps y)
 |  DLleEpsVal : forall x d,  DLle x (Val d) -> DLle (Eps x) (Val d)
 |  DLleVal : forall d d' n y, pred_nth y n = Val d' -> d <= d' -> DLle (Val d) y.
(*=End *)

Hint Constructors DLle.

(*=DLle_rec *)
Lemma DLle_rec : forall R : Stream D -> Stream D -> Prop,
   (forall x y, R (Eps x) (Eps y) -> R x y) ->
   (forall x d, R (Eps x) (Val d) -> R x (Val d)) ->
   (forall d y, R (Val d) y -> exists n, exists d', pred_nth y n = Val d' /\ d <= d')
   -> forall x y, R x y -> DLle x y.
(*=End *)
move => R REps REpsVal RVal; cofix; case => x.
- case => y H.
  + apply DLleEps. apply DLle_rec. by apply REps.
  + by apply DLleEpsVal; apply DLle_rec; auto.
move => y H.
case (RVal _ _ H); move => n [d [X L]].
by apply DLleVal with d n.
Qed.

(** *** Properties of the order *)

Lemma DLle_refl : forall x, DLle x x.
intros x. apply DLle_rec with (R:= fun x y => forall n, pred_nth x n = pred_nth y n) ; try (clear x).
intros x y C n. specialize (C (S n)). simpl in C. auto.
intros x d C n. specialize (C (S n)). simpl in C. rewrite C. case n ; auto.
intros d y C. exists 0. exists d. simpl. specialize (C 0). simpl in C. auto.
intros n ; auto.
Save.
Hint Resolve DLle_refl.

Lemma DLvalval : forall d x, DLle (Val d) x ->
 exists n, exists d', pred_nth x n = Val d' /\ d<=d'.
intros d x H.
inversion H.
exists n; exists d'.
intuition.
Qed.

Lemma pred_nth_epsS n (x y:Stream D): Eps y = pred_nth x n -> y = pred_nth x (S n).
elim:n x y. move => x y E. simpl in E. rewrite <- E. simpl. auto.
move => n IH x. case x ; clear x. intros x y. intros E. simpl in E. specialize (IH _ _ E). auto.
intros x y. simpl. intros incon. inversion incon.
Qed.

Lemma pred_nth_valS n d (y:Stream D): Val d = pred_nth y n -> Val d = pred_nth y (S n).
elim: n d y.
- move => d y E. simpl in E. by rewrite <- E.
- move => n IH d. case => y E.
  + simpl in E. by rewrite (IH _ _ E).
  + apply E.
Qed.

Lemma pred_nth_comp (y:Stream D) : forall m0 n1 m1 : nat,
   m0 == (n1 + m1)%N -> pred_nth y m0 = pred_nth (pred_nth y n1) m1.
move => m0.
elim: m0 y.
- move => y n1 m1 E. have X:=addn_eq0 n1 m1. rewrite <- (eqP E) in X. rewrite eq_refl in X.
  have Y:=proj1 (andP (sym_eq X)). rewrite (eqP Y). simpl. by rewrite (eqP (proj2 (andP (sym_eq X)))).
- move => m0 IH y n1. case.
  + rewrite addn0. case: n1 ; first by [].
    case: y ; last by [].
    simpl. move => y n E. specialize (IH y n 0). by rewrite IH ; last rewrite addn0.
  + move => n. rewrite addnS => E. simpl. case_eq (pred_nth y n1).
    * move => y' X. case: y X ; last by case: n1 E.
      move => y X. rewrite (pred_nth_epsS (sym_eq X)). simpl. by apply IH.
    * move => y' X. case: y X => y.
      - case: n1 E ; first by []. move => n1 E. simpl.
        specialize (IH y n1). move => X. rewrite X in IH. specialize (IH n.+1). rewrite addnS in IH. specialize (IH E).
        by apply IH.
      - move => X. have EE:= (pred_nth_val y n1). rewrite EE in X. by apply X.
Qed.

Lemma DLle_pred_nth x y n : DLle x y -> DLle (pred_nth x n) (pred_nth y n).
elim: n x y ; first by [].
move => n IH x y C. case: x y / C.
- move => x y C. simpl. apply IH. by apply C.
- move => x d C. simpl. specialize (IH _ _ C). rewrite pred_nth_val in IH. by apply IH.
- move => d d' m y E L. specialize (IH (Val d)).
  case: y E.
  + move => y. specialize (IH y). move => X. simpl. rewrite (pred_nth_val) in IH. apply IH.
    case: m X ; first by [].
    move => m X. simpl in X. by apply:(DLleVal X).
  + move => y. rewrite pred_nth_val. case. move => E. simpl. rewrite E.
    by apply DLleVal with d' 0 ; last by [].
Qed.

Lemma DLleEps_right : forall x y,  DLle x y -> DLle x (Eps y).
intros x y C. apply DLle_rec with (R:= fun x y => forall n, DLle (pred_nth x n) (pred_nth y (S n))).
clear x y C. intros x y C n. specialize (C (S n)). auto.
clear x y C. intros x y C n. specialize (C (S n)). auto.
clear x y C. intros d y C. specialize (C 0).
assert (DLle (Val d) (pred_nth y 1)) as CC by auto. clear C.
destruct (DLvalval CC) as [n [dd [X Y]]]. exists (S n). exists dd. split ; auto.
generalize X. clear X. destruct y. simpl. auto. simpl. case n ; auto.
intros n. simpl.
apply DLle_pred_nth ; auto.
Qed.
Hint Resolve DLleEps_right.

Lemma DLleEps_left : forall x y,  DLle x y -> DLle (Eps x) y.
intros x y C. apply DLle_rec with (R:= fun x y => forall n, DLle (pred_nth x (S n)) (pred_nth y n)).
clear x y C. intros x y C n. specialize (C (S n)). auto.
clear x y C. intros x y C n. specialize (C (S n)). destruct n ; auto.
clear x y C. intros d y C. specialize (C 0).
simpl in C.
destruct (DLvalval C) as [n [dd [X Y]]]. exists n. exists dd. split ; auto.
intros n. simpl. apply DLle_pred_nth ; auto.
Qed.
Hint Resolve DLleEps_left.

Lemma DLle_pred_left : forall x y, DLle x y -> DLle (pred x) y.
destruct x; destruct y; simpl; intros; trivial.
inversion H; auto.
inversion H; trivial.
Save.

Lemma DLle_pred_right : forall x y, DLle x y -> DLle x (pred y).
destruct x; destruct y; simpl; intros; trivial.
inversion H; auto.
inversion H; trivial.
destruct n; simpl in H1.
discriminate H1.
apply DLleVal with d' n; auto.
Save.

Hint Resolve DLle_pred_left DLle_pred_right.

Lemma DLle_pred : forall x y, DLle x y -> DLle (pred x) (pred y).
auto.
Save.

Hint Resolve DLle_pred.

Lemma DLle_pred_nth_left : forall n x y, DLle x y -> DLle (pred_nth x n) y.
induction n; intros.
simpl; auto.
rewrite pred_nth_Sn; auto.
Save.

Lemma DLle_pred_nth_right : forall n x y,
      DLle x y -> DLle x (pred_nth y n).
induction n; intros.
simpl; auto.
rewrite pred_nth_Sn; auto.
Save.

Hint Resolve DLle_pred_nth_left DLle_pred_nth_right.

(* should be called leq *)
Lemma DLleVal_leq : forall x y, DLle (Val x) (Val y) -> x <= y.
intros x y H; inversion H.
destruct n; simpl in H1; injection H1;intro; subst y; auto.
Save.
Hint Immediate DLleVal_leq.

(* New *)
Lemma DLle_leVal : forall x y, x<=y -> DLle (Val x) (Val y).
intros x y H.
apply (DLle_rec (R := fun x' y' => x'=Val x /\ y'=Val y)).
intros.
destruct H0; discriminate.
intros.
destruct H0; discriminate.
intros.
destruct H0.
subst y0.
exists 0.
exists y.
simpl.
split; trivial.
injection H0.
intro; subst d; auto.
auto.
Qed.

Lemma DLnvalval : forall n y d z, pred_nth y n = Val d -> DLle y z ->
 exists m, exists d', pred_nth z m = Val d' /\ d <= d'.
elim.
- move => y d z E L. simpl in E. case: L E ; [by [] | by [] | idtac].
  move => d1 d2 n y' E L. case => E'. rewrite E' in L. clear E' d1.
  exists n. exists d2. by split.
- move => n IH y d z E L. specialize (IH (pred y) d z). rewrite pred_nth_Sn_acc in E.
  specialize (IH E). apply IH. by apply DLle_pred_left.
Qed.

Lemma DLleEpsn n x z xx : pred_nth x n = Val xx -> DLle (Val xx) z -> DLle x z.
elim:n x z xx => x.
- move => z xx. simpl => E. by rewrite E.
- move => IH. case.
  + move => d z xx. simpl. move => C DD.
    specialize (IH d z xx C DD). by apply: (DLle_pred_right (DLleEps _)).
  + move => d z xx. simpl. case => e. by rewrite e.
Qed.

Lemma DLle_trans : forall x y z, DLle x y -> DLle y z -> DLle x z.
move => x y z D0 D1.
apply DLle_rec with (R:=fun x z => (forall xx n, pred_nth x n = Val xx -> DLle x z)).
- clear x y z D0 D1. move => x y C xx n X.
  specialize (C xx (S n) X). by apply (DLle_pred C).
- clear x y z D0 D1. move => x y C xx n X. specialize (C _ (S n) X).
  by apply (DLle_pred_left C).
- move => d yy C. specialize (C d 0).
  case (fun Z => DLvalval (C Z)) ; first by [].
  move => n [dd [ZZ Z]]. exists n. exists dd. by split.
- move => xx n C. case (DLnvalval C D0) => m [yy [P Q]].
  case (DLnvalval P D1) => k [zz [Pz Qz]].
  apply (DLleEpsn C). apply (DLleVal Pz). by apply (Ole_trans Q Qz).
Qed.

(** *** Declaration of the ordered set *)

Lemma LiftOrdAxiom : PreOrd.axiom DLle.
move => x. split ; first by [].
move => y z. by apply DLle_trans.
Qed.

Canonical Structure lift_ordMixin := OrdMixin LiftOrdAxiom.
Canonical Structure lift_ordType := Eval hnf in OrdType lift_ordMixin.

Lemma ordSetoidAxiom (X:ordType) : Setoid.axiom (@tset_eq X).
split ; first by [].
split ; last by apply: tset_sym.
by apply: tset_trans.
Qed.

Canonical Structure ordSetoidMixin D := SetoidMixin (ordSetoidAxiom D).
Canonical Structure ordSetoidType D := Eval hnf in SetoidType (ordSetoidMixin D).

Lemma lift_setoidAxiom : @Setoid.axiom (Stream D) (@tset_eq lift_ordType).
split ; last split ; first by [].
move => x y z. by apply tset_trans.
move => x y ; by apply tset_sym.
Qed.

Canonical Structure lift_setoidMixin := SetoidMixin lift_setoidAxiom.
Canonical Structure lift_setoidType := Eval hnf in SetoidType lift_setoidMixin.

(** ** Definition of the cpo structure *)

Lemma eq_Eps : forall x, x =-= Eps x.
intros; apply: Ole_antisym; repeat red; auto.
Save.
Hint Resolve eq_Eps.

(** *** Bottom is given by an infinite chain of Eps *)
(** printing DL_bot %\DLbot% *)
CoFixpoint DL_bot : lift_ordType := Eps DL_bot.

Lemma DL_bot_eq : DL_bot = Eps DL_bot.
transitivity match DL_bot with Eps x => Eps x | Val d => Val d end ; auto.
destruct DL_bot ; auto.
Save.

Lemma DLless_cond : forall x y, (forall xx, x =-= Val xx -> x <= y) -> DLle x y.
move => x y P. apply DLle_rec with (R:=fun x y => forall xx, x =-= Val xx -> x <= y).
- move => d0 d1 IH d00 dv.
  rewrite -> (eq_Eps d0) in dv. rewrite -> (eq_Eps d0). specialize (IH _ dv).
  by rewrite -> (eq_Eps d1).
- move => d0 d1 IH dd dv. rewrite -> (eq_Eps d0) in dv. specialize (IH _ dv).
  by rewrite -> (eq_Eps d0).
- move => d0 d1 IH. specialize (IH _ (Oeq_refl _)). by apply (DLvalval IH).
- by apply P.
Qed.

Lemma DL_bot_least : forall x, DL_bot <= x.
move => x. apply DLless_cond => xx [_ C].
case (DLvalval C) => n [dd [P Q]].
have F:False ; last by [].
elim: n P ; first by rewrite DL_bot_eq.
move => n IH. rewrite DL_bot_eq. by apply IH.
Qed.

(** *** More properties of elements in the lifted domain *)

(* This is essentially the same, when fixed up, as DLvalval that I proved above
   I've repeated it here, though
*)
Lemma DLle_Val_exists_pred :
      forall x d, Val d <= x -> exists k, exists d', pred_nth x k = Val d'
            /\ d <= d'.
intros x d H; inversion H; eauto.
Save.

Lemma Val_exists_pred_le :
      forall x d, (exists k, pred_nth x k = Val d) -> Val d <= x.
destruct 1; intros.
apply DLleVal with d x0; trivial.
Save.
Hint Immediate DLle_Val_exists_pred Val_exists_pred_le.

Lemma Val_exists_pred_eq :
      forall x d, (exists k, pred_nth x k = Val d) -> (Val d:lift_ordType) =-= x.
move => x d X. split. simpl. case: X => k e. by apply: (DLleVal e).
case: X => n X. rewrite <- X. by apply DLle_pred_nth_right.
Save.

(** *** Construction of least upper bounds *)

Definition isEps (x:Stream D) := match x with Eps _ => True | _ => False end.

Lemma isEps_Eps : forall x, isEps (Eps x).
repeat red; auto.
Save.

Lemma not_isEpsVal : forall d, ~ (isEps (Val d)).
repeat red; auto.
Save.
Hint Resolve isEps_Eps not_isEpsVal.

Lemma isEpsEps (x x': Stream D) : x = Eps x' -> isEps x.
move => E. by rewrite E.
Qed.

Definition isEps_dec (x: Stream D) : {d:D|x=Val d}+{isEps x} :=
match x as x0 return x = x0 -> {d:D|x=Val d}+{isEps x} with
| Eps x' => fun E => inright _ (isEpsEps E)
| Val d => fun E => inleft _ (exist _ d E)
end (refl_equal x).

(* Slightly more radical rewrite, trying to use equality *)

Lemma allvalsfromhere : forall (c:natO =-> lift_ordType) n d i,
  c n =-= Val d -> exists d', c (n+i)%N =-= Val d' /\ d <= d'.
move => c n d i [Hnv1 Hnv2].
have X:Val d <= c (n+i)%N. apply Ole_trans with (c n) ; first by []. apply fmonotonic. by apply: leq_addr.
case (DLle_Val_exists_pred X) => k [d' [P Q]].
exists d'. split ; last by [].
apply Oeq_sym. apply Val_exists_pred_eq. by exists k.
Qed.

Definition hasVal (x:Stream D) := exists j, exists d, pred_nth x j = Val d.
Definition valuable := {x | hasVal x}.

Definition projj (x:valuable) : lift_ordType :=
match x with exist x X => x end.

(* Redoing extract using constructive epsilon *)
Require Import ConstructiveEpsilon.

Lemma hasValEps x x' : x = Eps x' -> hasVal x -> hasVal x'.
move => e. rewrite e. clear e x.
case => n. case => d e. case: n e ; first by []. move => n. simpl => e. exists n. exists d. by apply e.
Qed.

Definition inc x' (X:{kd : nat * D | let (k, d) := kd in pred_nth x' k = Val d}) :
                 {kd : nat * D | let (k, d) := kd in pred_nth (Eps x') k = Val d} :=
match X with exist (k,d) X0 =>
  exist (fun kd : nat * D => let (k, d) := kd in pred_nth (Eps x') k = Val d) (k.+1,d) X0
end.

Lemma pred_nth_notEps x' : ~ (exists d : D, pred_nth (Eps x') 0 = Val d).
by case.
Qed.

Lemma pred_nthvalval d' n : (exists d : D, pred_nth (Val d') n = Val d).
exists d'. by case: n.
Qed.

Fixpoint hasVal_dec x n : { (exists d : D, pred_nth x n = Val d) } + {~ (exists d : D, pred_nth x n = Val d)} :=
match x,n return { (exists d : D, pred_nth x n = Val d) } + {~ (exists d : D, pred_nth x n = Val d)} with
| Eps x', S n => hasVal_dec x' n
| Eps x', O => right (exists d : D, pred_nth (Eps x') O = Val d) (@pred_nth_notEps x')
| Val d, n' => left (~ (exists d' : D, pred_nth (Val d) n = Val d')) (pred_nthvalval d n)
end.

Fixpoint getVal x n :=
match x as x0, n as n0 return (exists d, pred_nth x0 n0 = Val d) -> D with
| Eps x', S n' => getVal x' n'
| Eps x', O => fun P => match pred_nth_notEps P with end
| Val d, n => fun _ => d
end.

Lemma getValVal n x (P:exists d, pred_nth x n = Val d) : pred_nth x n = Val (@getVal x n P).
elim: n x P.
- by case ; first by move => x [d F].
- move => n IH. by case; first by apply IH.
Qed.

Definition findindexandval (x:valuable) : {kd | match kd with (k,d) => (pred_nth (projj x) k) = Val d end} :=
match x as x0 return {kd | match kd with (k,d) => (pred_nth (projj x0) k) = Val d end} with
| exist x' P =>
  match @constructive_indefinite_description_nat (fun n => exists d:D, pred_nth x' n = Val d) (hasVal_dec x') P
  with exist n Px => exist (fun kd => match kd with (k,d) => (pred_nth x' k) = Val d end) (n,getVal Px) (getValVal  Px)
  end
end.

Definition extract (x:valuable) : D :=
match (findindexandval x) with exist (n,d) _ => d end.

Lemma extractworks x : projj x =-= Val (extract x).
unfold extract. case (findindexandval x).
case => n d. move => X. apply Oeq_sym. apply Val_exists_pred_eq. exists n. by apply X.
Qed.

Lemma vinj : forall d d', (Val d:lift_ordType) =-= Val d' -> d =-= d'.
intros d d' (H1,H2). by split ; apply DLleVal_leq.
Qed.

Lemma vleinj : forall d d', Val d <= Val d' -> d <= d'.
auto.
Qed.

Lemma extractmono : forall (x y : valuable), (projj x) <= (projj y) -> extract x <= extract y.
intros x y H.
apply vleinj.
rewrite <- (extractworks x).
rewrite <- (extractworks y).
assumption.
Qed.

(* This is the simpler one that just takes an equality *)

Lemma pred_nth_eq k x : pred_nth x k =-= x.
elim: k x; first by [].
move => n IH. case ; last by [].
simpl. move => x. rewrite -> (IH x). split ; first by apply DLleEps_right. by apply DLleEps_left.
Qed.

Lemma eqValpred : forall x d, x =-= Val d -> exists k, exists d', pred_nth x k = Val d' /\ d=-=d'.
move => x d [H1 H2].
case (DLle_Val_exists_pred H2) => k [d' [H L]].
exists k; exists d';split ; first by [].
split ; first by [].
apply vleinj. rewrite <- H. clear L d' H.
rewrite <- H1. by rewrite -> pred_nth_eq.
Qed.

Lemma hasValShift (c:natO -=> lift_ordType) k d (Hck:c k =-= Val d) n : hasVal (c (n + k)%N).
rewrite addnC. case: (allvalsfromhere n Hck) => d' [A L].
case: (eqValpred A) => i [dd [XX _]]. exists i. by exists dd.
Qed.

Definition makechain (c:natO -=> lift_ordType) k d (Hck:c k =-= Val d) : nat -> D :=
fun n => @extract (exist hasVal (c (n+k)%N) (hasValShift Hck n)).

Lemma makechan_mono (c:natO -=> lift_ordType) k d (Hck:c k =-= Val d) : monotonic (makechain Hck).
move => n n' L. apply extractmono. simpl. apply fmonotonic. by apply: (leq_add L).
Qed.

Definition makechainm (c:natO -=> lift_ordType) k d (Hck:c k =-= Val d) : natO =-> D :=
  Eval hnf in mk_fmono (makechan_mono Hck).

Lemma pred_mono (c:natO =-> lift_ordType) : monotonic (fun n => pred (c n)).
move => x y H. apply: DLle_pred. by apply (fmonotonic c).
Qed.

Definition cpred (c:natO =-> lift_ordType) : natO =-> lift_ordType := Eval hnf in mk_fmono (pred_mono c).

Lemma fValIdx : forall (c:natO =-> lift_ordType) (n : nat),
        {dk: (D*nat)%type | match dk with (d,k) => k<n /\ c k =-= Val d end} + {(forall k, k<n -> isEps (c k))}.
move => c. elim ; first by right.
move => n. case.
- case. case => d k [H ck]. left. exists (d,k). split ; last by []. rewrite ltn_neqAle in H.
  by apply (proj2 (andP H)).
- move => X. case: (isEps_dec (c n)).
  + case => d E. left. exists (d,n). by rewrite E.
  + move => E. right => k. case_eq (k == n) => EE ; first by rewrite (eqP EE).
    move => L. rewrite ltnS in L. rewrite leq_eqVlt in L. rewrite EE in L. by apply X.
Defined.

Definition createchain (c:natO =-> lift_ordType) (n:nat)
  (X:{dk: (D*nat)%type | match dk with (d,k) => k<n /\ c k =-= Val d end}) :
   (natO =-> D) :=
match X with | exist (d,k) (conj Hk Hck) => @makechainm c k d Hck
end.

Lemma makechainworks : forall (c:natO =-> lift_ordType) k dk (H2:c k =-= Val dk) i (d:D), c (k+i)%N =-= (Val d) -> makechain H2 i =-= d.
move => c k dk Hck i d e.
apply vinj.
rewrite <- e.
apply Oeq_sym.
unfold makechain.
rewrite <- extractworks.
simpl. by rewrite addnC.
Qed.

Lemma eqDLeq : forall d d', d =-= d' -> Val d =-= (Val d').
move => d d'. by case ; split ; apply DLle_leVal.
Qed.

Lemma predeq : forall x, x =-= pred x.
move => x. case: x ; last by [].
move => x. simpl. by rewrite <-( @pred_nth_eq 1 (Eps x)).
Qed.

(* Just realized I should have had Val as a morphism ages ago *)
Add Parametric Morphism : (@Val D)
with signature (@tset_eq D) ==> (@tset_eq lift_ordType)
as Val_eq_compat.
intros.
apply eqDLeq.
assumption.
Qed.

Add Parametric Morphism : (@Val D)
with signature (@Ole D) ++> (@Ole lift_ordType)
as Val_le_compat.
intros.
apply DLle_leVal.
auto.
Qed.

Lemma DLle_Val_exists_eq : forall y d, Val d <= y -> exists d', y =-= Val d' /\ d <= d'.
intros y d H; inversion H.
exists d'.
split.
symmetry.
apply Val_exists_pred_eq.
exists n; trivial.
assumption.
Qed.

Lemma DLvalgetchain: forall (c:natO =-> lift_ordType) k d, c k =-= Val d -> exists c':natO =-> D, forall n, c(k+n)%N =-= Val (c' n).
intros c k d chk.
exists (makechainm chk).
intros n.
destruct (allvalsfromhere n chk) as [d' [chd ld]].
refine (Oeq_trans chd _).
apply eqDLeq.
apply (Oeq_sym (makechainworks chk chd)).
Qed.

Hint Immediate DLle_leVal.

Lemma eta_mono : monotonic (@Val D).
move => x y L. by rewrite -> L.
Qed.

Definition eta_m : D =-> lift_ordType := Eval hnf in mk_fmono eta_mono.

End Lift_ord.

Implicit Arguments eta_m [D].

Section Lift_cpo.

Variable D:cpoType.

CoFixpoint DL_lubn (c:natO =-> lift_ordType D) (n:nat) : lift_ordType D :=
    match fValIdx c n with inleft X => Val (lub (createchain X))
                                |  inright _  => Eps (DL_lubn (cpred c) (S n))
    end.

Lemma DL_lubn_inv : forall (c:natO =-> lift_ordType D) (n:nat), DL_lubn c n =
     match fValIdx c n with inleft X => Val (lub (createchain X))
                                |  inright _  => Eps (DL_lubn (cpred c) (S n))
    end.
intros; rewrite (DL_inv (DL_lubn c n)).
simpl; case (fValIdx c n); trivial.
Qed.

Lemma chainluble : forall (c:natO =-> lift_ordType D) k dk (Hkdk : c k =-= Val dk) k' dk' (Hkdk': c k' =-= Val dk'),
   lub (makechainm Hkdk) <= lub (makechainm Hkdk').
intros;apply lub_le.
intro n.
assert (Hkn := allvalsfromhere n Hkdk).
destruct Hkn as (dkn,(Hckn,Hdkdkn)).
setoid_replace (makechainm Hkdk n) with (dkn).
destruct (allvalsfromhere (n+k) Hkdk') as [dkk'n [Hckk'n Hddd]].
apply Ole_trans with dkk'n.
apply vleinj; rewrite <- Hckn; rewrite <- Hckk'n.
apply fmonotonic. rewrite addnC. by apply: (leq_addl k').
setoid_replace dkk'n with (makechainm Hkdk' (n+k)%N).
apply le_lub.
unfold makechainm.
apply Oeq_sym; apply makechainworks.
assumption.
unfold makechainm; apply makechainworks.
assumption.
Qed.

Lemma chainlubinv : forall (c:natO =-> lift_ordType D) k dk (Hkdk : c k =-= Val dk) k' dk' (Hkdk': c k' =-= Val dk'),
   lub (makechainm Hkdk) =-= lub (makechainm Hkdk').
intros;split;apply chainluble.
Qed.

Lemma pred_lubn_Val : forall (d:D)(n k p:nat) (c:natO =-> lift_ordType D),
             (n <k+p)%nat -> pred_nth (c n) k = Val d
                                   -> exists d', DL_lubn c p =-= Val d'.
move => d n. elim.
- move => p c L E. rewrite (DL_lubn_inv c p). simpl in E.
  case: (fValIdx c p).
  + case.
    * move => [d' k] [H1 H2]. simpl. by exists (lub (makechainm H2)).
    * move => X. specialize (X _ L). by rewrite E in X.
  + move => k IH p c L E. rewrite (DL_lubn_inv c p).
    case: (fValIdx c p).
    * unfold createchain. case. case. move => d' k'. case => LL EE.
      by exists (lub (makechainm EE)).
    * move => X. rewrite addSn in L. rewrite <- addnS in L.
      have A: (pred_nth (cpred c n) k = Val d) by simpl ; rewrite <- pred_nth_Sn_acc.
      specialize (IH (S p) (cpred c) L A).
      case: IH => d' IH. exists d'. rewrite <- IH. by rewrite <- eq_Eps.
Qed.

Lemma cpredsamelub : forall (c:natO =-> lift_ordType D) k dk (H1:c k =-= Val dk) (H2: (cpred c) k =-= Val dk),
                      lub (makechainm H1) =-= lub (makechainm H2).
intros; split.
apply: lub_le; intro.
setoid_replace (makechainm H1 n) with (makechainm H2 n).
apply le_lub.
assert (Hkn := allvalsfromhere n H1).
destruct Hkn as (dkn,(Hckn,Hdkdkn)).
unfold makechainm; simpl.
setoid_rewrite (makechainworks H1 Hckn).
assert (HH : ((cpred c) (k+n)%N =-= Val dkn)).
unfold cpred; simpl.
rewrite <- Hckn.
apply Oeq_sym; apply predeq.
setoid_rewrite (makechainworks H2 HH).
auto.

apply: lub_le; intro.
setoid_replace (makechainm H2 n) with (makechainm H1 n).
apply le_lub.
destruct (allvalsfromhere n H2) as (dkn,(Hckn,Hdkdkn)).
unfold makechainm; simpl.
setoid_rewrite (makechainworks H2 Hckn).
assert (HH : ((c) (k+n)%N =-= Val dkn)).
unfold cpred in Hckn; simpl in Hckn.
rewrite <- Hckn; apply predeq.
setoid_rewrite (makechainworks H1 HH); auto.
Qed.

Lemma attempt2 : forall kl (c:natO =-> lift_ordType D) p d, pred_nth (DL_lubn c p) kl = Val d
                    -> exists k, exists dk, exists Hkdk:c k =-= Val dk, d =-= lub (makechainm Hkdk).
elim.
- simpl. move => c p d E. rewrite -> DL_lubn_inv in E.
  case: (fValIdx c p) E ; last by [].
  move => s. case => e. rewrite <- e. clear d e.
  case: s. case => d n [L E]. simpl. exists n. exists d. by exists E.
- move => k IH c p d E. simpl in E. unfold createchain in E.
  have HH:=IH (cpred c) (S p) d.
  case: (fValIdx c p) E.
  + case. case => d' n [P Q] E.
    specialize (IH c p d). rewrite E in IH. apply IH. by apply pred_nth_val.
  + move => X E. case: (HH E) => n [x [P Q]].
    exists n. exists x. have PP:=P. simpl in PP. have P0:=Oeq_trans (predeq _) P. exists P0. rewrite -> Q.
    by apply (Oeq_sym (cpredsamelub P0 P)).
Qed.

(* first just wrap pred_lubn_Val to use equality *)
Lemma chainVallubnVal : forall (c:natO =-> lift_ordType D) n d p, c n =-= Val d -> exists d', DL_lubn c p =-= Val d'.
intros.
destruct (eqValpred H) as (k,(d'',(Hcnk,Hdd''))).
apply (pred_lubn_Val (n:=n) (k:=k+n+1) (p:=p) (c:=c) (d:=d'')).
apply ltn_addr. rewrite <- addnA. apply ltn_addl. rewrite addnS. rewrite addn0. by apply ltnSn.
rewrite addnS. rewrite addn0. rewrite <- addnS.
rewrite pred_nth_sum.
rewrite Hcnk. by [].
Qed.

Lemma chainVallubnlub : forall (c:natO =-> lift_ordType D) n d (H : c n =-= Val d) p, exists d',  DL_lubn c p =-= Val d' /\ d' =-= lub (makechainm H).
intros.
destruct (chainVallubnVal p H) as (d',HH).
exists d'.
split. assumption.
destruct (eqValpred HH) as (k,(d'',(Hk,Hd'd''))).
destruct (attempt2 Hk) as (p',(dp',(Hp',Heq))).
rewrite Hd'd''.
rewrite -> Heq.
apply chainlubinv.
Qed.

Definition DL_lub (c:natO =-> lift_ordType D) := DL_lubn c 1.

Lemma DL_lub_upper : forall c:natO =-> lift_ordType D, forall n, c n <= DL_lub c.
intros c n. simpl. apply: DLless_cond.
intros d C.
destruct (chainVallubnlub C 1) as [d' [Ln L]].
unfold DL_lub. rewrite -> Ln.
assert (X:=makechainworks C). specialize (X 0 d). rewrite addn0 in X.
specialize (X C). apply Ole_trans with (y:=Val d). by auto.
assert (pred_nth (Val d') 0 = Val d') as Y by auto.
apply (DLleVal Y). rewrite -> L.
apply Ole_trans with (y:=(makechainm (c:=c) (k:=n) (d:=d) C) 0). simpl. by auto.
by apply le_lub.
Qed.

Lemma DL_lub_least : forall (c : natO =-> lift_ordType D) a,
                      (forall n, c n <= a) -> DL_lub c <= a.
intros c a C. simpl.
apply: DLless_cond. intros d X.
destruct (eqValpred X) as [n [dd [P Q]]].
destruct (attempt2 P) as [m [d' [cm Y]]].
apply Ole_trans with (y:= (Val dd)).
refine (proj2 (Val_exists_pred_eq _)). exists n. auto.
assert (Z:= C m). rewrite -> cm in Z.
destruct (DLvalval Z) as [mm [e [R S]]].
apply (DLleVal R). rewrite -> Y.
apply lub_le.
intros nn.
assert (A:=makechainworks cm).
specialize (A nn).
clear S Y Z.
destruct (allvalsfromhere nn cm) as [nnv [S T]].
specialize (A _ S). rewrite -> A. clear A.
assert (a =-= Val e) as E.
apply Oeq_sym.
apply (Val_exists_pred_eq). exists mm. apply R.
assert (Z := C (m+nn)%N).
rewrite -> E in Z. rewrite -> S in Z. apply (vleinj Z).
Qed.

(** *** Declaration of the lifted cpo *)

Lemma DLCpoAxiom : CPO.axiom DL_lub.
move => x y n.
split ; first by apply DL_lub_upper.
by apply DL_lub_least.
Qed.

Canonical Structure lift_cpoMixin := CpoMixin DLCpoAxiom.
Canonical Structure lift_cpoType := Eval hnf in CpoType lift_cpoMixin.

Lemma lubval: forall (c:natO =-> lift_cpoType) d, lub c =-= Val d ->
                exists k, exists d', c k =-= Val d' /\ d' <= d.
intros c d l.
destruct l as [lubval1 lubval2].
destruct (DLle_Val_exists_pred lubval2) as [k xx].
destruct xx as [f' [lubval lf]].
assert (lub c =-= Val f') as lubval'.
apply: Ole_antisym.
eapply Ole_trans. apply lubval1. by apply: DLle_leVal.
simpl.
(* apply: DLleVal works here in 8.4pl2 but not in pl5, so changed to eapply *)
eapply (DLleVal). apply lubval. apply Ole_refl.
assert (f' <= d).
destruct lubval' as [v1 v2].
assert (Val f' <= Val d).
apply (Ole_trans v2 lubval1).
apply (DLleVal_leq H).
assert (d =-= f') as feq. auto.
clear H lubval1 lubval2 lf.

assert (xx:=attempt2 lubval).
destruct xx as [n [f0 [chnval lf']]].
exists n. exists f0. split. apply chnval.
assert (w:=makechainworks chnval).
specialize (w 0 f0). rewrite addn0 in w.
specialize (w chnval).
destruct w as [_ L2].
refine (Ole_trans L2 (Ole_trans (le_lub (makechainm chnval) 0) _)).
rewrite <- lf'. by auto.
Qed.

(*==========================================================================
  Eta
  ==========================================================================*)

(** printing eta %\ensuremath{\eta}% *)

Lemma eta_cont : continuous (@eta_m D).
move => c. simpl. unfold lub. simpl. unfold DL_lub. rewrite -> DL_lubn_inv. simpl.
apply: DLle_leVal.
apply lub_le => n. apply: (Ole_trans _ (le_lub _ n)). simpl.
 rewrite -> makechainworks. by apply Ole_refl. by apply Oeq_refl.
Qed.

Definition eta : D =-> lift_cpoType := Eval hnf in mk_fcont eta_cont.

End Lift_cpo.

Implicit Arguments eta [D].

(** printing _BOT %\LIFTED% *)
Notation "x '_BOT'" := (lift_cpoType x) (at level 28).

Lemma liftOrdPointed (D:ordType) : Pointed.axiom (DL_bot D).
move => x. by apply DL_bot_least.
Qed.

Canonical Structure liftOrdPointedMixin D := PointedMixin (@liftOrdPointed D).
Canonical Structure liftOrdPointedType D := Eval hnf in PointedType (liftOrdPointedMixin D).

Lemma liftCpoPointed (D:cpoType) : Pointed.axiom (DL_bot D).
move => x. by apply DL_bot_least.
Qed.

Canonical Structure liftCppoMixin D := PointedMixin (@liftCpoPointed D).
Canonical Structure liftCppoType D := Eval hnf in CppoType (liftCppoMixin D).
Canonical Structure liftCpoPointedType (D:cpoType) := Eval hnf in @PointedType (D _BOT) (liftCppoMixin D).

Lemma liftFunPointed C (D:pointedType) : Pointed.axiom (@fmon_cte C D PBot).
move => f x. simpl. by apply leastP.
Qed.

Canonical Structure funOrdPointedMixin C D := PointedMixin (@liftFunPointed C D).
Canonical Structure funOrdPointedType C D := Eval hnf in PointedType (funOrdPointedMixin C D).

Lemma PBot_app D (E:cppoType) : forall d, (PBot:D -=> E) d =-= PBot.
move => d. by simpl.
Qed.

Lemma PBot_incon  (D:cpoType) (x:D) : eta x <= PBot -> False.
move => incon.
inversion incon. subst. clear x H1 incon.
elim: n H0.
- simpl. unfold Pointed.least. simpl. by rewrite -> DL_bot_eq.
- move => n IH. unfold Pointed.least. simpl. by apply IH.
Qed.

Lemma PBot_incon_eq (D:cpoType) (x:D) : eta x =-= PBot -> False.
intros [incon _].
apply (PBot_incon incon).
Qed.


Generalizable All Variables.
Set Primitive Projections.

Class Eq (A : Type) := {
  eqb  : A -> A -> bool;
  neqb : A -> A -> bool;

  eqb_refl x : eqb x x = true;
  eqb_sym x y : eqb x y = eqb y x;
  eqb_trans {x y z} : eqb x y = true -> eqb y z = true -> eqb x z = true;

  eqb_eq {x y} : eqb x y = true -> x = y;
}.

Infix "==" := eqb (at level 70).
Infix "/=" := neqb (at level 70).

Lemma eqb_neq `{Eq A} {x y} : eqb x y = false -> x <> y.
Proof.
  repeat intro; subst.
  pose proof (eqb_refl y).
  rewrite H0 in H1.
  inversion H1.
Qed.

From Equations Require Import Equations.
Set Equations With UIP.

#[export]
Program Instance Eq_EqDec `{Eq A} : EqDec A.
Next Obligation.
  destruct (eqb x y) eqn:Heqe.
  - left.
    now apply eqb_eq in Heqe.
  - right.
    intro.
    subst.
    apply eqb_neq in Heqe.
    contradiction.
Defined.


Require Export Bool.

Lemma neg2xor : forall b, xorb true b = negb b.
Proof. auto. Qed.

Goal forall b1 b2, (negb b1 = b2)  ->  xorb true b1 = b2.
Proof.
  intros b1 b2.
  rewrite neg2xor.


Theorem backward_small : (forall A B : Prop, A -> (A -> B) -> B).

Proof.
  intros A B.
  intros proof_of_A A_implies_B.
  refine (A_implies_B _).
  exact proof_of_A.
Qed.