Require Import
  HoTT.Basics.Equivalences
  HoTT.Types.Bool
  HoTT.Types.Forall
  HoTT.Types.Sigma
  HoTT.Types.Prod
  HoTTClasses.theory.ua_homomorphism.

Import algebra_notations ne_list.notations.

(** The following section defines product algebra [ProdAlgebra].
    Section [bin_prod_algebra] specialises the definition to
    binary product algebra. *)

Section prod_algebra.
  Context `{Funext} {σ : Signature} (I : Type) (A : I → Algebra σ).

  Definition carriers_prod_algebra : Carriers σ
    := λ (s : Sort σ), ∀ (i:I), A i s.

  Fixpoint op_prod_algebra (w : SymbolType σ)
      : (∀ i, Operation (A i) w) →
        Operation carriers_prod_algebra w :=
    match w return (∀ i, Operation (A i) w) →
                    Operation carriers_prod_algebra w
    with
    | [:_:] => idmap
    | _ ::: g => λ f p, op_prod_algebra g (λ i, f i (p i))
    end.

  Definition ops_prod_algebra (u : Symbol σ)
    : Operation carriers_prod_algebra (σ u)
    := op_prod_algebra (σ u) (λ (i:I), u ^^ A i).

  Definition ProdAlgebra : Algebra σ
    := BuildAlgebra carriers_prod_algebra ops_prod_algebra.

  Global Instance trunc_prod_algebra {n : trunc_index}
    `{!∀ i, IsTruncAlgebra n (A i)}
    : IsTruncAlgebra n ProdAlgebra.
  Proof.
    intro s. exact _.
  Qed.
End prod_algebra.

(** The next section defines the product projection homomorphisms. *)

Section hom_proj_prod_algebra.
  Context `{Funext} {σ : Signature} (I : Type) (A : I → Algebra σ).

  Definition def_proj_prod_algebra (i:I) (s : Sort σ) (c : ProdAlgebra I A s)
    : A i s
    := c i.

  Lemma oppreserving_proj_prod_algebra {w : SymbolType σ}
    (i : I) (v : ∀ i : I, Operation (A i) w) (α : Operation (A i) w)
    (P : v i = α)
    : OpPreserving (def_proj_prod_algebra i)
        (op_prod_algebra I A w v) α.
  Proof.
    induction w.
    - exact P.
    - intro p. apply (IHw (λ i, v i (p i)) (α (p i))). f_ap.
  Defined.

  Global Instance is_homomorphism_proj_prod_algebra (i:I)
    : IsHomomorphism (def_proj_prod_algebra i).
  Proof.
    intro u.
    by apply oppreserving_proj_prod_algebra.
  Defined.

  Definition hom_proj_prod_algebra (i : I)
    : Homomorphism (ProdAlgebra I A) (A i)
    := BuildHomomorphism (def_proj_prod_algebra i).

End hom_proj_prod_algebra.

(** The product algebra univarsal mapping property [ump_prod_algebra]. *)

Section ump_prod_algebra.
  Context
    `{Funext}
    {σ : Signature}
    (I : Type)
    (A : I → Algebra σ)
    (C : Algebra σ).

  Definition hom_prod_algebra_mapout
    (f : Homomorphism C (ProdAlgebra I A)) (i:I)
    : Homomorphism C (A i)
    := hom_compose (hom_proj_prod_algebra I A i) f.

  Definition def_prod_algebra_mapin (f : ∀ (i:I) s, C s → A i s)
    : ∀ (s : Sort σ) , C s → ProdAlgebra I A s
    := λ (s : Sort σ) (x : C s) (i : I), f i s x.

  Lemma oppreserving_prod_algebra_mapin {w : SymbolType σ}
    (f : ∀ (i:I) s, C s → A i s)
    (α : ∀ (i:I), Operation (A i) w) (β : Operation C w)
    (P : ∀ (i:I), OpPreserving (f i) β (α i))
    : OpPreserving (def_prod_algebra_mapin f) β
        (op_prod_algebra I A w (λ i, α i)).
  Proof.
    induction w.
    - funext i. apply P.
    - intro x. apply IHw. intro i. apply P.
  Defined.

  Global Instance is_homomorphism_prod_algebra_mapin
    (f : ∀ (i:I), Homomorphism C (A i))
    : IsHomomorphism (def_prod_algebra_mapin f).
  Proof.
    intro u.
    apply oppreserving_prod_algebra_mapin.
    intro i.
    apply f.
  Defined.

  Definition hom_prod_algebra_mapin (f : ∀ i, Homomorphism C (A i))
    : Homomorphism C (ProdAlgebra I A)
    := BuildHomomorphism (def_prod_algebra_mapin f).

  (** Given a family of homomorphisms [h : ∀ (i:I), Homomorphism C (A i)]
      there is a unique homomorphism [f : Homomorphism C (ProdAlgebra I A)]
      such that [h i = hom_compose (pr i) f], where

      <<
        pr i = hom_proj_prod_algebra I A i
      >>

      is the ith projection homomorphism. *)

 Lemma ump_prod_algebra `{!∀ i, IsHSetAlgebra (A i)}
   : (∀ (i:I), Homomorphism C (A i)) <~> Homomorphism C (ProdAlgebra I A).
  Proof.
    apply (equiv_adjointify hom_prod_algebra_mapin hom_prod_algebra_mapout).
    - intro f. by apply path_hset_homomorphism.
    - intro f. funext i. by apply path_hset_homomorphism.
  Defined.
End ump_prod_algebra.

(** Binary product algebra. *)

Section bin_prod_algebra.
  Context `{Funext} {σ : Signature} (A B : Algebra σ).

  Definition bin_prod_algebras (b:Bool) : Algebra σ
    := if b then B else A.

  Global Instance trunc_bin_prod_algebras {n : trunc_index}
    `{!IsTruncAlgebra n A} `{!IsTruncAlgebra n B}
    : ∀ (b:Bool), IsTruncAlgebra n (bin_prod_algebras b).
  Proof.
    intros []; exact _.
  Qed.

  Definition BinProdAlgebra : Algebra σ :=
    ProdAlgebra Bool bin_prod_algebras.

  Definition fst_prod_algebra : Homomorphism BinProdAlgebra A
    := hom_proj_prod_algebra Bool bin_prod_algebras false.

  Definition snd_prod_algebra : Homomorphism BinProdAlgebra B
    := hom_proj_prod_algebra Bool bin_prod_algebras true.
