From algebra Require Export cmra.
From algebra Require Import upred.

(** * Indexed product *)
(** Need to put this in a definition to make canonical structures to work. *)
Definition iprod {A} (B : A → cofeT) := ∀ x, B x.
Definition iprod_insert {A} {B : A → cofeT} `{∀ x x' : A, Decision (x = x')}
    (x : A) (y : B x) (f : iprod B) : iprod B := λ x',
  match decide (x = x') with left H => eq_rect _ B y _ H | right _ => f x' end.
Global Instance iprod_empty {A} {B : A → cofeT}
  `{∀ x, Empty (B x)} : Empty (iprod B) := λ x, ∅.
Definition iprod_singleton {A} {B : A → cofeT}
    `{∀ x x' : A, Decision (x = x'), ∀ x : A, Empty (B x)}
  (x : A) (y : B x) : iprod B := iprod_insert x y ∅.
Instance: Params (@iprod_insert) 4.
Instance: Params (@iprod_singleton) 5.

Section iprod_cofe.
  Context {A} {B : A → cofeT}.
  Implicit Types x : A.
  Implicit Types f g : iprod B.

  Instance iprod_equiv : Equiv (iprod B) := λ f g, ∀ x, f x ≡ g x.
  Instance iprod_dist : Dist (iprod B) := λ n f g, ∀ x, f x ≡{n}≡ g x.
  Program Definition iprod_chain (c : chain (iprod B)) (x : A) : chain (B x) :=
    {| chain_car n := c n x |}.
  Next Obligation. by intros c x n i ?; apply (chain_cauchy c). Qed.
  Program Instance iprod_compl : Compl (iprod B) := λ c x,
    compl (iprod_chain c x).
  Definition iprod_cofe_mixin : CofeMixin (iprod B).
  Proof.
    split.
    - intros f g; split; [intros Hfg n k; apply equiv_dist, Hfg|].
      intros Hfg k; apply equiv_dist; intros n; apply Hfg.
    - intros n; split.
      + by intros f x.
      + by intros f g ? x.
      + by intros f g h ?? x; trans (g x).
    - intros n f g Hfg x; apply dist_S, Hfg.
    - intros n c x.
      rewrite /compl /iprod_compl (conv_compl n (iprod_chain c x)).
      apply (chain_cauchy c); lia.
  Qed.
  Canonical Structure iprodC : cofeT := CofeT iprod_cofe_mixin.

  (** Properties of empty *)
  Section empty.
    Context `{∀ x, Empty (B x)}.
    Definition iprod_lookup_empty  x : ∅ x = ∅ := eq_refl.
    Global Instance iprod_empty_timeless :
      (∀ x : A, Timeless (∅ : B x)) → Timeless (∅ : iprod B).
    Proof. intros ? f Hf x. by apply: timeless. Qed.
  End empty.

  (** Properties of iprod_insert. *)
  Context `{∀ x x' : A, Decision (x = x')}.

  Global Instance iprod_insert_ne n x :
    Proper (dist n ==> dist n ==> dist n) (iprod_insert x).
  Proof.
    intros y1 y2 ? f1 f2 ? x'; rewrite /iprod_insert.
    by destruct (decide _) as [[]|].
  Qed.
  Global Instance iprod_insert_proper x :
    Proper ((≡) ==> (≡) ==> (≡)) (iprod_insert x) := ne_proper_2 _.

  Lemma iprod_lookup_insert f x y : (iprod_insert x y f) x = y.
  Proof.
    rewrite /iprod_insert; destruct (decide _) as [Hx|]; last done.
    by rewrite (proof_irrel Hx eq_refl).
  Qed.
  Lemma iprod_lookup_insert_ne f x x' y :
    x ≠ x' → (iprod_insert x y f) x' = f x'.
  Proof. by rewrite /iprod_insert; destruct (decide _). Qed.

  Global Instance iprod_lookup_timeless f x : Timeless f → Timeless (f x).
  Proof.
    intros ? y ?.
    cut (f ≡ iprod_insert x y f).
    { by move=> /(_ x)->; rewrite iprod_lookup_insert. }
    by apply: timeless=>x'; destruct (decide (x = x')) as [->|];
      rewrite ?iprod_lookup_insert ?iprod_lookup_insert_ne.
  Qed.
  Global Instance iprod_insert_timeless f x y :
    Timeless f → Timeless y → Timeless (iprod_insert x y f).
  Proof.
    intros ?? g Heq x'; destruct (decide (x = x')) as [->|].
    - rewrite iprod_lookup_insert.
      apply: timeless. by rewrite -(Heq x') iprod_lookup_insert.
    - rewrite iprod_lookup_insert_ne //.
      apply: timeless. by rewrite -(Heq x') iprod_lookup_insert_ne.
  Qed.

  (** Properties of iprod_singletom. *)
  Context `{∀ x : A, Empty (B x)}.

  Global Instance iprod_singleton_ne n x :
    Proper (dist n ==> dist n) (iprod_singleton x).
  Proof. by intros y1 y2 Hy; rewrite /iprod_singleton Hy. Qed.
  Global Instance iprod_singleton_proper x :
    Proper ((≡) ==> (≡)) (iprod_singleton x) := ne_proper _.

  Lemma iprod_lookup_singleton x y : (iprod_singleton x y) x = y.
  Proof. by rewrite /iprod_singleton iprod_lookup_insert. Qed.
  Lemma iprod_lookup_singleton_ne x x' y: x ≠ x' → (iprod_singleton x y) x' = ∅.
  Proof. intros; by rewrite /iprod_singleton iprod_lookup_insert_ne. Qed.

  Global Instance iprod_singleton_timeless x (y : B x) :
    (∀ x : A, Timeless (∅ : B x)) → Timeless y → Timeless (iprod_singleton x y).
  Proof. eauto using iprod_insert_timeless, iprod_empty_timeless. Qed.
End iprod_cofe.

Arguments iprodC {_} _.

