Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Limits.Limit.
Require Import Archetypal.Discr.Discr.
Require Import Cat.Cat_Terminal.
Require Import
        Basic_Cons.Terminal
        Basic_Cons.Product
        Basic_Cons.Equalizer
        Basic_Cons.PullBack
.

(** In this module we show that terminal objects, products, equalizers and pullbacks
are limits. The corresponding duals are dually colimits. *)

Section Limits.
  Context {C : Category}.

  Universe i.

  Local Monomorphic Definition Constraint : Type@{i} := Set.

  Notation Empty := (Empty : Type@{i}).
  Notation bool := (bool : Type@{i}).
  Notation unit := (unit : Type@{i}).

  Section Terminal.

    Definition Terminal_Producing_Func_fun (x : Empty) : C
      :=
        match x with
        end
    .

    Context (L : Limit (Discr_Func Terminal_Producing_Func_fun)).

    Program Definition Terminal_as_Limit_Cone
            (c : C)
      :
        Cone (Discr_Func Terminal_Producing_Func_fun)
      :=
        {|
          cone_apex :=
            {|
              FO := fun _ => c;
              FA := fun _ _ _ => id
            |};
          cone_edge :=
            {|
              Trans :=
                fun x =>
                  match x with
                  end
            |}
        |}
    .

    Local Hint Extern 1 => match goal with [x : unit |- _] => destruct x end.
    Local Hint Extern 1 => rewrite From_Term_Cat.
    Local Hint Extern 1 => apply NatTrans_eq_simplify.
    Local Hint Extern 1 => progress cbn.

    Local Obligation Tactic := basic_simpl; auto 10.

    Program Definition Terminal_as_Limit_Cone_morph
            {c : C}
            (f : (c –≻ L)%morphism)
      :
        Cone_Morph _ (Terminal_as_Limit_Cone c) (LRKE L)
      :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  match c as u return ( _ –≻ L _o u)%object%morphism with
                    tt => f
                  end
            |}
        |}
    .

    Program Definition Terminal_as_Limit : Terminal C :=
      {|
        terminal := L;
        t_morph :=
          fun c =>
            Trans (LRKE_morph_ex L (Terminal_as_Limit_Cone c)) tt
      |}
    .

    Local Obligation Tactic := idtac.

    Next Obligation.
    Proof.
      intros c f g.
      apply (
          f_equal
            (fun w : (Terminal_as_Limit_Cone c –≻ L)%nattrans => Trans w tt)
            (
              LRKE_morph_unique
                L
                _
                (Terminal_as_Limit_Cone_morph f)
                (Terminal_as_Limit_Cone_morph g)
            )
        ).
    Qed.

  End Terminal.

  Section Product.
    Context (a b : C).

    Definition Product_Producing_Func_fun (x : bool) : C
      :=
        match x with
        | true => a
        | false => b
        end
    .

    Context (L : Limit (Discr_Func Product_Producing_Func_fun)).

    Program Definition Product_as_Limit_Cone
            {p : C}
            (h : (p –≻ a)%morphism)
            (h' : (p –≻ b)%morphism)
      :
        Cone (Discr_Func Product_Producing_Func_fun)
      :=
        {|
          cone_apex :=
            {|
              FO := fun _ => p;
              FA := fun _ _ _ => id
            |};
          cone_edge :=
            {|
              Trans :=
                fun x =>
                  match x with
                  | true => h
                  | false => h'
                  end
            |}
        |}
    .

    Local Hint Extern 1 => match goal with [x : unit |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [x : bool |- _] => destruct x end.
    Local Hint Extern 1 => rewrite From_Term_Cat.
    Local Hint Extern 1 => apply NatTrans_eq_simplify.
    Local Hint Extern 1 => progress cbn.

    Local Obligation Tactic := basic_simpl; auto 10.

    Program Definition Product_as_Limit_Cone_morph
            {p : C}
            (h : (p –≻ a)%morphism)
            (h' : (p –≻ b)%morphism)
            (f : (p –≻ L)%morphism)
            (H1 : (Trans L true ∘ f)%morphism = h)
            (H2 : (Trans L false ∘ f)%morphism = h')
      :
        Cone_Morph _ (Product_as_Limit_Cone h h') (LRKE L)
      :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  match c as u return ( _ –≻ L _o u)%object%morphism with
                    tt => f
                  end
            |}
        |}
    .

    Program Definition Product_as_Limit : Product a b :=
      {|
        product := L;
        Pi_1 := Trans (cone_edge L) true;
        Pi_2 := Trans (cone_edge L) false;
        Prod_morph_ex :=
          fun p h h' =>
            Trans (LRKE_morph_ex L (Product_as_Limit_Cone h h')) tt
      |}
    .

    Local Obligation Tactic := idtac.

    Next Obligation.
    Proof.
      intros p h h'.
      cbn.
      set (H :=
             f_equal
               (fun w
                    :
                      (Product_as_Limit_Cone h h'
                 ∘ Functor_To_1_Cat (Discr_Cat Datatypes.bool)
                 –≻ Discr_Func Product_Producing_Func_fun)%nattrans
                => Trans w true)
               (cone_morph_com (LRKE_morph_ex L (Product_as_Limit_Cone h h')))
          ).
      cbn in H.
      rewrite From_Term_Cat in H.
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros p h h'.
      set (H :=
             f_equal
               (fun w
                    :
                      ((Product_as_Limit_Cone h h')
                         ∘ Functor_To_1_Cat (Discr_Cat Datatypes.bool)
                         –≻ Discr_Func Product_Producing_Func_fun)%nattrans
                => Trans w false)
               (cone_morph_com (LRKE_morph_ex L (Product_as_Limit_Cone h h')))
          ).
      cbn in H.
      rewrite From_Term_Cat in H.
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros p h h' f g H1 H2 H3 H4.
      apply (
          f_equal
            (fun w : (Product_as_Limit_Cone h h' –≻ L)%nattrans => Trans w tt)
            (
              LRKE_morph_unique
                L
                _
                (Product_as_Limit_Cone_morph _ _ _ H1 H2)
                (Product_as_Limit_Cone_morph _ _ _ H3 H4)
            )
        ).
    Qed.

  End Product.

  Section Equalizer.
    Context {a b : C} (f g : (a –≻ b)%morphism).

    Local Hint Extern 1 => match goal with [x : unit |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [x : Empty |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [x : bool |- _] => destruct x end.
    Local Hint Extern 1 => rewrite From_Term_Cat.
    Local Hint Extern 1 => apply NatTrans_eq_simplify.
    Local Hint Extern 1 => progress cbn.

    Local Obligation Tactic := basic_simpl; auto 10.

    Program Definition Equalizer_Producing_Cat : Category
      :=
        {|
          Obj := bool;
          Hom :=
            fun x y =>
              match (x, y) with
              | (true, true) => unit
              | (true, false) => bool
              | (false, true) => Empty
              | (false, false) => unit
              end;
          compose :=
            fun x y z h h'=> _;
          id := fun x => _
        |}
    .

    Next Obligation.
    Proof.
      destruct x; destruct y; destruct z; auto.
    Defined.

    Next Obligation.
    Proof.
      destruct x; constructor.
    Defined.

    Program Definition Equalizer_Producing_Func :
      (Equalizer_Producing_Cat –≻ C)%functor
      :=
        {|
          FO :=
            fun x =>
              match x with
              | true => a
              | false => b
              end;
          FA := fun x y h => _
        |}
    .

    Next Obligation.
    Proof.
      destruct x; destruct y.
      exact id.
      destruct h.
      {
        exact f.
      }
      {
        exact g.
      }
      destruct h.
      exact id.
    Defined.

    Context (L : Limit Equalizer_Producing_Func).

    Program Definition Equalizer_as_Limit_Cone
            {p : C}
            {h : (p –≻ a)%morphism}
            (H : (f ∘ h)%morphism = (g ∘ h)%morphism)
      :
        Cone Equalizer_Producing_Func
      :=
        {|
          cone_apex :=
            {|
              FO := fun _ => p;
              FA := fun _ _ _ => id
            |};
          cone_edge :=
            {|
              Trans :=
                fun x =>
                  match x with
                  | true => h
                  | false => (f ∘ h)%morphism
                  end
            |}
        |}
    .

    Local Obligation Tactic := idtac.

    Program Definition Equalizer_as_Limit_Cone_morph
            {p : C}
            {h : (p –≻ a)%morphism}
            (H1 : (f ∘ h)%morphism = (g ∘ h)%morphism)
            (k : (p –≻ L)%morphism)
            (H2 : (Trans L true ∘ k)%morphism = h)
      :
        Cone_Morph _ (Equalizer_as_Limit_Cone H1) (LRKE L)
      :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  match c as u return ( _ –≻ L _o u)%object%morphism with
                    tt => k
                  end
            |}
        |}
    .

    Next Obligation.
    Proof.
      basic_simpl; auto 10.
    Qed.

    Next Obligation.
    Proof.
      basic_simpl; auto 10.
    Qed.

    Next Obligation.
    Proof.
      intros p h H1 k H2.
      apply NatTrans_eq_simplify.
      extensionality x.
      cbn in *.
      destruct x; auto.
      rewrite assoc_sym.
      cbn_rewrite (@Trans_com _ _ _ _ L true false false).
      rewrite assoc.
      rewrite H1; rewrite <- H2.
      trivial.
    Qed.

    Program Definition Equalizer_as_Limit : Equalizer f g :=
      {|
        equalizer := L;
        equalizer_morph := Trans L true;
        equalizer_morph_ex :=
          fun e eqm H =>
            Trans (LRKE_morph_ex L (Equalizer_as_Limit_Cone H)) tt
      |}
    .

    Local Obligation Tactic := idtac.

    Next Obligation.
    Proof.
      set (H := @Trans_com _ _ _ _ L true false false).
      cbn in H.
      cbn_rewrite (@Trans_com _ _ _ _ L true false true) in H.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      intros e eqm eqmc; cbn.
      cbn_rewrite (
          f_equal
            (fun w :
                   ((Equalizer_as_Limit_Cone eqmc)
                      ∘ Functor_To_1_Cat Equalizer_Producing_Cat
                      –≻ Equalizer_Producing_Func)%nattrans
             => Trans w true)
            (cone_morph_com (LRKE_morph_ex L (Equalizer_as_Limit_Cone eqmc)))
        ).
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros e eqm H1 h h' H2 H3.
      apply (
          f_equal
            (fun w : (Equalizer_as_Limit_Cone H1 –≻ L)%nattrans => Trans w tt)
            (
              LRKE_morph_unique
                L
                _
                (Equalizer_as_Limit_Cone_morph _ _ H2)
                (Equalizer_as_Limit_Cone_morph _ _ H3)
            )
        ).
    Qed.

  End Equalizer.

  Section PullBack.
    Context
      {a b c : C}
      (f : (a –≻ c)%morphism)
      (g : (b –≻ c)%morphism)
    .

    Inductive PBType :=
    | PB_A
    | PB_B
    | PB_C
    .

    Local Hint Extern 1 => match goal with [x : unit |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [x : PBType |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [x : Empty |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [x : bool |- _] => destruct x end.
    Local Hint Extern 1 => match goal with [|- unit] => constructor end.
    Local Hint Extern 1 => rewrite From_Term_Cat.
    Local Hint Extern 1 => apply NatTrans_eq_simplify.
    Local Hint Extern 1 => progress cbn.

    Local Obligation Tactic := basic_simpl; auto 10.

    Program Definition PullBack_Producing_Cat : Category
      :=
        {|
          Obj := PBType;
          Hom :=
            fun x y =>
              match (x, y) with
              | (PB_A, PB_A) => unit
              | (PB_A, PB_B) => Empty
              | (PB_A, PB_C) => unit
              | (PB_B, PB_A) => Empty
              | (PB_B, PB_B) => unit
              | (PB_B, PB_C) => unit
              | (PB_C, PB_A) => Empty
              | (PB_C, PB_B) => Empty
              | (PB_C, PB_C) => unit
              end;
          compose :=
            fun x y z h h'=> _;
          id := fun x => _
        |}
    .

    Program Definition PullBack_Producing_Func :
      (PullBack_Producing_Cat –≻ C)%functor
      :=
        {|
          FO :=
            fun x =>
              match x with
              | PB_A => a
              | PB_B => b
              | PB_C => c
              end;
          FA := fun x y h => _
        |}
    .

    Next Obligation.
    Proof.
      destruct x; destruct y; auto; try exact id.
    Defined.

    Context (L : Limit PullBack_Producing_Func).

    Program Definition PullBack_as_Limit_Cone
            {p : C}
            {h : (p –≻ a)%morphism}
            {h' : (p –≻ b)%morphism}
            (H : (f ∘ h)%morphism = (g ∘ h')%morphism)
      :
        Cone PullBack_Producing_Func
      :=
        {|
          cone_apex :=
            {|
              FO := fun _ => p;
              FA := fun _ _ _ => id
            |};
          cone_edge :=
            {|
              Trans :=
                fun x =>
                  match x with
                  | PB_A => h
                  | PB_B => h'
                  | PB_C => (f ∘ h)%morphism
                  end
            |}
        |}
    .

    Local Obligation Tactic := idtac.

    Program Definition PullBack_as_Limit_Cone_morph
            {p : C}
            {h : (p –≻ a)%morphism}
            {h' : (p –≻ b)%morphism}
            (H1 : (f ∘ h)%morphism = (g ∘ h')%morphism)
            (k : (p –≻ L)%morphism)
            (H2 : (Trans L PB_A ∘ k)%morphism = h)
            (H3 : (Trans L PB_B ∘ k)%morphism = h')
      :
        Cone_Morph _ (PullBack_as_Limit_Cone H1) (LRKE L)
      :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  match c as u return ( _ –≻ L _o u)%object%morphism with
                    tt => k
                  end
            |}
        |}
    .

    Next Obligation.
    Proof.
      basic_simpl; auto 10.
    Qed.

    Next Obligation.
    Proof.
      basic_simpl; auto 10.
    Qed.

    Next Obligation.
    Proof.
      intros p h h' H1 k H2 H3.
      apply NatTrans_eq_simplify.
      extensionality x.
      cbn in *.
      destruct x; auto.
      rewrite assoc_sym.
      cbn_rewrite (@Trans_com _ _ _ _ L PB_B PB_C tt).
      rewrite assoc.
      rewrite H1; rewrite <- H3.
      trivial.
    Qed.

    Program Definition PullBack_as_Limit : PullBack f g :=
      {|
        pullback := L;
        pullback_morph_1 := Trans L PB_A;
        pullback_morph_2 := Trans L PB_B;
        pullback_morph_ex :=
          fun e pm1 pm2 pmc =>
            Trans (LRKE_morph_ex L (PullBack_as_Limit_Cone pmc)) tt
      |}
    .

    Local Obligation Tactic := idtac.

    Next Obligation.
    Proof.
      set (H := @Trans_com _ _ _ _ L PB_B PB_C tt).
      cbn in H.
      cbn_rewrite (@Trans_com _ _ _ _ L PB_A PB_C tt) in H.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      intros e pm1 pm2 pmc; cbn.
      cbn_rewrite (
          f_equal
            (fun w :
                   ((PullBack_as_Limit_Cone pmc)
                      ∘ Functor_To_1_Cat PullBack_Producing_Cat
                      –≻ PullBack_Producing_Func)%nattrans
             => Trans w PB_A)
            (cone_morph_com (LRKE_morph_ex L (PullBack_as_Limit_Cone pmc)))
        ).
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros e pm1 pm2 pmc; cbn.
      cbn_rewrite (
          f_equal
            (fun w :
                   ((PullBack_as_Limit_Cone pmc)
                      ∘ Functor_To_1_Cat PullBack_Producing_Cat
                      –≻ PullBack_Producing_Func)%nattrans
             => Trans w PB_B)
            (cone_morph_com (LRKE_morph_ex L (PullBack_as_Limit_Cone pmc)))
        ).
      auto.
    Qed.

    Next Obligation.
    Proof.
      intros e pm1 pm2 H1 h h' H2 H3 H4 H5.
      apply (
          f_equal
            (fun w : (PullBack_as_Limit_Cone H1 –≻ L)%nattrans => Trans w tt)
            (
              LRKE_morph_unique
                L
                _
                (PullBack_as_Limit_Cone_morph _ _ H2 H3)
                (PullBack_as_Limit_Cone_morph _ _ H4 H5)
            )
        ).
    Qed.

  End PullBack.

End Limits.


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

Require Import List.

Require Import Domains.basics.
Require Import Domains.categories.
Require Import Domains.preord.
Require Import Domains.sets.
Require Import Domains.finsets.
Require Import Domains.esets.
Require Import Domains.effective.
Require Import Domains.plotkin.
Require Import Domains.profinite.
Require Import Domains.embed.
Require Import Domains.joinable.
Require Import Domains.directed.
Require Import Domains.cont_functors.
Require Import Domains.bilimit.

(**  * Embedding functor for exponentials.

     Here we define the function space functor in the category of embeddings
     and prove that is is continuous.
  *)

Section map_rel.
  Context {A B C D : preord}.

  Variable f:A -> B.
  Variable g:C -> D.

  Fixpoint map_rel (G:finset (A×C)%cat_ob) : finset (B×D)%cat_ob :=
    match G with
    | nil => nil
    | (a,c)::G' => (f a, g c)::map_rel G'
    end.

  Lemma map_rel_inh : forall hf G,
    inh hf G -> inh hf (map_rel G).
  Proof.
    intros.
    destruct hf; hnf; auto.
    destruct H.
    destruct H as [q [??]].
    clear x H0.
    induction G. elim H.
    hnf in H. destruct H.
    subst a.
    destruct q.
    exists (f c, g c0).
    exists (f c, g c0).
    split; simpl; auto.
    destruct IHG as [x ?]; auto.
    exists x.
    simpl. destruct a.
    apply cons_elem; auto.
  Qed.

  Lemma unmap_rel : forall b d G,
    (b,d) ∈ map_rel G ->
    exists a c, (a,c) ∈ G /\ f a ≈ b /\ g c ≈ d.
  Proof.
    induction G; simpl; intros.
    apply nil_elem in H. elim H.
    destruct a. simpl in H.
    apply cons_elem in H. destruct H.
    exists c. exists c0.
    split; auto.
    apply cons_elem; auto.
    destruct H as [[??][??]]; split; split; auto.
    destruct IHG as [p [q [??]]]; auto.
    exists p. exists q. split; auto.
    apply cons_elem; auto.
  Qed.

  Lemma unmap_rel_sub : forall G X,
    G ⊆ map_rel X ->
    exists G', G' ⊆ X /\ G ≈ map_rel G'.
  Proof.
    induction G; simpl; intros.
    exists nil. simpl; split; auto.
    red; intros. apply nil_elem in H0. elim H0.
    destruct (IHG X) as [G' [??]].
    hnf; intros. apply H. apply cons_elem; auto.
    assert (a ∈ map_rel X).
    apply H. apply cons_elem. auto.
    destruct a.
    apply unmap_rel in H2.
    destruct H2 as [p [q [?[??]]]].
    exists ((p,q)::G').
    split.
    hnf; intros.
    apply cons_elem in H5. destruct H5.
    rewrite H5. auto.
    apply H0; auto.
    split; hnf; simpl; intros.
    apply cons_elem in H5.
    destruct H5. rewrite H5.
    apply cons_elem.
    left.
    destruct H3; destruct H4; split; split; auto.
    apply cons_elem. right; auto.
    rewrite <- H1; auto.

    apply cons_elem in H5.
    destruct H5. rewrite H5.
    apply cons_elem.
    left.
    destruct H3; destruct H4; split; split; auto.
    apply cons_elem. right; auto.
    rewrite H1; auto.
  Qed.
End map_rel.

Section exp_functor.
  Variable hf:bool.
  Variables A B C D:ob (EMBED hf).

  Variable f:A ⇀ B.
  Variable g:C ⇀ D.

  Lemma map_rel_in : forall G a b,
    (a,b) ∈ G -> (f a, g b) ∈ map_rel f g G.
  Proof.
    induction G; simpl; intros.
    apply nil_elem in H. elim H.
    apply cons_elem in H. destruct H. destruct a.
    simpl. apply cons_elem.
    left.
    destruct H as [[??][??]].
    split; split; simpl in *; auto.
    apply embed_mono; auto.
    apply embed_mono; auto.
    apply embed_mono; auto.
    apply embed_mono; auto.
    destruct a. simpl.
    apply cons_elem. right.
    apply IHG. auto.
  Qed.

  Lemma is_joinable_unmap_rel X :
    is_joinable_relation hf (map_rel f g X) ->
    is_joinable_relation hf X.
  Proof.
    intros. destruct H; split.
    destruct hf; hnf; simpl; auto.
    destruct H as [x ?].
    destruct x.
    apply unmap_rel in H.
    destruct H as [p [q [?[??]]]].
    exists (p,q). auto.
    intros.
    destruct (mub_complete (PLT.plotkin B)
      (image (π₁)%cat_ops (map_rel f g G)) (f x)) as [z [??]].
    apply inh_image.
    apply map_rel_inh; auto.
    hnf; intros.
    apply image_axiom2 in H3.
    destruct H3 as [[p q] [??]]. simpl in *.
    rewrite H4.
    destruct H2.
    apply unmap_rel in H3.
    destruct H3 as [p' [q' [?[??]]]].
    rewrite <- H6.
    apply embed_mono. apply H2.
    apply image_axiom1'.
    exists (p',q'). split; auto.

    destruct (H0 (map_rel f g G)) with z
      as [q [??]]; auto.
    apply map_rel_inh; auto.
    hnf; intros.
    destruct a.
    apply unmap_rel in H5.
    destruct H5 as [p [q [?[??]]]].
    apply member_eq with (f p, g q).
    destruct H6; destruct H7; split; split; simpl; auto.
    apply map_rel_in. apply H1. auto.

    apply unmap_rel in H5.
    destruct H5 as [z' [q' [?[??]]]].
    assert (z' ≈ x).
    split.
    apply (embed_reflects f).
    rewrite H7; auto.
    destruct H2.
    apply H9.
    hnf; intros.
    apply image_axiom2 in H10.
    destruct H10 as [[r s] [??]].
    rewrite H11; simpl.
    apply (embed_reflects f).
    rewrite H7.
    destruct H3.
    apply H3.
    apply image_axiom1'.
    exists (f r, g s).
    split; auto.
    apply map_rel_in. auto.
    apply (embed_reflects f).
    rewrite H7; auto.
    exists q'. split.
    apply member_eq with (z',q'); auto.
    destruct H9; split; split; auto.
    hnf; intros.
    apply image_axiom2 in H10.
    destruct H10 as [[r s] [??]]. rewrite H11. simpl.
    apply (embed_reflects g).
    rewrite H8. apply H6.
    apply image_axiom1'.
    exists (f r, g s). split; auto.
    apply map_rel_in. auto.
  Qed.

  Lemma is_joinable_map_rel X :
    is_joinable_relation hf X ->
    is_joinable_relation hf (map_rel f g X).
  Proof.
    intros. destruct H. split.

    apply map_rel_inh; auto.
    intros.
    apply unmap_rel_sub in H1.
    destruct H1 as [G' [??]].

    assert (exists q, upper_bound q (image (π₁)%cat_ops G') /\ f q ≤ x).
    destruct H2. clear H4.
    assert (upper_bound x (image (π₁)%cat_ops (map_rel f g G'))).
    hnf; intros.
    apply H2.
    apply image_axiom2 in H4.
    destruct H4 as [?[??]].
    rewrite <- H3 in H4.
    rewrite H5.
    apply image_axiom1. auto.
    assert (inh hf G').
    destruct hf; hnf; auto.
    destruct HGinh as [[a c] ?].
    rewrite H3 in H5.
    apply unmap_rel in H5.
    destruct H5 as [p [q [?[??]]]].
    eauto.

    clear H2 G HGinh H0 H H3 X H1.
    induction G'.
    destruct hf.
    hnf in H5.
    destruct H5 as [[a c] ?].
    apply nil_elem in H. elim H.
    destruct (embed_directed0 f x) as [q ?].
    exists q. split; auto.
    hnf; simpl; intros.
    apply nil_elem in H0. elim H0.
    destruct a as [a c].
    assert (f a ≤ x).
    apply H4. simpl. apply cons_elem; auto.
    case_eq G'; intros.
    exists a. split; auto.
    hnf; simpl; intros.
    unfold image in H1. simpl in H1.
    apply cons_elem in H1.
    destruct H1; auto.
    apply nil_elem in H1. elim H1.
    rewrite <- H0.
    destruct IHG' as [q [??]].
    hnf; intros. apply H4.
    simpl. apply cons_elem; auto.
    rewrite H0.
    eapply elem_inh.
    apply cons_elem; eauto.
    destruct (embed_directed2 f x q a) as [z [?[??]]]; auto.
    exists z. split; auto.
    hnf; simpl; intros.
    unfold image in H8; simpl in H8.
    apply cons_elem in H8.
    destruct H8. rewrite H8; auto.
    transitivity q; auto.

    destruct H4 as [q [??]].
    destruct (mub_complete (PLT.plotkin A) (image (π₁)%cat_ops G') q) as [q' [??]].
    destruct hf; hnf; auto.
    destruct HGinh.
    destruct x0.
    rewrite H3 in H6.
    apply unmap_rel in H6.
    destruct H6 as [n [m [?[??]]]].
    exists n.
    apply image_axiom1'. exists (n,m); auto.
    auto.

    assert (x ≈ f q').
    split.
    destruct H2. apply H8.
    destruct H6.
    hnf; intros.
    apply image_axiom2 in H10.
    destruct H10 as [z [??]].
    rewrite H3 in H10.
    rewrite H11.
    simpl.
    destruct z as [za zb]. simpl.
    apply unmap_rel in H10.
    destruct H10 as [za' [zb' [?[??]]]].
    rewrite <- H12.
    apply embed_mono.
    apply H6.
    apply image_axiom1'.
    exists (za',zb'). auto.
    transitivity (f q); auto.
    apply embed_mono; auto.
    transitivity (f q); auto.
    apply embed_mono; auto.

    destruct (H0 G') with q'; auto.
    destruct hf; hnf; auto.
    destruct HGinh.
    destruct x0.
    rewrite H3 in H9.
    apply unmap_rel in H9.
    destruct H9 as [n [m [?[??]]]].
    exists (n,m). auto.
    destruct H9.
    exists (g x0).
    split; auto.
    apply member_eq with (f q', g x0).
    destruct H8; split; split; simpl; auto.
    apply map_rel_in. auto.
    hnf; intros.
    apply image_axiom2 in H11. destruct H11 as [y [??]].
    rewrite H12.
    destruct y as [y1 y2]. simpl.
    simpl in H12.
    rewrite H3 in H11.
    apply unmap_rel in H11.
    destruct H11 as [y1' [y2' [?[??]]]].
    rewrite <- H14.
    apply embed_mono.
    apply H10.
    apply image_axiom1'.
    exists (y1',y2'). split; simpl; auto.
  Qed.

  Definition exp_fmap_func (X:joinable_relation hf A C) : joinable_relation hf B D :=
    match X with
    | exist G H => exist (is_joinable_relation hf)
                         (map_rel f g G)
                         (is_joinable_map_rel G H)
    end.

  Program Definition unimage_jrel (y:finset (B×D)%cat_ob) :=
    esubset
      (fun ac =>
        exists b d, (b,d) ∈ y /\ b ≤ f (fst ac) /\ g (snd ac) ≤ d)
      _
      (eprod (eff_enum A (PLT.effective A)) (eff_enum C (PLT.effective C))).
  Next Obligation.
    intros.
    apply (semidec_ex _ _
      (fun a b => exists d, (b,d) ∈ y /\ b ≤ f (fst a) /\ g (snd a) ≤ d)).
    intros. destruct H0 as [d [?[??]]]. exists d; split; auto.
    apply member_eq with (b,d); auto.
    destruct H; split; split; auto.
    split; auto.
    rewrite <- H; auto.
    apply (@PLT.effective _ B).
    intros.
    destruct ab. simpl.
    apply (semidec_ex _ _
      (fun (_:unit) d => (c0, d) ∈ y /\ c0 ≤ f (fst c) /\ g (snd c) ≤ d)).
    intros. intuition.
    apply member_eq with (c0,b); auto.
    destruct H; split; split; auto.
    rewrite <- H; auto.
    apply PLT.effective.
    intros [??].
    apply semidec_conj.
    apply dec_semidec. apply finset_dec.
    apply (OrdDec _ (eff_ord_dec _ (effective_prod (PLT.effective B) (PLT.effective D)))).
    apply semidec_conj.
    apply dec_semidec; simpl; intros.
    apply (eff_ord_dec _ (PLT.effective B)).
    apply dec_semidec; simpl; intros.
    apply (eff_ord_dec _ (PLT.effective D)).
    exact tt.
  Qed.

  Lemma unimage_jrel_order (y:joinable_relation hf B D) :
    ((forall (x x' : A) (y0 y' : C),
     x ≤ x' ->
     y' ≤ y0 ->
     (x, y0) ∈ unimage_jrel (proj1_sig y) ->
     (x', y') ∈ unimage_jrel (proj1_sig y))).
  Proof.
    intros.
    apply esubset_elem in H1.
    destruct H1.
    apply esubset_elem.
    intros. destruct H4 as [?[?[?[??]]]].
    exists x0. exists x1. intuition.
    rewrite H5. apply embed_mono.
    destruct H3 as [[??][??]]; auto.
    rewrite <- H6.
    apply embed_mono.
    destruct H3 as [[??][??]]; auto.
    split; auto.
    apply eprod_elem; split; apply eff_complete.
    destruct H2 as [b [d [?[??]]]].
    exists b. exists d. simpl; split; auto.
    simpl in *.
    split.
    transitivity (f x); auto.
    apply embed_mono; auto.
    transitivity (g y0); auto.
    apply embed_mono; auto.
    intros. destruct H3 as [?[?[?[??]]]].
    exists x0. exists x1. intuition.
    rewrite H4. apply embed_mono.
    destruct H2 as [[??][??]]; auto.
    rewrite <- H5.
    apply embed_mono.
    destruct H2 as [[??][??]]; auto.
  Qed.

  Lemma unimage_jrel_directed (y:joinable_relation hf B D) :
    (forall a : A,
     directed hf
       (erel_image A C {| orddec := eff_ord_dec A (PLT.effective A) |}
          (unimage_jrel (proj1_sig y)) a)).
  Proof.
    intro a.
    apply prove_directed.
    generalize (refl_equal hf).
    pattern hf at 2. case hf; intros.
    pattern hf at 1. rewrite H. auto.
    pattern hf at 1. rewrite H.

    destruct y as [y [Hy1 Hy2]]. simpl in *.
    destruct (mub_complete (PLT.plotkin B) nil) with (f a) as [q [??]].
    simpl.
    pattern hf at 4. rewrite H. hnf; auto.
    hnf; intros. apply nil_elem in H0. elim H0.
    destruct (Hy2 nil) with q.
    pattern hf at 3. rewrite H. hnf; auto.
    hnf; intros. apply nil_elem in H2. elim H2.
    simpl. auto.
    destruct H2.
    generalize (embed_directed0 g x).
    pattern hf at 1. rewrite H.
    intros [x' ?].
    exists x'.
    apply erel_image_elem.
    apply esubset_elem.

    intros. destruct H6 as [?[?[?[??]]]].
    exists x0. exists x1. intuition.
    rewrite H7. apply embed_mono.
    destruct H5 as [[??][??]]; auto.
    rewrite <- H8.
    apply embed_mono.
    destruct H5 as [[??][??]]; auto.

    split.
    apply eprod_elem; split; apply eff_complete.
    exists q. exists x. split; simpl; auto.

    simpl; intros.
    apply erel_image_elem in H.
    apply erel_image_elem in H0.
    apply esubset_elem in H.
    apply esubset_elem in H0.
    destruct H as [_ ?].
    destruct H0 as [_ ?].
    destruct H as [p [q [?[??]]]].
    destruct H0 as [p' [q' [?[??]]]].
    simpl in *.

    destruct y as [y [Hy1 Hy2]]. simpl in *.
    destruct (mub_complete (PLT.plotkin B) (p::p'::nil)) with (f a) as [m [??]].
    apply elem_inh with p. apply cons_elem; auto.
    hnf; intros.
    apply cons_elem in H5. destruct H5. rewrite H5.
    auto.
    apply cons_elem in H5. destruct H5. rewrite H5.
    auto.
    apply nil_elem in H5. elim H5.
    destruct (Hy2 ((p,q)::(p',q')::nil)) with m as [n [??]].
    eapply elem_inh. apply cons_elem; eauto.
    hnf; simpl; intros.
    apply cons_elem in H7. destruct H7. rewrite H7.
    auto.
    apply cons_elem in H7. destruct H7. rewrite H7.
    auto.
    apply nil_elem in H7. elim H7.
    simpl. auto.
    simpl in H8.
    destruct (embed_directed2 g n x y0) as [z [?[??]]].
    transitivity q; auto.
    apply H8. apply cons_elem; auto.
    transitivity q'; auto.
    apply H8.
    apply cons_elem; right.
    apply cons_elem; auto.
    exists z. split; auto. split; auto.
    apply erel_image_elem.
    apply esubset_elem.

    intros. destruct H13 as [?[?[?[??]]]].
    exists x0. exists x1. intuition.
    rewrite H14. apply embed_mono.
    destruct H12 as [[??][??]]; auto.
    rewrite <- H15.
    apply embed_mono.
    destruct H12 as [[??][??]]; auto.

    split.
    apply eprod_elem; split; apply eff_complete.
    exists m. exists n. split; simpl; auto.

    intros. destruct H2 as [?[?[?[??]]]].
    exists x0. exists x1. intuition.
    rewrite H3. apply embed_mono.
    destruct H1 as [[??][??]]; auto.
    rewrite <- H4.
    apply embed_mono.
    destruct H1 as [[??][??]]; auto.

    intros. destruct H2 as [?[?[?[??]]]].
    exists x0. exists x1. intuition.
    rewrite H3. apply embed_mono.
    destruct H1 as [[??][??]]; auto.
    rewrite <- H4.
    apply embed_mono.
    destruct H1 as [[??][??]]; auto.
  Qed.

  Program Definition exp_fmap : PLT.exp A C ⇀ PLT.exp B D :=
    Embedding hf (PLT.exp A C) (PLT.exp B D) exp_fmap_func _ _ _ _.
  Next Obligation.
    simpl; intros.
    destruct a as [X HX].
    destruct a' as [Y HY]. simpl in *.
    hnf; simpl; intros.
    hnf in H; simpl in H.
    apply unmap_rel in H0.
    destruct H0 as [p [q [?[??]]]].
    destruct (H p q) as [m [n [?[??]]]]; auto.
    exists (f m). exists (g n).
    split.
    apply map_rel_in. auto.
    split.
    rewrite <- H1.
    apply embed_mono; auto.
    rewrite <- H2.
    apply embed_mono; auto.
  Qed.
  Next Obligation.
    simpl; intros.
    destruct a as [X HX].
    destruct a' as [Y HY]. simpl in *.
    hnf; simpl; intros.
    hnf in H; simpl in H.
    destruct (H (f a) (g b)) as [m [n [?[??]]]]; auto.
    apply map_rel_in. auto.
    apply unmap_rel in H1.
    destruct H1 as [p [q [?[??]]]].
    exists p. exists q.
    split; auto.
    split.
    apply (embed_reflects f).
    rewrite <- H2; auto.
    apply (embed_reflects g).
    rewrite H3. auto.
  Qed.
  Next Obligation.
    intro y.
    generalize (swell hf A C
            (PLT.effective A) (PLT.plotkin A)
            (PLT.effective C) (PLT.plotkin C)
            (unimage_jrel (proj1_sig y))
            (unimage_jrel_order y)
            (unimage_jrel_directed y)).
    intros; simpl in *.
    generalize (refl_equal hf).
    pattern hf at 2. case hf; intros.
    pattern hf at 1. rewrite H0. auto.
    pattern hf at 1. rewrite H0.
    destruct (H nil).
    pattern hf at 3.
    rewrite H0. hnf; auto.
    hnf; simpl; intros. apply nil_elem in H1. elim H1.
    destruct H1 as [?[??]].
    exists (exist _ x H3).
    simpl.
    hnf; simpl; intros.
    apply unmap_rel in H4.
    destruct H4 as [a' [c' [?[??]]]].
    apply H2 in H4.
    unfold unimage_jrel in H4.
    simpl in H4.
    apply esubset_elem in H4.
    destruct H4.
    destruct H7 as [p [q [?[??]]]].
    exists p. exists q.
    split; auto.
    split.
    rewrite <- H5. auto.
    rewrite <- H6. auto.

    intros. destruct H8 as [?[?[?[??]]]].
    exists x0. exists x1. intuition.
    rewrite H9. apply embed_mono.
    destruct H7 as [[??][??]]; auto.
    rewrite <- H10.
    apply embed_mono.
    destruct H7 as [[??][??]]; auto.
  Qed.
  Next Obligation.
    intros.
    generalize (swell hf A C
            (PLT.effective A) (PLT.plotkin A)
            (PLT.effective C) (PLT.plotkin C)
            (unimage_jrel (proj1_sig y))
            (unimage_jrel_order y)
            (unimage_jrel_directed y)).
    simpl in *; intros.
    destruct (H1 (proj1_sig a ++ proj1_sig b)) as [X [?[??]]].
    destruct a. destruct i.
    simpl.
    generalize i.
    clear.
    destruct hf; intros; hnf; auto.
    destruct i as [q ?].
    exists q. apply app_elem. auto.
    hnf; intros.
    apply app_elem in H2. destruct H2.
    apply esubset_elem.

    intros. destruct H4 as [?[?[?[??]]]].
    exists x. exists x0. intuition.
    rewrite H5. apply embed_mono.
    destruct H3 as [[??][??]]; auto.
    rewrite <- H6.
    apply embed_mono.
    destruct H3 as [[??][??]]; auto.

    destruct a0 as [p q].
    split. apply eprod_elem; split; apply eff_complete.
    destruct (H (f p) (g q)) as [m [n [?[??]]]].
    destruct a; simpl in *.
    apply map_rel_in. auto.
    exists m. exists n. split; auto.
    destruct a0 as [p q].
    destruct (H0 (f p) (g q)) as [m [n [?[??]]]].
    destruct b; simpl in *.
    apply map_rel_in. auto.
    apply esubset_elem.

    intros. destruct H7 as [?[?[?[??]]]].
    exists x. exists x0. intuition.
    rewrite H8. apply embed_mono.
    destruct H6 as [[??][??]]; auto.
    rewrite <- H9.
    apply embed_mono.
    destruct H6 as [[??][??]]; auto.

    split.
    apply eprod_elem; split; apply eff_complete.
    exists m. exists n. split; auto.

    exists (exist _ X H4).
    split.
    hnf; simpl; intros.
    apply unmap_rel in H5.
    destruct H5 as [a' [c' [?[??]]]].
    apply H3 in H5.
    apply esubset_elem in H5.
    destruct H5.
    destruct H8 as [m [n [?[??]]]].
    exists m. exists n. split; auto.
    simpl in *.
    split.
    rewrite H9; auto.
    rewrite <- H10; auto.

    intros. destruct H9 as [?[?[?[??]]]].
    exists x. exists x0. intuition.
    rewrite H10. apply embed_mono.
    destruct H8 as [[??][??]]; auto.
    rewrite <- H11.
    apply embed_mono.
    destruct H8 as [[??][??]]; auto.

    split; hnf; simpl; intros.
    assert ((a0,b0) ∈ X) .
    apply H2. apply app_elem. auto.
    exists a0. exists b0.
    split; auto.
    assert ((a0,b0) ∈ X) .
    apply H2. apply app_elem. auto.
    exists a0. exists b0.
    split; auto.
  Qed.
End exp_functor.

Lemma exp_fmap_ident hf (A B:ob (EMBED hf)) (f:A⇀A) (g:B⇀B) :
  f ≈ id -> g ≈ id ->
  exp_fmap hf A A B B f g ≈ id.
Proof.
  intros.
  apply embed_lift'. intro.
  simpl.
  unfold exp_fmap_func. destruct x; simpl.
  split; hnf; simpl; intros.
  apply unmap_rel in H1.
  destruct H1 as [p [q [?[??]]]].
  exists p. exists q. split; auto.
  split. rewrite <- H2.
  rewrite H. simpl. auto.
  rewrite <- H3. rewrite H0. simpl; auto.
  exists (f a). exists (g b).
  split; auto.
  apply map_rel_in; auto.
  split.
  rewrite H. simpl; auto.
  rewrite H0. simpl; auto.
Qed.

Lemma exp_fmap_compose hf (A B C D E F:ob (EMBED hf))
  (f1:B → E) (f2:D → F)
  (g1:A → B) (g2:C → D)
  (h1:A → E) (h2:C → F) :
  f1 ∘ g1 ≈ h1 ->
  f2 ∘ g2 ≈ h2 ->
  exp_fmap hf B E D F f1 f2 ∘ exp_fmap hf A B C D g1 g2 ≈
    exp_fmap hf A E C F h1 h2.
Proof.
  intros.
  apply embed_lift'. intro.
  simpl.
  unfold exp_fmap_func. destruct x; simpl.
  split; hnf; simpl; intros.
  apply unmap_rel in H1.
  destruct H1 as [p [q [?[??]]]].
  apply unmap_rel in H1.
  destruct H1 as [p' [q' [?[??]]]].
  exists (h1 p'). exists (h2 q').
  split.
  apply map_rel_in. auto.
  rewrite <- H. rewrite <- H0.
  split; simpl; auto.
  rewrite <- H2. rewrite <- H4. auto.
  rewrite <- H3. rewrite <- H5. auto.

  apply unmap_rel in H1.
  destruct H1 as [p [q [?[??]]]].
  exists (f1 (g1 p)). exists (f2 (g2 q)).
  split.
  apply map_rel_in.
  apply map_rel_in. auto.
  split.
  rewrite <- H2. rewrite <- H. simpl; auto.
  rewrite <- H3. rewrite <- H0. simpl; auto.
Qed.

Lemma exp_fmap_respects hf (A B C D:ob (EMBED hf))
   (f f':A → B)
   (g g':C → D) :
   f ≈ f' -> g ≈ g' ->
   exp_fmap hf A B C D f g ≈ exp_fmap hf A B C D f' g'.
Proof.
  intros.
  apply embed_lift'. intro.
  simpl.
  unfold exp_fmap_func. destruct x; simpl.
  split; hnf; simpl; intros.
  apply unmap_rel in H1.
  destruct H1 as [p [q [?[??]]]].
  exists (f' p). exists (g' q).
  split.
  apply map_rel_in. auto.
  split.
  rewrite <- H2.
  rewrite H. auto.
  rewrite <- H3. rewrite H0. auto.

  apply unmap_rel in H1.
  destruct H1 as [p [q [?[??]]]].
  exists (f p). exists (g q).
  split.
  apply map_rel_in. auto.
  split. rewrite <- H2. rewrite H; auto.
  rewrite <- H3. rewrite H0. auto.
Qed.

Program Definition expF hf : functor (PROD (EMBED hf) (EMBED hf)) (EMBED hf) :=
    Functor (PROD (EMBED hf) (EMBED hf)) (EMBED hf)
      (fun X => (@PLT.exp hf
                   (@obl (EMBED hf) (EMBED hf) X)
                   (@obr (EMBED hf) (EMBED hf) X)))
      (fun (X Y:ob (PROD (EMBED hf) (EMBED hf))) fg =>
        exp_fmap hf (@obl (EMBED hf) (EMBED hf) X)
                    (@obl (EMBED hf) (EMBED hf) Y)
                    (@obr (EMBED hf) (EMBED hf) X)
                    (@obr (EMBED hf) (EMBED hf) Y)
                    (@homl (EMBED hf) (EMBED hf) X Y fg)
                    (@homr (EMBED hf) (EMBED hf) X Y fg))
      _ _ _.
Next Obligation.
  simpl; intros.
  destruct A as [A B]. destruct f as [f g]. simpl.
  destruct H. simpl in *.
  apply exp_fmap_ident; auto.
Qed.
Next Obligation.
  simpl; intros.
  destruct A as [A A'].
  destruct B as [B B'].
  destruct C as [C C']. simpl in *.
  destruct f as [f f'].
  destruct g as [g g'].
  destruct h as [h h']. simpl in *.
  destruct H; simpl in *.
  symmetry. apply exp_fmap_compose; auto.
Qed.
Next Obligation.
  simpl; intros.
  destruct A as [A A'].
  destruct B as [B B'].
  destruct f as [f f'].
  destruct g as [g g'].
  destruct H; simpl in *.
  apply exp_fmap_respects; auto.
Qed.

Section expF_decompose.
  Variable hf:bool.
  Variable I:directed_preord.
  Variables DS1 DS2 : directed_system I (EMBED hf).
  Variable CC1 : cocone DS1.
  Variable CC2 : cocone DS2.

  Hypothesis decompose1 : forall x:cocone_point CC1,
    { i:I & { a:ds_F DS1 i | cocone_spoke CC1 i a ≈ x }}.
  Hypothesis decompose2 : forall x:cocone_point CC2,
    { i:I & { a:ds_F DS2 i | cocone_spoke CC2 i a ≈ x }}.

  Lemma finrel_decompose
    (X:finset (PLT.ord (cocone_point CC1) × PLT.ord (cocone_point CC2))%cat_ob) :
    forall (Hinh : inh hf X),
    { k:I & { Y:finset (PLT.ord (ds_F DS1 k) × PLT.ord (ds_F DS2 k))%cat_ob |
       X ≈ map_rel (cocone_spoke CC1 k) (cocone_spoke CC2 k) Y }}.
  Proof.
    induction X; intros.
    destruct hf. hnf in Hinh.
    elimtype False. destruct Hinh. apply nil_elem in H. auto.
    destruct (choose_ub_set I nil).
    hnf. auto.
    exists x. exists nil. simpl; auto.
    case_eq X; intros.
    destruct a as [a b].
    destruct (decompose1 a) as [i [a' ?]].
    destruct (decompose2 b) as [j [b' ?]].
    destruct (choose_ub I i j) as [k [??]].
    exists k.
    exists ((ds_hom DS1 i k H0 a', ds_hom DS2 j k H1 b')::nil).
    simpl.
    apply finset_cons_eq; auto.
    cut (b ≈ cocone_spoke CC2 k (ds_hom DS2 j k H1 b')).
    cut (a ≈ cocone_spoke CC1 k (ds_hom DS1 i k H0 a')).
    intros [??] [??]; split; split; auto.
    rewrite <- e.
    rewrite (cocone_commute CC1 i k H0). auto.
    rewrite <- e0.
    rewrite (cocone_commute CC2 j k H1). auto.
    rewrite <- H.
    destruct IHX as [k [Y ?]].
    rewrite H.
    eapply elem_inh. apply cons_elem. eauto.
    destruct a as [p q]. simpl in *.
    destruct (decompose1 p) as [i [p' ?]].
    destruct (decompose2 q) as [j [q' ?]].
    destruct (choose_ub_set I (i::j::k::nil)) as [m ?].
    assert (i≤m).
    apply u. apply cons_elem; auto.
    assert (j≤m).
    apply u.
    apply cons_elem; right.
    apply cons_elem; auto.
    assert (k≤m).
    apply u.
    apply cons_elem; right.
    apply cons_elem; right.
    apply cons_elem; auto.
    set (Y' := map_rel (ds_hom DS1 k m H2) (ds_hom DS2 k m H2) Y).
    exists m.
    exists ((ds_hom DS1 i m H0 p', ds_hom DS2 j m H1 q')::Y').
    simpl.
    apply finset_cons_eq; auto.
    cut (cocone_spoke CC2 m (ds_hom DS2 j m H1 q') ≈ q).
    cut (cocone_spoke CC1 m (ds_hom DS1 i m H0 p') ≈ p).
    intros [??] [??]; split; split; auto.
    rewrite <- e0.
    rewrite (cocone_commute CC1 i m H0). auto.
    rewrite <- e1.
    rewrite (cocone_commute CC2 j m H1). auto.
    rewrite e.
    unfold Y'.
    clear. induction Y; simpl; auto.
    destruct a as [a b]. simpl.
    apply finset_cons_eq; auto.
    split; split; simpl.
    rewrite (cocone_commute CC1 k m H2). auto.
    rewrite (cocone_commute CC2 k m H2). auto.
    rewrite (cocone_commute CC1 k m H2). auto.
    rewrite (cocone_commute CC2 k m H2). auto.
  Qed.
End expF_decompose.

Lemma expF_continuous hf : continuous_functor (expF hf).
Proof.
  repeat intro.
  apply decompose_is_colimit.
  simpl. intros.
  destruct x as [x Hx].
  set (DS1 := dir_sys_app DS (fstF _ _)).
  set (DS2 := dir_sys_app DS (sndF _ _)).
  set (CC1 := cocone_app CC (fstF _ _)).
  set (CC2 := cocone_app CC (sndF _ _)).
  destruct (finrel_decompose hf I DS1 DS2 CC1 CC2) with x
    as [k [x' ?]].
  apply colimit_decompose. apply fstF_continuous. auto.
  apply colimit_decompose. apply sndF_continuous. auto.
  destruct Hx; auto.
  exists k.
  assert (is_joinable_relation hf x').
  apply (is_joinable_unmap_rel hf _ _ _ _
    (cocone_spoke CC1 k) (cocone_spoke CC2 k) x').
  split; intros.
  eapply inh_eq. apply e.
  destruct Hx; auto.
  destruct Hx.
  destruct (H2 G) with x0 as [y [??]]; auto.
  rewrite e; auto.
  exists y; split; auto.
  destruct e. apply H5; auto.
  exists (exist _ x' H).
  simpl.
  split; hnf; simpl; intros.
  destruct e. apply H2 in H0.
  exists a. exists b. auto.
  destruct e. apply H1 in H0.
  exists a. exists b. auto.
Qed.


From mathcomp Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat seq eqtype order.
From ipcssr Require Import prelude avlmap forms derivations normal_forms kripke_trees
                           in_ngamma forces_ngamma le_ks derivable_def.

Section NMinimal.
Context {disp : unit} {A : orderType disp}.

Definition nminimal (work : seq (normal_form A)) (ds : seq (disj A)) (ni : seq (nested_imp A))
                    (ai : atomic_imps A) (a : atoms A) (ctx : seq (form A)) :=
  forall k, Is_Monotone_kripke_tree k ->
    forces_ngamma work ds ni ai a k -> {in ctx, forall c, forces_t k c}.

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

Lemma nminimal_derivable_forces work ds ni ai a ctx k :
  Is_Monotone_kripke_tree k ->
  forces_ngamma work ds ni ai a k ->
  nminimal work ds ni ai a ctx ->
  forall c, Derivable ctx c -> forces_t k c.
Proof.
move=>M F N c; case=>t D.
by apply/(soundness_t _ _ _ D _ M)/N.
Qed.

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

Lemma nminimal_eqv work ds ni1 ni2 ai a ctx :
  eqv_ni ni1 ni2 ->
  nminimal work ds ni1 ai a ctx -> nminimal work ds ni2 ai a ctx.
Proof.
rewrite /nminimal=>E NM k M F.
by apply: NM=>//; apply/forces_ngamma_eqv/F.
Qed.

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

Lemma nminimal_shift_work_ds i j work ds ni ai a ctx :
  nminimal (NDisj i j :: work) ds ni ai a ctx ->
  nminimal work ((i, j) :: ds) ni ai a ctx.
Proof.
rewrite /nminimal=>NM k M F.
by apply: NM=>//; apply: forces_ngamma_shift_ds_work.
Qed.

Lemma nminimal_shift_work_ni x work ds ni ai a ctx :
  nminimal (NImp_NF (nested_imp2nimp x) :: work) ds ni ai a ctx ->
  nminimal work ds (x :: ni) ai a ctx.
Proof.
rewrite /nminimal=>NM k M F.
by apply: NM=>//; apply: forces_ngamma_shift_ni_work.
Qed.

Lemma nminimal_shift_work_ai i b work ds ni ai a ctx :
  invariant ai ->
  nminimal (AImp i b :: work) ds ni ai a ctx ->
  nminimal work ds ni (update_aimps b i ai).1 a ctx.
Proof.
rewrite /nminimal=>Ha NM k M F.
by apply: NM=>//; apply: forces_ngamma_shift_ai_work.
Qed.

(*
Lemma nminimal_shift_work_ai_new i b work ds ni ai a ctx :
  invariant ai -> ~~ lookup ai i ->
  nminimal (AImp i b :: work) ds ni ai a ctx ->
  nminimal work ds ni (update_aimps b i ai) a ctx.
Proof.
rewrite /nminimal=>Ha L NM k M F.
by apply: NM=>//; apply: forces_ngamma_shift_ai_work_new.
Qed.

Lemma nminimal_shift_work_ai_old i b work ds ni ai a ctx :
  invariant ai -> lookup ai i ->
  nminimal (AImp i b :: work) ds ni ai a ctx ->
  nminimal work ds ni (update_aimps b i ai) a ctx.
Proof.
rewrite /nminimal=>Ha L NM k M F.
by apply: NM=>//; apply: forces_ngamma_shift_ai_work_old.
Qed.
*)

Lemma nminimal_shift_work_a i work ds ni ai a ctx :
  invariant a ->
  nminimal (NAtom i :: work) ds ni ai a ctx ->
  nminimal work ds ni ai (update_atoms i a).1 ctx.
Proof.
rewrite /nminimal=>Ha NM k M F.
by apply: NM=>//; apply: forces_ngamma_shift_a_work.
Qed.

Lemma nminimal_shift_work_ni_x_ni x work ds ni1 ni2 ai a ctx :
  nminimal (NImp_NF (nested_imp2nimp x) :: work) ds (ni1 ++ ni2) ai a ctx ->
  nminimal work ds (ni1 ++ x :: ni2) ai a ctx.
Proof.
rewrite /nminimal=>NM k M F.
by apply: NM=>//; apply: forces_ngamma_shift_ni_x_ni_work.
Qed.

Lemma nminimal_shift_ni_x_ni_work x work ds ni1 ni2 ai a ctx :
  nminimal work ds (ni1 ++ x :: ni2) ai a ctx ->
  nminimal (NImp_NF (nested_imp2nimp x) :: work) ds (ni1 ++ ni2) ai a ctx.
Proof.
rewrite /nminimal=>NM k M F.
by apply: NM=>//; apply: forces_ngamma_shift_work_ni_x_ni.
Qed.

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

Lemma nminimal_cons_work_strength b c work ds ni ai a ctx :
  (forall k, Is_Monotone_kripke_tree k ->
   forces_ngamma (c :: work) ds ni ai a k -> forces_t k (nf2form b)) ->
  nminimal (b :: work) ds ni ai a ctx ->
  nminimal (c :: work) ds ni ai a ctx.
Proof.
rewrite /nminimal=>H NM k M F.
apply: NM=>//; apply: (forces_ngamma_cons_work_weak c)=>// F'.
by apply: H.
Qed.

Lemma nminimal_cons_work_weak b c work ds ni ai a ctx :
  (forall k, Is_Monotone_kripke_tree k ->
   forces_t k (nf2form c) -> forces_t k (nf2form b)) ->
  nminimal (b :: work) ds ni ai a ctx ->
  nminimal (c :: work) ds ni ai a ctx.
Proof.
rewrite /nminimal=>H NM k M F.
apply: NM=>//; apply: (forces_ngamma_cons_work_weak c)=>// F'.
by apply: H.
Qed.

Lemma nminimal_shift_work_ai_weak i bs work ds ni ai a ctx :
  invariant ai -> lookup ai i = Some bs ->
  nminimal work ds ni ai a ctx ->
  nminimal (bs ++ work) ds ni (delete i ai).1 a ctx.
Proof.
rewrite /nminimal=>Ha L NM k M F.
apply: NM=>//; apply: (forces_ngamma_del_ai_rev i bs)=>//.
- move=>n b E; rewrite /nf2form -/nf2form.
  apply: forces_imp_t=>//; apply/F/(In_Work _ _ _ _ _ n).
  by rewrite onth_cat (onth_size E).
by apply: (forces_ngamma_cat_work_tail bs).
Qed.

Lemma nminimal_shift_ds_work_ctx work c i j ds ni ai a ctx :
  (forall k, Is_Monotone_kripke_tree k ->
   forces_t k (nf2form c) -> forces_t k (OrF (Atom i) (Atom j))) ->
  nminimal work ((i, j) :: ds) ni ai a ctx ->
  nminimal (c :: work) ds ni ai a (nf2form c :: ctx).
Proof.
rewrite /nminimal=>H NM k M F d; rewrite inE; case/orP=>[/eqP{d}->|Hd].
- by apply/F/in_ngamma_cons_work_head.
apply: NM=>//; apply/forces_ngamma_shift_work_ds.
apply/(forces_ngamma_cons_work_weak c)=>// Fc.
by rewrite /nf2form -/nf2form; apply: H.
Qed.

Lemma nminimal_cons_work_cons_ctx c work ds ni ai a ctx :
  nminimal work ds ni ai a ctx ->
  nminimal (c :: work) ds ni ai a (nf2form c :: ctx).
Proof.
rewrite /nminimal=>NM k M F d; rewrite inE; case/orP=>[/eqP{d}->|Hd].
- by apply/F/in_ngamma_cons_work_head.
by apply: NM=>//; apply/(forces_ngamma_cons_work_tail c).
Qed.

End NMinimal.


Require Import Base.
Require Import FlowEquivalence.
Require Import RiseDecoupled.
Import FE_Tactics.
Require Import List.
Import ListNotations.
Open Scope list_scope.

Require Import Omega.

Require Import PeanoNat.

Existing Instance event_eq_dec.
Existing Instance latch_eq_dec.

Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Equality.

(** * Definition of semi-decoupled marked graph *)
Section SemiDecoupled.

  Context (even odd : Set).
  Context `{Heven : eq_dec even} `{Hodd : eq_dec odd}.
  Variable c : circuit even odd.
  Variable init_st : state (latch even odd).

  Inductive sd_place : event even odd -> event even odd -> Set :=
  | SD_latch_fall l : sd_place (Rise l) (Fall l)
  | SD_latch_rise l : sd_place (Fall l) (Rise l)
  (* E- → O- for (E,O) *)
  (* O- → E- for (O,E) *)
  | SD_neighbor_fall_fall l l' : neighbor c l l' ->
                                 sd_place (Fall l) (Fall l')
  (* O+ → E+ for (O,E) *)
  (* E+ → O+ for (E,O) *)
  | SD_neighbor_rise_rise l l' : neighbor c l l' ->
                                 sd_place (Rise l) (Rise l')

  (* l'- → l+ for (l,l') *)
  | SD_neighbor_fall_rise l l' : neighbor c l l' ->
                                 sd_place (Fall l') (Rise l)
  .

  Definition semi_decoupled : marked_graph (event even odd) :=
    {| place := sd_place
     ; init_marking := fun t1 t2 p => match p with
                                      | SD_latch_fall (Odd _) => 1
                                      | SD_latch_rise (Even _) => 1
                                      | SD_neighbor_rise_rise (Odd _) (Even _) _ => 1
                                      | SD_neighbor_fall_fall (Even _) (Odd _) _ => 1
                                      | _ => 0
                                      end
    |}.

  Open Scope nat_scope.

  (** * Specialized is_enabled predicate *)
  Inductive is_enabled_SD : event even odd -> marking semi_decoupled -> Prop :=
  | fall_enabled_SD l (m : marking semi_decoupled) :
    0 < m _ _ (SD_latch_fall l) ->
    (forall l0 (pf : neighbor c l0 l),
        0 < m _ _ (SD_neighbor_fall_fall l0 l pf)) ->
    is_enabled_SD (Fall l) m

  | rise_enabled_SD l (m : marking semi_decoupled) :
    0 < m _ _ (SD_latch_rise l) ->
    (forall l' (pf : neighbor c l l'),
        0 < m _ _ (SD_neighbor_fall_rise l l' pf)) ->
    (forall l0 (pf : neighbor c l0 l),
        0 < m _ _ (SD_neighbor_rise_rise l0 l pf)) ->
    is_enabled_SD (Rise l) m
  .
  Lemma SD_is_enabled_equiv : forall e m,
    is_enabled_SD e m -> is_enabled semi_decoupled e m.
  Proof.
    destruct e as [l | l];
      intros m; inversion 1; subst;
      intros e0 p;
      simpl in p;
      dependent destruction p;
      auto.
  Qed.

  Lemma is_enabled_SD_equiv : forall e m,
    is_enabled semi_decoupled e m ->
    is_enabled_SD e m.
  Proof.
    intros e m Henabled.
    unfold is_enabled in *.
    destruct e as [l | l];
      constructor; intros; apply Henabled; eexists; try (econstructor; eauto; fail).
  Qed.

Arguments path_cost {transition M t1 t2}.

  Lemma sd_loop : forall t m,
    {semi_decoupled}⊢ t ↓ m ->
    forall l,
    m _ _ (SD_latch_fall l) + m _ _ (SD_latch_rise l) = 1.
  Proof.
    intros t m Ht l.
    solve_loop. destruct l; auto.
  Qed.

End SemiDecoupled.

About SD_latch_fall.
Print sd_place.
  Arguments SD_latch_fall {even odd}.
  Arguments SD_latch_rise {even odd}.
  Arguments SD_neighbor_fall_fall {even odd}.
  Arguments SD_neighbor_rise_rise {even odd}.
  Arguments SD_neighbor_fall_rise {even odd}.

  Arguments latch_fall {even odd}.
  Arguments latch_rise {even odd}.
  Arguments neighbor_fall_fall {even odd}.
  Arguments neighbor_fall_rise {even odd}.

  Arguments semi_decoupled {even odd}.

  Ltac get_enabled_constraints :=
    try match goal with
    | [ H : is_enabled (semi_decoupled _) _ _ |- _ ] =>
      apply is_enabled_SD_equiv in H; inversion H; subst
    end;
    specialize_enabled_constraints.

Section SD_RD_relate.

  Context (even odd : Set).
  Context `{Heven : eq_dec even} `{Hodd : eq_dec odd}.
  Variable c : circuit even odd.
  Variable init_st : state (latch even odd).

Print sd_place.
  Inductive SD_RD :
        forall {e1 e2}, place (semi_decoupled c) e1 e2 ->
        forall {e1' e2'}, place (rise_decoupled c) e1' e2' -> Prop :=
  | SD_RD_fall l : SD_RD (SD_latch_fall c l) (latch_fall c l)
  | SD_RD_rise l : SD_RD (SD_latch_rise c l) (latch_rise c l)
  | SD_RD_fall_rise l l' pf :
    SD_RD (SD_neighbor_fall_rise c l l' pf) (neighbor_fall_rise c l l' pf)
  | SD_RD_fall_fall l l' pf :
    SD_RD (SD_neighbor_fall_fall c l l' pf) (neighbor_fall_fall c l l' pf)
  .

  Lemma SD_RD_enabled_equiv : forall t m m' e1 e2 (p : place _ e1 e2)
                                            e1' e2' (p' : place _ e1' e2'),
    {semi_decoupled c}⊢ t ↓ m ->
    {rise_decoupled c}⊢ t ↓ m' ->
    SD_RD p p' ->
    m _ _ p = m' _ _ p'.
  Proof.
    induction t; intros m m' e1 e2 p e1' e2' p' Hm Hm' Hrel.
    * inversion Hm; inversion Hm'; subst.
      dependent destruction Hrel; auto.

    * dependent destruction Hm.
      dependent destruction Hm'.
      unfold fire.

      dependent destruction Hrel;
        simpl;
        repeat (compare_next; erewrite IHt; eauto; constructor; fail).
Qed.

  Lemma semi_decoupled_refines_rise_decoupled : forall t m,
    { semi_decoupled c }⊢ t ↓ m ->
    exists m', (({rise_decoupled c}⊢ t ↓ m')).
  Proof.
    intros t m Ht.
    induction Ht.
    * eexists. econstructor.
    * subst.
      destruct IHHt as [m' IHHt].
      eexists. econstructor; eauto.

      apply is_enabled_SD_equiv in H. inversion H; subst.

      + apply RD_is_enabled_equiv.
        constructor.
        ++ erewrite <- SD_RD_enabled_equiv; [ | eauto | eauto | constructor ].
           auto.
        ++ intros l' pf.
           erewrite <- SD_RD_enabled_equiv; [ | eauto | eauto | constructor ].
           auto.
      + apply RD_is_enabled_equiv.
        constructor.
        ++ erewrite <- SD_RD_enabled_equiv; [ | eauto | eauto | constructor ].
           auto.
        ++ intros l' pf.
           erewrite <- SD_RD_enabled_equiv; [ | eauto | eauto | constructor ].
           auto.
  Qed.

  (** * Flow equivalence proof *)
  Theorem semi_decoupled_flow_equivalence :
    flow_equivalence (semi_decoupled c) c init_st.
  Proof.
    intros l t v [m Hm] Hrel.
    apply rise_decoupled_flow_equivalence; auto.
    eapply semi_decoupled_refines_rise_decoupled; eauto.
  Qed.


(*Require Import Plug.*)
Require Export List SetoidList Bool Setoid Program Recdef ZArith.
Require Export Sets SetProperties Generate SetConstructs.

Notation "[]" := (@nil _).

(* begin hide *)
Section ListExtra.

  Variable A : Type.

  Fixpoint list_pow (x:list A)(n:nat) :=
    match n with
      | O => nil
      | S n => app x (list_pow x n)
    end.

End ListExtra.
(** end hide *)

(** Usefull (and naive) tactics. *)

Ltac destruct2 G H :=
  destruct G;destruct H.

Ltac apply_comp G H I :=
  apply G in H ; apply H in I.

Ltac apply2 G H I :=
  apply G in H;apply G in I.

Ltac apply_mem G H :=
  let K := fresh in
    generalize H;intro K;
      apply G in H.

Ltac apply2_mem G H I :=
  apply_mem G H ; apply_mem G I.

Ltac inv H :=
  inversion H;subst;try congruence.

Ltac invc H :=
  inversion_clear H;try congruence.

(** * Definition of sets as characteristic predicates. *)
(** These definitions are verbatim copied from the library Ensembles. We copy the definitions here
in order to get rid of the annoying extraction warning about the axiom of set extensionality. *)

Section SetsProp.

  Variable U : Type.

  Definition Ensemble := U -> Prop.

  Definition In (A:Ensemble) (x:U) : Prop := A x.

  Definition Included (B C:Ensemble) : Prop := forall x:U, In B x -> In C x.

  Inductive Empty_set : Ensemble :=.

  Inductive Singleton (x:U) : Ensemble :=
    In_singleton : In (Singleton x) x.

  Inductive Union (B C:Ensemble) : Ensemble :=
    | Union_introl : forall x:U, In B x -> In (Union B C) x
    | Union_intror : forall x:U, In C x -> In (Union B C) x.

  Definition Same_set (B C:Ensemble) : Prop := Included B C /\ Included C B.

End SetsProp.

(** Some simplifications for Booleans. *)

Ltac simpl_bool :=
  match goal with
    | H: ?x || ?y = true  |- _ => apply orb_true_iff in H
    | H: ?x && ?y = true  |- _ => apply andb_true_iff in H
    | H: ?x || ?y = false |- _ => apply orb_false_iff in H
    | H: ?x && ?y = false |- _ => apply andb_false_iff in H
    | |- ?x || ?y = true  => apply orb_true_iff
    | |- ?x && ?y = true  => apply andb_true_iff
    | |- ?x || ?y = false => apply orb_false_iff
    | |- ?x && ?y = false =>apply andb_false_iff
  end.

Ltac simpl_bool_full := repeat simpl_bool.

Ltac autotc := auto with typeclass_instances.


(* (c) Copyright Christian Doczkal, Saarland University                   *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From CompDecModal.libs
 Require Import edone bcase fset base sltype.
From CompDecModal.K
 Require Import K_def demo gentzen.

Set Default Proof Using "Type".

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

(** * Construction of a Universal Model *)

Implicit Types (C D : clause).

#[export] Hint Resolve closed_sfc : core.

Lemma gen_decP C : reflect (gen C) (gen_dec C).
Proof. exact: sumboolP. Qed.

Lemma gen_lcons C : ~~ gen_dec C -> lcons C.
Proof. apply: contraTT. rewrite negbK => ?. apply/gen_decP. exact: lcons_gen. Qed.

(** Every underivable clause is supported by an underivable clause *)

Lemma genN_supp C : ~~ gen_dec C -> exists2 D:clause, suppC D C & ~~ gen_dec D.
Proof.
  move => H. suff: [some D in (S0 (sfc C)), suppC D C && ~~ gen_dec D].
  { case/hasP => D _ /andP [D1 D2]. by exists D. }
  apply/negPn. rewrite -all_predC. apply: contraNN H => /allP H. apply/gen_decP.
  apply: (ref_R0 (@closed_sfc C)); first by rewrite powersetE sub_sfc.
  move => D /sepP [D1 D2]. move : (H _ D1) => /=. rewrite negb_and D2.
  by case: (gen_dec _).
Qed.

Lemma sat_cons (M : cmodel) (w : M) C : (forall s, s \in C -> eval (interp s) w) -> ~~ gen_dec C.
Proof. move => H. apply/negP => /gen_decP/gen_correctness. apply. by exists M; exists w. Qed.

Section UniversalModel.
  Record dmodel := DM { dstate :> choiceType ;
                        dtrans : dstate -> dstate -> bool;
                        dlabel : var -> pred dstate;
                        dbound : dstate -> {fset dstate};
                        dtransP x y : dtrans x y -> y \in dbound x
                      }.

  Fixpoint evald (M : dmodel) s : pred M :=
      match s with
      | fV p => dlabel p
      | fF => xpred0
      | fImp s t => fun w => evald s w ==> evald t w
      | fAX s => fun w => [all v in dbound w, dtrans w v ==> evald s v]
      end.

  Definition ts_of_dmodel (M : dmodel) : ts :=
    {| state := dstate M;
       trans := @dtrans M ;
       label p x := @dlabel M p x |}.

  Lemma evaldP (M : dmodel) (x:M) s : reflect (@eval (ts_of_dmodel M) s x) (evald s x).
  Proof.
    elim: s x => //=.
    - by constructor.
    - move => * ; exact: idP.
    - move => s IHs t IHt w.
      apply: iffP (@implyP _ _) _ _ => ? /IHs ?; apply/IHt; firstorder.
    - move => s IHs w.
      apply: iffP (@all_inP _ _ _ _) _ _ => [H v wv|H v _ wv].
      + apply/IHs. apply: H => //. exact: dtransP.
      + apply/IHs. exact: H.
  Qed.

  Lemma dmodelP (M : dmodel) : ldec (@eval (ts_of_dmodel M)).
  Proof. move => s w. case: (boolP (evald s w)) => /evaldP; tauto. Qed.

  Definition model_of_dmodel (M : dmodel) : cmodel := CModel (@dmodelP M).

  Definition UMType := { C : clause | ~~ gen_dec C }.
  Definition UMLabel (p:var) (C : UMType) := fV p^+ \in val C.

  Lemma UM_default_proof : ~~ gen_dec fset0.
  Proof.
    pose M := FModel [rel x y : unit | false] (fun p => xpred0).
    apply: (@sat_cons M tt) => ?. by rewrite inE.
  Qed.

  Definition UM_default : UMType := Sub fset0 UM_default_proof.

  Lemma UMP s1 s2 C : s1 \in C -> ~~ gen_dec C -> s1 = fAX s2^- ->
     exists x:UMType, suppC (val x) (s2^- |` R C).
  Proof.
    move => inC inDD E. subst s1.
    suff S: ~~ gen_dec (s2^- |` R C). case: (genN_supp S) => D D1 D2. by exists (Sub D D2).
    apply: contraNN inDD => /gen_decP H. rewrite (fset1U inC). apply/gen_decP. by constructor.
  Qed.

  Definition UM_select (u : sform) (x:UMType) : UMType :=
    (if u \in val x as b return u \in val x = b -> UMType
     then fun b =>
            (if u is fAX s^- as c return u = c -> UMType
             then fun e => (xchoose (UMP b (valP x) e))
             else fun _ => UM_default) erefl
     else fun _ => UM_default) erefl.

  Lemma UM_select_correct (u : sform) (x : UMType) :
    u \in val x -> isDia u -> suppC (val (UM_select u x)) (body u |` R (val x)).
  Proof.
    move => in_x dia_u. rewrite /UM_select.
    move: (erefl (u \in val x)). rewrite {2 3}in_x => e.
    destruct u as [[|p|s t|s] [|]] => //.
    exact: (xchooseP (UMP e (valP x) (erefl _))).
  Qed.

  Definition UM_trans (x y : UMType) := [some u in val x, isDia u && (y == UM_select u x)].

  Definition UM_bound (x : UMType) := [fset UM_select u x | u <- [fset v in val x | isDia v]].

  Lemma UM_trans_bound x y : UM_trans x y -> y \in UM_bound x.
  Proof.
    case/hasP => s s1 /andP[s2 s3]. apply/fimsetP.
    exists s; last exact/eqP. by rewrite inE s1.
  Qed.

  Definition UMd := DM UMLabel UM_trans_bound.

  Definition UM : cmodel := model_of_dmodel UMd.

  Lemma UM_trans_R (x y : UM) : trans x y -> suppC (val y) (R (val x)).
  Proof.
    case/hasP => u u1 /andP [u2 /eqP ->].
    move: (UM_select_correct u1 u2). rewrite suppCU. by bcase.
  Qed.

  Lemma UM_trans_D (x : UM) s : fAX s^- \in val x -> exists2 y : UM, trans x y & val y |> s^-.
  Proof.
    move => H. exists (UM_select (fAX s^-) x).
    - apply/hasP. by exists (fAX s^-) => //=.
    - move: (UM_select_correct H (erefl _)). by rewrite suppCU suppC1 /=; bcase.
  Qed.

  Lemma supp_eval s (x : UM) : val x |> s -> eval (interp s) x.
  Proof.
    case: s x. elim => [|p|s IHs t IHt|s IHs] [|] x.
    - by rewrite /= (LCF (gen_lcons (valP x))).
    - by rewrite /=.
    - done.
    - rewrite /= /UMLabel. case: (LCF (gen_lcons (valP x))) => [_ /(_ p)].
      by case: (_^+ \in _) => //= ->.
    - rewrite /=. case/orP => [/IHs|/IHt] /=; tauto.
    - rewrite /=. case/andP => [/IHs ? /IHt] /=; tauto.
    - move => inX y xy. apply: (IHs true).
      rewrite -suppC1. apply: suppC_sub (UM_trans_R xy). by rewrite fsub1 RE.
    - rewrite [_ |> _]/= => H. case: (UM_trans_D H) => y xy Hy.
      move/(_ y xy). exact: (IHs false).
  Qed.

  Theorem UM_universal s :
    (exists (M:cmodel) (w:M), eval s w) -> (exists (x:UM), eval s x).
  Proof.
    pose C := [fset s^+].
    move => [M] [w Hw].
    have: ~~ gen_dec C. apply: (@sat_cons M w) => ?. by rewrite in_fset1 => /eqP->.
    case/genN_supp => D /allP D1 D2. exists (Sub D D2).
    rewrite -[s]/(interp (s^+)). apply: supp_eval. apply: D1. exact: fset11.
  Qed.
End UniversalModel.


Require Import stdpp.list.
From Tweetnacl Require Export Libs.Lists_extended.
From Tweetnacl Require Import Libs.LibTactics.

Lemma Forall_nth_d: forall A (l:list A) (P:A -> Prop) d,
  P d ->
  Forall P l ->
    forall i, P (nth i l d).
Proof.
  intros A l P d Hd Hl.
  induction l ; destruct i ; inv Hl ; go.
Qed.

Lemma Forall_nth_len: forall A (l:list A) (P:A -> Prop) d,
  Forall P l ->
    forall i, i < length l ->
      P (nth i l d).
Proof.
  intros A l P d Hl.
  induction l; intros i Hi.
  - simpl in Hi.
    inv Hi.
  - destruct i; inv Hl ; go.
Qed.

Lemma nth_Forall: forall A (l: list A) (P:A -> Prop) d,
  (forall i, P (nth i l d)) ->
    Forall P l.
Proof.
  induction l ; go.
  intros P d Hnth ; apply Forall_cons_2.
  apply (Hnth 0).
  eapply IHl.
  intros i.
  apply (Hnth (S i)).
Qed.

Lemma upd_nth_Forall: forall i A (l:list A) (P: A -> Prop) v,
  Forall P l -> P v ->
  Forall P (upd_nth i l v).
Proof.
  induction i => A [|h q] P v Hl Hv ; simpl;
  try solve[apply Forall_cons_2 ; go];
  apply Forall_cons in Hl ; destruct Hl as [Ha Hl] ; apply Forall_cons_2 ; go.
Qed.

Lemma Forall_take_n_m : forall m n A (l:list A) (P: A -> Prop),
  n <= m ->
  Forall P (take m l) -> Forall P (take n l).
Proof.
induction m ; intros.
inv H.
rewrite firstn_O ; apply Forall_nil_2.
destruct n.
rewrite firstn_O ; apply Forall_nil_2.
destruct l.
simpl ; apply Forall_nil_2.
simpl.
simpl in H0.
apply Forall_cons in H0 ; destruct H0.
apply Forall_cons_2 ; go.
Qed.

Open Scope Z.

Lemma Forall_bounds_le_lt: forall a b l,
  Forall (fun x => a < x < b) l ->
    Forall (fun x => a <= x <= b) l.
Proof. intros; eapply Forall_impl ; eauto ; intros ; go. Qed.

Close Scope Z.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 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: Vincent Rahli

*)

Require Export computation2.
Require Export soterms.

Fixpoint compute_atmost_k_steps {o}
         (lib : library)
         (k   : nat)
         (t   : @NTerm o) : NTerm :=
  match k with
    | 0 => t
    | S n =>
      match compute_step lib t with
      | csuccess u => compute_atmost_k_steps lib n u
      | cfailure _ _ => t
      end
  end.

Lemma reduces_atmost_k_steps_of_compute_atmost_k_steps {o} :
  forall lib k (t : @NTerm o),
    {n : nat
     & n <= k
     # reduces_in_atmost_k_steps lib t (compute_atmost_k_steps lib k t) n}.
Proof.
  induction k; introv; simpl.

  - exists 0; dands; auto.
    rw @reduces_in_atmost_k_steps_0; auto.

  - remember (compute_step lib t) as comp; symmetry in Heqcomp.
    destruct comp as [u|].

    + pose proof (IHk u) as h; clear IHk; exrepnd.
      exists (S n); dands; auto; try omega.
      rw @reduces_in_atmost_k_steps_S; allrw.
      eexists; dands; eauto.

    + exists 0; dands; try omega.
      rw @reduces_in_atmost_k_steps_0; auto.
Qed.

Lemma reduces_to_of_compute_atmost_k_steps {o} :
  forall lib k (t : @NTerm o),
    reduces_to lib t (compute_atmost_k_steps lib k t).
Proof.
  introv.
  pose proof (reduces_atmost_k_steps_of_compute_atmost_k_steps lib k t) as q; exrepnd.
  exists n; auto.
Qed.

Definition opabs_member : opabs := Build_opabs "member" [] [0,0].

(* It would be better if the proof was just eq_refl *)
Lemma opabs_member_correct {o} :
  @correct_abs
    o
    opabs_member
    [(nvart, 0), (nvarT, 0)]
    (mk_so_equality (sovar nvart []) (sovar nvart []) (sovar nvarT [])).
Proof.
  exact (eq_refl, (eq_refl, (eq_refl, (eq_refl, eq_refl)))).
Qed.

Definition mk_abs {o} abs (l : list (@BTerm o)) : NTerm := oterm (Abs abs) l.

Time Eval compute in (compute_atmost_k_steps
                        [lib_abs
                           opabs_member
                           [(nvart, 0), (nvarT, 0)]
                           (mk_so_equality (sovar nvart []) (sovar nvart []) (sovar nvarT []))
                           opabs_member_correct]
                        1
                        (mk_abs opabs_member [nobnd (mk_var (nvar "t")), nobnd (mk_var (nvar "T"))])).


Require Import GHC.Base.
Require Import Data.Foldable.

Require Import Proofs.GHC.Base.
Require Import Proofs.GHC.List.
Require Import Coq.Classes.RelationClasses.

Set Warnings "-notation-overridden".

From Coq Require Import ssreflect.
Set Bullet Behavior "Strict Subproofs".

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

(* Laws *)

Class FoldableLaws {t} `{Foldable t} := {
(*  foldr_foldMap : forall f z t, foldr f z t = appEndo (foldMap (Mk_Endo ∘ f) t ) z;
  foldl_foldMap : forall f z t,
     foldl f z t = appEndo (getDual (foldMap (Mk_Dual ∘ Mk_Endo ∘ flip f) t)) z;
  foldMap_id : forall a `{Monoid a}, @fold t _ a = foldMap id *)
}.

Class FoldableFunctor {t} `{Foldable t} `{Functor t} := {
  foldfmap : forall a b (f : a -> b)`{Monoid b}, foldMap f = fold ∘ fmap f;
}.

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

(* Haskell-Coq equivalence *)

Require Coq.Lists.List.
Require Import Coq.ZArith.ZArith.

Theorem hs_coq_length_list {A} (l : list A) :
  length l = Zlength l.
Proof. apply hs_coq_list_length. Qed.

Theorem hs_coq_length_list' {A} (l : list A) :
  Data.Foldable.Foldable__list_length l = Zlength l.
Proof. apply hs_coq_length_list. Qed.

Theorem hs_coq_foldr_list {A B} (f : A -> B -> B) (z : B) (l : list A) :
  foldr f z l = Coq.Lists.List.fold_right f z l.
Proof. by rewrite ->hs_coq_foldr_base. Qed.

Theorem hs_coq_foldr_list' {A B} (f : A -> B -> B) (z : B) (l : list A) :
  Data.Foldable.Foldable__list_foldr f z l = Coq.Lists.List.fold_right f z l.
Proof. apply hs_coq_foldr_list. Qed.

Theorem hs_coq_foldl_list {A B} (f : B -> A -> B) (z : B) (l : list A) :
  foldl f z l = Coq.Lists.List.fold_left f l z.
Proof. apply hs_coq_foldl_base. Qed.

Theorem hs_coq_foldl'_list {A B} (f : B -> A -> B) (z : B) (l : list A) :
  foldl' f z l = Coq.Lists.List.fold_left f l z.
Proof. apply hs_coq_foldl_base. Qed.

Theorem hs_coq_foldl_list' {A B} (f : B -> A -> B) (z : B) (l : list A) :
  Data.Foldable.Foldable__list_foldl f z l = Coq.Lists.List.fold_left f l z.
Proof. apply hs_coq_foldl_list. Qed.

(* -------------------------------------------------------------------- *)
(** ** Theory about foldable for lists *)

Ltac unfold_Foldable_foldr :=
  unfold Foldable.foldr,
  Foldable.foldr__,
  Foldable.Foldable__list,
  Foldable.Foldable__list_foldr.

Ltac unfold_Foldable_foldl' :=
  unfold Foldable.foldl',  Foldable.Foldable__list,
  Foldable.foldl'__, Foldable.Foldable__list_foldl', Base.foldl'.

Ltac unfold_Foldable_foldl :=
  unfold Foldable.foldl,  Foldable.Foldable__list,
  Foldable.foldl__, Foldable.Foldable__list_foldl, Base.foldl.

Lemma Foldable_foldr_nil : forall a b (f: a -> b -> b) (s:b),
    Foldable.foldr f s nil = s.
Proof.
  unfold_Foldable_foldr.
  simpl.
  auto.
Qed.

Lemma Foldable_foldr_cons : forall a b (f: a -> b -> b) (s:b) x xs,
    Foldable.foldr f s (x :: xs) = f x (Foldable.foldr f s xs).
Proof.
  unfold_Foldable_foldr.
  simpl.
  auto.
Qed.

Lemma Foldable_foldr_app : forall a b (f:a -> b -> b) (s:b)
                              (vs1 : list a) (vs2: list a),
    Foldable.foldr f s (vs1 ++ vs2) =
    Foldable.foldr f (Foldable.foldr f s vs2) vs1.
Proof.
  intros.
  unfold_Foldable_foldr.
  rewrite hs_coq_foldr_base.
  rewrite fold_right_app.
  auto.
Qed.

Lemma Foldable_foldl_nil : forall a b (f: b -> a -> b) (s:b),
    Foldable.foldl f s nil = s.
Proof.
  unfold_Foldable_foldl.
  simpl.
  auto.
Qed.

Lemma Foldable_foldl_cons : forall a b (f: b -> a -> b) (s:b) x xs,
    Foldable.foldl f s (x :: xs) = (Foldable.foldl f (f s x) xs).
Proof.
  intros.
  unfold_Foldable_foldl.
  simpl.
  auto.
Qed.

Lemma Foldable_foldl_app : forall a b (f:b -> a -> b) (s:b)
                              (vs1 : list a) (vs2: list a),
    Foldable.foldl f s (vs1 ++ vs2) =
    Foldable.foldl f (Foldable.foldl f s vs1) vs2.
Proof.
  unfold_Foldable_foldl.
  intros.
  repeat rewrite <- List_foldl_foldr.
  rewrite fold_left_app.
  auto.
Qed.

Lemma Foldable_foldl'_nil : forall a b (f: b -> a -> b) (s:b),
    Foldable.foldl' f s nil = s.
Proof.
  unfold_Foldable_foldl'.
  simpl.
  auto.
Qed.

Lemma Foldable_foldl'_cons : forall a b (f: b -> a -> b) (s:b) x xs,
    Foldable.foldl' f s (x :: xs) = (Foldable.foldl' f (f s x) xs).
Proof.
  intros.
  unfold_Foldable_foldl'.
  simpl.
  auto.
Qed.

Lemma Foldable_foldl'_app : forall a b (f:b -> a -> b) (s:b)
                              (vs1 : list a) (vs2: list a),
    Foldable.foldl' f s (vs1 ++ vs2) =
    Foldable.foldl' f (Foldable.foldl' f s vs1) vs2.
Proof.
  unfold_Foldable_foldl'.
  intros.
  repeat rewrite <- List_foldl_foldr.
  rewrite fold_left_app.
  auto.
Qed.

Hint Rewrite
     Foldable_foldl'_nil Foldable_foldr_nil
     Foldable_foldl_nil

     Foldable_foldl'_cons Foldable_foldr_cons
     Foldable_foldl_cons

     Foldable_foldl'_app Foldable_foldr_app
     Foldable_foldl_app : hs_simpl.

Lemma Foldable_foldr_map {a}{b}{c:Type} g (f: a -> c) (xs : list a) (b0 : b):
 Foldable.foldr (g ∘ f) b0 xs =
 Foldable.foldr g b0 (List.map f xs).
Proof.
  elim: xs => [|x xs IH].
  - hs_simpl. auto.
  - hs_simpl. unfold Base.op_z2218U__ in *.
    rewrite map_cons.
    hs_simpl.
    f_equal.
    auto.
Qed.

Lemma Foldable_any_nil : forall A (f : A -> bool), Foldable.any f nil = false.
Proof.
  intros.
  unfold Foldable.any.
  unfold compose, Foldable.foldMap.
  unfold Foldable.Foldable__list,Foldable.foldMap__,
         Foldable.Foldable__list_foldMap,
         Foldable.Foldable__list_foldr.
  simpl.
  auto.
Qed.

Lemma Foldable_any_cons : forall A x xs (f : A -> bool),
    Foldable.any f (x :: xs) = f x || Foldable.any f xs.
Proof.
  intros.
  unfold Foldable.any.
  unfold compose, Foldable.foldMap.
  unfold Foldable.Foldable__list,Foldable.foldMap__,
         Foldable.Foldable__list_foldMap,
         Foldable.Foldable__list_foldr.
  simpl.
  auto.
Qed.

Lemma Foldable_any_app : forall {A} `{Eq_ A} (v:A) (l1 l2:list A),
      Foldable.any (fun y : A => v == y) (l1 ++ l2) =
      Foldable.any (fun y : A => v == y) l1
      || Foldable.any (fun y : A => v == y) l2.
Proof.
  intros.
  unfold Foldable.any.
  unfold compose, Foldable.foldMap.
  unfold Foldable.Foldable__list,Foldable.foldMap__,
         Foldable.Foldable__list_foldMap,
         Foldable.Foldable__list_foldr.
  simpl.
  induction l1.
  + simpl. auto.
  + simpl.
    rewrite <- orb_assoc.
    f_equal.
    unfold SemigroupInternal.getAny.
    auto.
Qed.

Hint Rewrite @Foldable_any_nil @Foldable_any_cons @Foldable_any_app : hs_simpl.

Lemma elem_nil : forall {A} `{Eq_ A}  (x:A),
  Foldable.elem x nil = false.
Proof.
  intros.
  reflexivity.
Qed.

Lemma elem_cons :
  forall {A} `{Eq_ A} (v:A) (x:A) (l:list A),
    Foldable.elem v (x :: l) = (v == x) || Foldable.elem v l.
Proof.
  intros.
  apply Foldable_any_cons.
Qed.

Lemma Foldable_elem_app : forall {A}`{Eq_ A} (v:A) (l1 l2:list A),
    Foldable.elem v (l1 ++ l2) = Foldable.elem v l1 || Foldable.elem v l2.
Proof.
  intros. apply Foldable_any_app.
Qed.

Hint Rewrite @elem_nil @elem_cons @Foldable_elem_app : hs_simpl.

Lemma Foldable_length_nil {a} :
  length (@nil a) = 0%Z.
Proof. reflexivity. Qed.

Lemma Foldable_length_cons {a} (x : a) (xs : list a) :
  length (cons x xs) = Z.succ (length xs).
Proof. by rewrite !hs_coq_length_list Zlength_cons. Qed.

Hint Rewrite @Foldable_length_nil @Foldable_length_cons : hs_simpl.

Import GHC.Base.ManualNotations.
Require Import Coq.Classes.Morphisms.
From Coq Require Import ssreflect ssrfun ssrbool.

Instance Foldable_elem_proper : forall {a}`{EqLaws a},
  Proper ((fun (x y:a) => x GHC.Base.== y) ==> (fun (x y:list a) => x GHC.Base.== y) ==> Logic.eq)
         Foldable.elem.
Proof.
  intros a E1 E2 x1 x2 Hx.
  move => y1. induction y1.
  - unfold_zeze. move => y2 Hy.
    destruct y2.
    auto.
    simpl in Hy.
    done.
  - case;
    unfold_zeze;
    simpl.
    done.
    move => a1 l.
    hs_simpl.
    move/andP => [h0 h1].
    rewrite (eq_replace_l _ _ _ Hx).
    rewrite (eq_replace_r _ _ _ h0).
    ssrbool.bool_congr.
    eapply IHy1.
    unfold_zeze.
    auto.
Qed.

Lemma elem_eq : forall {A:Type}`{EqLaws A} (xs : list A) (a b : A),
    a == b -> Foldable.elem a xs = Foldable.elem b xs.
Proof.
  move => A ??.
  elim => // x xs IH.
  move => a b h.
  hs_simpl.
  rewrite (IH _ _ h).
  erewrite eq_replace_l; eauto.
Qed.


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

Require Import Undecidability.Synthetic.Undecidability.
Require Import Undecidability.Synthetic.ReducibilityFacts.

From Undecidability.PCP              Require Import PCP PCPb_iff_iPCPb.
From Undecidability.StackMachines    Require Import BSM iPCPb_to_BSM_HALTING.
From Undecidability.MinskyMachines   Require Import MM BSM_MM.

Theorem PCPb_MM_HALTS_ON_ZERO : PCPb ⪯ MM_HALTS_ON_ZERO.
Proof.
  eapply reduces_transitive. exact PCPb_iff_iPCPb.reductionLR.
  eapply reduces_transitive. exact iPCPb_to_BSM_HALTING.
  apply BSM_MM_HALTS_ON_ZERO.
Qed.

Theorem PCPb_MM_HALTING : PCPb ⪯ MM_HALTING.
Proof.
  eapply reduces_transitive. exact PCPb_iff_iPCPb.reductionLR.
  eapply reduces_transitive. exact iPCPb_to_BSM_HALTING.
  apply BSM_MM_HALTING.
Qed.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype path fingraph bigop ssralg ssrnum ssrint.
From fourcolor Require Import hypermap geometry patch coloring birkhoff embed.
From fourcolor Require Import quiz quiztree part redpart discharge hubcap.
From fourcolor Require Import cfmap cfcontract cfreducible configurations.

(******************************************************************************)
(*   This file defines the properties and the specialized scripting language  *)
(* used to prove the seven 'presentation' lemmas (for hub sizes 5 to 11) in   *)
(* files presentN.v. This requires most the elements of graph theory that     *)
(* have been developped so far.                                               *)
(*   We implement Robertson et al.'s presentations directly as Coq scripts,   *)
(* using lemmas and bespoke tactic notation to handle concisely the four      *)
(* types of steps that make up presentations (split, symmetry, reducibility   *)
(* and hubcap), as well as general setup for a particular hub size            *)
(* (generating the quiz tree and the discharge rule fork).                    *)
(*   Definitions:                                                             *)
(*    reducibility <=> all configurations in the_configs are C-reducible.     *)
(*     valid_hub x <-> x is a dart of a minimal_counterexample G with         *)
(*                     positive dscore.                                       *)
(*  excluded_arity n <-> assuming reducibility, no valid_hub has arity n.     *)
(*    successful p <-> no valid_hub fits (exactly) part p.                    *)
(*  forced_part p0 p <-> any valid_hub that fits p0 must also fit p.          *)
(*  succeeds_in p0 p <-> forced_part p0 p implies successful p.               *)
(*   the_quiz_tree == fully evaluated quiz_tree for the_configs.              *)
(*  the_drule_fork n == drule fork for hub size n, precomputed for all n < 12 *)
(*                      (the_drule_fork n is the non-computed version).       *)
(* The presentation scripting language uses the notation for parts, part      *)
(* sublocations and hubcaps; this file exports the relevant XxSyntax modules. *)
(* It comprises the following notation:                                       *)
(*   Check <part>   ::= succeeds_in (Part <part>_0) (Part <part>);            *)
(*      in <part>_0     this is the general form of subgoals.                 *)
(*  Presentation red :: start a presentation proof; turns excluded_arity n in *)
(*                    red : reducibility                                      *)
(*                    ================================                        *)
(*                    Check $ * $ .. $ * $ (n times o)                        *)
(*                       in $ * $ .. $ * $                                    *)
(*    Reducibility :: close Check p in p0 by checking redpart p.              *)
(*  Hubcap <hubcap> :: close Check p in p0 by checking hubcap_cover <hubcap>  *)
(*                     and hubcap_fit p <hubcap>.                             *)
(*   <assumption> ::= <id>[<nat>] <= <nat> | <id>[<nat>] > <nat>              *)
(*                    where <id> is one of the sublocations s, h, or f[1-3].  *)
(*                    This denotes an arity assumption, e.g., s[2] <= 6       *)
(*                    stands for the assumption that the arity of the second  *)
(*                    spoke is less than 6, while s[2] > 6 denotes the        *)
(*                    complementary assumption.                               *)
(*  Pcase <id>: <assumption> :: split Check p   into two subgoals:            *)
(*  Pcase: <assumption>                  in p0                                *)
(*                                         <id> : sucessful p3                *)
(*                       ===========  and  ====================               *)
(*                       Check p1          Check p2                           *)
(*                          in p3             in p0                           *)
(*                    where p1, p2 are p with <assumtion> and its complement, *)
(*                    respectively, and p3 is p0 with <assumption>. If <id>   *)
(*                    is omitted then the context of the second subgoal is    *)
(*                    not extended.                                           *)
(* --> It is an invariant of presentation scripts that p0 is more general     *)
(* than p, and strictly so in the second subgoal of a Pcase. In the latter    *)
(* case p3 can be strictly more general than p1, hence the new second subgoal *)
(* assumption can be strictly stronger than 'successful p1'.                  *)
(*  Similar to <id>[<nat>] :: close Check p in p0 using <id> : sucessful p1   *)
(*  Similar to *<id>[<nat>]   by checking that p1 (or p1 reflected in the '*' *)
(*                            variant) and rotated by j implies p.            *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Definition reducibility := reducible_in_range 0 (size the_configs) the_configs.

Definition valid_hub G x := minimal_counter_example G /\ (0 < @dscore G x)%R.

Definition excluded_arity n :=
  reducibility -> forall G x, @valid_hub G x -> (arity x == n) = false.

Definition successful p := forall G x, @valid_hub G x -> ~~ exact_fitp x p.

Definition forced_part p0 p :=
  forall G x, @valid_hub G x -> exact_fitp x p0 -> exact_fitp x p.

Definition succeeds_in p0 p := forced_part p0 p -> successful p.

(* Presentation. *)
Lemma exclude_arity n :
  (reducibility -> succeeds_in (pcons_ n) (pcons_ n)) -> excluded_arity n.
Proof.
move=> succ_p0_n red G x x_ok; have [cexG _] := x_ok.
by apply: contraTF (exact_fitp_pcons_ cexG x) => /eqP->; apply: succ_p0_n.
Qed.

Section Succeed.

(* Tactic parameters come first. *)

(* Parameters for Pcase and Similar. *)
Variables (i : subpart_loc) (j k : nat) (mir lo : bool).

(* Parameter for Hubcap. *)
Variable hc : hubcap.

(* Implicit parameter and explicit assumption for Similar. *)
Variable ps : part.
Hypothesis ps_ok : successful ps.

(* Implicit goal parameters. *)
Variable p0 p : part.

(* Pcase Ln_m: i[j] <= k. or Pcase Ln_m: i[j] > k. *)
Lemma succeed_by_split :
  let pl := split_part i j k lo p in
  let pr := split_part i j k (~~ lo) p in
  let p0l := if good_split i j k p0 then split_part i j k lo p0 else pl in
    good_split i j k p -> succeeds_in p0l pl ->
  (successful p0l -> succeeds_in p0 pr) -> succeeds_in p0 p.
Proof.
move=> pl pr p0l p_ijk pl_ok pr_ok p0p.
have fitp_split x (x_ok : valid_hub x) := fitp_split (proj1 x_ok) _ _ x.
have p0lpl: forced_part p0l pl.
  rewrite /p0l; case: ifP => [p0ijk | _] G x x_ok //.
  by rewrite !fitp_split // => /andP[-> /p0p->].
have {}pl_ok: successful pl by apply: pl_ok.
have{p0lpl}pr_ok: successful pr.
  apply: pr_ok => G x x_ok => [|p0x]; have:= pl_ok G x x_ok.
    exact/contra/p0lpl.
  by rewrite !fitp_split // p0p ?andbT ?addNb.
move=> G x x_ok; have []:= (pl_ok G x x_ok, pr_ok G x x_ok).
by rewrite !fitp_split // addNb; case: (_ (+) _).
Qed.

(* Similar to Ln_m[j]. or Similar to *Ln_m[j]. *)
Lemma succeed_by_similarity :
  let p1 := if mir then mirror_part p else p in
  let p2 := rot_part j p1 in
  size_part ps = size_part p2 /\ cmp_part p2 ps = Psubset -> succeeds_in p0 p.
Proof.
move=> p1 p2 [Eps2 eq_p2ps] _ G x x_ok; apply/negP => fit_p.
pose G1 := if mir then mirror G else G.
have [x1 x1ok Exp1]: exists2 x1 : G1, valid_hub x1 & exact_fitp x1 p1.
  have [cexG pos_x] := x_ok; rewrite /G1 /p1.
  case mir; last by exists x.
  exists x; last by rewrite -(fitp_mirror cexG) mirror_mirror_part.
  split; first exact: minimal_counter_example_mirror.
  by rewrite (dscore_mirror cexG).
suffices [x2 x2ok Exp2]: exists2 x2 : G1, valid_hub x2 & exact_fitp x2 p2.
  have [Ep2 fit_p2] := andP Exp2; case/negP: (ps_ok x2ok); rewrite /exact_fitp.
  by rewrite Eps2 Ep2 (fitp_cmp fit_p2 ps) eq_p2ps.
have [ltnj | lejn] := ltnP (size_part p1) j.
  exists x1 => //; rewrite /exact_fitp size_rot_part; congr (_ && _): Exp1.
  rewrite -[in LHS](cat_take_drop_part j p1) !fitp_cat andbC.
  set p3 := drop_part j p1; suffices: size_part p3 == 0 by case: p3.
  by rewrite size_drop_part subn_eq0 ltnW.
have [cexG1 fit_x1] := x1ok.
exists (iter j face x1); last by rewrite /p2 -fitp_rot.
by rewrite /valid_hub -(@dscore_cface _ x1) // fconnect_iter.
Qed.

(* Implicit assumption for Reducible and Similar. *)
Hypothesis red_check : reducibility.

Definition the_quiz_tree := Eval vm_compute in cfquiz_tree the_configs.

Let the_redpart := redpart the_quiz_tree.

Lemma no_fit_the_redpart G :
    minimal_counter_example G ->
  forall (x : G) p', the_redpart p' -> ~~ exact_fitp x p'.
Proof.
move=> cexG x p1 redp1; apply: (no_fit_redpart cexG) p1 redp1 x => x.
move Dq: the_quiz_tree => q.
have{q Dq} <-: cfquiz_tree the_configs = q by exact <: Dq.
have:= red_check; rewrite /reducibility; move Dcfs: the_configs => cfs red_cfs.
apply/negP; case/(qzt_fit_cfquiz cexG)=> [cf ltcf [qz fit_qz [cf_ok [u qz_u]]]].
wlog{x fit_qz} [x fit_qz]: G cexG / exists x : G, fitqz x qz.
  move=> IH; case: fit_qz; apply: IH; first exact: cexG.
  exact: minimal_counter_example_mirror.
have red_cf: cfreducible (nth cf000 cfs cf).
  by have:= red_check (leq0n cf); rewrite Dcfs => /(_ ltcf).
have embedG := quiz_preembedding cexG cf_ok qz_u fit_qz.
exact: not_embed_reducible cexG cf_ok embedG red_cf.
Qed.

(* Reducible. *)
Lemma succeed_by_reducibility : the_redpart p -> succeeds_in p0 p.
Proof. by move=> Hp _ G x [cexG nFx]; apply: no_fit_the_redpart. Qed.

(* Hubcap T[j1,j2]<=b1 ... [] *)

Definition the_drule_fork_template n : drule_fork n.
do 12![case: n => [|n]; first exact: DruleFork (DruleForkValues _)].
abstract exact: DruleFork (DruleForkValues _).
Defined.

Definition the_drule_fork := Eval vm_compute in the_drule_fork_template.

Lemma succeed_by_hubcap :
  let n := size_part p in
    hubcap_cover n hc && hubcap_fit the_redpart (the_drule_fork n) p hc ->
  succeeds_in p0 p.
Proof.
move=> n fit_hc _ G x [cexG pos_x].
exact: (hubcap_fit_bound cexG (no_fit_the_redpart cexG)) fit_hc.
Qed.

End Succeed.

Arguments succeed_by_split i j k lo {p0 p} _ _ _ _ {G x}.
Arguments succeed_by_similarity j mir {ps} ps_ok {p0 p} _ _ {G x}.
Arguments succeed_by_reducibility {p0 p} red_check _ _ {G x}.
Arguments succeed_by_hubcap hc {p0 p} red_check _ _ {G x}.

(* Tactic extensions for the presentations. *)

Export PartSyntax.

Arguments succeeds_in (p0 p)%part_scope.
Arguments successful p%part_scope.

Notation "'Check' p1 'in' p0" := (succeeds_in p0 p1)
  (at level 10, p1, p0 at level 9,
   format "'[v' 'Check'  p1 '/'    'in'  p0 ']'").

Tactic Notation "Presentation" ident(red) := apply: exclude_arity => /= red.

Ltac Reducible := by apply succeed_by_reducibility; last exact <: isT.

Export HubcapSyntax.

Ltac Hubcap hc := by apply (succeed_by_hubcap hc); last exact <: isT.

Tactic Notation "Similar" "to" "*" ident(lab) "[" constr(n) "]" :=
  apply (succeed_by_similarity n true lab); compute; do 2!split.
Tactic Notation "Similar" "to" ident(lab) "[" constr(n) "]" :=
  apply (succeed_by_similarity n false lab); compute; do 2!split.

Export SublocSyntax.

Tactic Notation
  "Pcase" ident(label) " : " constr(i) "[" constr(j) "]" "<=" constr(k) :=
  apply (succeed_by_split i j.-1 k true) => //= [|label].
Tactic Notation
  "Pcase" ident(label) " : " constr(i) "[" constr(j) "]" ">" constr(k) :=
  apply (succeed_by_split i j.-1 k false) => //= [|label].
Tactic Notation
  "Pcase" " : " constr(i) "[" constr(j) "]" "<=" constr(k) :=
  apply (succeed_by_split i j.-1 k true) => //= [|_].
Tactic Notation
  "Pcase" " : " constr(i) "[" constr(j) "]" ">" constr(k) :=
  apply (succeed_by_split i j.-1 k false) => //= [|_].


(* Interrupt Mechanism *)

Require Import logic.

Section definitions.
  Context `{!clangG Σ} {invs: nat → iProp Σ} {ptot: nat}.

  Fixpoint INVS (p: nat) :=
    match p with
      | S p' => (invs p ∗ INVS p')%I
      | O => invs O
    end.

  Definition INVS_up (p: nat) :=
    match p with
      | O => True%I
      | S p' => INVS p'
    end.

  Fixpoint INVS_range (p: nat) (q: nat) : iProp Σ :=
    if bool_decide (p > q) then True%I
    else match q with
           | O => invs O
           | S q' => (invs q ∗ INVS_range p q')%I
         end.

  (* Interface *)

  Structure interrupt := Interrupt {
    (* -- predicates -- *)
    name : Type;
    f_sti: val;
    f_cli: val;
    f_create_task (f: ident) (p: nat) : val;
    hpri (γp: name) (i: nat) : iProp Σ;
    closed (γ: name): iProp Σ;
    int_ctx (γ γp: name): iProp Σ;
    (* -- general properties -- *)
    int_ctx_persistent γ γp : PersistentP (int_ctx γ γp);
    closed_timeless γ : TimelessP (closed γ);
    closed_exclusive γ : closed γ -∗ closed γ -∗ False; (* can't close twice *)
    (* HACK *)
    sti : expr := Evalue f_sti;
    cli : expr := Evalue f_cli;
    create_task f p : expr := Evalue $ f_create_task f p;
    (* -- operation specs -- *)
    create_task_spec E f e prio Φ ks:
      f T↦ Function Tvoid [] e ∗
      (∀ N: namespace,
         ⌜ ∀ E, N ⊥ E ⌝ -∗ INVS_range prio ptot -∗
         WP (e, ([], semp)) @ ⊤∖↑N {{ v, INVS_range prio ptot}})
      ⊢ WP (create_task f prio, ks) @ E {{ Φ }};
    sti_spec prio γ γp Φ ks:
      int_ctx γ γp ∗ hpri γp prio ∗ INVS_up prio ∗ closed γ ∗ (hpri γp prio -∗ Φ Vvoid)
      ⊢ WP (sti, ks) {{ Φ }};
    cli_spec prio γ γp Φ ks:
      int_ctx γ γp ∗ hpri γp prio ∗ (INVS_up prio -∗ hpri γp prio -∗ closed γ -∗ Φ Vvoid)
      ⊢ WP (cli, ks) {{ Φ }}
  }.
End definitions.

Existing Instances int_ctx_persistent closed_timeless.

Arguments interrupt {_ _} _ _.
Arguments hpri {_ _} _ {_ _} _ _.
Arguments closed {_ _} _ {_ _} _.
Arguments int_ctx {_ _} _ {_} _ _ _.