End bin_prod_algebra.

Module prod_algebra_notations.

  Global Notation "A × B" := (BinProdAlgebra A B)
                             (at level 40, left associativity)
                             : Algebra_scope.

End prod_algebra_notations.

Import prod_algebra_notations.

(** Specialisation of the product algebra univarsal mapping property
    to binary product. *)

Section ump_bin_prod_algebra.
  Context
    `{Funext}
    {σ : Signature}
    (A B C : Algebra σ)
    `{!IsHSetAlgebra A} `{!IsHSetAlgebra B}.

 Lemma ump_bin_prod_algebra
   : Homomorphism C A * Homomorphism C B <~> Homomorphism C (A × B).
  Proof.
    set (k := λ (b:Bool), Homomorphism C (bin_prod_algebras A B b)).
    exact (equiv_compose
            (ump_prod_algebra Bool (bin_prod_algebras A B) C)
            (equiv_bool_forall_prod k)^-1).
  Defined.
End ump_bin_prod_algebra.


Require Import Coq.Arith.Arith.
Require Import RGref.DSL.DSL.

(** * A "Postpend"-only Linked List
    We side-step the induction-induction issues we hit in the prepend-only
    example by doing append-only via set-once options.  This makes it
    much easier to prove things about manipulating the list.  The downside
    is that we can't prevent cycles - doing so would need to talk about
    reachability through cons cells in the definition of the list type,
    forcing induction-recursion again.
*)

Section AppendOnlyLinkedList.

Require Import Coq.Program.Equality.

Inductive appList : Set :=
  | rcons : nat -> ref{option appList|any}[optset appList,optset appList] -> appList.

Definition alist := ref{option appList|any}[optset appList, optset appList].

(** A remarkable number of the generated proof goals can be solved by
    firstorder reasoning or basic proof search. *)
Obligation Tactic :=
  try solve[firstorder]; try constructor; eauto; compute; auto.

Require Import Coq.Program.Tactics.

Global Instance appList_fold : rel_fold appList :=
  { rgfold := fun R G => appList ; (* TODO: This is technically unsound - need to recursively rewrite tail pointer relations... *)
    fold := fun R G x => x
  }.

Global Instance appList_contains : Containment appList. Admitted.
 (* want something like { contains := fun RR => RR = (optset ...) }. but need to handle cons/option shifting *)

Print ImmediateReachability.
Inductive applist_reachability : forall (T:Set) (P:hpred T) (R G:hrel T), ref{T|P}[R,G] -> appList -> Prop :=
  | tail_reach : forall n tl, applist_reachability (option appList) any (optset appList) (optset appList) tl (rcons n tl).
Global Instance applist_reachable : ImmediateReachability appList :=
  { imm_reachable_from_in := applist_reachability }.

Program Definition alist_append {Γ}(n:nat)(l:alist) : rgref Γ unit Γ :=
  (RGFix _ _ (fun (rec:alist->rgref Γ unit Γ) =>
             (fun tl => match !tl as y return (!tl = y -> _) with
                          | None => fun _ => ( f <- Alloc None;
                                      [ tl ]:= (Some (rcons n f))
                                    )
                          | Some l' => fun _ => (match l' with
                                          | rcons n' tl' => rec tl'
                                        end)
                        end _))) l.
Next Obligation.
  erewrite deref_conversion in *. rewrite H. constructor.
  Grab Existential Variables. eauto. eauto. eauto. eauto.
Qed.

Program Example test1 {Γ} : rgref Γ unit Γ :=
  l <- Alloc None;
  u <- alist_append 3 l;
  v <- alist_append 4 l;
  alist_append 5 l.

End AppendOnlyLinkedList.


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

Require Import List.

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

(**  * Embedding functor for exponentials.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


From Coq Require Import ssreflect ssrfun ssrbool.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Require Import Coq.Program.Equality.

Require Import Arith_base.
Require Import Vectors.Fin.
Require Import Vectors.VectorDef.
Require Import Bool.

Class Lex (A : Set) (FCross : A -> A -> A) (CP : A -> A -> Prop) : Prop := {
    transformable : forall (x : A), {P | ~ CP x (P x)};
    anti_identity : forall (x y : A), ~ CP x y -> ~ CP x (FCross x y);
    convergent_equality : forall (x y : A), x = y -> CP x y;
    crossover_identity : forall (y : A), {x | ~ (CP x y) -> CP (FCross x y) y}
}.

Class Agent {A : Set} {f : A -> A -> A} {f'} (H : Lex f f') (T : Set) := {
 memory : T -> A
}.

Section Env.
Variables X B A : Set.
Variable f : X -> X -> X.
Variable f' : X -> X -> bool.
Variable K : Lex f f'.
Variable H : Set -> Set.
Variable C : H A -> B -> Prop.
Variable point : forall x y , C x y -> A.
Variable Perception : forall {x y : B} (k : H A), C k x -> C k y -> Prop.
Variable Action : forall {x y : B} (k : H A) (x' : C k x) (y' : C k y), H A -> Prop.
Variable AG : Agent K A.

Record Functions : Type := F' {
   faction : H A -> H A;
   flang : H A -> H A
}.

Record Interation x y k (P : Functions) : Prop := I' {
    consistency_action : forall (x' : C ((flang P) k) x) (y' : C ((flang P) k) y) (H' : Perception x' y'),
                Action x' y' ((faction P) ((flang P)k));

    knowlegde : forall (x' : C k x) (y' : C k y) (a : C ((flang P) k) x)  (H' : Perception x' y'),
         memory (point a)  = (f (memory (point x')) (memory ((point y'))))

}.

Class Environment (k : H A) (H' : Functions) : Prop := {
  inhabited : forall (x : H A), {b | C x b};
  active : forall (k : H A), {y : (B * B) | {c : (C k (fst y) * C k (snd y)) | Perception (fst c) (snd c)}};
  iterate : forall {x y : B}  (x' : C k x) (y' : C k y), Interation x y k H';

}.

Notation "f ∘ g" := (fun x => f (g x)) (at level 80, right associativity).

Class State {f' g'} {k} := {
  inductive_environment :
    Environment k (F' f' g') /\ (forall k (x :  Environment k (F' f' g')), Environment ((g' ∘ f') k) (F' f' g'));
}.

End Env.

Inductive binary := |zero : binary |one : binary.

Inductive lex n :=
|lex' : t binary (S n) -> lex n.

Fixpoint invert_binary {y} (x : t binary y) : t binary y.
induction x.
refine (nil _).
destruct h.
refine (cons _ one _ (invert_binary _ x)).
refine (cons _ zero _ (invert_binary _ x)).
Defined.

Theorem _not_conservation:
  forall n (x : lex n), {P : forall {n} {h : lex n}, lex n | x <> P n x}.
move => x'.
pose (fun y (x : lex y) =>
  match x with
    |@lex' _ v  => @lex' y (invert_binary v)
  end).
intros; exists l.
destruct x; simpl; injection; intros.
clear H.
move : H0.
elim/@caseS' : t.
intros.
destruct h.
inversion H0.
inversion H0.
Qed.

Export VectorNotations.

Definition case1 {A} (P : t A 1 -> Type)
  (H : forall h, @P [h]) (v: t A 1) : P v :=
match v with
  |h :: t => match t with
    |nil _ => H h
  end
  |_ => fun devil => False_ind (@IDProp) devil
end.

Definition case_2nat (P : nat -> nat -> Type)
  (H : P 0 0) (H' : forall y, P 0 (S y)) (H1 : forall x, P (S x) 0)
     (H2 : forall x y, P (S x) (S y))
   : forall x y, P x y.
move => x y.
destruct x.
destruct y.
exact H.
refine (H' y).
destruct y.
refine (H1 x).
refine (H2 x y).
Defined.

Definition case_2t {A} (P : forall n, t A (S n) -> t A (S n) -> Type)
    (H' : forall n a b (t t' : t A n), P _ (a :: t) (b :: t'))
   : forall n (x y : t A (S n)), P _ x y.
move => n x.
refine (match x in (t _ (S n)) return (forall (y : (t A (S n))), P n x y) with
  |@cons _ k q c => _
 end).
elim/@caseS'.
intros.
refine (H' _ k h _ _).
Defined.

Definition rect_SS' {A} (P : forall n, t A (S n) -> Type)
  (H : forall n h a (t : t A (S n)), P _ t -> P _ (a :: h :: t)) (H' : forall h, @P 0 [h]) (H1' : forall h v, @P 1 [h; v]) : forall n (x : t A (S n)), P _ x.

  refine (fix fix_S n (v : t A (S n)) {struct v} : P n v := _).
  refine (match v as c in (t _ (S n)) return P n c with
  |cons _ h 0 v' => match v' with
      |@nil _ => _
    end
  | cons _ h 1 v1 => _
  | cons _ a (S (S n')) v' => _
  | _ => fun devil => False_rect (@IDProp) devil
  end).

intros.
refine (H' h).
intros.
refine (match v1 with
  |@cons _ k 0 q => match q in (t _ 0) with
    |@nil _ => _
  end
 end).

refine (H1' h k).
refine (match v' as c in (t _ (S (S n'))) return P (S (S n')) (a :: c) with
  |@cons _ k n q => _
 end).

destruct n.
exact idProp.
refine (H _ k a _ (fix_S _ q)).

Defined.

Definition rect_2S {A B} (P:forall {n}, t A (S n) -> t B (S n) -> Type)
  (bas : forall x y, P [x] [y]) (rect : forall {n} (v1 : t A (S n)) (v2 : t B (S n)), P v1 v2 ->
    forall a b, P (a :: v1) (b :: v2)) :
     forall {n} (v1 : t A (S n)) (v2 : t B (S n)), P v1 v2.

  refine (fix rect2_fix {n} (v1 : t A (S n)) : forall v2 : t B (S n), P _ v1 v2 :=
  match v1 in t _ (S n) with
  | [] => idProp
  | @cons _ h1 (S n') t1 => fun v2 =>
    caseS' v2 (fun v2' => P _ (h1::t1) v2') (fun h2 t2 => rect _ _ _ (rect2_fix t1 t2) h1 h2)
  |cons _ a 0 x' => fun (v2 : t B 1) => _
 end).

elim/@case0 : x'.
refine (match v2 with
  |cons _ b 0 y' => match y' with
      |nil _ => _
      |_ => _
    end
  end).

elim/@case0 : y'.
refine (bas a b).
exact idProp.
Defined.

Fixpoint cross_binary_vector {n} (x : t binary (S n)) (y : t binary (S n)) : t binary (S n).
elim/@rect_2S  : x/y.
intros.
refine (cons _ y _ (nil _)).
intros.

refine (match (a, b) with
  |(one, one) => (cons _ a _ (cross_binary_vector _ v1 v2))
  |(zero, zero) => (cons _ a _ (cross_binary_vector _ v1 v2))
  |(x', y') => (cons _ b _ v1)
 end).

Defined.

Definition cross_lex {n} (x : lex n) (y : lex n) : lex n.
constructor.
destruct x.
destruct y.
refine (cross_binary_vector t t0).
Defined.

Definition b_rect (P : binary -> binary -> Type) (H : P one one) (H' : P zero zero) (H1' : P one zero) (H2' : P zero one) (x y : binary) : P x y.
intros.
destruct x.
destruct y.
move => //=.
move => //=.
destruct y.
move => //=.
move => //=.
Defined.

Theorem crossover_binary :
  forall   n
           (x : t binary (S n))
           (y : t binary (S n)),
           x <> y ->
           x <> cross_binary_vector x y.

  have : forall t t0, lex' t <> lex' t0 -> t <> t0.
  intros.
  cbv in H.
  cbv.
  move => h'.
    have : lex' t = lex' t0.
    congruence.
  tauto.

  have : forall n h x y, cons _ n h x <> cons _ n h y -> x <> y.
   intros.
   move => H'.
   congruence.
  move => H'.

  have : forall h n x y, x <> y -> cons _ n h x <> cons _ n h y.
   intros.
   move => H2'.
   pose (fun a n (x : t a (S n)) => match x in (t _ (S n)) with
     |@cons _ _ _ x => x
     end).
   pose (@f_equal (t T (S h)) (t T h) (@y0 _ _) _ _ H2').
   simpl in e.
   tauto.
 move => K.

intros.
move : H; elim/@rect_2S : y/x0.
intros; unfold cross_binary_vector; simpl in *.
auto.
intros; move : H0 H; elim/@b_rect : a/b.
intros.
unfold cross_binary_vector; simpl; fold @cross_binary_vector.
apply H' in H0; apply H in H0.
auto.
intros.
unfold cross_binary_vector; simpl; fold @cross_binary_vector.
apply H' in H0; apply H in H0;apply : K.
trivial.
intros.
unfold cross_binary_vector; simpl; fold @cross_binary_vector.
move => H2'.
inversion H2'.
intros.
unfold cross_binary_vector; simpl; fold @cross_binary_vector.
move => H2';inversion H2'.
Qed.

Definition eq_vector_binary : forall (n : nat), t binary (S n) -> t binary (S n) -> bool.
  pose (fun (x y : binary) => match (x, y) with
  |(one, one) => true
  |(zero, zero) => true
  |(x, y) => false
  end).

  refine (fix fix_S n (t t0 : t binary (S n)) {struct t} := _).
  elim/@rect_2S : t/t0.
  intros;refine (b x y).
  intros;refine ((b a b0) && (fix_S _ v1 v2)).
Defined.

Definition lex_binary : forall (n : nat), lex n -> lex n -> bool.
intros.
destruct H.
destruct H0.
refine (eq_vector_binary t t0).
Defined.

Theorem lex_eq : forall n (v y : lex n), lex_binary v y = true -> v = y.
intros.
destruct v. destruct y.
move : H.
elim/@rect_2S : t/t0.
move => x y.
elim/b_rect : x/y.
trivial.
trivial.
simpl in *; congruence.
simpl in *; congruence.
intros.
move : H0.
elim/b_rect : a/b.
 - intros; simpl in *; apply H in H0; congruence.
 - intros; simpl in *; apply H in H0; congruence.
 - intros; simpl in *; congruence.
 - intros; simpl in *; congruence.
Qed.

Definition lex_prop : forall (n : nat), lex n -> lex n -> Prop.
intros.
exact (lex_binary H H0 = true).
Defined.

Fixpoint imperfect_binary_cpy {n} (x : t binary (S n)) : t binary (S n).
elim/@rectS : x.
case.
exact (cons _ one _ (nil _)).
exact (cons _ zero _ (nil _)).
intros.
refine (cons _ a _ (imperfect_binary_cpy _ v)).
Defined.

Theorem unique_binary_object_convergent_complement {n} (y : t binary (S n)) :
   {x | x <> y -> cross_binary_vector x y = y}.
exists (imperfect_binary_cpy y).
move : y; elim/@rectS.
case => //=.
case => //= H' V hi h.
have : imperfect_binary_cpy V <> V.
congruence.
move => H.
have : cross_binary_vector (imperfect_binary_cpy V) V = V.
apply : hi H; move => H3.
congruence.
have : imperfect_binary_cpy V <> V.
congruence.
move => H.
have : cross_binary_vector (imperfect_binary_cpy V) V = V.
apply : hi H; move => H3.
congruence.
Qed.

Theorem neg_of_convergent_lex : forall n (x : lex n) y, x <> y -> lex_binary x y = false.

  have : forall x y, lex_binary x y = false -> ~ lex_binary x y = true.
  move => n0 x0 y0.
  destruct (lex_binary x0 y0).
  move => h2.
  inversion h2.
  move => H2 H3.
  inversion H3.

intros.
destruct x0.
destruct y.
move : H.
elim/@rect_2S : t/t0.
move => x0 y.
elim/@b_rect : x0/y.
intros.
destruct H.
auto.
intros.
destruct H.
auto.
auto.
intros.
done.
intros.
move : H H0.
pose (fun n (x : t binary (S n)) => match x in t _ (S n) with
  |a :: b => b
 end).
pose (fun n (x : t binary (S n)) => match x in t _ (S n) with
  |a :: b => a
 end).
  have : forall x v v', lex' (x :: v) <> lex' (x :: v') -> lex' v <> lex' v'.
  case => n1. elim/@caseS'.
  move => h n2; elim/@caseS'.
  move => h0; elim/@case0.
  elim/@case0 : n2.
  intros; move => H2.
  injection H2; move => n2; subst.
  by contradiction H.
  intros.
  move => H2'.
     have : v = v'.
     congruence.
  move => H3; rewrite H3 in H.
  by contradiction H.
move => H2'.
elim/@b_rect : a/b.
intros; simpl in *; apply H2' in H0.
tauto.
intros; apply H2' in H0; tauto.
intros; trivial.
intros; trivial.
Qed.

Theorem lex_binary_eqv : forall {n} (m : lex n), lex_binary m m = true.
  intros.
  destruct m.
  elim/@rectS : t.
  by destruct a.
  by elim.
Qed.

Theorem neg_of_convergent_lex' : forall n (x : lex n) y, lex_binary x y = false -> x <> y.

  have : forall x y, lex_binary x y = false -> ~ lex_binary x y = true.
  move => n0 x0 y0.
  destruct (lex_binary x0 y0).
  move => h2.
  inversion h2.
  move => H2 H3.
  inversion H3.

intros.
apply x in H.
move => H2.
destruct x0.
destruct y.
move : H2 H.
elim/@rect_2S : t/t0.
move => x0 y.
elim/@b_rect : x0/y.
auto.
auto.
intros; inversion H2.
intros; inversion H2.
move => n0 v1 v2 H a b.

pose (fun n (x : t binary (S n)) => match x in t _ (S n) with
  |a :: b => b
 end).

elim/@b_rect : a/b.
intros.
simpl in *.
  have : one :: v1 = one :: v2.
  congruence.
move => e'.
apply (@f_equal _ _ (@y (S n0))) in e'; simpl in e'.
  have : lex' v1 = lex' v2.
  congruence.
auto.
intros.
simpl in *.
  have : zero :: v1 = zero :: v2.
  congruence.
move => e'.
apply (@f_equal _ _ (@y (S n0))) in e'; simpl in e'.
  have : lex' v1 = lex' v2.
  congruence.
auto.
intros.
inversion H2.
intros.
inversion H2.
Qed.

Instance binary_lex : forall x, Lex (@cross_lex x) (@lex_prop x).
 {

  constructor.

  (* The proof of lex transform *)
  intros.
  pose (_not_conservation x0).
  destruct s.
  exists (x1 x).
  apply not_true_iff_false.
  apply (neg_of_convergent_lex).
  trivial.

  (*Anti-identity proof of crossover function *)
  intros.
  destruct x0.
  destruct y.
  unfold lex_prop in *.
  apply not_true_iff_false.

  apply not_true_is_false in H.
  apply neg_of_convergent_lex.
  apply neg_of_convergent_lex' in H.
  move => H2.
  unfold cross_lex in H2.
    have : t <> t0.
    congruence.
  move => H2'.
  pose (@crossover_binary _ _ _ H2').
  congruence.

  (*Convergence implies to definitional equality *)
  intros.
  unfold lex_prop.
  rewrite H.
  clear H x0.
  apply : lex_binary_eqv.

  (*Existence of Convergence aproximation from x to y*)
  intros.
  destruct y.
  destruct (unique_binary_object_convergent_complement t).
  exists (lex' x0).
  move => H'.
  unfold lex_prop in *.

  apply not_true_is_false  in H'.
    have : x0 <> t.
    set (neg_of_convergent_lex' H'); congruence.
  move => H.
  apply e in H.
  unfold cross_lex.
  rewrite H.
  apply : lex_binary_eqv.
}
Defined.

Inductive SAgent n :=
   T' : lex n -> SAgent n.

Definition agent_lex {n} (x : SAgent n) :=
  match x with
    |@T' _ l => l
 end.

Fixpoint len {a} {n} (x : t a n) :=
  match x with
    |_ :: y => (len y) + 1
    |[] => 0
  end.

(*The class Agent is just a proof that there is a depedent product of a lex
  and one construction and the depedent product carry a memory that map the construction
   with one lexical memory *)

Instance SAgent' : forall x, Agent (binary_lex x) (SAgent x). {
  constructor.
  refine (@agent_lex x).
}
Defined.

Require Import Coq.Init.Specif.

Definition get_agent {n} {l} (ls : t (SAgent n) l) (y : nat) (H : y < l) : SAgent n := nth_order ls H.

Definition boundness {n} {l} (ls : t (SAgent n) l) (y : nat) : Prop := y < l.

Definition view {l} {n} {y} {y'} (v : t (SAgent n) (S l)) (H : y < (S l)) (H' : y' < (S l)) :=
  (y =? 0) && (y' =? l) = true.

Definition match_lex {l} {n} (v : t (SAgent n) (S l)) : t (SAgent n) (S l).

  have : 0 < S l /\ l < S l.
  auto with arith.
move => h.
destruct h.
set f' := v[@of_nat_lt H].
set s' := v[@of_nat_lt H0].

refine (replace (replace v (of_nat_lt H0) (T' (cross_lex (memory s') (memory f'))))
  (of_nat_lt H) (T' (cross_lex (memory f') (memory s')))).
Defined.

Definition action_prop {l} {n} {y} {y'} (v : t (SAgent n) (S l)) (H : y < S l) (H' : y' < S l) : t (SAgent n) (S l) -> Prop.
move => v'.
refine (get_agent v H = get_agent v' H').
Defined.

Definition tail := (fun a n (v : t a (S n))  => match v in (t _ (S n)) with
   |@cons _ _ _ v' => v'
   |@nil _ => idProp
 end).

Theorem head_get : forall a n (x : t a (S n)) (H : 0 < (S n)), hd x = nth x (Fin.of_nat_lt H).
intros.
move : H.
by elim/@caseS : x.
Qed.

Theorem last_tail : forall a n (x : t a (S n)) (H : n < (S n)), last x = nth x (Fin.of_nat_lt H).
intros.
move : H.
elim/@rectS : x.
intros.
by simpl.
intros.
simpl in *.
generalize (lt_S_n n0 (S n0) H0).
move => t.
pose (H t).
trivial.
Qed.

Theorem shift_hd_get' : forall A n (x : t A (S n)) (H : n < (S n)) (a : A), (shiftin a x)[@FS (Fin.of_nat_lt H)] = a.
intros.
move : H.
elim/@rect_SS' : x.
intros.
simpl in *.
by set (H (lt_S_n n0 (S n0)
                       (lt_S_n (S n0)
                          (S (S n0)) H0))).
trivial.
intros.
simpl in *.
trivial.
Defined.

Theorem of_nat_lt_c : forall x y (v : x < y) (v' : x < y), of_nat_lt v = of_nat_lt v'.
move => x y.
elim/@nat_double_ind : x/y.
intros.
destruct n.
inversion v.
simpl in *; trivial.
intros;inversion v.
intros.
set (H (lt_S_n n m v) (lt_S_n n m v')); simpl in *; rewrite e.
reflexivity.
Qed.

Definition shift {l} {n} (v : t (SAgent n) (S l)) : t (SAgent n) (S l).
destruct l.
exact v.
destruct l.
refine (cons _ (hd (tail v)) _ (cons _ (hd v) _ (nil _))).
refine (shiftin (hd v) (tail v)).
Defined.

Theorem inj : forall n l (x y : t (SAgent n) (S l)), shift x = shift y -> x = y.
  have : forall a b v1 v2, shiftin a v1 = shiftin b v2 -> v1 = v2 /\ a = b.
  intros.
  move : H.
  elim/@rect2 : v1/v2.
  constructor; trivial.
  simpl in H; congruence.
  intros.
  simpl in *.
  pose (fun n (x : t T (S n)) => match x in (t _ (S n)) with
     |@cons _ _ _ y => y
   end).
  pose (fun n (x : t T (S n)) => match x in (t _ (S n)) with
     |@cons _ x _ _ => x
   end).
 set (f_equal (@y0 _) H0).
 set (f_equal (@y _) H0).
 simpl in *.
 apply H in e0.
 destruct e0.
 constructor.
 congruence.
 trivial.

intros; move : H.
elim/@rect_2S : x0/y.
trivial.
intros.
destruct n0.
simpl in H0; injection H0; move : H H0.
elim/@caseS' : v1; elim/@caseS' : v2.
move => h t h0 t0.
elim/@case0 : t; elim/@case0 : t0.
intros.
simpl in *; subst; trivial.
simpl in *.
destruct n0.
by destruct (@x _ _ a b _ _ H0); subst.
by destruct (@x _ _ a b _ _ H0); subst.
Qed.

Theorem shift_back : forall n s (x : t (SAgent s) (S n)) (H : n < S n) (H' : 0 < S n), (shift x)[@of_nat_lt H] = x[@of_nat_lt H'].
move => n s.
elim/@rect_SS'.
intros;simpl in *; apply : shift_hd_get'.
done.
done.
Qed.

Theorem law1 : forall l y (k : t (SAgent l) (S y)) (x' : y < S y) (y' : 0 < S y), get_agent (match_lex k) y' = get_agent (shift (match_lex k)) x'.
  intros.
  move : x' y'.
  unfold get_agent.
  unfold nth_order.
  elim/@rectS : k.
  done.
  destruct n.
  done.
  simpl; unfold caseS'.
  elim/@caseS'.
  intros;move : H; elim/@caseS' : t.
  intros;symmetry.
  apply : shift_hd_get'.
Qed.

Theorem law2 : forall  l y (k : t (SAgent l) (S y)) (x' : y < S y) (y' : 0 < S y), agent_lex (match_lex k)[@of_nat_lt y'] = cross_lex (agent_lex k[@of_nat_lt y']) (agent_lex k[@of_nat_lt x']).
  move => l y.
  elim/@rectS.
  intros; trivial.
  intros; simpl in *.
  by rewrite (of_nat_lt_c (lt_S_n n (S n) (le_n (S (S n)))) (lt_S_n n (S n) x')).
Qed.

Instance SEnvironment : forall x y (k : t (SAgent x) (S y)),
   @Environment _ _ _ _ _ _ (
  fun x => t x (S y)) boundness get_agent (@view _ _) (@action_prop _ _) (SAgent' x) k (F' shift match_lex).
{
  constructor.
  exists 0.
  elim/@caseS : x0.
  unfold boundness.
  auto with arith.

  intros.
  unfold boundness in *.
  exists (0, y).
  exists (Nat.lt_0_succ y, @le_n (S y)).
  unfold view.
  simpl.
  apply : Nat.eqb_refl.

  intros.
  constructor;intros.
  unfold view in H'.
  unfold action_prop.

  unfold boundness in *.
  simpl.
  clear x' y'.
  move : x'0 y'0 H'.
  destruct y.
  elim/@case_2nat : x0/y0.
  intros.
  simpl.
  elim/@caseS' : k.
  unfold get_agent.
  pose (of_nat_lt_c x'0 y'0).
  tauto.
  intros.
  inversion H'.
  intros; inversion H'.
  intros; inversion H'.

  intros.
  apply andb_true_iff in H'.
  destruct H'.
  apply beq_nat_true in H.
  apply beq_nat_true in H0.
  subst.
  move : x'0 y'0.
  intros; apply : law1.

  simpl in *.
  unfold boundness in *.
  unfold view in H'.
  apply andb_true_iff in H'.
  destruct H'.
  apply beq_nat_true in H; apply beq_nat_true in H0.
  subst.

  unfold get_agent; unfold nth_order.
    have : of_nat_lt a = of_nat_lt x'0.
    apply of_nat_lt_c.
  move => H2; rewrite H2.
  apply : law2.
}

Defined.

Instance SUniverse : forall x y (v : t (SAgent x) (S y)), @State _ _ _ _ _ _ (
  fun x => t x (S y)) boundness get_agent (@view _ _) (@action_prop _ _) (SAgent' x) shift match_lex v.
constructor.
intros.

constructor.
(*when P(0) for environment *)
apply : SEnvironment.
intros.
constructor.
(*when P k -> P (k + 1), for the environment *)
unfold boundness in *.
move => H2; exists y; auto with arith.
intros; unfold boundness in *; exists (0, y); exists (Nat.lt_0_succ y, @le_n (S y)).
unfold view; apply : Nat.eqb_refl.
intros; constructor; simpl.
intros;unfold action_prop; unfold boundness in *; apply andb_true_iff in H'.
destruct H'.
apply beq_nat_true in H; apply beq_nat_true in H0.
subst.
(*both law1 and law2 proofs of inductive interaction was straightfoward, once law1 and law2 were
    strong enough to generalization of any type obeying just the type constaint *)
apply : law1.
intros; unfold boundness in *; apply andb_true_iff in H'.
destruct H'.
apply beq_nat_true in H; apply beq_nat_true in H0.
subst.
apply : law2.
Defined.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q A B Aprime Cprime : Universe, ((wd_ P Q /\ (wd_ P Aprime /\ (wd_ P Cprime /\ (wd_ A Aprime /\ (wd_ B Aprime /\ (wd_ Aprime Cprime /\ (wd_ A B /\ (wd_ A P /\ (wd_ B P /\ (col_ P Q Aprime /\ (col_ P Q Cprime /\ (col_ A B Aprime /\ col_ Aprime A Aprime)))))))))))) -> col_ Cprime Aprime P)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O A B C D E F : Universe, ((wd_ O A /\ (wd_ B A /\ (wd_ C D /\ (wd_ D E /\ (wd_ D B /\ (wd_ C E /\ (wd_ A D /\ (wd_ O B /\ (wd_ C O /\ (wd_ D O /\ (wd_ E O /\ (wd_ F D /\ (wd_ O F /\ (wd_ E F /\ (col_ E D F /\ (col_ O F E /\ (col_ D E B /\ (col_ C D E /\ col_ A C D)))))))))))))))))) -> col_ O D F)).
Proof.
  time tac.
Qed.

End FOFProblem.