Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.btauto.Btauto.
Require Import Coq.Program.Equality.
Local Open Scope bool_scope.

Require Import KA.Finite.
Require Import KA.Booleans.
Require Import KA.Terms.
Require Import KA.Vectors.
Require Import KA.Automata.
Require Import KA.Antimirov.
Require Import KA.Scope.
Local Open Scope ka_scope.

Section StructureDefinitions.
  Record monoid {X: Type} := {
    monoid_compose: X -> X -> X;
    monoid_unit: X;

    monoid_compose_assoc:
      forall (x1 x2 x3: X),
        monoid_compose (monoid_compose x1 x2) x3 =
        monoid_compose x1 (monoid_compose x2 x3);
    monoid_unit_left:
      forall (x: X),
      monoid_compose x monoid_unit = x;
    monoid_unit_right:
      forall (x: X),
      monoid_compose monoid_unit x = x;
  }.
  Arguments monoid X : clear implicits.

  Record kleene_algebra {X: Type} := {
    kleene_monoid: monoid X;
    kleene_plus: X -> X -> X;
    kleene_star: X -> X;
    kleene_zero: X;

    kleene_unit := monoid_unit kleene_monoid;
    kleene_multiply := monoid_compose kleene_monoid;

    kleene_plus_assoc:
      forall (x1 x2 x3: X),
        kleene_plus (kleene_plus x1 x2) x3 =
        kleene_plus x1 (kleene_plus x2 x3);
    kleene_plus_unit:
      forall (x: X),
        kleene_plus x kleene_zero = x;
    kleene_plus_idempotent:
      forall (x: X),
        kleene_plus x x = x;
    kleene_plus_commute:
      forall (x1 x2: X),
        kleene_plus x1 x2 = kleene_plus x2 x1;
    kleene_multiply_zero_left:
      forall (x: X),
        kleene_multiply kleene_zero x = kleene_zero;
    kleene_multiply_zero_right:
      forall (x: X),
        kleene_multiply x kleene_zero = kleene_zero;
    kleene_distribute_left:
      forall (x1 x2 x3: X),
        kleene_multiply x1 (kleene_plus x2 x3) =
        kleene_plus (kleene_multiply x1 x2) (kleene_multiply x1 x3);
    kleene_distribute_right:
      forall (x1 x2 x3: X),
        kleene_multiply (kleene_plus x1 x2) x3 =
        kleene_plus (kleene_multiply x1 x3) (kleene_multiply x2 x3);
    kleene_star_unroll:
      forall (x: X),
        kleene_plus kleene_unit (kleene_multiply x (kleene_star x)) =
        kleene_star x;
    kleene_star_fixpoint:
      forall (x1 x2 x3: X),
        kleene_plus (kleene_plus (kleene_multiply x1 x2) x3) x2 = x2 ->
        kleene_plus (kleene_multiply (kleene_star x1) x3) x2 = x2
  }.
  Arguments kleene_algebra X : clear implicits.
End StructureDefinitions.

Arguments monoid X : clear implicits.
Arguments kleene_algebra X : clear implicits.

