(** * F2: Strumienie [TODO] *)

Set Primitive Projections.
(* Set Warnings "+cannot-define-projection".
(* Set Warnings "+non-primitive-record". *) *)

(** W tym rozdziale będą ćwiczenia dotyczące strumieni, czyli ogólnie
    wesołe koinduktywne zabawy, o których jeszcze nic nie napisałem. *)

CoInductive Stream (A : Type) : Type := Cons
{
  hd : A;
  tl : Stream A;
}.

Arguments hd {A}.
Arguments tl {A}.

(** * Bipodobieństwo *)

CoInductive sim {A : Type} (s1 s2 : Stream A) : Prop :=
{
  hds : hd s1 = hd s2;
  tls : sim (tl s1) (tl s2);
}.

Lemma sim_refl :
  forall (A : Type) (s : Stream A),
    sim s s.
(* begin hide *)
Proof.
  cofix CH.
  now constructor.
Qed.
(* end hide *)

Lemma sim_sym :
  forall (A : Type) (s1 s2 : Stream A),
    sim s1 s2 -> sim s2 s1.
(* begin hide *)
Proof.
  cofix CH.
  intros A s1 s2 [hds tls].
  constructor; [easy |].
  now apply CH.
Qed.
(* end hide *)

Lemma sim_trans :
  forall (A : Type) (s1 s2 s3 : Stream A),
    sim s1 s2 -> sim s2 s3 -> sim s1 s3.
(* begin hide *)
Proof.
  cofix CH.
  intros A s1 s2 s3 [hds1 tls1] [hds2 tls2].
  constructor; [congruence |].
  now apply CH with (tl s2).
Qed.
(* end hide *)

Require Import Setoid.

#[export]
Instance Equiv_sim (A : Type) : Equivalence (@sim A).
(* begin hide *)
Proof.
  split; red.
  - now apply sim_refl.
  - now apply sim_sym.
  - now apply sim_trans.
Defined.
(* end hide *)

(** * [sapp] *)

(** Zdefiniuj funkcję [sapp], która skleja dwa strumienie. Czy taka
    funkcja w ogóle ma sens?*)

CoFixpoint sapp {A : Type} (s1 s2 : Stream A) : Stream A :=
{|
  hd := hd s1;
  tl := sapp (tl s1) s2;
|}.

(* begin hide *)
Ltac coind := cofix CH; constructor; cbn; auto.
(* end hide *)

Lemma sapp_pointless :
  forall (A : Type) (s1 s2 : Stream A),
    sim (sapp s1 s2) s1.
(* begin hide *)
Proof.
  cofix CH.
  now constructor; cbn.
Qed.
(* end hide *)

(** * [lsapp] *)

(** Zdefiniuj funkcję [lsapp], która dokleja listę na początek
    strumienia. *)

(* begin hide *)
Fixpoint lsapp {A : Type} (l : list A) (s : Stream A) : Stream A :=
match l with
| nil => s
| cons h t => {| hd := h; tl := lsapp t s; |}
end.
(* end hide *)

(** * [map] *)

(** Zdefiniuj funkcję [map], która aplikuje funkcję [f : A -> B] do
    każdego elementu strumienia. *)

(* begin hide *)
CoFixpoint map {A B : Type} (f : A -> B) (s : Stream A) : Stream B :=
{|
  hd := f (hd s);
  tl := map f (tl s);
|}.
(* end hide *)

Lemma map_id :
  forall (A : Type) (s : Stream A),
    sim (map (@id A) s) s.
(* begin hide *)
Proof.
  cofix CH.
  constructor; cbn; [easy |].
  now apply CH.
Qed.
(* end hide *)

Lemma map_map :
  forall (A B C : Type) (f : A -> B) (g : B -> C) (s : Stream A),
    sim (map g (map f s)) (map (fun x => g (f x)) s).
(* begin hide *)
Proof.
  cofix CH.
  constructor; cbn; [easy |].
  now apply CH.
Qed.
(* end hide *)

(** * [zipWith] i [unzip] (TODO) *)

(** Zdefiniuj funkcję [zipWith], która ze dwóch strumieni elementów
    [A] oraz [B] robi strumień elementów [C], mając do dyspozycji
    funkcję [f : A -> B -> C ].

    Następnie zdefiniuj funkcję [unzip], która ze strumienia par
    robi parę strumieni wiadomo w jaki sposób.

    Czy [zipWithh pair] i [unzip] są swoimi odwrotnościami? *)

(* begin hide *)
CoFixpoint zipWith
  {A B C : Type} (f : A -> B -> C)
  (s1 : Stream A) (s2 : Stream B) : Stream C :=
{|
  hd := f (hd s1) (hd s2);
  tl := zipWith f (tl s1) (tl s2);
|}.

Definition unzip
  {A B : Type} (s : Stream (A * B)) : Stream A * Stream B :=
    (map fst s, map snd s).

Lemma unzip_zipWith :
  forall {A B : Type} (s : Stream (A * B)),
    sim (zipWith pair (fst (unzip s)) (snd (unzip s))) s.
Proof.
  cofix CH.
  constructor; cbn.
  - now rewrite surjective_pairing.
  - now apply CH.
Qed.

Lemma zipWith_unzip :
  forall {A B : Type} (sa : Stream A) (sb : Stream B),
    let s' := unzip (zipWith pair sa sb) in
      sim (fst s') sa /\ sim (snd s') sb.
Proof.
  split; cbn.
  - revert sa sb.
    cofix CH.
    constructor; cbn; [easy |].
    now apply CH.
  - revert sa sb.
    cofix CH.
    constructor; cbn; [easy |].
    now apply CH.
Qed.

(** TODO: [unzis], cokolwiek to jest *)

(* end hide *)

(** * Inne funkcje (TODO) *)

(** Zdefiniuj resztę przydatnych funkcji podobnych do tych, które są
    dostępne dla list: [repeat], [iterate], [nth], [take], [drop],
    [splitAt], [insert], [replace], [scanl], [scanr], [intersperse],
    [merge].

    Zdefiniuj też funkcje, których zapomniałem (albo nie chciało mi
    się) wymienić. *)

(* begin hide *)
CoFixpoint repeat {A : Type} (x : A) : Stream A :=
{|
  hd := x;
  tl := repeat x;
|}.

CoFixpoint iterate {A : Type} (f : A -> A) (x : A) : Stream A :=
{|
  hd := x;
  tl := iterate f (f x);
|}.

Fixpoint nth (n : nat) {A : Type} (s : Stream A) : A :=
match n with
| 0 => hd s
| S n' => nth n' (tl s)
end.

Fixpoint take (n : nat) {A : Type} (s : Stream A) : list A :=
match n with
| 0 => nil
| S n' => cons (hd s) (take n' (tl s))
end.

Fixpoint drop (n : nat) {A : Type} (s : Stream A) : Stream A :=
match n with
| 0 => s
| S n' => drop n' (tl s)
end.

Fixpoint splitAt
  (n : nat) {A : Type} (s : Stream A) : list A * A * Stream A :=
match n with
| 0 => (nil, hd s, tl s)
| S n' => let '(l, x, s') := splitAt n' (tl s) in (cons (hd s) l, x, s')
end.

CoFixpoint from (n : nat) : Stream nat :=
{|
  hd := n;
  tl := from (S n);
|}.

Fixpoint insert (n : nat) {A : Type} (x : A) (s : Stream A) : Stream A :=
match n with
| 0 => {| hd := x; tl := s; |}
| S n' => {| hd := hd s; tl := insert n' x (tl s); |}
end.

Fixpoint replace (n : nat) {A : Type} (x : A) (s : Stream A) : Stream A :=
match n with
| 0 => {| hd := x; tl := tl s; |}
| S n' => {| hd := hd s; tl := replace n' x (tl s); |}
end.

CoFixpoint diagonal {A : Type} (s : Stream (Stream A)) : Stream A :=
{|
  hd := hd (hd s);
  tl := diagonal (tl (map tl s));
|}.

CoFixpoint scanl
  {A B : Type} (f : A -> B -> A) (x : A) (s : Stream B) : Stream A :=
{|
  hd := f x (hd s);
  tl := scanl f (f x (hd s)) (tl s);
|}.

CoFixpoint scanr
  {A B : Type} (f : A -> B -> B) (x : B) (s : Stream A) : Stream B :=
{|
  hd := f (hd s) x;
  tl := scanr f (f (hd s) x) (tl s);
|}.

CoFixpoint intersperse {A : Type} (x : A) (s : Stream A) : Stream A :=
{|
  hd := hd s;
  tl :=
  {|
    hd := x;
    tl := intersperse x (tl s);
  |};
|}.

CoFixpoint merge {A : Type} (s1 s2 : Stream A) : Stream A :=
{|
  hd := hd s1;
  tl :=
  {|
    hd := hd s2;
    tl := merge (tl s1) (tl s2);
  |};
|}.
(* end hide *)

Lemma merge_repeat :
  forall (A : Type) (x : A) (s : Stream A),
    sim (merge s (repeat x)) (intersperse x s).
(* begin hide *)
Proof.
  cofix CH.
  constructor; cbn; [easy |].
  constructor; cbn; [easy |].
  now apply CH.
Qed.
(* end hide *)

(* TODO: uporządkować *)

Lemma sim_map :
  forall {A B : Type} (f : A -> B) (s1 s2 : Stream A),
    sim s1 s2 -> sim (map f s1) (map f s2).
(* begin hide *)
Proof.
  cofix CH.
  intros * [hds tls].
  constructor; cbn; [now congruence |].
  now apply CH.
Qed.
(* end hide *)

Lemma sim_diagonal :
  forall {A : Type} (s1 s2 : Stream (Stream A)),
    sim s1 s2 -> sim (diagonal s1) (diagonal s2).
(* begin hide *)
Proof.
  cofix CH.
  intros * [hds tls].
  constructor; cbn; [now congruence |].
  now apply CH, sim_map.
Qed.
(* end hide *)

Compute take 10 (diagonal (map from (from 0))).
Compute take 10 (iterate (fun n => S (S n)) 0).

(* TODO *) Lemma diagonal_from :
  forall n : nat,
    sim
      (diagonal (map from (from n)))
      (iterate (fun n => S (S n)) n).
(* begin hide *)
Proof.
  cofix CH.
  constructor; cbn; [easy |].
Abort.
(* end hide *)

Lemma nth_insert :
  forall {A : Type} (n : nat) (x : A) (s : Stream A),
    nth n (insert n x s) = x.