Section iprod_cmra.
  Context {A} {B : A → cmraT}.
  Implicit Types f g : iprod B.

  Instance iprod_op : Op (iprod B) := λ f g x, f x ⋅ g x.
  Instance iprod_core : Core (iprod B) := λ f x, core (f x).
  Instance iprod_valid : Valid (iprod B) := λ f, ∀ x, ✓ f x.
  Instance iprod_validN : ValidN (iprod B) := λ n f, ∀ x, ✓{n} f x.
  Instance iprod_div : Div (iprod B) := λ f g x, f x ÷ g x.

  Definition iprod_lookup_op f g x : (f ⋅ g) x = f x ⋅ g x := eq_refl.
  Definition iprod_lookup_core f x : (core f) x = core (f x) := eq_refl.
  Definition iprod_lookup_div f g x : (f ÷ g) x = f x ÷ g x := eq_refl.

  Lemma iprod_included_spec (f g : iprod B) : f ≼ g ↔ ∀ x, f x ≼ g x.
  Proof.
    split.
    - by intros [h Hh] x; exists (h x); rewrite /op /iprod_op (Hh x).
    - intros Hh; exists (g ÷ f)=> x; specialize (Hh x).
      by rewrite /op /iprod_op /div /iprod_div cmra_op_div.
  Qed.

  Definition iprod_cmra_mixin : CMRAMixin (iprod B).
  Proof.
    split.
    - by intros n f1 f2 f3 Hf x; rewrite iprod_lookup_op (Hf x).
    - by intros n f1 f2 Hf x; rewrite iprod_lookup_core (Hf x).
    - by intros n f1 f2 Hf ? x; rewrite -(Hf x).
    - by intros n f f' Hf g g' Hg i; rewrite iprod_lookup_div (Hf i) (Hg i).
    - intros g; split.
      + intros Hg n i; apply cmra_valid_validN, Hg.
      + intros Hg i; apply cmra_valid_validN=> n; apply Hg.
    - intros n f Hf x; apply cmra_validN_S, Hf.
    - by intros f1 f2 f3 x; rewrite iprod_lookup_op assoc.
    - by intros f1 f2 x; rewrite iprod_lookup_op comm.
    - by intros f x; rewrite iprod_lookup_op iprod_lookup_core cmra_core_l.
    - by intros f x; rewrite iprod_lookup_core cmra_core_idemp.
    - intros f1 f2; rewrite !iprod_included_spec=> Hf x.
      by rewrite iprod_lookup_core; apply cmra_core_preserving, Hf.
    - intros n f1 f2 Hf x; apply cmra_validN_op_l with (f2 x), Hf.
    - intros f1 f2; rewrite iprod_included_spec=> Hf x.
      by rewrite iprod_lookup_op iprod_lookup_div cmra_op_div; try apply Hf.
    - intros n f f1 f2 Hf Hf12.
      set (g x := cmra_extend n (f x) (f1 x) (f2 x) (Hf x) (Hf12 x)).
      exists ((λ x, (proj1_sig (g x)).1), (λ x, (proj1_sig (g x)).2)).
      split_and?; intros x; apply (proj2_sig (g x)).
  Qed.
  Canonical Structure iprodR : cmraT := CMRAT iprod_cofe_mixin iprod_cmra_mixin.
  Global Instance iprod_cmra_unit `{∀ x, Empty (B x)} :
    (∀ x, CMRAUnit (B x)) → CMRAUnit iprodR.
  Proof.
    intros ?; split.
    - intros x; apply cmra_unit_valid.
    - by intros f x; rewrite iprod_lookup_op left_id.
    - by apply _.
  Qed.

  (** Internalized properties *)
  Lemma iprod_equivI {M} g1 g2 : (g1 ≡ g2)%I ≡ (∀ i, g1 i ≡ g2 i : uPred M)%I.
  Proof. by uPred.unseal. Qed.
  Lemma iprod_validI {M} g : (✓ g)%I ≡ (∀ i, ✓ g i : uPred M)%I.
  Proof. by uPred.unseal. Qed.

  (** Properties of iprod_insert. *)
  Context `{∀ x x' : A, Decision (x = x')}.

  Lemma iprod_insert_updateP x (P : B x → Prop) (Q : iprod B → Prop) g y1 :
    y1 ~~>: P → (∀ y2, P y2 → Q (iprod_insert x y2 g)) →
    iprod_insert x y1 g ~~>: Q.
  Proof.
    intros Hy1 HP n gf Hg. destruct (Hy1 n (gf x)) as (y2&?&?).
    { move: (Hg x). by rewrite iprod_lookup_op iprod_lookup_insert. }
    exists (iprod_insert x y2 g); split; [auto|].
    intros x'; destruct (decide (x' = x)) as [->|];
      rewrite iprod_lookup_op ?iprod_lookup_insert //; [].
    move: (Hg x'). by rewrite iprod_lookup_op !iprod_lookup_insert_ne.
  Qed.

  Lemma iprod_insert_updateP' x (P : B x → Prop) g y1 :
    y1 ~~>: P →
    iprod_insert x y1 g ~~>: λ g', ∃ y2, g' = iprod_insert x y2 g ∧ P y2.
  Proof. eauto using iprod_insert_updateP. Qed.
  Lemma iprod_insert_update g x y1 y2 :
    y1 ~~> y2 → iprod_insert x y1 g ~~> iprod_insert x y2 g.
  Proof.
    rewrite !cmra_update_updateP; eauto using iprod_insert_updateP with subst.
  Qed.

  (** Properties of iprod_singleton. *)
  Context `{∀ x, Empty (B x), ∀ x, CMRAUnit (B x)}.

  Lemma iprod_singleton_validN n x (y: B x) : ✓{n} iprod_singleton x y ↔ ✓{n} y.
  Proof.
    split; [by move=>/(_ x); rewrite iprod_lookup_singleton|].
    move=>Hx x'; destruct (decide (x = x')) as [->|];
      rewrite ?iprod_lookup_singleton ?iprod_lookup_singleton_ne //.
    by apply cmra_unit_validN.
  Qed.

  Lemma iprod_core_singleton x (y : B x) :
    core (iprod_singleton x y) ≡ iprod_singleton x (core y).
  Proof.
    by move=>x'; destruct (decide (x = x')) as [->|];
      rewrite iprod_lookup_core ?iprod_lookup_singleton
      ?iprod_lookup_singleton_ne // cmra_core_unit.
  Qed.

  Lemma iprod_op_singleton (x : A) (y1 y2 : B x) :
    iprod_singleton x y1 ⋅ iprod_singleton x y2 ≡ iprod_singleton x (y1 ⋅ y2).
  Proof.
    intros x'; destruct (decide (x' = x)) as [->|].
    - by rewrite iprod_lookup_op !iprod_lookup_singleton.
    - by rewrite iprod_lookup_op !iprod_lookup_singleton_ne // left_id.
  Qed.

  Lemma iprod_singleton_updateP x (P : B x → Prop) (Q : iprod B → Prop) y1 :
    y1 ~~>: P → (∀ y2, P y2 → Q (iprod_singleton x y2)) →
    iprod_singleton x y1 ~~>: Q.
  Proof. rewrite /iprod_singleton; eauto using iprod_insert_updateP. Qed.
  Lemma iprod_singleton_updateP' x (P : B x → Prop) y1 :
    y1 ~~>: P →
    iprod_singleton x y1 ~~>: λ g, ∃ y2, g = iprod_singleton x y2 ∧ P y2.
  Proof. eauto using iprod_singleton_updateP. Qed.
  Lemma iprod_singleton_update x y1 y2 :
    y1 ~~> y2 → iprod_singleton x y1 ~~> iprod_singleton x y2.
  Proof. eauto using iprod_insert_update. Qed.

  Lemma iprod_singleton_updateP_empty x (P : B x → Prop) (Q : iprod B → Prop) :
    ∅ ~~>: P → (∀ y2, P y2 → Q (iprod_singleton x y2)) → ∅ ~~>: Q.
  Proof.
    intros Hx HQ n gf Hg. destruct (Hx n (gf x)) as (y2&?&?); first apply Hg.
    exists (iprod_singleton x y2); split; [by apply HQ|].
    intros x'; destruct (decide (x' = x)) as [->|].
    - by rewrite iprod_lookup_op iprod_lookup_singleton.
    - rewrite iprod_lookup_op iprod_lookup_singleton_ne //. apply Hg.
  Qed.
  Lemma iprod_singleton_updateP_empty' x (P : B x → Prop) :
    ∅ ~~>: P → ∅ ~~>: λ g, ∃ y2, g = iprod_singleton x y2 ∧ P y2.
  Proof. eauto using iprod_singleton_updateP_empty. Qed.
End iprod_cmra.

Arguments iprodR {_} _.

(** * Functor *)
Definition iprod_map {A} {B1 B2 : A → cofeT} (f : ∀ x, B1 x → B2 x)
  (g : iprod B1) : iprod B2 := λ x, f _ (g x).

Lemma iprod_map_ext {A} {B1 B2 : A → cofeT} (f1 f2 : ∀ x, B1 x → B2 x) g :
  (∀ x, f1 x (g x) ≡ f2 x (g x)) → iprod_map f1 g ≡ iprod_map f2 g.
Proof. done. Qed.
Lemma iprod_map_id {A} {B: A → cofeT} (g : iprod B) : iprod_map (λ _, id) g = g.
Proof. done. Qed.
Lemma iprod_map_compose {A} {B1 B2 B3 : A → cofeT}
    (f1 : ∀ x, B1 x → B2 x) (f2 : ∀ x, B2 x → B3 x) (g : iprod B1) :
  iprod_map (λ x, f2 x ∘ f1 x) g = iprod_map f2 (iprod_map f1 g).
Proof. done. Qed.

Instance iprod_map_ne {A} {B1 B2 : A → cofeT} (f : ∀ x, B1 x → B2 x) n :
  (∀ x, Proper (dist n ==> dist n) (f x)) →
  Proper (dist n ==> dist n) (iprod_map f).
Proof. by intros ? y1 y2 Hy x; rewrite /iprod_map (Hy x). Qed.
Instance iprod_map_cmra_monotone {A} {B1 B2: A → cmraT} (f : ∀ x, B1 x → B2 x) :
  (∀ x, CMRAMonotone (f x)) → CMRAMonotone (iprod_map f).
Proof.
  split; first apply _.
  - intros n g Hg x; rewrite /iprod_map; apply (validN_preserving (f _)), Hg.
  - intros g1 g2; rewrite !iprod_included_spec=> Hf x.
    rewrite /iprod_map; apply (included_preserving _), Hf.
Qed.

Definition iprodC_map {A} {B1 B2 : A → cofeT} (f : iprod (λ x, B1 x -n> B2 x)) :
  iprodC B1 -n> iprodC B2 := CofeMor (iprod_map f).
Instance iprodC_map_ne {A} {B1 B2 : A → cofeT} n :
  Proper (dist n ==> dist n) (@iprodC_map A B1 B2).
Proof. intros f1 f2 Hf g x; apply Hf. Qed.

Program Definition iprodCF {C} (F : C → cFunctor) : cFunctor := {|
  cFunctor_car A B := iprodC (λ c, cFunctor_car (F c) A B);
  cFunctor_map A1 A2 B1 B2 fg := iprodC_map (λ c, cFunctor_map (F c) fg)
|}.
Next Obligation.
  intros C F A1 A2 B1 B2 n ?? g. by apply iprodC_map_ne=>?; apply cFunctor_ne.
Qed.
Next Obligation.
  intros C F A B g; simpl. rewrite -{2}(iprod_map_id g).
  apply iprod_map_ext=> y; apply cFunctor_id.
Qed.
Next Obligation.
  intros C F A1 A2 A3 B1 B2 B3 f1 f2 f1' f2' g. rewrite /= -iprod_map_compose.
  apply iprod_map_ext=>y; apply cFunctor_compose.
Qed.
Instance iprodCF_contractive {C} (F : C → cFunctor) :
  (∀ c, cFunctorContractive (F c)) → cFunctorContractive (iprodCF F).
Proof.
  intros ? A1 A2 B1 B2 n ?? g.
  by apply iprodC_map_ne=>c; apply cFunctor_contractive.
Qed.

Program Definition iprodRF {C} (F : C → rFunctor) : rFunctor := {|
  rFunctor_car A B := iprodR (λ c, rFunctor_car (F c) A B);
  rFunctor_map A1 A2 B1 B2 fg := iprodC_map (λ c, rFunctor_map (F c) fg)
|}.
Next Obligation.
  intros C F A1 A2 B1 B2 n ?? g. by apply iprodC_map_ne=>?; apply rFunctor_ne.
Qed.
Next Obligation.
  intros C F A B g; simpl. rewrite -{2}(iprod_map_id g).
  apply iprod_map_ext=> y; apply rFunctor_id.
Qed.
Next Obligation.
  intros C F A1 A2 A3 B1 B2 B3 f1 f2 f1' f2' g. rewrite /= -iprod_map_compose.
  apply iprod_map_ext=>y; apply rFunctor_compose.
Qed.
Instance iprodRF_contractive {C} (F : C → rFunctor) :
  (∀ c, rFunctorContractive (F c)) → rFunctorContractive (iprodRF F).
Proof.
  intros ? A1 A2 B1 B2 n ?? g.
  by apply iprodC_map_ne=>c; apply rFunctor_contractive.
Qed.


From Coq.Init Require Import Notations Datatypes.
Require Import Bool.
Require Import Coq.Logic.FunctionalExtensionality.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype seq fintype.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool ssrnat.
Set Warnings "parsing".

Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Require Export Quiver.
Set Implicit Arguments.
Unset Strict Implicit.

Module QuiverEg.
  Section ADef.
    Variable n : nat.
Check vPack.
    Definition An : finQuiverType := Quiver.Build
    (Quiver.aPack (vPack
      (ordinal_finType (S n)) (@Ordinal (S n) 0 is_true_true))
      (ordinal_finType n)
      (fun a => @Ordinal (S n) a (leq_trans (ltn_ord a) (leqnSn n)))
      (fun a => @Ordinal (S n) (S a) (ltn_ord a))
    ).
  End ADef.
  Section ATildeDef.
    Variable n : nat.
    Definition ATilde_n := @Quiver.addArrows (An n) 1 (fun _ => (@Ordinal (S n) 0 (ltn0Sn n))) (fun _ => (@Ordinal (S n) n (ltnSn n))).
  End ATildeDef.

  Definition SSQ_centre := Quiver.Build (Quiver.aPack
    (vPack unit_finType tt)
    void_finType
    (fun _ => tt)
    (fun _ => tt)
  ).

  Definition SSQ (d : seq nat) := Quiver.union SSQ_centre (map An d).

  Section DEDef.
    Variable n : nat.

    Definition Dn (_: n > 3) := SSQ (1::1::(n - 3)::nil).
    Definition En (_: n > 4) := SSQ (1::2::(n - 3)::nil).
    Definition EnTilde (_: n > 4) := SSQ (2::2::(n - 3)::nil).
(*    Definition DnTilde (_: n > 3) := . *)
  End DEDef.

  Module Exports.
  End Exports.
End QuiverEg.
Export QuiverEg.Exports.

Require Import QuiverRep Algebras Morphism Dimension.
From mathcomp Require Export matrix.
Module RepEg.
  Section ADef.
    Variable R : ringIBNType.
    Variable Q : finQuiverType.
    Variable alpha : \V_Q -> nat.
    Variable matr : forall a : \A_Q, 'M[R]_(alpha \t_Q(a), alpha \h_Q(a)).
    Definition rep := @QuivRep.Pack R Q
      (fun i : \V_Q => R \lmod^ (alpha i)).

    Section One.
      Variable (n : nat) (e : 'I_n) (s : 'I_e).
      Definition indcmpAnVS := fun i : \V_(Quiver.Q_Q (QuiverEg.An n)) =>
        if s < i < e then
          (lmods.ringMod R)
        else
          (lmodZero.type R).
          (*
      Program Definition indcmpAn := rep (@QuivRep.Pack R ((QuiverEg.An n))
        (indcmpAnVS)
        (fun a : \A_(Quiver.Q_Q (QuiverEg.An n)) =>
          if s < a < e then
            linID.map (lmods.ringMod R)
          else
            linZero.map (indcmpAnVS \t_Q(a)) (indcmpAnVS \h_Q(a))
        )).
    End ADef.*)
    End One.
  End ADef.
End RepEg.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import
        Limits.Limit
        Limits.GenProd_GenSum
        Limits.GenProd_Eq_Limits
.
Require Import Functor.Functor Functor.Functor_Ops.
Require Import NatTrans.Main.
Require Import Ext_Cons.Comma.
Require Import
        Basic_Cons.Terminal
        Basic_Cons.Equalizer
        Basic_Cons.Limits
.
Require Import Archetypal.Discr.Discr.
Require Import Cat.Cat_Terminal.

(** We show that if C is a complete category and G : C –≻ D preserves limits,
then every comma category (Comma (Func_From_SingletonCat x) G) for (x : D) has
generalized products. *)
Section Commas_GenProd.
  Context
    {C D : Category}
    {CC : Complete C}
    {G : (C –≻ D)%functor}
    (GCont : Continuous CC G)
    (x : D)
  .

  Local Hint Extern 1 => match goal with [x : unit |- _] => destruct x end.
  Local Hint Extern 1 => apply Comma_Hom_eq_simplify.
  Local Hint Extern 1 => progress cbn in *.
  Local Hint Extern 1 => rewrite From_Term_Cat.

  Local Obligation Tactic := basic_simpl; auto 10.

  Section fun_conv.
    Context {A : Type} (f : A → (Comma (Func_From_SingletonCat x) G)).

    Definition fun_conv (y : A) : C := CMO_trg (f y).

  End fun_conv.

  Context {A : Type} (f : A → (Comma (Func_From_SingletonCat x) G)).

  Definition GenProd_fun_conv : GenProd (fun_conv f) :=
    Limit_of (Discr_Func (fun_conv f)).

  Program Definition f_Cone : Cone (G ∘ (Discr_Func (fun_conv f)))%functor
    :=
      {|
        cone_apex :=
          {|
            FO :=
              fun _ => x;
            FA := fun _ _ _ => id
          |};
        cone_edge :=
          {|
            Trans := fun c => CMO_hom (f c)
          |}
      |}.

  Definition Limit_G_fun_conv : Limit (G ∘ (Discr_Func (fun_conv f)))%functor
    :=
      is_Cone_Local_Right_KanExt_Local_Right_KanExt
        _
        _
        (GCont _ (Discr_Func (fun_conv f)))
  .

  Section Comma_GenProd_Cone.
    Local Unset Transparent Obligations.

    Program Definition Comma_GenProd_Cone : Cone (Discr_Func f) :=
      {|
        cone_apex :=
          {|
            FO :=
              fun x =>
                {|
                  CMO_src := x;
                  CMO_trg := GenProd_fun_conv;
                  CMO_hom := Trans (LRKE_morph_ex Limit_G_fun_conv f_Cone) tt
                |};
            FA :=
              fun a b h =>
                {|
                  CMH_left := h;
                  CMH_right := id
                |}
          |};
        cone_edge :=
          {|
            Trans :=
              fun c =>
                {|
                  CMH_left := tt;
                  CMH_right := Trans GenProd_fun_conv c
                |}
          |}
      |}
    .

    Next Obligation.
    Proof.
      cbn_rewrite (f_equal
                     (fun w:
                            (f_Cone ∘ Functor_To_1_Cat (Discr_Cat A)
                                    –≻ G ∘ Discr_Func (fun_conv f))%nattrans
                      => Trans w c)
                     (cone_morph_com (LRKE_morph_ex Limit_G_fun_conv f_Cone))).
      rewrite From_Term_Cat.
      rewrite F_id.
      auto.
    Qed.

  End Comma_GenProd_Cone.

  Program Definition Cone_f_Cone_fun_conv_f (Cn : Cone (Discr_Func f)) :
    Cone (Discr_Func (fun_conv f)) :=
    {|
      cone_apex :=
        {|
          FO := fun _ => CMO_trg (Cn _o tt)%object;
          FA := fun a b h => id
        |};
      cone_edge :=
        {|
          Trans := fun c => CMH_right (Trans Cn c)
        |}
    |}
  .

  Section Cone_f_Cone_Morph_from_f_Cone.
    Context (Cn : Cone (Discr_Func f)).

    Local Obligation Tactic := idtac.

    Program Definition Cone_f_Cone_Morph_from_f_Cone  :
      LoKan_Cone_Morph f_Cone Limit_G_fun_conv
      :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  ((G _a
                      (Trans
                         (
                           LRKE_morph_ex
                             (GenProd_fun_conv)
                             (Cone_f_Cone_fun_conv_f Cn)
                         )
                         c
                      )
                   ) ∘ (CMO_hom (Cn _o tt)))%object%morphism
            |}
        |}
    .

    Next Obligation.
    Proof.
      basic_simpl; auto 10.
    Qed.

    Next Obligation.
    Proof.
      symmetry.
      apply Cone_f_Cone_Morph_from_f_Cone_obligation_1.
    Qed.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify.
      extensionality z.
      cbn in *.
      simpl_ids.
      rewrite assoc_sym.
      rewrite <- F_compose.
      rewrite assoc_sym.
      rewrite <- F_compose.
      repeat rewrite assoc.
      cbn_rewrite
        <-
        (
          f_equal
            (fun w :
                   ((Cone_f_Cone_fun_conv_f Cn)
                      ∘ Functor_To_1_Cat (Discr_Cat A)
                      –≻ Discr_Func (fun_conv f))%nattrans
             => Trans w z)
            (cone_morph_com (LRKE_morph_ex (GenProd_fun_conv) (Cone_f_Cone_fun_conv_f Cn)))
        ).
      etransitivity; [|symmetry; apply (CMH_com (Trans Cn z))].
      cbn; auto.
    Qed.

  End Cone_f_Cone_Morph_from_f_Cone.

  Section Comma_GenProd_Cone_Morph_ex.
    Context (Cn : Cone (Discr_Func f)).

    Local Unset Transparent Obligations.

    Program Definition Comma_GenProd_Cone_Morph_ex
      :
        LoKan_Cone_Morph Cn Comma_GenProd_Cone
      :=
        {|
          cone_morph :=
            {|
              Trans :=
                fun c =>
                  {|
                    CMH_left := tt;
                    CMH_right :=
                      match c as u return (CMO_trg (Cn _o u)%object –≻ _)%morphism with
                        tt =>
                        Trans
                          (LRKE_morph_ex (GenProd_fun_conv) (Cone_f_Cone_fun_conv_f Cn))
                          tt
                      end
                  |}
            |}
        |}
    .

    Next Obligation.
    Proof.
      repeat match goal with [x : unit |- _] => destruct x end.
      simpl_ids.
      apply (
          f_equal
            (fun w : (f_Cone –≻ Limit_G_fun_conv)%nattrans => Trans w tt)
            (LRKE_morph_unique
               Limit_G_fun_conv
               f_Cone
               (Cone_f_Cone_Morph_from_f_Cone Cn)
               (LRKE_morph_ex Limit_G_fun_conv f_Cone)
            )
        ).
    Qed.

    Local Obligation Tactic := idtac.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify.
      extensionality z.
      apply Comma_Hom_eq_simplify; cbn in *.
      match goal with [|- ?A = _] => destruct A; trivial end.
      simpl_ids.
      cbn_rewrite (
          f_equal
            (fun w :
                   ((Cone_f_Cone_fun_conv_f Cn)
                      ∘ Functor_To_1_Cat (Discr_Cat A)
                      –≻ Discr_Func (fun_conv f))%nattrans
             => Trans w z)
            (cone_morph_com (LRKE_morph_ex (GenProd_fun_conv) (Cone_f_Cone_fun_conv_f Cn)))
        ).
      auto.
    Qed.

  End Comma_GenProd_Cone_Morph_ex.

  Program Definition Cone_Morph_to_Comma_GenProd_Cone_TO_Cone_Morph_to_GenProd_fun_conv
          (Cn : Cone (Discr_Func f))
          (h : LoKan_Cone_Morph Cn Comma_GenProd_Cone)
    :
      LoKan_Cone_Morph (Cone_f_Cone_fun_conv_f Cn) GenProd_fun_conv
    :=
      {|
        cone_morph :=
          {|
            Trans :=
              fun c =>
                match
                  c as u
                  return
                  (
                    (CMO_trg ((Cn _o)%object tt))
                      –≻
                      (
                        (CC
                           (Discr_Cat A) _o)
                          (Discr_Func (fun_conv f)) _o)%object
                      u
                  )%morphism
                with
                | tt => CMH_right (Trans h tt)
                end
          |}
      |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality z.
    cbn.
    cbn_rewrite (
        f_equal
          (fun w :
                 ((Cn ∘ Functor_To_1_Cat (Discr_Cat A))
                    –≻
                    @Discr_Func (Comma (Func_From_SingletonCat x) G) _ f)%nattrans
           => CMH_right (Trans w z)
          )
          (cone_morph_com h)
      ).
    auto.
  Qed.

  Program Definition Comma_GenProd : GenProd f
    :=
      {|
        LRKE := Comma_GenProd_Cone;
        LRKE_morph_ex := Comma_GenProd_Cone_Morph_ex
      |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality z.
    destruct z.
    apply Comma_Hom_eq_simplify.
    match goal with [|- ?A = ?B] => destruct A; destruct B; trivial end.
    change (CMH_right (Trans h tt)) with
    (Trans (Cone_Morph_to_Comma_GenProd_Cone_TO_Cone_Morph_to_GenProd_fun_conv Cn h) tt).
    change (CMH_right (Trans h' tt)) with
    (Trans (Cone_Morph_to_Comma_GenProd_Cone_TO_Cone_Morph_to_GenProd_fun_conv Cn h') tt).
    match goal with
      [|- Trans ?A tt = Trans ?B tt] =>
      cutrewrite (A = B); trivial
    end.
    apply (LRKE_morph_unique GenProd_fun_conv).
  Qed.

End Commas_GenProd.


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 E Eprime A B C D Bprimeprime : Universe, ((wd_ C O /\ (wd_ A O /\ (wd_ B O /\ (wd_ D O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Eprime C /\ (wd_ B Bprimeprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ col_ O Eprime Bprimeprime))))))))))))) -> col_ O C D)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Definition of the finite set spec *)
Require Export Fiat.FiniteSetADTs.FiniteSetADT.
Require Import Coq.Strings.String Coq.Sets.Ensembles
  Coq.Sets.Finite_sets Coq.Lists.List
  Coq.Sorting.Permutation Coq.MSets.MSetInterface
  Coq.MSets.MSetAVL Coq.MSets.MSetList Coq.MSets.MSetRBT
  Fiat.ADT
  Fiat.ADT.ComputationalADT
  Fiat.ADTRefinement.Core
  Fiat.ADTNotation
  Fiat.ADTRefinement.GeneralRefinements
  Fiat.Common.IterateBoundedIndex
  Fiat.Common.Ensembles.EnsembleListEquivalence.

Set Implicit Arguments.

Local Open Scope string_scope.

Module BedrockWordAsOrderedType <: OrderedType.
  Definition t : Type := W.
  Definition eq : t -> t -> Prop := eq.
  Definition eq_equiv : Equivalence eq := _.
  Definition lt : t -> t -> Prop := fun x y => wlt x y = true.
  Definition lt_strorder : StrictOrder lt.
  Proof.
    constructor; repeat intro; unfold lt in *.
    { rewrite ?wlt_irrefl in *; congruence. }
    { eapply wlt_trans; eassumption. }
  Qed.
  Definition lt_compat : Proper (eq ==> eq ==> iff) lt.
  Proof.
    repeat intro; subst; unfold eq in *; subst; reflexivity.
  Qed.
  Definition compare : t -> t -> comparison
    := fun x y => if wlt x y
                  then Datatypes.Lt
                  else if wlt y x
                       then Datatypes.Gt
                       else Datatypes.Eq.
  Definition compare_spec :
    forall x y : t, CompareSpec (eq x y) (lt x y) (lt y x) (compare x y).
  Proof.
    unfold lt, eq, t, compare; intros x y.
    case_eq (wlt x y); case_eq (wlt y x); intros;
    constructor; trivial.
    eapply wle_antisym; eassumption.
  Qed.
  Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
  Proof.
    refine (fun x y
            => (if weq x y as weqxy return weq x y = weqxy -> _
                then fun H => left (proj2 (weq_iff x y) H)
                else fun H => right _)
                 eq_refl).
    abstract (unfold eq; intros; subst;
              pose proof (proj1 (weq_iff y y) eq_refl);
              congruence).
  Defined.
End BedrockWordAsOrderedType.

Module FiniteSetADTMSet (FSMSet : SetsOn BedrockWordAsOrderedType).

  Definition FiniteSetCImpl : cADT FiniteSetSig :=
    cADTRep FSMSet.t {
      Def Constructor sEmpty (_ : unit) : rep :=
         FSMSet.empty,

      Def Method sAdd (fs : rep , w : W) : unit :=
        (FSMSet.add w fs, tt),

      Def Method sRemove (fs : rep , w : W) : unit :=
        (FSMSet.remove w fs, tt),

      Def Method sIn (fs : rep , w : W) : bool :=
        (fs, FSMSet.mem w fs),

      Def Method sSize (fs : rep , _ : unit) : W :=
        (fs, from_nat (FSMSet.cardinal fs))
    }.

  Local Ltac handle_computes_to_step_t :=
    idtac;
    match goal with
      | _ => intro
      | _ => progress simpl in *
      | _ => progress destruct_head_hnf prod
      | _ => progress destruct_head_hnf unit
      | [ |- computes_to (Bind _ _) _ ] => refine (BindComputes _ _ _)
      | [ |- computes_to (Return _) _ ] => constructor
      | [ |- computes_to (Pick _) _ ] => constructor
    end.

  Local Ltac t_step :=
    idtac;
    match goal with
      | _ => progress repeat handle_computes_to_step_t
      | _ => progress destruct_head_hnf Empty_set
      | _ => progress destruct_head_hnf or
      | _ => progress destruct_head_hnf Union
      | _ => progress destruct_head_hnf Singleton
      | _ => progress destruct_head_hnf prod
      | _ => progress destruct_head_hnf unit
      | _ => progress destruct_head_hnf False
      | _ => progress inversion_by computes_to_inv
      | _ => progress subst
      | _ => progress unfold Ensembles.In, Same_set, Included, Subtract, Setminus in *
      | _ => progress simplify_hyps
      | [ H : (_, _) = (_, _) |- _ ] => inversion H; clear H
      | [ |- Empty_set _ _ ] => exfalso
      | [ |- Singleton _ _ _ ] => constructor
      | [ H : FSMSet.In _ FSMSet.empty |- _ ] => apply FSMSet.empty_spec in H
      | [ |- FSMSet.In _ (FSMSet.add _ _) ] => apply FSMSet.add_spec
      | [ H : FSMSet.In _ (FSMSet.add _ _) |- _ ] => apply FSMSet.add_spec in H
      | [ |- FSMSet.In _ (FSMSet.remove _ _) ] => apply FSMSet.remove_spec
      | [ H : FSMSet.In _ (FSMSet.remove _ _) |- _ ] => apply FSMSet.remove_spec in H
      | _ => rewrite FSMSet.cardinal_spec
      | [ |- Cardinal.cardinal _ _ _ ] => eexists
      | [ |- Datatypes.length _ = Datatypes.length _ ] => reflexivity
      | [ |- EnsembleListEquivalence _ _ ] => split
      | [ |- NoDup (FSMSet.elements _) ] => eapply NoDupA_NoDup; [ | apply FSMSet.elements_spec2w ]; try exact _
      | [ |- List.In _ (FSMSet.elements _) ] => apply InA_In_eq
      | [ |- InA _ _ (FSMSet.elements _) ] => apply FSMSet.elements_spec1
      | [ H : List.In _ (FSMSet.elements _) |- _ ] => apply InA_In_eq in H
      | [ H : InA _ _ (FSMSet.elements _) |- _ ] => apply FSMSet.elements_spec1 in H
      | [ |- FSMSet.mem _ _ = true ] => apply FSMSet.mem_spec
      | [ H : FSMSet.mem _ _ = true |- _ ] => apply FSMSet.mem_spec in H
      | [ H : ~Singleton _ ?x ?x |- _ ] => exfalso; apply H; clear
      | [ |- _ /\ _ ] => split
      | [ |- _ <-> _ ] => split
      | [ |- ?G ] => not has_evar G; solve [ eauto with nocore ]
      | [ |- ?G ] => not has_evar G; left; reflexivity
      | [ |- ?G ] => not has_evar G; right; reflexivity
      | [ |- ?G ] => not has_evar G; right; solve [ hnf; eauto with nocore ]
      | [ |- ?G ] => not has_evar G; left; solve [ hnf; eauto with nocore ]
    end.

  Local Ltac t := repeat repeat repeat t_step.

  Local Arguments cConstructors _ _ _ _ / .
  Local Arguments cMethods _ _ _ _ _ / .

  Definition FiniteSetImpl : FullySharpened FiniteSetSpec.
  Proof.
    exists FiniteSetCImpl.
    exists (fun S0 fs => Same_set _ S0 (fun w => FSMSet.In w fs));
      eapply Iterate_Dep_Type_BoundedIndex_equiv_1; simpl;
      unfold FiniteSetADT.cardinal;
      repeat split; t.
  Defined.

End FiniteSetADTMSet.

Module MSetAVL_BedrockWord := MSetAVL.Make BedrockWordAsOrderedType.
Module Export FiniteSetADTMSetAVL := FiniteSetADTMSet MSetAVL_BedrockWord.
Module MSetList_BedrockWord := MSetList.Make BedrockWordAsOrderedType.
Module Export FiniteSetADTMSetList := FiniteSetADTMSet MSetList_BedrockWord.
Module MSetRBT_BedrockWord := MSetRBT.Make BedrockWordAsOrderedType.
Module Export FiniteSetADTMSetRBT := FiniteSetADTMSet MSetRBT_BedrockWord.


Require Import List.
Require Import Util Var Val Exp Envs Map CSet AutoIndTac IL.
Require Import Sim SimTactics Infra.Status.

Set Implicit Arguments.
Unset Printing Records.

Inductive nstmt : Type :=
| nstmtLet    (x : var) (e: exp) (s : nstmt)
| nstmtIf     (e : op) (s : nstmt) (t : nstmt)
| nstmtApp   (l : var) (Y:args)
| nstmtReturn (e : op)
| nstmtFun    (F : list (var * params * nstmt)) (t : nstmt).

Instance NStmt_size : Size nstmt. gen_Size. Defined.

Fixpoint freeVars (s:nstmt) : set var :=
  match s with
    | nstmtLet x e s0 => (freeVars s0 \ singleton x) ∪ Exp.freeVars e
    | nstmtIf e s1 s2 => freeVars s1 ∪ freeVars s2 ∪ Ops.freeVars e
    | nstmtApp l Y => list_union (List.map Ops.freeVars Y)
    | nstmtReturn e => Ops.freeVars e
    | nstmtFun F s2 =>
      list_union (List.map (fun f => (freeVars (snd f) \ of_list (snd (fst f)))) F)
                 ∪ freeVars s2
  end.

(** *** Functional Semantics *)
Module F.

  Inductive block : Type :=
    blockI {
        block_L : onv block;
        block_E : onv val;
        block_F : list (var * params * nstmt);
        block_f : nat;
        block_Z := snd (fst (nth block_f block_F
                                (default_var, nil, nstmtReturn (Con val_true))))
      }.

  Definition labenv := onv block.
  Definition state : Type := (labenv * onv val * nstmt)%type.

  Definition mkBlock L E F f (_:var * params * nstmt) :=
    blockI L E F f.

  Inductive step : state -> event -> state -> Prop :=
  | nstepLet L E x e b v
    (def:op_eval E e = Some v)
    : step (L, E, nstmtLet x (Operation e) b) EvtTau (L, E[x<-Some v], b)

  | stepExtern L E x f Y s vl v
    (def:omap (op_eval E) Y = Some vl)
    : step  (L, E, nstmtLet x (Call f Y) s)
            (EvtExtern (ExternI f vl v))
            (L, E[x <- Some v], s)

  | nstepIfT L E
    e b1 b2 v
    (def:op_eval E e = Some v)
    (condTrue: val2bool v = true)
    : step (L, E, nstmtIf e b1 b2) EvtTau (L, E, b1)

  | nstepIfF L E
    e b1 b2 v
    (def:op_eval E e = Some v)
    (condFalse:val2bool v = false)
    : step (L, E, nstmtIf e b1 b2) EvtTau (L, E, b2)

  | nstepGoto L E l l' Y Z s L' E' F f
    (len:length Z = length Y)
    (lEQ:l = l') (* hack: otherwise inversions confuse guardedness checker in
                  simulation proofs*)

    (Ldef:L l = Some (blockI L' E' F f)) E'' vl
    (def:omap (op_eval E) Y = Some vl)
    (sdef : get F f (l', Z, s))
    (updOk:E'[Z <-- List.map Some vl]  = E'')
    : step (L, E, nstmtApp l Y)
           EvtTau
           (L'[List.map (fst ∘ fst) F <-- List.map Some (mapi (mkBlock L' E' F) F)], E'', s)

  | stepFun (L:onv block) E F t
    : step (L, E, nstmtFun F t) EvtTau (L[List.map (fst ∘ fst) F <--
                                                   List.map Some (mapi (mkBlock L E F) F)], E, t).

  Lemma step_internally_deterministic :
    internally_deterministic step.
  Proof.
    hnf; intros. inv H; inv H0; split; eauto; try congruence.
    rewrite Ldef0 in Ldef. inv Ldef. repeat (get_functional; subst); congruence.
  Qed.

  Lemma step_dec
  : reddec2 step.
  Proof.
    hnf; intros. destruct x as [[L V] []].
    - destruct e.
      + case_eq (op_eval V e); intros. left. eexists EvtTau; eauto using step.
        right. stuck.
      + case_eq (omap (op_eval V) Y); intros; try now (right; stuck).
        left. eexists (EvtExtern (ExternI f l default_val)). eauto using step.
    - case_eq (op_eval V e); intros.
      left. case_eq (val2bool v); intros; eexists EvtTau; eauto using step.
      right. stuck.
    - case_eq (L l); intros.
      + destruct b as [L' E' F' f'].
        destruct (get_dec F' f') as [[[[l' Z] s] ?]|].
        * decide (l = l'); subst.
          decide (length Z = length Y).
          case_eq (omap (op_eval V) Y); intros; [| right; stuck2].
          left. eexists EvtTau. econstructor.
          econstructor; try eapply H; try eapply g; eauto.
          right; stuck2. rewrite Ldef in H. inv H. get_functional; subst. congruence.
          right; stuck2. rewrite Ldef in H. inv H. get_functional; subst.
        * right; stuck2. rewrite Ldef in H. inv H. eauto.
      + right. stuck.
    - right. stuck.
    - left. exists EvtTau. eauto using step.
  Qed.

End F.

(** *** Imperative Semantics *)
Module I.

  Inductive block : Type :=
    blockI {
        block_L : onv block;
        block_F : list (var * params * nstmt);
        block_f : nat;
        block_Z := snd (fst (nth block_f block_F (default_var, nil, nstmtReturn (Con val_true))))
      }.

  Definition labenv := onv block.
  Definition state : Type := (labenv * onv val * nstmt)%type.
  Definition labenv_empty : labenv := fun _ => None.

  Definition mkBlock L F f (_:var *params*nstmt):=
    blockI L F f.

  Inductive step : state -> event -> state -> Prop :=
  | nstepLet L E x e b v
    (def:op_eval E e = Some v)
    : step (L, E, nstmtLet x (Operation e) b) EvtTau (L, E[x<-Some v], b)

  | stepExtern L E x f Y s vl v
    (def:omap (op_eval E) Y = Some vl)
    : step  (L, E, nstmtLet x (Call f Y) s)
            (EvtExtern (ExternI f vl v))
            (L, E[x <- Some v], s)

  | nstepIfT L E e b1 b2 v
    (def:op_eval E e = Some v)
    (condTrue: val2bool v = true)
    : step (L, E, nstmtIf e b1 b2) EvtTau (L, E, b1)

  | nstepIfF L E e b1 b2 v
    (def:op_eval E e = Some v)
    (condFalse:val2bool v = false)
    : step (L, E, nstmtIf e b1 b2) EvtTau (L, E, b2)

  | nstepGoto L E l l' Y Z s L' F f
    (len:length Z = length Y)
    (lEQ:l = l') (* hack: otherwise inversions confuse guardedness checker in
                  simulation proofs*)

    (Ldef:L l = Some (blockI L' F f)) E'' vl
    (def:omap (op_eval E) Y = Some vl)
    (sdef : get F f (l', Z, s))
    (updOk:E[Z <-- List.map Some vl]  = E'')
    : step (L, E, nstmtApp l Y)
           EvtTau
           (L'[List.map (fst ∘ fst) F <-- List.map Some (mapi (mkBlock L' F) F)], E'', s)

  | stepFun L E F t
    : step (L, E, nstmtFun F t)
           EvtTau
           (L[List.map (fst ∘ fst) F <-- List.map Some (mapi (mkBlock L F) F)], E, t).

  Lemma step_internally_deterministic :
    internally_deterministic step.
  Proof.
    hnf; intros. inv H; inv H0; split; eauto; try congruence.
    rewrite Ldef0 in Ldef. inv Ldef. get_functional; subst. congruence.
  Qed.

  Lemma step_externally_determined
  : externally_determined step.
  Proof.
    hnf; intros.
    inv H; inv H0; eauto; try get_functional; try congruence.
    rewrite Ldef0 in Ldef. inv Ldef. get_functional; subst. congruence.
  Qed.

  Lemma step_dec
  : reddec2 step.
  Proof.
      hnf; intros. destruct x as [[L V] []].
      - destruct e.
        + case_eq (op_eval V e); intros. left. eexists EvtTau; eauto using step.
          right. stuck.
        + case_eq (omap (op_eval V) Y); intros; try now (right; stuck).
          left. eexists (EvtExtern (ExternI f l default_val)). eauto using step.
    - case_eq (op_eval V e); intros.
      left. case_eq (val2bool v); intros; eexists EvtTau; eauto using step.
      right. stuck.
    - case_eq (L l); intros.
      + destruct b as [L' F' f'].
        destruct (get_dec F' f') as [[[[l' Z] s] ?]|].
        * decide (l = l').
          decide (length Z = length Y).
          case_eq (omap (op_eval V) Y); intros;[| now (right; stuck2)].
          left. eexists EvtTau. econstructor. econstructor; eauto.
          right; stuck2. rewrite Ldef in H. inv H. get_functional; subst. congruence.
          right; stuck2. rewrite Ldef in H. inv H. get_functional; subst.
        * right; stuck2. rewrite Ldef in H. inv H. eauto.
      + right. stuck.
    - right. stuck.
    - left. exists EvtTau. eauto using step.
  Qed.

End I.

Definition state_result X (s:X*onv val*nstmt) : option val :=
  match s with
    | (_, E, nstmtReturn e) => op_eval E e
    | _ => None
  end.

Instance statetype_I : StateType I.state := {
  step := I.step;
  result := (@state_result I.labenv);
  step_dec := I.step_dec;
  step_internally_deterministic := I.step_internally_deterministic;
  step_externally_determined := I.step_externally_determined
}.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Structure.Initial.
Require Import Category.Structure.Terminal.
Require Import Category.Instance.Zero.
Require Import Category.Instance.One.

Require Import Coq.Arith.PeanoNat.
Require Import Coq.Lists.List.
Require Import Coq.Lists.ListSet.
Require Import Coq.Vectors.Fin.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

(* jww (2017-06-02): TODO
Import ListNotations.

(* This record establishes the structure of a concrete category's objects and
   arrows, in terms of fixed sets of natural numbers. It's main practical use
   is for building diagrams. *)

Record Concrete_Structure := {
  obs   : nat;
  arrs  : nat;

  composition : Fin.t arrs -> Fin.t arrs -> Fin.t arrs;
  composition_assoc {f g h} :
    composition f (composition g h) = composition (composition f g) h
}.

(* A concrete category has a fixed set of objects (of some decidable type, to
   differentiate them), and a fixed set of arrows between those objects. A
   frequent use of these is as index categories to build diagrams. *)

Program Definition Concrete (C : Concrete_Structure) :
  Category := {|
  obj     := Fin.t (obs C);
  hom     := fun _ _ => Fin.t (S (arrs C));
  homset  := Morphism_equality
  id      := fun _ => F1;
  compose := fun x y z f g => match f, g with
    | f,  F1 => f
    | F1, g  => g
    | f,  g  => f
    end
|}.
Next Obligation. destruct f; reflexivity. Qed.
Next Obligation. destruct f; reflexivity. Qed.
Next Obligation.
  destruct f, g, h; auto; f_equal.
  - pose proof (@composition_assoc S t t0 t1).
    destruct (composition S t0 t1); try tauto.
    destruct (composition S t t0); try tauto.
    destruct (composition S t t2); try tauto.
    destruct (composition S t3 t1); try tauto.
    subst; reflexivity.
  - destruct (composition S t t0); try tauto.
  - destruct (composition S t t0); try tauto.
Qed.
Next Obligation.
  destruct f, g, h; auto; f_equal.
  - pose proof (@composition_assoc S t t0 t1).
    destruct (composition S t0 t1); try tauto.
    destruct (composition S t t0); try tauto.
    destruct (composition S t t2); try tauto.
    destruct (composition S t3 t1); try tauto.
    subst; reflexivity.
  - destruct (composition S t t0); try tauto.
  - destruct (composition S t t0); try tauto.
Qed.

Module ConcreteInstances.

Set Transparent Obligations.

(* The 0 category has no objects and no morphisms. It is initial in Cat. *)

Program Definition Structure_0 : Concrete_Structure := {|
  obs  := 0;
  arrs := 0
|}.
Next Obligation. apply case0; auto. Qed.
Next Obligation. apply case0; auto. Qed.

Program Definition Concrete_0 := Concrete Structure_0.

Program Instance Map_0 `(C : Category) : Concrete_0 ⟶ C.
Next Obligation. inversion H. Qed.
Next Obligation. inversion X. Qed.
Next Obligation. inversion X. Qed.
Next Obligation. inversion X. Qed.

Program Instance Initial_0 : @Initial Cat := {
  Zero := Concrete_0;
  zero := Map_0
}.
Next Obligation.
  constructive.
  refine (case0 (fun _ => _) _). exact X.
  refine (case0 (fun _ => _) _). exact X.
  refine (case0 (fun _ => _) _). exact X.
  refine (case0 (fun _ => _) _). exact X.
  refine (case0 (fun _ => _) _). exact X.
  refine (case0 (fun _ => _) _). exact X.
  refine (case0 (fun _ => _) _). exact A0.
  refine (case0 (fun _ => _) _). exact A0.
Qed.

Program Instance Initial_0_is_0 : @Zero Cat Initial_0 ≅ 0.
Next Obligation. exact Id. Qed.
Next Obligation. exact Id. Qed.
Next Obligation.
  constructive.
  refine (case0 (fun _ => _) _). exact X.
  refine (case0 (fun _ => _) _). exact X.
  refine (case0 (fun _ => _) _). exact None.
  refine (case0 (fun _ => _) _); simpl.
  refine (case0 (fun _ => _) _); simpl. exact X.
  simpl; refine (case0 (fun _ => _) _).
  simpl; refine (case0 (fun _ => _) _).
Qed.
Next Obligation.
  constructive.
  refine (case0 (fun _ => _) _). exact X.
  refine (case0 (fun _ => _) _). exact X.
  refine (case0 (fun _ => _) _). exact None.
  refine (case0 (fun _ => _) _); simpl.
  refine (case0 (fun _ => _) _); simpl. exact X.
  simpl; refine (case0 (fun _ => _) _).
  simpl; refine (case0 (fun _ => _) _).
Qed.

(* The 1 category has one object and its identity morphism. It is terminal in
   Cat. *)

Program Definition Structure_1 : Concrete_Structure := {|
  obs  := 1;
  arrs := 0
|}.
Next Obligation. apply case0; auto. Qed.
Next Obligation. apply case0; auto. Qed.

Program Definition Concrete_1 := Concrete Structure_1.

Program Instance Map_1 `(C : Category) : C ⟶ Concrete_1 := {
  fobj := fun _ => F1;
  fmap := fun _ _ _ => id
}.

Program Instance Terminal_1 : @Terminal Cat := {
  One := Concrete_1;
  one := Map_1
}.
Next Obligation.
  constructive; auto; simpl.
  all:swap 2 4.
  - exact None.
  - exact None.
  - simpl.
    destruct (fmap[f] f0); simpl;
    destruct (fmap[g] f0); auto;
    pattern t; apply case0.
  - simpl.
    destruct (fmap[f] f0); simpl;
    destruct (fmap[g] f0); auto;
    pattern t; apply case0.
  - simpl.
    destruct (fmap[f] f0); simpl;
    destruct (fmap[g] f0); auto;
    pattern t; apply case0.
  - simpl.
    destruct (fmap[f] f0); simpl;
    destruct (fmap[g] f0); auto;
    pattern t; apply case0.
  - simpl.
    destruct (fmap[g] id); auto;
    pattern t; apply case0.
  - simpl.
    destruct (fmap[f] id); auto;
    pattern t; apply case0.
Qed.

Program Instance Terminal_1_is_1 : @One Cat Terminal_1 ≅ _1.
Next Obligation.
  functor; simpl; intros; reflexivity.
Defined.
Next Obligation.
  functor; simpl; intros; reflexivity.
Defined.
Next Obligation.
  constructive; intuition.
Qed.
Next Obligation.
  constructive; intuition.
  all:swap 2 4.
  - exact None.
  - exact None.
  - simpl.
    destruct f; auto;
    pattern t; apply case0.
  - simpl.
    destruct f; auto;
    pattern t; apply case0.
  - simpl.
    destruct f; auto;
    pattern t; apply case0.
  - simpl.
    destruct f; auto;
    pattern t; apply case0.
  - reflexivity.
  - reflexivity.
Qed.

(* The 2 category has two objects, their identity morphisms, and a morphism
   from the first to the second object. *)

Program Definition Structure_2 : Concrete_Structure := {|
  obs  := 2;
  arrs := 1
|}.
Next Obligation. exact None. Defined.

Definition Concrete_2 := Concrete Structure_2.

(* The 3 category has three objects, their identity morphisms, and morphisms
   from the first to the second object, the second to the third, and the first
   to the third (required by composition). *)

Program Definition Structure_3 : Concrete_Structure := {|
  obs  := 3;
  arrs := 3;
  composition := fun f g =>

|}.

Definition Concrete_3 := Concrete Structure_3.

End ConcreteInstances.
*)


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^222 - 117
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 7%nat;
    base := 32;
    bitwidth := 32;
    s := 2^222;
    c := [(1, 117)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal20.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (x:lst) (IHx:@eq bool (even (len (append x x))) true):@eq bool (negb (even (len (append x (Cons n x))))) true.
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal20_theorem0_40_lem/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for bool.

              Derive Arbitrary for bool.

              Instance Dec_Eq_bool : Dec_Eq bool.

              Proof. dec_eq. Qed.
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (x:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"x:" ++ "(" ++ show x ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  x.
QuickChick collect_data.
Success.


(** * Limits and Colimits *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Functor.Composition.Core.
Require Import ExponentialLaws.Law1.Functors FunctorCategory.Core.
Require Import KanExtensions.Core InitialTerminalCategory.Core NatCategory.
Require Import Functor.Paths.
Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *)
Import Comma.Core.
Local Set Warnings Append "notation-overridden".

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope functor_scope.
Local Open Scope category_scope.

(** ** The diagonal or "constant diagram" functor Δ *)
Section diagonal_functor.
  Context `{Funext}.
  Variables C D : PreCategory.

  (**
     Quoting Dwyer and Spalinski:

     There is a diagonal or ``constant diagram'' functor

<<
     Δ : C → Cᴰ,
>>

     which carries an object [X : C] to the constant functor [Δ X : D
     -> C] (by definition, this ``constant functor'' sends each object
     of [D] to [X] and each morphism of [D] to [Identity X]). The
     functor Δ assigns to each morphism [f : X -> X'] of [C] the
     constant natural transformation [t(f) : Δ X -> Δ X'] determined
     by the formula [t(f) d = f] for each object [d] of [D].  **)

  (** We use [C¹] rather than [C] for judgemental compatibility with
      Kan extensions. *)

  Definition diagonal_functor : Functor (1 -> C) (D -> C)
    := @pullback_along _ D 1 C (Functors.to_terminal _).

  Definition diagonal_functor' : Functor C (D -> C)
    := diagonal_functor o ExponentialLaws.Law1.Functors.inverse _.

  Section convert.
    Lemma diagonal_functor_diagonal_functor' X
    : diagonal_functor X = diagonal_functor' (X (center _)).
    Proof.
      path_functor.
      simpl.
      repeat (apply path_forall || intro).
      apply identity_of.
    Qed.
  End convert.
End diagonal_functor.

Arguments diagonal_functor : simpl never.

Section diagonal_functor_lemmas.
  Context `{Funext}.
  Variables C D D' : PreCategory.

  Lemma compose_diagonal_functor x (F : Functor D' D)
  : diagonal_functor C D x o F = diagonal_functor _ _ x.
  Proof.
    path_functor.
  Qed.

  Definition compose_diagonal_functor_natural_transformation
             x (F : Functor D' D)
  : NaturalTransformation (diagonal_functor C D x o F) (diagonal_functor _ _ x)
    := Build_NaturalTransformation
         (diagonal_functor C D x o F)
         (diagonal_functor _ _ x)
         (fun z => identity _)
         (fun _ _ _ => transitivity
                         (left_identity _ _ _ _)
                         (symmetry
                            _ _
                            (right_identity _ _ _ _))).
End diagonal_functor_lemmas.

#[export]
Hint Rewrite @compose_diagonal_functor : category.

Section Limit.
  Context `{Funext}.
  Variables C D : PreCategory.
  Variable F : Functor D C.

  (** ** Definition of Limit *)
  (**
     Quoting Dwyer and Spalinski:

     Let [D] be a small category and [F : D -> C] a functor. A limit
     for [F] is an object [L] of [C] together with a natural
     transformation [t : Δ L -> F] such that for every object [X] of
     [C] and every natural transformation [s : Δ X -> F], there exists
     a unique map [s' : X -> L] in [C] such that [t (Δ s') = s].  **)

  Definition IsLimit
    := @IsRightKanExtensionAlong _ D 1 C (Functors.to_terminal _) F.
  (*Definition IsLimit' := @IsTerminalMorphism (_ -> _) (_ -> _) (diagonal_functor C D) F.*)
  (*  Definition Limit (L : C) :=
    { t : SmallNaturalTransformation ((diagonal_functor C D) L) F &
      forall X : C, forall s : SmallNaturalTransformation ((diagonal_functor C D) X) F,
        { s' : C.(Morphism) X L |
          unique
          (fun s' => SNTComposeT t ((diagonal_functor C D).(MorphismOf) s') = s)
          s'
        }
    }.*)

  (**
     Quoting Dwyer and Spalinski:

     Let [D] be a small category and [F : D -> C] a functor. A colimit
     for [F] is an object [c] of [C] together with a natural
     transformation [t : F -> Δ c] such that for every object [X] of
     [C] and every natural transformation [s : F -> Δ X], there exists
     a unique map [s' : c -> X] in [C] such that [(Δ s') t = s].  **)

  (** ** Definition of Colimit *)
  Definition IsColimit
    := @IsLeftKanExtensionAlong _ D 1 C (Functors.to_terminal _) F.
  (*Definition IsColimit' := @IsInitialMorphism (_ -> _) (_ -> _) F (diagonal_functor C D).*)
  (*  Definition Colimit (c : C) :=
    { t : SmallNaturalTransformation F ((diagonal_functor C D) c) &
      forall X : C, forall s : SmallNaturalTransformation F ((diagonal_functor C D) X),
        { s' : C.(Morphism) c X | is_unique s' /\
          SNTComposeT ((diagonal_functor C D).(MorphismOf) s') t = s
        }
    }.*)
  (** TODO(JasonGross): Figure out how to get good introduction and elimination rules working, which don't mention spurious identities. *)
  (*Section AbstractionBarrier.
    Section Limit.
      Set Printing  Implicit.
      Section IntroductionAbstractionBarrier.
        Local Open Scope morphism_scope.

        Definition Build_IsLimit
                 (lim_obj : C)
                 (lim_mor : morphism (D -> C)
                                     (diagonal_functor' C D lim_obj)
                                     F)
                 (lim := CommaCategory.Build_object
                           (diagonal_functor C D)
                           !(F : object (_ -> _))
                           !lim_obj
                           (center _)
                           lim_mor)
                 (UniversalProperty
                  : forall (lim_obj' : C)
                           (lim_mor' : morphism (D -> C)
                                                (diagonal_functor' C D lim_obj')
                                                F),
                      Contr { m : morphism C lim_obj' lim_obj
                            | lim_mor o morphism_of (diagonal_functor' C D) m = lim_mor' })
        : IsTerminalMorphism lim.
        Proof.
          apply Build_IsTerminalMorphism.
          intros A' p'.
          specialize (UniversalProperty (A' (center _))).*)
End Limit.

(** TODO(JasonGross): Port MorphismsBetweenLimits from catdb *)


From iris_examples.logrel_heaplang Require Export ltyping.
From iris.heap_lang Require Import adequacy.
From iris.heap_lang Require Import proofmode.

Lemma ltyped_safety `{heapPreG Σ} e σ es σ' e' :
  (∀ `{heapG Σ}, ∃ A, ∅ ⊨ e : A) →
  rtc erased_step ([e], σ) (es, σ') → e' ∈ es →
  is_Some (to_val e') ∨ reducible e' σ'.
Proof.
  intros Hty. apply (heap_adequacy Σ NotStuck e σ (λ _, True))=> // ?.
  destruct (Hty _) as [A He]. iStartProof. iDestruct (He $! ∅) as "#He".
  iSpecialize ("He" with "[]"); first by rewrite /env_ltyped.
  rewrite subst_map_empty. iApply (wp_wand with "He"); auto.
Qed.