(* Copyright (c) 2014, Robert Dockins *)

Require Import Setoid.

Require Import basics.
Require Import preord.
Require Import categories.
Require Import sets.
Require Import finsets.
Require Import esets.
Require Import effective.
Require Import plotkin.
Require Import joinable.
Require Import approx_rels.
Require Import profinite.
Require Import cpo.

(**  * Adjoint relation between the pointed and unpointed domains.

     Here we define the lifing and forgetful functors between pointed
     and unpointed domains, and show that they are adjoint.

     In addition, I show the counit of this adjunction has a partial inverse,
     which is a useful operation for "strictifying" a nonstrict hom.

     NOTE!! The naming convention here is opposite that of the companion
     paper.  Here the forgetful functor goes from unpointed domains to pointed
     domains, and the lifing functor goes from pointed domains to unpointed
     domains.
  *)

Program Definition plotkin_forget (A:preord)
  (Heff:effective_order A)
  (HA:plotkin_order false A) : plotkin_order true A

    := norm_plt A Heff true _.
Next Obligation.
  repeat intro. exists (mub_closure HA X).
  split; [ intros; apply mub_clos_incl; assumption | ].
  split.
  { hnf. hnf in Hinh.
    destruct Hinh as [x ?].
    exists x. apply mub_clos_incl; assumption.
  }
  repeat intro.
  generalize (mub_clos_mub HA X M).
  intros.
  destruct (mub_complete HA M z).
  - hnf; auto.
  - hnf; intros.
    apply H in H1.
    apply finsubset_elem in H1.
    + destruct H1; auto.
    + intros. rewrite <- H3; auto.
  - destruct H1.
    exists x. split; [ destruct H1; assumption | ].
    apply finsubset_elem.
    { intros. rewrite <- H3; auto. }
    split; auto.
    apply H0; auto.
    + hnf; auto.
    + hnf; intros.
      apply H in H3.
      apply finsubset_elem in H3.
      * destruct H3; auto.
      * intros. rewrite <- H5; auto.
Qed.

Definition forgetPLT_ob (X:ob PLT) : ob ∂PLT :=
  PLT.Ob _ (PLT.carrier _ X) (PLT.Class _ _
    (Preord.mixin (PLT.ord X))
    (PLT.effective X)
    (plotkin_forget _ (PLT.effective X) (PLT.plotkin X))).

Program Definition forgetPLT_map (X Y:ob PLT) (f:X → Y)
  : forgetPLT_ob X → forgetPLT_ob Y :=

  PLT.Hom _ (forgetPLT_ob X) (forgetPLT_ob Y)
    (@PLT.hom_rel _ X Y f) (PLT.hom_order _ X Y f) _.
Next Obligation.
  repeat intro. apply (PLT.hom_directed _ _ _ f); hnf; auto.
Qed.

Program Definition forgetPLT : functor PLT ∂PLT :=
  Functor PLT ∂PLT forgetPLT_ob forgetPLT_map _ _ _.
Solve Obligations of forgetPLT with auto.

Definition liftPPLT_ob (X:ob ∂PLT) : ob PLT :=
  PLT.Ob _ (option (PLT.carrier _ X)) (PLT.Class _ _
    (lift_mixin (PLT.ord X))
    (effective_lift (PLT.effective X))
    (lift_plotkin _ _ _  (PLT.plotkin X) (PLT.effective X))).

Definition liftPPLT_rel (X Y:preord) (HX:effective_order X) (f:erel X Y)
  : erel (lift X) (lift Y) :=
  union2 (union2 (single (None,None))
    (image (mk_pair (liftup X) (const (@None Y))) (eff_enum X HX)))
    (image (pair_map (liftup X) (liftup Y)) f).

Lemma liftPPLT_rel_elem X Y HX f :
  forall x y, (x,y) ∈ liftPPLT_rel X Y HX f <->
    (y ≈ None \/ exists a b, (a,b) ∈ f /\ x ≈ Some a /\ y ≈ Some b).
Proof.
  unfold liftPPLT_rel.
  intuition.
  - apply union2_elem in H. destruct H.
    + apply union2_elem in H. destruct H.
      * apply single_axiom in H.
        left.
        destruct H as [[??][??]]; split; auto.
      * apply image_axiom2 in H.
        destruct H as [q [??]].
        simpl in H0.
        left.
        destruct H0 as [[??][??]]; split; auto.
    + apply image_axiom2 in H.
      destruct H as [[p q] [??]].
      right.
      simpl in H0.
      exists p. exists q.
      split; auto.
      destruct H0 as [[??][??]]; split; split; auto.
  - apply union2_elem.
    left.
    apply union2_elem.
    destruct x.
    + right.
      apply image_axiom1'.
      simpl. exists c. split; auto.
      * split; split; auto.
      * apply eff_complete.
    + left.
      apply single_axiom.
      split; split; auto.
  - destruct H0 as [a [b [?[??]]]].
    apply union2_elem. right.
    apply image_axiom1'.
    exists (a,b). split; auto.
    simpl.
    split; split; auto.
Qed.

Program Definition liftPPLT_map (X Y:ob ∂PLT) (f:X → Y)
  : liftPPLT_ob X → liftPPLT_ob Y :=

  PLT.Hom _ (liftPPLT_ob X) (liftPPLT_ob Y)
     (liftPPLT_rel (PLT.ord X) (PLT.ord Y) (PLT.effective X) (@PLT.hom_rel _ X Y f))
      _ _.
Next Obligation.
  intros. simpl in *.
  apply liftPPLT_rel_elem.
  apply (liftPPLT_rel_elem (PLT.ord X) (PLT.ord Y)) in H1.
  destruct H1.
  - left.
    rewrite H1 in H0.
    split; auto. red; simpl; auto.
  - destruct H1 as [a [b [?[??]]]].
    destruct y'.
    + right.
      rewrite H2 in H.
      destruct x'.
      * exists c0. exists c.
        split; auto.
        apply PLT.hom_order with a b; auto.
        rewrite H3 in H0. auto.
      * elim H.
    + left; auto.