Section StructurePowerset.
  Context {A: Type}.
  Notation term := (term A).

  Definition powerset_multiplication
    {X: Type}
    `{Finite X}
    (M: monoid X)
    (xs1 xs2: X -> bool)
    (x: X)
  :
    bool
  :=
    disj (
      map (fun '(x1, x2) =>
        finite_eqb x (monoid_compose M x1 x2) &&
        xs1 x1 && xs2 x2
      )
      (list_prod finite_enum finite_enum)
    )
  .

  Lemma powerset_multiplication_characterise
    {X: Type}
    `{Finite X}
    (M: monoid X)
    (x1 x2: X -> bool)
    (x: X)
  :
    powerset_multiplication M x1 x2 x = true <->
    exists (x1' x2': X),
      x1 x1' = true /\
      x2 x2' = true /\
      monoid_compose M x1' x2' = x
  .
  Proof.
    unfold powerset_multiplication.
    rewrite disj_true, in_map_iff.
    split; intros.
    - destruct H0 as [(x1', x2') [? ?]].
      repeat rewrite Bool.andb_true_iff in H0.
      destruct H0 as [[? ?] ?].
      apply finite_eqb_eq in H0.
      now exists x1', x2'.
    - destruct H0 as [x1' [x2' [? [? ?]]]].
      exists (x1', x2').
      repeat rewrite Bool.andb_true_iff; intuition.
      + now apply finite_eqb_eq.
      + replace (list_prod finite_enum finite_enum)
          with (finite_enum (X := (prod X X)))
          by reflexivity.
        apply finite_cover.
  Qed.

  Program Definition monoid_powerset
    {X: Type}
    `{Finite X}
    (M: monoid X)
  :
    monoid (X -> bool)
  := {|
    monoid_compose := powerset_multiplication M;
    monoid_unit x := finite_eqb x (monoid_unit M);
  |}.
  Next Obligation.
    extensionality x.
    apply ZMicromega.eq_true_iff_eq.
    repeat rewrite powerset_multiplication_characterise.
    split; intros.
    - destruct H0 as [x' [x3' [? [? ?]]]].
      apply powerset_multiplication_characterise in H0.
      destruct H0 as [x1' [x2' [? [? ?]]]]; subst.
      exists x1', (monoid_compose M x2' x3'); intuition.
      + apply powerset_multiplication_characterise.
        now exists x2', x3'.
      + now rewrite monoid_compose_assoc.
    - destruct H0 as [x1' [x' [? [? ?]]]].
      apply powerset_multiplication_characterise in H1.
      destruct H1 as [x2' [x3' [? [? ?]]]]; subst.
      exists (monoid_compose M x1' x2'), x3'; intuition.
      apply powerset_multiplication_characterise.
      now exists x1', x2'.
  Qed.
  Next Obligation.
    extensionality x'.
    apply ZMicromega.eq_true_iff_eq.
    rewrite powerset_multiplication_characterise.
    split; intros.
    - destruct H0 as [x1' [x2' [? [? ?]]]].
      apply finite_eqb_eq in H1; subst.
      now rewrite monoid_unit_left.
    - exists x', (monoid_unit M).
      intuition.
      now apply finite_eqb_eq.
  Qed.
  Next Obligation.
    extensionality x'.
    apply ZMicromega.eq_true_iff_eq.
    rewrite powerset_multiplication_characterise.
    split; intros.
    - destruct H0 as [x1' [x2' [? [? ?]]]].
      apply finite_eqb_eq in H0; subst.
      now rewrite monoid_unit_right.
    - exists (monoid_unit M), x'.
      intuition.
      now apply finite_eqb_eq.
  Qed.

  Program Instance subset_order
    (X: Type)
  :
    PartialOrderZero (X -> bool)
  := {|
    partial_order_rel xs1 xs2 := forall x, xs1 x = true -> xs2 x = true;
    partial_order_zero x := false;
  |}.
  Next Obligation.
    extensionality x.
    apply ZMicromega.eq_true_iff_eq.
    intuition.
  Qed.

  Definition powerset_union
    {X: Type}
    (xs1 xs2: X -> bool)
    (x: X)
  :=
    xs1 x || xs2 x
  .

  Definition powerset_bottom
    {X: Type}
    (x: X)
  :
    bool
  :=
    false
  .

  Definition kleene_star_step
    {X: Type}
    `{Finite X}
    (M: monoid X)
    (xs xs': X -> bool)
  :
    X -> bool
  :=
    powerset_union (monoid_compose (monoid_powerset M) xs xs')
                   (monoid_unit (monoid_powerset M))
  .

  Lemma powerset_union_characterise
    {X: Type}
    (xs1 xs2: X -> bool)
    (x: X)
  :
    powerset_union xs1 xs2 x = true <->
    xs1 x = true \/ xs2 x = true
  .
  Proof.
    unfold powerset_union.
    now rewrite Bool.orb_true_iff.
  Qed.

  Lemma powerset_union_order
    {X: Type}
    (xs1 xs2: X -> bool)
  :
    powerset_union xs1 xs2 = xs2 <->
    partial_order_rel xs1 xs2
  .
  Proof.
    unfold partial_order_rel, powerset_union.
    simpl; split; intros.
    - now rewrite <- H, H0.
    - extensionality x.
      apply ZMicromega.eq_true_iff_eq.
      rewrite Bool.orb_true_iff.
      firstorder.
  Qed.

  Definition kleene_star_step_offset
    {X: Type}
    `{Finite X}
    (M: monoid X)
    (xs1 xs2 xs3: X -> bool)
  :
    X -> bool
  :=
    powerset_union (powerset_multiplication M xs1 xs3) xs2
  .

  Lemma powerset_union_multiply_distribute_right
    {X: Type}
    `{Finite X}
    (M: monoid X)
    (xs1 xs2 xs3: X -> bool)
  :
    powerset_multiplication M (powerset_union xs1 xs2) xs3 =
    powerset_union (powerset_multiplication M xs1 xs3)
                   (powerset_multiplication M xs2 xs3)
  .
  Proof.
    extensionality x'.
    unfold powerset_union.
    apply ZMicromega.eq_true_iff_eq.
    rewrite Bool.orb_true_iff.
    repeat rewrite powerset_multiplication_characterise.
    setoid_rewrite Bool.orb_true_iff.
    firstorder.
  Qed.

  Lemma powerset_union_multiply_distribute_left
    {X: Type}
    `{Finite X}
    (M: monoid X)
    (xs1 xs2 xs3: X -> bool)
  :
    powerset_multiplication M xs1 (powerset_union xs2 xs3) =
    powerset_union (powerset_multiplication M xs1 xs2)
      (powerset_multiplication M xs1 xs3)
  .
  Proof.
    extensionality x'.
    unfold powerset_union.
    apply ZMicromega.eq_true_iff_eq.
    rewrite Bool.orb_true_iff.
    repeat rewrite powerset_multiplication_characterise.
    setoid_rewrite Bool.orb_true_iff.
    firstorder.
  Qed.

  Lemma powerset_union_commute
    {X: Type}
    (xs1 xs2: X -> bool)
  :
    powerset_union xs1 xs2 =
    powerset_union xs2 xs1
  .
  Proof.
    extensionality x.
    unfold powerset_union.
    btauto.
  Qed.

  Lemma kleene_star_step_offset_fixpoint
    {X: Type}
    `{Finite X}
    (M: monoid X)
    (xs1 xs2: X -> bool)
  :
    mono_fixpoint (kleene_star_step_offset M xs1 xs2) =
    powerset_multiplication M (mono_fixpoint (kleene_star_step M xs1)) xs2
  .
  Proof.
    unfold mono_fixpoint.
    generalize (@length (X -> bool) finite_enum); intros.
    induction n; simpl in *.
    - extensionality x.
      unfold powerset_multiplication.
      symmetry; apply disj_false; intros.
      apply in_map_iff in H0.
      destruct H0 as [(x1, x2) [? ?]]; subst.
      btauto.
    - rewrite IHn.
      unfold kleene_star_step at 2, kleene_star_step_offset at 1.
      rewrite powerset_union_multiply_distribute_right.
      replace (powerset_multiplication M)
        with (monoid_compose (monoid_powerset M))
        by reflexivity.
      rewrite monoid_compose_assoc.
      now rewrite monoid_unit_right.
  Qed.

  Lemma powerset_multiplication_mono
    {X: Type}
    `{Finite X}
    (M: monoid X)
    (xs1 xs2 xs1' xs2': X -> bool)
  :
    partial_order_rel xs1 xs1' ->
    partial_order_rel xs2 xs2' ->
    partial_order_rel (powerset_multiplication M xs1 xs2)
                      (powerset_multiplication M xs1' xs2')
  .
  Proof.
    simpl; setoid_rewrite powerset_multiplication_characterise; firstorder.
  Qed.

  Lemma powerset_union_mono
    {X: Type}
    `{Finite X}
    (xs1 xs2 xs1' xs2': X -> bool)
  :
    partial_order_rel xs1 xs1' ->
    partial_order_rel xs2 xs2' ->
    partial_order_rel (powerset_union xs1 xs2)
                      (powerset_union xs1' xs2')
  .
  Proof.
    simpl; unfold powerset_union; setoid_rewrite Bool.orb_true_iff; firstorder.
  Qed.

  Lemma kleene_star_step_mono
    {X: Type}
    `{Finite X}
    (M: monoid X)
    (xs: X -> bool)
  :
    monotone (kleene_star_step M xs)
  .
  Proof.
    constructor; intros.
    unfold kleene_star_step.
    apply powerset_union_mono.
    - apply powerset_multiplication_mono; auto.
      apply partial_order_refl.
    - apply partial_order_refl.
  Qed.

  Lemma kleene_star_step_offset_mono
    {X: Type}
    `{Finite X}
    (M: monoid X)
    (xs1 xs2: X -> bool)
  :
    monotone (kleene_star_step_offset M xs1 xs2)
  .
  Proof.
    constructor; intros.
    unfold kleene_star_step_offset.
    apply powerset_union_mono.
    - apply powerset_multiplication_mono; auto.
      apply partial_order_refl.
    - apply partial_order_refl.
  Qed.

  Program Definition monoid_to_kleene_algebra
    {X: Type}
    `{Finite X}
    (M: monoid X)
  :
    kleene_algebra (X -> bool)
  := {|
    kleene_monoid := monoid_powerset M;
    kleene_zero x := false;
    kleene_plus := powerset_union;
    kleene_star xs := mono_fixpoint (kleene_star_step M xs);
  |}.
  Next Obligation.
    extensionality x'.
    unfold powerset_union.
    btauto.
  Qed.
  Next Obligation.
    extensionality x'.
    unfold powerset_union.
    btauto.
  Qed.
  Next Obligation.
    extensionality x'.
    unfold powerset_union.
    btauto.
  Qed.
  Next Obligation.
    apply powerset_union_commute.
  Qed.
  Next Obligation.
    extensionality x'.
    unfold powerset_multiplication.
    apply disj_false; intros.
    apply in_map_iff in H0.
    destruct H0 as [(x1, x2') [? ?]]; subst.
    btauto.
  Qed.
  Next Obligation.
    extensionality x'.
    unfold powerset_multiplication.
    apply disj_false; intros.
    apply in_map_iff in H0.
    destruct H0 as [(x1, x2') [? ?]]; subst.
    btauto.
  Qed.
  Next Obligation.
    apply powerset_union_multiply_distribute_left.
  Qed.
  Next Obligation.
    apply powerset_union_multiply_distribute_right.
  Qed.
  Next Obligation.
    transitivity (kleene_star_step M x (mono_fixpoint (kleene_star_step M x))).
    - unfold kleene_star_step.
      now rewrite powerset_union_commute.
    - apply mono_fixpoint_fixpoint.
      apply kleene_star_step_mono.
  Qed.
  Next Obligation.
    apply powerset_union_order.
    apply powerset_union_order in H0.
    rewrite <- kleene_star_step_offset_fixpoint.
    apply mono_fixpoint_least.
    - apply kleene_star_step_offset_mono.
    - now unfold kleene_star_step_offset.
  Qed.

  Equations kleene_interp
    {X: Type}
    (K: kleene_algebra X)
    (f: A -> X)
    (t: term)
  :
    X
  := {
    kleene_interp K f zero := kleene_zero K;
    kleene_interp K f one := kleene_unit K;
    kleene_interp K f (letter a) := f a;
    kleene_interp K f (t1 + t2) :=
      kleene_plus K (kleene_interp K f t1) (kleene_interp K f t2);
    kleene_interp K f (t1 ;; t2) :=
      kleene_multiply K (kleene_interp K f t1) (kleene_interp K f t2);
    kleene_interp K f (t*) :=
      kleene_star K (kleene_interp K f t)
  }.

  Lemma kleene_interp_sound
    {X: Type}
    (K: kleene_algebra X)
    (f: A -> X)
    (t1 t2: term)
  :
    t1 == t2 ->
    kleene_interp K f t1 = kleene_interp K f t2
  .
  Proof.
    intros; dependent induction H;
    autorewrite with kleene_interp in *;
    try congruence; try apply K.
    - now rewrite kleene_plus_assoc.
    - unfold kleene_multiply.
      now rewrite monoid_compose_assoc.
    - unfold kleene_multiply, kleene_unit.
      now rewrite monoid_unit_left.
    - unfold kleene_multiply, kleene_unit.
      now rewrite monoid_unit_right.
    - rewrite kleene_plus_commute.
      now rewrite kleene_star_unroll.
    - now apply kleene_star_fixpoint.
  Qed.
End StructurePowerset.

Section StructureFromAutomaton.
  Context {A: Type}.
  Notation automaton := (automaton A).
  Notation term := (term A).

  Program Definition automaton_monoid
    {Q: Type}
    `{Finite Q}
    (aut: automaton Q)
  :
    monoid (Q -> Q -> bool)
  := {|
    monoid_compose := matrix_product_bool;
    monoid_unit := finite_eqb;
  |}.
  Next Obligation.
    apply matrix_product_bool_associative.
  Qed.
  Next Obligation.
    apply matrix_product_bool_unit_right.
  Qed.
  Next Obligation.
    apply matrix_product_bool_unit_left.
  Qed.

  Definition automaton_kleene_algebra
    {Q: Type}
    `{Finite Q}
    (aut: automaton Q)
  :
    kleene_algebra ((Q -> Q -> bool) -> bool)
  :=
    monoid_to_kleene_algebra (automaton_monoid aut)
  .

  Definition automaton_kleene_algebra_embed
    {Q: Type}
    `{Finite Q}
    (aut: automaton Q)
    (a: A)
  :
    (Q -> Q -> bool) -> bool
  :=
    finite_eqb (aut_transitions aut a)
  .

  Lemma kleene_interp_witness_construct
    {Q: Type}
    `{Finite Q}
    (aut: automaton Q)
    (t: term)
    (m: Q -> Q -> bool)
  :
    kleene_interp (automaton_kleene_algebra aut)
                  (automaton_kleene_algebra_embed aut)
                  t m = true ->
    exists w,
      automaton_transition_matrix aut w = m /\
      term_matches t w
  .
  Proof.
    revert aut m; dependent induction t; intros;
    autorewrite with derivative_write in H0;
    autorewrite with kleene_interp in H0;
    simpl in H0.
    - discriminate.
    - unfold kleene_unit in H0; simpl in H0.
      apply finite_eqb_eq in H0; subst.
      exists nil; intuition.
      constructor.
    - unfold automaton_kleene_algebra_embed in H0.
      apply finite_eqb_eq in H0; subst.
      exists (a :: nil).
      autorewrite with automaton_transition_matrix.
      rewrite matrix_product_bool_unit_right; intuition.
      constructor.
    - apply powerset_union_characterise in H0; destruct H0.
      + apply IHt1 in H0.
        destruct H0 as [w [? ?]].
        exists w; intuition.
        now constructor.
      + apply IHt2 in H0.
        destruct H0 as [w [? ?]].
        exists w; intuition.
        now constructor.
    - unfold kleene_multiply in H0; simpl in H0.
      apply powerset_multiplication_characterise in H0.
      destruct H0 as [m1 [m2 [? [? ?]]]]; subst.
      apply IHt1 in H0; destruct H0 as [w1 [? ?]]; subst.
      apply IHt2 in H1; destruct H1 as [w2 [? ?]]; subst.
      exists (w1 ++ w2); simpl.
      rewrite automaton_transition_matrix_app; intuition.
      now constructor.
    - unfold mono_fixpoint in H0; revert H0.
      match goal with
      | |- context [ length ?l ] => generalize (length l)
      end.
      intros n; revert m.
      induction n; simpl; intros.
      + discriminate.
      + unfold kleene_star_step in H0 at 1.
        apply powerset_union_characterise in H0.
        simpl in H0; destruct H0.
        * apply powerset_multiplication_characterise in H0.
          destruct H0 as [m1 [m2 [? [? ?]]]].
          apply IHn in H1; destruct H1 as [w2 [? ?]]; subst.
          apply IHt in H0; destruct H0 as [w1 [? ?]]; subst.
          exists (w1 ++ w2).
          rewrite automaton_transition_matrix_app.
          intuition (now constructor).
        * exists nil.
          apply finite_eqb_eq in H0; subst.
          intuition constructor.
  Qed.

  Lemma kleene_interp_witness_apply
    {Q: Type}
    `{Finite Q}
    (aut: automaton Q)
    (t: term)
    (w: list A)
  :
    term_matches t w ->
    kleene_interp (automaton_kleene_algebra aut)
                  (automaton_kleene_algebra_embed aut)
                  t
                  (automaton_transition_matrix aut w)
      = true
  .
  Proof.
    intros; revert aut.
    dependent induction H0; intros;
    autorewrite with kleene_interp;
    autorewrite with automaton_transition_matrix;
    simpl.
    - unfold kleene_unit; simpl.
      now apply finite_eqb_eq.
    - unfold automaton_kleene_algebra_embed.
      apply finite_eqb_eq.
      now rewrite matrix_product_bool_unit_right.
    - apply powerset_union_characterise.
      rewrite IHterm_matches; intuition btauto.
    - apply powerset_union_characterise.
      rewrite IHterm_matches; intuition btauto.
    - unfold kleene_multiply; simpl.
      apply powerset_multiplication_characterise.
      exists (automaton_transition_matrix aut w1).
      exists (automaton_transition_matrix aut w2).
      intuition; simpl.
      now rewrite automaton_transition_matrix_app.
    - rewrite <- mono_fixpoint_fixpoint.
      + unfold kleene_star_step.
        apply powerset_union_characterise; right.
        now apply finite_eqb_eq.
      + apply kleene_star_step_mono.
    - rewrite <- mono_fixpoint_fixpoint.
      + unfold kleene_star_step at 1.
        apply powerset_union_characterise; left.
        apply powerset_multiplication_characterise.
        exists (automaton_transition_matrix aut w1).
        exists (automaton_transition_matrix aut w2).
        intuition.
        * specialize (IHterm_matches2 aut).
          now autorewrite with kleene_interp in IHterm_matches2.
        * now rewrite automaton_transition_matrix_app.
      + apply kleene_star_step_mono.
  Qed.
End StructureFromAutomaton.

Section StructureNormalForm.
  Context {A: Type}.
  Context `{Finite A}.
  Notation automaton := (automaton A).
  Notation term := (term A).

  Definition kleene_interp_recombine
    {Q: Type}
    `{Finite Q}
    (aut: automaton Q)
    (q: Q)
  :
    term
  :=
    sum (
       map (automaton_relation_solution aut)
           (filter (kleene_interp (automaton_kleene_algebra aut)
                                  (automaton_kleene_algebra_embed aut)
                                  (compute_automaton_solution aut q))
                   finite_enum)
    )
  .

  Lemma kleene_interp_recombine_characterise
    {Q: Type}
    `{Finite Q}
    (aut: automaton Q)
    (q: Q)
  :
     kleene_interp_recombine aut q == compute_automaton_solution aut q
  .
  Proof.
    unfold kleene_interp_recombine.
    rewrite <- (automaton_sum_accepting_matrices_characterise aut q) at 2.
    unfold automaton_sum_accepting_matrices.
    apply term_lequiv_squeeze.
    - apply sum_lequiv_all; intros.
      apply in_map_iff in H1.
      destruct H1 as [m [? ?]]; subst.
      apply filter_In in H2.
      destruct H2 as [_ ?].
      apply kleene_interp_witness_construct in H1.
      destruct H1 as [w [? ?]].
      apply sum_lequiv_member.
      apply in_map_iff.
      exists m; subst; intuition.
      unfold automaton_accepting_matrices.
      apply filter_In.
      split; [ apply finite_cover |].
      apply automaton_accepts_transition_matrix.
      rewrite <- automaton_least_solution_match.
      + apply H2.
      + rewrite automaton_least_solution_invariant.
        apply compute_automaton_solution_least_solution.
    - apply sum_lequiv_all; intros.
      apply in_map_iff in H1.
      destruct H1 as [? [? ?]]; subst.
      destruct (term_empty (automaton_relation_solution aut x)) eqn:?.
      + apply term_empty_zero in Heqb.
        rewrite Heqb.
        apply term_lequiv_zero.
      + apply term_empty_dec in Heqb.
        destruct Heqb as [w ?].
        * rewrite term_equiv_sound
            with (t2 := automaton_relation_solution' aut x)
            in H1 by (apply automaton_relation_solution_characterise).
          unfold automaton_relation_solution' in H1.
          apply automaton_transition_monad_solution in H1.
          rewrite matrix_product_bool_unit_left in H1; subst.
          apply sum_lequiv_member.
          apply in_map_iff.
          eexists; intuition.
          apply filter_In.
          split; [apply finite_cover |].
          apply kleene_interp_witness_apply.
          unfold automaton_accepting_matrices in H2.
          apply filter_In in H2.
          destruct H2 as [_ ?].
          rewrite automaton_least_solution_match.
          -- apply automaton_accepts_transition_matrix, H1.
          -- rewrite automaton_least_solution_invariant.
             apply compute_automaton_solution_least_solution;
             apply automaton_relation_solution_characterise.
  Qed.

  Lemma term_normal_form_left_pre
    (t1 t2: term)
  :
    let aut1 := automaton_coalesce (automaton_antimirov t1) initial_b in
    let aut2 := automaton_coalesce (automaton_antimirov t2) initial_b in
    let aut := automaton_coproduct aut1 aut2 in
    t1 == compute_automaton_solution aut (inl (inr tt))
  .
  Proof.
    intros.
    rewrite term_roundtrip_invariant at 1.
    unfold term_roundtrip.
    unfold antimirov_solution.
    transitivity (compute_automaton_solution aut1 (inr tt)).
    - subst aut1.
      rewrite (automaton_coalesce_solution _ initial_b (inr tt)).
      unfold automaton_coalesce_import_solution.
      apply sum_equiv_containment; intros t ?.
      + apply in_map_iff in H0.
        destruct H0 as [? [? ?]]; subst.
        apply initial_list in H1.
        apply in_map_iff.
        exists x.
        split; auto.
        apply filter_In.
        split; [apply finite_cover|].
        now apply initial_dec.
      + apply in_map_iff in H0.
        destruct H0 as [? [? ?]]; subst.
        apply filter_In in H1.
        destruct H1 as [_ ?].
        apply in_map_iff.
        exists x.
        split; auto.
        apply initial_list.
        now apply initial_dec.
    - now rewrite (automaton_coproduct_solution_left aut1 aut2 (inr tt)).
  Qed.

  Lemma term_normal_form_left
    (t1 t2: term)
  :
    let aut1 := automaton_antimirov t1 in
    let aut2 := automaton_antimirov t2 in
    let aut := automaton_coproduct (automaton_coalesce aut1 initial_b)
                                   (automaton_coalesce aut2 initial_b) in
    let rels := kleene_interp (automaton_kleene_algebra aut)
                              (automaton_kleene_algebra_embed aut) t1 in
    t1 == sum (map (automaton_relation_solution aut)
                   (filter rels finite_enum))
  .
  Proof.
    intros.
    rewrite term_normal_form_left_pre at 1.
    rewrite <- kleene_interp_recombine_characterise.
    unfold kleene_interp_recombine.
    erewrite kleene_interp_sound.
    - now subst aut1 aut2 aut rels.
    - now rewrite <- term_normal_form_left_pre.
  Qed.

  Lemma term_normal_form_right_pre
    (t1 t2: term)
  :
    let aut1 := automaton_coalesce (automaton_antimirov t1) initial_b in
    let aut2 := automaton_coalesce (automaton_antimirov t2) initial_b in
    let aut := automaton_coproduct aut1 aut2 in
    t2 == compute_automaton_solution aut (inr (inr tt))
  .
  Proof.
    intros.
    rewrite term_roundtrip_invariant at 1.
    unfold term_roundtrip.
    unfold antimirov_solution.
    transitivity (compute_automaton_solution aut2 (inr tt)).
    - subst aut2.
      rewrite (automaton_coalesce_solution _ initial_b (inr tt)).
      unfold automaton_coalesce_import_solution.
      apply sum_equiv_containment; intros t ?.
      + apply in_map_iff in H0.
        destruct H0 as [? [? ?]]; subst.
        apply initial_list in H1.
        apply in_map_iff.
        exists x.
        split; auto.
        apply filter_In.
        split; [apply finite_cover|].
        now apply initial_dec.
      + apply in_map_iff in H0.
        destruct H0 as [? [? ?]]; subst.
        apply filter_In in H1.
        destruct H1 as [_ ?].
        apply in_map_iff.
        exists x.
        split; auto.
        apply initial_list.
        now apply initial_dec.
    - now rewrite (automaton_coproduct_solution_right aut1 aut2 (inr tt)).
  Qed.

  Lemma term_normal_form_right
    (t1 t2: term)
  :
    let aut1 := automaton_antimirov t1 in
    let aut2 := automaton_antimirov t2 in
    let aut := automaton_coproduct (automaton_coalesce aut1 initial_b)
                                   (automaton_coalesce aut2 initial_b) in
    let rels := kleene_interp (automaton_kleene_algebra aut)
                              (automaton_kleene_algebra_embed aut) t2 in
    t2 == sum (map (automaton_relation_solution aut)
                   (filter rels finite_enum))
  .
  Proof.
    intros.
    rewrite term_normal_form_right_pre at 1.
    rewrite <- kleene_interp_recombine_characterise.
    unfold kleene_interp_recombine.
    erewrite kleene_interp_sound.
    - now subst aut1 aut2 aut rels.
    - now rewrite <- term_normal_form_right_pre.
  Qed.
End StructureNormalForm.


#[global]
Set Primitive Projections.
#[global]
Unset Printing Primitive Projection Parameters.

#[global]
Set Universe Polymorphism.

#[global]
Set Default Goal Selector "!".

Require Import Coq.Unicode.Utf8.
Require Import Coq.Program.Tactics.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.

Import IfNotations.
Import ListNotations.

#[universes(cumulative)]
Record span A B := {
  s: Type ;
  π1: s → A ;
  π2: s → B ;
}.
Arguments s {A B}.
Arguments π1 {A B}.
Arguments π2 {A B}.

Definition id A: span A A :=
  {|
  s := A ;
  π1 x := x ;
  π2 x := x ;
  |}.

Definition compose {A B C} (f: span B C) (g: span A B): span A C :=
  {|
  s := { xy | π1 f (fst xy) = π2 g (snd xy) } ;
  π1 xy := π1 g (snd (proj1_sig xy)) ;
  π2 xy := π2 f (fst (proj1_sig xy)) ;
  |}.
Infix "∘" := compose (at level 30).

Inductive ext {A B} (F: span A B): A → B → Type :=
| sup (x: s F): ext F (π1 F x) (π2 F x).

Definition tag {A B} {F: span A B} {C D} (e: ext F C D) :=
  let '(sup _ x) := e in
  x.

(* dependent product basically

 should be like Ran P Q A B = forall x, P(x, A) → Q(x, B)

  x <- P -> A
  ———-
  x <- Q -> B
 *)
Record Ran {C D E} (F: span C D) (G: span C E) := {
  x: D ;
  y: E ;
  p A: ext F A x → ext G A y ;
}.
Arguments x {C D E F G}.
Arguments y {C D E F G}.

Arguments p {C D E F G}.

#[program]
Definition ran {C D E} (F: span C D) (G: span C E): span D E :=
  {|
  s := Ran F G ;
  π1 r := x r ;
  π2 r := y r ;
  |}.
Notation "[ A , B ]" := (ran A B).

Definition codensity {A B} (F: span A B) := [F, F].

Definition codensity_id {A B} (F: span A B) (x: B): ext (codensity F) x x.
Proof.
  cbn in *.
  refine (sup (codensity F) {| x := x ; y := x |}).
  intros.
  apply X.
Defined.

Definition codensity_compose {K L} {F: span K L} {A B C}: ext (codensity F) B C → ext (codensity F) A B → ext (codensity F) A C.
Proof.
  intros f g.
  destruct f as [f].
  cbn in *.
  (* A little odd finagling here is required *)
  remember (x f) as B'.
  destruct g as [g].
  cbn in *.
  refine (sup (codensity F) {| x := x g ; y := y f |}).
  intros.
  apply (p f).
  rewrite <- HeqB'.
  apply (p g).
  auto.
Defined.

Definition eval {A B} (F: span A B) (G: span A B): s ([ F , G ] ∘ F) → s G.
Proof.
  cbn in *.
  intros [[[?] ?] ?].
  cbn in *.
  refine (tag (p0 _ _)).
  Unshelve.
  2: {
    apply (π1 F s0).
  }
  subst.
  apply (sup F s0).
Defined.

(* Garbage prototype *)

Inductive term :=
| var (x: string)
| lam (x: string) (e: term)
| app (e0 e1: term).

Inductive rule :=
| var_rule (n: nat) (x: string)
| lam_rule (n: nat) (x: string) (e: term)
| app_rule (n: nat) (e0 e1: term)
.

Definition vars (r: rule): nat * term :=
  match r with
  | var_rule n x => (S n, var x)
  | lam_rule n x e => (n, lam x e)
  | app_rule n e0 e1 => (n, app e0 e1)
  end.

Definition Vars := {| π1 x := fst (vars x) ; π2 x := snd (vars x) |}.

Definition VARS := ext (codensity Vars).

Definition VARS_id: ∀ x, VARS x x := codensity_id Vars.
Definition VARS_compose {A B C}: VARS B C → VARS A B → VARS A C := @codensity_compose _ _ Vars _ _ _.

Definition VARS_rule {x y} (p: ∀ A, ext Vars A x → ext Vars A y): VARS _ _ := sup (codensity Vars) {| p := p |}.


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

Require Import Setoid.
Require Import List.

Require Import basics.
Require Import categories.
Require Import preord.
Require Import sets.
Require Import finsets.
Require Import esets.
Require Import effective.
Require Import plotkin.
Require Import profinite.
Require Import embed.
Require Import directed.
Require Import cont_functors.
Require Import cpo.

(**  * Bilimits and fixpoints of continuous functors.

       Here we construct the colimit of directed systems.
       The carrier of the bilimit is the disjoint union
       of the directed system.  The order on the bilimit
       elements holds if there exists some larger poset
       into which both elements can be embedded where
       the ordering holds.
  *)
Section bilimit.
  Variable hf:bool.
  Variable I:directed_preord.
  Variable DS:directed_system I (EMBED hf).

  Record limset :=
    LimSet
    { idx : I
    ; elem : ds_F DS idx
    }.

  Definition limset_order (x y:limset) :=
    exists k (Hxk : idx x ≤ k) (Hyk : idx y ≤ k),
      ds_hom DS (idx x) k Hxk (elem x)
      ≤ ds_hom DS (idx y) k Hyk (elem y).

  (**  This lemma shows that if two elements compare in any larger poset,
       the compare in _every_ larger poset.
    *)
  Lemma limset_order_exists_forall x y :
    limset_order x y <->
    forall k (Hxk : idx x ≤ k) (Hyk : idx y ≤ k),
      ds_hom DS (idx x) k Hxk (elem x)
      ≤ ds_hom DS (idx y) k Hyk (elem y).
  Proof.
    split; intros.
    - destruct H as [k' [Hxk' [Hyk' ?]]].
      destruct (choose_ub I k k') as [q [??]].
      assert (Hxq : idx x ≤ q)
         by (transitivity k; auto).
      assert (Hyq : idx y ≤ q)
         by (transitivity k; auto).
    assert (ds_hom DS (idx x) q Hxq (elem x) ≤
            ds_hom DS (idx y) q Hyq (elem y)).
    { rewrite <- (ds_compose DS (idx x) k' q Hxk' H1 Hxq).
      rewrite <- (ds_compose DS (idx y) k' q Hyk' H1 Hyq).
      simpl. apply embed_mono. auto.
    }
    rewrite <- (ds_compose DS (idx x) k q Hxk H0 Hxq) in H2.
    rewrite <- (ds_compose DS (idx y) k q Hyk H0 Hyq) in H2.
    simpl in H2.

    apply embed_reflects in H2. auto.

    - destruct (choose_ub I (idx x) (idx y)) as [k [??]].
      exists k, H0, H1.
      apply H.
  Qed.

  Lemma limset_order_refl (x:limset) : limset_order x x.
  Proof.
    exists (idx x). exists (ord_refl _ _).  exists (ord_refl _ _). auto.
  Qed.

  Lemma limset_order_trans (x y z:limset) :
    limset_order x y -> limset_order y z -> limset_order x z.
  Proof.
    intros [k1 [Hxk1 [Hyk1 ?]]].
    intros [k2 [Hyk2 [Hzk2 ?]]].
    destruct (choose_ub I k1 k2) as [k [??]].
    assert (Hxk : idx x ≤ k) by (transitivity k1; auto).
    assert (Hyk : idx y ≤ k) by (transitivity k1; auto).
    assert (Hzk : idx z ≤ k) by (transitivity k2; auto).
    exists k. exists Hxk. exists Hzk.
    transitivity (ds_hom DS (idx y) k Hyk (elem y)).
    - rewrite <- (ds_compose DS (idx x) k1 k Hxk1 H1 Hxk).
      rewrite <- (ds_compose DS (idx y) k1 k Hyk1 H1 Hyk).
      simpl. apply embed_mono. auto.
    - rewrite <- (ds_compose DS (idx y) k2 k Hyk2 H2 Hyk).
      rewrite <- (ds_compose DS (idx z) k2 k Hzk2 H2 Hzk).
      simpl. apply embed_mono. auto.
  Qed.

  Definition limord_mixin :=
    Preord.Mixin limset limset_order limset_order_refl limset_order_trans.

  Canonical Structure limord := Preord.Pack limset limord_mixin.

  (**  The order is decidable.
    *)
  Lemma limset_order_dec (x y:limset) :
    { limset_order x y } + { ~limset_order x y }.
  Proof.
    destruct (choose_ub I (idx x) (idx y)) as [k [??]].
    destruct (eff_ord_dec _ (PLT.effective (ds_F DS k))
                (ds_hom DS (idx x) k H (elem x))
                (ds_hom DS (idx y) k H0 (elem y))).
    - left.
      exists k. exists H. exists H0. auto.
    - right. intro.
      rewrite limset_order_exists_forall in H1.
      apply n. apply H1.
  Qed.

  (**  Furthermore, all the elements can be enumerated.
    *)
  Definition limset_enum : eset limord :=
    fun n => let (p,q) := pairing.unpairing n in
         match eff_enum _ (dir_effective I) p with
         | Some i =>
              match eff_enum _ (PLT.effective (ds_F DS i)) q with
              | Some x => Some (LimSet i x)
              | None => None
              end
         | None => None
         end.

  (** Thus, the bilimit is an effective order. *)
  Program Definition limord_effective : effective_order limord :=
    EffectiveOrder limord limset_order_dec limset_enum _.
  Next Obligation.
    intros [i x].
    generalize (eff_complete _ (dir_effective I) i).
    intros [p ?].
    case_eq (eff_enum I (dir_effective I) p); intros.
    2: rewrite H0 in H; elim H.
    rewrite H0 in H.
    destruct H.
    set (x' := ds_hom DS i c H x).
    assert (x' ∈ eff_enum _ (PLT.effective (ds_F DS c)))
      by apply eff_complete.
    destruct H2 as [q ?].
    case_eq (eff_enum _ (PLT.effective (ds_F DS c)) q); intros.
    2: rewrite H3 in H2; elim H2.
    rewrite H3 in H2.
    exists (pairing.pairing (p,q)).
    unfold limset_enum.
    rewrite pairing.unpairing_pairing.
    rewrite H0. rewrite H3.
    split.
    - exists c. simpl. exists H. exists (ord_refl _ _).
      rewrite (ds_ident DS c (ord_refl _ _)). simpl. auto.
    - exists c. simpl. exists (ord_refl _ _). exists H.
      rewrite (ds_ident DS c (ord_refl _ _)). simpl. auto.
  Qed.

  (**  Moreover, the bilimit has normal sets.
    *)
  Lemma limord_has_normals : has_normals limord limord_effective hf.
  Proof.
    hnf. intros.
    destruct (choose_ub_set I (map idx X)) as [k ?].

    assert { M | X ≈ map (LimSet k) M }.
    { clear Hinh.
      induction X.
      - exists nil. simpl; auto.
      - destruct IHX as [M ?].
        + hnf; intros. apply u.
          simpl. apply cons_elem; auto.
        + assert (Hak : idx a ≤ k).
          { apply u. simpl. apply cons_elem; auto. }
          exists (ds_hom DS (idx a) k Hak (elem a) :: M).
          split.
          * hnf; simpl; intros.
            apply cons_elem in H.
            destruct H.
            ** rewrite H.
               apply cons_elem. left.
               split.
               *** exists k; simpl. exists Hak. exists (ord_refl _ _).
                   rewrite (ds_ident DS k (ord_refl _ _)).
                   simpl. auto.
               *** exists k; simpl. exists (ord_refl _ _). exists Hak.
                   rewrite (ds_ident DS k (ord_refl _ _)).
                   simpl. auto.
            ** apply cons_elem. right.
               rewrite <- e; auto.
          * hnf; intros.
            simpl in H.
            apply cons_elem in H.
            destruct H.
            ** rewrite H.
               apply cons_elem. left.
               split.
               *** exists k; simpl. exists (ord_refl _ _). exists Hak.
                   rewrite (ds_ident DS k (ord_refl _ _)).
                   simpl. auto.
               *** exists k; simpl. exists Hak. exists (ord_refl _ _).
                   rewrite (ds_ident DS k (ord_refl _ _)).
                   simpl. auto.
            ** apply cons_elem. right.
               rewrite e; auto.
    }

    destruct X0 as [M HM].
    exists (map (LimSet k) (mub_closure (PLT.plotkin (ds_F DS k)) M)).
    split.
    - hnf; intros.
      rewrite HM in H.
      destruct H as [q [??]].
      apply in_map_iff in H.
      destruct H as [q' [??]].
      subst q.
      assert (q' ∈ mub_closure (PLT.plotkin (ds_F DS k)) M).
      { apply mub_clos_incl. exists q'; auto. }
      destruct H as [x [??]].
      rewrite H0.
      exists (LimSet k x).
      split.
      + apply in_map. auto.
      + split.
        * exists k; simpl.
          exists (ord_refl _ _ ).
          exists (ord_refl _ _ ).
          apply embed_mono; auto.
        * exists k; simpl.
          exists (ord_refl _ _ ).
          exists (ord_refl _ _ ).
          apply embed_mono; auto.
    - split.
      + revert Hinh.
        unfold inh.
        pattern hf at 1 2. case hf; auto.
        intros [x ?].
        rewrite HM in H.
        destruct H as [x' [??]].
        apply in_map_iff in H.
        destruct H as [q [??]].
        subst x'.
        assert (q ∈ mub_closure (PLT.plotkin (ds_F DS k)) M).
        { apply mub_clos_incl. exists q; split; auto. }
        destruct H as [q' [??]].
        exists (LimSet k q').
        exists (LimSet k q').
        split; auto.
        apply in_map. auto.

      + intros.
        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 (choose_ub I (idx z) k) as [k' [Hzk' Hkk']].
             generalize (embed_directed0 (ds_hom DS k k' Hkk')
                                         (ds_hom DS (idx z) k' Hzk' (elem z))).
             rewrite H at 1.
             intros [q ?].
             destruct (mub_complete (PLT.plotkin (ds_F DS k)) nil q) as [q' [??]].
             *** hnf. pattern hf at 1. rewrite H. auto.
             *** hnf; simpl; intros. apply nil_elem in H1. elim H1.
             *** assert (q' ∈ mub_closure (PLT.plotkin (ds_F DS k)) M).
                 { apply mub_clos_mub with nil; auto.
                   - hnf. pattern hf at 1. rewrite H. auto.
                   - hnf; intros. apply nil_elem in H3; elim H3.
                 }
                 destruct H3 as [q'' [??]].
                 exists (LimSet k q'').
                 apply finsubset_elem.
                 **** intros. rewrite <- H5; auto.
                 **** split.
                      ***** exists (LimSet k q'').
                            split; auto.
                            apply in_map. auto.
                      ***** exists k'. simpl. exists Hkk'. exists Hzk'.
                            transitivity (ds_hom DS k k' Hkk' q); auto.
                            apply embed_mono.
                            rewrite <- H4; auto.

        * intros.
          apply finsubset_elem in H.
          apply finsubset_elem in H0.
          ** destruct H. destruct H0.
             destruct H as [x' [??]].
             destruct H0 as [y' [??]].
             apply in_map_iff in H.
             destruct H as [x'' [??]].
             apply in_map_iff in H0.
             destruct H0 as [y'' [??]].
             subst x' y'.
             rewrite H3 in H1. rewrite H4 in H2.
             destruct H1 as [k' [Hkk' [Hzk' ?]]]. simpl in *.

             destruct H2 as [l [Hl1 [Hl2 ?]]]. simpl in *.
             destruct (choose_ub I k' l) as [m [Hm1 Hm2]].
             assert (Hkm : k ≤ m) by (transitivity k'; auto).
             assert (Hzm : idx z ≤ m) by (transitivity k'; auto).

             destruct (embed_directed2 (ds_hom DS k m Hkm)
                                       (ds_hom DS (idx z) m Hzm (elem z)))
               with x'' y'' as [c [?[??]]]; auto.
             *** rewrite <- (ds_compose DS k k' m Hkk' Hm1 Hkm).
                 rewrite <- (ds_compose DS (idx z) k' m Hzk' Hm1 Hzm).
                 simpl. apply embed_mono. auto.
             *** rewrite <- (ds_compose DS k l m Hl1 Hm2 Hkm).
                 rewrite <- (ds_compose DS (idx z) l m Hl2 Hm2 Hzm).
                 simpl. apply embed_mono. auto.

             *** destruct (mub_complete (PLT.plotkin (ds_F DS k))
                                        (x''::y''::nil) c) as [c' [??]].
                 **** apply elem_inh with x''. apply cons_elem; auto.
                 **** hnf; simpl; intros.
                      apply cons_elem in H8. destruct H8.
                      ***** rewrite H8; auto.
                      ***** apply cons_elem in H8. destruct H8.
                            rewrite H8; auto.
                            apply nil_elem in H8. elim H8.
                 **** assert (c' ∈ mub_closure (PLT.plotkin (ds_F DS k)) M).
                      { apply mub_clos_mub with (x''::y''::nil); auto.
                        apply elem_inh with x''. apply cons_elem; auto.
                        hnf; simpl; intros.
                        apply cons_elem in H10. destruct H10.
                        - rewrite H10; auto.
                          exists x''; split; auto.
                        - apply cons_elem in H10. destruct H10.
                          + rewrite H10; auto.
                            exists y''; split; auto.
                          + apply nil_elem in H10. elim H10.
                      }
                      destruct H10 as [c'' [??]].
                      exists (LimSet k c'').
                      split.
                      ***** rewrite H3.
                            exists k'. simpl. exists Hkk'. exists Hkk'.
                            apply embed_mono; auto.
                            rewrite <- H11.
                            destruct H8.
                            apply H8. apply cons_elem; auto.
                      ***** split.
                            ****** rewrite H4.
                                   exists k'. simpl. exists Hkk'. exists Hkk'.
                                   apply embed_mono; auto.
                                   rewrite <- H11.
                                   destruct H8.
                                   apply H8.
                                   apply cons_elem. right.
                                   apply cons_elem. auto.
                            ****** apply finsubset_elem.
                                   intros. rewrite <- H12; auto.
                                   split; auto.
                                   ******* exists (LimSet k c'').
                                           split; auto.
                                           apply in_map. auto.
                                   ******* exists m. simpl.
                                           exists Hkm. exists Hzm.
                                           transitivity (ds_hom DS k m Hkm c); auto.
                                           apply embed_mono.
                                           rewrite <- H11; auto.
          ** intros. rewrite <- H2. auto.
          ** intros. rewrite <- H2. auto.
  Qed.

  (**  Altogether, this makes the bilimit a plotkin order.
    *)
  Definition limord_plotkin : plotkin_order hf limord :=
    norm_plt limord limord_effective hf limord_has_normals.

  Definition bilimit : PLT.ob hf :=
    PLT.Ob hf limset (PLT.Class _ _ limord_mixin limord_effective limord_plotkin).

  (**  Here we define the spokes of the colimit cocone.
    *)
  Program Definition limset_spoke (i:I) : hom (EMBED hf) (ds_F DS i) bilimit
    := Embedding hf (ds_F DS i : ob (EMBED hf)) bilimit
    (fun x => LimSet i x) _ _ _ _.
  Next Obligation.
    intros. hnf. simpl. exists i. exists (ord_refl _ _). exists (ord_refl _ _).
    rewrite (ds_ident DS i (ord_refl I i)). simpl. auto.
  Qed.
  Next Obligation.
    intros.
    destruct H as [k [Hki [Hki' ?]]]. simpl in *.
    rewrite <- (ds_compose DS i k k Hki' (ord_refl I k) Hki) in H.
    rewrite (ds_ident DS k (ord_refl I k)) in H.
    simpl in H.
    apply embed_reflects in H. auto.
  Qed.
  Next Obligation.
    intros.
    destruct (choose_ub I i (idx y)) as [k [??]].
    generalize (refl_equal hf). pattern hf at 2. case hf.
    - intros. pattern hf at 1. rewrite H1. auto.
    - intros. pattern hf at 1. rewrite H1.
      generalize (embed_directed0 (ds_hom DS i k H)
        (ds_hom DS (idx y) k H0 (elem y))).
      pattern hf at 1. rewrite H1.
      intros [q ?].
      exists q.
      hnf; simpl.
      exists k. exists H. exists H0.
      auto.
  Qed.
  Next Obligation.
    simpl; intros.
    destruct H as [k1 [Hik1 [Hyk1 ?]]]. simpl in *.
    destruct H0 as [k2 [Hik2 [Hyk2 ?]]]. simpl in *.
    destruct (choose_ub I k1 k2) as [k [??]].
    assert (i ≤ k) by (transitivity k1; auto).
    assert (idx y ≤ k) by (transitivity k1; auto).
    destruct (embed_directed2 (ds_hom DS i k H3)
      (ds_hom DS (idx y) k H4 (elem y)) a b) as [q [?[??]]].
    - rewrite <- (ds_compose DS i k1 k Hik1 H1 H3).
      rewrite <- (ds_compose DS (idx y) k1 k Hyk1 H1 H4).
      simpl. apply embed_mono. auto.
    - rewrite <- (ds_compose DS i k2 k Hik2 H2 H3).
      rewrite <- (ds_compose DS (idx y) k2 k Hyk2 H2 H4).
      simpl. apply embed_mono. auto.
    - exists q. split; auto.
      exists k. simpl.
      exists H3. exists H4. auto.
  Qed.

  Lemma limset_spoke_commute : forall i j (Hij:i≤j),
     limset_spoke i ≈ limset_spoke j ∘ ds_hom DS i j Hij.
  Proof.
    intros; split; hnf; simpl; intros.
    - exists j. simpl. exists Hij. exists (ord_refl _ _).
      rewrite (ds_ident DS j (ord_refl _ _)). simpl; auto.
    - exists j. simpl. exists (ord_refl _ _). exists Hij.
      rewrite (ds_ident DS j (ord_refl _ _)). simpl; auto.
  Qed.

  Definition bilimit_cocone : cocone DS :=
    Cocone DS bilimit limset_spoke limset_spoke_commute.

  Section bilimit_univ.
    Variable YC:cocone DS.

    Program Definition limord_univ : bilimit ⇀ YC :=
      Embedding hf bilimit (YC : ob (EMBED hf))
        (fun x => let (i,x') := x in cocone_spoke YC i x')
        _ _ _ _.
    Next Obligation.
      simpl; intros.
      destruct a as [i a].
      destruct a' as [i' a'].
      hnf in H. simpl in H.
      destruct H as [k [Hk1 [Hk2 ?]]].
      generalize (cocone_commute YC i k Hk1); intros.
      rewrite H0; clear H0.
      generalize (cocone_commute YC i' k Hk2); intros.
      rewrite H0. simpl.
      apply embed_mono. auto.
    Qed.
    Next Obligation.
      simpl; intros.
      destruct a as [i a].
      destruct a' as [i' a'].
      destruct (choose_ub I i i') as [k [Hk1 Hk2]].
      exists k. simpl. exists Hk1. exists Hk2.
      apply (embed_reflects (cocone_spoke YC k)).
      apply (use_ord H).
      - destruct (cocone_commute YC i k Hk1); intros.
        apply H1; auto.
      - destruct (cocone_commute YC i' k Hk2); intros.
        apply H0; auto.
    Qed.
    Next Obligation.
      intro.
      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 (choose_ub_set I nil) as [i _].
        generalize (embed_directed0 (cocone_spoke YC i) y).
        pattern hf at 1. rewrite H.
        intros [x ?].
        exists (LimSet i x). auto.
    Qed.
    Next Obligation.
      intros.
      destruct a as [i a].
      destruct b as [j b].
      destruct (choose_ub I i j) as [k [Hk1 Hk2]].
      rewrite (cocone_commute YC i k Hk1) in H.
      rewrite (cocone_commute YC j k Hk2) in H0.
      destruct (embed_directed2 (cocone_spoke YC k) y
        (ds_hom DS i k Hk1 a)
        (ds_hom DS j k Hk2 b)) as [c [?[??]]]; auto.
      exists (LimSet k c).
      split; auto.
      split.
      - exists k. simpl.
        exists Hk1. exists (ord_refl _ _).
        rewrite (ds_ident DS k (ord_refl _ _)).
        simpl. auto.
      - exists k. simpl.
        exists Hk2. exists (ord_refl _ _).
        rewrite (ds_ident DS k (ord_refl _ _)).
        simpl. auto.
    Qed.

    Lemma limord_univ_commute i :
      cocone_spoke YC i ≈ limord_univ ∘ limset_spoke i.
    Proof.
      cut (forall x,
        cocone_spoke YC i x ≈ limord_univ (limset_spoke i x)).
      { intros. split; intro x; destruct (H x); auto. }
      simpl; intros; auto.
    Qed.

    Lemma limord_univ_uniq (f:bilimit ⇀ YC) :
      (forall i, cocone_spoke YC i ≈ f ∘ limset_spoke i) ->
      f ≈ limord_univ.
    Proof.
      intros.
      cut (forall x, f x ≈ limord_univ x).
      { intros. split; intro x; destruct (H0 x); auto. }
      simpl. intros.
      destruct x as [i x].
      rewrite H. simpl. auto.
    Qed.
  End bilimit_univ.

  Definition bilimit_construction : directed_colimit DS bilimit_cocone :=
    DirectedColimit DS bilimit_cocone
      limord_univ
      limord_univ_commute
      limord_univ_uniq.

  Program Definition ep_set : dir_preord I → (PLT.hom_ord hf bilimit bilimit) :=
    Preord.Hom _ _
        (fun i => embed (embed_ep_pair (limset_spoke i)) ∘
                  project (embed_ep_pair (limset_spoke i)))
        _.
  Next Obligation.
    hnf; simpl; intros.
    hnf; simpl; intros.
    destruct a0 as [x y].
    apply PLT.compose_hom_rel in H0 as [z [??]].
    apply PLT.compose_hom_rel.
    exists (ds_hom DS a b H z).
    split; simpl.
    - simpl in *.
      apply project_rel_elem.
      apply project_rel_elem in H0.
      rewrite <- H0.
      generalize (limset_spoke_commute a b H).
      intro.
      destruct H2. apply H3.
    - apply embed_rel_elem.
      simpl in H1.
      apply embed_rel_elem in H1.
      rewrite H1.
      generalize (limset_spoke_commute a b H).
      intros [??]. apply H2.
  Qed.

  Program Definition Iset : Preord.carrier (cl_eset (directed_hf_cl hf) I)
    := exist _ (eff_enum I (dir_effective I)) _.
  Next Obligation.
    hnf. simpl; intros.
    destruct (choose_ub_set I M). exists x. split; auto.
    apply eff_complete.
  Qed.

  Lemma bilimit_cpo_colimit : forall x y:bilimit,
    y ≤ x ->
    exists i a,
      y ≤ limset_spoke i a /\
      limset_spoke i a ≤ x.
  Proof.
    intros. destruct H as [k [Hk1 [Hk2 ?]]].
    exists k. exists (ds_hom DS (idx x) k Hk2 (elem x)).
    split.
    - exists k. simpl. exists Hk1. exists (ord_refl _ _).
      rewrite (ds_ident DS k (ord_refl _ _)); simpl; auto.
    - exists k. simpl. exists (ord_refl _ _). exists Hk2.
      rewrite (ds_ident DS k (ord_refl _ _)); simpl; auto.
  Qed.

  Lemma bilimit_cpo_colimit1 :
    id(bilimit) ≤ ∐(image ep_set Iset).
  Proof.
    hnf. intros [x y] ?.
    simpl in H.
    apply approx_rels.ident_elem in H.
    simpl.
    apply union_axiom.
    destruct (bilimit_cpo_colimit x y) as [i [a [??]]]; auto.
    exists (PLT.hom_rel (ep_set#i)).
    split.
    - apply image_axiom1'.
      exists (ep_set#i).
      split; auto.
      apply image_axiom1'.
      exists i. split; auto.
      apply eff_complete.
    - simpl.
      apply PLT.compose_hom_rel.
      exists a. split.
      apply project_rel_elem. auto.
      apply embed_rel_elem. auto.
  Qed.

  Lemma bilimit_cpo_colimit2 :
    id(bilimit) ≈ ∐(image ep_set Iset).
  Proof.
    split. apply bilimit_cpo_colimit1.
    apply CPO.sup_is_least.
    hnf. simpl; intros.
    apply image_axiom2 in H. destruct H as [i [??]].
    rewrite H0.
    unfold ep_set. simpl.
    apply (ep_ident hf _ _ _ _
      (embed_func_is_ep_pair hf _ _ (limset_spoke i))).
  Qed.

End bilimit.

(**  The following two constructions show that a cocone is a colimit
     in EMBED iff every element can be factored through a spoke of the cocone.

     Passing thorough these constructions is generally the easiest way to
     demonstrate that an embedding functor is continuous.
  *)
Section colimit_decompose.
  Variable hf:bool.
  Variable I:directed_preord.
  Variable DS : directed_system I (EMBED hf).
  Variable CC : cocone DS.
  Variable Hcolimit : directed_colimit DS CC.

  Lemma colimit_decompose : forall x:cocone_point CC,
    { i:I & { a:ds_F DS i | cocone_spoke CC i a ≈ x }}.
  Proof.
    intros.
    set (y := colim_univ Hcolimit (bilimit_cocone hf I DS) x).
    exists (idx _ _ _ y).
    exists (elem _ _ _ y).
    split.
    - apply (embed_reflects
               (colim_univ Hcolimit (bilimit_cocone hf I DS))).
      generalize (colim_commute Hcolimit (bilimit_cocone hf I DS) (idx _ _ _ y)).
      simpl. intros.
      transitivity (limset_spoke hf I DS (idx _ _ _ y) (elem hf I DS y)).
      { rewrite H. auto. }
      transitivity y; auto.
      destruct y; simpl; auto.
    - apply (embed_reflects
               (colim_univ Hcolimit (bilimit_cocone hf I DS))).
      generalize (colim_commute Hcolimit (bilimit_cocone hf I DS) (idx _ _ _ y)).
      simpl. intros.
      transitivity (limset_spoke hf I DS (idx _ _ _ y) (elem hf I DS y)).
      { transitivity y; auto.
        destruct y; simpl; auto.
      }
      rewrite H; auto.
  Qed.
End colimit_decompose.

Section colimit_decompose2.
  Variable hf:bool.
  Variable I:directed_preord.
  Variable DS : directed_system I (EMBED hf).
  Variable CC : cocone DS.
  Hypothesis decompose : forall x:cocone_point CC,
    { i:I & { a:ds_F DS i | cocone_spoke CC i a ≈ x }}.

  Definition decompose_univ_func (YC:cocone DS) (x:cocone_point CC) :=
    cocone_spoke YC
       (projT1 (decompose x))
       (proj1_sig (projT2 (decompose x))).

  Program Definition decompose_univ (YC:cocone DS) : CC ⇀ YC :=
    Embedding hf (cocone_point CC: ob (EMBED hf))
                 (cocone_point YC : ob (EMBED hf))
                 (decompose_univ_func YC) _ _ _ _.
  Next Obligation.
    unfold decompose_univ_func. intros.
    destruct (decompose a) as [i [q ?]]. simpl.
    destruct (decompose a') as [j [q' ?]]. simpl.
    destruct (choose_ub I i j) as [k [??]].
    rewrite (cocone_commute YC i k H0).
    rewrite (cocone_commute YC j k H1).
    simpl.
    apply embed_mono.
    apply (embed_reflects (cocone_spoke CC k)).
    apply (use_ord H).
    - rewrite <- e.
      rewrite (cocone_commute CC i k H0). auto.
    - rewrite <- e0.
      rewrite (cocone_commute CC j k H1). auto.
  Qed.
  Next Obligation.
    unfold decompose_univ_func. intros.
    destruct (decompose a) as [i [q ?]]. simpl in *.
    destruct (decompose a') as [j [q' ?]]. simpl in *.
    destruct (choose_ub I i j) as [k [??]].
    rewrite (cocone_commute YC i k H0) in H.
    rewrite (cocone_commute YC j k H1) in H.
    simpl in H.
    apply embed_reflects in H.
    rewrite <- e.
    rewrite <- e0.
    rewrite (cocone_commute CC i k H0).
    rewrite (cocone_commute CC j k H1).
    simpl. apply embed_mono; auto.
  Qed.
  Next Obligation.
    intros.
    unfold decompose_univ_func.
    destruct hf; simpl; auto.
    destruct (choose_ub_set I nil) as [i ?].
    destruct (embed_directed0 (cocone_spoke YC i) y).
    exists (cocone_spoke CC i x).
    destruct (decompose (cocone_spoke CC i x)) as [m [z' ?]]. simpl.
    rewrite <- H.
    destruct (choose_ub I m i) as [k [??]].
    rewrite (cocone_commute YC m k H0).
    rewrite (cocone_commute YC i k H1).
    simpl. apply embed_mono.
    rewrite (cocone_commute CC m k H0) in e.
    rewrite (cocone_commute CC i k H1) in e.
    simpl in e.
    destruct e.
    apply (embed_reflects (cocone_spoke CC k)) in H2. auto.
  Qed.
  Next Obligation.
    unfold decompose_univ_func. intros.
    destruct (decompose a) as [i [q ?]]. simpl in *.
    destruct (decompose b) as [j [q' ?]]. simpl in *.
    destruct (choose_ub I i j) as [k [??]].
    rewrite (cocone_commute YC i k H1) in H.
    rewrite (cocone_commute YC j k H2) in H0.
    simpl in H, H0.
    destruct (embed_directed2 (cocone_spoke YC k) y
      (ds_hom DS i k H1 q)
      (ds_hom DS j k H2 q')) as [z [?[??]]]; auto.
    exists (cocone_spoke CC k z).
    split.
    - destruct (decompose (cocone_spoke CC k z)) as [m [z' ?]]. simpl.
      rewrite <- H3.

      destruct (choose_ub I m k) as [k' [??]].
      rewrite (cocone_commute YC m k' H6).
      rewrite (cocone_commute YC k k' H7).
      simpl. apply embed_mono.
      destruct e1.
      rewrite (cocone_commute CC m k' H6) in H8.
      rewrite (cocone_commute CC k k' H7) in H8.
      simpl in H8.
      apply (embed_reflects (cocone_spoke CC k')) in H8. auto.

    - split.
      + rewrite <- e.
        rewrite (cocone_commute CC i k H1).
        simpl. apply embed_mono. auto.
      + rewrite <- e0.
        rewrite (cocone_commute CC j k H2).
        simpl. apply embed_mono. auto.
  Qed.

  Program Definition decompose_is_colimit : directed_colimit DS CC :=
    DirectedColimit DS CC decompose_univ _ _.
  Next Obligation.
    intros. apply embed_lift'. simpl.
    unfold decompose_univ_func. simpl. intro x.
    destruct (decompose (cocone_spoke CC i x)) as [j [x' ?]]. simpl.
    destruct (choose_ub I i j) as [k [??]].
    rewrite (cocone_commute YC i k H).
    rewrite (cocone_commute YC j k H0).
    rewrite (cocone_commute CC i k H) in e.
    rewrite (cocone_commute CC j k H0) in e.
    simpl in e.
    destruct e; split; simpl.
    - apply embed_reflects in H2. apply embed_mono; auto.
    - apply embed_reflects in H1. apply embed_mono; auto.
  Qed.
  Next Obligation.
    simpl; intros.
    intros. apply embed_lift'.
    intro x.
    simpl. unfold decompose_univ_func.
    destruct (decompose x) as [i [x' ?]]. simpl.
    (* FIXME, why can I not just rewrite using <- e here? *)
    transitivity (f (cocone_spoke CC i x')).
    { apply embed_map_eq_morphism; auto. }
    rewrite (H i).
    simpl; auto.
  Qed.
End colimit_decompose2.

(** With the bilimit in hand, we can construct the least
    fixpoint of continuous functors in the embeddings
    over the category of partial plotkin orders by appeal
    to the general fixpoint construction for continuous functors.
 *)
Section fixpoint.
  Variable F:functor (EMBED true) (EMBED true).
  Hypothesis Fcontinuous : continuous_functor F.

  Definition fixpoint : ob (EMBED true) :=
    cont_functors.fixpoint
           PPLT_EMBED_initialized
           F
           (bilimit_cocone true).

  Definition fixpoint_initial : Alg.initial_alg (EMBED true) F :=
    cont_functors.fixpoint_initial
           PPLT_EMBED_initialized
           F
           (bilimit_cocone true)
           (bilimit_construction true)
           Fcontinuous.

  Definition fixpoint_iso : F fixpoint ↔ fixpoint :=
    cont_functors.fixpoint_iso
           PPLT_EMBED_initialized
           F
           (bilimit_cocone true)
           (bilimit_construction true)
           Fcontinuous.
End fixpoint.

Require Import Arith.

(** We can also build fixpoints in the category of total
    Plotkin orders by requiring a little more data.
    This proof is a modification of Theorem 79 from
    Carl Gunter's PhD thesis (CMU, 1985).
 *)
Section total_fixpoint.
  Variable F:functor (EMBED false) (EMBED false).
  Hypothesis Fcontinuous : continuous_functor F.

  Variable A:ob PLT.
  Variable h:A ⇀ F A.

  Fixpoint iterF (x:nat) : ob PLT :=
    match x with
    | O => A
    | S x' => F (iterF x')
    end.

  Fixpoint injectA (j:nat) : A ⇀ iterF j :=
    match j as j' return A ⇀ iterF j' with
    | 0 => id
    | S n => F·(injectA n) ∘ h
    end.

  Fixpoint iter_hom (i:nat) : forall (j:nat) (Hij:i <= j), iterF i ⇀ iterF j :=
    match i as i' return forall (j:nat) (Hij:i' <= j), iterF i' ⇀ iterF j with
    | O => fun j Hij => injectA j
    | S i' => fun j =>
        match j as j' return forall (Hij:S i' <= j'), iterF (S i') ⇀ iterF j' with
        | O => fun Hij => False_rect _ (HSle0 i' Hij) (* impossible case *)
        | S j' => fun Hij => F·(iter_hom i' j' (gt_S_le i' j' Hij))
        end
    end.

  Lemma iter_hom_proof_irr i : forall j H1 H2,
    iter_hom i j H1 ≈ iter_hom i j H2.
  Proof.
    induction i; simpl; intros; auto.
    destruct j.
    - elimtype False. inversion H1.
    - apply Functor.respects.
      apply IHi.
  Qed.

  Program Definition kleene_chain_alt : directed_system nat_dirord (EMBED false) :=
    DirSys nat_dirord _ iterF iter_hom _ _.
  Next Obligation.
    induction i; simpl; intros; auto.
    apply Functor.ident; auto.
  Qed.
  Next Obligation.
    induction i. simpl; intros.
    - clear Hij Hik.
      revert k Hjk; induction j; simpl; intros.
      + apply cat_ident1.
      + destruct k.
        { elimtype False. inversion Hjk. }
        simpl.
        rewrite (@cat_assoc (EMBED false)).
        apply cat_respects; auto.
        symmetry. apply Functor.compose.
        symmetry. apply IHj.

    - intros. destruct j.
      + elimtype False. inversion Hij.
      + destruct k.
        * elimtype False. inversion Hjk.
        * simpl.
          rewrite <- (Functor.compose F _ _ _ (iter_hom j k (gt_S_le j k Hjk))).
          ** reflexivity.
          ** auto.
  Qed.

  Definition fixpoint_alt : ob PLT := bilimit false nat_dirord kleene_chain_alt.

  Let BL := Fcontinuous
               nat_dirord kleene_chain_alt
               (bilimit_cocone false nat_dirord kleene_chain_alt)
               (bilimit_construction false nat_dirord kleene_chain_alt).

  Program Definition cocone_plus1 : cocone (dir_sys_app kleene_chain_alt F)
    := Cocone (dir_sys_app kleene_chain_alt F) fixpoint_alt
      (fun i => cocone_spoke (bilimit_cocone false nat_dirord kleene_chain_alt) (S i)) _.
  Next Obligation.
    simpl; intros.
    assert (Hij' : S i <= S j) by auto with arith.
    rewrite (cocone_commute (bilimit_cocone false nat_dirord kleene_chain_alt) (S i) (S j) Hij').
    simpl. apply cat_respects; auto.
    apply Functor.respects.
    apply iter_hom_proof_irr.
  Qed.

  Program Definition cocone_minus1 : cocone kleene_chain_alt
    := Cocone kleene_chain_alt (F fixpoint_alt)
           (fun i =>
              F·(cocone_spoke (bilimit_cocone false nat_dirord kleene_chain_alt) i) ∘
              iter_hom i (S i) (le_S i i (le_refl i)))
           _.
  Next Obligation.
    simpl. intros.
    assert (i <= S j) by auto with arith.
    rewrite <- (@cat_assoc (EMBED false)).
    rewrite (kleene_chain_alt_obligation_2 i j (S j) Hij (le_S j j (le_refl j)) H).
    destruct i.

    - simpl.
      rewrite Functor.ident; auto.
      rewrite (@cat_ident2 (EMBED false)).
      rewrite (@cat_assoc (EMBED false)).
      apply cat_respects; auto.
      apply Functor.compose.
      rewrite (limset_spoke_commute false nat_dirord kleene_chain_alt 0%nat j Hij).
      simpl. auto.

    - simpl.
      etransitivity.
      + symmetry.
        apply (Functor.compose F) with
          (f0:=limset_spoke false nat_dirord kleene_chain_alt (S i))
          (g:=iter_hom i (S i) (gt_S_le i (S i) (le_S (S i) (S i) (le_refl (S i)))))
          (h:=limset_spoke false nat_dirord kleene_chain_alt j ∘
            iter_hom i j (gt_S_le i j H)).
        assert (i <= j) by auto with arith.
        rewrite <- (limset_spoke_commute false nat_dirord kleene_chain_alt i j).
        rewrite <- (limset_spoke_commute false nat_dirord kleene_chain_alt i (S i)).
        auto.
      + apply (Functor.compose F); auto.
  Qed.

  Definition fixpoint_alt_in : F fixpoint_alt ⇀ fixpoint_alt :=
    colim_univ BL cocone_plus1.
  Definition fixpoint_alt_out : fixpoint_alt ⇀ F fixpoint_alt :=
    limord_univ false nat_dirord kleene_chain_alt cocone_minus1.

  Lemma fixpoint_alt_in_out : fixpoint_alt_in ∘ fixpoint_alt_out ≈ id.
  Proof.
    transitivity (limord_univ false nat_dirord kleene_chain_alt
      (bilimit_cocone false nat_dirord kleene_chain_alt)).
   -  apply (limord_univ_uniq false nat_dirord kleene_chain_alt
      (bilimit_cocone false nat_dirord kleene_chain_alt)).
      simpl; intros. unfold fixpoint_alt_in. unfold fixpoint_alt_out.
      rewrite <- (@cat_assoc (EMBED false)).
      rewrite <- (limord_univ_commute false nat_dirord kleene_chain_alt cocone_minus1 i).
      simpl.
      generalize (colim_commute BL cocone_plus1 i). simpl. intros.
      transitivity (limset_spoke false nat_dirord kleene_chain_alt (S i)
                                 ∘ iter_hom i (S i) (le_S i i (le_refl i))).
      { apply (limset_spoke_commute false nat_dirord kleene_chain_alt i (S i)). }
      rewrite (@cat_assoc (EMBED false)).
      apply cat_respects; auto.
   - symmetry.
     apply (limord_univ_uniq false nat_dirord kleene_chain_alt
                             (bilimit_cocone false nat_dirord kleene_chain_alt)).
     simpl; intros.
     symmetry.
     apply cat_ident2.
  Qed.

  Lemma fixpoint_alt_out_in : fixpoint_alt_out ∘ fixpoint_alt_in ≈ id.
  Proof.
    transitivity (colim_univ BL
        (cocone_app (bilimit_cocone false nat_dirord kleene_chain_alt) F)).

    - apply (colim_uniq BL (cocone_app (bilimit_cocone false nat_dirord kleene_chain_alt) F)).
      simpl. unfold fixpoint_alt_out. unfold fixpoint_alt_in.
      intros.
      generalize (colim_commute BL cocone_plus1 i).
      simpl. intros.
      rewrite <- (@cat_assoc (EMBED false)).
      rewrite <- H.
      generalize (limord_univ_commute false nat_dirord kleene_chain_alt
      cocone_minus1 (S i)). simpl. intros.
      rewrite <- H0.
      apply Functor.compose.
      apply (limset_spoke_commute false nat_dirord kleene_chain_alt i (S i)).
    - symmetry.
      apply (colim_uniq BL (cocone_app (bilimit_cocone false nat_dirord kleene_chain_alt) F)).
      simpl; intros.
      symmetry. apply cat_ident2.
  Qed.

  Definition fixpoint_embed : A ⇀ fixpoint_alt :=
    limset_spoke false nat_dirord kleene_chain_alt 0%nat.

  Definition fixpoint_alt_iso : F fixpoint_alt ↔ fixpoint_alt :=
    Isomorphism (EMBED false) (F fixpoint_alt) fixpoint_alt
       fixpoint_alt_in
       fixpoint_alt_out
       fixpoint_alt_out_in
       fixpoint_alt_in_out.

End total_fixpoint.


Require Import Reals.
Require Import Fourier Lra.
Require Import Rpow_facts.

Require Import Rinterval Rextensionality.
Require Import Rsequence_facts Rsequence_sums_facts Rsequence_rewrite_facts.
Require Import RFsequence RFsequence_facts.
Require Import Rpser_def Rpser_def_simpl Rpser_base_facts.
Require Import Rpser_cv_facts Rpser_sums.
Require Import MyINR.

Local Open Scope R_scope.

(** Abel's lemma : Normal convergence of the power serie *)

Lemma Rpser_abs_cv_radius_weak : forall (An : Rseq) (r : R),
  Cv_radius_weak An r -> forall x, Rabs x < r ->
  { l | Rpser_abs An x l}.
Proof.
intros An r Rho x x_bd ;
 assert (Rho' := proj1 (Cv_radius_weak_abs An r) Rho) ;
 pose (l := weaksum_r (| An |) r Rho' (Rabs x)) ;
 exists l ; rewrite Rpser_abs_unfold ; apply weaksum_r_sums ;
 rewrite Rabs_Rabsolu ; assumption.
Qed.

Lemma Rpser_abs_infinite_cv_radius: forall An,
  infinite_cv_radius An -> forall x, {l | Rpser_abs An x l}.
Proof.
intros An rAn x ; apply (Rpser_abs_cv_radius_weak _ _
 (rAn (Rabs x + 1)) x (Rlt_n_Sn _)).
Qed.

Lemma Rpser_abel2 : forall An r, Cv_radius_weak An r ->
  forall r' : posreal, r' < r -> CVN_r (fun n x => gt_pser An x n) r'.
Proof.
intros An r Pr [a a_pos] r'_ub.
 assert (a_bd : Rabs a < r) by (rewrite Rabs_pos_eq ; [| left] ; assumption).
 assert (r_pos : 0 < r) by (apply Rlt_trans with a ; assumption).
 assert (r'_bd : Rabs (middle a r) < r).
  rewrite Rabs_pos_eq ; [apply middle_is_in_the_middle |
   left ; apply middle_lt_lt_pos_lt] ; assumption.
 rewrite Cv_radius_weak_abs in Pr.
 exists (gt_abs_pser An (middle a r)) ;
 exists (weaksum_r (| An |) r Pr (Rabs (middle a r))) ; split.
 rewrite <- Rseq_cv_Un_cv_equiv ;
 apply Rseq_cv_eq_compat with (Rseq_sum (gt_abs_pser An (middle a r))).
 intro n ; fold (Rseq_abs (gt_abs_pser An (middle a r))) ;
 apply Rseq_sum_ext with (Vn := gt_abs_pser An (middle a r)) ;
 apply Rseq_abs_idempotent.
 assert (tmp := Rseq_sum_ext _ _ (gt_abs_pser_unfold An (middle a r))) ;
 symmetry in tmp ; apply (Rseq_cv_eq_compat  _ _ _ tmp) ; clear tmp.
 apply weaksum_r_sums ; rewrite Rabs_Rabsolu ; assumption.
 intros n y B ; apply gt_abs_pser_le_compat ; unfold Boule in B ;
 apply Rle_trans with a ; [left |].
 unfold Rminus in B ; rewrite Ropp_0, Rplus_0_r in B ; apply B.
 rewrite Rabs_pos_eq ; [left ; apply middle_is_in_the_middle |
 left ; apply middle_lt_lt_pos_lt] ; assumption.
Qed.

(** A sufficient condition for the radius of convergence*)
Lemma Rpser_finite_cv_radius_caracterization : forall An x l,
  Rpser An x l -> (forall l : R, ~ Rpser_abs An x l) ->
  finite_cv_radius An (Rabs x).
Proof.
intros An x l Hcv Hncv ; split; intros r Hr.
 apply Cv_radius_weak_le_compat with x.
  rewrite Rabs_pos_eq ; [left |] ; apply Hr.
  apply (Rpser_bound_criteria _ _ l Hcv).
 intro Hf ;
 destruct (Rpser_abs_cv_radius_weak An r Hf x Hr) as [l' Hl'] ;
 apply Hncv with l' ; assumption.
Qed.

Lemma Rpser_infinite_cv_radius_caracterization :
  forall An, (forall x, {l | Rpser An x l}) -> infinite_cv_radius An.
Proof.
intros An weaksum r ; destruct (weaksum r) as (l, Hl) ;
 apply Rpser_bound_criteria with l ; assumption.
Qed.

(** * Caracterization of the cv radius of the formal derivative *)

Lemma Cv_radius_weak_derivable_compat : forall An r,
  Cv_radius_weak An r -> forall r', Rabs r' < Rabs r ->
  Cv_radius_weak (An_deriv An) r'.
Proof.
intros An r rho r' r'_bd.
 assert (Rabsr_pos : 0 < Rabs r).
  apply Rle_lt_trans with (Rabs r') ; [apply Rabs_pos | assumption].
 assert (x_lt_1 : Rabs (r'/ r) < 1).
  unfold Rdiv ; rewrite Rabs_mult ; rewrite Rabs_Rinv.
  replace 1 with (Rabs r *  / Rabs r).
  apply Rmult_lt_compat_r ; [apply Rinv_0_lt_compat |] ; assumption.
  apply Rinv_r ; apply Rgt_not_eq ; assumption.
  intro Hf ; rewrite Hf, Rabs_R0 in Rabsr_pos ; apply (Rlt_irrefl _ Rabsr_pos).
  destruct rho as (B,HB).
  case (Req_or_neq r') ; intro r'_lb.
  exists (Rabs (An 1%nat)) ; intros x Hx ; destruct Hx as (i, Hi) ;
 rewrite Hi ; unfold gt_abs_pser, gt_pser, An_deriv, Rseq_shift, Rseq_mult, Rseq_abs.
 destruct i.
 simpl ; rewrite Rmult_1_l ; rewrite Rmult_1_r ; apply Rle_refl.
 rewrite r'_lb ; rewrite pow_i ; [| intuition] ; repeat (rewrite Rmult_0_r) ;
 rewrite Rabs_R0 ; apply Rabs_pos.
 assert (Rabsr'_pos : 0 < Rabs r') by (apply Rabs_pos_lt ; assumption).
 destruct (Rpser_cv_speed_pow_id (r' / r) x_lt_1 (Rabs r') Rabsr'_pos) as (N, HN).
 destruct (Rseq_partial_bound (gt_abs_pser (An_deriv An) r') N) as (B2, HB2).
 exists (Rmax B B2) ; intros x Hx ; destruct Hx as (i, Hi) ;
 rewrite Hi ; unfold gt_abs_pser, gt_pser, Rseq_abs, Rseq_mult in * ;
 case (le_lt_dec i N) ; intro H.
 rewrite <- Rabs_Rabsolu ; apply Rle_trans with B2 ; [apply HB2 | apply RmaxLess2] ;
 assumption.
 apply Rle_trans with (Rabs (/r' * (INR (S i) * (r' / r) ^ S i) * An (S i) * r ^ S i)).
 right ; apply Rabs_eq_compat ; unfold An_deriv, Rseq_shift, Rseq_mult ; field_simplify.
 unfold Rdiv ; repeat (rewrite Rmult_assoc) ; repeat (apply Rmult_eq_compat_l).
 rewrite Rpow_mult_distr.
 try (rewrite Rinv_1 ; rewrite Rmult_1_r).
 rewrite Rmult_assoc.
 replace ((/ r) ^ S i * (r ^ S i * / r')) with (/ r').
 simpl ; field ; assumption.
 field_simplify.
 unfold Rdiv ; repeat (rewrite <- Rmult_assoc) ; apply Rmult_eq_compat_r.
 rewrite <- Rinv_pow.
 field.
 apply pow_nonzero.
 intro Hf ; rewrite Hf, Rabs_R0 in r'_bd.
 assert (H0 : 0 < 0).
 apply Rlt_trans with (Rabs r') ; assumption.
 apply (Rlt_irrefl _ H0).
 intro Hf ; rewrite Hf, Rabs_R0 in r'_bd.
 assert (H0 : 0 < 0).
 apply Rlt_trans with (Rabs r') ; assumption.
 apply (Rlt_irrefl _ H0).
 assumption.
 assumption.
 assumption.
 rewrite Rmult_assoc ; rewrite Rabs_mult.
 apply Rle_trans with (Rabs (/ r' * (INR (S i) * (r' / r) ^ S i)) * B).
 apply Rmult_le_compat_l ; [apply Rabs_pos |] ; apply HB ; exists (S i) ; reflexivity.
 apply Rle_trans with (1*B) ; [| rewrite Rmult_1_l ; apply RmaxLess1].
 apply Rmult_le_compat_r.
 apply Rle_trans with (Rabs (An 0%nat * r ^ 0)) ; [apply Rabs_pos |] ;
 apply HB ; exists 0%nat ; reflexivity.
 rewrite Rabs_mult ; apply Rle_trans with (Rabs (/r') * Rabs r').
 apply Rmult_le_compat_l.
 apply Rabs_pos.
 apply Rle_trans with (R_dist (INR (S i) * (r' / r) ^ S i) 0) ;
 [right ; unfold R_dist ; rewrite Rminus_0_r ; reflexivity |] ; left ; apply HN ;
 intuition.
 rewrite <- Rabs_mult ; rewrite Rinv_l ; [| assumption] ; rewrite Rabs_R1 ; right ; trivial.
Qed.

Lemma Cv_radius_weak_derivable_compat_rev : forall An r,
  Cv_radius_weak (An_deriv An) r -> Cv_radius_weak An r.
Proof.
intros An r [B HB] ; exists (Rmax (B * Rabs r) (Rabs (An O))) ;
 intros x [i Hi] ; subst.
 destruct i.
  apply Rle_trans with (Rabs (An O)) ; [apply gt_abs_pser_0_ub | apply Rmax_r].
  rewrite gt_abs_pser_S ; apply Rle_trans with (B * Rabs r) ; [| apply Rmax_l].
  apply Rmult_le_compat_r ; [apply Rabs_pos |].
  apply Rle_trans with (gt_abs_pser (An_deriv An) r i) ; [| apply HB ; exists i ;
  reflexivity].
  rewrite <- (Rmult_1_l (gt_abs_pser (Rseq_shift An) r i)).
  unfold gt_abs_pser, gt_pser, An_deriv, Rseq_shift, Rseq_abs, Rseq_mult.
  rewrite Rmult_assoc, (Rabs_mult (INR (S i))) ; apply Rmult_le_compat_r ;
  [apply Rabs_pos |] ; rewrite <- INR_1, Rabs_INR ; apply le_INR ; omega.
Qed.

Lemma finite_cv_radius_derivable_compat : forall An r,
  finite_cv_radius An r <->
  finite_cv_radius (An_deriv An) r.
Proof.
intros An r ; split.

intros [H_ub H_lub] ; split.
 intros r' (r'_lb, r'_ub) ; apply Cv_radius_weak_derivable_compat with
 (r := middle (Rabs r) (Rabs r')).
 apply H_ub ; split.
 left ; apply middle_lt_le_pos_lt.
 apply Rabs_pos_lt ; apply Rgt_not_eq ; apply Rlt_gt ;
 apply Rle_lt_trans with r' ; assumption.
 apply Rabs_pos.
 rewrite middle_comm ; apply Rlt_le_trans with (Rabs r).
 eapply middle_is_in_the_middle.
 apply Rle_lt_trans with r' ; [right ; apply Rabs_right ; intuition |].
 apply Rlt_le_trans with r ; [assumption | right ; symmetry ; apply Rabs_right ;
 left ; apply Rle_lt_trans with r' ; assumption].
 right ; apply Rabs_right ; left ; apply Rle_lt_trans with r' ; assumption.
 apply Rle_lt_trans with r'.
 right ; apply Rabs_right ; intuition.
 rewrite Rabs_right.
 apply Rle_lt_trans with (Rabs r') ; [right ; symmetry ;apply Rabs_right ;
 intuition | rewrite middle_comm].
 eapply middle_is_in_the_middle.
 apply Rle_lt_trans with r' ; [right ; apply Rabs_right ; intuition |].
 apply Rlt_le_trans with r ; [assumption | right ; symmetry ; apply Rabs_right ;
 left ; apply Rle_lt_trans with r' ; assumption].
 left ; apply middle_lt_le_pos_lt ;  [apply Rabs_pos_lt ; apply Rgt_not_eq ;
 apply Rlt_gt ; apply Rle_lt_trans with r' ; assumption | apply Rabs_pos].

 intros r' rltr' Hf ; apply (H_lub _ rltr') ;
  apply Cv_radius_weak_derivable_compat_rev ; assumption.

intros [H_ub H_lub] ; split.
 intros r' r'_bd ; apply Cv_radius_weak_derivable_compat_rev ;
  apply H_ub ; assumption.

 intros r' rltr' Hf.
  assert (r0_bd : r < middle r r') by
   (apply middle_is_in_the_middle ; assumption).
  apply (H_lub _ r0_bd) ; eapply Cv_radius_weak_derivable_compat.
  eassumption.
  assert (r_pos : 0 <= r).
   eapply finite_cv_radius_pos ; split ; [apply H_ub | apply H_lub].
  assert (r'_pos : 0 <= r') by (left ; apply Rle_lt_trans with r ; assumption).
  assert (middle_pos : 0 <= middle r r') by
   (apply middle_le_le_pos ; assumption).
  do 2 (rewrite Rabs_pos_eq ; [| assumption]) ; apply middle_is_in_the_middle ;
  assumption.
Qed.

Lemma infinite_cv_radius_derivable_compat : forall An,
         infinite_cv_radius An <->
         infinite_cv_radius (An_deriv An).
Proof.
intro An ; split.
intros Rho r ; apply Cv_radius_weak_derivable_compat with (r := (Rabs r) + 1).
 apply Rho.
 replace (Rabs (Rabs r + 1)) with (Rabs r + 1).
 lra.
 symmetry ; apply Rabs_right.
 apply Rle_ge ; apply Rle_trans with (Rabs r) ; [apply Rabs_pos | lra].

intros Rho r ; apply Cv_radius_weak_derivable_compat_rev ; apply Rho.
Qed.

(** Using the results on the derivative, we can now talk about Rseq_prod. *)

Lemma Cv_radius_weak_prod_compat:
  forall (An Bn : Rseq) (r1 r2 : R),
  Cv_radius_weak An r1 ->
  Cv_radius_weak Bn r2 ->
  forall r, Rabs r < Rmin (Rabs r1) (Rabs r2) ->
  Cv_radius_weak (An # Bn) r.
Proof.
intros An Bn r1 r2 rAn rBn r Hr.
 apply Cv_radius_weak_ext with (An_deriv (fun n => if eq_nat_dec n 0 then 0
else (Rseq_div (An # Bn) (Rseq_shift INR)) (pred n))).

unfold An_deriv, Rseq_shift, Rseq_mult, Rseq_div, Rdiv ; intro n ; simpl.
rewrite <- Rmult_assoc, Rmult_comm, <- Rmult_assoc, Rinv_l, Rmult_1_l.
 reflexivity.
 apply Rgt_not_eq ; unfold Rgt ; replace (match n with | 0%nat => 1 | S _ => INR n + 1 end)
 with (INR (S n)) by auto ; apply lt_0_INR ; omega.
apply Cv_radius_weak_derivable_compat with (Rmin (Rabs r1) (Rabs r2)).

destruct (Cv_radius_weak_prod_prelim An Bn r1 r2 rAn rBn) as [B HB] ;
 exists (B * Rabs (Rmin (Rabs r1) (Rabs r2))) ;
 intros x [i Hi] ; subst ; unfold gt_abs_pser, Rseq_abs, gt_pser,
 Rseq_mult ; destruct i as [| j].
  simpl ; rewrite Rmult_1_r, Rabs_R0 ; apply Rle_trans with
  ((gt_abs_pser ((An # Bn) / Rseq_shift INR)) (Rmin (Rabs r1) (Rabs r2)) O *
  Rabs (Rmin (Rabs r1) (Rabs r2))).
  apply Rmult_le_pos ; [unfold gt_abs_pser, Rseq_abs|] ; apply Rabs_pos.
  apply Rmult_le_compat_r ; [apply Rabs_pos | apply HB ; exists O ; reflexivity].
 simpl.
 rewrite (Rmult_comm (Rmin (Rabs r1) (Rabs r2))), <- Rmult_assoc, Rabs_mult,
  (Rabs_pos_eq (Rmin (Rabs r1) (Rabs r2))).
  apply Rmult_le_compat_r.
  apply MyRIneq.Rmin_pos ; apply Rabs_pos.
  apply HB ; exists j ; reflexivity.
  apply MyRIneq.Rmin_pos ; apply Rabs_pos.
  rewrite (Rabs_pos_eq (Rmin (Rabs r1) (Rabs r2))) ;
  [assumption | apply MyRIneq.Rmin_pos ; apply Rabs_pos].
Qed.

Lemma infinite_cv_radius_prod_compat: forall (An Bn : Rseq),
  infinite_cv_radius An -> infinite_cv_radius Bn ->
  infinite_cv_radius (An # Bn).
Proof.
intros An Bn rAn rBn r ; apply Cv_radius_weak_prod_compat with (Rabs r + 1) (Rabs r + 1).
 apply rAn.
 apply rBn.
 apply Rlt_le_trans with (Rabs r + 1) ; [lra |].
 right ; rewrite Rmin_diag ; symmetry ; apply Rabs_pos_eq ;
 rewrite Rplus_comm ; apply Rle_zero_pos_plus1, Rabs_pos.
Qed.

(** Same thing but for the nth derivative. *)

Lemma Cv_radius_weak_nth_derivable_compat (k : nat) : forall An r,
         Cv_radius_weak An r -> forall r', Rabs r' < Rabs r ->
         Cv_radius_weak (An_nth_deriv An k) r'.
Proof.
induction k ; intros An r rAn r' r'_bd.

 erewrite Cv_radius_weak_ext ; [| apply An_nth_deriv_0].
  eapply Cv_radius_weak_le_compat ; [left |] ; eassumption.

 assert (Hrew : Rabs (middle (Rabs r') (Rabs r)) = middle (Rabs r') (Rabs r)).
  apply Rabs_pos_eq ; apply middle_le_le_pos ; apply Rabs_pos.
 erewrite Cv_radius_weak_ext ; [| apply An_nth_deriv_S] ;
  apply Cv_radius_weak_derivable_compat with (middle (Rabs r') (Rabs r)).
 apply IHk with r ; [| rewrite Hrew ; apply middle_is_in_the_middle] ;
  assumption.
 rewrite Hrew ; apply middle_is_in_the_middle ; assumption.
Qed.

Lemma Cv_radius_weak_nth_derivable_compat_rev (k : nat) : forall An r,
         Cv_radius_weak (An_nth_deriv An k) r ->
         Cv_radius_weak An r.
Proof.
induction k ; intros An r rAn.

 erewrite Cv_radius_weak_ext.
  eassumption.
  symmetry ; apply An_nth_deriv_0.

 apply IHk ; apply Cv_radius_weak_derivable_compat_rev ;
  erewrite Cv_radius_weak_ext.
  eassumption.
  symmetry ; apply An_nth_deriv_S.
Qed.

Lemma finite_cv_radius_nth_derivable_compat (k : nat) : forall An r,
         finite_cv_radius An r <->
         finite_cv_radius (An_nth_deriv An k) r.
Proof.
induction k ; intros An r.
rewrite <- finite_cv_radius_ext ;
 [reflexivity | apply An_nth_deriv_0].

split ; intro Rho.
 rewrite finite_cv_radius_ext ; [| eapply An_nth_deriv_S].
  rewrite <- finite_cv_radius_derivable_compat, <- IHk ; assumption.
 rewrite IHk, finite_cv_radius_derivable_compat ;
  rewrite <- finite_cv_radius_ext ;
  [| eapply An_nth_deriv_S] ; assumption.
Qed.

Lemma infinite_cv_radius_nth_derivable_compat (k : nat) : forall An,
         infinite_cv_radius An <->
         infinite_cv_radius (An_nth_deriv An k).
Proof.
induction k ; intro An.
rewrite <- infinite_cv_radius_ext ;
 [| eapply An_nth_deriv_0] ; reflexivity.

split ; intro Rho.
 rewrite infinite_cv_radius_ext ; [| eapply An_nth_deriv_S].
  rewrite <- infinite_cv_radius_derivable_compat, <- IHk ; assumption.
 rewrite IHk, infinite_cv_radius_derivable_compat,
  <- infinite_cv_radius_ext ; [| eapply An_nth_deriv_S] ; assumption.
Qed.


(* This file is used for testing `autorewrite` tactics *)

Reset Initial.
Require Import Arith.
Variable Ack : nat->nat->nat.

Axiom Ack0 : forall m:nat, Ack 0 m = S m.
Axiom Ack1 : forall n:nat, Ack (S n) 0 = Ack n 1.
Axiom Ack2 : forall n m:nat, Ack (S n)  (S m) = Ack n (Ack (S n) m).

Hint Rewrite Ack0 Ack1 Ack2 :base0.

Lemma RseAck0 : Ack 3 2 = 29.
  autorewrite with base0 using try reflexivity. Qed.

Require Import Omega.

Variable g : nat->nat->nat.

Axiom g0 : forall m:nat, g 0 m=m.
Axiom g1 : forall n m:nat, (n>0) -> (m>100) -> g n m = g (pred n) (m - 10).
Axiom g2 : forall n m:nat, (n>0)->(m<=100) -> g n m = g (S n) (m+11).

Hint Rewrite g0 g1 g2 using omega:base1.
Lemma Resg0 : g 1 110 = 100.
  autorewrite with base1 using first [progress reflexivity |  progress simpl]. Qed.
(* exp1 || exp2 is equivalent to first [progress exp1 | progress exp2] tactics *)
Lemma Resg1 : g 1 95 = 91.
  autorewrite with base1 using reflexivity || simpl. Qed.


(** * Choice.v: An example of probabilistic choice *)
Require Export Prog.
Set Implicit Arguments.
Module Choice (Univ:Universe).
Module RP := (Rules Univ).
(* begin hide *)
Import Univ.
Import RP.
Import RP.PP.
Import RP.PP.MP.
Import RP.PP.MP.UP.
(* end hide *)
(** ** Definition of a probabilistic choice
We interpret the probabilistic program $p$ which executes
two probabilistic programs $p_1$ and $p_2$ and then make a choice
between the two computed results.
<<
let rec p () = let x = p1 () in let y = p2 () in choice x y
>>*)
Section CHOICE.
Variable A : Type.
Variables p1 p2 : distr A.
Variable choice : A -> A -> A.
Definition p : distr A := Mlet p1 (fun x => Mlet p2 (fun y => Munit (choice x y))).
(** ** Main result
 We estimate the probability for $p$ to satisfy $Q$ given estimations for
both $p_1$ and $p_2$. *)
(** *** Assumptions
We need extra properties on $p_1$, $p_2$ and $choice$.
- $p_1$ and $p_2$ terminate with probability $1$
- $Q$ value on $choice$ is not less than the sum of values of $Q$ on separate elements.
If $Q$ is a boolean function it means than if one of $x$ or $y$ satisfies $Q$
then $(choice~x~y)$ will also satisfy $Q$ *)
Hypothesis p1_terminates : (mu p1 (f_one A))==1.
Hypothesis p2_terminates : (mu p2 (f_one A))==1.

Variable Q : A -> U.
Hypothesis choiceok : forall x y, Q x + Q y <= Q (choice x y).

(** *** Proof of estimation
$\bfrac{\ok{k_1}{p_1}{Q}~~~\ok{k_2}{p_2}{Q}}
	  {\ok{k_1(1-k_2)+k_2}{p}{Q}}$
*)

Lemma choicerule : forall k1 k2,
  k1 <= mu p1 Q -> k2 <= mu p2 Q ->  (k1 * ([1-] k2) + k2) <= mu p Q.
unfold p,Mlet,star; simpl; unfold unit; intros.
apply Ule_trans with
  (mu p1 (fun x : A => mu p2 (fun y : A => Q x * ([1-] (Q y)) + Q y))).
apply Ule_trans with
  (mu p1 (fun x : A =>
           ((mu p2 (fun y : A => Q x * ([1-] (Q y))))
           +(mu p2 Q)))).
change
 (k1 * [1-] k2 + k2 <=
  mu p1 (fplus (fun x : A => mu p2 (fun y : A => Q x * [1-] (Q y)))
               (fun x => mu p2 Q))).
assert (H1 : fplusok (fun x : A => mu p2 (fun y : A => Q x * [1-] (Q y)))
               (fun x => mu p2 Q)).
repeat red; unfold finv; intros.
apply Ule_trans with (mu p2 (fun y : A => [1-] (Q y))).
apply (mu_monotonic p2); auto.
apply (mu_stable_inv p2 Q).
setoid_rewrite (mu_stable_plus p1 H1).
setoid_replace (mu p1 (fun _ : A => mu p2 Q))
  with (mu p2 Q); auto.
apply Ule_trans with
   (k1 * [1-] (mu p2 Q) + (mu p2 Q)); auto.
apply Uplus_le_compat_left.
apply Ule_trans with
(mu p1 (fun x : A => (Q x) * mu p2 (finv Q))).
apply Ule_trans with
      ((mu p1 Q) * (mu p2 (finv Q))).
setoid_rewrite (mu_one_inv p2 p2_terminates Q); auto.
setoid_rewrite (mu_stable_mult_right p1 (mu p2 (finv Q)) Q); auto.
apply (mu_monotonic p1); red; intros.
setoid_rewrite <- (mu_stable_mult p2 (Q x) (finv Q)); auto.
exact (mu_cte_eq p1 (mu p2 Q) p1_terminates).

apply (mu_monotonic p1); red; intros.
assert (fplusok (fun y : A => Q x * [1-] (Q y)) Q).
repeat red; unfold finv; auto.
setoid_rewrite <- (mu_stable_plus p2 H1); auto.
apply (mu_monotonic p1); red; intros.
apply (mu_monotonic p2); red; intros.
apply Ule_trans with ((Q x) + (Q x0)); auto.
Qed.

End CHOICE.
End Choice.


(*
Copyright © 2006-2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import Coq.Setoids.Setoid.
Require Export CoRN.order.SemiLattice.

Local Open Scope po_scope.

(**
* Lattice
A lattice is a semilattice with a join operation such that it forms
a semilattice with in the dual partial order.
*)
Record Lattice : Type :=
{ sl :> SemiLattice
; join : sl -> sl -> sl
; l_proof : is_SemiLattice (Dual sl) join
}.
(* begin hide *)
Arguments join [l].
(* end hide*)
Section Join.

Variable X : Lattice.

Definition makeLattice (po:PartialOrder) (meet join :  po -> po -> po) p1 p2 p3 p4 p5 p6 :=
@Build_Lattice (@makeSemiLattice po meet p1 p2 p3) join
(@Build_is_SemiLattice (Dual po) join p4 p5 p6).

(** The axioms of a join lattice. *)
Lemma join_ub_l : forall x y : X, x <= join x y.
Proof (sl_meet_lb_l _ _ (l_proof X)).

Lemma join_ub_r : forall x y : X, y <= join x y.
Proof (sl_meet_lb_r _ _ (l_proof X)).

Lemma join_lub : forall x y z : X, x <= z -> y <= z -> join x y <= z.
Proof (sl_meet_glb _ _ (l_proof X)).

(**
** Dual Latice
The dual of a lattice is a lattice. *)
Definition Dual : Lattice :=
@makeLattice (Dual X) (@join X) (@meet X)
 join_ub_l
 join_ub_r
 join_lub
 (@meet_lb_l X)
 (@meet_lb_r X)
 (@meet_glb X).

(** All the lemmas about meet semilattices hold for join. *)
Lemma join_comm :  forall x y:X, join x y == join y x.
Proof meet_comm Dual.

Lemma join_assoc : forall x y z:X, join x (join y z) == join (join x y) z.
Proof meet_assoc Dual.

Lemma join_idem : forall x:X, join x x == x.
Proof meet_idem Dual.

Lemma le_join_l : forall x y : X, y <= x <-> join x y == x.
Proof le_meet_l Dual.

Lemma le_join_r : forall x y : X, x <= y <-> join x y == y.
Proof le_meet_r Dual.

Lemma join_monotone_r : forall a : X, monotone X (join a).
Proof meet_monotone_r Dual.

Lemma join_monotone_l : forall a : X, monotone X (fun x => join x a).
Proof meet_monotone_l Dual.

Lemma join_le_compat : forall w x y z : X, w<=y -> x<=z -> join w x <= join y z.
Proof fun w x y z => meet_le_compat Dual y z w x.

End Join.
(* begin hide *)
Add Parametric Morphism X : (@join X) with signature (@st_eq (sl X)) ==> (@st_eq X) ==> (@st_eq X) as join_compat.
Proof.
 exact (meet_compat (Dual X)).
Qed.
(* end hide *)
Section MeetJoin.

Variable X : Lattice.
(** Lemma about how meet and join interact. *)
Lemma meet_join_absorb_l_l : forall x y:X, meet x (join x y) == x.
Proof.
 intros.
 apply le_antisym.
  apply meet_lb_l.
 apply meet_glb.
  apply le_refl.
 apply join_ub_l.
Qed.

Lemma meet_join_absorb_l_r : forall x y:X, meet x (join y x) == x.
Proof.
 intros.
 rewrite -> (join_comm X).
 apply meet_join_absorb_l_l.
Qed.

Lemma meet_join_absorb_r_l : forall x y:X, meet (join x y) x == x.
Proof.
 intros.
 rewrite -> (meet_comm X).
 apply meet_join_absorb_l_l.
Qed.

Lemma meet_join_absorb_r_r : forall x y:X, meet (join y x) x == x.
Proof.
 intros.
 rewrite -> (join_comm X).
 apply meet_join_absorb_r_l.
Qed.

Lemma meet_join_eq : forall x y : X, meet x y == join x y -> x == y.
Proof.
 intros.
 rewrite <- (meet_join_absorb_l_l y x).
 rewrite -> (join_comm X y x).
 rewrite <- H.
 rewrite -> (meet_comm X x y).
 rewrite -> (meet_assoc X).
 rewrite -> (meet_idem X).
 set (RHS := meet y x).
 rewrite <- (meet_join_absorb_l_l x y).
 rewrite <- H.
 rewrite -> (meet_assoc X).
 rewrite -> (meet_idem X).
 rewrite -> (meet_comm X).
 reflexivity.
Qed.

End MeetJoin.

Section JoinMeet.

Variable X : Lattice.
(** The dual of the previous laws holds. *)
Lemma join_meet_absorb_l_l : forall x y:X, join x (meet x y) == x.
Proof meet_join_absorb_l_l (Dual X).

Lemma join_meet_absorb_l_r : forall x y:X, join x (meet y x) == x.
Proof meet_join_absorb_l_r (Dual X).

Lemma join_meet_absorb_r_l : forall x y:X, join (meet x y) x == x.
Proof meet_join_absorb_r_l (Dual X).

Lemma join_meet_absorb_r_r : forall x y:X, join (meet y x) x == x.
Proof meet_join_absorb_r_r (Dual X).

End JoinMeet.