Require Import
  Coq.Program.Program
  Coq.Unicode.Utf8
  Coq.Classes.Morphisms
  Coq.Lists.List
  CDS4LTL.Model.

Open Scope program_scope.
Open Scope list_scope.

Module LTLStep.

Module Import LTL := LTL.

Section Step.

Context {a : Type}.

(** This data type encodes the syntax of LTL in Positive Normal Form (PNF). *)
Inductive Formula : Type :=
  | Top
  | Bottom
  | Examine       (v   : option a -> Formula)
  | And           (p q : Formula)
  | Or            (p q : Formula)
  | Next          (p   : Formula)
  | Until         (p q : Formula)
  | Wait          (p q : Formula)
  | Always        (p   : Formula)
  | Eventually    (p   : Formula)
  | Release       (p q : Formula)
  | StrongRelease (p q : Formula).

Inductive Failed : Type :=
  | HitBottom
  | EndOfTrace
  | Rejected    (x : a)
  | BothFailed  (p q : Failed)
  | LeftFailed  (p : Failed)
  | RightFailed (q : Failed).

Inductive Result : Type :=
  | Failure  (e : Failed)
  | Continue (l : Formula)
  | Success.

Open Scope ltl_scope.

Fixpoint negate (l : Formula) : Formula :=
  match l with
  | Top               => Bottom
  | Bottom            => Top
  | Examine v         => Examine (negate ∘ v)
  | And p q           => Or (negate p) (negate q)
  | Or p q            => And (negate p) (negate q)
  | Next p            => Next (negate p)
  | Until p q         => Release (negate p) (negate q)
  | Wait p q          => StrongRelease (negate p) (negate q)
  | Always p          => Eventually (negate p)
  | Eventually p      => Always (negate p)
  | Release p q       => Until (negate p) (negate q)
  | StrongRelease p q => Wait (negate p) (negate q)
  end.

Fixpoint size (p : Formula) : nat :=
  match p with
  | Top               => 1
  | Bottom            => 1
  | Examine v         => 1
  | And p q           => 1 + size p + size q
  | Or p q            => 1 + size p + size q
  | Next p            => 1 + size p
  | Until p q         => 1 + size p + size q
  | Wait p q          => 1 + size p + size q
  | Always p          => 1 + size p
  | Eventually p      => 1 + size p
  | Release p q       => 1 + size p + size q
  | StrongRelease p q => 1 + size p + size q
  end.

Definition and_result (f g : Result) : Result :=
  match f, g with
  | Failure e, _   => Failure (LeftFailed e)
  | _, Failure e   => Failure (RightFailed e)
  | Continue f',
    Continue g'    => Continue (And f' g')
  | f', Success    => f'
  | Success, g'    => g'
  end.

Definition or_result (f g : Result) : Result :=
  match f, g with
  | Failure e1,
    Failure e2     => Failure (BothFailed e1 e2)
  | Success, _     => Success
  | _, Success     => Success
  | Continue f',
    Continue g'    => Continue (Or f' g')
  | Failure _, g'  => g'
  | f', Failure _  => f'
  end.

Fixpoint compile (l : Formula) : option a -> Result := fun mx =>
  match l with
  | Top    => Success
  | Bottom => Failure HitBottom

  | Examine v =>
    match mx with
    | None   => compile (v None) None
    | Some x => compile (v (Some x)) (Some x)
    end

  | And p q => and_result (compile p mx) (compile q mx)
  | Or p q  => or_result (compile p mx) (compile q mx)

  | Next p   =>
    match mx with
    | None   => compile p None
    | Some _ => Continue p
    end

  | Until p q =>
    match mx with
    | None   => compile q None
    | Some x => or_result (compile q mx)
                          (and_result (compile p mx) (Continue (Until p q)))
    end

  | Release p q =>
    match mx with
    | None   => compile q None
    | Some x => and_result (compile q mx)
                           (or_result (compile p mx) (Continue (Release p q)))
    end

  | Always p =>
    match mx with
    | None   => compile p None
    | Some x => and_result (compile p mx) (Continue (Always p))
    end

  | Eventually p =>
    match mx with
    | None   => compile p None
    | Some x => or_result (compile p mx) (Continue (Eventually p))
    end

  | Wait p q =>
    match mx with
    | None   => or_result (compile q None) (compile p None)
    | Some x => or_result (compile q mx)
                          (and_result (compile p mx) (Continue (Wait p q)))
    end

  | StrongRelease p q =>
    match mx with
    | None   => and_result (compile q None) (compile p None)
    | Some x => and_result (compile q mx)
                           (or_result (compile p mx) (Continue (StrongRelease p q)))
    end
  end.

Definition step (m : Result) (x : a) : Result :=
  match m with
  | Continue l => compile l (Some x)
  | r => r
  end.

Fixpoint run (m : Formula) (xs : list a) : Result :=
  match xs with
  | nil     => compile m None
  | x :: xs =>
    match compile m (Some x) with
    | Continue l => run l xs
    | Failure e  => Failure e
    | Success    => Success
    end
  end.

Definition passes (r : Result) : Prop :=
  match r with
  | Failure e  => False
  | Continue _ => True
  | Success    => True
  end.

Definition passes_equiv (p q : Result) : Prop := passes p <-> passes q.
Arguments passes_equiv p q /.

#[global]
Program Instance Equivalence_passes_equiv : Equivalence passes_equiv.
Next Obligation.
  unfold passes_equiv.
  repeat intro; auto.
  reflexivity.
Qed.
Next Obligation.
  unfold passes_equiv.
  repeat intro; intuition.
Qed.
Next Obligation.
  unfold passes_equiv.
  repeat intro; firstorder.
Qed.

Lemma run_and p q s :
  passes (run (And p q) s) <-> passes (run p s) /\ passes (run q s).
Proof.
  split; intros.
  - generalize dependent p.
    generalize dependent q.
    induction s; simpl; intros; intuition.
    + destruct (compile p None); simpl in *; intuition.
    + destruct (compile q None); simpl in *; intuition.
      destruct (compile p None); simpl in *; intuition.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition.
      destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
      now specialize (IHs _ _ H).
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
      destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
      now specialize (IHs _ _ H).
  - generalize dependent p.
    generalize dependent q.
    induction s; simpl; intros; intuition.
    + destruct (compile p None) eqn:?; simpl in *; intuition;
      destruct (compile q None) eqn:?; simpl in *; intuition.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
      destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
Qed.

Lemma run_or p q s :
  passes (run (Or p q) s) <-> passes (run p s) \/ passes (run q s).
Proof.
  split; intros.
  - generalize dependent p.
    generalize dependent q.
    induction s; simpl; intros; intuition.
    + destruct (compile p None); simpl in *; intuition;
      destruct (compile q None); simpl in *; intuition.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
      destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
  - generalize dependent p.
    generalize dependent q.
    induction s; simpl; intros; intuition.
    + destruct (compile p None) eqn:?; simpl in *; intuition;
      destruct (compile q None) eqn:?; simpl in *; intuition.
    + destruct (compile p None) eqn:?; simpl in *; intuition;
      destruct (compile q None) eqn:?; simpl in *; intuition.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
      destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
      destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
Qed.

Lemma run_next p x xs :
  passes (run (Next p) (x :: xs)) <-> passes (run p xs).
Proof. now induction xs; intuition. Qed.

Lemma run_until p q s :
  passes (run (Until p q) s) <->
  let fix go s :=
      match s with
      | nil     => passes (run q s)
      | _ :: xs => passes (run q s) \/ (passes (run p s) /\ go xs)
      end in go s.
Proof.
  split; intros.
  - generalize dependent p.
    generalize dependent q.
    induction s; simpl; intros; intuition.
    destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
    destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
    + rewrite run_and in H.
      now firstorder.
    + rewrite run_or, run_and in H.
      now firstorder.
    + now firstorder.
    + rewrite run_or in H.
      now firstorder.
  - generalize dependent p.
    generalize dependent q.
    induction s; simpl; intros; intuition.
    destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
    destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
    + rewrite run_or, run_and.
      now firstorder.
    + rewrite run_or.
      now firstorder.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
      destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
      * rewrite run_and.
        now firstorder.
      * rewrite run_or, run_and.
        now firstorder.
      * rewrite run_or.
        now firstorder.
Qed.

Lemma run_wait p q s :
  passes (run (Wait p q) s) <->
  let fix go s :=
      match s with
      | nil     => passes (run q s) \/ passes (run p s)
      | _ :: xs => passes (run q s) \/ (passes (run p s) /\ go xs)
      end in go s.
Proof.
  split; intros.
  - generalize dependent p.
    generalize dependent q.
    induction s; simpl; intros; intuition.
    + destruct (compile p None) eqn:?; simpl in *; intuition;
      destruct (compile q None) eqn:?; simpl in *; intuition.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
      destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
      * rewrite run_and in H.
        now firstorder.
      * rewrite run_or, run_and in H.
        now firstorder.
      * now firstorder.
      * rewrite run_or in H.
        now firstorder.
  - generalize dependent p.
    generalize dependent q.
    induction s; simpl; intros; intuition.
    + destruct (compile p None) eqn:?; simpl in *; intuition;
      destruct (compile q None) eqn:?; simpl in *; intuition.
    + destruct (compile p None) eqn:?; simpl in *; intuition;
      destruct (compile q None) eqn:?; simpl in *; intuition.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
      destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
      * rewrite run_or, run_and.
        now firstorder.
      * rewrite run_or.
        now firstorder.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
      destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
      * rewrite run_and.
        now firstorder.
      * rewrite run_or, run_and.
        now firstorder.
      * rewrite run_or.
        now firstorder.
