From Categories.Essentials Require Import Notations Types Facts_Tactics Quotient.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Basic_Cons.Equalizer.
From Categories.Coq_Cats.Type_Cat Require Import Type_Cat Equalizer.
From Categories Require Import NatTrans.NatTrans NatTrans.Func_Cat.
From Categories Require Import PreSheaf.PreSheaf.

Local Obligation Tactic := idtac.

Section Equalizer.
  Context (C : Category) {A B : PreSheaf C} (f g : (A --> B)%nattrans).

  (** The pointwise equalizer presheaf. *)
  Program Definition PSh_ptw_eq_Func : PreSheaf C :=
    {|
      FO := fun c => Type_Cat_Has_Equalizers _ _ (Trans f c) (Trans g c);
      FA := fun c c' h x => exist _ (A _a h (proj1_sig x))%morphism _
    |}.
  Next Obligation.
  Proof.
    intros c c' h x.
    basic_simpl.
    cbn_rewrite (equal_f (Trans_com f h) x1).
    cbn_rewrite (equal_f (Trans_com g h) x1).
    rewrite x2.
    trivial.
  Qed.
  Next Obligation.
  Proof.
    basic_simpl; FunExt; basic_simpl.
    apply sig_proof_irrelevance; cbn.
    rewrite (F_id A).
    trivial.
  Qed.
  Next Obligation.
  Proof.
    intros a b c f' g'.
    FunExt; basic_simpl.
    apply sig_proof_irrelevance; cbn.
    cbn_rewrite (F_compose A f' g').
    trivial.
  Qed.

  Local Obligation Tactic := basic_simpl; auto.

  (** The equalizer morph. *)
  Program Definition PSh_ptw_eq_morph_NatTrans : NatTrans PSh_ptw_eq_Func A :=
    {|
      Trans :=
        fun c =>
          equalizer_morph
            (Type_Cat_Has_Equalizers _ _ (Trans f c) (Trans g c))
    |}.

  Local Hint Extern 1 => apply NatTrans_eq_simplify; FunExt; basic_simpl : core.

  Local Obligation Tactic := idtac.

  Program Definition PSh_Eq : Equalizer (PShCat C) f g :=
    {|
      equalizer := PSh_ptw_eq_Func;
      equalizer_morph := PSh_ptw_eq_morph_NatTrans;
      equalizer_morph_ex :=
        fun u v H =>
          {|
            Trans := fun c x => exist _ (Trans v c x) _
          |}
    |}.
  Next Obligation. Proof. basic_simpl; auto. Qed.
  Next Obligation.
  Proof.
    intros u v H c x.
    apply (f_equal (fun w :(u --> B)%nattrans => Trans w c x) H).
  Qed.
  Next Obligation.
  Proof.
    intros u v H c x h.
    FunExt.
    apply sig_proof_irrelevance; cbn.
    apply (equal_f (Trans_com v h)).
  Qed.
  Next Obligation.
  Proof.
    symmetry.
    apply PSh_Eq_obligation_3.
  Qed.
  Next Obligation. Proof. basic_simpl; auto. Qed.
  Next Obligation.
    intros e' eqm H1 u u' H4 H5.
    rewrite <- H5 in H4; clear H5.
    assert (H4' := f_equal Trans H4); clear H4.
    apply NatTrans_eq_simplify.
    extensionality x; extensionality y.
    apply sig_proof_irrelevance.
    apply (f_equal (fun w => w x y) H4').
  Qed.

End Equalizer.

Instance PSh_Has_Equalizers (C : Category) : Has_Equalizers (PShCat C)
  := fun _ _ => PSh_Eq C.

Section CoEqualizer.
  Context (C : Category) {A B : PreSheaf C} (f g : (A --> B)%nattrans).

  Lemma another_coequalizer
        (c c' : C)
        (h : (c' --> c)%morphism)
    : ((equalizer_morph
          (Type_Cat_Has_CoEqualizers _ _ (Trans f c') (Trans g c'))) ∘
        (B _a h) ∘ (Trans f c))%morphism
      =
      ((equalizer_morph
          (Type_Cat_Has_CoEqualizers _ _ (Trans f c') (Trans g c'))) ∘
        (B _a h) ∘ (Trans g c))%morphism.
  Proof.
    FunExt; cbn.
    cbn_rewrite <- (equal_f (Trans_com f h)).
    cbn_rewrite <- (equal_f (Trans_com g h)).
    apply (equal_f
             (equalizer_morph_com
                (Type_Cat_Has_CoEqualizers _ _ (Trans f c') (Trans g c')))).
  Qed.

  Lemma CoEq_rel_natural
        (a b : C)
        (h : (b --> a)%morphism)
        (x y : (B _o)%object a)
        (H : CoEq_rel (Trans f a) (Trans g a) x y)
    : CoEq_rel (Trans f b) (Trans g b) (B _a h x)%morphism (B _a h y)%morphism.
  Proof.
    cbn in *.
    induction H.
    {
      destruct H as [z [H1 H2]].
      rewrite <- H1, <- H2.
      constructor 1.
      exists ((A _a)%morphism h z); split.
      apply (equal_f (Trans_com f h)).
      apply (equal_f (Trans_com g h)).
    }
    { constructor 2. }
    { constructor 3; auto. }
    { econstructor 4; eauto. }
  Qed.

  Lemma equalizer_morph_com_simplified
        (a : C)
        (x y : (B _o)%object a)
        (H : CoEq_rel (Trans f a) (Trans g a) x y)
    : equalizer_morph (Type_Cat_CoEq (Trans f a) (Trans g a)) y =
      equalizer_morph (Type_Cat_CoEq (Trans f a) (Trans g a)) x.
  Proof.
    induction H; auto.
    destruct H as [z [H1 H2]].
    rewrite <- H1, <- H2.
    symmetry.
    apply
      (equal_f
         (@equalizer_morph_com
            _ _ _ _ _ (Type_Cat_Has_CoEqualizers _ _ (Trans f a) (Trans g a)))).
  Qed.

  (** The pointwise equalizer presheaf. *)
  Program Definition PSh_ptw_coeq_Func : PreSheaf C :=
    {|
      FO := fun c => Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c);
      FA :=
        fun c c' h x =>
          @equalizer_morph_ex
            _
            _
            _
            _
            _
            (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))
            _
            ((equalizer_morph
                (Type_Cat_Has_CoEqualizers _ _ (Trans f c') (Trans g c')))
               ∘ (B _a h)
            )%morphism (another_coequalizer _ _ _) x
    |}.

  Next Obligation.
  Proof.
    basic_simpl.
    eapply
      (
        @equalizer_morph_unique
          _
          _
          _
          _
          _
          (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))
          _
          (equalizer_morph
             (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c)))
      );
      cbn; trivial.
    + apply (@equalizer_morph_com
               _ _ _ _ _
               (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))).
    + extensionality x.
      apply class_of_inj.
      rewrite (F_id B).
      apply representative_of_class_of.
  Qed.

  Next Obligation.
  Proof.
    intros a b c f' g'; cbn in *.
    apply
      (@equalizer_morph_unique
         _
         _
         _
         _
         _
         (Type_Cat_Has_CoEqualizers _ _ (Trans f a) (Trans g a))
         _
         ((equalizer_morph
             (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c)))
            ∘ (B _a (f' ∘ g')))%morphism
      ); cbn.
    {
      extensionality x.
      cbn_rewrite (F_compose B f' g').
      cbn_rewrite <- (equal_f (Trans_com f f')).
      cbn_rewrite <- (equal_f (Trans_com f g')).
      cbn_rewrite <- (equal_f (Trans_com g f')).
      cbn_rewrite <- (equal_f (Trans_com g g')).
      apply (equal_f
               (@equalizer_morph_com
                  _
                  _
                  _
                  _
                  _
                  (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))
               )
            ).
    }
    {
      extensionality x.
      apply equalizer_morph_com_simplified.
      apply CoEq_rel_natural.
      symmetry.
      apply representative_of_class_of.
    }
    {
      extensionality x.
      cbn_rewrite (@F_compose _ _ B).
      apply equalizer_morph_com_simplified.
      apply CoEq_rel_natural; trivial.
      etransitivity.
      apply CoEq_rel_natural; reflexivity.
      symmetry.
      etransitivity.
      apply representative_of_class_of.
      apply CoEq_rel_natural.
      apply representative_of_class_of.
    }
  Qed.

  (** The equalizer morph. *)
  Program Definition PSh_ptw_coeq_morph_NatTrans :
    NatTrans B PSh_ptw_coeq_Func :=
    {|
      Trans :=
        fun c =>
          equalizer_morph
            (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))
    |}.
  Next Obligation.
  Proof.
    intros c c' h.
    extensionality x.
    cbn.
    apply equalizer_morph_com_simplified.
    apply CoEq_rel_natural; trivial.
    apply representative_of_class_of.
  Qed.
  Next Obligation.
  Proof.
    symmetry.
    apply PSh_ptw_coeq_morph_NatTrans_obligation_1.
  Qed.

(*  Local Hint Extern 1 => apply NatTrans_eq_simplify; FunExt; basic_simpl. *)

  Program Definition PSh_CoEq : CoEqualizer (PShCat C) f g :=
    {|
      equalizer := PSh_ptw_coeq_Func;
      equalizer_morph := PSh_ptw_coeq_morph_NatTrans;
      equalizer_morph_ex :=
        fun u v H =>
          {|
            Trans := fun x w => Trans v x (representative w)
          |}
    |}.
  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality c; extensionality x.
    cbn.
    apply (equal_f
             (@equalizer_morph_com
                _
                _
                _
                _
                _
                (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))
               )
          ).
  Qed.
  Next Obligation.
  Proof.
    intros u v Hfg c c' h; cbn in *.
    extensionality w.
    cbn_rewrite <- (equal_f (Trans_com v h)).
    pose proof
         (representative_of_class_of
            (CoEq_rel (Trans f c') (Trans g c'))
            ((B _a)%morphism h (representative w))) as Hw.
    revert Hw.
    generalize
      (representative
         (class_of
            (CoEq_rel (Trans f c') (Trans g c'))
            ((B _a)%morphism h (representative w)))) as x; intros x Hw.
    induction Hw as [l l' H''| | |]; auto.
    destruct H'' as [q [H''1 H''2]].
    rewrite <- H''1, <- H''2.
    apply (f_equal (fun w : (A --> u)%nattrans => Trans w c' q) Hfg).
  Qed.
  Next Obligation.
  Proof.
    symmetry.
    apply PSh_CoEq_obligation_2; trivial.
  Qed.
  Next Obligation.
  Proof.
    intros e' eqm eqmc.
    apply NatTrans_eq_simplify.
    extensionality c; extensionality x.
    cbn in *.
    pose proof (representative_of_class_of (CoEq_rel (Trans f c) (Trans g c)) x)
      as Hx.
    induction Hx as [l l' H''| | |]; auto.
    destruct H'' as [q [H''1 H''2]].
    rewrite <- H''1, <- H''2.
    apply (f_equal (fun w : (A --> e')%nattrans => Trans w c q) eqmc).
  Qed.
  Next Obligation.
    intros e' eqm eqmc u u' H4 H5.
    apply NatTrans_eq_simplify.
    extensionality c.
    assert (eqmc' := f_equal (fun w : (A --> e')%nattrans => Trans w c) eqmc);
      clear eqmc.
    assert (H4' := f_equal (fun w : (B --> e')%nattrans=> Trans w c) H4); clear H4.
    assert (H5' := f_equal (fun w : (B --> e')%nattrans => Trans w c) H5); clear H5.
    apply (
        @equalizer_morph_unique
          _
          _
          _
          _
          _
          (Type_Cat_Has_CoEqualizers _ _ (Trans f c) (Trans g c))
          _
          (Trans eqm c)
      ); assumption.
  Qed.

End CoEqualizer.

Instance PSh_Has_CoEqualizers (C : Category) : Has_CoEqualizers (PShCat C)
  := fun _ _ => PSh_CoEq C.


Require Export EEdge.

Section cfg.
  Context `(C : redCFG).

  Lemma loop_head_acyclic_entry p h
        (Hloop : loop_head h)
        (Hedge : a_edge__P p h)
    : entry_edge p h.
  Proof.
    copy Hedge Hedge'.
    eapply a_edge_incl in Hedge.
    destruct (edge_Edge Hedge).
    all:auto;exfalso.
    - eapply basic_edge_no_loop2;eauto.
    - destruct b. contradiction.
    - destruct e. eapply no_exit_head;eauto.
  Qed.

  Lemma loop_cutting' q p t
        (Hpath : CPath q p t)
        (Hnoh : forall h, loop_contains h q -> h <> q -> h ∉ t)
    : exists t', Path a_edge__P q p t'.
  Proof.
    revert p Hpath Hnoh.
    specialize (well_founded_ind (R:=(@StrictPrefix' Lab)) (@StrictPrefix_well_founded Lab)
                                 (fun t => forall p : Lab,
                                      CPath q p t
                                      -> (forall h : Lab, loop_contains h q -> h <> q -> h ∉ t)
                                      -> exists t' : list Lab, Path a_edge__P q p t'))
      as WFind.
    eapply WFind.
    intros;clear WFind.
    inv_path H0.
    - eexists;econstructor.
    - specialize (H π) as Hπ.
      exploit' Hπ.
      { econstructor. econstructor. }
      specialize (Hπ x0).
      exploit Hπ.
      { intros. intro N. eapply H1;eauto. }
      destructH.
      destruct (edge_Edge H3).
      + exists (p :: t'). destruct b. econstructor;eauto.
      + decide (p = q).
        {
          subst. eexists. econstructor.
        }
        eapply loop_contains_ledge in b. eapply dom_loop_contains in b;cycle 1.
        * intro N. eapply H1;eauto.
        * eapply dom_dom_acyclic in b. eapply b in Hπ as Hb.
          eapply path_to_elem in Hb;eauto. destructH. eexists;eauto.
      + exists (p :: t').
        eapply entry_edge_acyclic in e. econstructor;eauto.
      + exists (p :: t').
        eapply exit_edge_acyclic in e. econstructor;eauto.
  Qed.

  Lemma loop_cutting q p t
        (Hpath : CPath q p t)
        (Hnoh : forall h, loop_contains h q -> h <> q -> h ∉ t)
    : exists t', Path a_edge__P q p t'.
  Proof.
    eapply loop_cutting';eauto.
  Qed.

  Lemma member_reachs_innermost_latch_acyclic h q
        (Hloop : innermost_loop h q)
    : exists p, p ↪ h /\ q -a>* p.
  Proof.
    destruct Hloop. destruct H. destructH.
    exists x. split;auto.
    decide (h = q).
    { subst q. eapply loop_reachs_member. eapply loop_contains_ledge;eauto. }
    eapply loop_cutting in H3;eauto.
    intros.
    destr_r' π;subst.
    - inv H3.
    - path_simpl' H3.
      rewrite rev_rcons in H4. cbn in H4. rewrite <-in_rev in H4.
      assert (h ∉ (l ++ [q])) as Hnin.
      {
        contradict H4.
        eapply In_rcons in H4.
        destruct H4;[contradiction|auto].
      }
      contradict Hnin.
      decide (h0 = h). { subst;eauto. }
                       eapply path_from_elem in Hnin;eauto.
      destructH.
      eapply postfix_incl;eauto.
      eapply dom_loop_contains;eauto.
      + eapply loop_contains_ledge;eauto.
      + intro N. eapply H0 in H. contradict n0. eapply loop_contains_Antisymmetric;eauto.
  Qed.
End cfg.


Require Import Category.Setoids.
Require Import Category.Types.
Require Import Category.Types_Setoids.
Require Import Category.RComod.
Require Import Category.RComonad.
Require Import Category.Stream.Category.
Require Import Category.Stream.Axioms.
Require Import Theory.Category.
Require Import Theory.InitialTerminal.
Require Import Theory.Functor.
Require Import Theory.RelativeComonad.
Require Import Theory.Comodule.
Require Import Theory.Product.
Require Import Theory.PrecompositionWithProduct.
Require Import Theory.PushforwardComodule.

Generalizable All Variables.

(*------------------------------------------------------------------------------
  -- ＳＴＲＥＡＭ  ＩＳ  ＴＥＲＭＩＮＡＬ  ＩＮ  ＳＴＲＥＡＭ
  ----------------------------------------------------------------------------*)
(** * Stream is terminal in Streams **)

(* begin hide *)
Ltac clean_hyps := repeat match goal with H : _ |- _ => clear H end.
(* end hide *)

Module StreamTerminal (Import Ax : StreamAxioms).

  (** ** -∼- is an equivalence relation **)
  Lemma bisim_refl : ∀ {A} {s : Stream A}, s ∼ s.
  Proof.
    intros. apply bisim_intro with (R := λ s₁ s₂ ∙ s₁ = s₂); [clean_hyps; intros..|auto].
    - subst; reflexivity.
    - subst; reflexivity.
  Qed.

  Lemma bisim_sym : ∀ {A} {s₁ s₂ : Stream A}, s₁ ∼ s₂ → s₂ ∼ s₁.
  Proof.
    intros.
    apply bisim_intro with (R := λ s₁ s₂ ∙ s₂ ∼ s₁); [clean_hyps; intros..|auto].
    - symmetry; now apply bisim_head.
    - now apply bisim_tail.
  Qed.

  Lemma bisim_trans : ∀ {A} {s₁ s₂ s₃ : Stream A}, s₁ ∼ s₂ → s₂ ∼ s₃ → s₁ ∼ s₃.
  Proof.
    intros.
    apply bisim_intro with (R := λ s₁ s₃ ∙ ∃ s₂, s₁ ∼ s₂ ∧ s₂ ∼ s₃);
    [clean_hyps; intros.. | eauto].
    - destruct H as (? & ? & ?).
      etransitivity. eapply bisim_head; eauto.
      now apply bisim_head.
    - destruct H as (? & ? & ?).
      eexists; split; eapply bisim_tail; eauto.
  Qed.

  Instance bisim_equiv : ∀ {A}, Equivalence (@bisim A).
  Proof.
    constructor; repeat intro.
    - now apply bisim_refl.
    - now apply bisim_sym.
    - eapply bisim_trans; eauto.
  Qed.

  Lemma eq_bisim : ∀ {A} {s₁ s₂ : Stream A}, s₁ = s₂ → s₁ ∼ s₂.
  Proof.
    intros. now rewrite H.
  Qed.

  (** ** Stream as a setoid **)
  Program Definition STREAM (A : Type) : Setoids.Obj :=
    Setoids.make ⦃ Carrier ≔ Stream A ; Equiv ≔ bisim ⦄.

  (** ** head & tail are setoids morphisms **)
  Lemma head_cong : ∀ {A} {s₁ s₂ : Stream A}, s₁ ∼ s₂ → head s₁ = head s₂.
  Proof.
    intros A s₁ s₂ eq_s₁s₂. now apply bisim_head.
  Qed.

  Lemma tail_cong : ∀ {A} {s₁ s₂ : Stream A}, s₁ ∼ s₂ → tail s₁ ∼ tail s₂.
  Proof.
    intros A s₁ s₂ eq_s₁s₂. now apply bisim_tail.
  Qed.

  Program Definition 𝒉𝒆𝒂𝒅 {A} : STREAM A ⇒ 𝑬𝑸 A := Setoids.Morphism.make head.
  (** head-cong **)
  Next Obligation.
    now apply head_cong.
  Qed.

  Program Definition 𝒕𝒂𝒊𝒍 {A} : STREAM A ⇒ STREAM A := Setoids.Morphism.make tail.
  (** tail-cong **)
  Next Obligation.
    now apply tail_cong.
  Qed.

  (** ** Cosubstitution for streams **)
  Definition cosubst {A B : 𝑻𝒚𝒑𝒆} (f : Stream A ⇒ B) : Stream A ⇒ Stream B :=
    corec f tail.

  (** ** Stream is a relative comonad over EQ **)
  Obligation Tactic := idtac.
  Program Definition 𝑺𝒕𝒓 : ‵ 𝑹𝑪𝒐𝒎𝒐𝒏𝒂𝒅 𝑬𝑸 ′ :=
    RelativeComonad.make  ⦃ T       ≔ STREAM
                          ; counit  ≔ λ X ∙ 𝒉𝒆𝒂𝒅
                          ; cobind  ≔ λ X Y ∙ λ f ↦ Setoids.Morphism.make (cosubst f) ⦄.
  (** cosubst-cong **)
  Next Obligation.
    intros.
    apply bisim_intro with (λ s₁ s₂ ∙ ∃ x y, x ∼ y ∧ s₁ = cosubst f x ∧ s₂ = cosubst f y)
    ; [clean_hyps; intros..|eauto].
    - destruct H as (x & y & eq_xy & -> & ->).
      unfold cosubst. repeat rewrite head_corec.
      now rewrite eq_xy.
    - destruct H as (x & y & eq_xy & -> & ->).
      exists (tail x). exists (tail y).
      split; [|split].
      + now apply bisim_tail.
      + unfold cosubst at 1. rewrite tail_corec. reflexivity.
      + unfold cosubst at 1. rewrite tail_corec. reflexivity.
  Qed.
  (** cosubst-cong₂ **)
  Next Obligation.
    intros X Y f g eq_fg x y eq_xy. simpl.
    apply bisim_intro with (λ s₁ s₂ ∙ ∃ x y, x ∼ y ∧ s₁ = cosubst f x ∧ s₂ = cosubst g y); [intros..|eauto].
    - destruct H as (x' & y' & eq_xy' & -> & ->).
      unfold cosubst; repeat rewrite head_corec.
      etransitivity. eapply (Setoids.cong f). apply eq_xy'.
      now apply eq_fg.
    - destruct H as (x' & y' & eq_xy' & -> & ->).
      exists (tail x'). exists (tail y').
      split; [|split].
      + now apply bisim_tail.
      + unfold cosubst at 1. rewrite tail_corec. reflexivity.
      + unfold cosubst at 1. rewrite tail_corec. reflexivity.
  Qed.
  (** cobind-counit **)
  Next Obligation.
    simpl. intros.
    apply bisim_intro with (λ s₁ s₂ ∙ ∃ x y, x ∼ y ∧ s₁ = cosubst head x ∧ s₂ = y); [clean_hyps; intros..|eauto].
    - destruct H as (x & y & eq_xy & -> & ->).
      unfold cosubst; rewrite head_corec; now apply head_cong.
    - destruct H as (x & y & eq_xy & -> & ->).
      exists (tail x). exists (tail y).
      split; [|split].
      + now apply bisim_tail.
      + unfold cosubst at 1. rewrite tail_corec. reflexivity.
      + reflexivity.
  Qed.
  (** counit-cobind **)
  Next Obligation.
    repeat intro. rewrite H. simpl. unfold cosubst. now rewrite head_corec.
  Qed.
  (** cobind-cobind **)
  Next Obligation.
    intros X Y Z f g x y eq_xy. rewrite <- eq_xy. clear y eq_xy. simpl.
    apply bisim_intro with (λ s₁ s₂ ∙ ∃ x, s₁ = cosubst g (cosubst f x) ∧ s₂ = cosubst (λ y ∙ g (cosubst f y)) x);
    [clean_hyps; intros..|eauto].
    - destruct H as (x & -> & ->).
      unfold cosubst. repeat rewrite head_corec. reflexivity.
    - destruct H as (x & -> & ->).
      exists (tail x). split.
      + unfold cosubst. now do 2 rewrite tail_corec.
      + unfold cosubst. now rewrite tail_corec.
  Qed.

  (** ** Stream coalgebra **)
  Program Definition 𝑻𝒂𝒊𝒍 : ‵ [𝑺𝒕𝒓] ⇒ [𝑺𝒕𝒓] ′ :=
    Comodule.make ⦃ α ≔ λ A ∙ Setoids.Morphism.make 𝒕𝒂𝒊𝒍 ⦄.
  (** tail-cong **)
  Next Obligation.
    intros A x y eq_xy; now rewrite eq_xy.
  Qed.
  (** α-commutes **)
  Next Obligation.
    intros C D f x y eq_xy. rewrite eq_xy. apply eq_bisim. simpl. unfold cosubst. now rewrite tail_corec.
  Qed.

  Program Definition 𝑺𝑻𝑹 : ‵ 𝑺𝒕𝒓𝒆𝒂𝒎 ′ :=
    Stream.make ⦃ T ≔ 𝑺𝒕𝒓 ; tail ≔ 𝑻𝒂𝒊𝒍 ⦄.

  (** ** 𝑺𝑻𝑹 is a terminal object **)

  Section Defs.

    Variable (Tr : 𝑺𝒕𝒓𝒆𝒂𝒎).

    Notation T                  := (Stream.T Tr).
    Notation "'T⋅tail'"         := (Stream.tail Tr _).
    Notation "'T⋅tail[' A ]"    := (Stream.tail Tr A) (only parsing).
    Notation STR                := (Stream.T 𝑺𝑻𝑹).
    Notation "'STR⋅tail'"       := (Stream.tail 𝑺𝑻𝑹 _).
    Notation "'STR⋅tail[' A ]"  := (Stream.tail 𝑺𝑻𝑹 A) (only parsing).

    Local Notation "a ∼ b" := (SEquiv a b).

    Definition tau {A} : T A → STR A := corec T⋅counit T⋅tail.

    Lemma head_tau : ∀ A (t : T A), STR⋅counit (tau t) = T⋅counit t.
    Proof.
      intros. unfold tau. simpl. now rewrite head_corec.
    Qed.

    Lemma tail_tau : ∀ A (t : T A), STR⋅tail (tau t) = tau (T⋅tail t).
    Proof.
      intros. unfold tau. simpl. now rewrite tail_corec.
    Qed.

    Lemma tau_cong : ∀ A (x y : T A), x ∼ y → tau x ∼ tau y.
    Proof.
      intros.
      apply bisim_intro with (λ s₁ s₂ ∙ ∃ x y, x ∼ y ∧ s₁ = tau x ∧ s₂ = tau y);
      [clean_hyps; intros..|eauto].
      - destruct H as (x & y & eq_xy & -> & ->).
        unfold tau. repeat rewrite head_corec. now rewrite eq_xy.
      - destruct H as (x & y & eq_xy & -> & ->).
        exists (T⋅tail x). exists (T⋅tail y). split; [|split].
        + now rewrite eq_xy.
        + unfold tau. now rewrite tail_corec.
        + unfold tau. now rewrite tail_corec.
    Qed.

    Program Definition Tau {A} : T A ⇒ STR A :=
      Setoids.Morphism.make tau.
    (** tau-cong **)
    Next Obligation.
      intros. now apply tau_cong.
    Qed.

    Lemma tau_counit : ∀ A (t t' : T A), t ∼ t' → T⋅counit t ∼ STR⋅counit (tau t').
    Proof.
      intros A t t' eq_tt'. rewrite eq_tt'. simpl. unfold tau. now rewrite head_corec.
    Qed.

    Lemma tau_cobind : ∀ A B (f : STR A ⇒ 𝑬𝑸 B) x y, x ∼ y → Tau (T⋅cobind (f ∘ Tau) x) ∼ STR⋅cobind f (Tau y).
    Proof.
      intros A B f x y eq_xy. rewrite <- eq_xy. clear y eq_xy.
      apply bisim_intro with (λ s₁ s₂ ∙ ∃ x, s₁ ∼ Tau (T⋅cobind (f ∘ Tau) x) ∧ s₂ ∼ STR⋅cobind f (Tau x));
      [clean_hyps;intros..|eauto].
      - destruct H as (x & ? & ?).
        etransitivity. eapply head_cong. apply H.
        symmetry; etransitivity. eapply head_cong; apply H0.
        simpl. unfold tau, cosubst. repeat rewrite head_corec.
        symmetry. etransitivity. apply (counit_cobind T). reflexivity.
        reflexivity.
      - destruct H as (x & ? & ?).
        exists (T⋅tail x). split.
        etransitivity. eapply tail_cong. apply H.
        simpl. unfold tau. repeat rewrite tail_corec.
        apply tau_cong. etransitivity. apply (α_commutes (Stream.tail Tr)). reflexivity.
        simpl. reflexivity.
        etransitivity. eapply tail_cong. apply H0.
        simpl. unfold tau, cosubst. repeat rewrite tail_corec. reflexivity.
      - exists x; split; reflexivity.
    Qed.

  End Defs.

  (** printing τ #◯# *)

  (** ◯ is a morphism of triangles **)
  Program Definition τ (T : 𝑺𝒕𝒓𝒆𝒂𝒎) : T ⇒ 𝑺𝑻𝑹 :=
    Stream.make ⦃ τ ≔ RelativeComonad.make ⦃ τ ≔ λ A ∙ Tau T ⦄ ⦄.
  (** τ-counit **)
  Next Obligation.
    repeat intro. now apply tau_counit.
  Qed.
  (** τ-cobind **)
  Next Obligation.
    repeat intro. now apply tau_cobind.
  Qed.
  (** τ-commutes **)
  Next Obligation.
    repeat intro. rewrite H. simpl. unfold tau. repeat rewrite tail_corec. reflexivity.
  Qed.

  (* begin hide *)
  Local Notation "⟨ f ⟩" := (RelativeComonad.τ (m := Stream.τ f)) (only parsing).
  (* end hide *)

  (** 𝑺𝑻𝑹 is a terminal object **)
  Program Definition Terminality : Terminal 𝑺𝒕𝒓𝒆𝒂𝒎 :=
    Terminal.make  ⦃ one  ≔ 𝑺𝑻𝑹
                   ; top  ≔ τ ⦄.
  (** top-unique **)
  Next Obligation.
    intros A f X x y eq_xy. rewrite <- eq_xy. clear y eq_xy. simpl.
    apply bisim_intro with (λ s₁ s₂ ∙ ∃ x, s₁ ∼ ⟨f⟩ _ x ∧ s₂ ∼ tau A x); [clean_hyps; intros..|].
    - destruct H as (? & ? & ?).
      etransitivity. eapply head_cong. apply H.
      symmetry; etransitivity. eapply head_cong. apply H0.
      unfold tau. rewrite head_corec. symmetry. etransitivity. symmetry. apply (τ_counit (Stream.τ f)).
      reflexivity. reflexivity.
    - destruct H as (? & ? & ?).
      exists (Stream.tail A _ x). split.
      + etransitivity. eapply tail_cong. apply H.
        etransitivity. symmetry. eapply (Stream.τ_commutes f). reflexivity.
        reflexivity.
      + etransitivity. eapply tail_cong. apply H0.
        unfold tau. rewrite tail_corec. reflexivity.
    - exists x. split; reflexivity.
  Qed.

End StreamTerminal.


Require Import compcert.lib.Coqlib compcert.lib.Zbits.
Require Import compcert.common.AST compcert.lib.Integers.
Require Import compcert.common.Values compcert.common.Memory.
Require Import compcert.common.Globalenvs compcert.common.Events.

Inductive int_or_ptr: val -> mem -> val -> Prop :=
  | int_or_ptr_int: forall n m,
      Int.and n Int.one = Int.one ->
      int_or_ptr (Vint n) m Vfalse
  | int_or_ptr_ptr: forall b ofs m,
      Mem.range_perm m b (Ptrofs.unsigned ofs) (Ptrofs.unsigned ofs + 2) Cur Nonempty ->
      Ptrofs.and ofs Ptrofs.one = Ptrofs.zero ->
      int_or_ptr (Vptr b ofs) m Vtrue.

Remark ptrofs_2_aligned: forall ofs,
  Ptrofs.and ofs Ptrofs.one = Ptrofs.zero <-> (2 | Ptrofs.unsigned ofs).
Proof.
  assert (A: forall n, (2 | n) <-> Z.Even n).
  { intros; split; intros [k E]; rewrite E; exists k; ring. }
  assert (B: forall n, Z.Even n <-> Z.testbit n 0 = false).
  { intros. rewrite Z.bit0_odd, <- Z.negb_even, <- Z.even_spec, negb_false_iff. tauto. }
  intros; split; intros.
- apply A. apply B. change false with (Ptrofs.testbit Ptrofs.zero 0). rewrite <- H.
  rewrite Ptrofs.bits_and, Ptrofs.bits_one. simpl. rewrite andb_true_r; auto.
  generalize Ptrofs.wordsize_pos; omega.
- apply A in H. apply B in H. Ptrofs.bit_solve. rewrite Ptrofs.bits_one.
  destruct (zeq i 0); simpl.
  rewrite andb_true_r. subst i. exact H.
  apply andb_false_r.
Qed.

Lemma int_or_ptr_inject:
  forall v m res f v' m',
  int_or_ptr v m res ->
  Val.inject f v v' ->
  Mem.inject f m m' ->
  exists res', int_or_ptr v' m' res' /\ Val.inject f res res'.
Proof.
  destruct 1; intros VI MI; inv VI.
- (* integer *)
  exists Vfalse; split.
+ constructor; auto.
+ constructor.
- (* pointer *)
  assert (AL: (2 | delta)).
  { change 2 with (align_chunk Mint16unsigned). clear H0.
    eauto using Mem.mi_align, Mem.mi_inj, Mem.range_perm_max. }
  assert (OF: Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta)) = Ptrofs.unsigned ofs + delta).
  { eapply Mem.address_inject; eauto. apply H. omega. }
  exists Vtrue; split.
+ constructor.
* rewrite OF. replace (Ptrofs.unsigned ofs + delta + 2) with ((Ptrofs.unsigned ofs + 2) + delta) by omega.
  eapply Mem.range_perm_inject; eauto.
* apply ptrofs_2_aligned in H0. apply ptrofs_2_aligned. rewrite OF.
  apply Z.divide_add_r; auto.
+ constructor.
Qed.


Require Import
  HoTT.Types.Universe
  HoTT.Basics.Decidable
  HoTT.HSet
  HoTT.Basics.PathGroupoids
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.orders
  HoTT.Classes.orders.lattices
  HoTT.Classes.theory.lattices
  HoTTClasses.partiality
  HoTT.Classes.implementations.peano_naturals.

Local Set Universe Minimization ToSet.

Definition Sier := partial Unit.

Global Instance SierLe : Le Sier := _.
Arguments SierLe _ _ /.

Global Instance SierBot : Bottom Sier := bot _.

Global Instance SierTop : Top Sier := eta _ tt.

Definition IsTop (s : Sier) : Type0 := top <= s.
Coercion IsTop : Sier >-> Sortclass.

Section contents.
Context `{Funext} `{Univalence}.

Instance Sier_order : PartialOrder SierLe := partial_order _.

Lemma top_greatest : forall x : Sier, x <= top.
Proof.
apply (partial_ind0 _ _).
- intros [];reflexivity.
- apply bot_least.
- intros f IH. apply sup_le_r. exact IH.
Qed.

(* We need this for the bot_least case. *)
Definition SierJoin_aux : forall y : Sier, Sier -> sigT (fun j : Sier => y <= j).
Proof.
intros y. apply (partial_rec Unit _ (fun a b => a.1 <= b.1)).
simple refine (Build_Recursors _ _ _ _ _ _ _ _ _ _ _ _);simpl.
- intros _;exists top. apply top_greatest.
- exists y;reflexivity.
- intros f IH. simpl in IH. simple refine (existT _ _ _);simpl.
  + apply sup. exists (fun n => (f n).1).
    exact IH.
  + transitivity ((f O).1).
    * apply ((f O).2).
    * exact (sup_is_ub _ {| seq := fun n : nat => (f n).1; seq_increasing := IH |} O).
- intros;reflexivity.
- simpl. apply pr2.
- simpl. intros s p x. apply sup_le_l.
- simpl. intros s p x IH. apply sup_le_r.
  apply IH.
- intros a b E1 E2. apply Sigma.path_sigma_hprop.
  apply (antisymmetry le);trivial.
Defined.

Global Instance SierJoin : Join Sier
  := fun x y => (SierJoin_aux y x).1.

Definition SierJoin_top : forall x : Sier, join top x = top
  := fun _ => idpath.

Definition SierJoin_bot : forall x : Sier, join bottom x = x
  := fun _ => idpath.

Instance SierJoin_preserve_le_l : forall y, OrderPreserving (fun x => join x y)
  := fun y => partialLe_rec _ _ (fun a b => a.1 <= b.1) _.

Definition SierJoin_seq_l : IncreasingSequence Sier -> Sier ->
  IncreasingSequence Sier.
Proof.
intros s y;exists (fun n => join (s n) y).
intros n;apply (order_preserving (fun x => join x y)). apply seq_increasing.
Defined.

Definition SierJoin_sup : forall s (y : Sier),
  join (sup _ s) y = sup _ (SierJoin_seq_l s y)
  := fun _ _ => idpath.

Definition SierJoin_ub_r : forall x y : Sier, y <= join x y
  := fun x y => (SierJoin_aux y x).2.

Instance SierJoin_is_join : JoinSemiLatticeOrder SierLe.
Proof.
split.
- apply _.
- intros x y;revert x;apply (partial_ind0 _ _).
  + intros [];reflexivity.
  + apply bot_least.
  + intros s IH. apply sup_le_r.
    intros n. change (join (sup Unit s) y) with (sup Unit (SierJoin_seq_l s y)).
    etransitivity;[apply IH|].
    exact (sup_is_ub _ (SierJoin_seq_l s y) _).
- apply SierJoin_ub_r.
- apply (partial_ind0 _ (fun x => forall y z, _ -> _ -> _)).
  + intros [] y z E1 E2. apply E1.
  + intros y z E1 E2. apply E2.
  + intros s IH y z E1 E2.
    apply (sup_le_r _ (SierJoin_seq_l s y)).
    intros n. apply IH;trivial.
    apply sup_le_l. trivial.
Qed.

Global Instance SierMeet : Meet Sier.
Proof.
intros x y;revert x;apply (partial_rec Unit _ le).
simple refine (Build_Recursors _ _ _ _ _ _ _ _ _ _ _ _);simpl.
- intros _;exact y.
- exact bottom.
- intros f IH;simpl in IH.
  apply sup. exists f. exact IH.
- reflexivity.
- apply bot_least.
- intros s p x IH;apply (sup_le_l _ _ _ IH).
- intros s p x IH;apply sup_le_r. apply IH.
Defined.

Definition SierMeet_top : forall x : Sier, meet top x = x
  := fun _ => idpath.

Definition SierMeet_bot : forall x : Sier, meet bottom x = bottom
  := fun _ => idpath.

Instance SierMeet_preserve_le_l : forall y, OrderPreserving (fun x => meet x y)
  := fun y => partialLe_rec _ _ le _.

Definition SierMeet_seq_l : IncreasingSequence Sier -> Sier ->
  IncreasingSequence Sier.
Proof.
intros s y;exists (fun n => meet (s n) y).
intros n;apply (order_preserving (fun x => meet x y)). apply seq_increasing.
Defined.

Definition SierMeet_sup : forall s (y : Sier),
  meet (sup _ s) y = sup _ (SierMeet_seq_l s y)
  := fun _ _ => idpath.

Lemma SierMeet_is_meet@{} : MeetSemiLatticeOrder SierLe.
Proof.
split.
- apply _.
- intros x y;revert x. apply (partial_ind0 _ _).
  + intros []. apply top_greatest.
  + intros;apply bot_least.
  + intros s IH.
    change (sup Unit s ⊓ y) with (sup _ (SierMeet_seq_l s y)).
    apply sup_le_r. intros n. simpl.
    etransitivity;[apply IH|]. apply sup_is_ub.
- intros x y;revert x. apply (partial_ind0 _ _).
  + reflexivity.
  + apply bot_least.
  + intros s IH.
    change (sup Unit s ⊓ y) with (sup _ (SierMeet_seq_l s y)).
    apply sup_le_r. simpl. intros n;apply IH.
- apply (partial_ind0 _ (fun x => forall y z, _ -> _ -> _)).
  + intros [] y z E1 E2. apply E2.
  + intros y z E1 E2. apply E1.
  + intros s IH y z;revert z y.
    apply (partial_ind0 _ (fun z => forall y, _ -> _ -> _)).
    * intros [] y E1 E2.
      apply (eta_le_sup _) in E1.
      revert E1;apply (Trunc_ind _);intros [n E1].
      transitivity (meet (s n) y);auto.
      exact (sup_is_ub _ (SierMeet_seq_l _ _) _).
    * intros;apply bot_least.
    * intros s' IH' y E1 E2.
      apply sup_le_r. intros n.
      apply IH';(transitivity (sup _ s');[apply sup_is_ub|]);trivial.
Qed.
Existing Instance SierMeet_is_meet.

Section distrib_lattice.

Local Instance Sier_lattice_order : LatticeOrder SierLe := {}.
Local Existing Instance join_sl_order_join_sl.
Local Existing Instance meet_sl_order_meet_sl.

Global Instance Sier_distributive_lattice : DistributiveLattice Sier.
Proof.
repeat (split;try apply _).
- hnf. intros a b. apply (antisymmetry le).
  + apply join_le.
    * reflexivity.
    * apply meet_lb_l.
  + apply join_ub_l.
- hnf. intros a b. apply (antisymmetry le).
  + apply meet_lb_l.
  + apply meet_le.
    * reflexivity.
    * apply join_ub_l.
- hnf. intros a b c. apply (antisymmetry le).
  + apply join_le; apply meet_le.
    * apply join_ub_l.
    * apply join_ub_l.
    * transitivity b.
      { apply meet_lb_l. }
      { apply join_ub_r. }
    * transitivity c.
      { apply meet_lb_r. }
      { apply join_ub_r. }
  + revert a b c. apply (partial_ind0 _ (fun a => forall b c, _)).
    * intros [] b c. reflexivity.
    * reflexivity.
    * intros s IH b c.
      rewrite !SierJoin_sup,SierMeet_sup.
      apply sup_le_r. intros n.
      simpl. rewrite (commutativity (f:=meet)),SierMeet_sup;simpl.
      apply sup_le_r;intros m.
      simpl.
      assert (E : exists k, n <= k /\ m <= k)
      by (destruct (total le n m) as [E|E];eauto).
      destruct E as [k [En Em]].
      etransitivity;[|apply (sup_is_ub _ _ k)].
      simpl. etransitivity;[|apply IH].
      apply meet_le.
      { etransitivity;[apply meet_lb_r|].
        apply join_le;[|apply join_ub_r].
        transitivity (s k);[|apply join_ub_l].
        apply (order_preserving s). trivial. }
      { etransitivity;[apply meet_lb_l|].
        apply join_le;[|apply join_ub_r].
        transitivity (s k);[|apply join_ub_l].
        apply (order_preserving s). trivial. }
Qed.

End distrib_lattice.
Local Existing Instance join_sl_order_join_sl.
Local Existing Instance meet_sl_order_meet_sl.

Fixpoint joined_seq_aux (f : nat -> Sier) (n : nat) : Sier :=
  match n with
  | O => f O
  | S k => join (joined_seq_aux f k) (f n)
  end.

Definition joined_seq (f : nat -> Sier) : IncreasingSequence Sier.
Proof.
exists (joined_seq_aux f).
intros;simpl. apply join_ub_l.
Defined.

Definition CountableSup (f : nat -> Sier) : Sier
  := sup _ (joined_seq f).

Lemma joined_seq_ub_n : forall f n, f n <= joined_seq f n.
Proof.
intros f [|n].
- reflexivity.
- simpl. apply join_ub_r.
Qed.

Lemma countable_sup_ub : forall f n, f n <= CountableSup f.
Proof.
intros. transitivity (joined_seq f n).
- apply joined_seq_ub_n.
- unfold CountableSup. apply sup_is_ub.
Qed.

Lemma joined_seq_least_ub_n' : forall f n x, (forall m, m <= n -> f m <= x) ->
  joined_seq f n <= x.
Proof.
intros f;induction n as [|n IHn];intros x E.
- simpl. apply E. reflexivity.
- simpl. apply join_le.
  + apply IHn. intros m Em;apply E.
    constructor;trivial.
  + apply E. reflexivity.
Qed.

Definition joined_seq_least_ub_n@{} := joined_seq_least_ub_n'@{Set Ularge Set}.

Lemma countable_sup_least_ub : forall f x, (forall n, f n <= x) ->
  CountableSup f <= x.
Proof.
intros f x E. apply sup_le_r.
intros n. apply joined_seq_least_ub_n. intros m _;apply E.
Qed.

Lemma top_le_meet : forall a b : Sier, meet a b <-> a /\ b.
Proof.
unfold IsTop. intros a b;split.
- intros E;split;transitivity (meet a b);trivial.
  + apply meet_lb_l.
  + apply meet_lb_r.
- intros [E1 E2]. apply meet_le;trivial.
Qed.

Lemma top_le_join@{} : forall a b : Sier, join a b <-> hor a b.
Proof.
unfold IsTop. intros a b;split.
- revert a b;apply (partial_ind0 _ (fun a => forall b, _ -> _)).
  + intros [] ? E;apply tr;left;apply E.
  + intros b E;apply tr;right;apply E.
  + intros s IH b E.
    change (top <= sup _ (SierJoin_seq_l s b)) in E.
    apply (eta_le_sup _) in E. revert E. apply (Trunc_ind _).
    intros [n E]. simpl in E.
    apply IH in E. revert E;apply (Trunc_ind _).
    intros [E|E];apply tr;[left|right;trivial].
    transitivity (s n);trivial. apply sup_is_ub.
- apply (Trunc_ind _);intros [E|E].
  + transitivity a;auto. apply join_ub_l.
  + transitivity b;auto. apply join_ub_r.
Qed.

Lemma top_le_joined_seq_n' : forall f n, joined_seq f n <->
  merely (exists m, m <= n /\ f m).
Proof.
unfold IsTop. intros f;induction n as [|n IHn];simpl;
(split;[intros E|apply (Trunc_ind _);intros [m [Em E]]]).
- apply tr;exists 0;split;trivial. reflexivity.
- rewrite (antisymmetry le m 0 Em (zero_least m)) in E. trivial.
- apply top_le_join in E. revert E;apply (Trunc_ind _);intros [E|E].
  + apply IHn in E;revert E;apply (Trunc_ind _);intros [m [E1 E2]].
    apply tr;exists m;split;trivial. constructor;trivial.
  + apply tr;exists (S n);split;trivial. reflexivity.
- apply le_S_either in Em. destruct Em as [Em|Em].
  + transitivity (joined_seq f n);[|apply join_ub_l].
    apply IHn. apply tr;exists m;auto.
  + rewrite <-Em. transitivity (f m);auto. apply join_ub_r.
Qed.

Definition top_le_joined_seq_n@{} := top_le_joined_seq_n'@{Set Ularge Set Set}.

Lemma top_le_sup@{} : forall (s : IncreasingSequence Sier),
  IsTop (sup Unit s) <-> merely@{Set} (exists n, s n).
Proof.
intros s;split.
- intros E.
  apply (eta_le_sup _) in E.
  exact E.
- apply (Trunc_ind _);intros [n E].
  red;transitivity (s n);trivial.
  apply sup_is_ub.
Qed.

Lemma top_le_countable_sup@{} : forall f, CountableSup f <->
  merely (exists n, f n).
Proof.
unfold IsTop. intros f;split.
- intros E.
  apply (eta_le_sup _) in E.
  revert E;apply (Trunc_ind _);intros [n E].
  apply top_le_joined_seq_n in E. revert E;apply (Trunc_ind _);intros [m [_ E]].
  apply tr;exists m;trivial.
- apply (Trunc_ind _);intros [n E].
  transitivity (f n);trivial. apply countable_sup_ub.
Qed.

Lemma countable_sup_meet_distr_r : forall a f,
  meet (CountableSup f) a = CountableSup (fun n => meet (f n) a).
Proof.
intros a f.
unfold CountableSup at 1. rewrite SierMeet_sup.
apply sup_extensionality;simpl.
induction n as [|n IHn];simpl.
- reflexivity.
- simpl in IHn. rewrite <-IHn.
  apply meet_join_distr_r.
Qed.

Lemma countable_sup_meet_distr_l : forall a f,
  meet a (CountableSup f) = CountableSup (fun n => meet a (f n)).
Proof.
intros. rewrite (commutativity (f:=meet)),countable_sup_meet_distr_r.
apply ap,path_forall. intros n. apply commutativity.
Qed.

Section enumerable_sup.
Universe UA.
Variable A : Type@{UA}.

Context `{Enumerable A}.

Definition EnumerableSup@{} (f : A -> Sier)  : Sier
  := CountableSup (f ∘ (enumerator A)).

Lemma enumerable_sup_ub' : forall (f:A->Sier) (x:A), f x <= EnumerableSup f.
Proof.
intros f x.
generalize (center _ (enumerator_issurj _ x)). apply (Trunc_ind _).
intros [a []]. clear x. unfold EnumerableSup.
apply (countable_sup_ub (Compose _ _) a).
Qed.

Definition enumerable_sup_ub@{} := enumerable_sup_ub'@{Uhuge Ularge}.

Lemma enumerable_sup_least_ub@{} : forall (f:A->Sier) s, (forall x, f x <= s) ->
  EnumerableSup f <= s.
Proof.
intros f s E. apply countable_sup_least_ub.
intros;apply E.
Qed.

Lemma top_le_enumerable_sup' : forall f, iff@{Set UA UA} (EnumerableSup f)
  (merely (exists x, f x)).
Proof.
intros f;split.
- intros E. apply top_le_countable_sup in E;revert E;
  apply (Trunc_ind _);intros [n E].
  apply tr;econstructor;apply E.
- apply (Trunc_ind _);intros [x E].
  generalize (center _ (enumerator_issurj _ x)). apply (Trunc_ind _).
  intros [a Ea]. destruct Ea.
  apply top_le_countable_sup. apply tr;exists a;apply E.
Qed.

Definition top_le_enumerable_sup@{} := top_le_enumerable_sup'@{Uhuge Ularge}.

Lemma enumerable_sup_meet_distr_l : forall a f,
  meet a (EnumerableSup f) = EnumerableSup (fun n => meet a (f n)).
Proof.
intros. apply countable_sup_meet_distr_l.
Qed.

Lemma enumerable_sup_meet_distr_r : forall a f,
  meet (EnumerableSup f) a = EnumerableSup (fun n => meet (f n) a).
Proof.
intros. apply countable_sup_meet_distr_r.
Qed.

End enumerable_sup.

Lemma not_bot : ~ (@bottom Sier _).
Proof.
intros E.
apply (not_eta_le_bot@{Set} _ tt). apply E.
Qed.

Lemma SierLe_imply : forall a b : Sier, a <= b -> a -> b.
Proof.
intros a b E E';red;transitivity a;trivial.
Qed.

Definition meet_top_l : forall a : Sier, meet top a = a
  := fun _ => idpath.

Lemma meet_top_r : forall a : Sier, meet a top = a.
Proof.
intros. etransitivity;[|apply meet_top_l]. apply commutativity.
Qed.

Definition meet_bot_l : forall a : Sier, meet bottom a = bottom
  := fun _ => idpath.

Lemma meet_bot_r : forall a : Sier, meet a bottom = bottom.
Proof.
intros. etransitivity;[|apply meet_bot_l]. apply commutativity.
Qed.

Definition join_top_l : forall a : Sier, join top a = top
  := fun _ => idpath.

Lemma join_top_r : forall a : Sier, join a top = top.
Proof.
intros. etransitivity;[|apply join_top_l]. apply commutativity.
Qed.

Definition join_bot_l : forall a : Sier, join bottom a = a
  := fun _ => idpath.

Lemma join_bot_r : forall a : Sier, join a bottom = a.
Proof.
intros. etransitivity;[|apply join_bot_l]. apply commutativity.
Qed.

Lemma top_le_eq : forall a : Sier, a -> a = top.
Proof.
intros a E. apply (antisymmetry le);trivial.
apply top_greatest.
Qed.

Lemma bot_eq : forall a : Sier, a <= bottom -> a = bottom.
Proof.
intros a E. apply (antisymmetry le);trivial.
apply bot_least.
Qed.

Lemma imply_le : forall a b : Sier, (a -> b) -> a <= b.
Proof.
apply (partial_ind0 _ (fun a => forall b, _ -> _)).
- intros [] b E. apply E. apply top_greatest.
- intros;apply bot_least.
- intros s IH b E. apply sup_le_r. intros n.
  apply IH. intros En. apply E.
  red. transitivity (s n);trivial. apply sup_is_ub.
Qed.

Class SemiDecide@{i} (A : Type@{i}) := semi_decide : Sier.
Arguments semi_decide A {_}.

Class SemiDecidable@{i} (A : Type@{i}) `{SemiDecide A}
  := semi_decidable : iff@{Set i i} (semi_decide A) A.

Global Instance decidable_semi_decide@{i} (A:Type@{i}) `{Decidable A}
  : SemiDecide A.
Proof.
red. exact (if dec A then top else bottom).
Defined.
Arguments decidable_semi_decide _ {_} /.

Global Instance decidable_semi_decidable@{i} (A:Type@{i}) `{Decidable A}
  : SemiDecidable@{i} A.
Proof.
red. unfold semi_decide;simpl. destruct (dec A) as [E|E];split;intros E'.
- trivial.
- apply top_greatest.
- apply not_bot in E'. destruct E'.
- destruct (E E').
Qed.

Lemma semidecidable_top@{i} {A:Type@{i} } `{SemiDecidable@{i} A}
  : A -> semi_decide A = top.
Proof.
intros E. apply top_le_eq. apply semi_decidable. trivial.
Qed.

Lemma semidecidable_bot@{i} {A:Type@{i} } `{SemiDecidable@{i} A}
  : ~ A -> semi_decide A = bottom.
Proof.
intros E'. apply bot_eq,imply_le. intros E. apply semi_decidable in E.
destruct (E' E).
Qed.

Lemma semi_decide_meet_le@{i} (A:Type@{i}) `{SemiDecidable@{i} A}
  : forall b c, iff@{Set i i} (meet (semi_decide A) b <= c) (A -> b <= c).
Proof.
intros. split.
- intros E Ea. rewrite (semidecidable_top Ea),meet_top_l in E. trivial.
- intros E. apply imply_le;intros E'.
  apply top_le_meet in E';destruct E' as [E1 E2].
  apply semi_decidable in E1. apply SierLe_imply with b;trivial.
  apply E;trivial.
Qed.

Global Instance semi_decide_conj@{i j k} (A:Type@{i}) `{SemiDecide A}
  (B:Type@{j}) `{SemiDecide B}
  : SemiDecide@{k} (A /\ B)
  := meet (semi_decide A) (semi_decide B).
Arguments semi_decide_conj _ {_} _ {_} /.

Global Instance semi_decidable_conj@{i j k} (A:Type@{i}) `{SemiDecidable@{i} A}
  (B:Type@{j}) `{SemiDecidable@{j} B}
  : SemiDecidable@{k} (A /\ B).
Proof.
split.
- intros E;apply top_le_meet in E;destruct E as [E1 E2];
  apply semi_decidable in E1;apply semi_decidable in E2;split;trivial.
- intros [E1 E2];apply top_le_meet;split;apply semi_decidable;trivial.
Qed.

Global Instance semi_decide_disj@{i j k} (A:Type@{i}) `{SemiDecide@{i} A}
  (B:Type@{j}) `{SemiDecide@{j} B}
  : SemiDecide@{k} (hor@{i j k} A B)
  := join (semi_decide A) (semi_decide B).
Arguments semi_decide_disj _ {_} _ {_} /.

Global Instance semi_decidable_disj@{i j k} (A:Type@{i}) `{SemiDecidable@{i} A}
  (B:Type@{j}) `{SemiDecidable@{j} B}
  : SemiDecidable@{k} (hor@{i j k} A B).
Proof.
split.
- intros E;apply top_le_join in E;revert E;apply (Trunc_ind _);intros [E|E];
  apply semi_decidable in E;apply tr;auto.
- apply (Trunc_ind _);intros [E|E];apply top_le_join,tr;[left|right];
  apply semi_decidable;trivial.
Qed.

Global Instance semi_decide_exists@{i j k} (A : Type@{i}) `{Enumerable@{i} A}
  (B : A -> Type@{j}) `{forall x, SemiDecide@{j} (B x)}
  : SemiDecide@{k} (merely@{k} (exists x, B x))
  := EnumerableSup A (fun x => semi_decide (B x)).
Arguments semi_decide_exists A {_} B {_} /.

Global Instance semi_decidable_exists@{i j k} (A : Type@{i}) `{Enumerable@{i} A}
  (B : A -> Type@{j}) `{!forall x, SemiDecide (B x)}
  `{!forall x, SemiDecidable@{j} (B x)}
  : SemiDecidable (merely@{k} (exists x, B x)).
Proof.
red;unfold semi_decide;simpl.
split.
- intros E;apply top_le_enumerable_sup in E.
  revert E;apply (Trunc_ind _);intros [x E];apply tr;exists x;
  apply semi_decidable,E.
- apply (Trunc_ind _);intros [x E];apply top_le_enumerable_sup,tr;exists x.
  apply (snd semi_decidable),E.
Qed.

Global Instance semi_decide_sier (a : Sier) : SemiDecide a
  := a.
Arguments semi_decide_sier _ /.

Global Instance semi_decidable_sier (a : Sier) : SemiDecidable a.
Proof.
red. split;trivial.
Qed.

Section interleave.

Definition disjoint (a b : Sier) := a -> b -> Empty.

Lemma disjoint_top_l : forall b, disjoint top b -> b = bottom.
Proof.
intros b E. apply bot_eq. apply imply_le.
intros Eb. apply Empty_ind,E;trivial. apply top_greatest.
Qed.

Lemma disjoint_sup_l : forall s b, disjoint (sup _ s) b ->
  forall n, disjoint (s n) b.
Proof.
intros s b E n E1 E2.
apply E;trivial. apply top_le_sup. apply tr;eauto.
Qed.

Lemma disjoint_le_l : forall a b, disjoint a b -> forall a', a' <= a ->
  disjoint a' b.
Proof.
intros a b E a' Ea E1 E2;apply E;trivial. red; transitivity a';trivial.
Qed.

Definition interleave_aux_seq (s : IncreasingSequence Sier)
  (Is : forall (n : nat) (b : Sier),
       disjoint (s n) b -> partial bool)
  (Isle : forall (n : nat) (b : Sier) (Ea : disjoint (s n) b)
         (Ea' : disjoint (s (S n)) b), (Is n b Ea) ≤ (Is (S n) b Ea'))
  (b : Sier)
  (E : disjoint (sup Unit s) b)
  : IncreasingSequence (partial bool).
Proof.
simple refine (Build_IncreasingSequence _ _).
- intros n. apply (Is n b).
  apply disjoint_sup_l;trivial.
- simpl. auto.
Defined.

Definition interleave_inductors : Inductors Unit
  (fun a => forall b, disjoint a b -> sigT (fun s : partial bool =>
    partial_map (const false) b <= s))
  (fun a a' f g E => forall b Ea Ea', (f b Ea).1 <= (g b Ea').1).
Proof.
simple refine (Build_Inductors _ _ _ _ _ _ _ _ _ _ _ _);simpl.
- intros [] b E. exists (eta _ true).
  rewrite (disjoint_top_l _ E). apply bot_least.
- intros b _. exists (partial_map (const false) b).
  reflexivity.
- intros s Is Isle b E.
  simple refine (existT _ _ _);simpl;
  [apply sup;apply (interleave_aux_seq s (fun n b E => (Is n b E).1) Isle b E)|].
  etransitivity;[|apply (sup_is_ub _ _ 0)].
  simpl. apply Is.
- intros a f b Ea Ea'.
  assert (Hrw : Ea = Ea') by apply path_ishprop.
  apply (ap (f b)) in Hrw. apply (ap pr1) in Hrw. rewrite Hrw;reflexivity.
- simpl. intros x f b _ E.
  apply f.
- simpl;intros s x Ex fs fs_increasing fb Eb n a Ea Ea'.
  pose proof (fun b Ea Ea' => sup_le_l _ _ _ (Eb b Ea Ea')) as E;
  simpl in E.
  etransitivity;[|simple refine (E _ _ _ n);eapply disjoint_le_l;eauto].
  set (Esup := disjoint_sup_l _ _ _ _).
  assert (Hrw : Ea = Esup) by apply path_ishprop.
  apply (ap (fs n a)),(ap pr1) in Hrw. rewrite <-Hrw;reflexivity.
- simpl. intros s x Ex fs fs_incr fx IHs b ??.
  apply sup_le_r. intros n;simpl.
  auto.
- simpl. intros x y fx fy Ex Ey.
  destruct (partial_antisymm Unit x y Ex Ey);simpl;clear Ex Ey.
  intros Efx Efy.
  apply path_forall;intros b;apply path_forall;intros Eb;
  apply Sigma.path_sigma_hprop.
  apply (antisymmetry le);trivial.
Defined.

Definition interleave : forall a b : Sier, disjoint a b -> partial bool
  := fun a b E => (partial_rect _ _ _ interleave_inductors a b E).1.

Definition interleave_top_l_rw : forall b E, interleave top b E = eta _ true
  := fun _ _ => idpath.

Definition interleave_le : forall a a', a <= a' -> forall b E E',
  interleave a b E <= interleave a' b E'
  := partialLe_rect _ _ _ interleave_inductors.

Definition interleave_sup_l : forall s b E, interleave (sup _ s) b E =
  sup _ (Build_IncreasingSequence
    (fun n => interleave (s n) b (disjoint_sup_l _ _ E _ ))
    (fun n => interleave_le _ _ (seq_increasing _ _) _ _ _))
  := fun _ _ _ => idpath.

Lemma interleave_top_r_rw : forall a E, interleave a top E = eta _ false.
Proof.
apply (partial_ind0 _ (fun a => forall E, _)).
- intros [] E. apply Empty_ind. apply E;apply reflexivity.
- intros E. reflexivity.
- intros s Es E.
  rewrite interleave_sup_l.
  apply (snd (eta_eq_sup_iff bool _ (Build_IncreasingSequence _ _))).
  apply tr;exists 0. simpl.
  apply Es.
Qed.

Lemma interleave_top_l : forall (a b : Sier) E, a ->
  interleave a b E = eta _ true.
Proof.
intros a b E Ea.
apply top_le_eq in Ea.
symmetry in Ea. destruct Ea. reflexivity.
Qed.

Lemma interleave_top_r : forall(a b : Sier) E, b ->
  interleave a b E = eta _ false.
Proof.
intros a b E Eb.
apply top_le_eq in Eb.
symmetry in Eb. destruct Eb. apply interleave_top_r_rw.
Qed.

Definition interleave_bot_rw : forall E, interleave bottom bottom E = bot _
  := fun _ => idpath.

Lemma interleave_bot : forall a b E, a <= bottom -> b <= bottom ->
  interleave a b E = bot _.
Proof.
intros a b E E1 E2.
apply bot_eq in E1;apply bot_eq in E2.
symmetry in E1;symmetry in E2. destruct E1,E2.
reflexivity.
Qed.

Lemma interleave_le_const_r : forall a b E,
  partial_map (const false) b <= interleave a b E.
Proof.
intros. apply ((partial_rect _ _ _ interleave_inductors a b E).2).
Qed.

Lemma interleave_pr : forall a b E v, interleave a b E = eta _ v ->
  match v with true => a | false => b end.
Proof.
apply (partial_ind0 _ (fun a => forall b E v, _ -> _)).
- intros [] b E v Ev.
  apply (injective (eta _)) in Ev.
  rewrite <-Ev;apply top_greatest.
- intros b E v Ev.
  change (partial_map (const false) b = eta _ v) in Ev.
  clear E;revert b v Ev. apply (partial_ind0 _ (fun b => forall v, _ -> _)).
  + intros [] v E. apply (injective (eta _)) in E.
    rewrite <-E;apply top_greatest.
  + intros v E. change (bot _ = eta _ v) in E.
    apply Empty_ind,(not_eta_le_bot bool v). rewrite E;reflexivity.
  + intros s IHs v E.
    unfold partial_map in E;rewrite partial_bind_sup_l in E.
    apply (eta_eq_sup_iff _) in E.
    revert E;apply (Trunc_ind _);intros [n E].
    simpl in E. apply IHs in E.
    destruct v;trivial.
    apply top_le_sup. apply tr;exists n;trivial.
- intros s IHs b E v Ev.
  rewrite interleave_sup_l in Ev.
  apply (eta_eq_sup_iff _) in Ev. simpl in Ev.
  revert Ev;apply (Trunc_ind _);intros [n Ev].
  apply IHs in Ev. destruct v;trivial.
  apply top_le_sup. apply tr;exists n;trivial.
Qed.

End interleave.

End contents.

Arguments semi_decide A {_}.
Arguments decidable_semi_decide _ {_} /.
Arguments semi_decide_conj {_} _ {_} _ {_} /.
Arguments semi_decide_disj {_} _ {_} _ {_} /.
Arguments semi_decide_sier _ /.
Arguments semi_decide_exists {_} A {_} B {_} /.


Require Import List Arith Ascii String.
Import ListNotations.
Open Scope string_scope.

Inductive prim := PtrIncr | PtrDecr | Incr | Decr | Get.

Inductive stmt :=
| SNil : stmt
| Prim : prim -> stmt -> stmt
| Put : stmt -> stmt
| Loop : stmt -> stmt -> stmt.

Fixpoint parse' (str : string) :=
  match str with
  | "" => (SNil, nil)
  | String x xs =>
    let (body, rest) := parse' xs in
    match x with
    | ">"%char => (Prim PtrIncr body, rest)
    | "<"%char => (Prim PtrDecr body, rest)
    | "+"%char => (Prim Incr body, rest)
    | "-"%char => (Prim Decr body, rest)
    | ","%char => (Prim Get body, rest)
    | "."%char => (Put body, rest)
    | "["%char =>
      match rest with
      | nil => (Loop body SNil, nil)
      | cons s rest' => (Loop body s, rest')
      end
    | "]"%char => (SNil, cons body rest)
    | _ => (SNil, nil)
    end
  end.

Definition parse str := fst (parse' str).

Definition run_prim (env : (nat -> nat) * nat * list nat) p :=
  let '(data, ptr, input) := env in
  match p with
  | PtrIncr => (data, S ptr, input)
  | PtrDecr => (data, pred ptr, input)
  | Incr => (fun i => if Nat.eq_dec i ptr then S (data ptr) else data i,
                      ptr, input)
  | Decr => (fun i => if Nat.eq_dec i ptr then pred (data ptr) else data i,
                      ptr, input)
  | Get =>
    match input with
    | [] => env
    | x::rest => (fun i => if Nat.eq_dec i ptr then x else data i,
                           ptr, rest)
    end
  end.

Fixpoint append (s1 s2 : stmt) :=
  match s1 with
  | SNil => s2
  | Prim p s => Prim p (append s s2)
  | Put s => Put (append s s2)
  | Loop b s => Loop b (append s s2)
  end.

Ltac run env c' :=
  let c := eval compute in c' in
  match env with
  | (?data, ?ptr, ?input) =>
    match c with
    | SNil => idtac
    | Prim ?p ?c' =>
      let env' := eval compute in (run_prim (data,ptr,input) p) in
      run env' c'
    | Put ?c' =>
      let x := eval compute in (data ptr) in
      idtac x;
      run env c'
    | Loop ?c1 ?c2 =>
      let x := eval compute in (Nat.eq_dec (data ptr) 0) in
      match x with
      | left _ => run env c2
      | right _ => run env (append c1 (Loop c1 c2))
      end
    end
  end.

Goal True.
  run ((fun _:nat=>0), 0, [4;3]) (parse ",>,<[-<+>]<.").
  run ((fun _:nat=>0), 0, [3;3]) (parse ",>,<[->[->>+<<]>>[-<+<+>>]<<<]>>.").
  run ((fun _:nat=>0), 0, @nil nat) (parse "+[>.+<]").
Abort.


Set Implicit Arguments.
Set Asymmetric Patterns.

Require Import CoqStock.comparable.

Require Import Reexamined.compare_regex.
Require Import Reexamined.nullable.
Require Import Reexamined.regex.

(* simplified is a property that a regex's ors are somewhat simplified *)
Fixpoint simplified {A: Type} {cmp: comparable A} (r: regex A) : Prop :=
  match r with
  | fail => True
  | empty => True
  | char _ => True
  | or s t =>
    simplified s
    /\ simplified t
    /\ compare_regex s t = Lt
    /\ match s with
       | or _ _ => False
       | _ => True
       end
    /\ match t with
       | or tl _ => compare_regex s tl = Lt
       | _ => True
       end
  | and s t => simplified s /\ simplified t
  | concat s t => simplified s /\ simplified t
  | not s => simplified s
  | star s => simplified s
  end.

(*
(or (char x1) (or (char x2) (or (char x3) (char x4))))
or
- x1
- or
  - x2
  - or
    - x3
    - x4
*)
Lemma test_simplified_or_all_left_in_order : forall {A: Type} {cmp: comparable A} (x1 x2 x3 x4: A)
  (p12: compare x1 x2 = Lt)
  (p23: compare x2 x3 = Lt)
  (p34: compare x3 x4 = Lt),
  simplified (or (char x1) (or (char x2) (or (char x3) (char x4)))) -> True.
Proof.
intros.
firstorder.
Qed.

(*
(or (char x1) (or (char x2) (or (char x2) (char x1))))
or
- x1
- or
  - x2
  - or
    - x2
    - x1
*)
Lemma test_simplified_or_all_left_out_of_order : forall
  {A: Type}
  {cmp: comparable A}
  (x1 x2 x3 x4: A)
  (p12: compare x1 x2 = Lt)
  (p23: compare x2 x3 = Lt)
  (p34: compare x3 x4 = Lt),
  simplified (or (char x1) (or (char x3) (or (char x2) (char x4)))) -> False.
Proof.
intros x cmp.
intros x1 x2 x3 x4.
intros p12 p23 p34.
simpl.
firstorder.
assert (p := proof_compare_lt_trans x2 x3 x2 p23 H7).
rewrite proof_compare_eq_reflex in p.
discriminate.
Qed.

(*
(or (or (char x1) (char x2)) (or (char x3) (char x4)))
or
  - or
    - x1
    - x2
  - or
    - x3
    - x4
*)
Lemma test_simplified_or_symmetric: forall {A: Type} {cmp: comparable A} (x1 x2 x3 x4: A)
  (p12: compare x1 x2 = Lt)
  (p23: compare x2 x3 = Lt)
  (p34: compare x3 x4 = Lt),
  simplified (or (or (char x1) (char x2)) (or (char x3) (char x4))) -> False.
Proof.
intros x cmp.
intros x1 x2 x3 x4 p12 p23 p34.
simpl.
firstorder.
Qed.