Qed.
Next Obligation.
  repeat intro.
  set (M' := unlift_list M).
  case_eq M'; intros.
  - exists None.
    split.
    + red; intros.
      destruct x0; auto.
      destruct H1 as [q [??]].
      destruct q.
      * assert (List.In c0 M').
        { apply in_unlift. auto. }
        rewrite H0 in H3. elim H3.
      * auto.
    + apply erel_image_elem.
      apply liftPPLT_rel_elem.
      auto.
  - destruct x.
    + destruct (PLT.hom_directed _ _ _ f c0 M').
      * exists c. rewrite H0. apply cons_elem; auto.
      * red; intros.
        destruct H1 as [q [??]].
        apply in_unlift in H1.
        assert (Some a ∈ M).
        { exists (Some q); split; auto. }
        apply H in H3.
        apply erel_image_elem in H3.
        apply (liftPPLT_rel_elem (PLT.ord X) (PLT.ord Y)) in H3.
        destruct H3.
        ** destruct H3. elim H3.
        ** destruct H3 as [m [n [?[??]]]].
           apply erel_image_elem.
           apply PLT.hom_order with m n; auto.
      * destruct H1.
        exists (Some x).
        split.
        ** red; intros.
           destruct x0.
           *** apply erel_image_elem in H2.
               apply H1.
               destruct H3 as [q [??]].
               destruct q.
               **** exists c2; split; auto.
                    apply in_unlift; auto.
               **** destruct H4. elim H4.
           *** red; auto.
        ** apply erel_image_elem in H2.
           apply erel_image_elem.
           apply liftPPLT_rel_elem.
           right; eauto.
    + assert (Some c ∈ M).
      { exists (Some c). split; auto.
        apply in_unlift.
        fold M'. rewrite H0. simpl; auto.
      }
      apply H in H1.
      apply erel_image_elem in H1.
      apply (liftPPLT_rel_elem (PLT.ord X) (PLT.ord Y)) in H1.
      destruct H1.
      * destruct H1. elim H1.
      * destruct H1 as [a [b [?[??]]]].
        destruct H2. elim H4.
Qed.

Program Definition liftPPLT : functor ∂PLT PLT :=
  Functor ∂PLT PLT liftPPLT_ob liftPPLT_map _ _ _.
Next Obligation.
  simpl; intros.
  split; hnf; simpl; intros.
  - destruct a as [a a'].
    apply (liftPPLT_rel_elem _ _ (PLT.effective A) (PLT.hom_rel f)) in H0.
    destruct H0.
    + apply ident_elem. rewrite H0. red; simpl; auto.
    + apply ident_elem.
      destruct H0 as [p [q [?[??]]]].
      rewrite H1. rewrite H2.
      destruct H. red in H. simpl in H.
      apply H in H0.
      apply ident_elem in H0. auto.
  - destruct a as [a a'].
    apply ident_elem in H0.
    apply (liftPPLT_rel_elem _ _ (PLT.effective A) (PLT.hom_rel f)).
    destruct a'; auto.
    right.
    destruct a; [ | solve [elim H0] ].
    exists c0. exists c.
    split; auto.
    destruct H. apply H1.
    simpl. apply ident_elem. auto.
Qed.
Next Obligation.
  intros.
  split; hnf; simpl; intros.
  - destruct a as [a c].
    apply compose_elem.
    { apply liftPPLT_map_obligation_1. }
    apply (liftPPLT_rel_elem _ _ (PLT.effective A) (PLT.hom_rel h)) in H0.
    destruct H0.
    + exists None.
      split.
      * apply (liftPPLT_rel_elem _ _ (PLT.effective A) (PLT.hom_rel g)); auto.
      * apply (liftPPLT_rel_elem _ _ (PLT.effective B) (PLT.hom_rel f)); auto.
    + destruct H0 as [a' [c' [?[??]]]].
      destruct H.
      apply H in H0.
      apply PLT.compose_hom_rel in H0.
      destruct H0 as [b' [??]].
      exists (Some b').
      split.
      * apply (liftPPLT_rel_elem _ _ (PLT.effective A) (PLT.hom_rel g)).
        right; eauto.
      * apply (liftPPLT_rel_elem _ _ (PLT.effective B) (PLT.hom_rel f)).
        right; eauto.

  - destruct a as [a c].
    apply PLT.compose_hom_rel in H0.
    destruct H0 as [b [??]]. simpl in b.
    apply (liftPPLT_rel_elem _ _ (PLT.effective A) (PLT.hom_rel g)) in H0.
    apply (liftPPLT_rel_elem _ _ (PLT.effective B) (PLT.hom_rel f)) in H1.
    apply (liftPPLT_rel_elem _ _ (PLT.effective A) (PLT.hom_rel h)).
    destruct H1; auto.
    destruct H0.
    + destruct H1 as [?[?[?[??]]]].
      rewrite H0 in H2. destruct H2. elim H4.
    + right.
      destruct H0 as [x [y [?[??]]]].
      destruct H1 as [x' [y' [?[??]]]].
      rewrite H3 in H4.
      exists x. exists y'.
      split; auto.
      destruct H. apply H6.
      simpl. apply compose_elem.
      * apply PLT.hom_order.
      * exists y.
        split; auto.
        apply PLT.hom_order with x' y'; auto.
Qed.
Next Obligation.
  intros.
  split; hnf; simpl; intros.
  - destruct a as [a b].
    apply (liftPPLT_rel_elem _ _ (PLT.effective A) (PLT.hom_rel f)) in H0.
    apply (liftPPLT_rel_elem _ _ (PLT.effective A) (PLT.hom_rel g)).
    destruct H0; auto.
    right.
    destruct H0 as [p [q [?[??]]]].
    exists p. exists q. split; auto.
    destruct H. apply H; auto.
  - destruct a as [a b].
    apply (liftPPLT_rel_elem _ _ (PLT.effective A) (PLT.hom_rel g)) in H0.
    apply (liftPPLT_rel_elem _ _ (PLT.effective A) (PLT.hom_rel f)).
    destruct H0; auto.
    right.
    destruct H0 as [p [q [?[??]]]].
    exists p. exists q. split; auto.
    destruct H. apply H3; auto.
Qed.

Definition adj_unit_rel (X:preord) (HX:effective_order X) : erel X (lift X) :=
 union2
    (image (mk_pair (id(X)) (const None)) (eff_enum X HX))
    (image (pair_map (id(X)) (liftup X))
      (esubset_dec _ (fun q => fst q ≥ snd q)
                  (fun q => eff_ord_dec X HX (snd q) (fst q))
                  (eprod (eff_enum X HX)
                         (eff_enum X HX)))).

Lemma adj_unit_rel_elem X HX x x' :
  (x,x') ∈ adj_unit_rel X HX <-> Some x ≥ x'.
Proof.
  unfold adj_unit_rel.
  split; intros.
  - apply union2_elem in H.
    destruct H.
    + apply image_axiom2 in H.
      destruct H as [y [??]].
      simpl in H0.
      destruct H0. destruct H0.
      transitivity (@None X); auto.
      red; simpl; auto.
    + apply image_axiom2 in H.
      destruct H as [y [??]].
      simpl in H0.
      apply esubset_dec_elem in H.
      * destruct H.
        destruct H0. destruct H0.
        transitivity (Some (snd y)); auto.
        transitivity (Some (fst y)); auto.
        destruct H2. auto.
      * intros.
        destruct H2 as [[??][??]].
        transitivity (snd x0); auto.
        transitivity (fst x0); auto.
  - apply union2_elem.
    destruct x'.
    + right.
      apply image_axiom1'.
      simpl. exists (x,c).
      split; auto.
      apply esubset_dec_elem.
      * intros.
        destruct H0 as [[??][??]].
        transitivity (snd x0); auto.
        transitivity (fst x0); auto.
      * split; auto.
        apply eprod_elem. split; apply eff_complete.
    + left.
      apply image_axiom1'.
      simpl. exists x. split; auto. apply eff_complete.
Qed.

Program Definition adj_unit_hom (X:ob PLT)
  : X → (liftPPLT (forgetPLT X))

  := PLT.Hom _ X (liftPPLT (forgetPLT X)) (adj_unit_rel (PLT.ord X) (PLT.effective X)) _ _.
Next Obligation.
  intros.
  apply adj_unit_rel_elem in H1.
  apply adj_unit_rel_elem.
  transitivity y; auto.
  transitivity (Some x); auto.
Qed.
Next Obligation.
  repeat intro.
  exists (Some x).
  split.
  - red; intros.
    apply H in H0.
    apply erel_image_elem in H0.
    apply adj_unit_rel_elem in H0. auto.
  - apply erel_image_elem.
    apply adj_unit_rel_elem.
    auto.
Qed.

Program Definition adj_unit : nt id(PLT) (liftPPLT ∘ forgetPLT)
  := NT id(PLT) (liftPPLT ∘ forgetPLT) adj_unit_hom _.
Next Obligation.
  simpl; intros.
  split; hnf; simpl; intros.
  - destruct a as [a b].
    apply PLT.compose_hom_rel in H.
    destruct H as [b' [??]].
    simpl in H0.
    apply adj_unit_rel_elem in H0.
    apply PLT.compose_hom_rel.
    simpl.
    exists (Some a).
    split.
    + apply adj_unit_rel_elem. auto.
    + rewrite (liftPPLT_rel_elem _ _ _ (PLT.hom_rel f)).
      destruct b; auto.
      right.
      exists a. exists c.
      split; auto.
      apply PLT.hom_order with a b'; auto.

  - destruct a as [a b].
    apply PLT.compose_hom_rel in H.
    simpl in H.
    destruct H as [a' [??]].
    apply adj_unit_rel_elem in H.
    apply PLT.compose_hom_rel.
    apply (liftPPLT_rel_elem _ _ (PLT.effective A) (PLT.hom_rel f)) in H0.
    destruct H0.
    + destruct (PLT.hom_directed _ _ _ f a nil).
      * red; simpl; auto.
      * red; simpl; intros. apply nil_elem in H1. elim H1.
      * destruct H1. apply erel_image_elem in H2.
        exists x. split; auto.
        apply adj_unit_rel_elem; auto.
        rewrite H0. red; simpl; auto.
    + destruct H0 as [p [q [?[??]]]].
      exists q. split; auto.
      * apply PLT.hom_order with p q; auto.
        rewrite H1 in H. auto.
      * apply adj_unit_rel_elem. auto.
Qed.

Definition adj_counit_rel (Y:ob ∂PLT)
  : erel (forgetPLT (liftPPLT Y)) Y :=

    (image (pair_map (liftup Y) (id(PLT.ord Y)))
      (esubset_dec _ (fun q => fst q ≥ snd q)
                  (fun q => eff_ord_dec Y (PLT.effective Y) (snd q) (fst q))
                  (eprod (eff_enum Y (PLT.effective Y))
                         (eff_enum Y (PLT.effective Y))))).

Lemma adj_counit_rel_elem Y : forall y y',
  (y,y') ∈ adj_counit_rel Y <-> y ≥ Some y'.
Proof.
  unfold adj_counit_rel.
  intuition.
  - apply image_axiom2 in H.
    destruct H as [[p q] [??]].
    apply esubset_dec_elem in H.
    + destruct H.
      simpl in H0.
      destruct H0 as [[??][??]]. simpl in *.
      transitivity (Some q); auto.
      transitivity (Some p); auto.
    + intros. destruct H2 as [[??][??]].
      transitivity (snd x); auto.
      transitivity (fst x); auto.

  - apply image_axiom1'.
    destruct y.
    + exists (c,y'). split; simpl; auto.
      apply esubset_dec_elem.
      * intros. destruct H0 as [[??][??]].
        transitivity (snd x); auto.
        transitivity (fst x); auto.
      * split; auto.
        apply eprod_elem. split; apply eff_complete.
    + elim H.
Qed.

Program Definition adj_counit_hom Y : forgetPLT (liftPPLT Y) → Y :=
  PLT.Hom _ (forgetPLT (liftPPLT Y)) Y (adj_counit_rel Y) _ _.
Next Obligation.
  intros.
  apply adj_counit_rel_elem in H1.
  apply adj_counit_rel_elem.
  transitivity (Some y); auto.
  transitivity x; auto.
Qed.
Next Obligation.
  repeat intro.
  destruct x.
  - exists c.
    split.
    + red; intros.
      apply H in H0.
      apply image_axiom2 in H0.
      destruct H0 as [[p q] [??]].
      apply esubset_dec_elem in H0.
      * destruct H0.
        simpl in H1, H2.
        rewrite H1.
        apply adj_counit_rel_elem in H0.
        rewrite H2 in H0. auto.
      * simpl; intros.
        destruct H3 as [[??][??]]; auto.
        transitivity (fst x0); auto.
    + apply erel_image_elem.
      apply adj_counit_rel_elem. auto.

  - destruct Hinh as [q ?].
    apply H in H0.
    apply erel_image_elem in H0.
    apply adj_counit_rel_elem in H0.
    elim H0.
Qed.

Program Definition adj_counit : nt (forgetPLT ∘ liftPPLT) id(∂PLT)
  := NT (forgetPLT ∘ liftPPLT) id(∂PLT) adj_counit_hom _.
Next Obligation.
  intros.
  split; hnf; simpl; intros.
  - destruct a as [a b].
    apply PLT.compose_hom_rel in H; simpl.
    simpl in H.
    destruct H as [b' [??]].
    apply (adj_counit_rel_elem B) in H0.
    apply (liftPPLT_rel_elem _ _ (PLT.effective A) (PLT.hom_rel f)) in H.
    destruct H.
    + rewrite H in H0. elim H0.
    + destruct H as [p [q [?[??]]]].
      apply PLT.compose_hom_rel.
      rewrite H2 in H0.
      exists p.
      split.
      * apply adj_counit_rel_elem.
        rewrite H1; auto.
      * apply PLT.hom_order with p q; auto.

  - destruct a as [a b].
    apply PLT.compose_hom_rel in H; simpl.
    destruct H as [a' [??]].
    apply adj_counit_rel_elem in H.
    destruct a; [ | solve [elim H] ].
    apply PLT.compose_hom_rel. simpl.
    exists (Some b).
    split.
    + apply (liftPPLT_rel_elem _ _ (PLT.effective A) (PLT.hom_rel f)).
      right.
      exists c. exists b. split; auto.
      apply (PLT.hom_order _ _ _ f) with a' b; auto.
    + apply adj_counit_rel_elem. auto.
Qed.

Program Definition adj_counit_inv_hom Y : Y → forgetPLT (liftPPLT Y) :=
  PLT.Hom _ Y (forgetPLT (liftPPLT Y)) (adj_unit_rel (PLT.ord Y) (PLT.effective Y)) _ _.
Next Obligation.
  intros.
  apply adj_unit_rel_elem in H1.
  apply adj_unit_rel_elem.
  transitivity y; auto.
  transitivity (Some x); auto.
Qed.
Next Obligation.
  repeat intro.
  exists (Some x).
  split.
  red; intros.
  apply H in H0.
  apply erel_image_elem in H0.
  apply adj_unit_rel_elem in H0. auto.
  apply erel_image_elem.
  apply adj_unit_rel_elem.
  auto.
Qed.

Lemma adj_counit_inv_ntish : forall A B f,
  adj_counit_inv_hom B ∘ f ≤ forgetPLT·liftPPLT·f ∘ adj_counit_inv_hom A.
Proof.
  intros. hnf; simpl; intros.
  destruct a as [a b].
  apply PLT.compose_hom_rel in H.
  apply PLT.compose_hom_rel. simpl.
  exists (Some a). split.
  - apply adj_unit_rel_elem; auto.
  - apply (liftPPLT_rel_elem _ _ (PLT.effective A) (PLT.hom_rel f)).
    destruct H as [y [??]].
    simpl in H0.
    apply adj_unit_rel_elem in H0.
    destruct b; auto.
    right.
    exists a. exists c. split; auto.
    apply PLT.hom_order with a y; auto.
Qed.

Lemma adj_counit_inv_le Y : adj_counit_inv_hom Y ∘ adj_counit Y ≤ id.
Proof.
  hnf; simpl; intros.
  destruct a as [y y'].
  apply PLT.compose_hom_rel in H.
  destruct H as [y'' [??]].
  apply adj_counit_rel_elem in H.
  simpl in H0.
  apply adj_unit_rel_elem in H0.
  apply ident_elem.
  transitivity (Some y''); auto.
Qed.

Lemma adj_counit_inv_largest Y : forall f,
  f ∘ adj_counit Y ≤ id -> f ≤ adj_counit_inv_hom Y.
Proof.
  repeat intro; simpl in *.
  destruct a.
  apply adj_unit_rel_elem.
  assert ((Some c, o) ∈ PLT.hom_rel (f ∘ adj_counit_hom Y)).
  { apply (PLT.compose_hom_rel _ _ _ _ (adj_counit_hom Y) f).
    exists c. split; auto.
    apply adj_counit_rel_elem. auto.
  }
  apply H in H1.
  simpl in H1.
  apply ident_elem in H1. auto.
Qed.

Lemma adj_counit_inv_eq Y : adj_counit Y ∘ adj_counit_inv_hom Y ≈ id.
Proof.
  split; hnf; simpl; intros.
  - destruct a as [y y'].
    apply PLT.compose_hom_rel in H.
    simpl in H.
    destruct H as  [y'' [??]].
    apply adj_unit_rel_elem in H.
    apply ident_elem.
    rewrite (adj_counit_rel_elem Y) in H0.
    destruct y''.
    + transitivity c; auto.
    + elim H0.

  - destruct a as [y y'].
    apply ident_elem in H.
    apply PLT.compose_hom_rel.
    exists (Some y').
    split.
    + apply adj_unit_rel_elem. auto.
    + apply adj_counit_rel_elem; auto.
Qed.

Lemma adj_inv_eq : forall A B (f:A → liftPPLT B),
  (forall a, exists b, (a, Some b) ∈ PLT.hom_rel f) ->
  adj_counit_inv_hom B ∘ adj_counit B ∘ forgetPLT·f ≈ forgetPLT·f.
Proof.
  intros. split.
  - transitivity (id ∘ forgetPLT·f).
    + apply PLT.compose_mono; [ auto; fail |].
      apply adj_counit_inv_le.
    + rewrite (cat_ident2 ∂PLT). auto.
  - hnf. intros [x y] H0.
    apply PLT.compose_hom_rel.
    destruct y.
    + exists (Some c). split; auto.
      apply PLT.compose_hom_rel.
      exists c. split.
      * apply adj_counit_rel_elem. auto.
      * apply adj_unit_rel_elem. auto.
    + destruct (H x) as [y ?].
      exists (Some y). split; auto.
      apply PLT.compose_hom_rel.
      exists y. split.
      * apply adj_counit_rel_elem. auto.
      * apply adj_unit_rel_elem. hnf. auto.
Qed.

Lemma adj_inv_eq_converse : forall A B (f:A → liftPPLT B),
  adj_counit_inv_hom B ∘ adj_counit B ∘ forgetPLT·f ≥ forgetPLT·f ->
  (forall a, exists b, (a, Some b) ∈ PLT.hom_rel f).
Proof.
  repeat intro.
  destruct (PLT.hom_directed false A (liftPPLT B) f a nil).
  - hnf; auto.
  - red; intros. apply nil_elem in H0. elim H0.
  - destruct H0 as [_ ?].
    apply erel_image_elem in H0.
    generalize (H _ H0).
    intros.
    rewrite (PLT.compose_hom_rel true _ _ _
      (forgetPLT·f)
      (adj_counit_inv_hom B ∘ adj_counit B)
      a x) in H1.
    destruct H1 as [q [??]].
    simpl in H1.
    apply PLT.compose_hom_rel in H2.
    destruct H2 as [y [??]].
    simpl in H2.
    apply adj_counit_rel_elem in H2.
    destruct q.
    + eauto.
    + elim H2.
Qed.

Program Definition PLT_adjoint : adjunction forgetPLT liftPPLT :=
  Adjunction forgetPLT liftPPLT adj_unit adj_counit _ _.
Next Obligation.
  split; hnf; simpl; intros.
  - destruct a as [a a'].
    apply ident_elem.
    apply PLT.compose_hom_rel in H; simpl in *.
    destruct H as [y [??]].
    apply adj_unit_rel_elem in H.
    apply (adj_counit_rel_elem (forgetPLT_ob A)) in H0.
    change (Some a' ≤ Some a).
    transitivity y; auto.

  - destruct a as [a a'].
    apply ident_elem in H.
    apply PLT.compose_hom_rel; simpl in *.
    exists (Some a).
    split.
    + apply adj_unit_rel_elem. auto.
    + apply (adj_counit_rel_elem (forgetPLT_ob A)); auto.
Qed.
Next Obligation.
  split; hnf; simpl; intros.
  - destruct a as [a a'].
    apply ident_elem.
    apply PLT.compose_hom_rel in H; simpl in *.
    destruct H as [y [??]].
    apply adj_unit_rel_elem in H.
    apply (liftPPLT_rel_elem _ _ (PLT.effective _) (adj_counit_rel A)) in H0.
    destruct H0.
    + rewrite H0. red; simpl; auto.
    + destruct H0 as [p [q [?[??]]]].
      rewrite H2.
      apply (adj_counit_rel_elem A) in H0.
      transitivity p; auto.
      rewrite H1 in H. auto.

  - destruct a as [a a'].
    apply ident_elem in H.
    apply PLT.compose_hom_rel; simpl in *.
    exists (Some a).
    split.
    + apply adj_unit_rel_elem. auto.
    + apply (liftPPLT_rel_elem _ _ (PLT.effective _) (adj_counit_rel A)).
      destruct a'; auto.
      right.
      destruct a.
      * simpl.
        exists (Some c0). exists c.
        split; auto.
        apply (adj_counit_rel_elem A). auto.
      * elim H.
Qed.

Notation U := liftPPLT.
Notation L := forgetPLT.
Notation ε := (adj_counit _).
Notation η := (adj_unit _).
Notation γ := (adj_counit_inv_hom _).

Definition plt_hom_adj (X:PLT) (Y:∂PLT) (f:X → U Y) : L X → Y
  := ε ∘ L·f.

Definition plt_hom_adj' (X:PLT) (Y:∂PLT) (f:L X → Y) : X → U Y
  := U·f ∘ η.

Arguments plt_hom_adj [X Y] f.
Arguments plt_hom_adj' [X Y] f.

Notation Ψ := plt_hom_adj.
Notation "Ψ⁻¹" := plt_hom_adj'.

Lemma plt_hom_adj1 (X:PLT) (Y:∂PLT) (f:X → U Y) : Ψ⁻¹ (Ψ f) ≈ f.
Proof.
  unfold plt_hom_adj, plt_hom_adj'.
  rewrite (Functor.compose U) ; [ | reflexivity ].
  rewrite <- (cat_assoc PLT).
  rewrite <- (NT.axiom adj_unit f).
  rewrite (cat_assoc PLT).
  generalize (Adjunction.adjoint_axiom2 PLT_adjoint Y); intros.
  rewrite H. apply cat_ident2.
Qed.

Lemma plt_hom_adj2 (X:PLT) (Y:∂PLT) (f:L X → Y) : Ψ (Ψ⁻¹ f) ≈ f.
Proof.
  unfold plt_hom_adj, plt_hom_adj'.
  rewrite (Functor.compose L); [ | reflexivity ].
  rewrite (cat_assoc ∂PLT).
  rewrite (NT.axiom adj_counit f).
  rewrite <- (cat_assoc ∂PLT).
  generalize (Adjunction.adjoint_axiom1 PLT_adjoint X); intros.
  rewrite H. apply cat_ident1.
Qed.

Lemma U_mono : forall (X Y:ob ∂PLT) (f f':X → Y),
  f ≤ f' -> U·f ≤ U·f'.
Proof.
  repeat intro; simpl in *.
  destruct a as [x y].
  apply (liftPPLT_rel_elem _ _ _ (PLT.hom_rel f)) in H0.
  apply (liftPPLT_rel_elem _ _ _ (PLT.hom_rel f')).
  destruct H0; auto. right.
  destruct H0 as [a [b [?[??]]]].
  exists a. exists b. split; auto.
Qed.

Lemma U_reflects : forall (X Y:ob ∂PLT) (f f':X → Y),
  U·f ≤ U·f' -> f ≤ f'.
Proof.
  repeat intro; simpl in *.
  destruct a as [x y].
  assert ((Some x, Some y) ∈ (PLT.hom_rel (liftPPLT_map X Y f))).
  { simpl.
    apply (liftPPLT_rel_elem _ _ _ (PLT.hom_rel f)).
    right. exists x. exists y. split; auto.
  }
  apply H in H1.
  simpl in H1.
  apply (liftPPLT_rel_elem _ _ _ (PLT.hom_rel f')) in H1.
  destruct H1.
  - destruct H1. elim H1.
  - destruct H1 as [a [b [?[??]]]].
    apply member_eq with (a,b); auto.
    split; split; auto.
Qed.

Lemma L_mono : forall (X Y:ob PLT) (f f':X → Y),
  f ≤ f' -> L·f ≤ L·f'.
Proof.
  auto.
Qed.

Lemma L_reflects : forall (X Y:ob PLT) (f f':X → Y),
  L·f ≤ L·f' -> f ≤ f'.
Proof.
  auto.
Qed.

Lemma Psi_mono (X:PLT) (Y:∂PLT) (f g:X → U Y) :
  f ≤ g -> Ψ f ≤ Ψ g.
Proof.
  unfold plt_hom_adj. intros.
  apply PLT.compose_mono; auto.
Qed.

Lemma Psi_inv_mono (X:PLT) (Y:∂PLT) (f g:L X → Y) :
  f ≤ g -> Ψ⁻¹ f ≤ Ψ⁻¹ g.
Proof.
  unfold plt_hom_adj'. intros.
  apply PLT.compose_mono; auto.
  apply U_mono. auto.
Qed.

Lemma Psi_reflects (X:PLT) (Y:∂PLT) (f g:X → U Y) :
  Ψ f ≤ Ψ g -> f ≤ g.
Proof.
  intros.
  rewrite <- (plt_hom_adj1 X Y f).
  rewrite <- (plt_hom_adj1 X Y g).
  apply Psi_inv_mono; auto.
Qed.

Lemma Psi_inv_reflects (X:PLT) (Y:∂PLT) (f g:L X → Y) :
  Ψ⁻¹ f ≤ Ψ⁻¹ g -> f ≤ g.
Proof.
  intros.
  rewrite <- (plt_hom_adj2 X Y f).
  rewrite <- (plt_hom_adj2 X Y g).
  apply Psi_mono; auto.
Qed.

Lemma U_bottom_least (X:PLT) (Y:∂PLT) (f:X → U Y) :
  Ψ⁻¹ ⊥ ≤ f.
Proof.
  intros.
  apply Psi_reflects.
  rewrite plt_hom_adj2.
  apply bottom_least.
Qed.

Instance lift_plt_pointed (X:PLT) (Y:∂PLT) :
  pointed (PLT.homset_cpo _ X (liftPPLT Y)) :=
  { bottom := Ψ⁻¹ ⊥
  ; bottom_least := U_bottom_least X Y
  }.

Program Definition lift_unit : 1 → L 1
  := PLT.Hom true 1 (L 1) (ident_rel effective_unit) _ _.
Next Obligation.
  intros. eapply ident_ordering; eauto.
Qed.
Next Obligation.
  intros. apply ident_image_dir.
Qed.

Program Definition lift_unit' : L 1 → 1
  := PLT.Hom true (L 1) 1 (ident_rel effective_unit) _ _.
Next Obligation.
  intros. eapply ident_ordering; eauto.
Qed.
Next Obligation.
  intros. apply ident_image_dir.
Qed.

Lemma lift_unit_id1 : lift_unit ∘ lift_unit' ≈ id.
Proof.
  split; hnf; intros.
  destruct a. destruct c. destruct c0.
  simpl. apply ident_elem. auto.
  destruct a. destruct c. destruct c0.
  apply PLT.compose_hom_rel. exists tt.
  split; simpl; apply ident_elem; auto.
Qed.

Lemma lift_unit_id2 : lift_unit' ∘ lift_unit ≈ id.
Proof.
  split; hnf; intros.
  destruct a. destruct c. destruct c0.
  simpl. apply ident_elem. auto.
  destruct a. destruct c. destruct c0.
  apply PLT.compose_hom_rel. exists tt.
  split; simpl; apply ident_elem; auto.
Qed.

Program Definition lift_prod (A B:PLT) : (L A ⊗ L B) → L (A × B)
  := PLT.Hom true (L A ⊗ L B) (L (A × B))
          (ident_rel (effective_prod (PLT.effective A) (PLT.effective B)))
          _ _.
Next Obligation.
  intros. eapply ident_ordering; eauto.
Qed.
Next Obligation.
  intros. apply ident_image_dir.
Qed.

Program Definition lift_prod' (A B:PLT) : L (A × B) → L A ⊗ L B
  := PLT.Hom true (L (A × B)) (L A ⊗ L B)
          (ident_rel (effective_prod (PLT.effective A) (PLT.effective B)))
          _ _.
Next Obligation.
  intros. eapply ident_ordering; eauto.
Qed.
Next Obligation.
  intros. apply ident_image_dir.
Qed.

Lemma lift_prod_id1 A B : lift_prod A B ∘ lift_prod' A B ≈ id.
Proof.
  split; hnf; intros.
  - destruct a.
    apply PLT.compose_hom_rel in H.
    destruct H as [q [??]].
    simpl in *. apply ident_elem in H. apply ident_elem in H0.
    apply ident_elem. transitivity q; auto.
  - destruct a.
    apply PLT.compose_hom_rel.
    simpl. exists c0.
    simpl in *. apply ident_elem in H.
    split; apply ident_elem; auto.
Qed.

Lemma lift_prod_id2 A B : lift_prod' A B ∘ lift_prod A B ≈ id.
Proof.
  split; hnf; intros.
  - destruct a.
    apply PLT.compose_hom_rel in H.
    destruct H as [q [??]].
    simpl in *. apply ident_elem in H. apply ident_elem in H0.
    apply ident_elem. transitivity q; auto.
  - destruct a.
    apply PLT.compose_hom_rel.
    simpl. exists c0.
    simpl in *. apply ident_elem in H.
    split; apply ident_elem; auto.
Qed.

Local Transparent PLT.pair.

Lemma lift_prod_pair C A B (f:C → A) (g:C → B) :
  lift_prod A B ∘ 《L·f, L·g》 ≈ L·〈f, g〉.
Proof.
  split; hnf; intros.
  - destruct a.
    apply PLT.compose_hom_rel in H.
    destruct H as [q [??]].
    simpl in H0.
    apply ident_elem in H0.
    revert H.
    apply pair_rel_ordering; auto.
    + apply PLT.hom_order.
    + apply PLT.hom_order.
  - destruct a.
    apply PLT.compose_hom_rel.
    exists c0.
    split; auto.
    simpl. apply ident_elem. auto.
Qed.

Lemma lift_prod_pair' C A B (f:C → A) (g:C → B) :
  《L·f, L·g》 ≈ lift_prod' A B ∘ L·〈f, g〉.
Proof.
  split; hnf; intros.
  - destruct a.
    apply PLT.compose_hom_rel.
    exists c0.
    split; auto.
    simpl. apply ident_elem. auto.
  - destruct a.
    apply PLT.compose_hom_rel in H.
    destruct H as [q [??]].
    simpl in H0.
    apply ident_elem in H0.
    simpl.
    destruct c0. destruct q.
    apply (pair_rel_elem _ _ _ _ _ _ c c0 c1).
    simpl in H.
    rewrite (pair_rel_elem _ _ _ _ _ _ c c2 c3) in H.
    destruct H. destruct H0. simpl in *. split.
    + eapply (PLT.hom_order _ _ _ f); eauto.
    + eapply (PLT.hom_order _ _ _ g); eauto.
Qed.

Lemma lift_prod_natural A B C D (f:A → B) (g:C → D) :
  lift_prod B D ∘ PLT.pair_map (L·f) (L·g) ≈ L·(PLT.pair_map f g) ∘ lift_prod A C.
Proof.
  split; hnf; intros.
  - destruct a.
    apply PLT.compose_hom_rel in H.
    destruct H as [q [??]]. destruct q.
    apply PLT.compose_hom_rel.
    exists c. split.
    + simpl. apply ident_elem. auto.
    + simpl in H0.
      apply ident_elem in H0.
      apply PLT.hom_order with c (c1,c2); auto.
  - destruct a.
    apply PLT.compose_hom_rel in H.
    destruct H as [q [??]].
    apply PLT.compose_hom_rel.
    exists c0. split.
    + apply PLT.hom_order with q c0; auto.
      simpl in H. apply ident_elem in H. auto.
    + simpl. apply ident_elem. auto.
Qed.

Lemma lift_prod'_natural (A B C D:PLT) (f:A → B) (g:C → D) :
   PLT.pair_map (L·f) (L·g) ∘ lift_prod' A C ≈ lift_prod' B D ∘ L·(PLT.pair_map f g).
Proof.
  split; hnf; intros.
  - destruct a.
    apply PLT.compose_hom_rel in H.
    destruct H as [q [??]]. destruct q.
    apply PLT.compose_hom_rel.
    exists c0. split.
    + simpl in H. apply ident_elem in H.
      apply PLT.hom_order with (c1,c2) c0; auto.
    + simpl. apply ident_elem. auto.
  - destruct a.
    apply PLT.compose_hom_rel in H.
    destruct H as [q [??]].
    apply PLT.compose_hom_rel.
    exists c. split.
    + simpl. apply ident_elem; auto.
    + apply PLT.hom_order with c q; auto.
      simpl in H0. apply ident_elem in H0. auto.
Qed.

Arguments lift_prod {A B}.
Arguments lift_prod' {A B}.

Section strictify.
  Variables X Y:ob ∂PLT.
  Variable f: U X → U Y.

  Definition strictify : X → Y := ε ∘ L·f ∘ γ.

  Lemma f_explode : U·(ε ∘ L·f) ∘ η ≈ f.
  Proof.
    apply plt_hom_adj1.
  Qed.

  Lemma strictify_le : U·strictify ≤ f.
  Proof.
    unfold strictify.
    rewrite Functor.compose; [ | reflexivity ].
    rewrite <- f_explode at 2.
    apply PLT.compose_mono.

    - generalize (Adjunction.adjoint_axiom2 PLT_adjoint).
      intro.
      generalize (H X).
      intros.
      transitivity (U·adj_counit_inv_hom X ∘ id (U X)).
      { rewrite (cat_ident1 _ _ _ (U·adj_counit_inv_hom X)). auto. }
      rewrite <- H0.
      simpl.
      rewrite (cat_assoc _ _ _ _ _ (U·adj_counit_inv_hom X)).
      rewrite <- (Functor.compose U); [ | reflexivity ].
      transitivity (id ∘ adj_unit_hom (U X)).
      { apply PLT.compose_mono. auto.
        transitivity (U·(id (L(U(X))))).
        - apply U_mono.
          apply adj_counit_inv_le.
        - rewrite Functor.ident; auto.
      }
      rewrite (cat_ident2 _ _ _ (adj_unit_hom _)). auto.
    - auto.
  Qed.

  Lemma strictify_largest : forall q, U·q ≤ f -> q ≤ strictify.
  Proof.
    intros.
    unfold strictify.
    transitivity (adj_counit Y ∘ L·U·q ∘ adj_counit_inv_hom X).
    { transitivity (adj_counit Y ∘ adj_counit_inv_hom Y ∘ q).
      { rewrite (adj_counit_inv_eq Y).
        rewrite (cat_ident2 _ _ _ q). auto.
      }
      rewrite <- (cat_assoc _ _ _ _ _ (adj_counit Y)).
      rewrite <- (cat_assoc _ _ _ _ _ (adj_counit Y)).
      apply PLT.compose_mono; auto.
      apply adj_counit_inv_ntish.
    }
    rewrite <- (cat_assoc _ _ _ _ _ (adj_counit Y)).
    rewrite <- (cat_assoc _ _ _ _ _ (adj_counit Y)).
    apply PLT.compose_mono; auto.
    apply PLT.compose_mono; auto.
  Qed.
End strictify.

Lemma U_hom_rel (A B:∂PLT) (f:A → B) (a:U A) (b:U B) :
  (a,b) ∈ PLT.hom_rel (U·f) <->
  (b = None \/ exists a' b', (a',b') ∈ PLT.hom_rel f /\ a = Some a' /\ b = Some b').
Proof.
  simpl. split; intros.
  - rewrite  (liftPPLT_rel_elem _ _ _ _ a b) in H.
    destruct H.
    + destruct b; auto.
      destruct H. elim H.
    + destruct H as [p [q [?[??]]]].
      right.
      destruct a.
      * destruct b.
        ** exists c. exists c0. split; auto.
           revert H. apply PLT.hom_order; auto.
        ** destruct H1. elim H2.
      * destruct H0. elim H2.
  - apply liftPPLT_rel_elem.
    destruct H.
    + subst b; auto.
    + destruct H as [p [q [?[??]]]].
      subst a b.
      right. eauto.
Qed.

Lemma L_hom_rel (A B:PLT) (f:A → B) (a:L A) (b:L B) :
  (a,b) ∈ PLT.hom_rel (L·f) <-> (a,b) ∈ PLT.hom_rel f.
Proof.
  split; auto.
Qed.

Definition lift (X:PLT) : PLT := U (L X).
Definition colift (X:∂PLT) : ∂PLT := L (U X).

Definition smash_prod (A B:∂PLT) : U A × U B → U (A ⊗ B)
  := U·(PLT.pair_map ε ε ∘ lift_prod') ∘ η.

Definition unsmash_prod (A B:∂PLT) : U (A ⊗ B) → U A × U B
  := 〈 U·π₁, U·π₂ 〉.

Inductive smash_prod_spec (A B:∂PLT) :  U A × U B -> U (A ⊗ B) -> Prop :=
  | smash_some : forall x x' y y',
         x' ≤ x -> y' ≤ y ->
         smash_prod_spec A B (Some x, Some y) (Some (x',y'))
  | smash_none : forall m, smash_prod_spec A B m None.

Lemma smash_prod_iff (A B:∂PLT) m n :
  (m,n) ∈ PLT.hom_rel (smash_prod A B) <-> smash_prod_spec A B m n.
Proof.
  unfold smash_prod. split; intro.
  - apply PLT.compose_hom_rel in H.
    destruct H as [y [??]].
    apply adj_unit_rel_elem in H.
    apply U_hom_rel in H0.
    destruct H0.
    + subst n.
      apply smash_none.
    + destruct H0 as [a' [b' [?[??]]]]. subst y n.
      apply PLT.compose_hom_rel in H0.
      destruct H0 as [q [??]].
      unfold PLT.pair_map in H1.
      destruct b'.
      rewrite (PLT.pair_hom_rel true _ _ _ _ _ q c c0) in H1.
      destruct H1.
      destruct m.
      destruct H. simpl in *.
      destruct a'. simpl in *.
      apply ident_elem in H0.
      apply PLT.compose_hom_rel in H1.
      apply PLT.compose_hom_rel in H2.
      destruct H1 as [q1 [??]].
      destruct H2 as [q2 [??]].
      simpl in H4. simpl in H5.
      apply adj_counit_rel_elem in H4.
      apply adj_counit_rel_elem in H5.
      destruct q.
      simpl in *.
      apply (pi1_rel_elem  _ _ _ _ o1 o2 q1) in H1.
      apply (pi2_rel_elem  _ _ _ _ o1 o2 q2) in H2.
      destruct H0. simpl in *.
      assert (Some c ≤ c1).
      { rewrite H4. rewrite H1. rewrite H0. auto. }
      assert (Some c0 ≤ c2).
      { rewrite H5. rewrite H2. rewrite H6. auto. }
      destruct c1.
      * destruct c2.
        ** apply smash_some; auto.
        ** elim H8.
      * elim H7.

  - inversion H.
    + subst.
      apply PLT.compose_hom_rel.
      exists (Some (Some x, Some y)).
      split.
      * apply adj_unit_rel_elem. auto.
      * apply U_hom_rel. right.
        exists (Some x, Some y).
        exists (x',y'). split; auto.
        apply PLT.compose_hom_rel.
        simpl.
        exists (Some x, Some y).
        split.
        ** apply ident_elem. auto.
        ** apply PLT.pair_hom_rel. split.
           *** apply PLT.compose_hom_rel.
               exists (Some x). split.
               **** apply pi1_rel_elem. auto.
               **** simpl. apply adj_counit_rel_elem. auto.
           *** apply PLT.compose_hom_rel.
               exists (Some y). split.
               **** apply pi2_rel_elem. auto.
               **** simpl. apply adj_counit_rel_elem. auto.
    + subst m0 n.
      apply PLT.compose_hom_rel.
      exists None.
      split.
      * apply adj_unit_rel_elem. hnf. auto.
      * apply U_hom_rel. auto.
Qed.

Lemma smash_unsmash (A B:∂PLT) :
  smash_prod A B ∘ unsmash_prod A B ≈ id.
Proof.
  split; hnf; intros.
  - destruct a.
    apply PLT.compose_hom_rel in H.
    destruct H as [q [??]].
    rewrite smash_prod_iff in H0.
    destruct q.
    unfold unsmash_prod in H.
    rewrite (PLT.pair_hom_rel _ _ _ _ _ _ c c1 c2) in H. destruct H.
    apply U_hom_rel in H.
    apply U_hom_rel in H1.
    simpl. apply ident_elem.
    inversion H0; subst.
    + destruct H1; [ discriminate |].
      destruct H; [ discriminate |].
      destruct H1 as [?[?[?[??]]]].
      destruct H as [?[?[?[??]]]].
      rewrite H2 in H5. inversion H5. subst x0.
      inversion H3. subst x1.
      subst c.
      destruct x2.
      inversion H7. subst x3.
      simpl in H.
      apply (pi1_rel_elem _ _ _ _ c c0 x) in H.
      simpl in H1.
      apply (pi2_rel_elem _ _ _ _ c c0 y) in H1.
      split; simpl.
      * rewrite H4. auto.
      * rewrite H6. auto.
    + hnf. auto.

  - destruct a.
    simpl in H. apply ident_elem in H.
    apply PLT.compose_hom_rel.
    destruct c.
    + destruct c.
      exists (Some c, Some c1).
      split.
      * unfold unsmash_prod.
        apply PLT.pair_hom_rel.
        split.
        ** apply U_hom_rel.
           right.
           exists (c,c1). exists c.
           split; auto.
           simpl. apply pi1_rel_elem. auto.
        ** apply U_hom_rel.
           right.
           exists (c,c1). exists c1.
           split; auto.
           simpl. apply pi2_rel_elem. auto.
      * apply smash_prod_iff.
        destruct c0.
        ** destruct c0.
           destruct H. apply smash_some; auto.
        ** apply smash_none.
    + destruct c0; [ elim H |].
      exists (None,None).
      split.
      * unfold unsmash_prod.
        apply PLT.pair_hom_rel.
        split; apply U_hom_rel; auto.
      * apply smash_prod_iff.
        apply smash_none.
Qed.

Lemma unsmash_smash (A B:∂PLT) :
  unsmash_prod A B ∘ smash_prod A B ≤ id.
Proof.
  hnf; intros. destruct a. simpl. apply ident_elem.
  apply PLT.compose_hom_rel in H.
  destruct H as [q [??]].
  apply smash_prod_iff in H.
  unfold unsmash_prod in H0.
  destruct c0.
  apply (PLT.pair_hom_rel _ _ _ _ _ _ q c0 c1) in H0.
  destruct H0.
  apply U_hom_rel in H0.
  apply U_hom_rel in H1.
  destruct c.
  destruct H0.
  - destruct H1.
    * subst. split; hnf; auto.
    * subst c0. split; simpl.
      ** hnf; auto.
      ** destruct H1 as [?[?[?[??]]]].
         subst.
         inversion H; subst.
         simpl in H0.
         rewrite (pi2_rel_elem _ _ _ _ x' y' x0) in H0.
         transitivity (Some y'); auto.

  - destruct H1.
    * subst c1.
      split; simpl; [ | hnf; auto ].
      destruct H0 as [?[?[?[??]]]].
      subst. inversion H; subst.
      simpl in H0.
      rewrite (pi1_rel_elem _ _ _ _ x' y' x0) in H0.
      transitivity (Some x'); auto.
    * destruct H0 as [?[?[?[??]]]].
      destruct H1 as [?[?[?[??]]]].
      subst.
      inversion H4; subst.
      inversion H; subst.
      simpl in *.
      rewrite (pi1_rel_elem _ _ _ _ x' y' x0) in H0.
      rewrite (pi2_rel_elem _ _ _ _ x' y' x2) in H1.
      split; simpl.
      ** transitivity (Some x'); auto.
      ** transitivity (Some y'); auto.
Qed.

Global Opaque liftPPLT.
Global Opaque forgetPLT.


Require Import Category.Lib.
Require Import Category.Theory.Isomorphism.
Require Import Category.Structure.Cartesian.Closed.
Require Import Category.Instance.Sets.
Require Import Category.Instance.Sets.Cartesian.

Generalizable All Variables.

(* This instance must appear in a separate file, because the Closed structure
   makes use of isomorphisms in [Sets]. *)

#[export]
Program Instance Sets_Closed : @Closed Sets _ := {
  exponent_obj := fun x y =>
    {| carrier := SetoidMorphism x y
     ; is_setoid := @SetoidMorphism_Setoid x y |};

  exp_iso := fun _ _ _ =>
    {| to   := {| morphism := fun f =>
                    {| morphism := fun x =>
                         {| morphism := fun y => f (x, y) |} |} |}
     ; from := {| morphism := fun f =>
                    {| morphism := fun p => f (fst p) (snd p) |} |} |}
}.
Next Obligation.
  proper; destruct f; simpl.
  apply proper_morphism.
  split; simpl; intuition.
Qed.
Next Obligation.
  proper; destruct f; simpl.
  apply proper_morphism.
  split; simpl; intuition.
Qed.
Next Obligation.
  proper; simpl in *.
  destruct f; simpl in *.
  unfold Proper, respectful, SetoidMorphism_equiv in proper_morphism.
  rewrite (proper_morphism _ _ X).
  destruct (morphism y).
  apply proper_morphism0; assumption.
Qed.


(** * Autosubst Header for Scoped Syntax
    Our development utilises well-scoped de Bruijn syntax. This means that the de Bruijn indices are taken from finite types. As a consequence, any kind of substitution or environment used in conjunction with well-scoped syntax takes the form of a mapping from some finite type _I^n_. In particular, _renamings_ are mappings _I^n -> I^m_. Here we develop the theory of how these parts interact.

Version: December 11, 2019.
*)
From cbpv Require Export axioms.
Set Implicit Arguments.
Unset Strict Implicit.

Definition ap {X Y} (f : X -> Y) {x y : X} (p : x = y) : f x = f y :=
  match p with eq_refl => eq_refl end.

Definition apc {X Y} {f g : X -> Y} {x y : X} (p : f = g) (q : x = y) : f x = g y :=
  match q with eq_refl => match p with eq_refl => eq_refl end end.

(** ** Primitives of the Sigma Calculus
    We implement the finite type with _n_ elements, _I^n_, as the _n_-fold iteration of the Option Type. _I^0_ is implemented as the empty type.
*)

Fixpoint fin (n : nat) : Type :=
  match n with
  | 0 => False
  | S m => option (fin m)
  end.

(** Renamings and Injective Renamings
     _Renamings_ are mappings between finite types.
*)
Definition ren (m n : nat) : Type := fin m -> fin n.

Definition id {X} (x : X) := x.

Definition idren {k: nat} : ren k k :=
  fun x => x.

(** We give a special name, to the newest element in a non-empty finite type, as it usually corresponds to a freshly bound variable. *)
Definition var_zero {n : nat} : fin (S n) := None.

Definition null {T} (i : fin 0) : T := match i with end.

Definition shift {n : nat} : ren n (S n) :=
  Some.

Definition comp := @funcomp.

(** Extension of Finite Mappings
    Assume we are given a mapping _f_ from _I^n_ to some type _X_, then we can _extend_ this mapping with a new value from _x : X_ to a mapping from _I^n+1_ to _X_. We denote this operation by _x . f_ and define it as follows:
*)
Definition scons {X : Type} {n : nat} (x : X) (f : fin n -> X) (m : fin (S n)) : X :=
  match m with
  | None => x
  | Some i => f i
  end.

(** ** Type Class Instances for Notation *)

(** *** Type classes for renamings. *)

Class Ren1 (X1  : Type) (Y Z : Type) :=
  ren1 : X1 -> Y -> Z.

Class Ren2 (X1 X2 : Type) (Y Z : Type) :=
  ren2 : X1 -> X2 -> Y -> Z.

Class Ren3 (X1 X2 X3 : Type) (Y Z : Type) :=
  ren3 : X1 -> X2 -> X3 -> Y -> Z.

Class Ren4 (X1 X2 X3 X4 : Type) (Y Z : Type) :=
  ren4 : X1 -> X2 -> X3 -> X4 -> Y -> Z.

Class Ren5 (X1 X2 X3 X4 X5 : Type) (Y Z : Type) :=
  ren5 : X1 -> X2 -> X3 -> X4 -> X5 -> Y -> Z.

Notation "s ⟨ xi1 ⟩" := (ren1  xi1 s) (at level 7, left associativity, format "s  ⟨ xi1 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ⟩" := (ren3 xi1 xi2 xi3 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩" := (ren4  xi1 xi2 xi3 xi4 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩" := (ren5  xi1 xi2 xi3 xi4 xi5 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩") : subst_scope.

Notation "⟨ xi ⟩" := (ren1 xi) (at level 1, left associativity, format "⟨ xi ⟩") : fscope.

Notation "⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2) (at level 1, left associativity, format "⟨ xi1 ; xi2 ⟩") : fscope.

(** *** Type Classes for Substiution *)

Class Subst1 (X1 : Type) (Y Z: Type) :=
  subst1 : X1 -> Y -> Z.

Class Subst2 (X1 X2 : Type) (Y Z: Type) :=
  subst2 : X1 -> X2 -> Y  -> Z.

Class Subst3 (X1 X2 X3 : Type) (Y Z: Type) :=
  subst3 : X1 -> X2 -> X3 ->  Y  -> Z.

Class Subst4 (X1 X2 X3 X4: Type) (Y Z: Type) :=
  subst4 : X1 -> X2 -> X3 -> X4 -> Y  -> Z.

Class Subst5 (X1 X2 X3 X4 X5 : Type) (Y Z: Type) :=
  subst5 : X1 -> X2 -> X3 -> X4 -> X5  -> Y  -> Z.

Notation "s [ sigma ]" := (subst1 sigma s) (at level 7, left associativity, format "s '/' [ sigma ]") : subst_scope.

Notation "s [ sigma ; tau ]" := (subst2 sigma tau s) (at level 7, left associativity, format "s '/' [ sigma ; '/'  tau ]") : subst_scope.

(** ** Type Class for Variables *)
Class Var X Y :=
  ids : X -> Y.

(** ** Proofs for substitution primitives *)

(** Forward Function Composition
    Substitutions represented as functions are ubiquitious in this development and we often have to compose them, without talking about their pointwise behaviour.
    That is, we are interested in the forward compostion of functions, _f o g_, for which we introduce a convenient notation, "f >> g". The direction of the arrow serves as a reminder of the _forward_ nature of this composition, that is first apply _f_, then _g_. *)

Arguments funcomp {X Y Z} (g)%fscope (f)%fscope.

Notation "f >> g" := (funcomp g f) (at level 50).
Open Scope subst_scope.

Notation "x .: f" := (@scons _ _ x f) (at level 55) : subst_scope.

(** Generic lifting operation for renamings *)
Definition up_ren m n (xi : ren m n) : ren (S m) (S n) :=
  var_zero .: xi >> shift.

(** Generic proof that lifting of renamings composes. *)
Lemma up_ren_ren k l m (xi: ren k l) (zeta : ren l m) (rho: ren k m) (E: forall x, (xi >> zeta) x = rho x) :
  forall x, (up_ren xi >> up_ren zeta) x = up_ren rho x.
Proof.
  intros [x|].
  - simpl. unfold funcomp. now rewrite <- E.
  - reflexivity.
Qed.

Arguments up_ren_ren {k l m} xi zeta rho E.

Lemma scons_eta {T} {n : nat} (f : fin (S n) -> T) :
  f var_zero .: shift >> f = f.
Proof. fext. intros [x|]; reflexivity.  Qed.

Lemma scons_eta_id {n : nat} : var_zero .: shift = id :> (fin (S n) -> fin (S n)).
Proof. fext. intros [x|]; reflexivity. Qed.

Lemma scons_comp (T: Type) U {m} (s: T) (sigma: fin m -> T) (tau: T -> U ) :
  (s .: sigma) >> tau = (tau s) .: (sigma >> tau) .
Proof.
  fext. intros [x|]. reflexivity. simpl. reflexivity.
Qed.

Lemma fin_eta {X} (f g : fin 0 -> X) :
  forall x, f x = g x.
Proof. intros []. Qed.

(** ** Variadic Substitution Primitives *)

Fixpoint shift_p (p : nat) {n} : ren n (p + n) :=
  fun n => match p with
        | 0 => n
        | S p => Some (shift_p p n)
        end.

Fixpoint scons_p {X: Type} {m : nat} : forall {n} (f : fin m -> X) (g : fin n -> X), fin (m + n)  -> X.
Proof.
  destruct m.
  - intros n f g. exact g.
  - intros n f g. cbn. apply scons.
    + exact (f var_zero).
    + apply scons_p.
      * intros z. exact (f (Some z)).
      * exact g.
Defined.

Definition zero_p {m : nat} {n} : fin m -> fin (m + n).
Proof.
  induction m.
  - intros [].
  - intros [x|].
    + exact (shift_p 1 (IHm x)).
    + exact var_zero.
Defined.

Lemma scons_p_head' {X} {m n} (f : fin m -> X) (g : fin n -> X) z:
  (scons_p  f g) (zero_p  z) = f z.
Proof.
 induction m.
  - inversion z.
  - destruct z.
    + simpl. simpl. now rewrite IHm.
    + reflexivity.
Qed.

Lemma scons_p_head X m n (f : fin m -> X) (g : fin n -> X) :
  (zero_p  >> scons_p f g) = f.
Proof. fext. intros z. unfold funcomp. apply scons_p_head'. Qed.

Lemma scons_p_tail' X  m n (f : fin m -> X) (g : fin n -> X) z :
  scons_p  f g (shift_p m z) = g z.
Proof. induction m; cbn; eauto. Qed.

Lemma scons_p_tail X  m n (f : fin m -> X) (g : fin n -> X) :
  shift_p m  >> scons_p f g = g.
Proof. fext. intros z. unfold funcomp. apply scons_p_tail'. Qed.

Lemma destruct_fin {m n} (x : fin (m + n)):
  (exists x', x = zero_p  x') \/ exists x', x = shift_p m x'.
Proof.
  induction m; simpl in *.
  - right. eauto.
  - destruct x as [x|].
    + destruct (IHm x) as [[x' ->] |[x' ->]].
      * left. now exists (Some x').
      * right. eauto.
    + left. exists None. eauto.
Qed.

Lemma scons_p_comp' X Y m n (f : fin m -> X) (g : fin n -> X) (h : X -> Y) x:
 h (scons_p  f g x)  = scons_p (f >> h) (g >> h) x.
Proof.
  destruct (destruct_fin x) as [[x' ->]|[x' ->]].
  - now rewrite !scons_p_head'.
  - now rewrite !scons_p_tail'.
Qed.

Lemma scons_p_comp {X Y m n} {f : fin m -> X} {g : fin n -> X} {h : X -> Y} :
  (scons_p f g) >> h = scons_p   (f >> h) (g >> h).
Proof. fext. intros z. unfold funcomp. apply scons_p_comp'. Qed.

Lemma scons_p_congr {X} {m n} (f f' : fin m -> X) (g g': fin n -> X) z:
  (forall x, f x = f' x) -> (forall x, g x = g' x) -> scons_p f g z = scons_p f' g' z.
Proof. intros H1 H2. induction m; eauto. cbn. destruct z; eauto. Qed.

(** Generic n-ary lifting operation. *)
Definition upRen_p p { m : nat } { n : nat } (xi : (fin) (m) -> (fin) (n)) : fin (p + m) -> fin (p + n)  :=
   scons_p  (zero_p ) (xi >> shift_p _).

Arguments upRen_p p {m n} xi.

(** Generic proof for composition of n-ary lifting. *)
Lemma up_ren_ren_p p k l m (xi: ren k l) (zeta : ren l m) (rho: ren k m) (E: forall x, (xi >> zeta) x = rho x) :
  forall x, (upRen_p p xi >> upRen_p p zeta) x = upRen_p p rho x.
Proof.
  intros x. destruct (destruct_fin x) as [[? ->]|[? ->]].
  - unfold upRen_p. unfold funcomp. now repeat rewrite scons_p_head'.
  - unfold upRen_p. unfold funcomp. repeat rewrite scons_p_tail'.
    now rewrite <- E.
Qed.

Arguments zero_p m {n}.
Arguments scons_p  {X} m {n} f g.

Lemma scons_p_eta {X} {m n} {f : fin m -> X}
      {g : fin n -> X} (h: fin (m + n) -> X) {z: fin (m + n)}:
  (forall x, g x = h (shift_p m x)) -> (forall x, f x = h (zero_p m x)) -> scons_p m f g z = h z.
Proof.
  intros H1 H2. destruct (destruct_fin z) as [[? ->] |[? ->]].
  - rewrite scons_p_head'. eauto.
  - rewrite scons_p_tail'. eauto.
Qed.

Arguments scons_p_eta {X} {m n} {f g} h {z}.
Arguments scons_p_congr {X} {m n} {f f'} {g g'} {z}.

Opaque scons.
Opaque var_zero.
Opaque null.
Opaque shift.
Opaque up_ren.
Opaque var_zero.
Opaque idren.
Opaque comp.
Opaque funcomp.
Opaque id.

(** ** Notations for Scoped Syntax *)

Module CommaNotation.
Notation "s , sigma" := (scons s sigma) (at level 60, format "s ,  sigma", right associativity) : subst_scope.
End CommaNotation.

Notation "s '..'" := (scons s ids) (at level 1, format "s ..") : subst_scope.

Notation "↑" := (shift) : subst_scope.

Ltac unfold_funcomp := match goal with
                           | |-  context[(?f >> ?g) ?s] => change ((f >> g) s) with (g (f s))
                           end.

(** ** Tactics for Scoped Syntax *)

(** Generic fsimpl tactic: simplifies the above primitives in a goal. *)
Ltac fsimpl :=
  repeat match goal with
         | [|- context[id >> ?f]] => change (id >> f) with f (* AsimplCompIdL *)
         | [|- context[?f >> id]] => change (f >> id) with f (* AsimplCompIdR *)
         | [|- context [id ?s]] => change (id s) with s
         | [|- context[comp ?f ?g]] => change (comp f g) with (g >> f) (* AsimplCompIdL *)
         | [|- context[(?f >> ?g) >> ?h]] =>
           change ((f >> g) >> h) with (f >> (g >> h)) (* AsimplComp *)

         | [|- zero_p >> scons_p ?f ?g] => rewrite scons_p_head

         | [|- context[(?s.:?sigma) var_zero]] => change ((s.:sigma) var_zero) with s
         | [|- context[(?s.:?sigma) (shift ?m)]] => change ((s.:sigma) (shift m)) with (sigma m)

         | [|- context[idren >> ?f]] => change (idren >> f) with f
         | [|- context[?f >> idren]] => change (f >> idren) with f
         | [|- context[?f >> (?x .: ?g)]] => change (f >> (x .: g)) with g
         | [|- context[?x2 .: shift >> ?f]] => change x2 with (f var_zero); rewrite (@scons_eta _ _ f)
         | [|- context[?f var_zero .: ?g]] => change g with (shift >> f); rewrite scons_eta

         |[|- _ =  ?h (?f ?s)] => change (h (f s)) with ((f >> h) s)
         |[|-  ?h (?f ?s) = _] => change (h (f s)) with ((f >> h) s)

         | _ => first [progress (rewrite scons_comp) |  progress (rewrite scons_eta_id) | progress (autorewrite with FunctorInstances)]
         end.

(** Generic fsimpl tactic: simplifies the above primitives in the context *)
Ltac fsimplc :=
  repeat match goal with
         | [H: context[id >> ?f] |- _] => change (id >> f) with f in H(* AsimplCompIdL *)
         | [H: context[?f >> id]|- _] => change (f >> id) with f in H(* AsimplCompIdR *)
         | [H: context [id ?s]|- _] => change (id s) with s in H
         | [H: context[comp ?f ?g]|- _] => change (comp f g) with (g >> f) in H (* AsimplCompIdL *)
         | [H: context[(?f >> ?g) >> ?h]|- _] =>
           change ((f >> g) >> h) with (f >> (g >> h)) in H (* AsimplComp *)
         | [H: context[(?s.:?sigma) var_zero]|- _] => change ((s.:sigma) var_zero) with s in H
         | [H: context[(?s.:?sigma) var_zero]|- _] => change ((s.:sigma) var_zero) with s in H
         | [H: context[(?s.:?sigma) (shift ?m)]|- _] => change ((s.:sigma) (shift m)) with (sigma m) in H
                                                                                |[H : context[ _ =  ?h (?f ?s)]|- _] => change (h (f s)) with ((f >> h) s) in H
         |[H: context[?h (?f ?s) = _]|- _] => change (h (f s)) with ((f >> h) s) in H
         | [H: context[idren >> ?f]|- _] => change (idren >> f) with f in H
         | [H: context[?f >> idren]|- _] => change (f >> idren) with f in H
         | [H: context[?f >> (?x .: ?g)]|- _] =>
           change (f >> (x .: g)) with g in H
         | [H: context[?x2 .: shift >> ?f]|- _] =>
           change x2 with (f var_zero) in H; rewrite (@scons_eta _ _ f) in H
         | [H: context[?f var_zero .: ?g]|- _] =>
           change g with (shift >> f) in H; rewrite scons_eta in H
         | _ => first [progress (rewrite scons_comp in *) | progress (rewrite scons_eta_id in *) | progress (autorewrite with FunctorInstances in *)]
         end.

(** Simplification in both the goal and the context *)
Tactic Notation "fsimpl" "in" "*" :=
  fsimpl; fsimplc.

Tactic Notation "auto_case" tactic(t) :=  (match goal with
                                           | [|- forall (i : fin 0), _] => intros []; t
                                           | [|- forall (i : fin (S (S (S (S _))))), _] => intros [[[[|]|]|]|]; t
                                           | [|- forall (i : fin (S (S (S _)))), _] => intros [[[|]|]|]; t
                                           | [|- forall (i : fin (S (S _))), _] => intros [[?|]|]; t
                                           | [|- forall (i : fin (S _)), _] =>  intros [?|]; t
                                           end).

(** Functor instances which can be added later on. *)
Hint Rewrite  @scons_p_comp scons_p_head scons_p_tail @scons_p_head' @scons_p_tail': FunctorInstances.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	                   Natural Isomorphism            		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export CatProperty.
Require Export CatFunct.

Set Implicit Arguments.
Unset Strict Implicit.

(* 1ere solution: def primitive *)

Section natiso_def.

Variable A B : Category.

Definition RNatIso_law (F G : Functor A B) (T : NT F G)
  (T1 : NT G F) := T1 o_NTv T =_NT Id_CatFunct G.

Variable F G : Functor A B.

Definition AreNatIsos (T : NT F G) (T1 : NT G F) :=
  RNatIso_law T T1 /\ RNatIso_law T1 T.

Structure > NatIso : Type :=
  {NatIso_mor :> NT F G;
   NatIso_inv : NT G F;
   Prf_NatIso :> AreNatIsos NatIso_mor NatIso_inv}.

Lemma Idl_nat_inv :
 forall i : NatIso, RNatIso_law (NatIso_mor i) (NatIso_inv i).
Proof.
simple induction i; unfold AreNatIsos in |- *; intros T1 T2 p; elim p; auto.
Qed.

Lemma Idr_nat_inv :
 forall i : NatIso, RNatIso_law (NatIso_inv i) (NatIso_mor i).
Proof.
simple induction i; unfold AreNatIsos in |- *; intros T1 T2 p; elim p; auto.
Qed.

End natiso_def.

Section about_isIso.

Variables (A B : Category) (F G : Functor A B) (T : NT F G).

(* qq a. Ta isIso => T isIso *)

Variable h : forall a : A, G a --> F a.

Hypothesis H : forall a : A, AreIsos (T a) (h a).

Lemma NTinv_nt_law : NT_law h.
Proof.
unfold NT_law in |- *; intros a b f.
(* *) apply Trans with ((h a o T a o FMor G f) o h b).
apply Comp_r.
(* *) apply Trans with ((h a o T a) o FMor G f).
(* *) apply Trans with (Id (G a) o FMor G f).
apply Idl1.
apply Comp_r; apply Sym; apply (Idl_inv (H a)).
apply Ass1.
(* *) apply Trans with ((h a o FMor F f o T b) o h b).
apply Comp_r; apply Comp_l; apply NatCond1.
(* *) apply Trans with (h a o (FMor F f o T b) o h b).
apply Ass1.
apply Comp_l.
(* *) apply Trans with (FMor F f o T b o h b).
apply Ass1.
(* *) apply Trans with (FMor F f o Id _).
apply Comp_l; apply (Idr_inv (H b)).
apply Idr1.
Qed.

Canonical Structure NTinv := Build_NT NTinv_nt_law.

Lemma NT_areIso : AreNatIsos T NTinv.
Proof.
red in |- *; split; unfold RNatIso_law in |- *; unfold Equal_NT in |- *;
 simpl in |- *; unfold Comp_tau in |- *; simpl in |- *;
 unfold Id_CatFunct_tau in |- *; intro a.
apply (Idl_inv (H a)).
apply (Idr_inv (H a)).
Qed.

Canonical Structure NT_Iso : NatIso F G := NT_areIso.

(* T isIso => qq a. Ta isIso *)

Variable T1 : NT G F.

Hypothesis H' : AreNatIsos T T1.

Variable a : A.

Lemma NTa_areIso : AreIsos (T a) (T1 a).
Proof.
red in |- *; split; unfold RIso_law in |- *.
apply (Idl_nat_inv H' a).
apply (Idr_nat_inv H' a).
Qed.

Canonical Structure NTa_Iso : Iso (F a) (G a) := NTa_areIso.

End about_isIso.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	                   Monoids Category                		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                     A. SAIBI	  May 95                  		     *)
(*									     *)
(*****************************************************************************)

Require Export SET.
Require Export Monoid.

Set Implicit Arguments.
Unset Strict Implicit.

(* Monoid Morphism composition *)

Section comp_mon.

Variables (m1 m2 m3 : Monoid) (f : MonMor m1 m2) (g : MonMor m2 m3).

Definition Comp_MonMor_map := f o_M g.

Lemma Comp_MonMor_unit_law : MonUnit_law Comp_MonMor_map.
Proof.
unfold MonUnit_law, Comp_MonMor_map in |- *.
simpl in |- *; unfold Comp_fun in |- *.
apply Trans with (g (Munit m2)).
apply Pres1; apply MMon_unit.
apply MMon_unit.
Qed.

Lemma Comp_MonMor_op_law : MonOp_law Comp_MonMor_map.
Proof.
unfold MonOp_law, Comp_MonMor_map in |- *.
simpl in |- *; unfold Comp_fun in |- *.
intros a b.
apply Trans with (g (f a +_M f b)).
apply (Pres g); apply MMon_op.
apply MMon_op.
Qed.

Canonical Structure Comp_MonMor : MonMor_setoid m1 m3 :=
  Build_MonMor Comp_MonMor_unit_law Comp_MonMor_op_law.

End comp_mon.

Lemma Comp_MonMor_congl : Congl_law Comp_MonMor.
Proof.
unfold Congl_law in |- *; simpl in |- *.
unfold Equal_MonMor, Ext in |- *; simpl in |- *.
unfold Comp_fun in |- *.
intros m1 m2 m3 f g h H a.
apply H.
Qed.

Lemma Comp_MonMor_congr : Congr_law Comp_MonMor.
Proof.
unfold Congr_law in |- *; simpl in |- *.
unfold Equal_MonMor, Ext in |- *; simpl in |- *.
unfold Comp_fun in |- *.
intros m1 m2 m3 f g h H a.
apply Pres1.
apply H.
Qed.

Definition Comp_MON := Build_Comp Comp_MonMor_congl Comp_MonMor_congr.

Lemma Assoc_MON : Assoc_law Comp_MON.
Proof.
unfold Assoc_law in |- *; simpl in |- *; intros m1 m2 m3 m4 f g h.
unfold Equal_MonMor, Ext in |- *; simpl in |- *.
unfold Comp_fun in |- *; intro a.
apply Refl.
Qed.

(* Id *)

Section id_mon_def.

Variable m : Monoid.

Definition Id_MON_map := Id_SET m.

Lemma Id_MON_unit_law : MonUnit_law Id_MON_map.
Proof.
unfold MonUnit_law, Id_MON_map in |- *; simpl in |- *.
unfold Id_fun in |- *; apply Refl.
Qed.

Lemma Id_MON_op_law : MonOp_law Id_MON_map.
Proof.
unfold MonOp_law, Id_MON_map in |- *; simpl in |- *.
unfold Id_fun in |- *; intros a b.
apply Refl.
Qed.

Canonical Structure Id_MON : MonMor_setoid m m :=
  Build_MonMor Id_MON_unit_law Id_MON_op_law.

End id_mon_def.

Lemma Idl_MON : Idl_law Comp_MON Id_MON.
Proof.
unfold Idl_law in |- *; intros m1 m2 f; simpl in |- *.
unfold Equal_MonMor, Ext in |- *; simpl in |- *.
unfold Comp_fun in |- *; intro a.
unfold Id_MON_map in |- *; simpl in |- *; unfold Id_fun in |- *.
apply Refl.
Qed.

Lemma Idr_MON : Idr_law Comp_MON Id_MON.
Proof.
unfold Idr_law in |- *; intros m1 m2 f; simpl in |- *.
unfold Equal_MonMor, Ext in |- *; simpl in |- *.
unfold Comp_fun in |- *; intro a.
unfold Id_MON_map in |- *; simpl in |- *; unfold Id_fun in |- *.
apply Refl.
Qed.

Canonical Structure MON := Build_Category Assoc_MON Idl_MON Idr_MON.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University
  Copyright 2018 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli & Mark Bickford

*)

Require Export rules_pertype_equality.
Require Export rules_typehood.

(**

  We now prove the truth of several rules about the PER type.

*)

(* [14] ============ PERTYPE MEMBER EQUALITY (ALT) ============ *)

(**

  The following rule is called the ``pertype member equality'' rule.
  It allows one to prove that terms are well-formed partial
  equivalence relations, i.e., members of a ``pertype'' type.

  The 3rd subgoal is necessary because we have to prove [R[s1] t1[s1] t2[s2]]
  is inhabited, but from the 2nd subgoal we only know that [R[s1] t1[s1] t2[s1]]
  is inhabited and that [R[s1] t1[s1] t2[s1]] and [R[s2] t1[s2] t2[s2]] are
  equal types.  Therefore, we need to go from [R[s1] t1[s1] t2[s2]] to either
  [R[s1] t1[s1] t2[s1]] or [R[s2] t1[s2] t2[s2]].
  For that we use the 1st subgoal which says that [R[s1] x y] is inhabited iff
  [R[s2] x y] is inhabited.  We now get that [R[s2] t1[s1] t2[s2]] is inhabited.
  Finally because t1[s1] ~ t1[s2] we get that [R[s2] t1[s2] t2[s2]] is inhabited.

<<
   H |- t1 = t2 in pertype(R)

     By pertypeMemberEquality

     H |- istype(pertype(R))
     H |- R t1 t2
     H |- t1 in Base
>>
 *)

Definition rule_pertype_member_equality_alt {o}
           (t1 t2 R e : NTerm)
           (H : @barehypotheses o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality t1 t2 (mk_pertype R))))
    [ mk_baresequent H (mk_conclax (mk_istype (mk_pertype R))),
      mk_baresequent H (mk_concl (mk_apply2 R t1 t2) e),
      mk_baresequent H (mk_conclax (mk_member t1 mk_base))
    ]
    [].

Lemma rule_pertype_member_equality_alt_true {o} :
  forall lib (t1 t2 R e : NTerm),
  forall H : @barehypotheses o,
    rule_true lib (rule_pertype_member_equality_alt
                 t1 t2 R e
                 H).
Proof.
  unfold rule_pertype_member_equality_alt, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hypa.
  rename Hyp1 into hypb.
  rename Hyp2 into hypc.
  destseq; allsimpl; proof_irr; GC.

  exists (@covered_axiom o (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  (* xxx *)
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  lift_lsubst.
  rw @member_eq.
  rw <- @member_equality_iff.

  vr_seq_true in hypa.
  pose proof (hypa s1 s2) as hypa'.
  repeat (autodimp hypa' hyp); exrepnd.
  lsubst_tac.
  rw @tequality_mkc_istype in hypa'0.

  generalize (teq_and_eq_if_equality lib
                (mk_pertype R) t1 t2 s1 s2 H wT w1 w2 c1 c3 c2 c4 cT cT0
                eqh sim); intro k; lsubst_tac; apply k; clear k; auto.

  clear dependent s1.
  clear dependent s2.
  introv hf sim.
  lsubst_tac.

  pose proof (hypa s1 s2 hf sim) as hypa; exrepnd.

  vr_seq_true in hypb.
  pose proof (hypb s1 s2 hf sim) as hypb; exrepnd.

  vr_seq_true in hypc.
  pose proof (hypc s1 s2 hf sim) as hypc; exrepnd.

  lsubst_tac.
  allrw @member_eq.
  allrw <- @member_member_iff.
  allrw @tequality_mkc_member_base.
  allapply @member_in_uni.

  (* trivial hyp *)
  clear hypc1.

  rw @tequality_mkc_istype in hypa0; auto.
  duplicate hypa0 as xx.
  apply tequality_implies_type_left in xx.
  rw @tequality_mkc_pertype in hypa0; repnd.
  allapply @inhabited_type_if_equality.
  spcast.

  rw @equality_in_mkc_pertype2; dands; auto.
  apply hypa4.
  apply @inhabited_type_cequivc with (a := mkc_apply2 (lsubstc R w0 s2 c0)
                                                      (lsubstc t1 w1 s2 ct2)
                                                      (lsubstc t2 w2 s2 cb2)); auto;
    [apply implies_cequivc_apply2; sp;apply cequivc_sym; auto|];[].
  apply @inhabited_type_tequality in hypb0; auto.
Qed.

(**

  This is a variant of [rule_pertype_elimination] but where the
  well-formedness goal is stated using a ``type'' sequent.  Also it
  allows one to use all the hypotheses:
<<
   H, x : t1 = t2 in pertype(R), J |- C ext e

     By pertypeElimination i z

     H, x : t1 = t2 in pertype(R), [z : R t1 t2], J |- C ext e
     H, x : t1 = t2 in pertype(R), J |- istype(R t1 t2)
>>
 *)

Definition rule_pertype_elimination_alt {o}
           (R t1 t2 C e : NTerm)
           (x z : NVar)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))) ++ J)
       (mk_concl C e))
    [ mk_baresequent
        (snoc (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))))
              (mk_hhyp z (mk_apply2 R t1 t2))
              ++ J)
        (mk_concl C e),
      mk_baresequent (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))) ++ J)
                      (mk_conclax (mk_istype (mk_apply2 R t1 t2)))
    ]
    [sarg_var z].

Lemma rule_pertype_elimination_alt_true {o} :
  forall lib (R t1 t2 C e : NTerm),
  forall x z : NVar,
  forall H J : @barehypotheses o,
    rule_true lib (rule_pertype_elimination_alt
                 R t1 t2 C e
                 x z
                 H J).
Proof.
  unfold rule_pertype_elimination_alt, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

   (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.

  assert (covered e
                  (nh_vars_hyps
                     (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # !LIn x (free_vars t1)
           # !LIn x (free_vars t2)
           # disjoint (free_vars R) (vars_hyps J)
           # disjoint (free_vars t1) (vars_hyps J)
           # disjoint (free_vars t2) (vars_hyps J)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
    try (complete (discover; repeat (first [ progress (allrw in_app_iff) | progress (allrw in_snoc) ]); sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp));
    try (complete (unfold disjoint; unfold disjoint in wfh13; introv k l; discover;
                   repeat (first [ progress (allrw in_app_iff) | progress (allrw in_snoc) ]); sp));
    try (complete (allunfold @disjoint; introv k;
                   discover; allrw in_app_iff; allrw in_snoc; sp)).

  destruct vhyps as [ nixr vhyps ].
  destruct vhyps as [ nixt1 vhyps ].
  destruct vhyps as [ nixt2 vhyps ].
  destruct vhyps as [ nizc  vhyps ].
  destruct vhyps as [ nize  vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  rw @equality_in_mkc_equality in sim2; repnd.
  rw @equality_in_mkc_pertype in sim0; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim7; exrepnd.
  generalize (hyp1 ((snoc (snoc s1a0 (x, t0)) (z, t)) ++ s1b)
                   ((snoc (snoc s2a0 (x, t3)) (z, t)) ++ s2b));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
  apply app_split in sim7; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  rw @similarity_snoc in sim14; simpl in sim14; exrepnd; subst; cpx.
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t0)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.
  rewrite substitute_hyps_snoc_sub_weak in sim10; sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  rw @eq_hyps_app; simpl.
  exists (snoc (snoc s1a (x, t6)) (z, t4))
         s1b
         (snoc (snoc s2a1 (x, t7)) (z, t5))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  assert (cover_vars (mk_apply2 R t1 t2) (snoc s2a1 (x, t7)))
         as cv
         by (apply cover_vars_apply2; sp;
             try (apply cover_vars_var);
             repeat (apply cover_vars_snoc_weak); sp;
             repeat (rw dom_csub_snoc); simpl; repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x, t6)) (snoc s2a1 (x, t7)) t4 t5 w3 p0 cv;
    dands; try (complete sp).

  lsubst_tac.

  vr_seq_true in hyp2.
  generalize (hyp2 (snoc s1a  (x, t6) ++ s1b)
                   (snoc s2a1 (x, t7) ++ s2b));
    clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.

  rw @similarity_app; simpl.
  exists (snoc s1a (x,t6)) s1b (snoc s2a1 (x,t7)) s2b; repeat (rw length_snoc); sp.
  lsubst_tac.
  auto.
  apply tequality_mkc_istype. auto.

  apply sub_eq_hyps_snoc_weak; sp.

  (* similarity *)
  rw @similarity_app; simpl.
  exists (snoc (snoc s1a0 (x, t0)) (z, t))
         s1b
         (snoc (snoc s2a0 (x, t3)) (z, t))
         s2b; repeat (rw length_snoc); sp.

  assert (wf_term (mk_apply2 R t1 t2))
         as wfap by (apply wf_apply2; sp).

  assert (cover_vars (mk_apply2 R t1 t2) (snoc s1a0 (x, t0)))
         as cvap
         by (apply cover_vars_snoc_weak;rw @cover_vars_apply2; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x, t0)) (snoc s2a0 (x, t3)) t t wfap cvap; sp.

  lsubst_tac.
  rw @member_eq; sp.

  rewrite substitute_hyps_snoc_sub_weak; sp.
  (* similarity proved *)

  assert (lsubstc C wfct (snoc (snoc s1a0 (x, t0)) (z, t) ++ s1b) pC0
          = lsubstc C wfct (snoc s1a0 (x, t0) ++ s1b) pC1)
         as eq1
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc C wfct (snoc (snoc s2a0 (x, t3)) (z, t) ++ s2b) pC3
          = lsubstc C wfct (snoc s2a0 (x, t3) ++ s2b) pC2)
         as eq2
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s1a0 (x, t0)) (z, t) ++ s1b) pt0
          = lsubstc e wfce (snoc s1a0 (x, t0) ++ s1b) pt1)
         as eq3
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s2a0 (x, t3)) (z, t) ++ s2b) pt3
          = lsubstc e wfce (snoc s2a0 (x, t3) ++ s2b) pt2)
         as eq4
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  rw eq1 in hyp0.
  rw eq1 in hyp1.
  rw eq2 in hyp0.
  rw eq3 in hyp1.
  rw eq4 in hyp1.
  sp.

Qed.

Lemma rule_pertype_elimination_alt_true_ex {o} :
  forall lib z R t1 t2 C e x H J,
    rule_true_if lib (@rule_pertype_elimination_alt
                    o
                    R t1 t2 C e
                    x z
                    H J).
Proof.
  intros.
  generalize (rule_pertype_elimination_alt_true lib R t1 t2 C e x z H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.


(** The conditional probabilistic guarded command language (cpGCL). *)

Require Import Coq.Program.Basics.
Require Import Coq.QArith.QArith.

Require Import order.

(** For now we support only boolean values. *)
Definition val := bool.

(** A program state is a map from identifiers (nat) to values. *)
Definition St : Type := nat -> val.
Definition empty : St := fun _ => false.
Definition upd (x : nat) (v : val) (st : St) : St :=
  fun y => if Nat.eqb y x then v else st y.

(** An expression is a function from program states to values. *)
Definition exp := St -> val.

Inductive cpGCL : Type :=
| CSkip : cpGCL
| CAbort : cpGCL
| CAssign : nat -> exp -> cpGCL
| CSeq : cpGCL -> cpGCL -> cpGCL
| CIte : exp -> cpGCL -> cpGCL -> cpGCL
| CChoice : Q -> cpGCL -> cpGCL -> cpGCL
| CWhile : exp -> cpGCL -> cpGCL
| CObserve : exp -> cpGCL.

(* Record prog := *)
(*   { prog_com : cpGCL *)
(*   ; prog_query : exp }. *)

Notation "a ';;;' b" := (CSeq a b) (at level 100, right associativity) : cpGCL_scope.
Open Scope cpGCL_scope.

(** A cpGCL command is well-formed when all p values in choice
    commands are valid probabilities. *)
(** NOTE: this could be strengthened to [0 < p < 1] since choice
    commands with p=0 or p=1 are unnecessary and can be eliminated. *)
Inductive wf_cpGCL : cpGCL -> Prop :=
| wf_skip : wf_cpGCL CSkip
| wf_abort : wf_cpGCL CAbort
| wf_assign : forall x e, wf_cpGCL (CAssign x e)
| wf_seq : forall c1 c2,
    wf_cpGCL c1 -> wf_cpGCL c2 -> wf_cpGCL (CSeq c1 c2)
| wf_ite : forall e c1 c2,
    wf_cpGCL c1 -> wf_cpGCL c2 -> wf_cpGCL (CIte e c1 c2)
| wf_cchoice : forall p c1 c2,
    0 <= p <= 1 -> wf_cpGCL c1 -> wf_cpGCL c2 -> wf_cpGCL (CChoice p c1 c2)
| wf_while : forall e body, wf_cpGCL body -> wf_cpGCL (CWhile e body)
| wf_observe : forall e, wf_cpGCL (CObserve e).

Fixpoint wf_cpGCLb (c : cpGCL) : bool :=
  match c with
  | CSkip => true
  | CAbort => true
  | CAssign _ _ => true
  | CSeq c1 c2 => wf_cpGCLb c1 && wf_cpGCLb c2
  | CIte _ c1 c2 => wf_cpGCLb c1 && wf_cpGCLb c2
  | CChoice p c1 c2 =>
    Qle_bool 0 p && Qle_bool p 1 && wf_cpGCLb c1 && wf_cpGCLb c2
  | CWhile _ body => wf_cpGCLb body
  | CObserve _ => true
  end.

(* wf_cpGCL is decidable. *)
Lemma wf_cpGCLb_spec (c : cpGCL) : reflect (wf_cpGCL c) (wf_cpGCLb c).
Proof.
  induction c; simpl; try solve[repeat constructor].
  - destruct IHc1, IHc2; simpl; repeat constructor; auto;
      intro HC; apply n; inversion HC; auto.
  - destruct IHc1, IHc2; simpl; repeat constructor; auto;
      intro HC; apply n; inversion HC; auto.
  - destruct IHc1, IHc2; simpl.
    + destruct (Qle_bool 0 q) eqn:H0; simpl.
      * destruct (Qle_bool q 1) eqn:H1; simpl; constructor.
        -- constructor; auto; split; apply Qle_bool_iff; auto.
        -- intro HC; inversion HC; subst.
           destruct H4 as [? Hq].
           apply Qle_bool_iff in Hq; congruence.
      * constructor; intro HC; inversion HC; subst.
        destruct H3 as [Hq ?].
        apply Qle_bool_iff in Hq; congruence.
    + rewrite andb_false_r; constructor; intro HC; inversion HC; auto.
    + rewrite andb_false_r; constructor; intro HC; inversion HC; auto.
    + rewrite andb_false_r; constructor; intro HC; inversion HC; auto.
  - destruct IHc; repeat constructor; auto.
    intro HC; inversion HC; auto.
Qed.

(** f is an expectation. *)
Definition expectation {A : Type} (f : A -> Q) := forall x, 0 <= f x.

Definition bounded {A : Type} (f : A -> Q) (b : Q) := forall x, f x <= b.

(** f is a bounded expectation (bounded above by 1). *)
Definition bounded_expectation {A : Type} (f : A -> Q) (b : Q) :=
  forall x, 0 <= f x <= b.

(** Predicate asserting that a command contains no observe
  commands. *)
Inductive no_obs : cpGCL -> Prop :=
| no_obs_skip : no_obs CSkip
| no_obs_abort : no_obs CAbort
| no_obs_assign : forall x e, no_obs (CAssign x e)
| no_obs_seq : forall c1 c2,
    no_obs c1 -> no_obs c2 ->
    no_obs (CSeq c1 c2)
| no_obs_ite : forall e c1 c2,
    no_obs c1 -> no_obs c2 ->
    no_obs (CIte e c1 c2)
| no_obs_choice : forall p c1 c2,
    no_obs c1 -> no_obs c2 ->
    no_obs (CChoice p c1 c2)
| no_obs_while : forall e c,
    no_obs c ->
    no_obs (CWhile e c).

Inductive cpGCL_le : cpGCL -> cpGCL -> Prop :=
| le_skip : cpGCL_le CSkip CSkip
| le_abort : forall c, cpGCL_le CAbort c
| le_assign : forall x e, cpGCL_le (CAssign x e) (CAssign x e)
| le_seq : forall c1 c2 c2',
    cpGCL_le c2 c2' ->
    cpGCL_le (CSeq c1 c2) (CSeq c1 c2')
| le_ite: forall e c1 c1' c2 c2',
    cpGCL_le c1 c1' ->
    cpGCL_le c2 c2' ->

    cpGCL_le (CIte e c1 c2) (CIte e c1' c2')
| le_choice: forall p c1 c1' c2 c2',
    cpGCL_le c1 c1' ->
    cpGCL_le c2 c2' ->
    cpGCL_le (CChoice p c1 c2) (CChoice p c1' c2')
| le_while : forall e c,
    cpGCL_le (CWhile e c) (CWhile e c)
| le_observe : forall e,
    cpGCL_le (CObserve e) (CObserve e).

Instance Reflexive_cpGCL_le : Reflexive cpGCL_le.
Proof. intro c; induction c; constructor; auto. Qed.

Instance Transitive_cpGCL_le : Transitive cpGCL_le.
Proof.
  intros c1 c2; revert c1.
  induction c2; intros c1 c3 Hle1 Hle2;
    inversion Hle1; inversion Hle2; subst; auto; constructor;
      try solve[eapply IHc2_1; auto]; eapply IHc2_2; auto.
Qed.

Program Instance OType_cpGCL : OType cpGCL :=
  { leq := cpGCL_le }.
Next Obligation.
  split. apply Reflexive_cpGCL_le. apply Transitive_cpGCL_le.
Qed.


(** DWFM soundness proofs - The type system. *)
From esop Require Import corecalculus.
From stdpp Require Import gmap strings set.
From iris.algebra Require Import big_op.

Definition lname := positive.
Definition lnames := gset lname.

Inductive type :=
| tbool
| tunit
| tref (ξ: lname)
| ttask (ξ: lname) (A: lnames) (τ: type)
with
hexpr :=
| hemp
| hstar (η η': hexpr)
| hpt (ξ: lname) (τ: type)
| hwait (ξ: lname) (A: lnames) (η: hexpr).
Bind Scope ty_scope with type.
Bind Scope he_scope with hexpr.
Notation Bool := tbool.
Notation Unit := tunit.
Notation "'Ref(' ξ ')'" := (tref ξ) (at level 30): ty_scope.
Notation "'Promise(' ξ ',' A ')' τ" := (ttask ξ A τ) (at level 30): ty_scope.
Infix "⊗" := hstar (at level 45): he_scope.
Infix "↦" := hpt (at level 35): he_scope.
Notation "'Wait(' ξ ',' A ')' η" := (hwait ξ A η) (at level 40): he_scope.
Notation "∅" := hemp: he_scope.
(* TODO: Add function types. For now, we simply type let expressions. *)
Instance: EqDecision type.
Proof. solve_decision. Qed.
Instance: EqDecision hexpr.
Proof. solve_decision. Qed.

Definition env := gmap string type.

Definition insert' {A} b (y: A) (m: gmap string A) :=
  match b with BNamed x => <[x:=y]>m | BAnon => m end.
Definition Let b e e' := App (Rec BAnon b e') e.

Class Names A := names: A → gset lname.
Fixpoint ty_names τ: gset lname :=
  match τ with
  | tbool => ∅
  | tunit => ∅
  | tref ξ => {[ ξ ]}
  | ttask ξ A τ => {[ ξ ]} ∪ (ty_names τ ∖ A)
  end.
Instance: Names type := ty_names.

Fixpoint he_names η: gset lname :=
  match η with
  | hemp => ∅
  | hstar η η' => he_names η ∪ he_names η'
  | hpt ξ τ => {[ ξ ]} ∪ names τ
  | hwait ξ A η => {[ ξ ]} ∪ (he_names η ∖ A)
  end.
Instance: Names hexpr := he_names.

Fixpoint res_names η: gset lname :=
  match η with
  | hemp => ∅
  | hstar η η' => res_names η ∪ res_names η'
  | hpt ξ τ => {[ ξ ]}
  | hwait ξ A η => {[ ξ ]} ∪ (res_names η ∖ A)
  end.

Inductive hexpr_equiv: Equiv hexpr :=
| hee_refl: Reflexive (≡)
| hee_symm: Symmetric (≡)
| hee_trans: Transitive (≡)
| hee_proper_star: Proper ((≡) ==> (≡) ==> (≡)) hstar
| hee_proper_wait: ∀ ξ A, Proper ((≡) ==> (≡)) (hwait ξ A)
| hee_assoc: Assoc (≡) hstar
| hee_comm: Comm (≡) hstar
| hee_left: LeftId (≡) hemp hstar.
Instance hexpr_equivalence: Equivalence hexpr_equiv.
Proof. split; [apply hee_refl|apply hee_symm|apply hee_trans]. Qed.
Existing Instances hee_proper_star hee_proper_wait hee_assoc hee_comm hee_left hexpr_equiv.
Instance: RightId (≡) hemp hstar.
Proof. intro; rewrite comm left_id //. Qed.

Instance he_names_proper: Proper ((≡) ==> (=)) he_names.
Proof.
  intros η η' eqη.
  apply leibniz_equiv.
  induction eqη; simpl; try done.
  - by etrans.
  - by f_equiv.
  - by do 2 f_equiv.
  - by rewrite assoc.
  - by rewrite comm.
  - by rewrite left_id.
Qed.

Instance res_names_proper: Proper ((≡) ==> (=)) res_names.
Proof.
  intros η η' eqη.
  apply leibniz_equiv.
  induction eqη; simpl; try done.
  - by etrans.
  - by f_equiv.
  - by do 2 f_equiv.
  - by rewrite assoc.
  - by rewrite comm.
  - by rewrite left_id.
Qed.

Lemma res_names_sub_names η: res_names η ⊆ names η.
Proof.
  induction η; cbn -[union]; try done.
  - by apply union_mono.
  - apply union_subseteq_l.
  - apply union_mono; first done.
    apply difference_mono; done.
Qed.

Instance combine_names `{Names A, Names B}: Names (A*B) := λ p, names (p.1) ∪ names (p.2).
Canonical Structure lnamesC := leibnizC lnames.
Instance lnamesC_union: Union lnamesC := (∪).
Instance lnamesC_monoid: Monoid lnamesC_union := Build_Monoid lnamesC (∪) ∅ _ _ _ _.

Instance names_env: Names env := λ Γ, [^ (∪) map] _ ↦ τ ∈ Γ, (names τ: lnamesC).
Lemma elem_of_names_env_empty ξ: ¬ξ ∈ names (∅: env).
Proof. rewrite /names /names_env big_opM_empty elem_of_empty => [[]]. Qed.
Lemma elem_of_names_env_insert x τ (Γ: env) ξ (x_fresh: Γ!!x = None):
  ξ ∈ names (<[x:=τ]>Γ) ↔ ξ ∈ names τ ∨ ξ ∈ names Γ.
Proof. rewrite /names /names_env big_opM_insert ?elem_of_union; done. Qed.

Lemma elem_of_names_env ξ (Γ: env): ξ ∈ names Γ ↔ ∃ x τ, Γ !! x = Some τ ∧ ξ ∈ names τ.
Proof.
  induction Γ as [|x τ Γ x_fresh IH] using map_ind.
  - trans False.
    { split; [apply elem_of_names_env_empty|done]. }
    setoid_rewrite lookup_empty.
    split; first done.
    intros [? [? [[=] _]]].
  - rewrite elem_of_names_env_insert ?IH; last done.
    split.
    { intros [inξ|[x' [τ' [mt inξ]]]].
      { exists x, τ; rewrite lookup_insert; auto. }
      exists x', τ'; rewrite lookup_insert_ne; auto.
      intros <-; by rewrite x_fresh in mt. }
    { intros [x' [τ' [mt inξ]]].
      destruct (decide (x=x')) as [<-|neq].
      { rewrite lookup_insert in mt; injection mt as <-; auto. }
      rewrite lookup_insert_ne in mt; eauto. }
Qed.

Lemma elem_of_names_env_insert_gen x τ (Γ: env) ξ:
  ξ ∈ names (<[x:=τ]>Γ) → ξ ∈ names τ ∨ ξ ∈ names Γ.
Proof.
  assert (<[x:=τ]>Γ = <[x:=τ]>(delete x Γ)) as ->.
  { by apply map_eq; intro; rewrite insert_delete. }
  rewrite elem_of_names_env_insert; last apply lookup_delete.
  intros [case|case]; auto.
  right.
  rewrite elem_of_names_env in case * => [[x' [τ' [mtx inξ]]]].
  rewrite elem_of_names_env.
  exists x', τ'; split; auto.
  rewrite lookup_delete_Some in mtx * => [[_ ?]]; done.
Qed.

Lemma elem_of_names_env_insert' x τ (Γ: env) ξ:
  ξ ∈ names (insert' x τ Γ) → ξ ∈ names τ ∨ ξ ∈ names Γ.
Proof.
  destruct x; last apply elem_of_names_env_insert_gen.
  auto.
Qed.

Inductive heap_wf: lnames → hexpr → Prop :=
| wf_emp Ξ: heap_wf Ξ hemp
| wf_star Ξ η₁ η₂ (disj: res_names η₁ ⊥ res_names η₂):
    heap_wf Ξ η₁ → heap_wf Ξ η₂ → heap_wf Ξ (η₁ ⊗ η₂)
| wf_pt Ξ ξ τ (inξ: ξ ∈ Ξ) (sub: names τ ⊆ Ξ): heap_wf Ξ (ξ ↦ τ)
| wf_wait Ξ ξ A η (inξ: ξ ∈ Ξ) (notinξ: ξ ∉ names η)
          (disj: Ξ ⊥ A):
    heap_wf (Ξ ∪ A) η → heap_wf Ξ (hwait ξ A η).

Lemma heap_wf_star Ξ η₁ η₂:
  heap_wf Ξ (η₁ ⊗ η₂) ↔ heap_wf Ξ η₁ ∧ heap_wf Ξ η₂ ∧ res_names η₁ ⊥ res_names η₂.
Proof.
  split.
  - inversion_clear 1; auto.
  - by intros [?[??]]; constructor.
Qed.

Lemma heap_wf_wait Ξ ξ A η:
  heap_wf Ξ (hwait ξ A η) ↔ ξ ∈ Ξ ∧ ξ ∉ names η ∧ Ξ ⊥ A ∧ heap_wf (Ξ ∪ A) η.
Proof.
  split.
  - inversion_clear 1; auto.
  - by intros [?[?[??]]]; constructor.
Qed.

Instance heap_wf_proper: Proper ((≡) ==> (≡) ==> iff) heap_wf.
Proof.
  intros Ξ ? <-%leibniz_equiv.
  intros η η' eqη; revert Ξ.
  induction eqη as [η|η₁ η₂ eqη|η₁ η₂ η₃ eq₁₂ IH₁₂ eq₂₃ IH₂₃|η₁ η₁' eqη₁ IHη₁ η₂ η₂' eqη₂ IHη₂
                    |ξ A η η' eqη IH|η₁ η₂ η₃|η₁ η₂|η];
    intro.
  - done.
  - done.
  - by rewrite IH₁₂.
  - by rewrite !heap_wf_star IHη₁ IHη₂ eqη₁ eqη₂.
  - by rewrite !heap_wf_wait IH eqη.
  - rewrite !heap_wf_star; cbn.
    rewrite disjoint_union_r disjoint_union_l.
    tauto.
  - rewrite !heap_wf_star.
    intuition.
  - rewrite heap_wf_star.
    intuition.
    + constructor.
    + apply disjoint_empty_l.
Qed.

(* TODO - figure out how to get a nice notation working. *)
Inductive typing: lnames → env → expr → hexpr → lnames → type → hexpr → Prop :=
| tytrue U Γ: typing U Γ Ctrue ∅ ∅ Bool ∅
| tyfalse U Γ: typing U Γ Cfalse ∅ ∅ Bool ∅
| tyunit  U Γ: typing U Γ Cunit ∅ ∅ Unit ∅
| tyvar U Γ (x: string) τ (Γx: Γ !! x = Some τ): typing U Γ x ∅ ∅ τ ∅
| tylet U Γ (x: binder) η₁ η₂ η₃ τ₁ τ₂ A₁ A₂ e₁ e₂:
    typing U Γ e₁ η₁ A₁ τ₁ η₂ →
    typing (U ∪ A₁) (insert' x τ₁ Γ) e₂ η₂ A₂ τ₂ η₃ →
    typing U Γ (Let x e₁ e₂) η₁ (A₁ ∪ A₂) τ₂ η₃
| tyif U Γ η₁ η₂ η₃ τ A₁ A₂ e₁ e₂ e₃:
    typing U Γ e₁ η₁ A₁ tbool η₂ →
    typing (U ∪ A₁) Γ e₂ η₂ A₂ τ η₃ →
    typing (U ∪ A₁) Γ e₃ η₂ A₂ τ η₃ →
    typing U Γ (If e₁ e₂ e₃) η₁ (A₁ ∪ A₂) τ η₃
| tyref U Γ e η₁ η₂ τ A ξ (ξ_fresh: ξ ∉ U ∪ A) (post_wf: heap_wf (U ∪ A ∪ {[ξ]}) (η₂ ⊗ ξ ↦ τ)):
    typing U Γ e η₁ A τ η₂ →
    typing U Γ (Alloc e) η₁ (A ∪ {[ ξ ]}) (Ref(ξ)) (η₂ ⊗ ξ ↦ τ)
| tyread U Γ e η₁ η₂ ξ τ A:
    typing U Γ e η₁ A (Ref(ξ)) (η₂ ⊗ ξ ↦ τ) →
    typing U Γ (Read e) η₁ A τ (η₂ ⊗ ξ ↦ τ)
| tywrite U Γ e e' η₁ η₂ η₃ ξ τ A₁ A₂:
    typing U Γ e η₁ A₁ (Ref(ξ)) η₂ →
    typing (U ∪ A₁) Γ e' η₂ A₂ τ (η₃ ⊗ ξ ↦ τ) →
    typing U Γ (Write e e') η₁ (A₁ ∪ A₂) Unit (η₃ ⊗ ξ ↦ τ)
| typost U Γ e η₁ η₂ τ A ξ (ξ_fresh: ξ ∉ U ∪ A) (wf_post: heap_wf (U ∪ {[ξ]}) (Wait(ξ,A) η₂)):
    typing U Γ e η₁ A τ η₂ →
    typing U Γ (Post e) η₁ {[ξ]} (Promise(ξ,A) τ) (Wait(ξ,A) η₂)
| tywait U Γ e (η₁ η₂ η₃: hexpr) τ ξ A₁ A₂ (wfη: heap_wf (U ∪ A₁ ∪ A₂) (η₂ ⊗ η₃)) (disj: A₂ ⊥ U)
         (ξ_not_in_τ: ξ ∉ names τ) (ξ_not_in_η₃: ξ ∉ names η₃) (disjA: A₁ ⊥ A₂):
    typing U Γ e η₁ A₁ (ttask ξ A₂ τ) (η₂ ⊗ hwait ξ A₂ η₃) →
    typing U Γ (Wait e) η₁ (A₁ ∪ A₂) τ (η₂ ⊗ η₃)
| tyframe U Γ e (η₁ η₂: hexpr) τ A (ηf: hexpr)
          (disjη: res_names η₁ ⊥ res_names ηf)
          (disjη': res_names η₂ ⊥ res_names ηf)
          (disjA: A ⊥ names ηf) (wf: heap_wf (U ∪ A) ηf):
    typing U Γ e η₁ A τ η₂ →
    typing U Γ e (η₁ ⊗ ηf) A τ (η₂ ⊗ ηf)
| tyweaken U Γ e η₁ η₂ τ A U' Γ' A' (env_good: names Γ ⊆ U) (pre_good: names η₁ ⊆ U) (disjUA: U' ⊥ A')
           (subU: U ⊆ U') (subΓ: Γ ⊆ Γ') (subA: A ⊆ A') (wf: heap_wf (A' ∪ U') η₂):
    typing U Γ e η₁ A τ η₂ →
    typing U' Γ' e η₁ A' τ η₂
| typroper U U' Γ e η₁ η₁' A A' τ η₂ η₂'
           (eqU: U ≡ U') (eqη₁: η₁ ≡ η₁') (eqA: A ≡ A') (eqη₂: η₂ ≡ η₂'):
    typing U Γ e η₁ A τ η₂ → typing U' Γ e η₁' A' τ η₂'.
Instance: Proper ((≡) ==> (=) ==> (=) ==> (≡) ==> (≡) ==> (=) ==> (≡) ==> iff) typing.
Proof.
  intros U ? <-%leibniz_equiv Γ ? <- e ? <- η₁ η₁' eqη₁ A ? <-%leibniz_equiv τ ? <- η₂ η₂' eqη₂.
  split; apply typroper; done.
Qed.

Lemma lookup_insert' {A} x b y z (m: gmap string A):
  insert' b x m !! y = Some z ↔ (b = BNamed y ∧ x = z) ∨ (b ≠ BNamed y ∧ m!!y = Some z).
Proof.
  unfold insert'.
  destruct b as [|b].
  - intuition congruence.
  - destruct (decide (b = y)) as [<-|neq].
    + rewrite lookup_insert; intuition congruence.
    + rewrite lookup_insert_ne; intuition congruence.
Qed.

Lemma typing_good_names U Γ e η τ η' A:
  typing U Γ e η A τ η' →
  names Γ ⊆ U → names η ⊆ U →
  A ⊥ U ∧ names τ ⊆ U ∪ A ∧ names η' ⊆ U ∪ A.
Proof.
  induction 1; intros env_good' pre_good'; cbn -[union].
  1,2,3: repeat split; try apply disjoint_empty_l; try apply empty_subseteq.
  - split; first apply disjoint_empty_l.
    split; last apply empty_subseteq.
    rewrite right_id.
    etrans; last apply env_good'.
    intro ξ.
    rewrite elem_of_names_env.
    exists x,τ; auto.
  - destruct IHtyping1 as [disj₁ [subτ₁ subη₂]]; auto.
    destruct IHtyping2 as [[disj₂ disjA]%disjoint_union_r [subτ₂ subη₃]]; auto.
    { intros ξ [?|?]%elem_of_names_env_insert'; auto.
      apply elem_of_union_l; auto. }
    rewrite !assoc disjoint_union_l; auto.
  - destruct IHtyping1 as [disj₁ [subτ₁ subη₂]]; auto.
    destruct IHtyping2 as [[disj₂ disjA]%disjoint_union_r [subτ₂ subη₃]]; auto.
    { etrans; first done. apply union_subseteq_l. }
    rewrite !assoc disjoint_union_l; auto.
  - destruct IHtyping as [disj [subτ subη']]; auto.
    rewrite not_elem_of_union in ξ_fresh * => [[??]].
    repeat split.
    + rewrite disjoint_union_l disjoint_singleton_l; auto.
    + rewrite assoc; apply union_subseteq_r.
    + rewrite (comm (∪) {[ξ]}) !assoc; apply union_mono; last done.
      apply union_least; done.
  - destruct IHtyping as [disj [subτ subη']]; auto.
    repeat split; auto.
    etrans; last apply subη'.
    etrans; last apply union_subseteq_r.
    apply union_subseteq_r.
  - destruct IHtyping1 as [disj [subτ subη']]; auto.
    destruct IHtyping2 as [disj' [subτ' subη'']]; auto.
    { by etrans; last apply union_subseteq_l. }
    rewrite disjoint_union_r in disj' * => [[??]].
    rewrite disjoint_union_l; split; auto.
    split.
    { apply empty_subseteq. }
    rewrite (assoc (∪) U); done.
  - destruct IHtyping as [disj₁ [subτ₁ subη₂]]; auto.
    rewrite not_elem_of_union in ξ_fresh * => [[??]].
    rewrite disjoint_singleton_l.
    split; auto.
    split; (rewrite comm; apply union_mono; last done).
    + clear -subτ₁; set_solver.
    + clear -subη₂; set_solver.
  - destruct IHtyping as [disj' [subτ subη]]; auto.
    rewrite disjoint_union_l.
    rewrite !assoc.
    repeat split; auto.
    + intros ξ' inξ'.
      rewrite elem_of_union.
      destruct (decide (ξ' ∈ A₂)); auto.
      left; apply subτ.
      rewrite /= elem_of_union elem_of_difference; auto.
    + apply union_least.
      * etrans; last apply union_subseteq_l.
        etrans; last apply subη.
        apply union_subseteq_l.
      * intros ξ' inξ'.
        rewrite elem_of_union.
        destruct (decide (ξ' ∈ A₂)); auto.
        left; apply subη.
        cbn -[union].
        do 2 apply elem_of_union_r.
        rewrite elem_of_difference; auto.
  - destruct IHtyping as [disj [subτ subη]]; auto.
    + etrans; last apply pre_good'.
      apply union_subseteq_l.
    + repeat split; auto.
      apply union_least; auto.
      trans U; last apply union_subseteq_l.
      etrans; last apply pre_good'.
      apply union_subseteq_r.
  - destruct IHtyping as [disj [namesτ namesη']]; auto.
    repeat split; auto.
    + etrans; first apply namesτ.
      apply union_mono; done.
    + etrans; first apply namesη'.
      apply union_mono; done.
  - subst.
    apply leibniz_equiv in eqU; subst.
    apply leibniz_equiv in eqA; subst.
    rewrite -eqη₂.
    destruct IHtyping as [? [??]]; auto.
    rewrite eqη₁; done.
Qed.

Lemma heap_wf_names U η: heap_wf U η → names η ⊆ U.
Proof.
  induction 1; cbn -[union].
  - apply empty_subseteq.
  - by apply union_least.
  - apply union_least; auto.
    apply elem_of_subseteq_singleton; done.
  - apply union_least.
    + by apply elem_of_subseteq_singleton.
    + clear -IHheap_wf.
      set_solver.
Qed.

Lemma typing_wf  U Γ e η τ η' A:
  typing U Γ e η A τ η' → heap_wf U η → heap_wf (U ∪ A) η'.
Proof.
  induction 1; intro wf'.
  1-4: constructor.
  all: try by rewrite ?union_assoc_L; auto.
  - inversion_clear wf'.
    constructor; auto.
  - by rewrite union_comm_L.
  - apply leibniz_equiv in eqU.
    apply leibniz_equiv in eqA.
    subst.
    rewrite -eqη₂.
    apply IHtyping.
    rewrite eqη₁; done.
Qed.