Qed.

Lemma run_always p s :
  passes (run (Always p) s) <->
  let fix go s :=
      match s with
      | nil     => passes (run p s)
      | _ :: xs => passes (run p s) /\ go xs
      end in go s.
Proof.
  split; intros.
  - generalize dependent p.
    induction s; simpl; intros; intuition.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition.
      rewrite run_and in H.
      now firstorder.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition.
      * rewrite run_and in H.
        now firstorder.
      * now firstorder.
  - generalize dependent p.
    induction s; simpl; intros; intuition.
    destruct (compile p (Some a0)) eqn:?; simpl in *; intuition.
    rewrite run_and.
    now firstorder.
Qed.

Lemma run_eventually p s :
  passes (run (Eventually p) s) <->
  let fix go s :=
      match s with
      | nil     => passes (run p s)
      | _ :: xs => passes (run p s) \/ go xs
      end in go s.
Proof.
  split; intros.
  - generalize dependent p.
    induction s; simpl; intros; intuition.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition.
      * now firstorder.
      * rewrite run_or in H.
        now firstorder.
  - generalize dependent p.
    induction s; simpl; intros; intuition.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition.
      rewrite run_or.
      now firstorder.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition.
      rewrite run_or.
      now firstorder.
Qed.

Lemma run_release p q s :
  passes (run (Release p q) s) <->
  let fix go s :=
      match s with
      | nil     => passes (run q s)
      | _ :: xs => passes (run q s) /\ (passes (run p s) \/ go xs)
      end in go s.
Proof.
  split; intros.
  - generalize dependent p.
    generalize dependent q.
    induction s; simpl; intros; intuition.
    destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
    destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
    + rewrite run_and in H.
      now firstorder.
    + rewrite run_and, run_or in H.
      now firstorder.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
      destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
      * rewrite run_and in H.
        now firstorder.
      * now firstorder.
      * rewrite run_and, run_or in H.
        now firstorder.
      * rewrite run_or in H.
        now firstorder.
  - generalize dependent p.
    generalize dependent q.
    induction s; simpl; intros; intuition.
    destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
    destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
    + rewrite run_and, run_or.
      now firstorder.
    + rewrite run_or.
      now firstorder.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
      destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
      * rewrite run_and.
        now firstorder.
      * rewrite run_and, run_or.
        now firstorder.
      * rewrite run_or.
        now firstorder.
Qed.

Lemma run_strong_release p q s :
  passes (run (StrongRelease p q) s) <->
  let fix go s :=
      match s with
      | nil     => passes (run q s) /\ passes (run p s)
      | _ :: xs => passes (run q s) /\ (passes (run p s) \/ go xs)
      end in go s.
Proof.
  split; intros.
  - generalize dependent p.
    generalize dependent q.
    induction s; simpl; intros; intuition.
    + destruct (compile p None) eqn:?; simpl in *; intuition;
      destruct (compile q None) eqn:?; simpl in *; intuition.
    + destruct (compile p None) eqn:?; simpl in *; intuition;
      destruct (compile q None) eqn:?; simpl in *; intuition.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
      destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
      * rewrite run_and in H.
        now firstorder.
      * rewrite run_and, run_or in H.
        now firstorder.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
      destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
      * rewrite run_and in H.
        now firstorder.
      * now firstorder.
      * rewrite run_and, run_or in H.
        now firstorder.
      * rewrite run_or in H.
        now firstorder.
  - generalize dependent p.
    generalize dependent q.
    induction s; simpl; intros; intuition.
    + destruct (compile p None) eqn:?; simpl in *; intuition;
      destruct (compile q None) eqn:?; simpl in *; intuition.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
      destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
      * rewrite run_and, run_or.
        now firstorder.
      * rewrite run_or.
        now firstorder.
    + destruct (compile p (Some a0)) eqn:?; simpl in *; intuition;
      destruct (compile q (Some a0)) eqn:?; simpl in *; intuition.
      * rewrite run_and.
        now firstorder.
      * rewrite run_and, run_or.
        now firstorder.
      * rewrite run_or.
        now firstorder.
Qed.

(*
Lemma run_correct (l : Formula) (s : list a) :
 matches l s <-> passes (run l s).
Proof.
  generalize dependent s.
  induction l; intros.
  - now induction s.
  - now induction s.
  - induction s; intuition.
    + now specialize (proj1 (H _ _) H0).
    + now apply H, H0.
    + now specialize (proj1 (H _ _) H2).
    + now apply H, H2.
  - split; intros.
      destruct H.
      specialize (proj1 (IHl1 _) H); intros; clear IHl1 H.
      specialize (proj1 (IHl2 _) H0); intros; clear IHl2 H0.
      now apply run_and.
    apply run_and in H.
    now firstorder.
  - split; intros.
      destruct H.
        specialize (proj1 (IHl1 _) H); intros; clear IHl1 H.
        apply run_or.
        now left.
      specialize (proj1 (IHl2 _) H); intros; clear IHl2 H.
      apply run_or.
      now right.
    apply run_or in H.
    now firstorder.
  - split; intros;
    induction s; intuition.
    + now apply IHl in H.
    + now apply IHl in H.
    + now apply IHl.
    + now apply IHl.
  - split; intros.
      apply run_until.
      simpl.
      now induction s; firstorder.
    apply run_until in H.
    now induction s; firstorder.
  - split; intros.
      apply run_wait.
      simpl.
      now induction s; firstorder.
    apply run_wait in H.
    now induction s; firstorder.
  - split; intros.
      apply run_always.
      simpl.
      now induction s; firstorder.
    apply run_always in H.
    now induction s; firstorder.
  - split; intros.
      apply run_eventually.
      simpl.
      now induction s; firstorder.
    apply run_eventually in H.
    now induction s; firstorder.
  - split; intros.
      apply run_release.
      simpl.
      now induction s; firstorder.
    apply run_release in H.
    now induction s; firstorder.
  - split; intros.
      apply run_strong_release.
      simpl.
      now induction s; firstorder.
    apply run_strong_release in H.
    now induction s; firstorder.
Qed.
*)

End Step.

End LTLStep.

Require Import Coq.Arith.PeanoNat.

Module StepExamples.

Module Import S := LTLStep.
Import S.LTL.

Import ListNotations.

#[global]
Declare Scope boolean_scope.
Bind Scope boolean_scope with Formula.
Delimit Scope boolean_scope with boolean.
Open Scope boolean_scope.

Notation "¬ p"    := (negate p)      (at level 75, right associativity) : boolean_scope.
Infix    "∨"      := Or              (at level 85, right associativity) : boolean_scope.
Notation "p ⇒ q"  := (¬ p ∨ q)       (at level 86, right associativity) : boolean_scope.
Notation "⊤"      := True            (at level 0, no associativity) : boolean_scope.
Notation "⊥"      := False           (at level 0, no associativity) : boolean_scope.
Infix    "∧"      := And             (at level 80, right associativity) : boolean_scope.
(* Infix    "⟹"     := implies         (at level 99, right associativity) : boolean_scope. *)
(* Infix    "≈"      := equivalent      (at level 90, no associativity) : boolean_scope. *)

#[global]
Declare Scope ltl_scope.
Bind Scope ltl_scope with Formula.
Delimit Scope ltl_scope with ltl.
Open Scope boolean_scope.
Open Scope ltl_scope.

Notation "◯ p"       := (Next p)             (at level 75, right associativity) : ltl_scope.
Notation "◇ p"       := (Eventually p)       (at level 75, right associativity) : ltl_scope.
Notation "□ p"       := (Always p)           (at level 75, right associativity) : ltl_scope.
Notation "p 'U' q"   := (Until p q)          (at level 79, right associativity) : ltl_scope.
Notation "p 'W' q"   := (Wait p q)           (at level 79, right associativity) : ltl_scope.
Notation "p 'R' q"   := (Release p q)        (at level 79, right associativity) : ltl_scope.
Notation "p 'M' q"   := (StrongRelease p q) (at level 79, right associativity) : ltl_scope.
Notation "'Λ' x , p" := (Examine (λ x , p))  (at level 97, no associativity) : ltl_scope.

Open Scope ltl_scope.

Definition num (n : nat) : @Formula nat :=
  Λ x, match x with
       | Some x => if x =? n then Top else Bottom
       | None => Bottom
       end.

Definition if_then {a : Type} (p : a -> bool) (f : a -> Formula) :=
  Λ x, match x with
       | Some x => if p x then f x else Top
       | None => Top
       end.

Fixpoint series {a : Type} (l : list (@Formula a)) : @Formula a :=
  match l with
  | nil => Top
  | x :: nil => x
  | x :: xs => x ∧ Next (series xs)
  end.

Example ex_match_query  :
  passes (run (num 1 ∧ ◯ (num 2)) [1; 2]).
Proof. constructor. Qed.

Example ex_match_series :
  passes (run (series [num 1; num 2]) [1; 2]).
Proof. constructor. Qed.

Example ex_match_sample1 :
  passes (run (◇ (num 3 ⇒ ◇ (num 8))) [1; 2; 3; 4; 5; 6; 7; 8; 9]).
Proof. constructor. Qed.