(* begin hide *)
Proof.
  induction n as [| n']; cbn; intros; [easy |].
  now apply IHn'.
Qed.
(* end hide *)

Lemma nth_replace :
  forall {A : Type} (n : nat) (x : A) (s : Stream A),
    nth n (replace n x s) = x.
(* begin hide *)
Proof.
  induction n as [| n']; cbn; intros; [easy |].
  now apply IHn'.
Qed.
(* end hide *)

Lemma drop_map :
  forall {A B : Type} (f : A -> B) (n : nat) (s : Stream A),
    drop n (map f s) = map f (drop n s).
(* begin hide *)
Proof.
  induction n as [| n']; cbn; intros; [easy |].
  now apply IHn'.
Qed.
(* end hide *)

Lemma hd_drop :
  forall (A : Type) (n : nat) (s : Stream A),
    hd (drop n s) = nth n s.
(* begin hide *)
Proof.
  induction n as [| n']; cbn; intros; [easy |].
  now apply IHn'.
Qed.
(* end hide *)

Lemma tl_drop :
  forall (A : Type) (n : nat) (s : Stream A),
    tl (drop n s) = drop n (tl s).
(* begin hide *)
Proof.
  induction n as [| n']; cbn; intros; [easy |].
  now apply IHn'.
Qed.
(* end hide *)

Lemma nth_drop :
  forall (A : Type) (n m : nat) (s : Stream A),
    nth n (drop m s) = nth (n + m) s.
(* begin hide *)
Proof.
  induction n as [| n']; cbn; intros.
  - now apply hd_drop.
  - now rewrite tl_drop, IHn'.
Qed.
(* end hide *)

Lemma drop_drop :
  forall (A : Type) (n m : nat) (s : Stream A),
    drop m (drop n s) = drop (n + m) s.
(* begin hide *)
Proof.
  induction n as [| n']; cbn; intros; [easy |].
  now apply IHn'.
Qed.
(* end hide *)

(* TODO: take_map dla strumieni *)
(*
Lemma take_map :
  forall {A B : Type} (f : A -> B) (n : nat) (s : Stream A),
    take n (map f s) = D5.map f (take n s).
Proof.
  induction n as [| n']; cbn; intros.
    reflexivity.
    rewrite IHn'. reflexivity.
Qed.
*)

(** * Predykaty i relacje na strumieniach (TODO) *)

(** Zdefiniuj różne użyteczne predykaty i relacje podobne do tych
    listowych, w tym [Elem], [Dup], [NoDup], [Exists], [Forall] i
    wszystkie inne, o których zapomniałem. *)

(* begin hide *)
Inductive Elem {A : Type} (x : A) (s : Stream A) : Prop :=
| Elem_hd : x = hd s -> Elem x s
| Elem_tl : Elem x (tl s) -> Elem x s.
(* end hide *)

#[global] Hint Constructors Elem : core.

(* begin hide *)
Inductive Dup {A : Type} (s : Stream A) : Prop :=
| Dup_hd : Elem (hd s) (tl s) -> Dup s
| Dup_tl : Dup (tl s) -> Dup s.
(* end hide *)

Ltac inv H := inversion H; subst; clear H.

Require Import Arith.

Lemma Elem_nth :
  forall (A : Type) (x : A) (s : Stream A),
    Elem x s <-> exists n : nat, nth n s = x.
(* begin hide *)
Proof.
  split.
  - induction 1; subst.
    + now exists 0; cbn.
    + destruct IHElem as [n p].
      now exists (S n); cbn.
  - intros [n <-]; revert s.
    induction n as [| n']; cbn; intros.
    + now left.
    + now right; apply IHn'.
Qed.
(* end hide *)

Lemma nth_from :
  forall n m : nat,
    nth n (from m) = n + m.
(* begin hide *)
Proof.
  induction n as [| n']; cbn; intros; [easy |].
  now rewrite IHn', <- plus_n_Sm.
Qed.
(* end hide *)

Lemma Elem_from_add :
  forall n m : nat,
    Elem n (from m) ->
      forall k : nat, Elem (k + n) (from m).
(* begin hide *)
Proof.
  intros.
  rewrite Elem_nth in *.
  destruct H as [l H].
  exists (k + l).
  rewrite nth_from in *.
  now rewrite <- Nat.add_assoc, H.
Qed.
(* end hide *)

Require Import Lia.

Lemma Elem_from :
  forall n m : nat,
    Elem n (from m) <-> m <= n.
(* begin hide *)
Proof.
  intros.
  rewrite Elem_nth.
  split.
  - intros [k <-].
    rewrite nth_from.
    now apply Nat.le_add_l.
  - intros H.
    exists (n - m).
    rewrite nth_from.
    now apply Nat.sub_add.
Qed.
(* end hide *)

Lemma Dup_spec :
  forall (A : Type) (s : Stream A),
    Dup s <-> exists n m : nat, n <> m /\ nth n s = nth m s.
(* begin hide *)
Proof.
  split.
  - induction 1.
    + apply Elem_nth in H as [n H].
      now exists 0, (S n); cbn.
    + destruct IHDup as (n & m & IH1 & IH2).
      exists (S n), (S m); cbn.
      now split; [congruence |].
  - intros (n & m & H1 & H2).
    revert s m H1 H2.
    induction n as [| n']; cbn; intros.
    + left; rewrite Elem_nth.
      exists (m - 1).
      rewrite H2.
      destruct m as [| m']; cbn; [contradiction |].
      now rewrite Nat.sub_0_r.
    + destruct m as [| m'].
      * left; rewrite Elem_nth.
        exists n'.
        now rewrite H2; cbn.
      * right.
        now apply (IHn' _ m'); [congruence |].
Qed.
(* end hide *)

Lemma NoDup_from :
  forall n : nat,
    ~ Dup (from n).
(* begin hide *)
Proof.
  intros n H.
  apply Dup_spec in H as (m1 & m2 & H1 & H2).
  rewrite 2!nth_from, Nat.add_cancel_r in H2.
  contradiction.
Qed.
(* end hide *)

(* begin hide *)
Inductive Exists {A : Type} (P : A -> Prop) (s : Stream A) : Prop :=
| Exists_hd : P (hd s) -> Exists P s
| Exists_tl : Exists P (tl s) -> Exists P s.
(* end hide *)

Lemma Exists_spec :
  forall (A : Type) (P : A -> Prop) (s : Stream A),
    Exists P s <-> exists n : nat, P (nth n s).
(* begin hide *)
Proof.
  split.
  - induction 1 as [| s H [n IH]].
    + now exists 0; cbn.
    + now exists (S n).
  - intros [n H]; revert s H.
    induction n as [| n']; cbn; intros.
    + now left.
    + now right; apply IHn'.
Qed.
(* end hide *)

(* begin hide *)
CoInductive Forall {A : Type} (s : Stream A) (P : A -> Prop) : Prop :=
{
  Forall_hd : P (hd s);
  Forall_tl : Forall (tl s) P;
}.
(* end hide *)

Lemma Forall_spec :
  forall (A : Type) (s : Stream A) (P : A -> Prop),
    Forall s P <-> forall n : nat, P (nth n s).
(* begin hide *)
Proof.
  split; intros; revert s H.
  - induction n as [| n']; cbn; intros.
    + now apply Forall_hd.
    + now apply IHn', Forall_tl.
  - cofix CH.
    constructor.
    + now apply (H 0).
    + apply CH; intros n.
      now apply (H (S n)).
Qed.
(* end hide *)

Lemma Forall_spec' :
  forall (A : Type) (s : Stream A) (P : A -> Prop),
    Forall s P <-> forall x : A, Elem x s -> P x.
(* begin hide *)
Proof.
  intros A s P.
  setoid_rewrite Elem_nth.
  split.
  - intros HF x [n <-].
    now apply Forall_spec.
  - intros H.
    apply Forall_spec; intros n.
    apply H.
    now exists n.
Qed.
(* end hide *)

Lemma Forall_Exists :
  forall (A : Type) (P : A -> Prop) (s : Stream A),
    Forall s P -> Exists P s.
(* begin hide *)
Proof.
  constructor.
  now apply Forall_hd.
Qed.
(* end hide *)

(*
(* begin hide *)
(* #[projections(primitive = no)] *)
Variant SubstreamF {A : Type} (F : Stream A -> Stream A -> Prop) (s1 s2 : Stream A) : Prop :=
| MkSubstreamF :
    forall n : nat, hd s1 = nth n s2 -> F (tl s1) (drop (S n) s2) -> SubstreamF F s1 s2.
(*
{
  pos : nat;
  nth_pos_hd : hd s1 = nth pos s2;
  SubstreamT' : F (tl s1) (drop (S pos) s2);
}.
*)

CoInductive Substream {A : Type} (s1 s2 : Stream A) : Prop :=
{
  Substream_out : SubstreamT Substream s1 s2;
}.

CoInductive SubstreamT {A : Type} (s1 s2 : Stream A) : Type :=
{
  pos : nat;
  nth_pos_hd : hd s1 = nth pos s2;
  SubstreamT' : SubstreamT (tl s1) (drop (S pos) s2);
}.

Definition Substream {A : Type} (s1 s2 : Stream A) : Prop :=
  inhabited (SubstreamT s1 s2).
(* end hide *)

Lemma drop_tl :
  forall (A : Type) (n : nat) (s : Stream A),
    drop n (tl s) = drop (S n) s.
(* begin hide *)
Proof.
  reflexivity.
Qed.
(* end hide *)

Lemma Substream_tl :
  forall (A : Type) (s1 s2 : Stream A),
    Substream s1 s2 -> Substream (tl s1) (tl s2).
(* begin hide *)
Proof.
  intros A s1 s2 [[n p [m q H]]].
  rewrite nth_drop, <- plus_n_Sm in q.
  constructor; econstructor; [now apply q |].
  now rewrite drop_drop, <- plus_n_Sm, plus_Sn_m, Nat.add_comm in H.
Qed.
(* end hide *)

Lemma Substream_tl_l :
  forall (A : Type) (s1 s2 : Stream A),
    Substream s1 s2 -> Substream (tl s1) s2.
(* begin hide *)
Proof.
  intros A s1 s2 [[n p [m q H]]].
  constructor; econstructor.
  - now rewrite q, nth_drop.
  - now rewrite drop_drop, Nat.add_comm, plus_Sn_m in H.
Qed.
(* end hide *)

Lemma Substream_drop :
  forall (A : Type) (n : nat) (s1 s2 : Stream A),
    Substream s1 s2 -> Substream (drop n s1) (drop n s2).
(* begin hide *)
Proof.
  induction n as [| n']; cbn; intros; [easy |].
  now apply IHn', Substream_tl.
Qed.
(* end hide *)

Lemma Substream_drop_l :
  forall (A : Type) (n : nat) (s1 s2 : Stream A),
    Substream s1 s2 -> Substream (drop n s1) s2.
(* begin hide *)
Proof.
  induction n as [| n']; cbn; intros; [easy |].
  now apply IHn', Substream_tl_l.
Qed.
(* end hide *)

Lemma Substream_refl :
  forall (A : Type) (s : Stream A),
    Substream s s.
(* begin hide *)
Proof.
  constructor; revert s.
  cofix CH.
  econstructor 1 with (pos := 0); cbn; [easy |].
  now apply CH.
Qed.
(* end hide *)

Lemma Substream_trans :
  forall (A : Type) (s1 s2 s3 : Stream A),
    Substream s1 s2 -> Substream s2 s3 -> Substream s1 s3.
(* begin hide *)
Proof.
  intros A s1 s2 s3 [H12] H23; constructor; revert s1 s2 s3 H12 H23.
  cofix CH.
  intros s1 s2 s3 [n1 p1 H12'] H23.
  destruct (Substream_drop _ n1 _ _ H23) as [n2 p2 H2].
  econstructor 1 with (n := n1 + n2); cbn.
  - now rewrite Nat.add_comm, <- nth_drop, <- p2, hd_drop.
  - apply CH with (tl (drop n1 s2)).
    + now rewrite tl_drop.
    + now rewrite drop_tl, plus_n_Sm, <- drop_drop.
Qed.
(* end hide *)

Lemma Substream_not_antisymm :
  exists (A : Type) (s1 s2 : Stream A),
    Substream s1 s2 /\ Substream s2 s1 /\ ~ sim s1 s2.
(* begin hide *)
Proof.
  exists bool, (iterate negb true), (iterate negb false).
  repeat split.
  - econstructor 1 with (n := 1); cbn; [easy |].
    now apply Substream_refl.
  - econstructor 1 with (n := 1); cbn; [easy |].
    now apply Substream_refl.
  - intros [[=] tls].
Qed.
(* end hide *)
*)

(* begin hide *)
Inductive Suffix {A : Type} : Stream A -> Stream A -> Prop :=
| Suffix_refl :
    forall s : Stream A, Suffix s s
| Suffix_tl :
    forall s1 s2 : Stream A,
      Suffix (tl s1) s2 -> Suffix s1 s2.
(* end hide *)

Fixpoint snoc {A : Type} (x : A) (l : list A) : list A :=
match l with
| nil => cons x nil
| cons h t => cons h (snoc x t)
end.

Lemma Suffix_spec :
  forall (A : Type) (s1 s2 : Stream A),
    Suffix s1 s2 <-> exists n : nat, s2 = drop n s1.
(* begin hide *)
Proof.
  split.
  - induction 1 as [| s1 s2 H [n IH]].
    + now exists 0.
    + now exists (S n).
  - intros [n ->]; revert s1.
    induction n as [| n']; cbn; intros.
    + now left.
    + now right; apply IHn'.
Qed.
(* end hide *)

(* begin hide *)
Definition Incl {A : Type} (s1 s2 : Stream A) : Prop :=
  forall x : A, Elem x s1 -> Elem x s2.

Definition SetEquiv {A : Type} (s1 s2 : Stream A) : Prop :=
  Incl s1 s2 /\ Incl s2 s1.
(* end hide *)

Lemma sim_Elem :
  forall (A : Type) (x : A) (s1 s2 : Stream A),
    sim s1 s2 -> Elem x s1 -> Elem x s2.
(* begin hide *)
Proof.
  intros A x s1 s2 Hs Hel1; revert s2 Hs.
  induction Hel1; intros s2 [hds tls].
  - now left; congruence.
  - now right; apply IHHel1.
Qed.
(* end hide *)

Lemma sim_Incl :
  forall (A : Type) (s1 s1' s2 s2' : Stream A),
    sim s1 s1' -> sim s2 s2' -> Incl s1 s2 -> Incl s1' s2'.
(* begin hide *)
Proof.
  unfold Incl.
  intros A s1 s1' s2 s2' Hs1 Hs2 Hincl x Hel.
  eapply sim_Elem; [now apply Hs2 |].
  apply Hincl.
  eapply sim_Elem; [| now eassumption].
  now apply sim_sym, Hs1.
Qed.
(* end hide *)

Lemma sim_SetEquiv :
  forall (A : Type) (s1 s1' s2 s2' : Stream A),
    sim s1 s1' -> sim s2 s2' -> SetEquiv s1 s2 -> SetEquiv s1' s2'.
(* begin hide *)
Proof.
  unfold SetEquiv.
  now split; eapply sim_Incl; firstorder eauto.
Qed.
(* end hide *)

Definition scons {A : Type} (x : A) (s : Stream A) : Stream A :=
{|
  hd := x;
  tl := s;
|}.

(** * Permutacje strumieni *)

(** Zdefiniuj relację [SPermutation], która jest analogiczna do
    relacji [Permutation], którą znasz z list. Udowodnij jej
    specyfikację. *)

(* begin hide *)
Inductive SPermutation {A : Type} : Stream A -> Stream A -> Prop :=
| SPerm_refl :
    forall s : Stream A, SPermutation s s
| SPerm_skip :
    forall (x : A) (s1 s2 : Stream A),
      SPermutation s1 s2 -> SPermutation (scons x s1) (scons x s2)
| SPerm_swap :
    forall (x y : A) (s1 s2 : Stream A),
      SPermutation s1 s2 ->
        SPermutation (scons x (scons y s1)) (scons y (scons x s2))
| SPerm_trans :
    forall s1 s2 s3 : Stream A,
      SPermutation s1 s2 -> SPermutation s2 s3 -> SPermutation s1 s3.

#[global] Hint Constructors SPermutation : core.
(* end hide *)

(* TODO *) Require Import Permutation.

Lemma lsapp_scons :
  forall (A : Type) (l : list A) (x : A) (s : Stream A),
    lsapp l (scons x s) = lsapp (snoc x l) s.
(* begin hide *)
Proof.
  induction l as [| h t]; cbn; intros.
    reflexivity.
    rewrite IHt. reflexivity.
Qed.
(* end hide *)

Lemma SPermutation_Permutation_lsapp :
  forall (A : Type) (l1 l2 : list A) (s1 s2 : Stream A),
    Permutation l1 l2 -> SPermutation s1 s2 ->
      SPermutation (lsapp l1 s1) (lsapp l2 s2).
(* begin hide *)
Proof.
  intros until 2. revert s1 s2 H0.
  induction H; intros; cbn; eauto.
  constructor. induction l as [| h t]; cbn.
    assumption.
    constructor. apply IHt.
Qed.
(* end hide *)

Lemma take_drop :
  forall (A : Type) (n : nat) (s : Stream A),
    sim s (lsapp (take n s) (drop n s)).
(* begin hide *)
Proof.
  induction n as [| n']; cbn; intros; [now apply sim_refl |].
  constructor; cbn; [easy |].
  now apply IHn'.
Qed.
(* end hide *)

Lemma take_add :
  forall (A : Type) (n m : nat) (s : Stream A),
    take (n + m) s = List.app (take n s) (take m (drop n s)).
(* begin hide *)
Proof.
  induction n as [| n']; cbn; intros; [easy |].
  now rewrite IHn'.
Qed.
(* end hide *)

Lemma SPermutation_spec :
  forall (A : Type) (s1 s2 : Stream A),
    SPermutation s1 s2 <->
    exists n : nat,
      Permutation (take n s1) (take n s2) /\
      drop n s1 = drop n s2.
(* begin hide *)
Proof.
  split.
    - induction 1 as
    [
    | x s1 s2 H (n & IH1 & IH2)
    | x y s1 s2 H (n & IH1 & IH2)
    | s1 s2 s3 H1 (n1 & IH11 & IH12) H2 (n2 & IH21 & IH22)
    ]; cbn.
      + now exists 0; cbn.
      + now exists (S n); cbn; auto.
      + exists (S (S n)); cbn.
        split; [| easy].
        now rewrite perm_swap, IH1.
      + exists (n1 + n2).
        split; cycle 1.
        * now rewrite <- drop_drop, IH12, Nat.add_comm, <- drop_drop, <- IH22, !drop_drop,
            Nat.add_comm.
        * replace (take (n1 + n2) s3) with (take (n2 + n1) s3) by now rewrite Nat.add_comm.
          now rewrite 2!take_add, IH11, IH12, <- IH22, <- IH21, <- 2!take_add, Nat.add_comm.
    - intros (n & H1 & H2). admit.
Admitted.
(*
      + rewrite (take_drop _ n s1), (take_drop _ n s2), H2.
      + apply SPermutation_Permutation_lsapp.
        * assumption.
        * apply SPerm_refl.
Qed.
*)
(* end hide *)

(** * Permutacje strumieni v2 *)

(** Poprzedni podrozdział jest trochę lipny, bo tamtejsza definicja nie uchwytuje wszystkich możliwych
    permutacji strumieni - wymusza ona, żeby każda permutacja składa się z jedynie skończonej liczby
    przestawień. *)

CoFixpoint swap {A : Type} (s : Stream A) : Stream A :=
{|
  hd := hd (tl s);
  tl :=
  {|
    hd := hd s;
    tl := swap (tl (tl s));
  |}
|}.

(** Widać, że dla strumienia pokroju [s = cocons 0 (cocons 1 (cocons 2 ...))] zdanie
    [SPermutation s (swap s)] nie zachodzi, bo przestawienia elementów ciągną się w
    nieskończoność.

    Potrzebna jest nam zatem jakaś lepsza definicja permutacji. *)

Lemma SPermutation_not_swap :
  forall {A : Type} (s : Stream A),
    SPermutation s (swap s) -> sim s (swap s).
(* begin hide *)
Proof.
  intros A s1 H.
  remember (swap s1) as s2.
  revert Heqs2.
  induction H; intros.
    apply sim_refl.
Admitted.
(* end hide *)

(** * Strumienie za pomocą przybliżeń (TODO) *)

Require Import Program.Equality.

Module approx.

Inductive Vec (A : Type) : nat -> Type :=
| vnil : Vec A 0
| vcons : forall n : nat, A -> Vec A n -> Vec A (S n).

Arguments vnil {A}.
Arguments vcons {A} {n}.

Definition vhd {A : Type} {n : nat} (v : Vec A (S n)) : A :=
match v with
| vcons h _ => h
end.

Definition vtl {A : Type} {n : nat} (v : Vec A (S n)) : Vec A n :=
match v with
| vcons _ t => t
end.

Lemma vhd_vtl :
  forall (A : Type) (n : nat) (v : Vec A (S n)),
    v = vcons (vhd v) (vtl v).
(* begin hide *)
Proof.
  dependent destruction v. cbn. reflexivity.
Qed.
(* end hide *)

Fixpoint vtake {A : Type} (s : Stream A) (n : nat) : Vec A n :=
match n with
| 0 => vnil
| S n' => vcons (hd s) (vtake (tl s) n')
end.

Fixpoint vtake' {A : Type} (s : Stream A) (n : nat) : Vec A (S n) :=
match n with
| 0 => vcons (hd s) vnil
| S n' => vcons (hd s) (vtake' (tl s) n')
end.

CoFixpoint unvtake {A : Type} (f : forall n : nat, Vec A (S n)) : Stream A :=
{|
  hd := vhd (f 0);
  tl := unvtake (fun n : nat => vtl (f (S n)))
|}.

Fixpoint vnth {A : Type} {n : nat} (v : Vec A n) (k : nat) : option A :=
match v, k with
| vnil, _ => None
| vcons h t, 0 => Some h
| vcons h t, S k' => vnth t k'
end.

Ltac depdestr x :=
  let x' := fresh "x" in remember x as x'; dependent destruction x'.

Lemma unvtake_vtake' :
  forall (A : Type) (n : nat) (f : forall n : nat, Vec A (S n)),
    (forall m1 m2 k : nat, k <= m1 -> k <= m2 ->
      vnth (f m1) k = vnth (f m2) k) ->
       vtake' (unvtake f) n = f n.
(* begin hide *)
Proof.
  induction n as [| n']; cbn; intros.
    remember (f 0) as v. dependent destruction v. cbn. f_equal.
      dependent destruction v. reflexivity.
    rewrite IHn'.
      rewrite vhd_vtl. f_equal.
        specialize (H 0 (S n') 0 ltac:(auto) ltac:(apply Nat.le_0_l)).
        depdestr (f 0). depdestr (f (S n')). cbn in *.
        inversion H. reflexivity.
      intros. specialize (H (S m1) (S m2) (S k)).
        depdestr (f (S m1)). depdestr (f (S m2)). cbn in *.
        apply H; apply le_n_S; assumption.
Qed.
(* end hide *)

Lemma vtake_unvtake :
  forall (A : Type) (s : Stream A),
    sim (unvtake (vtake' s)) s.
(* begin hide *)
Proof.
  cofix CH.
  constructor; cbn.
    reflexivity.
    apply CH.
Qed.
(* end hide *)

End approx.

(** * Pomysł dawno zapomniany: (ko)induktywne specyfikacje funkcji (TODO) *)

Inductive Filter {A : Type} (f : A -> bool) : Stream A -> Stream A -> Prop :=
| Filter_true :
    forall s r r' : Stream A,
      f (hd s) = true -> Filter f (tl s) r ->
        hd r' = hd s -> tl r' = r -> Filter f s r'
| Filter_false :
    forall s r : Stream A,
      f (hd s) = false -> Filter f (tl s) r -> Filter f s r.

Lemma Filter_bad :
  forall (A : Type) (f : A -> bool) (s r : Stream A),
    Filter f s r -> (forall x : A, f x = false) -> False.
(* begin hide *)
Proof.
  induction 1; intros.
    specialize (H3 (hd s)). congruence.
    apply IHFilter. assumption.
Qed.
(* end hide *)

CoInductive Filter' {A : Type} (f : A -> bool) (s r : Stream A) : Prop :=
{
  Filter'_true :
    f (hd s) = true -> hd s = hd r /\ Filter' f (tl s) (tl r);
  Filter'_false :
    f (hd s) = false -> Filter' f (tl s) r;
}.

Lemma Filter'_const_false :
  forall (A : Type) (s r : Stream A),
    Filter' (fun _ => false) s r.
(* begin hide *)
Proof.
  cofix CH.
  constructor.
    inversion 1.
    intros _. apply CH.
Qed.
(* end hide *)

Lemma Filter'_const_true :
  forall (A : Type) (s r : Stream A),
    Filter' (fun _ => true) s r -> sim s r.
(* begin hide *)
Proof.
  cofix CH.
  constructor.
    destruct H. firstorder.
    apply CH. destruct H. firstorder.
Qed.
(* end hide *)

(* begin hide *)

Lemma Stream_coiter :
  forall (A X : Type),
    (X -> A) -> (X -> X) -> X -> Stream A.
Proof.
  cofix CH.
  constructor.
    apply X0, X2.
    apply (CH _ _ X0 X1 (X1 X2)).
Defined.

Definition from' : nat -> Stream nat.
Proof.
  apply Stream_coiter.
    exact (fun n => n).
    exact S.
Defined.

Definition Stream' (A : Type) : Type :=
  {X : Type & X * (X -> A) * (X -> X)}%type.

Lemma Stream'_Stream {A : Type} (s : Stream' A) : Stream A.
Proof.
(*  cofix CH.*)
  destruct s as [X [[x hd] tl]].
  apply (Stream_coiter A X).
    exact hd.
    exact tl.
    exact x.
Defined.

Definition Stream_Stream' {A : Type} (s : Stream A) : Stream' A.
Proof.
  red. exists (Stream A). exact ((s, hd), tl).
Defined.

Lemma Streams :
  forall (A : Type) (s : Stream A),
    sim (Stream'_Stream (Stream_Stream' s)) s.
Proof.
  cofix CH.
  constructor.
    cbn. reflexivity.
    cbn. apply CH.
Qed.

Lemma Streams' :
  forall (A : Type) (s : Stream' A),
    Stream_Stream' (Stream'_Stream s) = s.
Proof.
  destruct s as [X [[x hd] tl]]. cbn.
  unfold Stream_Stream'.
Abort.

(* end hide *)

(** * Bijekcja między [Stream unit] i [unit] (TODO) *)

Require Import FinFun ZArith.

CoFixpoint theChosenOne : Stream unit :=
{|
  hd := tt;
  tl := theChosenOne;
|}.

Lemma all_chosen_unit_aux :
  forall s : Stream unit,
    sim s theChosenOne.
(* begin hide *)
Proof.
  cofix CH.
  constructor.
    destruct (hd s). cbn. reflexivity.
    cbn. apply CH.
Qed.
(* end hide *)

Lemma all_chosen_unit :
  forall x y : Stream unit,
    sim x y.
(* begin hide *)
Proof.
  intros.
  rewrite (all_chosen_unit_aux x), (all_chosen_unit_aux y).
  reflexivity.
Qed.
(* end hide *)

Axiom sim_eq :
  forall (A : Type) (x y : Stream A), sim x y -> x = y.

Lemma all_eq :
  forall x y : Stream unit,
    x = y.
(* begin hide *)
Proof.
  intros; apply sim_eq, all_chosen_unit.
Qed.
(* end hide *)

Definition unit_to_stream (u : unit) : Stream unit := theChosenOne.
Definition stream_to_unit (s : Stream unit) : unit := tt.

Lemma unit_is_Stream_unit :
  Bijective unit_to_stream.
(* begin hide *)
Proof.
  red. exists stream_to_unit.
  split; intros.
    destruct x; trivial.
    apply all_eq.
Qed.
(* end hide *)

(** * Trochę losowości (TODO) *)

CoFixpoint rand (seed n1 n2 : Z) : Stream Z :=
{|
  hd := Zmod seed n2;
  tl := rand (Zmod seed n2 * n1) n1 n2;
|}.

CoFixpoint rand' (seed n1 n2 : Z) : Stream Z :=
{|
  hd := Zmod seed n2;
  tl := rand' (Zmod (seed * n1) n2) n1 n2;
|}.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e158m15_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import List.
Require Import ZArith.
Require Import Lia.
Require Import Init.Nat.
Require Import Logic.Eqdep.
Require Import Logic.Eqdep_dec.
Require Import Arith.PeanoNat.
Require Import Bool.Bool.
Require Import Util.
Require Import Group.
Require Import AsynchronousGames.
Require Import Lifting.

Inductive leq_tensor (P Q : PartialOrder) :
{i : ((I P) * (I Q)) & (sum unit (sum (N P (fst i)) (N Q (snd i)))) } ->
{i : ((I P) * (I Q)) & (sum unit (sum (N P (fst i)) (N Q (snd i)))) } ->
Prop :=
| leq_tensor_least : forall i j m,
leq_tensor P Q (existT _ (i, j) (inl tt)) (existT _ (i, j) m)
| leq_tensor_left : forall i j m m' a b,
leq P (existT _ i (inr m)) (existT _ i (inr m')) ->
a = (existT _ (i, j) (inr (inl m))) ->
b = (existT _ (i, j) (inr (inl m'))) ->
leq_tensor P Q a b
| leq_tensor_right : forall i j m m' a b,
leq Q (existT _ j (inr m)) (existT _ j (inr m')) ->
a = (existT _ (i, j) (inr (inr m))) ->
b = (existT _ (i, j) (inr (inr m'))) ->
leq_tensor P Q a b.

Definition partial_order_tensor (P Q : PartialOrder) : PartialOrder :=
         {|
            I := (I P) * (I Q);
            N x := sum (N P (fst x)) (N Q (snd x));
            leq := leq_tensor P Q;
         |}.

Inductive incompatible_tensor (E F : EventStructure) :
(M (partial_order_tensor (P E) (P F))) ->
(M (partial_order_tensor (P E) (P F))) ->
Prop :=
| incomp_tensor_least : forall i j i' j' m m',
((i <> i') \/ (j <> j')) ->
incompatible_tensor E F (existT _ (i, j) m) (existT _ (i', j') m')
| incomp_tensor_left : forall index m m' a b,
incompatible E (existT _ (fst index) (inr m))
(existT _ (fst index) (inr m')) ->
a = (existT _ index (inr (inl m))) ->
b = (existT _ index (inr (inl m'))) ->
incompatible_tensor E F a b
| incomp_tensor_right : forall index m m' a b,
incompatible F (existT _ (snd index) (inr m))
(existT _ (snd index) (inr m')) ->
a = (existT _ index (inr (inr m))) ->
b = (existT _ index (inr (inr m'))) ->
incompatible_tensor E F a b.

Definition event_structure_tensor (E F : EventStructure) : EventStructure :=
        {|
            P := partial_order_tensor (P E) (P F);
            incompatible := incompatible_tensor E F;
            ideal m := match m with
                      | existT _ (i, j) (inl tt) => (existT _ (i, j) (inl tt)) :: nil
                      | existT _ (i, j) (inr (inl m)) =>
                      map (fun x => match x with
                                    | existT _ i (inl tt) => existT _ (i, j) (inl tt)
                                    | existT _ i (inr m) => existT _ (i, j) (inr (inl m))
                      end) (ideal E (existT _ i (inr m)))
                      | existT _ (i, j) (inr (inr m)) =>
                      map (fun x => match x with
                                    | existT _ j (inl tt) => existT _ (i, j) (inl tt)
                                    | existT _ j (inr m) => existT _ (i, j) (inr (inr m))
                                    end) (ideal F (existT _ j (inr m)))
                      end;
         |}.

Fixpoint cast_tensor_to_left E F (l : Position (event_structure_tensor E F))
: Position E :=
match l with
| nil => nil
| (existT _ (i,j) (inl tt)) :: xs
=> (existT _ i (inl tt)) :: (cast_tensor_to_left E F xs)
| (existT _ (i,j) (inr (inl m))) :: xs
=> (existT _ i (inr m)) :: (cast_tensor_to_left E F xs)
| (existT _ i (inr (inr _))) :: xs
=> cast_tensor_to_left E F xs
end.

Fixpoint cast_tensor_to_right E F (l : Position (event_structure_tensor E F))
: Position F :=
match l with
| nil => nil
| (existT _ (i,j) (inl tt)) :: xs
=> (existT _ j (inl tt)) :: (cast_tensor_to_right E F xs)
| (existT _ (i,j) (inr (inr m))) :: xs
=> (existT _ j (inr m)) :: (cast_tensor_to_right E F xs)
| (existT _ i (inr (inl _))) :: xs
=> cast_tensor_to_right E F xs
end.

Definition tensor_nat (p q : Z) :=
if Z.ltb p 0 then
(if Z.ltb q 0 then Z.add p q else p)
else
(if Z.ltb q 0 then q else Z.add p q).

Definition tensor_move_is_inl (A B : AsynchronousArena)
(m : M (P (event_structure_tensor (E A) (E B)))) : Prop :=
match m with
| existT _ _ (inl tt) => True
| existT _ _ (inr (inl _)) => True
| _ => False
end.

Definition tensor_move_is_inr (A B : AsynchronousArena)
(m : M (P (event_structure_tensor (E A) (E B)))) : Prop :=
match m with
| existT _ _ (inl tt) => True
| existT _ _ (inr (inr _)) => True
| _ => False
end.

Definition inl_move_is_projection (A B : AsynchronousArena)
(m : M (P (event_structure_tensor (E A) (E B))))
(m' : M (P (E A))) : Prop :=
(exists i, m = existT _ i (inl tt) /\ m' = existT _ (fst i) (inl tt))
\/
(exists i k, m = existT _ i (inr (inl k)) /\ m' = existT _ (fst i) (inr k)).

Definition inr_move_is_projection (A B : AsynchronousArena)
(m : M (P (event_structure_tensor (E A) (E B))))
(m' : M (P (E B))) : Prop :=
(exists i, m = existT _ i (inl tt) /\ m' = existT _ (snd i) (inl tt))
\/
(exists i k, m = existT _ i (inr (inr k)) /\ m' = existT _ (snd i) (inr k)).

Definition inf_projects_to_left_inf
(A B : AsynchronousArena)
(f : nat -> M (P (event_structure_tensor (E A) (E B))))
(g : (nat -> (M (P (E A))))) :=
exists (h : nat -> nat),
(forall n,
(tensor_move_is_inl A B (f n) ->
(exists k, n = h k /\ inl_move_is_projection A B (f (h k)) (g k) ))).

Definition inf_projects_to_right_inf
(A B : AsynchronousArena)
(f : nat -> M (P (event_structure_tensor (E A) (E B))))
(g : (nat -> (M (P (E B))))) :=
exists (h : nat -> nat),
(forall n,
(tensor_move_is_inr A B (f n) ->
(exists k, n = h k /\ inr_move_is_projection A B (f (h k)) (g k) ))).

Definition inf_projects_to_left_finite
(A B : AsynchronousArena)
(f : nat -> M (P (event_structure_tensor (E A) (E B))))
(g : list (M (P (E A)))) :=
exists (h : list nat),
(forall n,
(tensor_move_is_inl A B (f n) ->
(exists k m, index_of n h = Some k /\ nth_error g k = Some m /\
inl_move_is_projection A B (f n) m))).

Definition inf_projects_to_right_finite
(A B : AsynchronousArena)
(f : nat -> M (P (event_structure_tensor (E A) (E B))))
(g : list (M (P (E B)))) :=
exists (h : list nat),
(forall n,
(tensor_move_is_inr A B (f n) ->
(exists k m, index_of n h = Some k /\ nth_error g k = Some m /\
inr_move_is_projection A B (f n) m))).

Definition infinite_payoff_right_finite (A B : AsynchronousArena)
(f : nat -> M (P (event_structure_tensor (E A) (E B))) )
(inf : bool) :=
exists g l,
(inf_projects_to_left_inf A B f g) /\ (inf_projects_to_right_finite A B f l)
/\ (infinite_payoff A g inf).

Definition infinite_payoff_left_finite (A B : AsynchronousArena)
(f : nat -> M (P (event_structure_tensor (E A) (E B))) )
(inf : bool) :=
exists g l,
(inf_projects_to_right_inf A B f g) /\ (inf_projects_to_left_finite A B f l)
/\ (infinite_payoff B g inf).

Definition infinite_payoff_both_infinite (A B : AsynchronousArena)
(f : nat -> M (P (event_structure_tensor (E A) (E B))) )
(inf : bool) :=
if inf then
exists g g',
(inf_projects_to_left_inf A B f g) /\ (inf_projects_to_right_inf A B f g')
/\ (infinite_payoff A g inf) /\ (infinite_payoff A g inf)
else
(exists g, (inf_projects_to_left_inf A B f g) /\ (infinite_payoff A g inf))
\/
(exists g, (inf_projects_to_right_inf A B f g) /\ (infinite_payoff B g inf)).

Definition asynchronous_arena_tensor (A B : AsynchronousArena) : AsynchronousArena :=
        {|
            E := event_structure_tensor (E A) (E B);
            polarity m := match m with
                          | existT _ (i,j) (inl ll) => true
                          | existT _ (i,j) (inr (inl m)) => (polarity A) (existT _ i (inr m))
                          | existT _ (i,j) (inr (inr m)) => (polarity B) (existT _ j (inr m))
                          end;
            finite_payoff_position l :=
              (match l with
                | nil => (-1)%Z
                | _ => let left := finite_payoff_position A (cast_tensor_to_left _ _ l) in
                       let right := finite_payoff_position B (cast_tensor_to_right _ _ l) in
                       tensor_nat left right
              end);
            finite_payoff_walk w :=
              let fp := cast_tensor_to_left _ _ (fst (fst w)) in
              let fm := cast_tensor_to_left _ _ (snd (fst w)) in
              let sp := cast_tensor_to_left _ _ (fst (snd w)) in
              let sm := cast_tensor_to_left _ _ (snd (snd w)) in
              let left := finite_payoff_walk A ((fp, fm), (sp, sm)) in
              let fp := cast_tensor_to_right _ _ (fst (fst w)) in
              let fm := cast_tensor_to_right _ _ (snd (fst w)) in
              let sp := cast_tensor_to_right _ _ (fst (snd w)) in
              let sm := cast_tensor_to_right _ _ (snd (snd w)) in
              let right := finite_payoff_walk B ((fp, fm), (sp, sm)) in
              tensor_nat left right;
            infinite_payoff f inf :=
              (infinite_payoff_right_finite A B f inf) \/
              (infinite_payoff_left_finite A B f inf) \/
              (infinite_payoff_both_infinite A B f inf);
            positive_or_negative := true;
         |}.

Definition asynchronous_game_tensor_positive (G H: AsynchronousGame) : AsynchronousGame :=
         {|
             A := asynchronous_arena_tensor (A G) (A H);
             X := product_group (X G) (X H);
             Y := product_group (Y G) (Y H);
             action g m h := match m with
                                | existT _ (i,j) (inl tt) =>
                                  (match action G (fst g) (existT _ i (inl tt)) (fst h),
                                         action H (snd g) (existT _ j (inl tt)) (snd h) with
                                    | existT _ i _, existT _ j _ => existT _ (i,j) (inl tt)
                                  end)
                                | existT _ (i,j) (inr (inl m)) =>
                                  (match action G (fst g) (existT _ i (inr m)) (fst h),
                                         action H (snd g) (existT _ j (inl tt)) (snd h) with
                                    | existT _ i (inl tt), existT _ j _ => existT _ (i,j) (inl tt)
                                    | existT _ i (inr m), existT _ j _ => existT _ (i,j) (inr (inl m))
                                  end)
                                | existT _ (i,j) (inr (inr m)) =>
                                  (match action G (fst g) (existT _ i (inl tt)) (fst h),
                                         action H (snd g) (existT _ j (inr m)) (snd h) with
                                    | existT _ i _, existT _ j (inl tt) => existT _ (i,j) (inl tt)
                                    | existT _ i _, existT _ j (inr m) => existT _ (i,j) (inr (inr m))
                                  end)
                             end;
        |}.

Definition tensor (G H: AsynchronousGame) : AsynchronousGame :=
match positive_or_negative (A G), positive_or_negative (A H) with
| true, true => asynchronous_game_tensor_positive G H
| true, false => asynchronous_game_tensor_positive G (lifting H (1)%Z true)
| false, true => asynchronous_game_tensor_positive (lifting G (1)%Z true) H
| false, false => asynchronous_game_tensor_positive (lifting G (1)%Z true) (lifting H (1)%Z true)
end.

(*Proof.
- intros.
+ destruct x. destruct x. destruct s.
++ destruct u. apply leq_tensor_least.
++ destruct s.
+++ apply leq_tensor_left with (i:=i) (j:=i0) (m:=n) (m':=n).
++++ apply reflexive.
++++ auto.
++++ auto.
+++ apply leq_tensor_right with (i:=i) (j:=i0) (m:=n) (m':=n).
++++ apply reflexive.
++++ auto.
++++ auto.
- intros. destruct x. destruct y. destruct H. inversion H.
+ subst. inversion H0.
++ subst. apply inj_pairT2 in H3. subst. apply inj_pairT2 in H6.
subst. apply inj_pairT2 in H5. subst. auto.
++ subst. apply inj_pairT2 in H5. subst. inversion H2.
subst. apply inj_pairT2 in H2. inversion H2. subst.
apply inj_pairT2 in H3. subst. apply inj_pairT2 in H4. inversion H4.
++ subst. apply inj_pairT2 in H5. subst. inversion H2. subst.
apply inj_pairT2 in H2. subst. apply inj_pairT2 in H3. subst.
apply inj_pairT2 in H4. inversion H4.
+ subst. inversion H3. subst. inversion H2. subst.
apply inj_pairT2 in H2. subst. apply inj_pairT2 in H6. subst.
auto. inversion H0.
++ subst. inversion H5. subst. apply inj_pairT2 in H5.
inversion H5. subst. apply inj_pairT2 in H4. inversion H4. subst.
assert
((existT (fun i : I P => (unit + N P i)%type) i0 (inr m0)) =
       (existT (fun i : I P => (unit + N P i)%type) i0 (inr m'0))).
{apply anti_symmetric. auto. }
apply inj_pairT2 in H6. inversion H6. auto.
++ subst. inversion H5.
+ subst. inversion H3. subst. inversion H2. subst.
apply inj_pairT2 in H7. subst. apply inj_pairT2 in H3. subst.
inversion H0.
++ subst. inversion H5.
++ subst. inversion H5. subst. apply inj_pairT2 in H5. inversion H5.
subst. apply inj_pairT2 in H4. inversion H4. subst.
assert (
(existT (fun i : I Q => (unit + N Q i)%type) j0 (inr m0)) =
(existT (fun i : I Q => (unit + N Q i)%type) j0 (inr m'0)) ).
{ apply anti_symmetric. auto. }
apply inj_pairT2 in H7. inversion H7. auto.
- intros. destruct H. inversion H.
+ subst. inversion H0.
++ subst. apply leq_tensor_least.
++ subst. inversion H2. subst. apply leq_tensor_least.
++ subst. inversion H2. subst. apply leq_tensor_least.
+ subst. inversion H0.
++ subst. inversion H3. subst. apply inj_pairT2 in H3.
inversion H3. subst.
assert (leq P
       (existT (fun i : I P => (unit + N P i)%type) i0 (inr m))
       (existT (fun i : I P => (unit + N P i)%type) i0 (inr m'0))).
{apply transitive with (y:=
(existT (fun i : I P => (unit + N P i)%type) i0 (inr m0))). auto. }
apply leq_tensor_left with (i:=i0) (j:=j0) (m:=m) (m':=m'0). auto.
auto. auto.
++ subst. inversion H3.
+ subst. inversion H0.
++ subst. inversion H3.
++ subst. inversion H3. subst. apply inj_pairT2 in H3. inversion H3.
subst.
assert (leq Q
       (existT (fun i : I Q => (unit + N Q i)%type) j0 (inr m))
       (existT (fun i : I Q => (unit + N Q i)%type) j0 (inr m'0))).
{apply transitive with (y:=
(existT (fun i : I Q => (unit + N Q i)%type) j0 (inr m0))). auto. }
apply leq_tensor_right with (i:=i0) (j:=j0) (m:=m) (m':=m'0). auto.
auto. auto.
- intros. destruct i. unfold iff. split.
+ intros. inversion H.
++ auto.
++ subst. inversion H1.
++ subst. inversion H1.
+ intros. subst. apply leq_tensor_least with (m:=m).
- intros. inversion H.
+ auto.
+ subst. inversion H1. inversion H2. subst. auto.
+ subst. inversion H1. inversion H2. subst. auto.
- intros. destruct i. destruct j. destruct (index_equality P i i1).
+ destruct (index_equality Q i0 i2).
++ subst. left. auto.
++ right. unfold not. intros. inversion H. contradiction n.
+ right. unfold not. intros. inversion H. contradiction n.
Defined.

Proof.
- intros. inversion H.
+ subst. apply incomp_tensor_least. intuition.
+ subst. inversion H.
++ subst. inversion H4. subst. intuition.
++ subst. inversion H3. subst. apply inj_pairT2 in H6. subst.
apply inj_pairT2 in H2. inversion H2. subst.
apply incomp_tensor_left with (m:=m'0) (m':=m0).
+++ apply symmetric. auto.
+++ auto.
+++ auto.
++ subst. inversion H3.
+ subst. apply incomp_tensor_right with (m:=m') (m':=m).
++ apply symmetric. auto.
++ auto.
++ auto.
- unfold not. intros. inversion H.
+ subst. intuition.
+ subst. apply inj_pairT2 in H2. inversion H2. subst.
assert (~ incompatible E
       (existT (fun i : I (P E) => (unit + N (P E) i)%type)
          (fst index) (inr m'))
       (existT (fun i : I (P E) => (unit + N (P E) i)%type)
          (fst index) (inr m'))).
{apply irreflexive. } contradiction H1.
+ subst. apply inj_pairT2 in H2. inversion H2. subst.
assert (~ incompatible F
       (existT (fun i : I (P F) => (unit + N (P F) i)%type)
          (snd index) (inr m'))
       (existT (fun i : I (P F) => (unit + N (P F) i)%type)
          (snd index) (inr m'))).
{apply irreflexive. } contradiction H1.
- intros. simpl. destruct x.
+ destruct x. destruct y.
++ destruct x. destruct s.
+++ simpl. destruct u.
++++ unfold iff. split.
+++++ intros. simpl. left. inversion H.
++++++ subst. apply inj_pairT2 in H6. subst.
apply inj_pairT2 in H3. subst. auto.
++++++ subst. inversion H2.
++++++ subst. inversion H2.
+++++ intros. destruct H.
++++++ inversion H. subst. apply inj_pairT2 in H. subst.
apply leq_tensor_least.
++++++ contradiction H.
+++ destruct n.
++++ simpl. unfold iff. split.
+++++ intros. apply in_map_iff. inversion H.
++++++ subst. inversion H6. subst.
apply inj_pairT2 in H3. subst.
refine (ex_intro _ (existT _ i (inl tt)) _). split.
+++++++ auto.
+++++++ apply ideal_finite. apply unit_is_least. auto.
++++++ subst. inversion H2. subst. apply inj_pairT2 in H2.
inversion H2. subst. inversion H1. subst. apply inj_pairT2 in H1.
subst. refine (ex_intro _ (existT _ i3 (inr m)) _). split.
+++++++ auto.
+++++++ apply ideal_finite. auto.
++++++ subst. inversion H2.
+++++ intros. apply in_map_iff in H. destruct H. destruct x. destruct s.
++++++ destruct u. inversion H. subst. inversion H0. subst.
apply inj_pairT2 in H0. subst. apply ideal_finite in H1.
apply unit_is_least in H1. subst. apply leq_tensor_least.
++++++ destruct H. inversion H. subst. apply inj_pairT2 in H. subst.
apply ideal_finite in H0. assert (H1 := H0).
apply leq_same_component in H0. subst.
apply leq_tensor_left with (i:=i) (j:=i2) (m:=n0) (m':=n). auto. auto.
auto.
++++ unfold iff. split.
+++++ intros. apply in_map_iff. inversion H.
++++++ subst. apply inj_pairT2 in H3. subst.
refine (ex_intro _ (existT _ i0 (inl tt)) _). split.
+++++++ auto.
+++++++ apply ideal_finite. apply unit_is_least. auto.
++++++ subst. inversion H1. subst. apply inj_pairT2 in H1. subst.
inversion H2.
++++++ subst. inversion H2. subst. apply inj_pairT2 in H2. inversion H2.
subst. inversion H1. subst. apply inj_pairT2 in H7. subst.
refine (ex_intro _ (existT _ j (inr m)) _). split.
+++++++ auto.
+++++++ apply ideal_finite. auto.
+++++ intros.
++++++ apply in_map_iff in H. destruct H. destruct x. destruct H.
apply ideal_finite in H0. assert (H1 := H0). apply leq_same_component in H0. subst.
destruct s.
+++++++ destruct u. inversion H. subst. apply inj_pairT2 in H. subst.
apply leq_tensor_least.
+++++++ inversion H. subst. apply inj_pairT2 in H. subst.
apply leq_tensor_right with (i:=i1) (j:=i2) (m:=n0) (m':=n). auto. auto. auto.
- intros. destruct H. inversion H.
+ subst. inversion H0.
++ apply incomp_tensor_least. auto.
++ subst. inversion H3. subst. apply incomp_tensor_least. auto.
++ subst. inversion H3. subst. apply incomp_tensor_least. auto.
+ subst. inversion H0.
++ subst. inversion H3. subst. apply inj_pairT2 in H3. inversion H3.
subst. apply incomp_tensor_left with (m:=m) (m':=m'0). apply incompatible_closed
with (y:=(existT (fun i0 : I (P E) => (unit + N (P E) i0)%type)
     (fst (i, j)) (inr m0))). auto. auto. auto.
++ subst. inversion H3.
+ subst. inversion H0.
++ subst. inversion H3.
++ subst. inversion H3. subst. apply inj_pairT2 in H3. inversion H3.
subst. apply incomp_tensor_right with (m:=m) (m':=m'0). apply incompatible_closed
with (y:=(existT (fun i0 : I (P F) => (unit + N (P F) i0)%type)
     (snd (i, j)) (inr m0))). auto. auto. auto.
Defined.

Fact second_in_tensor_is_second :
forall E F m, second_move (P (event_structure_tensor E F)) m <->
((exists i j k, m = existT _ (i,j) (inr (inl k)) /\
second_move (P E) (existT _ i (inr k)))
\/
(exists i j k, m = existT _ (i,j) (inr (inr k)) /\
second_move (P F) (existT _ j (inr k)))).
Proof. unfold iff. split.
+ intros. unfold second_move in H. destruct H.
rewrite initial_is_unit in H. destruct m. destruct s.
++ contradiction H. refine (ex_intro _ x _). destruct u. auto.
++ destruct x. destruct n.
+++ left. refine (ex_intro _ i _). refine (ex_intro _ i0 _).
refine (ex_intro _ n _). split.
++++ auto.
++++ unfold second_move. unfold not. intros. split.
+++++ intros. rewrite initial_is_unit in H1. destruct H1.
inversion H1.
+++++ intros. destruct n0.
++++++ destruct s.
+++++++ destruct u. apply initial_is_unit.
refine (ex_intro _ x _). auto.
+++++++ destruct H1. assert (H3 := H1).
apply leq_same_component in H3. subst.
assert (initial_move (P (event_structure_tensor E F))
(existT
          (fun i : I (P (event_structure_tensor E F)) =>
           (unit + N (P (event_structure_tensor E F)) i)%type)
          (i, i0) (inr (inl n0)))).
{apply H0. split.
+ apply leq_tensor_left with (i:=i) (j:=i0) (m:=n0) (m':=n).
++ auto.
++ auto.
++ auto.
+ unfold not. intros. apply inj_pairT2 in H3. inversion H3. subst.
contradiction H2. auto. }
apply initial_is_unit in H3. destruct H3. inversion H3.
+++ simpl. right. refine (ex_intro _ i _). refine (ex_intro _ i0 _).
refine (ex_intro _ n _). split.
++++ auto.
++++ unfold second_move. split.
+++++ unfold not. intros. apply initial_is_unit in H1. destruct H1.
inversion H1.
+++++ intros. destruct H1. assert (H3 := H1). destruct n0.
++++++ apply leq_same_component in H3. subst. destruct s.
+++++++ apply initial_is_unit. destruct u. refine (ex_intro _ i0 _).
auto.
+++++++
assert (initial_move (P (event_structure_tensor E F))
(existT
          (fun i : I (P (event_structure_tensor E F)) =>
           (unit + N (P (event_structure_tensor E F)) i)%type)
          (i, i0) (inr (inr n0)))).
{apply H0. split.
+ apply leq_tensor_right with (i:=i) (j:=i0) (m:=n0) (m':=n).
++ auto.
++ auto.
++ auto.
+ unfold not. intros. apply inj_pairT2 in H3. inversion H3. subst.
contradiction H2. auto.
 } apply initial_is_unit in H3. destruct H3. inversion H3.
+ intros. destruct H.
++ destruct H. destruct H. destruct H. destruct H. subst. unfold second_move.
split.
+++ unfold not. intros. apply initial_is_unit in H. destruct H. inversion H.
+++ intros. destruct H. unfold second_move in H0. destruct H0. destruct n.
++++ destruct s.
+++++ apply initial_is_unit. destruct u. refine (ex_intro _ x2 _). auto.
+++++ inversion H.
++++++ subst. inversion H5. subst. apply inj_pairT2 in H5. inversion H5.
subst. inversion H4. subst. apply inj_pairT2 in H4. inversion H4. subst.
assert (initial_move (P E) (existT (fun i : I (P E) => (unit + N (P E) i)%type) i
          (inr m))).
{apply H2. split.
+ auto.
+ unfold not. intros. apply inj_pairT2 in H6. inversion H6. subst. contradiction H1. auto.
} apply initial_is_unit in H6. destruct H6. inversion H6.
++++++ subst. inversion H5.
++ destruct H. destruct H. destruct H. destruct H. subst. unfold second_move. split.
+++ unfold not. intros. apply initial_is_unit in H. destruct H. inversion H.
+++ intros. destruct H. unfold second_move in H0. destruct H0. destruct n.
++++ destruct s.
+++++ apply initial_is_unit. destruct u. refine (ex_intro _ x2 _). auto.
+++++ inversion H.
++++++ subst. inversion H5.
++++++ subst. inversion H5. subst. apply inj_pairT2 in H5. inversion H5.
subst. inversion H4. subst. apply inj_pairT2 in H4. inversion H4. subst.
assert (initial_move (P F) (existT (fun i : I (P F) => (unit + N (P F) i)%type) j
          (inr m))).
{apply H2. split.
+ auto.
+ unfold not. intros. apply inj_pairT2 in H6. inversion H6. subst. contradiction H1. auto.
} apply initial_is_unit in H6. destruct H6. inversion H6.
Qed.

Proof.
- left. auto.
- intros. apply initial_is_unit in H. destruct H. subst.
destruct x. easy.
- intros. apply second_in_tensor_is_second in H. destruct H.
+ destruct H. destruct H. destruct H. destruct H. subst. apply polarity_second in H0.
rewrite positive1 in H0. auto.
+ destruct H. destruct H. destruct H. destruct H. subst. apply polarity_second in H0.
rewrite positive2 in H0. auto.
- intros. destruct H. destruct w. destruct p. destruct p0. simpl in *. subst. simpl.
assert ((finite_payoff_walk A
     (cast_tensor_to_left (E A) (E B) p, nil,
     (cast_tensor_to_left (E A) (E B) p0, nil))) = 0%Z).
{apply initial_null. auto. }
assert ((finite_payoff_walk B
     (cast_tensor_to_right (E A) (E B) p, nil,
     (cast_tensor_to_right (E A) (E B) p0, nil))) = 0%Z).
{apply initial_null. auto. }
assert (forall a b f, a = 0%Z /\ b = 0%Z /\ f 0%Z 0%Z  = 0%Z
-> f a b = 0%Z).
{intros. destruct H1. destruct H2. subst. auto. }
apply H1. auto.
Defined.

Proof.
- intros.
assert (left_action _ _ (actl G) /\ left_action _ _ (actl H)).
{split; apply restriction_to_left_is_action. }
destruct H0. destruct H0. destruct H1. unfold actl in *. unfold left_action. split.
+ intros. destruct x. destruct x. destruct s.
++ destruct u. flatten_all. simpl in *. rewrite H0 in e. inversion e. subst.
apply inj_pairT2 in e. subst. rewrite H1 in e0. inversion e0. subst. apply inj_pairT2 in e0.
subst. auto.
++ destruct n.
+++ simpl. flatten_all; subst.
++++  rewrite H0 in e. inversion e.
++++  rewrite H0 in e. inversion e. subst.
apply inj_pairT2 in e. subst. rewrite H1 in e1. inversion e1. subst. apply inj_pairT2 in e1.
subst. auto.
+++ simpl. flatten_all; subst.
++++  rewrite H0 in e. inversion e. subst.
apply inj_pairT2 in e. subst. rewrite H1 in e0. inversion e0.
++++  rewrite H0 in e. inversion e. subst.
apply inj_pairT2 in e. subst. rewrite H1 in e0. inversion e0. subst. apply inj_pairT2 in e0.
subst. auto.
+ intros. destruct x. destruct x. destruct s.
++ destruct u. simpl. flatten_all; subst.
+++ rewrite <- H3 in e8. rewrite <- H2 in e7. inversion e. subst. apply inj_pairT2 in e.
subst. rewrite e1 in e8. rewrite e0 in e7.
assert (leq _
(action G (fst g)
       (existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) i1
          (inl tt)) (id (Y G)))
(action G (fst g)
       (existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) i1 s0)
       (id (Y G)))).
{apply coherence_1. apply unit_is_least. auto. }
rewrite e7 in H4. rewrite e5 in H4. apply leq_same_component in H4. subst.
assert (leq _
(action H (snd g)
       (existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) i2
          (inl tt)) (id (Y H)))
(action H (snd g)
       (existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) i2 s1)
       (id (Y H)))).
{apply coherence_1. apply unit_is_least. auto. }
rewrite e8 in H4. rewrite e6 in H4. apply leq_same_component in H4. subst. auto.
+++ apply action_does_not_send_inr_to_inl in e5. contradiction e5.
+++ inversion e.
+++ inversion e.
+++ inversion e.
++ destruct n.
+++ flatten_all; subst; simpl in *.
++++ apply action_does_not_send_inr_to_inl in e9. contradiction e9.
++++ apply action_does_not_send_inr_to_inl in e0. contradiction e0.
++++ apply action_does_not_send_inr_to_inl in e0. contradiction e0.
++++ apply action_does_not_send_inr_to_inl in e7. contradiction e7.
++++ apply action_does_not_send_inr_to_inl in e10. contradiction e10.
++++ inversion e.
++++ apply action_does_not_send_inr_to_inl in e11. contradiction e11.
++++ apply action_does_not_send_inr_to_inl in e8. contradiction e8.
++++ apply action_does_not_send_inr_to_inl in e10. contradiction e10.
++++ inversion e.
++++ apply action_does_not_send_inr_to_inl in e8. contradiction e8.
++++ inversion e.
++++ apply action_does_not_send_inr_to_inl in e6. contradiction e6.
++++ apply action_does_not_send_inr_to_inl in e6. contradiction e6.
++++ apply action_does_not_send_inr_to_inl in e9. contradiction e9.
++++ inversion e. subst. apply inj_pairT2 in e. inversion e. subst. rewrite <- H3 in
e11. rewrite <- H2 in e9. rewrite e0 in e9. rewrite e2 in e11. rewrite e6 in e9.
assert (leq _
(action H (snd g)
       (existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) i2 (inl tt))
       (id (Y H)))
(action H (snd g)
        (existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) i2 s1)
        (id (Y H)))).
{apply coherence_1. apply unit_is_least. auto. }
rewrite e11 in H4. rewrite e8 in H4. apply leq_same_component in H4. subst. inversion e9.
subst. apply inj_pairT2 in e9. auto.
++++ apply action_does_not_send_inr_to_inl in e10. contradiction e10.
++++ apply action_does_not_send_inr_to_inl in e7. contradiction e7.
++++ apply action_does_not_send_inr_to_inl in e9. contradiction e9.
++++ inversion e.
+++ flatten_all; subst; simpl in *.
++++ apply action_does_not_send_inr_to_inl in e10. contradiction e10.
++++ apply action_does_not_send_inr_to_inl in e1. contradiction e1.
++++ apply action_does_not_send_inr_to_inl in e1. contradiction e1.
++++ apply action_does_not_send_inr_to_inl in e7. contradiction e7.
++++ apply action_does_not_send_inr_to_inl in e11. contradiction e11.
++++ inversion e.
++++ apply action_does_not_send_inr_to_inl in e12. contradiction e12.
++++ apply action_does_not_send_inr_to_inl in e8. contradiction e8.
++++ apply action_does_not_send_inr_to_inl in e11. contradiction e11.
++++ inversion e.
++++ apply action_does_not_send_inr_to_inl in e9. contradiction e9.
++++ inversion e.
++++ apply action_does_not_send_inr_to_inl in e6. contradiction e6.
++++ apply action_does_not_send_inr_to_inl in e6. contradiction e6.
++++ inversion e.
++++ inversion e.
++++ apply action_does_not_send_inr_to_inl in e11. contradiction e11.
++++ apply action_does_not_send_inr_to_inl in e7. contradiction e7.
++++ apply action_does_not_send_inr_to_inl in e10. contradiction e10.
++++ inversion e. subst. apply inj_pairT2 in e. inversion e. subst. rewrite <- H3 in
e10. rewrite <- H2 in e9. rewrite e0 in e9. rewrite e1 in e10. rewrite e7 in e10.
inversion e10. subst. apply inj_pairT2 in e10. inversion e10. subst.
assert (leq _
(action G (fst g)
       (existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) i1 (inl tt))
       (id (Y G)))
(action G (fst g) (existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) i1 s0)
       (id (Y G)))).
{apply coherence_1. apply unit_is_least. auto. }
rewrite e9 in H4. rewrite e6 in H4. apply leq_same_component in H4. subst. auto.
- intros.
assert (right_action _ _ (actr G) /\ right_action _ _ (actr H)).
{split; apply restriction_to_right_is_action. }
destruct H0. destruct H0. destruct H1. unfold actr in *. unfold right_action. split.
+ intros. destruct x. destruct x. destruct s.
++ destruct u. flatten_all. simpl in *. rewrite H0 in e. inversion e. subst.
apply inj_pairT2 in e. subst. rewrite H1 in e0. inversion e0. subst. apply inj_pairT2 in e0.
subst. auto.
++ destruct n.
+++ simpl. flatten_all; subst.
++++  rewrite H0 in e. inversion e.
++++  rewrite H0 in e. inversion e. subst.
apply inj_pairT2 in e. subst. rewrite H1 in e1. inversion e1. subst. apply inj_pairT2 in e1.
subst. auto.
+++ simpl. flatten_all; subst.
++++  rewrite H0 in e. inversion e. subst.
apply inj_pairT2 in e. subst. rewrite H1 in e0. inversion e0.
++++  rewrite H0 in e. inversion e. subst.
apply inj_pairT2 in e. subst. rewrite H1 in e0. inversion e0. subst. apply inj_pairT2 in e0.
subst. auto.
+ intros. destruct x. destruct x. destruct s.
++ destruct u. simpl. flatten_all; subst.
+++ rewrite <- H3 in e8. rewrite <- H2 in e7. inversion e. subst. apply inj_pairT2 in e.
subst. rewrite e1 in e8. rewrite e0 in e7.
assert (leq _
(action G (id (X G))
       (existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) i1 (inl tt))
       (fst h))
(action G (id (X G))
       (existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) i1 s0)
       (fst h))).
{apply coherence_1. apply unit_is_least. auto. }
rewrite e7 in H4. rewrite e5 in H4. apply leq_same_component in H4. subst.
assert (leq _
(action H (id (X H))
       (existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) i2 (inl tt))
       (snd h))
(action H (id (X H))
       (existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) i2 s1)
       (snd h))).
{apply coherence_1. apply unit_is_least. auto. }
rewrite e8 in H4. rewrite e6 in H4. apply leq_same_component in H4. subst. auto.
+++ apply action_does_not_send_inr_to_inl in e5. contradiction e5.
+++ inversion e.
+++ inversion e.
+++ inversion e.
++ destruct n.
+++ flatten_all; subst; simpl in *.
++++ apply action_does_not_send_inr_to_inl in e9. contradiction e9.
++++ apply action_does_not_send_inr_to_inl in e0. contradiction e0.
++++ apply action_does_not_send_inr_to_inl in e0. contradiction e0.
++++ apply action_does_not_send_inr_to_inl in e7. contradiction e7.
++++ apply action_does_not_send_inr_to_inl in e10. contradiction e10.
++++ inversion e.
++++ apply action_does_not_send_inr_to_inl in e11. contradiction e11.
++++ apply action_does_not_send_inr_to_inl in e8. contradiction e8.
++++ apply action_does_not_send_inr_to_inl in e10. contradiction e10.
++++ inversion e.
++++ apply action_does_not_send_inr_to_inl in e8. contradiction e8.
++++ inversion e.
++++ apply action_does_not_send_inr_to_inl in e6. contradiction e6.
++++ apply action_does_not_send_inr_to_inl in e6. contradiction e6.
++++ apply action_does_not_send_inr_to_inl in e9. contradiction e9.
++++ inversion e. subst. apply inj_pairT2 in e. inversion e. subst. rewrite <- H3 in
e11. rewrite <- H2 in e9. rewrite e0 in e9. rewrite e2 in e11. rewrite e6 in e9.
assert (leq _
(action H (id (X H))
       (existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) i2 (inl tt))
       (snd h))
(action H (id (X H))
        (existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) i2 s1)
        (snd h))).
{apply coherence_1. apply unit_is_least. auto. }
rewrite e11 in H4. rewrite e8 in H4. apply leq_same_component in H4. subst. inversion e9.
subst. apply inj_pairT2 in e9. auto.
++++ apply action_does_not_send_inr_to_inl in e10. contradiction e10.
++++ apply action_does_not_send_inr_to_inl in e7. contradiction e7.
++++ apply action_does_not_send_inr_to_inl in e9. contradiction e9.
++++ inversion e.
+++ flatten_all; subst; simpl in *.
++++ apply action_does_not_send_inr_to_inl in e10. contradiction e10.
++++ apply action_does_not_send_inr_to_inl in e1. contradiction e1.
++++ apply action_does_not_send_inr_to_inl in e1. contradiction e1.
++++ apply action_does_not_send_inr_to_inl in e7. contradiction e7.
++++ apply action_does_not_send_inr_to_inl in e11. contradiction e11.
++++ inversion e.
++++ apply action_does_not_send_inr_to_inl in e12. contradiction e12.
++++ apply action_does_not_send_inr_to_inl in e8. contradiction e8.
++++ apply action_does_not_send_inr_to_inl in e11. contradiction e11.
++++ inversion e.
++++ apply action_does_not_send_inr_to_inl in e9. contradiction e9.
++++ inversion e.
++++ apply action_does_not_send_inr_to_inl in e6. contradiction e6.
++++ apply action_does_not_send_inr_to_inl in e6. contradiction e6.
++++ inversion e.
++++ inversion e.
++++ apply action_does_not_send_inr_to_inl in e11. contradiction e11.
++++ apply action_does_not_send_inr_to_inl in e7. contradiction e7.
++++ apply action_does_not_send_inr_to_inl in e10. contradiction e10.
++++ inversion e. subst. apply inj_pairT2 in e. inversion e. subst. rewrite <- H3 in
e10. rewrite <- H2 in e9. rewrite e0 in e9. rewrite e1 in e10. rewrite e7 in e10.
inversion e10. subst. apply inj_pairT2 in e10. inversion e10. subst.
assert (leq _
(action G (id (X G))
       (existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) i1 (inl tt))
       (fst h))
(action G (id (X G))
       (existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) i1 s0)
       (fst h))).
{apply coherence_1. apply unit_is_least. auto. }
rewrite e9 in H4. rewrite e6 in H4. apply leq_same_component in H4. subst. auto.
- intros. destruct m. inversion H0.
+ subst. apply inj_pairT2 in H3. subst. flatten_all; subst.
++ apply reflexive.
++ apply action_does_not_send_inr_to_inl in e3. contradiction e3.
++ assert (leq _
(action G (fst g)
      (existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) i (inl tt))
      (fst h))
(action G (fst g)
       (existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) i (inr n))
       (fst h))).
{apply coherence_1. apply unit_is_least. auto. }
rewrite e3 in H1. rewrite e in H1. apply leq_same_component in H1. subst. apply unit_is_least. auto.
++ apply action_does_not_send_inr_to_inl in e3. contradiction e3.
++ assert (leq _
(action H (snd g)
       (existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) j (inl tt))
       (snd h))
(action H (snd g)
       (existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) j (inr n))
       (snd h))).
{apply coherence_1. apply unit_is_least. auto. }
rewrite e3 in H1. rewrite e0 in H1. apply leq_same_component in H1. subst. apply unit_is_least. auto.
+ subst. inversion H2. subst. apply inj_pairT2 in H2. subst. flatten_all; subst; simpl in *.
++ apply action_does_not_send_inr_to_inl in e3. contradiction e3.
++ apply action_does_not_send_inr_to_inl in e. contradiction e.
++ apply action_does_not_send_inr_to_inl in e2. contradiction e2.
++ assert (leq _
(action G (fst g)
      (existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) i (inr m))
      (fst h))
(action G (fst g)
       (existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) i (inr m'))
       (fst h))).
{apply coherence_1. auto. }
rewrite e2 in H2. rewrite e in H2. assert (H3:=H2). apply leq_same_component in H2. subst.
apply leq_tensor_left with (i:=x1) (j:=x0) (m:=n) (m':=n0). auto. auto. auto.
+ subst. inversion H2. subst. apply inj_pairT2 in H2. subst. flatten_all; subst; simpl in *.
++ apply action_does_not_send_inr_to_inl in e3. contradiction e3.
++ apply action_does_not_send_inr_to_inl in e0. contradiction e0.
++ apply action_does_not_send_inr_to_inl in e2. contradiction e2.
++ assert (leq _
(action H (snd g) (existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) j (inr m))
       (snd h))
(action H (snd g) (existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) j (inr m'))
       (snd h))).
{apply coherence_1. auto. }
rewrite e2 in H2. rewrite e0 in H2. assert (H3:=H2). apply leq_same_component in H2. subst.
apply leq_tensor_right with (i:=x) (j:=x1) (m:=n) (m':=n0). auto. auto. auto.
- intros. destruct m. destruct x. flatten_all; subst; simpl in *.
+ auto.
+ apply action_does_not_send_inr_to_inl in e1. contradiction e1.
+ rewrite <- e1. apply coherence_2.
+ apply action_does_not_send_inr_to_inl in e2. contradiction e2.
+ rewrite <- e2. apply coherence_2.
- intros. destruct i. destruct
(action G (fst g)
       (existT (fun i1 : I (P (E (A G))) => (unit + N (P (E (A G))) i1)%type) i
          (inl tt)) (fst h)).
destruct (action H (snd g)
       (existT (fun i2 : I (P (E (A H))) => (unit + N (P (E (A H))) i2)%type) i0
          (inl tt)) (snd h)). refine (ex_intro _ (x,x0) _). auto.
- intros. destruct i. destruct m.
+ destruct (action G (fst g)
       (existT (fun i1 : I (P (E (A G))) => (unit + N (P (E (A G))) i1)%type) i
          (inr n)) (fst h)) eqn:eqn1. destruct s.
++ assert (exists k k1,
action G (fst g)
         (existT (fun i1 : I (P (E (A G))) => (unit + N (P (E (A G))) i1)%type) i
            (inr n)) (fst h) =
existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) k (inr k1)).
{apply action_preserves_non_initial. }
destruct H0. destruct H0. rewrite eqn1 in H0. inversion H0.
++ destruct (action H (snd g)
       (existT (fun i1 : I (P (E (A H))) => (unit + N (P (E (A H))) i1)%type) i0
          (inl tt)) (snd h)) eqn:eqn2. refine (ex_intro _ (x,x0) _). refine (ex_intro _ (inl n0) _).
auto.
+ destruct (action G (fst g)
       (existT (fun i1 : I (P (E (A G))) => (unit + N (P (E (A G))) i1)%type) i
          (inl tt)) (fst h)) eqn:eqn1. destruct s.
++ destruct (action H (snd g)
       (existT (fun i1 : I (P (E (A H))) => (unit + N (P (E (A H))) i1)%type) i0
          (inr n)) (snd h)) eqn:eqn2. destruct s.
+++ assert (exists k k1,
action H (snd g)
         (existT (fun i1 : I (P (E (A H))) => (unit + N (P (E (A H))) i1)%type) i0
            (inr n)) (snd h) =
existT (fun i : I (P (E (A H))) => (unit + N (P (E (A H))) i)%type) k
         (inr k1)).
{apply action_preserves_non_initial. }
destruct H0. destruct H0. rewrite eqn2 in H0. inversion H0.
+++ refine (ex_intro _ (x,x0) _). refine (ex_intro _ (inr n0) _). auto.
++ assert (exists k,
action G (fst g)
         (existT (fun i1 : I (P (E (A G))) => (unit + N (P (E (A G))) i1)%type) i
            (inl tt)) (fst h) =
existT (fun i : I (P (E (A G))) => (unit + N (P (E (A G))) i)%type) k
         (inl tt)).
{apply action_preserves_initial. }
destruct H0. rewrite eqn1 in H0. inversion H0.
Defined.*)


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e140m27_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e174m3_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


From Coq Require Import ssreflect ssrfun ssrbool.

From stdpp Require Import propset.

From MatchingLogic Require Import Syntax.

(* TODO: set? *)
(* TODO: well-formedness *)
Record NamedAxioms {Σ : Signature} :=
{
  NAName : Type;
  NAAxiom : NAName -> Pattern ;
  NAwf : forall (name : NAName), well_formed (NAAxiom name) ;
}.

Definition theory_of_NamedAxioms {Σ : Signature} (NAs : NamedAxioms) : Theory :=
  PropSet (fun p => exists (n : NAName NAs), p = NAAxiom _ n).

(* TODO: do we want to make this a type class? *)
Record NamedAxiomsIncluded {Σ : Signature}  (NA₁ NA₂ : NamedAxioms) :=
  { NAIinj : NAName NA₁ -> NAName NA₂;
    NAIax : forall (n : NAName NA₁), NAAxiom _ n = NAAxiom _ (NAIinj n);
  }.

Lemma NamedAxiomsIncluded_impl_TheoryIncluded {Σ : Signature} NA₁ NA₂:
  NamedAxiomsIncluded NA₁ NA₂ ->
  (theory_of_NamedAxioms NA₁) ⊆ (theory_of_NamedAxioms NA₂).
Proof.
  intros [inj ax].
  unfold theory_of_NamedAxioms.
  rewrite -> elem_of_subseteq.
  intros ϕ H.
  rewrite -> elem_of_PropSet. rewrite -> elem_of_PropSet in H.
  destruct H as [n Hn]. subst ϕ.
  eexists. auto.
Qed.

Program Definition NamedAxiomsIncluded_refl {Σ : Signature} NA : NamedAxiomsIncluded NA NA :=
  {| NAIinj := λ n, n; |}.
Next Obligation. auto. Qed.
(* TODO make it a stdpp preorder  *)

Program Definition NamedAxiomsIncluded_compose {Σ : Signature} NA₁ NA₂ NA₃ :
  NamedAxiomsIncluded NA₁ NA₂ ->
  NamedAxiomsIncluded NA₂ NA₃ ->
  NamedAxiomsIncluded NA₁ NA₃ :=
  λ HI₁ HI₂, {| NAIinj := λ n, NAIinj _ _ HI₂ (NAIinj _ _ HI₁ n);  |}.
Next Obligation.
  intros Σ NA₁ NA₂ NA₃ [inj₁ ax₁] [inj₂ ax₂] n.
  simpl.
  rewrite -ax₂.
  rewrite -ax₁.
  auto.
Qed.


Require Import FP.CoreData.
Require Import FP.CoreClasses.

Import CoreDataNotation.
Import CoreClassesNotation.

Section Deriving_RDC.
  Context {T U} inj TR TD UR UD
    `{! InjectionRespect T U inj TR UR
     ,! RelDecCorrect U UR UD
     }
    `(! TD = (UD `on` inj) ).

  Definition Deriving_RDC : RelDecCorrect T TR TD.
  Proof. constructor ; intros.
    - rewrite H ; simpl.
      apply InjectionRespect_eta in H0.
      apply rel_correct ; auto.
    - rewrite H in H0 ; simpl in H0.
      apply InjectionRespect_beta.
      apply dec_correct ; auto.
  Qed.
End Deriving_RDC.

Section Deriving_IR.
  Context {T U} inj (TR:T->T->Prop) (UR:U->U->Prop)
    `(! TR = (UR `on` inj) ).

  Definition Deriving_IR : InjectionRespect T U inj TR UR.
  Proof. constructor ; unfold Proper,"==>","<==" ; simpl ; intros.
    rewrite H in H0 ; auto.
    rewrite H ; unfold on ; simpl ; auto.
  Qed.
End Deriving_IR.

Section Deriving_IR_inv.
  Context {T U} to from TR UR
    `{! PER TR
     ,! InjectionRespect T U to UR TR
     ,! InjectionInverse U T from to eq
     }
    `(! UR = (TR `on` to) ).

  Definition Deriving_IR_inv : InjectionRespect U T from TR UR.
  Proof.
    constructor ; unfold Proper,"==>","<==" ; simpl ; intros.
    - rewrite H ; simpl.
      repeat (rewrite InjectionInverse_inv ; logical_eqv).
    - rewrite H in H0 ; simpl in H0.
      repeat (rewrite InjectionInverse_inv in H0 ; logical_eqv).
  Qed.
End Deriving_IR_inv.

Section Deriving_II_ext.
  Context {T U} to from R1 R2
    `{! Equivalence R1
     ,! Equivalence R2
     ,! InjectionInverse T U to from R1
     ,! Proper (R1 ==> R1 ==> impl) R2
     }.

  Definition Deriving_II_ext : InjectionInverse T U to from R2.
  Proof. constructor ; intros.
    eapply Proper0.
    - symmetry ; apply InjectionInverse_inv ; logical_eqv.
    - reflexivity.
    - reflexivity.
  Qed.
End Deriving_II_ext.

Section Deriving_ID.
  Context {T U} to from TM UM
    `{! InjectionInverse U T from to eq }
    `(! TM = (from '.:' (UM `on` to)) ).

  Definition Deriving_ID : InjectionDistribute T U to TM UM eq.
  Proof. constructor ; intros.
    rewrite H ; simpl.
    apply InjectionInverse_inv ; logical_eqv.
  Qed.
End Deriving_ID.

Section Deriving_ID_ext.
  Context {T U} to TM UM eqv1 eqv2
    `{! Equivalence eqv1 ,! Equivalence eqv2
     ,! InjectionDistribute T U to TM UM eqv1
     ,! Proper (eqv1 ==> eqv1 ==> impl) eqv2
     }.

  Definition Deriving_ID_ext : InjectionDistribute T U to TM UM eqv2.
  Proof.
    constructor ; intros.
    rewrite InjectionDistribute_law.
    reflexivity.
  Qed.
End Deriving_ID_ext.

Section Deriving_Eq_RDC.
  Context {T U} inj
    `{! EqDec T ,! EqDec U
     ,! Eq_RDC U
     ,! InjectionRespect T U inj eq eq
     }
    `(! eq_dec = (eq_dec `on` inj) ).

  Definition Deriving_Eq_RDC : Eq_RDC T.
  Proof.
    repeat (constructor ; simpl in * ; intros).
    - rewrite H ; simpl.
      apply rel_correct.
      apply InjectionRespect_eta ; auto.
    - rewrite H in H0 ; simpl in H0.
      apply dec_correct in H0.
      apply InjectionRespect_beta ; auto.
    Qed.
End Deriving_Eq_RDC.

Section Deriving_PER_WF.
  Context {T U} inj
    `{! Eqv T ,! Eqv U ,! PER_WF U
     ,! InjectionRespect T U inj eqv eqv
     }.

  Definition Deriving_PER_WF : PER_WF T.
  Proof.
    repeat constructor.
    - unfold Symmetric ; intros.
      apply InjectionRespect_beta ; apply InjectionRespect_eta in H ; symmetry ; auto.
    - unfold Transitive ; intros x y z H1 H2.
      apply InjectionRespect_beta.
      apply InjectionRespect_eta in H1 ; apply InjectionRespect_eta in H2.
      transitivity (inj y) ; auto.
  Qed.
End Deriving_PER_WF.

Section Deriving_ER_WF.
  Context {T U} inj
    `{! Eqv T ,! Eqv U ,! ER_WF U
     ,! InjectionRespect T U inj eqv eqv
     }.

  Definition Deriving_ER_WF : ER_WF T.
  Proof.
    repeat constructor.
    - unfold Reflexive ; intros.
      apply InjectionRespect_beta ; reflexivity.
    - unfold Symmetric ; intros.
      apply InjectionRespect_beta ; apply InjectionRespect_eta in H ; symmetry ; auto.
    - unfold Transitive ; intros x y z H1 H2.
      apply InjectionRespect_beta.
      apply InjectionRespect_eta in H1 ; apply InjectionRespect_eta in H2.
      transitivity (inj y) ; auto.
  Qed.
End Deriving_ER_WF.

Section Deriving_Lte_RDC.
  Context {T U} inj
    `{! Lte T ,! LteDec T ,! Lte U ,! LteDec U ,! Lte_RDC U
     ,! InjectionRespect T U inj lte lte
     }
    `(! lte_dec = (lte_dec `on` inj) ).

  Definition Deriving_Lte_RDC : Lte_RDC T.
  Proof.
    repeat constructor ; intros.
    - rewrite H ; simpl.
      apply InjectionRespect_eta in H0.
      apply rel_correct in H0 ; auto.
    - rewrite H in H0 ; simpl in H0.
      apply InjectionRespect_beta.
      apply dec_correct ; auto.
  Qed.
End Deriving_Lte_RDC.

Section Deriving_PreOrd.
  Context {T U} inj
    `{! Lte T ,! Lte U ,! PreOrd U
     ,! InjectionRespect T U inj lte lte
     }.

  Definition Deriving_PreOrd : PreOrd T.
  Proof.
    constructor.
    - unfold Reflexive ; intros.
      apply InjectionRespect_beta.
      reflexivity.
    - unfold Transitive ; intros.
      apply InjectionRespect_beta.
      apply InjectionRespect_eta in H.
      apply InjectionRespect_eta in H0.
      transitivity (inj y) ; auto.
  Qed.
End Deriving_PreOrd.

Section Deriving_PartialOrd.
  Context {T U} inj
    `{! Lte T ,! Eqv T ,! ER_WF T ,! PreOrd T
     ,! Lte U ,! Eqv U ,! ER_WF U ,! PartialOrd U
     ,! InjectionRespect T U inj eqv eqv
     ,! InjectionRespect T U inj lte lte
     }.

  Definition Deriving_PartialOrd : PartialOrd T.
  Proof.
    constructor.
    - eauto with typeclass_instances.
    - unfold Antisymmetric ; intros.
      apply InjectionRespect_beta.
      apply InjectionRespect_eta in H.
      apply InjectionRespect_eta in H0.
      apply PartialOrd_Antisymmetry ; auto.
    - unfold Proper,"==>",impl,Basics.impl ; intros.
      apply InjectionRespect_beta.
      apply InjectionRespect_eta in H.
      apply InjectionRespect_eta in H0.
      apply InjectionRespect_eta in H1.
      eapply PartialOrd_respect_eqv.
      apply H.
      apply H0.
      apply H1.
  Qed.
End Deriving_PartialOrd.

Section Deriving_PartialOrd_RDC.
  Context {T U} inj
    `{! Lte T ,! Eqv T ,! ER_WF T ,! PartialOrd T ,! PartialOrdDec T
     ,! Lte U ,! Eqv U ,! ER_WF U ,! PartialOrd U ,! PartialOrdDec U ,! PartialOrd_RDC U
     ,! InjectionRespect T U inj eqv eqv
     ,! InjectionRespect T U inj lte lte
     }
    `(! pord_dec = (pord_dec `on` inj) ).

  Definition Deriving_PartialOrd_RDC : PartialOrd_RDC T.
  Proof.
    constructor ; intros ; try rewrite H ; try rewrite H in H0 ; simpl in *.
    - apply InjectionRespect_eta in H0.
      apply pord_rel_correct_eqv ; auto.
    - apply InjectionRespect_eta in H0.
      apply pord_rel_correct_lt ; auto.
    - apply InjectionRespect_eta in H0.
      apply pord_rel_correct_gt ; auto.
    - apply InjectionRespect_eta in H0.
      apply pord_rel_correct_un ; auto.
    - apply InjectionRespect_beta.
      apply pord_dec_correct_eqv ; auto.
    - apply InjectionRespect_beta.
      apply pord_dec_correct_lt ; auto.
    - apply InjectionRespect_beta.
      apply pord_dec_correct_gt ; auto.
    - apply InjectionRespect_beta.
      apply pord_dec_correct_un ; auto.
  Qed.
End Deriving_PartialOrd_RDC.

Section Deriving_TotalOrd.
  Context {T U} (inj:T->U)
   `{! Lte T ,! Eqv T ,! ER_WF T ,! PartialOrd T
    ,! Lte U ,! Eqv U ,! ER_WF U ,! TotalOrd U
    ,! InjectionRespect T U inj lte lte
    }.
  Definition Deriving_TotalOrd : TotalOrd T.
  Proof.
    constructor ; eauto with typeclass_instances.
    intros.
    unfold "~" at 1 ; intros pun ; destruct pun.
    apply (TotalOrd_comparable (inj x) (inj y)) ; constructor
    ; unfold "~" ; intros H1 ; apply InjectionRespect_beta in H1 ; contradiction.
  Qed.
End Deriving_TotalOrd.

Section Deriving_TotalOrd_RDC.
  Context {T U} inj
    `{! Lte T ,! Eqv T ,! ER_WF T ,! TotalOrd T ,! TotalOrdDec T
     ,! Lte U ,! Eqv U ,! ER_WF U ,! TotalOrd U ,! TotalOrdDec U ,! TotalOrd_RDC U
     ,! InjectionRespect T U inj eqv eqv
     ,! InjectionRespect T U inj lte lte
     }
    `(! tord_dec = (tord_dec `on` inj) ).

  Definition Deriving_TotalOrd_RDC : TotalOrd_RDC T.
  Proof.
    constructor ; intros ; try rewrite H ; try rewrite H in H0 ; simpl in *.
    - apply InjectionRespect_eta in H0.
      apply tord_rel_correct_eqv ; auto.
    - apply InjectionRespect_eta in H0.
      apply tord_rel_correct_lt ; auto.
    - apply InjectionRespect_eta in H0.
      apply tord_rel_correct_gt ; auto.
    - apply InjectionRespect_beta.
      apply tord_dec_correct_eqv ; auto.
    - apply InjectionRespect_beta.
      apply tord_dec_correct_lt ; auto.
    - apply InjectionRespect_beta.
      apply tord_dec_correct_gt ; auto.
  Qed.
End Deriving_TotalOrd_RDC.

Section Deriving_LatticeWF.
  Context {T U} inj
    `{! Eqv T ,! Lte T ,! ER_WF T ,! PartialOrd T ,! Lattice T
     ,! Eqv U ,! Lte U ,! ER_WF U ,! PartialOrd U ,! Lattice U ,! LatticeWF U
     ,! InjectionRespect T U inj lte lte
     ,! InjectionDistribute T U inj lmeet lmeet eqv
     ,! InjectionDistribute T U inj ljoin ljoin eqv
     }.

  Definition Deriving_LatticeWF : LatticeWF T.
  Proof.
    constructor ; intros ; constructor
    ; apply InjectionRespect_beta ; rewrite InjectionDistribute_law.
    - apply lmeet_ineq.
    - apply lmeet_ineq.
    - apply ljoin_ineq.
    - apply ljoin_ineq.
  Qed.
End Deriving_LatticeWF.

Section Deriving_BoundedLatticeWF.
  Context {T U} to from
    `{! Lte T ,! Eqv T ,! ER_WF T ,! PartialOrd T ,! Lattice T ,! BoundedLattice T
     ,! Lte U ,! Eqv U ,! ER_WF U ,! PartialOrd U ,! Lattice U ,! BoundedLattice U ,! BoundedLatticeWF U
     ,! InjectionRespect T U to eqv eqv
     ,! InjectionRespect T U to lte lte
     ,! InjectionRespect U T from lte lte
     ,! InjectionInverse U T from to eqv
     }
    `(! ltop = from ltop
     ,! lbot = from lbot
     ).

  Definition Deriving_BoundedLatticeWF : BoundedLatticeWF T.
  Proof.
    constructor ; intros.
    - rewrite H.
      apply InjectionRespect_beta.
      rewrite  InjectionInverse_inv ; logical_eqv.
      apply ltop_ineq.
    - rewrite H0.
      apply InjectionRespect_beta.
      rewrite InjectionInverse_inv ; logical_eqv.
      apply lbot_ineq.
  Qed.
End Deriving_BoundedLatticeWF.


Require Import Program.
From KapCake Require Import finmap_ext.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Local Open Scope fset.
Local Open Scope fmap.

Section SN.
(* Types for nodes and sites *)
Variables (S N : choiceType).

(* Contact graphs *)
Record cg : Type :=
  CG { siteMap : {fmap S -> N}
     ; edges : rel S
     ; edges_sym : symmetric edges
     (* wildcards *)
     ; wildcards : {fset S}
     ; w_in_sites : wildcards `<=` domf siteMap
    }.

Definition empty : cg := @CG fmap0 _ (@rel0_sym S) fset0 (fsub0set _).

Section CG.
Variable (g : cg).
Definition nodes : {fset N} := codomf (siteMap g).
Definition sites : {fset S} := domf (siteMap g).
Definition sites_of (n : N) : {fset sites} :=
  preimage_of (siteMap g) n.
Definition is_free (s : S) : bool :=
  [forall t : sites, edges g s (val t) == false].
Coercion sites_to_val (s : sites) : S := val s.

Definition add_sites (m : {fmap S -> N}) : cg :=
  @CG (siteMap g + m) (edges g) (edges_sym g)
    (wildcards g) (fsubset_cat _ (w_in_sites g)).

Definition add_site (n : N) (s : S) : cg :=
  add_sites [fmap].[s <- n].

Definition add_node (n : N) (ss : {fset S}) : cg :=
  add_sites [fmap _ : ss => n].

Program Definition remove_sites (ss : {fset S}) : cg :=
  @CG (siteMap g).[\ ss] (edges g) (edges_sym g)
    (wildcards g `\` ss) _.
Next Obligation.
  apply/fsubsetP => s /fsetDP [sIw sNIss]. rewrite !inE sNIss.
  by move: (fsubsetP (w_in_sites g) _ sIw) => ->.
Qed.

Definition remove_site (s : S) : cg :=
  remove_sites [fset s].

Definition remove_node (n : N) : cg :=
  remove_sites [fsetval s in sites_of n].

Program Definition add_edge (s t : S) : cg :=
  @CG (siteMap g)
    (fun x y => ((x, y) =sym= (s, t)) || (edges g x y)) _
    (wildcards g) (w_in_sites g).
Next Obligation.
  move=> x y. by rewrite /sym_eq [_ && _ || _]orbC (edges_sym g x y).
Qed.

Program Definition remove_edge (s t : S) : cg :=
  @CG (siteMap g)
    (fun x y => if (x, y) =sym= (s, t) then false else edges g x y) _
    (wildcards g) (w_in_sites g).
Next Obligation.
  move=> x y. by rewrite /sym_eq [_ && _ || _]orbC (edges_sym g x y).
Qed.

End CG.
End SN.

(* Lemmas for contact graphs.
 * add_nodeN: add_node and nodes.
 * add_nodeS: add_node and sites.
 * add_nodeE: add_node and edges.
 * remove_nodeN: add_node and nodes.
 * remove_nodeS: add_node and sites.
 * remove_nodeE: add_node and edges.
 *)
(* Module Lemmata. *)
Section CG_SN.
Variables (S N : choiceType) (g : cg S N).
Implicit Types (n : N) (ss : {fset S}).

Lemma in_sites_of n (s : sites g) :
  siteMap g s == n <-> s \in sites_of g n.
Proof using Type.
  split. move=> /eqP <-.
  by rewrite !inE eqxx.
  by rewrite !inE.
Qed.

Lemma add_nodeN n ss :
  ss != fset0 ->
  nodes (add_node g n ss) = n |` nodes (remove_sites g ss).
Proof using Type.
  move=> H. by rewrite /nodes codomf_cat codomf_const.
Qed.

Lemma add_nodeN0 n ss :
  ss == fset0 ->
  nodes (add_node g n ss) = nodes g.
Proof using Type.
  move=> /eqP ->. rewrite /add_node /add_sites /nodes /=.
  by rewrite (@fmap_nil S N [fmap _ : fset0 => n]) // catf0.
Qed.

Lemma add_nodeS n ss :
  sites (add_node g n ss) = sites g `|` ss.
Proof using Type. by rewrite /sites /= fsetUDr fsetDv fsetD0. Qed.

Lemma add_nodeE n ss :
  edges (add_node g n ss) = edges g.
Proof using Type. done. Qed.

Lemma add_sitesN (f : {fmap S -> N}) :
  nodes (add_sites g f) =
    codomf f `|` nodes (remove_sites g (domf f)).
Proof using Type.
  by rewrite /add_sites /remove_sites /nodes /= codomf_cat.
Qed.

Lemma add_sitesS (f : {fmap S -> N}) :
  sites (add_sites g f) = sites g `|` domf f.
Proof using Type. by rewrite /sites /= fsetUDr fsetDv fsetD0. Qed.

Lemma add_sitesE n (f : {fmap S -> N}) :
  edges (add_sites g f) = edges g.
Proof using Type. done. Qed.

Lemma remove_sitesN ss :
  nodes (remove_sites g ss) =
    nodes g `\` [fset n in nodes g | val @` sites_of g n `<=` ss].
Proof using Type.
  rewrite /remove_sites /nodes /= codomf_rem -fsetD_negb.
  symmetry. apply/fsetP => n. apply/imfsetP. case: ifP.
  rewrite (in_codomf_fset _ (fun s => s \notin ss)).
  move=> /existsP[s /andP[H1 H2]].
  (* move/(in_codomf_fset _ (fun s => s \notin ss) _) => [s [H1 H2]]. *)
  exists n => //. rewrite !inE. apply/andP. split.
  apply/existsP. by exists s.
  apply/negP. move/val_fsubset_in => H.
  move: (H s (iffLR (in_sites_of n s) H1)). exact/negP.
  (* second part *)
  move=> /negbT H /= [n' H1 H2].
  (* move: H1. rewrite !inE -H2 => /andP[/existsP[s sSOn'] H3]. *)
  move: H1. rewrite !inE -H2 => /andP[_ H3].
  apply/negP: H. rewrite negbK.
  move: H3. move/val_fsubset_notin => [t [H4 H5]].
  rewrite (in_codomf_fset _ (fun s => s \notin ss)).
  move: (iffRL (in_sites_of n t) H4) => H6.
  apply/existsP. exists t. by apply/andP.
Qed.

Lemma remove_sitesS ss :
  sites (remove_sites g ss) = sites g `\` ss.
Proof using Type.
  apply/fsetP => s.
  rewrite in_fsep /sites /= in_fsetD.
  by rewrite andbC -andbA andbb.
  (* rewrite in_fsep /sites /=. *)
  (* by apply/(andPP idP (fsetDP _ _ _))/fsetDP *)
  (* => [[_ [H sNIss]] | [H sNIss]]; split. *)
Qed.

Lemma remove_sitesE ss :
  edges (remove_sites g ss) = edges g.
Proof using Type. done. Qed.

Lemma remove_nodeN n :
  nodes (remove_node g n) = nodes g `\ n.
Proof using Type.
  rewrite /remove_node /nodes.
  rewrite codomf_rem.
  apply/fsetP => x. apply/imfsetP.
  case: ifP => /=.
  (* use x to get the a site of x: *)
  (* if x is in codomf (siteMap g) then there must be a site *)
  (* mapping to it in domf (siteMap g). *)
  rewrite in_fsetD1 mem_codomf => /andP[xNEn /existsP[s Hs]].
  exists s; last first.
    by rewrite (eqP Hs).
  rewrite !inE. apply/negP. rewrite (eqP Hs).
  by apply/negP: xNEn.
  (* second part *)
  (* x \notin codomf (siteMap g) `\ n -> *)
  (* there's no site y of x that's a site of n. *)
  rewrite !inE /=.
  move=> /negbT xNIcod [s sNSOn] sSOx.
  rewrite !inE /= in sNSOn.
  apply/negP: xNIcod. rewrite negbK. apply/andP. split; last first.
  apply/existsP. exists s. by rewrite sSOx.
  rewrite sSOx. apply: sNSOn.
Qed.

Lemma remove_nodeS n :
  sites (remove_node g n) =
    sites g `\` [fset val s | s in sites_of g n].
Proof using Type.
  apply/fsetP => s.
  by rewrite !inE andbCA andbb.
  (* alternative proof *)
  (* apply/fsetP => s. rewrite !inE. *)
  (* case: (s \in sites g) => // /=. *)
  (* by rewrite andbF. *)
Qed.

Lemma remove_nodeE n :
  edges (remove_node g n) = edges g.
Proof using Type. done. Qed.

Lemma add_edgeN (s t : S) :
  nodes (add_edge g s t) = nodes g.
Proof using Type. done. Qed.

Lemma add_edgeS (s t : S) :
  sites (add_edge g s t) = sites g.
Proof using Type. done. Qed.

Lemma add_edgeE (s t : S) :
  edges (add_edge g s t) =
    (fun x y => ((x, y) =sym= (s, t)) || edges g x y).
Proof using Type. done. Qed.

Lemma remove_edgeN (s t : S) :
  nodes (remove_edge g s t) = nodes g.
Proof using Type. done. Qed.

Lemma remove_edgeS (s t : S) :
  sites (remove_edge g s t) = sites g.
Proof using Type. done. Qed.

Lemma remove_edgeE (s t : S) :
  edges (remove_edge g s t) =
    (fun x y => if (x, y) =sym= (s, t)
                then false else edges g x y).
Proof using Type. done. Qed.

End CG_SN.
(* End Lemmata. *)

Section Realisable.
Variables (S N : choiceType) (g : cg S N).

Definition is_realisable : bool :=
  (* no self loop *)
  [forall s : sites g, ~~(edges g s s)] &&
  (* at most 1 incident edge per site *)
  [forall s : sites g, forall t : sites g, forall t' : sites g,
      edges g s t && edges g s t' ==> (t == t')].
  (* [&& (* no self loop *) *)
  (*     [forall s : sites g, ~~(edges g s s)], *)
  (*     (* at most 1 incident edge per site *) *)
  (*     [forall s : sites g, forall t : sites g, forall t' : sites g, *)
  (*         edges g s t && edges g s t' ==> (t == t')] *)
  (*     (* wildcard sites aren't bound *) *)
  (*   & [forall s : sites g, (val s \in wildcards g) ==> *)
  (*         [forall t : sites g, ~~(edges g s t)]]]. *)

Definition IsRealisable : Prop :=
  (forall s : sites g, ~~(edges g s s)) /\
  (forall s t t' : sites g,
      edges g s t && edges g s t' -> t = t').
  (* [/\ (forall s : sites g, ~~(edges g s s)), *)
  (*     (forall s t t' : sites g, *)
  (*         edges g s t && edges g s t' -> t = t') *)
  (*   & (forall s : sites g, val s \in wildcards g -> *)
  (*         (forall t : sites g, ~~(edges g s t)))]. *)

Lemma realP : reflect IsRealisable is_realisable.
Proof using Type.
  exact: (andPP forallP
            'forall_'forall_'forall_(implyPP idP eqP)).
  (* exact: (and3PP forallP *)
  (*           'forall_'forall_'forall_(implyPP idP eqP) *)
  (*           'forall_(implyPP idP forallP)). *)
Qed.

End Realisable.

(* Notations *)
Module SGNotations.

Declare Custom Entry siteMapping.
Notation "[ T | s1 , .. , sn |]" :=
  (let e := empty [choiceType of T] [choiceType of T]
   in (add_site .. (add_site e s1.2 s1.1) .. sn.2 sn.1))
    (at level 0, s1 custom siteMapping, sn custom siteMapping).
Notation "s -> u" := (s, u) (in custom siteMapping at level 2,
                           s constr at level 1, u constr at level 1).

Declare Custom Entry edge.
Notation "[ T | s1 , .. , sn | e1 , .. , en |]" :=
  (let e := empty [choiceType of T] [choiceType of T] in
   let g := (add_site .. (add_site e s1.2 s1.1) .. sn.2 sn.1)
   in (add_edge .. (add_edge g e1.1 e1.2) .. en.1 en.2))
    (at level 0, s1 custom siteMapping, sn custom siteMapping,
      e1 custom edge, en custom edge).
Notation "s1 -- s2" := (s1, s2) (in custom edge at level 2,
                             s1 constr at level 1,
                             s2 constr at level 1).
End SGNotations.
Import SGNotations.

(* Examples of the above notations. *)
Definition g1 := [nat| 0 -> 0, 1 -> 1 |].
Definition g2 := [nat| 0 -> 0, 1 -> 1 | 0 -- 1 |].

(* Print g1. Print g2. *)
(* Goal is_realisable g1 == true. *)
(*   by rewrite /is_realisable !forall_true. *)
(* Qed. *)


From Undecidability.L.Tactics Require Import LTactics.
From Undecidability.L.Datatypes Require Import Lists LTerm.

From Undecidability.L Require Import Functions.Decoding.

From Undecidability.L Require Export LinDecode.LTD_def.

Global Instance linDec_list X `{_:linTimeDecodable X}: linTimeDecodable (list X).
Proof.
  evar (c:nat). exists c.
  unfold decode,decode_list,list_decode;cbn.
  extract.
  recRel_prettify2;cbn[size];ring_simplify.
  [c]:exact (max (c__linDec X) 12).
  all:unfold c;try nia.
Qed.


Require Import Notations.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section Graph.
  Record Graph (v : Type) := {
    Vertex :> _ := v;
    Edge' : v -> v -> Type
  }.
End Graph.

Bind Scope graph_scope with Graph.
Bind Scope vertex_scope with Vertex.
Bind Scope edge_scope with Edge'.

Arguments Vertex {v%type} G%graph : rename.

Section GraphInterface.
  Context `(G : @Graph v).

  Definition Edge : forall s d : G, _ := Eval cbv beta delta [Edge'] in G.(Edge').
End GraphInterface.

Bind Scope edge_scope with Edge.

Arguments Vertex {v%type} G : rename, simpl never.
Arguments Edge {v%type} G s d : rename, simpl nomatch.