Example ex_match_sample2 :
  passes (run (◇ (if_then (λ n, n =? 3) (λ n, ◇ (num (n + 5)))))
              [1; 2; 3; 4; 5; 6; 7; 8; 9]).
Proof. constructor. Qed.

End StepExamples.


Require Import
  CMorphisms
  FormTopC.FormTop
  Algebra.SetsC
  Algebra.OrderC
  Algebra.PreOrder
  Prob.StdLib.

Set Universe Polymorphism.
Local Open Scope Subset.
Local Open Scope FT.

(** Continuous maps. *)
Module Cont.

Definition map@{AS PS XS AT PT XT PS'}
  (S : PreSpace.t@{AS PS XS})
  (T : PreSpace.t@{AT PT XT}) : Type@{PS'}
  := T -> Subset@{AS PS} S.

Section Cont.
Universes AS PS XS AT PT XT PS'.
Context {S : PreSpace.t@{AS PS XS}}
        {T : PreSpace.t@{AT PT XT}}.

Record t@{} {F_ : map@{AS PS XS AT PT XT PS'} S T} : Type :=
  { here : forall a, a <|[S] (union@{AT AS PT PS} (fun _ : T => True) F_)
  ; le_left : forall a b c, a <=[PreSpace.S S] c -> F_ b c -> F_ b a
  ; local : forall {a b c}, F_ b a -> F_ c a
    -> a <|[S] union@{AT AS PT PS} (eq b ↓ eq c) F_
  ; cov : forall {a b} V, F_ b a -> b <|[T] V
    -> a <|[S] union@{AT AS PT PS} V F_
  }.

Arguments t F_ : clear implicits.

Definition Sat@{} (F_ : map@{AS PS XS AT PT XT PS'} S T)
  : map@{AS PS XS AT PT XT PS'} S T := fun t s =>
  s <|[S] F_ t.

Definition func_LE@{}
  (F_ G_ : map@{AS PS XS AT PT XT PS'} S T) : Type@{PS'} :=
  RelIncl@{AT AS PS PS'} (Sat F_) (Sat G_).

Definition func_EQ@{} (F_ G_ : map S T) : Type@{PS'} :=
  RelSame@{AT AS PS PS'} (Sat F_) (Sat G_).

Context {POS : PreO.t@{AS PS} (le (PreSpace.S S))}
        {POT : PreO.t@{AT PT} (le (PreSpace.S T))}.

Global Instance func_LE_PreOrder : CRelationClasses.PreOrder func_LE.
Proof.
constructor; unfold Reflexive, Transitive, func_LE; intros.
- reflexivity.
- etransitivity; eassumption.
Qed.

Global Instance func_EQ_Equivalence : Equivalence func_EQ.
Proof.
constructor; unfold Reflexive, Transitive, Symmetric, func_EQ; intros.
- reflexivity.
- symmetry; assumption.
- etransitivity; eassumption.
Qed.

Lemma func_LE_antisym : forall (F F' : map S T),
  func_LE F F' -> func_LE F' F -> func_EQ F F'.
Proof.
unfold func_LE, func_EQ. intros.
apply RelIncl_RelSame; assumption.
Qed.

Lemma func_EQ_LE F F' : func_EQ F F' -> func_LE F F'.
Proof.
unfold func_EQ, func_LE. intros. apply RelSame_RelIncl.
assumption.
Qed.

Record pt {F : Subset T} :=
  { pt_here : Inhabited F
  ; pt_local : forall {b c}, F b -> F c -> Inhabited ((eq b ↓ eq c) ∩ F)
  ; pt_cov : forall {b V}, F b -> b <| V -> Inhabited (F ∩ V)
  }.

Arguments pt F : clear implicits.

(** Convert a continuous map for formal topologies to a
    frame homomorphism (i.e., continuous map on locales)
  *)
Definition frame (F_ : map S T) (U : Subset T) : Subset S :=
  union U F_.

Context {FTS : FormTop.t S} {FTT : FormTop.t T}.

Lemma Sat_mono2 (F_ : map S T) : F_ ⊑ Sat F_.
Proof.
unfold RelIncl. intros. unfold Sat.
unfold Included, pointwise_rel, arrow; intros.
apply FormTop.refl. assumption.
Qed.

Lemma Sat_mono (F_ G_ : map S T) :
  F_ ⊑ G_ ->
  Sat F_ ⊑ Sat G_.
Proof.
unfold RelIncl, Sat; intros.
unfold Included, pointwise_rel, arrow; intros.
eapply FormTop.monotone. apply X. assumption.
Qed.

Lemma Sat_idempotent (F_ : map S T) :
  Sat F_ ==== Sat (Sat F_).
Proof.
apply RelIncl_RelSame. apply Sat_mono2.
unfold RelIncl, Included, pointwise_rel, arrow, Sat.
intros.
eapply FormTop.trans. eassumption.
intros. assumption.
Qed.

Lemma func_EQ_Sat (F_ G_ : map S T)
  : func_EQ F_ G_ -> func_EQ (Sat F_) (Sat G_).
Proof.
unfold func_EQ. intros.
rewrite <- !Sat_idempotent. assumption.
Qed.

Lemma Cov_Sat : forall a U (F_ : map S T),
  a <|[S] union U F_ ->
  a <|[S] union U (Sat F_).
Proof.
intros. eapply FormTop.Cov_Proper. reflexivity.
eapply union_monotone.
eapply Sat_mono2. eassumption.
Qed.

Lemma t_Sat {F_ : map S T} (H : t F_)
  : t (Sat F_).
Proof.
constructor; intros.
- apply Cov_Sat. apply (here H).
- unfold Sat in *. eapply FormTop.le_left; eassumption.
- unfold Sat in X, X0. FormTop.ejoin. FormTop.etrans.
  apply Cov_Sat.
  destruct X1 as [[ub Fub lb] [uc Fuc lc]].
  apply (local H); (eapply (le_left H); [| eassumption]);
    assumption.
- unfold Sat in X. FormTop.etrans.
  apply Cov_Sat. eapply (cov H); eassumption.
Qed.

Section DirectedSup.
Context {Ix : Type} `{JoinLat.t Ix}.
Variable (f : Ix -> map S T).
Variable (fmono : forall i j, JoinLat.le i j -> f i ⊑ f j).
Definition func_Dsup : map S T := fun t s =>
  { i : Ix & f i t s }.

Lemma oneIncl i : f i ⊑ func_Dsup.
Proof.
intros. unfold RelIncl, Included, pointwise_rel, arrow; intros.
exists i. assumption.
Qed.

Lemma single_Dsup : forall i a U,
 a <| union U (f i) ->
 a <| (union U func_Dsup).
Proof.
intros. eapply FormTop.Cov_Proper.
reflexivity. apply union_monotone. apply (oneIncl i).
assumption.
Qed.

Variable nonempty : Ix.

Lemma func_Dsup_Cont : (forall i, Cont.t (f i)) -> Cont.t func_Dsup.
Proof.
intros iCont. constructor; intros.
- eapply single_Dsup. apply (Cont.here (iCont nonempty)).
- unfold func_Dsup in *. destruct X0.
  exists x. eapply (Cont.le_left (iCont x)); eassumption.
- destruct X, X0.
  pose (x' := JoinLat.max x x0).
  apply single_Dsup with x'.
  apply (Cont.local (iCont x')).
  eapply fmono; (apply JoinLat.max_ok || assumption).
  eapply fmono. eapply PreO.max_r. apply JoinLat.max_ok.
  assumption.
- destruct X. apply single_Dsup with x.
  eapply (Cont.cov (iCont x)). eassumption. assumption.
Qed.

End DirectedSup.

End Cont.

Arguments t : clear implicits.
Arguments pt : clear implicits.

(** I might have broken this tactic. *)
Ltac ecov := match goal with
 | [ H : In (?f _) ?a, X : t ?S _ ?F
      |- ?Cov ?S ?a (union _ ?F) ] =>
    eapply (cov X _ H)
  end.

Section Morph.

Context {S : PreSpace.t}.
Context {POS : PreO.t (le (PreSpace.S S))}
        {FTS : FormTop.t S}.

Definition id (x y : S) := (y <= x)%FT.

Theorem t_id : t S S id.
Proof.
constructor; intros; unfold id in *.
- eapply FormTop.refl. exists a; eauto. unfold In. constructor.
  reflexivity.
- eapply PreO.le_trans; eassumption.
- apply FormTop.refl. exists a.
  apply down_eq.
split; eassumption.
  reflexivity.
- eapply FormTop.le_left; try eassumption.
  clear X. FormTop.trans X0.
  apply FormTop.refl. econstructor. eassumption.
  reflexivity.
Qed.

Context {T : PreSpace.t}.
Context {POT : PreO.t (le (PreSpace.S T))}
        {FTT : FormTop.t T}.

Context {U : PreSpace.t}.
Context {POU : PreO.t (le (PreSpace.S U))}
        {FTU : FormTop.t U}.

(*
Everything in s maps to u
iff there is some subset T such that
  everything in s maps to T and
  everything in T maps to u
*)

Theorem t_compose : forall (F : map S T) (G : map T U),
    t S T F
  -> t T U G
  -> t S U (compose G F).
Proof.
intros. constructor; intros.
- pose proof (here X a) as X1.
  FormTop.trans X1. destruct X1. destruct i.
  pose proof (here X0 a0).
  pose proof (cov X _ f X1).
  refine (FormTop.monotone _ _ _ _ X2).
  apply Same_set_Included. symmetry.
  apply union_compose.
- unfold compose in *.
  intros.
  destruct X2 as [t1 [Fat1 Gt1b]].
  exists t1. split. eassumption. eapply (le_left X). eassumption.
  assumption.
- destruct X1 as [t1 [Gt1b Fat1]].
  destruct X2 as [t2 [Gt2b Fat2]].
  pose proof (local X Fat1 Fat2).
  eapply FormTop.trans.
  eassumption. simpl. intros.
  destruct X2 as [tt downtt].
  apply (FormTop.monotone)
  with (union (union (eq b ↓ eq c) G) F).
  apply Same_set_Included. symmetry.
  apply union_compose.
  eapply (cov X). eassumption.
  apply down_eq in downtt.
  destruct downtt as [tt1 tt2].
  apply (local X0).
  eapply (le_left X0). eapply tt1. eassumption.
  eapply (le_left X0). eapply tt2. eassumption.
- destruct X1 as [t [Gtb Fat]].
  apply (FormTop.monotone) with (union (union V G) F).
  apply Same_set_Included. symmetry. apply union_compose.
  apply (cov X _ Fat).
  apply (cov X0 _ Gtb). assumption.
Qed.

Lemma compose_proper_LE : forall (F F' : map S T) (G G' : map T U),
  Cont.t S T F' ->
  func_LE (S := S) F F' -> func_LE (S := T) G G' ->
  func_LE (S := S) (compose G F) (compose G' F').
Proof.
unfold func_LE, compose.
intros F F' G G' ContF X X0. unfold RelSame.
intros. unfold RelIncl, Included, pointwise_rel, arrow.
unfold Sat, In.
intros. unfold In in *.
FormTop.trans X1. destruct X1. destruct p.
  apply (Sat_mono2 (S := T)) in g.
  apply (Sat_mono2 (S := S)) in f.
  apply X0 in g. apply X in f.
  unfold Sat in g, f. FormTop.etrans.
  pose proof (fun a b => Cont.cov ContF (a := a) (b := b)).
  specialize (X1 _ _ _ f g). clear f.
  FormTop.etrans. destruct X1.
  apply FormTop.refl. exists a1. split; assumption.
Qed.

Lemma compose_proper : forall (F F' : map S T) (G G' : map T U),
  Cont.t S T F ->
  Cont.t S T F' ->
  func_EQ (S := S) F F' -> func_EQ (S := T) G G' ->
  func_EQ (S := S) (compose G F) (compose G' F').
Proof.
intros. apply func_LE_antisym; apply compose_proper_LE;
  repeat (assumption || apply func_EQ_LE || symmetry).
Qed.

End Morph.
End Cont.

Arguments Cont.t : clear implicits.

Module IGCont.
Section IGCont.

Context {S : PreSpace.t}.
Context {T : PreISpace.t}.

Context {POS : PreO.t (le S)}
        {POT : PreO.t (le T)}.

Record t {F_ : Cont.map S (toPSL T)} :=
  { here : forall a, a <|[S] union (fun _ : T => True) F_
  ; local : forall a b c, F_ b a -> F_ c a ->
       a <|[S] union (eq b ↓ eq c) F_
  ; le_left : forall a b c, a <=[S] c -> F_ b c -> F_ b a
  ; le_right :  forall a b c, F_ b a -> b <=[T] c -> F_ c a
  ; ax_right : forall a t t' (j : PreISpace.Ix T t'),
     t <= t' -> F_ t a ->
     a <|[S] union (eq t ↓ PreISpace.C T t' j) F_
  }.

Arguments t : clear implicits.

Context {FTS : FormTop.t S}.

(** Lemma 2.28 of "Exponentiation of unary topologies over
    inductively generated formal topologies" *)
Theorem cont : forall F, t F -> Cont.t S (toPSL T) F.
Proof.
intros. constructor; intros.
- apply (here X).
- eapply le_left; eassumption.
- apply local; assumption.
- generalize dependent a. induction X1; intros.
  + apply FormTop.refl. exists a; assumption.
  + apply IHX1. eapply le_right; eassumption.
  + pose proof (ax_right X _ _ _ i l X1) as X2.
    clear X1.
    FormTop.etrans. destruct X2.
    eapply X0; eassumption.
Qed.

(** I should look at Lemma 2.19 of dexplong.pdf *)
Lemma pos F (H : t F) `{FormTop.tPos S} `{FormTop.gtPos T} : forall (t : T) (s : S),
  F t s -> Pos s -> gPos t.
Proof.
intros.
Admitted.

Existing Instances union_Proper FormTop.Cov_Proper.

Theorem converse : forall F, Cont.t S (toPSL T) F
  -> t (@Cont.Sat S (toPSL T) F).
Proof.
intros.
constructor; intros.
- apply (Cont.Cov_Sat (T := toPSL T)). apply (Cont.here X).
- unfold Cont.Sat in *.
  apply Cont.Cov_Sat. FormTop.ejoin. FormTop.etrans.
  destruct X2. destruct d, d0.
  apply (Cont.local X); eapply (Cont.le_left X).
  apply l. assumption. apply l0. assumption.
- unfold Cont.Sat in *.
  eapply FormTop.le_left; eassumption.
- unfold Cont.Sat in *.
  FormTop.etrans.
  assert (b <|[toPSL T] eq c).
  eapply FormTop.glle_left. eassumption.
  apply FormTop.glrefl. reflexivity.
  pose proof (Cont.cov X (a := a) (b := b) (eq c)).
  eapply FormTop.monotone. Focus 2. apply X3.
  assumption. assumption.
  apply union_eq.
- unfold Cont.Sat in X1. FormTop.etrans.
  apply (Cont.Cov_Sat (T := toPSL T)). Cont.ecov.
  apply FormTop.gle_infinity with _ j. assumption.
  intros. apply FormTop.glrefl. assumption.
Qed.

Record pt {F : Subset T} :=
  { pt_here : Inhabited F
  ; pt_local : forall {b c}, F b -> F c -> Inhabited ((eq b ↓ eq c) ∩ F)
  ; pt_le_right : forall {a b}, F a -> a <=[T] b -> F b
  ; pt_cov : forall t t' (j : PreISpace.Ix T t'),
     t <= t' -> F t ->
     Inhabited (F ∩ (eq t ↓ PreISpace.C T t' j))
  }.

Arguments pt : clear implicits.

Lemma pt_cont F : pt F -> Cont.pt (toPSL T) F.
Proof.
intros H. constructor; intros.
- apply (pt_here H).
- apply (pt_local H); assumption.
- induction X0.
  + exists a; split; assumption.
  + apply IHX0. eapply (pt_le_right H); eassumption.
  + destruct (pt_cov H _ _ i l X). destruct i0.
    eapply X0; eassumption.
Qed.

Lemma pt_cont_converse F : Cont.pt (toPSL T) F -> pt F.
Proof.
intros H. constructor; intros.
- apply (Cont.pt_here H).
- apply (Cont.pt_local H); assumption.
- pose proof (Cont.pt_cov H X (V := eq b)).
  destruct X1. eapply FormTop.glle_left. eassumption.
  apply FormTop.glrefl. reflexivity.
  destruct i. subst. assumption.
- pose (eq t0 ↓ PreISpace.C T t' j) as V.
  pose proof (Cont.pt_cov H X0 (V := V)).
  eapply X1.
  apply FormTop.gle_infinity with _ j. eassumption.
  intros.  apply FormTop.glrefl. assumption.
Qed.

End IGCont.

Arguments pt : clear implicits.
Arguments t : clear implicits.

End IGCont.

Module IGLCont.
Section IGLCont.

Context {S : PreSpace.t}.
Context {T : PreISpace.t}.

Context {POS : PreO.t (le S)}
        {POT : PreO.t (le T)}.

Record pt {F : Subset T} :=
  { pt_here : Inhabited F
  ; pt_local : forall {b c}, F b -> F c -> Inhabited ((eq b ↓ eq c) ∩ F)
  ; pt_le_right : forall {a b}, F a -> a <=[T] b -> F b
  ; pt_cov : forall t (i : PreISpace.Ix T t), F t ->
     Inhabited (F ∩ PreISpace.C T t i)
  }.

Arguments pt : clear implicits.

Lemma localized_pt_impl {F : Subset T}
  {loc : localized T} (ptF : pt F) : IGCont.pt T F.
Proof.
econstructor.
- apply (pt_here ptF).
- intros b c. apply (pt_local ptF).
- intros a b. apply (pt_le_right ptF).
- intros.
  pose proof (loc t t' X j).
  destruct X1.
  pose proof (pt_cov ptF t x X0).
  destruct X1.
  destruct i0.
  eexists. split. eassumption.
  apply i. assumption.
Qed.

End IGLCont.
End IGLCont.


Require Import init.

Require Import Coq.Init.Tactics.

Require Import tensor_product_universal.
Require Import tensor_product_isomorphisms.
Require Import tensor_product_assoc.
Require Import module_category.

Require Import nat.
Require Import set.
Require Import list.
Require Import unordered_list.

(* begin hide *)
Section TensorPower.

(* end hide *)
Context {F : CRingObj} (V : ModuleObj F).

(* begin hide *)
Local Arguments cat_compose : simpl never.
Local Arguments cat_id : simpl never.

Infix "⊗" := tensor_product.

(* end hide *)
Fixpoint tensor_power (n : nat) :=
    match n with
    | nat_zero => cring_module F
    | nat_suc n' => V ⊗ tensor_power n'
    end.

(* begin hide *)
Let TPP a := module_plus (tensor_power a).
Let TPZ a := module_zero (tensor_power a).
Let TPN a := module_neg (tensor_power a).
Let TPPC a := module_plus_comm (tensor_power a).
Let TPPA a := module_plus_assoc (tensor_power a).
Let TPPZ a := module_plus_lid (tensor_power a).
Let TPPN a := module_plus_linv (tensor_power a).
Let TPSM a := module_scalar (tensor_power a).
Let TPSMO a := module_scalar_id (tensor_power a).
Let TPSML a := module_scalar_ldist (tensor_power a).
Let TPSMR a := module_scalar_rdist (tensor_power a).
Let TPSMC a := module_scalar_comp (tensor_power a).
Let TP2P a b := module_plus (tensor_power a ⊗ tensor_power b).
Let TP2Z a b := module_zero (tensor_power a ⊗ tensor_power b).
Let TP2SM a b := module_scalar (tensor_power a ⊗ tensor_power b).

Existing Instances TPP TPZ TPN TPPC TPPA TPPZ TPPN TPSM TPSMO TPSML TPSMR TPSMC
    TP2P TP2Z TP2SM.

(* end hide *)
Record generic_tensor_power := make_generic_tensor_power {
    generic_tensor_power_n : nat;
    generic_tensor_power_t : module_V (tensor_power generic_tensor_power_n);
}.

Definition to_generic_tensor {n} (A : module_V (tensor_power n))
    := make_generic_tensor_power n A.

Definition tensor_power_nat_eq {m n : nat} (eq : m = n)
        : cat_morphism (MODULE F) (tensor_power m) (tensor_power n).
    rewrite eq.
    exact 𝟙.
Defined.

Theorem tensor_power_eq_generic : ∀ m n (eq : m = n) A B,
    to_generic_tensor A = to_generic_tensor B →
    tensor_power_nat_eq eq A = B.
Proof.
    intros m n eq A B AB.
    (* I honestly don't know what I'm doing in this proof *)
    inversion AB.
    inversion_sigma.
    subst B.
    rewrite (proof_irrelevance H1_ eq).
    clear H0 H1_ AB.
    destruct eq; cbn.
    reflexivity.
Qed.

Theorem tensor_power_eq : ∀ n (A B : module_V (tensor_power n)),
    to_generic_tensor A = to_generic_tensor B → A = B.
Proof.
    intros n A B eq.
    assert (n = n) as eq' by reflexivity.
    assert (tensor_power_nat_eq eq' A = A) as eq2.
    {
        apply tensor_power_eq_generic.
        reflexivity.
    }
    rewrite <- eq2 at 1.
    apply tensor_power_eq_generic.
    exact eq.
Qed.

Lemma generic_tensor_eq_generic : ∀ m n (eq : m = n) A,
    to_generic_tensor (tensor_power_nat_eq eq A) =
    to_generic_tensor A.
Proof.
    intros m n eq A.
    destruct eq.
    cbn.
    unfold cat_id; cbn.
    reflexivity.
Qed.

Lemma to_generic_tensor_plus : ∀ {m n}
    {A C : module_V (tensor_power m)}
    {B D : module_V (tensor_power n)},
    to_generic_tensor C = to_generic_tensor D →
    to_generic_tensor A = to_generic_tensor B →
    to_generic_tensor (A + C) = to_generic_tensor (B + D).
Proof.
    intros m n A C B D CD AB.
    inversion AB.
    inversion CD.
    inversion_sigma.
    subst B D.
    rewrite (proof_irrelevance H3_ H1_).
    clear H3_ H0 H2 AB CD.
    destruct H1_; cbn.
    reflexivity.
Qed.

Fixpoint tensor_power_mult1 (n : nat)
    : cat_morphism (MODULE F) ((tensor_power n) ⊗ V) (tensor_power (nat_suc n))
:=
    match n with
    | nat_zero => tensor_product_comm_homo (cring_module F) V
    | nat_suc n' =>
        tensor_product_riso_homo V
            (tensor_power n' ⊗ V)
            (tensor_power (nat_suc n'))
            (tensor_power_mult1 n') ∘
        tensor_product_assoc_inv_homo V (tensor_power n') V
    end.

Fixpoint tensor_power_mult (m n : nat)
    : cat_morphism (MODULE F)
        (tensor_power m ⊗ tensor_power n)
        (tensor_power (m + n))
:=
    match n with
    | nat_zero =>
        tensor_power_nat_eq (Logic.eq_sym (plus_rid m)) ∘
        tensor_product_rid_homo (tensor_power m)
    | nat_suc n' =>
        tensor_power_mult (nat_suc m) n' ∘
        tensor_product_liso_homo
            (tensor_power m ⊗ V)
            (tensor_power (nat_suc m))
            (tensor_power n')
            (tensor_power_mult1 m) ∘
        tensor_product_assoc_homo
            (tensor_power m)
            V
            (tensor_power n')
    end.

Theorem tensor_power_mult1_iso :
    ∀ n, isomorphism (C0 := MODULE F) (tensor_power_mult1 n).
Proof.
    intros n.
    induction n.
    -   cbn.
        apply tensor_product_comm_iso.
    -   cbn.
        apply compose_isomorphism.
        +   apply tensor_product_riso_iso.
            exact IHn.
        +   apply tensor_product_assoc_inv_iso.
Qed.

Theorem tensor_power_mult_iso :
    ∀ m n, isomorphism (C0 := MODULE F) (tensor_power_mult m n).
Proof.
    intros m n.
    revert m.
    induction n; intros.
    -   cbn.
        apply compose_isomorphism.
        +   unfold tensor_power_nat_eq, Logic.eq_rect_r, Logic.eq_rect.
            destruct (Logic.eq_sym _).
            apply id_isomorphism.
        +   apply tensor_product_rid_iso.
    -   cbn.
        repeat apply compose_isomorphism.
        +   exact (IHn (nat_suc m)).
        +   apply tensor_product_liso_iso.
            apply tensor_power_mult1_iso.
        +   apply tensor_product_assoc_iso.
Qed.

Fixpoint vectors_to_power (l : list (module_V V))
    : module_V (tensor_power (list_size l))
:=  match l with
    | list_end => @one _ (cring_one F)
    | a ꞉ l' => tensor_mult V (tensor_power (list_size l'))
        a (vectors_to_power l')
    end.

Let tensor_mult' {a b} A B
    := tensor_mult (tensor_power a) (tensor_power b) A B.

Local Infix "⊗'" := tensor_mult' (at level 40, no associativity).

Let f {a b} A := tensor_power_mult a b A.

Lemma f_plus : ∀ a b (A B : module_V (tensor_power a ⊗ tensor_power b)),
    f (A + B) = f A + f B.
Proof.
    intros a b A B.
    unfold f.
    apply (@module_homo_plus _ _ _ (tensor_power_mult a b)).
Qed.
Lemma f_scalar : ∀ a b A (B : module_V (tensor_power a ⊗ tensor_power b)),
    f (A · B) = A · f B.
Proof.
    intros a b A B.
    unfold f.
    apply (@module_homo_scalar _ _ _ (tensor_power_mult a b)).
Qed.
Lemma f_zero : ∀ a b,
    f (zero (U := module_V (tensor_power a ⊗ tensor_power b))) = 0.
Proof.
    intros a b.
    apply module_homo_zero.
Qed.

Lemma tensor_ldist' :
    ∀ a b (A : module_V (tensor_power a)) (B C : module_V (tensor_power b)),
        A ⊗' (B + C) = A ⊗' B + A ⊗' C.
Proof.
    intros a b A B C.
    apply tensor_ldist.
Qed.
Lemma tensor_rdist' :
    ∀ a b (A B : module_V (tensor_power a)) (C : module_V (tensor_power b)),
        (A + B) ⊗' C = A ⊗' C + B ⊗' C.
Proof.
    intros a b A B C.
    apply tensor_rdist.
Qed.
Lemma tensor_lanni' :
    ∀ a b (A : module_V (tensor_power b)),
        (@zero _ (module_zero (tensor_power a))) ⊗' A =
        (@zero _ (module_zero (tensor_power a ⊗ tensor_power b))).
Proof.
    intros a b A.
    apply tensor_product_lanni.
Qed.
Lemma tensor_ranni' :
    ∀ a b (A : module_V (tensor_power a)),
        A ⊗' (@zero _ (module_zero (tensor_power b))) =
        (@zero _ (module_zero (tensor_power a ⊗ tensor_power b))).
Proof.
    intros a b A.
    apply tensor_product_ranni.
Qed.
Lemma tensor_lscalar' :
    ∀ α a b (A : module_V (tensor_power a)) (B : module_V (tensor_power b)),
    (α · A) ⊗' B = α · (A ⊗' B).
Proof.
    intros α a b A B.
    apply tensor_lscalar.
Qed.
Lemma tensor_rscalar' :
    ∀ α a b (A : module_V (tensor_power a)) (B : module_V (tensor_power b)),
    A ⊗' (α · B) = α · (A ⊗' B).
Proof.
    intros α a b A B.
    apply tensor_rscalar.
Qed.

Definition generic_tensor_mult (A B : generic_tensor_power) :=
    make_generic_tensor_power _ (f
    (tensor_mult _ _ (generic_tensor_power_t A) (generic_tensor_power_t B))).

Theorem generic_tensor_mult_eq : ∀ {m n}
    {v1 v2 : module_V V} {B1 : module_V (tensor_power m)}
    {B2 : module_V (tensor_power n)},
    v1 = v2 → to_generic_tensor B1 = to_generic_tensor B2 →
    @to_generic_tensor (nat_suc m) (tensor_mult _ _ v1 B1) =
    @to_generic_tensor (nat_suc n) (tensor_mult _ _ v2 B2).
Proof.
    intros m n v1 v2 B1 B2 eq1 eq2.
    subst v2.
    inversion eq2.
    reflexivity.
Qed.

Theorem generic_tensor_scalar_eq : ∀ {m n}
    {A : module_V (tensor_power m)} {B : module_V (tensor_power n)} α,
    to_generic_tensor A = to_generic_tensor B →
    to_generic_tensor (α · A) = to_generic_tensor (α · B).
Proof.
    intros m n A B α eq.
    inversion eq.
    reflexivity.
Qed.

Lemma to_generic_tensor_f_eq : ∀ {a1 a2 b1 b2 A1 A2 B1 B2},
    to_generic_tensor A1 = to_generic_tensor A2 →
    to_generic_tensor B1 = to_generic_tensor B2 →
    to_generic_tensor (@f a1 b1 (A1 ⊗' B1)) =
    to_generic_tensor (@f a2 b2 (A2 ⊗' B2)).
Proof.
    intros a1 a2 b1 b2 A1 A2 B1 B2 eq1 eq2.
    inversion eq1.
    inversion eq2.
    reflexivity.
Qed.

Theorem vectors_to_power_mult : ∀ l1 l2,
    f (vectors_to_power l1 ⊗' vectors_to_power l2)
    = tensor_power_nat_eq (list_size_conc l1 l2)
        (vectors_to_power (l1 + l2)).
Proof.
    intros l1 l2.
    symmetry; apply tensor_power_eq_generic.
    revert l1.
    induction l2; intros.
    -   rewrite list_conc_rid.
        cbn.
        unfold f; cbn.
        change (list_size []) with (zero (U := nat)).
        unfold zero at 4; cbn.
        destruct (Logic.eq_sym (plus_rid (list_size l1))); cbn.
        rewrite cat_lid.
        change (module_homo_f (tensor_product_rid_homo _)) with
            (tensor_product_rid_f (tensor_power (list_size l1))).
        unfold tensor_mult'; rewrite (tensor_product_rid_eq (tensor_power _)).
        rewrite scalar_id.
        reflexivity.
    -   rewrite <- list_conc_single.
        rewrite plus_assoc.
        rewrite IHl2; clear IHl2.
        rewrite list_conc_single.
        unfold f at 2; cbn.
        change (list_size (a ꞉ l2)) with (nat_suc (list_size l2)).
        cbn.
        unfold cat_compose; cbn.
        change (module_homo_f (tensor_product_assoc_homo _ _ _)) with
            (tensor_product_assoc_f (tensor_power (list_size l1)) V
                (tensor_power (list_size l2))).
        unfold tensor_mult' at 2;
            rewrite (tensor_product_assoc_eq (tensor_power (list_size l1))).
        change (module_homo_f (tensor_product_liso_homo _ _ _ _)) with
            (tensor_product_liso_f (tensor_power (list_size l1) ⊗ V)
                (V ⊗ tensor_power (list_size l1)) (tensor_power (list_size l2))
                (tensor_power_mult1 (list_size l1))).
        rewrite tensor_product_liso_eq.
        change (module_homo_f (tensor_power_mult _ _)) with
            (@f (nat_suc (list_size l1)) (list_size l2)).
        change (tensor_mult (V ⊗ tensor_power (list_size l1))
            (tensor_power (list_size l2))) with
            (@tensor_mult' (nat_suc (list_size l1)) (list_size l2)).
        assert (∀ l, nat_suc (list_size l) = list_size (l + a ꞉ list_end)) as n_eq.
        {
            intros l.
            rewrite list_size_comm.
            reflexivity.
        }
        symmetry in n_eq.
        pose (X := tensor_power_mult1 (list_size l1)
            (tensor_mult (tensor_power (list_size l1)) V (vectors_to_power l1)
            a)).
        change (module_homo_f (tensor_power_mult1 (list_size l1))
            (tensor_mult (tensor_power (list_size l1)) V (vectors_to_power l1)
            a)) with X.
        assert (tensor_power_nat_eq (n_eq l1)
                (vectors_to_power (l1 + a ꞉ list_end)) = X) as eq.
        {
            unfold X; clear X.
            induction l1.
            -   apply tensor_power_eq_generic.
                cbn.
                change (list_size []) with (zero (U := nat)).
                unfold zero at 4; cbn.
                change (module_homo_f (tensor_product_comm_homo _ _)) with
                    (tensor_product_comm_f (cring_module F) V).
                rewrite tensor_product_comm_eq.
                reflexivity.
            -   cbn.
                change (list_size (a0 ꞉ l1)) with (nat_suc (list_size l1)).
                cbn.
                unfold cat_compose; cbn.
                fold (tensor_product_assoc_inv_f V (tensor_power (list_size l1)) V).
                rewrite tensor_product_assoc_inv_eq.
                fold (tensor_product_riso_f V (tensor_power (list_size l1) ⊗ V)
                    (V ⊗ tensor_power (list_size l1))
                    (tensor_power_mult1 (list_size l1))).
                rewrite tensor_product_riso_eq.
                pose (X := tensor_power_mult1 (list_size l1)
                    (tensor_mult (tensor_power (list_size l1)) V
                    (vectors_to_power l1) a)).
                fold X in IHl1.
                change (module_homo_f (tensor_power_mult1 (list_size l1))
                    (tensor_mult (tensor_power (list_size l1)) V
                    (vectors_to_power l1) a)) with X.
                rewrite <- IHl1; clear IHl1 X.
                apply (tensor_power_eq_generic _ _ (n_eq (a0 ꞉ l1))).
                change (V ⊗ tensor_power (list_size l1)) with
                    (tensor_power (nat_suc (list_size l1))).
                apply generic_tensor_mult_eq.
                1: reflexivity.
                rewrite generic_tensor_eq_generic.
                reflexivity.
        }
        rewrite <- eq; clear eq X.
        apply (@to_generic_tensor_f_eq
            (list_size (l1 + a ꞉ list_end))
            (nat_suc (list_size l1))
        ).
        2: reflexivity.
        rewrite generic_tensor_eq_generic.
        reflexivity.
Qed.

Definition simple_tensor_power n (A : module_V (tensor_power n)) :=
    ∃ α (l : set_type (λ l : list (module_V V), list_size l = n)),
    A = α · tensor_power_nat_eq [|l] (vectors_to_power [l|]).

Theorem tensor_power_sum : ∀ {n} (A : module_V (tensor_power n)),
    ∃ l : ulist (set_type (simple_tensor_power n)),
    A = ulist_sum (ulist_image (λ x, [x|]) l).
Proof.
    intros n A.
    nat_induction n.
    -   assert (simple_tensor_power 0 A) as A_in.
        {
            unfold simple_tensor_power.
            exists A.
            assert (@list_size (module_V V) list_end = 0) as eq by reflexivity.
            exists [list_end|eq].
            cbn.
            rewrite <- @module_homo_scalar.
            unfold scalar_mult; cbn.
            change (list_size []) with (zero (U := nat)).
            unfold zero at 6; cbn.
            pose (X1 := cring_mult_lid).
            pose (X2 := cring_mult_comm).
            rewrite mult_rid.
            symmetry; apply tensor_power_eq_generic.
            reflexivity.
        }
        exists ([A|A_in] ː ulist_end).
        rewrite ulist_image_add, ulist_sum_add.
        rewrite ulist_image_end, ulist_sum_end.
        rewrite plus_rid.
        reflexivity.
    -   cbn in A.
        pose proof (tensor_sum _ _ A) as [l l_eq]; subst A.
        induction l using ulist_induction.
        +   exists ulist_end.
            do 2 rewrite ulist_image_end.
            reflexivity.
        +   destruct IHl as [l' IHl].
            destruct a as [a' [a [A eq]]]; subst a'; cbn.
            specialize (IHn A) as [lA A_eq].
            assert (∀ B : set_type (simple_tensor_power n),
                simple_tensor_power (nat_suc n) (tensor_mult _ _ a [B|]))
                as a_in.
            {
                intros [B [α [Bl B_eq]]]; cbn.
                subst B.
                exists α.
                assert (list_size (a ꞉ [Bl|]) = nat_suc n) as Bl_eq.
                {
                    rewrite list_size_add.
                    rewrite [|Bl].
                    reflexivity.
                }
                exists [a ꞉ [Bl|]|Bl_eq].
                cbn.
                rewrite (tensor_rscalar V).
                apply f_equal.
                symmetry; apply (tensor_power_eq_generic _ _ Bl_eq).
                apply generic_tensor_mult_eq.
                1: reflexivity.
                rewrite generic_tensor_eq_generic.
                reflexivity.
            }
            pose (laA := ulist_image (λ x, [_|a_in x]) lA).
            exists (laA + l').
            rewrite ulist_image_conc.
            change (V ⊗ tensor_power n) with (tensor_power (nat_suc n)).
            rewrite ulist_sum_plus.
            rewrite <- IHl; clear IHl.
            rewrite ulist_image_add, ulist_sum_add; cbn.
            apply rplus.
            rewrite A_eq.
            unfold laA.
            rewrite ulist_image_comp; cbn.
            clear A A_eq laA a_in.
            induction lA using ulist_induction.
            *   do 2 rewrite ulist_image_end, ulist_sum_end.
                apply tensor_product_ranni.
            *   do 2 rewrite ulist_image_add, ulist_sum_add.
                rewrite (tensor_ldist V).
                apply lplus.
                exact IHlA.
Qed.

Lemma tensor_power_rscalar : ∀ n
    (A : module_V (tensor_power n)) (B : module_V (tensor_power 0)),
    tensor_power_nat_eq (plus_rid n) (f (A ⊗' B)) = B · A.
Proof.
    intros n A B.
    apply tensor_power_eq_generic.
    unfold f; cbn.
    unfold zero at 4; cbn.
    destruct (Logic.eq_sym (plus_rid n)); cbn.
    rewrite cat_lid.
    change (module_homo_f (tensor_product_rid_homo _)) with
        (tensor_product_rid_f (tensor_power n)).
    unfold tensor_mult'; rewrite (tensor_product_rid_eq (tensor_power n)).
    reflexivity.
Qed.

Lemma tensor_power_lscalar : ∀ n
    (A : module_V (tensor_power 0)) (B : module_V (tensor_power n)),
    f (A ⊗' B) = A · B.
Proof.
    intros n A B.
    pose proof (tensor_power_sum A) as [lA A_eq].
    pose proof (tensor_power_sum B) as [lB B_eq].
    subst A B.
    induction lB as [|B lB] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        rewrite tensor_ranni'.
        rewrite scalar_ranni.
        apply module_homo_zero.
    }
    rewrite ulist_image_add, ulist_sum_add.
    rewrite tensor_ldist'.
    rewrite f_plus.
    rewrite scalar_ldist.
    rewrite IHlB; clear IHlB.
    apply rplus; clear lB.
    induction lA as [|A lA] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        rewrite tensor_lanni'.
        rewrite scalar_lanni.
        apply module_homo_zero.
    }
    rewrite ulist_image_add, ulist_sum_add.
    rewrite tensor_rdist'.
    rewrite f_plus.
    rewrite scalar_rdist.
    rewrite IHlA; clear IHlA.
    apply rplus; clear lA.
    destruct A as [A' [α [lA A_eq]]]; subst A'; cbn.
    destruct B as [B' [β [lB B_eq]]]; subst B'; cbn.
    rewrite tensor_lscalar', tensor_rscalar'.
    do 2 rewrite f_scalar.
    pose (UM := cring_mult).
    pose (UMC := cring_mult_comm).
    unfold scalar_mult at 4; cbn.
    unfold zero at 15; cbn.
    rewrite <- scalar_comp.
    apply f_equal.
    rewrite (scalar_comp _ β).
    rewrite (mult_comm _ β).
    rewrite <- scalar_comp.
    apply f_equal.
    apply tensor_power_eq.
    pose proof (generic_tensor_eq_generic _ _ [|lA] (vectors_to_power [lA|])) as eq1.
    pose proof (generic_tensor_eq_generic _ _ [|lB] (vectors_to_power [lB|])) as eq2.
    rewrite (to_generic_tensor_f_eq eq1 eq2); clear eq1 eq2.
    rewrite vectors_to_power_mult.
    rewrite generic_tensor_eq_generic.
    destruct lA as [lA lA_size]; cbn.
    destruct lA.
    2: inversion lA_size.
    cbn.
    cbn in lA_size.
    assert (tensor_power_nat_eq lA_size (@one _ (cring_one F))
        = (@one _ (cring_one F))) as eq.
    {
        apply tensor_power_eq_generic.
        reflexivity.
    }
    rewrite eq; clear eq.
    rewrite scalar_id.
    rewrite generic_tensor_eq_generic.
    reflexivity.
Qed.

Theorem tensor_power_mult_assoc : ∀ a b c A B C,
    tensor_power_nat_eq (plus_assoc _ _ _)
    (tensor_power_mult a (b + c)
        (tensor_mult (tensor_power a) (tensor_power (b + c))
            A
            (tensor_power_mult b c
                (tensor_mult (tensor_power b) (tensor_power c) B C))))
    =
    tensor_power_mult (a + b) c
        (tensor_mult (tensor_power (a + b)) (tensor_power c)
            (tensor_power_mult a b
                (tensor_mult (tensor_power a) (tensor_power b) A B))
            C).
Proof.
    intros a b c A B C.
    apply tensor_power_eq_generic.
    cbn.
    change (tensor_mult (tensor_power a) (tensor_power b) A B)
        with (tensor_mult' A B).
    change (tensor_mult (tensor_power b) (tensor_power c) B C)
        with (tensor_mult' B C).
    change (module_homo_f (tensor_power_mult a b) (A ⊗' B)) with (f (A ⊗' B)).
    change (module_homo_f (tensor_power_mult b c) (B ⊗' C)) with (f (B ⊗' C)).
    change (tensor_mult (tensor_power a) (tensor_power (b + c)) A (f (B ⊗' C)))
        with (tensor_mult' A (f (B ⊗' C))).
    change (tensor_mult (tensor_power (a + b)) (tensor_power c) (f (A ⊗' B)) C)
        with (tensor_mult' (f (A ⊗' B)) C).
    change (module_homo_f (tensor_power_mult a (b + c)) (A ⊗' (f (B ⊗' C))))
        with (f (A ⊗' (f (B ⊗' C)))).
    change (module_homo_f (tensor_power_mult (a + b) c) (f (A ⊗' B) ⊗' C))
        with (f (f (A ⊗' B) ⊗' C)).
    pose proof (tensor_power_sum A) as [lA A_eq]; subst A.
    induction lA as [|A lA] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        do 2 rewrite tensor_lanni'.
        do 2 rewrite f_zero.
        rewrite tensor_lanni'.
        rewrite f_zero.
        rewrite plus_assoc.
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add.
    do 2 rewrite tensor_rdist'.
    do 2 rewrite f_plus.
    rewrite tensor_rdist'.
    rewrite f_plus.
    apply (to_generic_tensor_plus IHlA); clear IHlA lA.
    pose proof (tensor_power_sum B) as [lB B_eq]; subst B.
    induction lB as [|B lB] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        rewrite tensor_lanni'.
        rewrite tensor_ranni'.
        do 2 rewrite f_zero.
        rewrite tensor_lanni'.
        rewrite tensor_ranni'.
        do 2 rewrite f_zero.
        rewrite plus_assoc.
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add.
    rewrite tensor_ldist'.
    rewrite tensor_rdist'.
    do 2 rewrite f_plus.
    rewrite tensor_rdist'.
    rewrite f_plus.
    rewrite tensor_ldist'.
    rewrite f_plus.
    apply (to_generic_tensor_plus IHlB); clear IHlB lB.
    pose proof (tensor_power_sum C) as [lC C_eq]; subst C.
    induction lC as [|C lC] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        do 2 rewrite tensor_ranni'.
        do 2 rewrite f_zero.
        rewrite tensor_ranni'.
        rewrite f_zero.
        rewrite plus_assoc.
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add.
    do 2 rewrite tensor_ldist'.
    do 2 rewrite f_plus.
    rewrite tensor_ldist'.
    rewrite f_plus.
    apply (to_generic_tensor_plus IHlC); clear IHlC lC.
    destruct A as [A' [α [lA A_eq]]]; cbn.
    remember (vectors_to_power [lA|]) as A.
    destruct B as [B' [β [lB B_eq]]]; cbn.
    remember (vectors_to_power [lB|]) as B.
    destruct C as [C' [γ [lC C_eq]]]; cbn.
    remember (vectors_to_power [lC|]) as C.
    subst A' B' C'.
    do 2 rewrite tensor_lscalar'.
    rewrite tensor_rscalar'.
    do 3 rewrite f_scalar.
    do 2 rewrite tensor_rscalar'.
    do 2 rewrite f_scalar.
    rewrite tensor_lscalar'.
    rewrite (tensor_rscalar' β).
    do 2 rewrite f_scalar.
    do 2 rewrite tensor_lscalar'.
    rewrite tensor_rscalar'.
    do 3 rewrite f_scalar.
    do 3 apply generic_tensor_scalar_eq.
    pose proof (generic_tensor_eq_generic _ _ [|lA] A) as eq1.
    pose proof (generic_tensor_eq_generic _ _ [|lB] B) as eq2.
    pose proof (generic_tensor_eq_generic _ _ [|lC] C) as eq3.
    pose proof (to_generic_tensor_f_eq eq1 eq2) as eq12.
    pose proof (to_generic_tensor_f_eq eq2 eq3) as eq23.
    rewrite (to_generic_tensor_f_eq eq1 eq23).
    rewrite (to_generic_tensor_f_eq eq12 eq3).
    clear eq1 eq2 eq3 eq12 eq23.
    subst A B C.
    rewrite vectors_to_power_mult.
    pose proof (generic_tensor_eq_generic _ _ (list_size_conc [lB|] [lC|])
        (vectors_to_power ([lB|] + [lC|]))) as eq.
    rewrite (to_generic_tensor_f_eq (Logic.eq_refl _) eq); clear eq.
    rewrite vectors_to_power_mult.
    rewrite generic_tensor_eq_generic.
    rewrite vectors_to_power_mult.
    pose proof (generic_tensor_eq_generic _ _ (list_size_conc [lA|] [lB|])
        (vectors_to_power ([lA|] + [lB|]))) as eq.
    rewrite (to_generic_tensor_f_eq eq (Logic.eq_refl _)); clear eq.
    rewrite vectors_to_power_mult.
    rewrite generic_tensor_eq_generic.
    rewrite plus_assoc.
    reflexivity.
Qed.
(* begin hide *)

End TensorPower.
(* end hide *)


Require Import util.
Require Import c_util.
Require Export flow.
Set Implicit Arguments.
Open Local Scope CR_scope.

Section single_inverses.

  Variable f: Flow CRasCSetoid.

  Variable fmono: mono f.

  Lemma purify_mono: forall x, monotonic (f x).
  Proof.
    intros.
    unfold monotonic.
    destruct fmono; set (s x); [left | right]; assumption.
  Qed.

  Definition mle (x x': CR): Prop := if fmono then x <= x' else x' <= x.
  Definition mlt (x x': CR): CProp := if fmono then x < x' else x' < x.

  Lemma mle_refl x: mle x x.
  Proof. unfold mle. destruct fmono; intros; apply CRle_refl. Qed.

  Lemma mle_trans x y z: mle x y -> mle y z -> mle x z.
  Proof.
    unfold mle.
    destruct fmono; intros; apply CRle_trans with y; assumption.
  Qed.

  Lemma mlt_le x x': mlt x x' -> mle x x'.
  Proof.
    unfold mlt, mle. destruct fmono; intros; apply CRlt_le; assumption.
  Qed.

  Lemma mono_le_opp v t t': t' < t -> mlt (f v t') (f v t).
  Proof.
    unfold mlt.
    destruct fmono;intros; apply s; assumption.
  Qed.

  Lemma mono_opp v t t': t' <= t -> mle (f v t') (f v t).
  Proof with auto.
    unfold mle.
    destruct fmono; intros.
      apply mildly_increasing...
      intros. rewrite H0. reflexivity.
    apply mildly_decreasing...
    intros. rewrite H0. reflexivity.
  Qed.

  Variables
    (inv: CR -> CR -> Time)
    (inv_correct: forall x x', f x (inv x x') == x').

  Definition f_eq x t t': f x t == f x t' <-> t == t'.
  Proof.
    intros.
    apply mono_eq.
      intros.
      rewrite H.
      reflexivity.
    apply purify_mono.
  Qed.

  Lemma inv_correct' x t: inv x (f x t) == t.
  Proof.
    intros.
    destruct (f_eq x (inv x (f x t)) t).
    clear H0. apply H.
    rewrite inv_correct. reflexivity.
  Qed.

  Add Morphism inv with signature (@cs_eq _) ==> (@cs_eq _) ==> (@cs_eq _)
    as inv_wd.
  Proof with auto.
    intros.
    destruct (f_eq x (inv x x0) (inv y y0)).
    apply H1.
    rewrite inv_correct.
    rewrite H.
    rewrite inv_correct...
  Qed.

  Lemma inv_plus x y z: inv x z == inv x y + inv y z.
  Proof with auto.
    intros. destruct (f_eq x (inv x z) (inv x y + inv y z)).
    clear H0. apply H.
    rewrite flow_additive...
    repeat rewrite inv_correct.
    reflexivity.
  Qed.

  Lemma inv_refl x: inv x x == 0.
  Proof with auto.
    intros. destruct (f_eq x (inv x x) 0).
    clear H0. apply H.
    repeat rewrite inv_correct...
    rewrite flow_zero...
  Qed.

  Lemma f_le x t t': mle (f x t) (f x t') -> t <= t'.
  Proof with auto.
    unfold mle. intros. destruct fmono.
      apply strongly_increasing_inv_mild with (f x)...
    apply strongly_decreasing_inv_mild with (f x)...
  Qed.

  Lemma inv_le_right a x x': inv a x <= inv a x' <-> mle x x'.
  Proof with auto.
    unfold mle.
    split.
      intros.
      destruct fmono.
        rewrite <- (inv_correct a x).
        rewrite <- (inv_correct a x').
        apply mildly_increasing...
        intros. rewrite H0...
      rewrite <- (inv_correct a x).
      rewrite <- (inv_correct a x').
      apply mildly_decreasing...
      intros. rewrite H0...
    set f_le. unfold mle in c. clearbody c.
    intros.
    apply c with a.
    destruct fmono; repeat rewrite inv_correct...
  Qed.

  Lemma inv_very_correct t x: inv (f x t) x == -t.
  Proof with auto with real.
    intros.
    assert (inv x x == 0).
      apply inv_refl.
    rewrite (inv_plus x (f x t) x) in H.
    rewrite inv_correct' in H.
    rewrite <- (Radd_0_l CR_ring_theory (-t)).
    rewrite <- H.
    rewrite (Radd_comm CR_ring_theory).
    rewrite (Radd_assoc CR_ring_theory).
    rewrite (Radd_comm CR_ring_theory (-t)).
    rewrite (Ropp_def CR_ring_theory).
    rewrite (Radd_0_l CR_ring_theory)...
  Qed.

  Lemma inv_inv x y: inv x y == - inv y x.
  Proof with auto.
    intros.
    set (inv_very_correct (inv y x) y).
    clearbody s. rewrite <- s.
    rewrite inv_correct...
  Qed.

  Lemma inv_uniq_0 x x': inv x x' == - inv 0 x + inv 0 x'.
  Proof with auto.
    intros.
    rewrite (inv_plus x 0 x').
    rewrite (inv_inv x 0)...
  Qed.
    (* hm, this shows that inv is uniquely determined by the values it
      takes with 0 as first argument. perhaps the reason we don't
      just take inv as a unary function is that it is problematic
      for flow functions with singularities at 0? *)

  Lemma inv_le a x x': mle x x' -> inv a x <= inv a x'.
  Proof with auto.
    intros.
    set f_le. clearbody c.
    apply c with a.
    unfold mle in *.
    destruct fmono; do 2 rewrite inv_correct...
  Qed.

  Lemma inv_nonneg x x': 0 <= inv x x' <-> mle x x'.
  Proof with auto.
    unfold mle.
    split; intros.
      destruct fmono.
        rewrite <- (flow_zero f x).
        rewrite <- (inv_correct x x').
        apply mildly_increasing...
        intros. rewrite H0...
      rewrite <- (flow_zero f x).
      rewrite <- (inv_correct x x').
      apply mildly_decreasing...
      intros. rewrite H0...
    rewrite <- (inv_refl x).
    apply inv_le...
  Qed.

  Lemma inv_zero x x': inv x x' == 0 <-> x == x'.
  Proof with auto.
    split; intros.
      rewrite <- (inv_correct x x').
      rewrite H, flow_zero...
    rewrite H.
    apply inv_refl.
  Qed.

  Lemma f_le_left x x' t: x <= x' -> f x t <= f x' t.
  Proof with auto with real.
    intros.
    set (inv_nonneg x x').
    set (inv_nonneg x' x).
    clearbody i i0.
    unfold mle in *.
    destruct fmono; clear fmono; destruct f.
      simpl strongly_increasing in s.
      clear f. rename flow_morphism into f.
      rewrite <- (inv_correct x x').
      rewrite <- flow_additive.
      apply mildly_increasing...
        intros. rewrite H0...
      rewrite <- (Radd_0_l CR_ring_theory t) at 1.
      apply t9.
        apply i...
      apply CRle_refl.
    simpl strongly_decreasing in s.
    clear f. rename flow_morphism into f.
    rewrite <- (inv_correct x x').
    simpl.
    rewrite <- flow_additive.
    apply mildly_decreasing...
      intros. rewrite H0...
    rewrite <- (Radd_0_l CR_ring_theory t) at 2.
    apply t9.
      rewrite inv_inv.
      assert (0 == -0).
        rewrite CRopp_Qopp.
        apply inject_Q_CR_wd.
        reflexivity.
      rewrite H0.
      apply t8.
      apply i0...
    apply CRle_refl.
  Qed.

  Lemma inv_le_left a x x': mle x x' -> inv x' a <= inv x a.
  Proof with auto.
    intros.
    rewrite (inv_inv x'). rewrite (inv_inv x).
    apply t8. apply inv_le...
  Qed.

  Lemma mle_flow t x: 0 <= t -> mle x (f x t).
  Proof with auto.
    intros.
    apply mle_trans with (f x 0).
      unfold mle.
      destruct fmono; rewrite flow_zero; apply CRle_refl.
    apply mono_opp...
  Qed.

End single_inverses.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Construction.Coproduct.

Generalizable All Variables.

Section Coproduct.

Context {C : Category}.
Context `{@Cocartesian C}.

Definition sum_obj : C ∐ C → C :=
  sum_rect (const C) Datatypes.id Datatypes.id.

Section sum_map.

#[local] Set Transparent Obligations.

Program Definition sum_map (a : C ∐ C) (b : C ∐ C) (f : a ~> b) :
  sum_obj a ~> sum_obj b :=
  match a, b with
  | Datatypes.inl x, Datatypes.inl y => _
  | Datatypes.inl _, Datatypes.inr _ => !
  | Datatypes.inr x, Datatypes.inl _ => !
  | Datatypes.inr x, Datatypes.inr y => _
  end.

End sum_map.

#[export]
Program Instance CoproductFunctor : C ∐ C ⟶ C := {
  fobj := sum_obj;
  fmap := sum_map;
}.
Next Obligation.
  proper; destruct x, y; simpl; tauto.
Qed.
Next Obligation.
  destruct x; simpl; reflexivity.
Qed.
Next Obligation.
  destruct x, y, z; simpl; cat; tauto.
Qed.

End Coproduct.