Require Import Basics.
Require Import Cubical.DPath.
Require Import Cubical.PathSquare.
Require Import Cubical.DPathSquare.
Require Import Cubical.PathCube.

Declare Scope dcube_scope.
Delimit Scope dcube_scope with dcube.

(* In this file we define a dependent cube *)

(* Dependent cubes *)
Definition DPathCube {A} (B : A -> Type)
  {x000 x010 x100 x110 x001 x011 x101 x111 : A}
  {p0i0 : x000 = x010} {p1i0 : x100 = x110}
  {pi00 : x000 = x100} {pi10 : x010 = x110}
  {p0i1 : x001 = x011} {p1i1 : x101 = x111}
  {pi01 : x001 = x101} {pi11 : x011 = x111}
  {p00i : x000 = x001} {p01i : x010 = x011}
  {p10i : x100 = x101} {p11i : x110 = x111}
  {s0ii : PathSquare p0i0 p0i1 p00i p01i}
  {s1ii : PathSquare p1i0 p1i1 p10i p11i}
  {sii0 : PathSquare p0i0 p1i0 pi00 pi10}
  {sii1 : PathSquare p0i1 p1i1 pi01 pi11}
  {si0i : PathSquare p00i p10i pi00 pi01}
  {si1i : PathSquare p01i p11i pi10 pi11}
  (cube : PathCube s0ii s1ii sii0 sii1 si0i si1i)
  {b000 : B x000} {b010 : B x010} {b100 : B x100} {b110 : B x110}
  {b001 : B x001} {b011 : B x011} {b101 : B x101} {b111 : B x111 }
  {bp0i0 : DPath B p0i0 b000 b010} {bp1i0 : DPath B p1i0 b100 b110}
  {bpi00 : DPath B pi00 b000 b100} {bpi10 : DPath B pi10 b010 b110}
  {bp0i1 : DPath B p0i1 b001 b011} {bp1i1 : DPath B p1i1 b101 b111}
  {bpi01 : DPath B pi01 b001 b101} {bpi11 : DPath B pi11 b011 b111}
  {bp00i : DPath B p00i b000 b001} {bp01i : DPath B p01i b010 b011}
  {bp10i : DPath B p10i b100 b101} {bp11i : DPath B p11i b110 b111}
  (bs0ii : DPathSquare B s0ii bp0i0 bp0i1 bp00i bp01i)
  (bs1ii : DPathSquare B s1ii bp1i0 bp1i1 bp10i bp11i)
  (bsii0 : DPathSquare B sii0 bp0i0 bp1i0 bpi00 bpi10)
  (bsii1 : DPathSquare B sii1 bp0i1 bp1i1 bpi01 bpi11)
  (bsi0i : DPathSquare B si0i bp00i bp10i bpi00 bpi01)
  (bsi1i : DPathSquare B si1i bp01i bp11i bpi10 bpi11) : Type.
Proof.
  destruct cube.
  exact (PathCube bs0ii bs1ii bsii0 bsii1 bsi0i bsi1i).
Defined.

Definition equiv_dc_const' {A B : Type}
  {x000 x010 x100 x110 x001 x011 x101 x111 : A}
  {p0i0 : x000 = x010} {p1i0 : x100 = x110}
  {pi00 : x000 = x100} {pi10 : x010 = x110}
  {p0i1 : x001 = x011} {p1i1 : x101 = x111}
  {pi01 : x001 = x101} {pi11 : x011 = x111}
  {p00i : x000 = x001} {p01i : x010 = x011}
  {p10i : x100 = x101} {p11i : x110 = x111}
  {s0ii : PathSquare p0i0 p0i1 p00i p01i}
  {s1ii : PathSquare p1i0 p1i1 p10i p11i}
  {sii0 : PathSquare p0i0 p1i0 pi00 pi10}
  {sii1 : PathSquare p0i1 p1i1 pi01 pi11}
  {si0i : PathSquare p00i p10i pi00 pi01}
  {si1i : PathSquare p01i p11i pi10 pi11}
  {cube : PathCube s0ii s1ii sii0 sii1 si0i si1i}
  {b000 b010 b100 b110 b001 b011 b101 b111 : B}
  {bp0i0 : DPath (fun _ => B) p0i0 b000 b010}
  {bp1i0 : DPath (fun _ => B) p1i0 b100 b110}
  {bpi00 : DPath (fun _ => B) pi00 b000 b100}
  {bpi10 : DPath (fun _ => B) pi10 b010 b110}
  {bp0i1 : DPath (fun _ => B) p0i1 b001 b011}
  {bp1i1 : DPath (fun _ => B) p1i1 b101 b111}
  {bpi01 : DPath (fun _ => B) pi01 b001 b101}
  {bpi11 : DPath (fun _ => B) pi11 b011 b111}
  {bp00i : DPath (fun _ => B) p00i b000 b001}
  {bp01i : DPath (fun _ => B) p01i b010 b011}
  {bp10i : DPath (fun _ => B) p10i b100 b101}
  {bp11i : DPath (fun _ => B) p11i b110 b111}
  {bs0ii : DPathSquare (fun _ => B) s0ii bp0i0 bp0i1 bp00i bp01i}
  {bs1ii : DPathSquare (fun _ => B) s1ii bp1i0 bp1i1 bp10i bp11i}
  {bsii0 : DPathSquare (fun _ => B) sii0 bp0i0 bp1i0 bpi00 bpi10}
  {bsii1 : DPathSquare (fun _ => B) sii1 bp0i1 bp1i1 bpi01 bpi11}
  {bsi0i : DPathSquare (fun _ => B) si0i bp00i bp10i bpi00 bpi01}
  {bsi1i : DPathSquare (fun _ => B) si1i bp01i bp11i bpi10 bpi11}
  : PathCube
    (ds_const'^-1 bs0ii) (ds_const'^-1 bs1ii) (ds_const'^-1 bsii0)
    (ds_const'^-1 bsii1) (ds_const'^-1 bsi0i) (ds_const'^-1 bsi1i)
    <~> DPathCube (fun _ => B) cube bs0ii bs1ii bsii0 bsii1 bsi0i bsi1i.
Proof.
  by destruct cube.
Defined.

Notation dc_const' := equiv_dc_const'.

Definition equiv_dc_const {A B : Type}
  {x000 x010 x100 x110 x001 x011 x101 x111 : A}
  {p0i0 : x000 = x010} {p1i0 : x100 = x110}
  {pi00 : x000 = x100} {pi10 : x010 = x110}
  {p0i1 : x001 = x011} {p1i1 : x101 = x111}
  {pi01 : x001 = x101} {pi11 : x011 = x111}
  {p00i : x000 = x001} {p01i : x010 = x011}
  {p10i : x100 = x101} {p11i : x110 = x111}
  {s0ii : PathSquare p0i0 p0i1 p00i p01i}
  {s1ii : PathSquare p1i0 p1i1 p10i p11i}
  {sii0 : PathSquare p0i0 p1i0 pi00 pi10}
  {sii1 : PathSquare p0i1 p1i1 pi01 pi11}
  {si0i : PathSquare p00i p10i pi00 pi01}
  {si1i : PathSquare p01i p11i pi10 pi11}
  {cube : PathCube s0ii s1ii sii0 sii1 si0i si1i}
  {b000 b010 b100 b110 b001 b011 b101 b111 : B}
  {bp0i0 : b000 = b010} {bp1i0 : b100 = b110}
  {bpi00 : b000 = b100} {bpi10 : b010 = b110}
  {bp0i1 : b001 = b011} {bp1i1 : b101 = b111}
  {bpi01 : b001 = b101} {bpi11 : b011 = b111}
  {bp00i : b000 = b001} {bp01i : b010 = b011}
  {bp10i : b100 = b101} {bp11i : b110 = b111}
  {bs0ii : PathSquare bp0i0 bp0i1 bp00i bp01i}
  {bs1ii : PathSquare bp1i0 bp1i1 bp10i bp11i}
  {bsii0 : PathSquare bp0i0 bp1i0 bpi00 bpi10}
  {bsii1 : PathSquare bp0i1 bp1i1 bpi01 bpi11}
  {bsi0i : PathSquare bp00i bp10i bpi00 bpi01}
  {bsi1i : PathSquare bp01i bp11i bpi10 bpi11}
  : PathCube bs0ii bs1ii bsii0 bsii1 bsi0i bsi1i
  <~> DPathCube (fun _ => B) cube (ds_const bs0ii) (ds_const bs1ii) (ds_const bsii0)
     (ds_const bsii1) (ds_const bsi0i) (ds_const bsi1i).
Proof.
  by destruct cube.
Defined.

Notation dc_const := equiv_dc_const.

(** Dependent Kan fillers *)

Section Kan.
  Context {A} {x000 x010 x100 x110 x001 x011 x101 x111 : A}
    {p0i0 : x000 = x010} {p1i0 : x100 = x110} {pi00 : x000 = x100}
    {pi10 : x010 = x110} {p0i1 : x001 = x011} {p1i1 : x101 = x111}
    {pi01 : x001 = x101} {pi11 : x011 = x111} {p00i : x000 = x001}
    {p01i : x010 = x011} {p10i : x100 = x101} {p11i : x110 = x111}
    {s1ii : PathSquare p1i0 p1i1 p10i p11i} {s0ii : PathSquare p0i0 p0i1 p00i p01i}
    {sii0 : PathSquare p0i0 p1i0 pi00 pi10} {sii1 : PathSquare p0i1 p1i1 pi01 pi11}
    {si0i : PathSquare p00i p10i pi00 pi01} {si1i : PathSquare p01i p11i pi10 pi11}
    (c : PathCube s0ii s1ii sii0 sii1 si0i si1i)
    {P : A -> Type} {y000 y010 y100 y110 y001 y011 y101 y111}
    {q0i0 : DPath P p0i0 y000 y010} {q1i0 : DPath P p1i0 y100 y110} {qi00 : DPath P pi00 y000 y100}
    {qi10 : DPath P pi10 y010 y110} {q0i1 : DPath P p0i1 y001 y011} {q1i1 : DPath P p1i1 y101 y111}
    {qi01 : DPath P pi01 y001 y101} {qi11 : DPath P pi11 y011 y111} {q00i : DPath P p00i y000 y001}
    {q01i : DPath P p01i y010 y011} {q10i : DPath P p10i y100 y101} {q11i : DPath P p11i y110 y111}.

  Definition dc_fill_left
    (t1ii : DPathSquare P s1ii q1i0 q1i1 q10i q11i)
    (tii0 : DPathSquare P sii0 q0i0 q1i0 qi00 qi10) (tii1 : DPathSquare P sii1 q0i1 q1i1 qi01 qi11)
    (ti0i : DPathSquare P si0i q00i q10i qi00 qi01) (ti1i : DPathSquare P si1i q01i q11i qi10 qi11)
    : {t0ii : DPathSquare P s0ii q0i0 q0i1 q00i q01i & DPathCube P c t0ii t1ii tii0 tii1 ti0i ti1i}.
  Proof.
    destruct c.
    apply cu_fill_left.
  Defined.

  Definition dc_fill_right
    (t0ii : DPathSquare P s0ii q0i0 q0i1 q00i q01i)
    (tii0 : DPathSquare P sii0 q0i0 q1i0 qi00 qi10) (tii1 : DPathSquare P sii1 q0i1 q1i1 qi01 qi11)
    (ti0i : DPathSquare P si0i q00i q10i qi00 qi01) (ti1i : DPathSquare P si1i q01i q11i qi10 qi11)
    : {t1ii : DPathSquare P s1ii q1i0 q1i1 q10i q11i & DPathCube P c t0ii t1ii tii0 tii1 ti0i ti1i}.
  Proof.
    destruct c.
    apply cu_fill_right.
  Defined.

  Definition dc_fill_top
    (t0ii : DPathSquare P s0ii q0i0 q0i1 q00i q01i) (t1ii : DPathSquare P s1ii q1i0 q1i1 q10i q11i)
                                                    (tii1 : DPathSquare P sii1 q0i1 q1i1 qi01 qi11)
    (ti0i : DPathSquare P si0i q00i q10i qi00 qi01) (ti1i : DPathSquare P si1i q01i q11i qi10 qi11)
    : {tii0 : DPathSquare P sii0 q0i0 q1i0 qi00 qi10 & DPathCube P c t0ii t1ii tii0 tii1 ti0i ti1i}.
  Proof.
    destruct c.
    apply cu_fill_top.
  Defined.

  Definition dc_fill_bottom
    (t0ii : DPathSquare P s0ii q0i0 q0i1 q00i q01i) (t1ii : DPathSquare P s1ii q1i0 q1i1 q10i q11i)
    (tii0 : DPathSquare P sii0 q0i0 q1i0 qi00 qi10)
    (ti0i : DPathSquare P si0i q00i q10i qi00 qi01) (ti1i : DPathSquare P si1i q01i q11i qi10 qi11)
    : {tii1 : DPathSquare P sii1 q0i1 q1i1 qi01 qi11 & DPathCube P c t0ii t1ii tii0 tii1 ti0i ti1i}.
  Proof.
    destruct c.
    apply cu_fill_bottom.
  Defined.

  Definition dc_fill_front
    (t0ii : DPathSquare P s0ii q0i0 q0i1 q00i q01i) (t1ii : DPathSquare P s1ii q1i0 q1i1 q10i q11i)
    (tii0 : DPathSquare P sii0 q0i0 q1i0 qi00 qi10) (tii1 : DPathSquare P sii1 q0i1 q1i1 qi01 qi11)
                                                    (ti1i : DPathSquare P si1i q01i q11i qi10 qi11)
    : {ti0i : DPathSquare P si0i q00i q10i qi00 qi01 & DPathCube P c t0ii t1ii tii0 tii1 ti0i ti1i}.
  Proof.
    destruct c.
    apply cu_fill_front.
  Defined.

  Definition dc_fill_back
    (t0ii : DPathSquare P s0ii q0i0 q0i1 q00i q01i) (t1ii : DPathSquare P s1ii q1i0 q1i1 q10i q11i)
    (tii0 : DPathSquare P sii0 q0i0 q1i0 qi00 qi10) (tii1 : DPathSquare P sii1 q0i1 q1i1 qi01 qi11)
    (ti0i : DPathSquare P si0i q00i q10i qi00 qi01)
    : {ti1i : DPathSquare P si1i q01i q11i qi10 qi11 & DPathCube P c t0ii t1ii tii0 tii1 ti0i ti1i}.
  Proof.
    destruct c.
    apply cu_fill_back.
  Defined.

End Kan.


(* In this file we formalize the definition of a certain monoidal structure on a display category and show that the total category has the structure of a monoidal category if the base category is a monoidal category and the displayed category has this certain monoidal structure.

The data of a displayed monoidal category consists of:
    - A (base) category C.
    - A displayed category D over C.
    - A displayed tensor DT which consists of:
                  - D_x → D_y → D_{x ⊗_{T} y} : a → (b → a⊗_{{DT}} b).
                  - (a -->[f] a') → (b -->[g] b') → ( (a ⊗_{{DT}} b) -->[f ⊗^{T} g] (a' ⊗_{{DT}} b') : f'→g'→ (f' ⊗^{{DT}} g').
    - A term i : D I, called the displayed unit.
    - A natural transformation dlu : (i ⊗_{{TD}} (-)) -->[lu_x] (-) with naturality condition:
                  - (id_i ⊗^{{TD}} f') ;; dlu_b = dlu_a ;; f'
                  where the equality is dependent over the naturality condition of lu w.r.t. f, i.e. we have to transport.
    - A natural transformation dru : ((-) ⊗_{{TD}} i) -->[ru_x] (-) with naturality condition:
                  - (f' ⊗^{{TD}} id_i) ;; dru_b = dru_a ;; f'
                  where the equality is dependent over the naturality condition of ru w.r.t. f, i.e. we have to transport.
    - A natural transformation dα : ((-)⊗(-))⊗(-) -->[α_{x,y,z}] (-)⊗((-)⊗(-)) with naturality condition:
                  - dα_{a,b,c} ;; (f' ⊗^{{TD}} (g' ⊗^{{TD}} h')) = (f'⊗g')⊗h' ;; dα_{a',b',c'}
And the properties of a displayed monoidal category are given by:
    - Displayed triangle identity:
                  - dα_{a,i,b} ;; (id_a ⊗ dlu_b) = dru_a ⊗ id_b.
    - Displayed pentagon_identity:
                  -

*)

Require Import UniMath.Foundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesCurried.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

Section displayedmonoidalcategories.

  Context (C : category) (D : disp_cat C) (T : tensor_data C) (I : C) (α : associator_data T) (lu : leftunitor_data T I) (ru : rightunitor_data T I) (tid : tensorfunctor_id T) (tcomp : tensorfunctor_comp T) (αnat : associator_naturality α) (αiso : associator_is_natiso α) (lunat : leftunitor_naturality lu) (luiso : leftunitor_is_natiso lu) (runat : rightunitor_naturality ru) (ruiso : rightunitor_is_natiso ru) (tri : triangle_identity lu ru α) (pen : pentagon_identity α).

  Definition displayedtensor_data : UU :=
    ∑ (dt : ∏ (x y : C), (D x) → (D y) -> (D (x ⊗_{T} y))),
    ∏ (x x' y y' : C), ∏ (f : C⟦x,x'⟧) (g : C⟦y,y'⟧), ∏ (a : D x) (a' : D x') (b : D y) (b' : D y'),
      (a -->[f] a') -> (b -->[g] b') -> ((dt x y a b)-->[f ⊗^{T} g] (dt x' y' a' b')).

  Definition displayedtensoronobjects_from_displayedtensordata (dtd : displayedtensor_data)
    :  ∏ (x y : C), (D x) → (D y) -> (D (x ⊗_{T} y)) := pr1 dtd.
  Notation "a ⊗_{{ dtd }} b" := (displayedtensoronobjects_from_displayedtensordata dtd _ _ a b) (at level 31).

  Definition displayedtensoronmorphisms_from_displayedtensordata (dtd : displayedtensor_data) :
    ∏ (x x' y y' : C) (f : C ⟦ x, x' ⟧) (g : C ⟦ y, y' ⟧) (a : D x) (a' : D x') (b : D y) (b' : D y'),
  (a -->[ f] a') -> (b -->[ g] b') -> ((a ⊗_{{dtd}} b) -->[ f ⊗^{ T} g ] (a' ⊗_{{ dtd}} b'))
    := pr2 dtd.
  Notation "f' ⊗^{{ dtd }} g'" := (displayedtensoronmorphisms_from_displayedtensordata dtd _ _ _ _ _ _ _ _ _ _ f' g'  ) (at level 31).

  Definition displayedassociator_data (dtd : displayedtensor_data) : UU :=
    ∏ (x y z : C), ∏ (a : D x) (b : D y) (c : D z),
      ((a ⊗_{{dtd}} b) ⊗_{{dtd}} c) -->[(α x y z)] (a ⊗_{{dtd}} (b ⊗_{{dtd}} c)).

  Definition displayedleftunitor_data (dtd : displayedtensor_data) (i : D I) : UU
    := ∏ (x : C), ∏ (a : D x), ((i ⊗_{{dtd}} a)-->[(lu x)] a).

  Definition displayedrightunitor_data (dtd : displayedtensor_data) (i : D I) : UU
    := ∏ (x : C), ∏ (a : D x), ((a ⊗_{{dtd}} i)-->[(ru x)] a).

  Definition displayedmonoidalcat_data : UU :=
    ∑ dtd : displayedtensor_data, ∑ i : D I,
          (displayedleftunitor_data dtd i) × (displayedrightunitor_data dtd i) × (displayedassociator_data dtd).

  Definition displayedtensordata_from_dispmoncatdata (DMD : displayedmonoidalcat_data) : displayedtensor_data := pr1 DMD.
  Coercion displayedtensordata_from_dispmoncatdata : displayedmonoidalcat_data >-> displayedtensor_data.

  Definition displayedunit_from_dispmoncatdata (DMD : displayedmonoidalcat_data) : D I := pr1 (pr2 DMD).
  Coercion displayedunit_from_dispmoncatdata : displayedmonoidalcat_data >-> ob_disp.

  Definition displayedleftunitordata_from_dispmoncatdata (DMD : displayedmonoidalcat_data) : displayedleftunitor_data DMD DMD := pr1 (pr2 (pr2 DMD)).
  Coercion displayedleftunitordata_from_dispmoncatdata : displayedmonoidalcat_data >-> displayedleftunitor_data.

  Definition displayedrightunitordata_from_dispmoncatdata (DMD : displayedmonoidalcat_data) : displayedrightunitor_data DMD DMD := pr1 (pr2 (pr2 (pr2 DMD))).
  Coercion displayedrightunitordata_from_dispmoncatdata : displayedmonoidalcat_data >-> displayedrightunitor_data.

  Definition displayedassociatordata_from_dispmoncatdata (DMD : displayedmonoidalcat_data) : displayedassociator_data DMD := pr2 (pr2 (pr2 (pr2 DMD))).
  Coercion displayedassociatordata_from_dispmoncatdata : displayedmonoidalcat_data >-> displayedassociator_data.

  (** PROPERTIES **)
  Definition displayedtensor_id (dtd : displayedtensor_data)
    := ∏ (x y : C), ∏ (a : D x) (b : D y),  ((id_disp a) ⊗^{{dtd}} (id_disp b))  = transportb _ (tid x y) (id_disp (a ⊗_{{dtd}} b)).

  Definition displayedtensor_comp (dtd : displayedtensor_data)
    := ∏ (x y x' y' x'' y'': C), ∏ (a : D x) (b : D y) (a' : D x') (b' : D y') (a'' : D x'') (b'' : D y''),
      ∏ (f1 : C⟦x, x'⟧) (g1 : C⟦y,y'⟧) (f2 : C⟦x',x''⟧) (g2 : C⟦y',y''⟧) (f1' : a -->[f1] a') (g1' : b -->[g1] b') (f2' : a' -->[f2] a'') (g2' : b' -->[g2] b''), ((f1'⊗^{{dtd}} g1') ;; (f2'⊗^{{dtd}} g2')) = transportb _ (tcomp x y x' y' x'' y'' f1 f2 g1 g2) ((f1';;f2') ⊗^{{dtd}} (g1';;g2')).

  Definition displayedassociator_naturality {dtd : displayedtensor_data} (dα : displayedassociator_data dtd) : UU :=
    ∏ (x x' y y' z z' : C), ∏ (a : D x) (a' : D x') (b : D y) (b' : D y') (c : D z) (c' : D z'),
      ∏ (f : C⟦x,x'⟧) (g : C⟦y,y'⟧) (h : C⟦z,z'⟧), ∏ (f' : a-->[f] a') (g' : b -->[g] b') (h' : c -->[h] c'),
      ((dα x y z a b c) ;; (f' ⊗^{{dtd}} (g' ⊗^{{dtd}} h'))) = transportb _ (αnat _ _ _ _ _ _ f g h) (((f' ⊗^{{dtd}} g') ⊗^{{dtd}} h') ;; dα _ _ _ a' b' c').

  Definition displayedassociator_is_nat_iso {dtd : displayedtensor_data} (dα : displayedassociator_data dtd) : UU :=
    ∏ (x y z : C), ∏ (a : D x) (b : D y) (c : D z), is_z_iso_disp ((α x y z),,(αiso x y z)) (dα x y z a b c).

  Definition displayedleftunitor_naturality {i : D I} {dtd : displayedtensor_data} (dlud : displayedleftunitor_data dtd i) : UU :=
    ∏ (x y : C), ∏ (a : D x) (b : D y) (f : C⟦x,y⟧) (f' : a -->[f] b),
      (dlud x a) ;; f' = transportb _ (lunat x y f) (((id_disp i) ⊗^{{dtd}} f') ;; (dlud y b)).

  Definition displayedleftunitor_is_nat_iso {i : D I} {dtd : displayedtensor_data} (dlu : displayedleftunitor_data dtd i) : UU :=
    ∏ (x : C), ∏ (a : D x), is_z_iso_disp (lu x,, luiso x) (dlu x a).

  Definition displayedrightunitor_naturality {dtd : displayedtensor_data} {i : D I} (drud : displayedrightunitor_data dtd i) : UU :=
    ∏ (x y : C), ∏ (a : D x) (b : D y) (f : C⟦x,y⟧) (f' : a -->[f] b),
      ((drud x a) ;; f') = transportb _ (runat x y f) (( f' ⊗^{{dtd}}  (id_disp i)) ;; (drud y b)).

  Definition displayedrightunitor_is_nat_iso {i : D I} {dtd : displayedtensor_data} (dru : displayedrightunitor_data dtd i) : UU :=
    ∏ (x : C), ∏ (a : D x), is_z_iso_disp (ru x,, ruiso x) (dru x a).

  Definition displayedtriangle_identity {dtd : displayedtensor_data} {i : D I} (dlud : displayedleftunitor_data dtd i) (drud : displayedrightunitor_data dtd i) (dα : displayedassociator_data dtd) := ∏ (x y : C), ∏ (a : D x) (b : D y),
      ((dα x I y a i b) ;; ((id_disp a)  ⊗^{{dtd}} dlud y b )) = transportb _ (tri x y) ((drud x a) ⊗^{{dtd}} id_disp b).

  Definition displayedpentagon_identity {dtd : displayedtensor_data} (dα : displayedassociator_data dtd) : UU
    := ∏ (w x y z: C), ∏ (e : D w) (a : D x) (b : D y) (c : D z),
      (((dα _ _ _ e a b) ⊗^{{dtd}} (id_disp c)) ;; (dα _ _ _ e (a ⊗_{{dtd}} b) c) ;; ((id_disp e) ⊗^{{dtd}}  (dα _ _ _  a b c))) = transportb _ (pen w x y z) ((dα (w ⊗_{T} x) y z (e ⊗_{{dtd}} a) b c) ;; (dα w x (y ⊗_{T} z) e a (b ⊗_{{dtd}} c))).

  Definition displayedmonoidal_laws (DMD :  displayedmonoidalcat_data) : UU :=
    (displayedtensor_id DMD) × (displayedtensor_comp DMD) ×
                             (displayedassociator_naturality DMD) × (displayedassociator_is_nat_iso DMD) ×
                             (displayedleftunitor_naturality DMD) × (displayedleftunitor_is_nat_iso DMD) ×
                             (displayedrightunitor_naturality DMD) × (displayedrightunitor_is_nat_iso DMD) ×
                             (displayedtriangle_identity DMD DMD DMD) × (displayedpentagon_identity DMD).

  Definition displayedtensorid_from_monoidallaws {DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedtensor_id DMD := pr1 DML.
Coercion displayedtensorid_from_monoidallaws : displayedmonoidal_laws >-> displayedtensor_id.

Definition displayedtensorcomp_from_monoidallaws {DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedtensor_comp DMD := pr1 (pr2 DML).
Coercion displayedtensorcomp_from_monoidallaws : displayedmonoidal_laws >-> displayedtensor_comp.

Definition displayedassociatornaturality_from_monoidallaws {DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedassociator_naturality DMD := pr1 (pr2 (pr2 DML)).
Coercion displayedassociatornaturality_from_monoidallaws : displayedmonoidal_laws >-> displayedassociator_naturality.

Definition displayedassociatorisiso_from_monoidallaws {DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedassociator_is_nat_iso DMD := pr1 (pr2 (pr2 (pr2 DML))).
Coercion displayedassociatorisiso_from_monoidallaws : displayedmonoidal_laws >-> displayedassociator_is_nat_iso.

Definition displayedleftunitornaturality_from_monoidallaws {DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedleftunitor_naturality DMD := pr1 (pr2 (pr2 (pr2 (pr2 DML)))).
Coercion displayedleftunitornaturality_from_monoidallaws : displayedmonoidal_laws >-> displayedleftunitor_naturality.

Definition displayedleftunitorisiso_from_monoidallaws {DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedleftunitor_is_nat_iso DMD := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 DML))))).
Coercion displayedleftunitorisiso_from_monoidallaws : displayedmonoidal_laws >-> displayedleftunitor_is_nat_iso.

Definition displayedrightunitornaturality_from_monoidallaws{DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedrightunitor_naturality DMD := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 DML)))))).
Coercion displayedrightunitornaturality_from_monoidallaws : displayedmonoidal_laws >-> displayedrightunitor_naturality.

Definition displayedrightunitorisiso_from_monoidallaws {DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedrightunitor_is_nat_iso DMD := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 DML))))))).
Coercion displayedrightunitorisiso_from_monoidallaws : displayedmonoidal_laws >-> displayedrightunitor_is_nat_iso.

Definition displayedtriangleidentity_from_monoidallaws {DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedtriangle_identity DMD DMD DMD := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 DML)))))))).
Coercion displayedtriangleidentity_from_monoidallaws : displayedmonoidal_laws >-> displayedtriangle_identity.

Definition displayedpentagonidentity_from_monoidallaws {DMD : displayedmonoidalcat_data} (DML : displayedmonoidal_laws DMD) : displayedpentagon_identity DMD := pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 DML)))))))).
Coercion displayedpentagonidentity_from_monoidallaws : displayedmonoidal_laws >-> displayedpentagon_identity.

End displayedmonoidalcategories.


From Equations Require Import Equations.

Section box.
  Universe u.
  Context {A : Type@{u}} `(EA : EqDec A).

  Inductive box : Type@{u} :=
  | pack : A -> box.
  Derive NoConfusion for box.

  Derive EqDec for box.
  Inspect 5.
End box.

Definition test := @box_eqdec nat _.

Section LIST.

Variable (A:Type) (eq_dec : EqDec A).

Inductive list : Type :=
| nil
| cons : A -> list -> list.

Derive NoConfusion EqDec for list.

End LIST.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Export syntax_ott.
Require Import
        rules_inf
        Infrastructure
        KeyProperties
        SubtypingInversion
        Disjointness.

Require Import List. Import ListNotations.
Require Import Arith Lia.

Lemma TypedReduce_progress: forall v A,
    value v -> Typing [] v Chk A -> exists v', TypedReduce v A v'.
Proof with eauto.
  intros v A Val TypC.
  lets* (B&Typ&Sub): Typing_chk2inf TypC. clear TypC. gen v.
  induction Sub; intros;
    try solve [inverts Typ; inverts Val; exists~].
  - inverts Typ; inverts Val...
    +
      forwards* (?&?): IHSub H2.
    +
      forwards* (?&?): IHSub H4.
  - inverts Typ; inverts~ Val.
    + forwards* (?&?): IHSub H4.
    + forwards* (?&?): IHSub H6.
  - lets *[?|?]: toplike_decidable D.
    +
      clear IHSub1 IHSub2. gen C.
      induction v; intros; inverts Typ; try solve [inverts Val]...
  - lets *[?|?]: toplike_decidable D.
    inverts Typ; inverts Val.
    forwards* (?&?): IHSub H5.
  -
    forwards* (?&?): IHSub1 Typ.
    forwards* (?&?): IHSub2 Typ.
Qed.

Lemma papp_progress: forall v1 v2 A,
    value v1 -> value v2 -> Typing nil (e_app v1 v2) Inf A -> exists e, papp v1 (vl_exp v2) e.
Proof with eauto.
  intros v1 v2 A Val1 Val2 Typ. gen A.
  induction Val1; intros;
    try solve [exists*].
  - inverts Typ.
    inverts H1. inverts H3.
  - inverts Typ. inverts H2.
    inverts H4.
    forwards* (?&?): TypedReduce_progress Val2.
  - inverts Typ.
    inverts H1; inverts H3...
    + assert (algo_sub (t_and A2 B2) A2) by auto_sub.
      assert (algo_sub (t_and A2 B2) B2) by auto_sub.
      forwards*: Typ_app v1 v2.
      forwards*: Typ_app v0 v2.
      forwards* (?&?): IHVal1_1.
      forwards* (?&?): IHVal1_2.
    + assert (algo_sub (t_and A2 B2) A2) by auto_sub.
      assert (algo_sub (t_and A2 B2) B2) by auto_sub.
      forwards*: Typ_app v1 v2.
      forwards*: Typ_app v0 v2.
      forwards* (?&?): IHVal1_1.
      forwards* (?&?): IHVal1_2.
  - inverts Typ. inverts H1.
    inverts H3.
Qed.

Lemma papp_progress2: forall v1 la A,
    value v1 -> Typing nil (e_proj v1 la) Inf A -> exists e, papp v1 (vl_la la) e.
Proof with eauto.
  intros v1 la A Val1 Typ. gen A.
  induction Val1; intros;
    try solve [exists*].
  - inverts Typ. inverts H2. inverts H3.
  - inverts Typ. inverts H3. inverts H4.
  - inverts Typ.
    inverts H2; inverts H3...
    + lets*: Typ_proj v1 la H4.
      lets*: Typ_proj v2 la H8.
      forwards* (?&?): IHVal1_1.
      forwards* (?&?): IHVal1_2.
    + lets*: Typ_proj v1 la H5.
      lets*: Typ_proj v2 la H9.
      forwards* (?&?): IHVal1_1.
      forwards* (?&?): IHVal1_2.
  - inverts Typ. inverts H2. inverts* H3.
Qed.

Theorem progress : forall e dir A,
    Typing nil e dir A ->
    value e \/ exists e', step e e'.
Proof with auto.
  introv Typ. lets Typ': Typ.
  inductions Typ;
    lets Lc: Typing_regular_1 Typ';
    auto;
    try solve [left; auto];
    try solve [right; auto].
  - (* var *)
    invert H0.
  - (* app *)
    inverts Lc.
    right.
    destruct~ IHTyp1 as [Val1 | [e1' Red1]].
    destruct~ IHTyp2 as [Val2 | [e2' Red2]].
    + (* v1 v2 *)
      forwards* (?&?): papp_progress Val1 Val2.
    + exists*.
    + exists*.
  - (* proj *)
    inverts Lc.
    right.
    destruct~ IHTyp as [Val1 | [e1' Red1]].
    + forwards* (?&?): papp_progress2 Val1.
    + exists*.
  - (* rcd *)
    inverts Lc.
    destruct~ IHTyp as [ Val1 | [t1' Red1]]. right*.
  - (* merge *)
    inverts Lc.
    destruct~ IHTyp1 as [ Val1 | [t1' Red1]];
      destruct~ IHTyp2 as [ Val2 | [t2' Red2]];
      subst.
    + (* e_merge v1 e2 *)
      inverts* Typ1.
    + (* e_merge e1 v2 *)
      inverts* Typ2.
    + (* e_merge e1 e2 *)
      inverts* Typ2.
  - (* anno *)
    right.
    destruct~ IHTyp as [ Val | [t' Red]].
    + (* e_anno v A *)
      lets* (v1' & Tyr) : TypedReduce_progress Val Typ.
    + (* e_anno e A *)
      forwards*: Step_anno Red.
  - (* fixpoint *)
    right. eauto.
  - (* mergev *)
    destruct~ IHTyp1 as [ Val1 | [t1' Red1]];
      destruct~ IHTyp2 as [ Val2 | [t2' Red2]];
      subst.
    + (* e_merge v1 e2 *)
      inverts* Typ1.
    + (* e_merge e1 v2 *)
      inverts* Typ2.
    + (* e_merge e1 e2 *)
      inverts* Typ2.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Psatz.
Require Import Crypto.Compilers.Z.Syntax.
Require Import Crypto.Compilers.Z.Syntax.Util.
Require Import Crypto.Compilers.Z.Syntax.Equality.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Z.Bounds.Interpretation.
Require Import Crypto.Compilers.Z.Bounds.InterpretationLemmas.Tactics.
Require Import Crypto.Compilers.SmartMap.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.Bool.
Require Import Crypto.Util.FixedWordSizesEquality.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.PointedProp.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.SplitInContext.
Require Import Crypto.Util.Tactics.UniquePose.

Local Open Scope Z_scope.

Local Arguments lift_op : simpl never.
Local Arguments cast_back_flat_const : simpl never.
Local Arguments unzify_op : simpl never.
Local Arguments Z.pow : simpl never.
Local Arguments Z.add !_ !_.
Local Existing Instances Z.pow_Zpos_le_Proper Z.log2_up_le_Proper.

Section with_round_up.
  Context (is_bounded_by_interp_op
           : forall t tR (opc : op t tR)
                    (bs : interp_flat_type Bounds.interp_base_type _)
                    (v : interp_flat_type interp_base_type _)
                    (H : Bounds.is_bounded_by bs v)
                    (Hside : to_prop (interped_op_side_conditions opc v)),
              Bounds.is_bounded_by (Bounds.interp_op opc bs) (Syntax.interp_op _ _ opc v)).
  Context {round_up : nat -> option nat}.

  Local Notation pick_typeb := (@Bounds.bounds_to_base_type round_up) (only parsing).
  Local Notation pick_type v := (SmartFlatTypeMap pick_typeb v).

  Local Ltac t_small :=
    repeat first [ progress cbv [Bounds.bounds_to_base_type Bounds.smallest_logsz Bounds.actual_logsz] in *
                 | progress simpl in *
                 | progress autorewrite with push_Zof_nat zsimplify_const
                 | solve [ trivial ]
                 | progress change (@interpToZ) with (fun t1 => cast_const (t1:=t1) (t2:=TZ)) in *
                 | progress change (@cast_const TZ TZ) with (fun x : Z => x) in *
                 | progress Z.ltb_to_lt
                 | rewrite Z2Nat.id in * by auto with zarith
                 | rewrite <- Z.log2_up_le_pow2_full in * by auto with zarith
                 | break_innermost_match_step
                 | apply conj
                 | omega
                 | rewrite <- Z.log2_up_le_full
                 | match goal with
                   | [ |- ?x < ?y ] => cut (x + 1 <= y); [ omega | ]
                   | [ H : (_ <=? _)%nat = true |- _ ] => apply Nat.leb_le in H
                   | [ H : (_ <= _)%nat |- _ ] => apply inj_le in H
                   end ].

  Local Arguments cast_const : simpl never.
  Lemma interpToZ_cast_const_small T0 (bs : Bounds.interp_base_type T0)
        (v : interp_base_type (@Bounds.bounds_to_base_type round_up T0 bs))
        (H : match Bounds.bit_width_of_base_type T0 with
             | Some sz => 0 <= ZRange.lower bs /\ ZRange.upper bs < 2 ^ sz
             | None => True
             end)
        (Hv : ZRange.lower bs <= interpToZ (cast_const (t2:=T0) v) <= ZRange.upper bs)
    : interpToZ (cast_const (t2:=T0) v) = interpToZ v.
  Proof.
    destruct_head base_type; simpl in *; try reflexivity.
    unfold Bounds.smallest_logsz, Bounds.interp_base_type, cast_const in *.
    break_innermost_match_hyps; Z.ltb_to_lt; simpl in *;
      [ pose proof (wordToZ_range v) | omega ].
    rewrite wordToZ_ZToWord_mod_full.
    rewrite wordToZ_ZToWord_mod_full in Hv.
    revert Hv; apply Z.max_case_strong; Z.rewrite_mod_small; intros; try omega; [].
    rewrite Z.mod_small; [ reflexivity | split; auto with zarith ].
    autorewrite with push_Zof_nat zsimplify_const in *.
    rewrite Z2Nat.id in * by auto with zarith.
    destruct_head' and.
    eapply Z.lt_le_trans; [ eassumption | ].
    repeat first [ progress Z.peel_le
                 | rewrite <- Z.log2_up_pow2 by auto with zarith; progress Z.peel_le
                 | omega ].
  Qed.

  Local Existing Instances Z.pow_Zpos_le_Proper Z.pow_Zpos_le_Proper_flip Z.lt_le_flip_Proper_flip_impl.
  Lemma ZToInterp_cast_const_small T (bs : Bounds.interp_base_type T)
        v
        (H : match Bounds.bit_width_of_base_type T with
             | Some sz => 0 <= ZRange.lower bs /\ ZRange.upper bs < 2 ^ sz
             | None => True
             end)
        (Hb : ZRange.lower bs <= interpToZ (@ZToInterp T v) <= ZRange.upper bs)
    : @cast_const (@Bounds.bounds_to_base_type round_up T bs) T (ZToInterp v) = ZToInterp v.
  Proof.
    apply ZToInterp_eq_inj.
    rewrite ?interpToZ_ZToInterp_mod.
    rewrite interpToZ_ZToInterp_mod in Hb.
    destruct T; simpl in *.
    { unfold Bounds.actual_logsz.
      break_innermost_match; Z.ltb_to_lt; try reflexivity; [].
      t_small.
      apply Z.max_case_strong; intros; Z.rewrite_mod_small; omega. }
    { unfold Bounds.smallest_logsz.
      break_innermost_match_step; Z.ltb_to_lt; try omega; [].
      revert Hb; apply (Z.max_case_strong 0 v); intros; Z.rewrite_mod_small; try reflexivity.
      rewrite Z.max_r by auto with zarith.
      autorewrite with push_Zof_nat zsimplify_const in *.
      rewrite Z2Nat.id by auto with zarith.
      rewrite Z.mod_mod_small; try apply conj; auto with zarith;
        repeat first [ rewrite <- Z.log2_up_le_pow2_full in * by auto with zarith
                     | rewrite <- Z.log2_up_le_full
                     | omega
                     | apply conj
                     | progress Z.peel_le
                     | rewrite <- Z.log2_up_pow2 by auto with zarith; progress Z.peel_le
                     | match goal with
                       | [ |- 2^?x mod 2^?y = 0 ]
                         => destruct (Z.pow2_lt_or_divides x y);
                            [ solve [ auto with zarith ]
                            | exfalso; assert (2^y <= 2^x)
                            | assumption ]
                       end ]. }
  Qed.

  Lemma pull_cast_genericize_op
        t tR (opc : op t tR)
        (bs : interp_flat_type Bounds.interp_base_type t)
        (v : interp_flat_type interp_base_type (pick_type bs))
        (H : Bounds.is_bounded_by bs
                                  (SmartFlatTypeMapUnInterp
                                     (fun (t1 : base_type) (b0 : Bounds.interp_base_type t1) => cast_const) v))
        (Hside : to_prop (interped_op_side_conditions opc (cast_back_flat_const v)))
    : interp_op t tR opc (cast_back_flat_const v)
      = cast_back_flat_const (interp_op (pick_type bs) (pick_type (Bounds.interp_op opc bs)) (genericize_op opc) v).
  Proof.
    pose proof (is_bounded_by_interp_op t tR opc bs).
    unfold interp_op in *.
    rewrite Zinterp_op_genericize_op.
    generalize dependent (Zinterp_op t tR opc).
    generalize dependent (Bounds.interp_op opc bs); simpl; intros.
    repeat (destruct_one_head flat_type; try solve [ inversion opc ]);
      repeat first [ progress simpl in *
                   | progress destruct_head unit
                   | progress destruct_head True
                   | progress cbv [unzify_op cast_back_flat_const lift_op Bounds.is_bounded_by' ZRange.is_bounded_by'] in *
                   | progress change (@interpToZ TZ) with (fun x : Z => x) in *
                   | progress specialize_by auto
                   | progress specialize_by constructor
                   | match goal with
                     | [ H : forall v, _ <= ?f v <= _ /\ _ -> _ |- context[?f ?v'] ]
                       => specialize (H v')
                     | _ => progress specialize_by_assumption
                     | _ => progress specialize_by auto
                     | [ H : forall v : unit, _ |- _ ] => specialize (H tt)
                     | [ H : forall v : _ * _, _ /\ _ -> _ |- _ ]
                       => specialize (fun v1 v2 p1 p2 => H (v1, v2) (conj p1 p2));
                          cbn [fst snd] in H;
                          specialize (fun v1 p1 v2 p2 => H v1 v2 p1 p2)
                     end
                   | progress destruct_head'_and ];
      [
      | rewrite cast_const_idempotent_small by t_small; reflexivity
      | .. ];
      repeat match goal with
             | _ => progress change (@cast_const TZ) with @ZToInterp in *
             | [ |- context[@cast_const ?x TZ] ]
               => progress change (@cast_const x TZ) with (@interpToZ x) in *
             | [ H : context[@cast_const ?x TZ] |- _ ]
               => progress change (@cast_const x TZ) with (@interpToZ x) in *
             end;
      repeat match goal with
             | _ => reflexivity
             | _ => progress rewrite ?interpToZ_cast_const_small, ?ZToInterp_cast_const_small by auto
             | [ H : context[ZToInterp (?f (interpToZ (cast_const ?v)))] |- _ ]
               => rewrite (@interpToZ_cast_const_small _ _ v) in H by auto
             | [ H : context[(interpToZ (cast_const ?v), _)] |- _ ]
               => rewrite (@interpToZ_cast_const_small _ _ v) in H by auto
             | [ H : context[(_, interpToZ (cast_const ?v))] |- _ ]
               => rewrite (@interpToZ_cast_const_small _ _ v) in H by auto
             end.
  Qed.
End with_round_up.


From Coq Require Import Bool List Reals FinFun Program Lia.
Import ListNotations.

From CasperCBC Require Import Lib.Preamble Lib.ListExtras VLSM.Common VLSM.Composition VLSM.Equivocation.

(** * VLSM List Validator Protocol *)

Section ListNode.

(**

We introduce here the "minimal list validator protocol", by quoting the official
documentation:

In this section, we propose a protocol where each validator keeps a list of states of other validators. Each validator broadcasts its view of the other validators'
states. We claim that the protocol is nontrivial and safe: when equivocations are limited, it is possible to reach either outcome, and if the protocol reaches
a decision, all the validators agree on what it is.

**)

(** Our context includes a finite [index] type with decidable equality and an instance of it, [index_self] which
    designates the chosen index of the current machine **)

Context
  {index : Type}
  {index_self : index}
  {index_listing : list index}
  {Hfinite : Listing index_listing}
  `{EqDecision index}.

(** Each state contains a binary value and a list of all the states of the other validators. **)

Inductive state : Type :=
| Bottom
| Something
  : forall (b : bool) (is : indexed_state index_listing),
  state
with indexed_state : list index -> Type :=
| Empty
  : indexed_state []
| Append
  : forall (v : index) (l : list index)
      (s : state) (is : indexed_state l),
  indexed_state (v :: l)
.
Fixpoint state_eq_dec (s1 s2 : state)
  : {s1 = s2} + {s1 <> s2}
with
indexed_state_eq_dec (l : list index) (ls1 : indexed_state l) (ls2 : indexed_state l)
  : {ls1 = ls2} + {ls1 <> ls2}.
Proof.
- destruct s1; destruct s2.
  + left. reflexivity.
  + right. intro H. discriminate H.
  + right. intro H. discriminate H.
  + destruct (bool_eq_dec b b0).
    * { destruct (indexed_state_eq_dec index_listing is is0).
      - subst. left. reflexivity.
      - right. subst. intro H. elim n. inversion H. reflexivity.
      }
    * right. intro H. elim n. inversion H. reflexivity.
- dependent destruction ls1; dependent destruction ls2.
  + left. reflexivity.
  + destruct (state_eq_dec s s0).
    * { destruct (indexed_state_eq_dec l ls1 ls2).
      - left. subst. reflexivity.
      - right. intro H. elim n. inversion H. apply inj_pairT2 in H2. assumption.
      }
    * right. intro H. elim n. inversion H. reflexivity.
Qed.

Global Instance state_EqDecision : EqDecision state := state_eq_dec.

Fixpoint depth (s : state) : nat :=
  match s with
  | Bottom => 0
  | Something cv ls => depth_indexed index_listing ls + 1
  end
  with depth_indexed (l : list index) (ls : indexed_state l) : nat :=
  match ls with
  | Empty => 0
  | Append v l' s' is' => max (depth s') (depth_indexed l' is')
  end.

(** Some utility functions. **)

Fixpoint project_indexed
  (l : list index)
  (is : indexed_state l)
  (v : index)
  : state
  :=
  match is with
  | Empty =>
    Bottom
  | Append v' l' s is' =>
    if decide (v' = v)
    then s
    else project_indexed l' is' v
  end.

Definition project
  (s : state)
  (v : index)
  : state
  :=
  match s with
  | Bottom => Bottom
  | Something b is => project_indexed index_listing is v
  end.

Fixpoint update_indexed
  (l : list index)
  (is : indexed_state l)
  (v : index)
  (new_s : state)
  : indexed_state l
  :=
  match is with
  | Empty => Empty
  | Append v' l' s is' =>
    if decide (v' = v)
    then Append v' l' new_s is'
    else Append v' l' s (update_indexed l' is' v new_s)
  end.

Lemma update_indexed_eq
  (l : list index)
  (is : indexed_state l)
  (i : index)
  (news : state)
  (Heq : project_indexed l is i = news) :
  (update_indexed l is i news = is).
Proof.
  induction is.
  - simpl.
    reflexivity.
  - simpl.
    destruct (decide (v = i)) eqn : eq.
    + assert (Hsame : s = news). {
        simpl in Heq.
        rewrite eq in Heq.
        assumption.
      }
      rewrite Hsame.
      reflexivity.
    +
      assert (Hstep : project_indexed (v :: l) (Append v l s is) i = project_indexed l is i). {
        unfold project_indexed.
        rewrite eq.
        simpl.
        reflexivity.
      }

      assert (update_indexed l is i news = is). {
        apply IHis.
        rewrite Hstep in Heq.
        assumption.
      }

      rewrite H.
      reflexivity.
Qed.

Lemma update_indexed_same
  (l : list index)
  (is : indexed_state l)
  (i : index)
  (j : index)
  (Heq : i = j)
  (Hin : In i l)
  (news : state) :
  project_indexed l (update_indexed l is i news) j = news.
Proof.
  induction is.
  - unfold In in Hin.
    exfalso.
    assumption.
  - simpl.
    destruct (decide (v = i)) eqn : dec_eq; simpl; rewrite <- Heq; rewrite dec_eq;
    simpl.
    + reflexivity.
    + assert (Hin' : In i l). {
        apply (in_fast l i v Hin n).
      }
      rewrite Heq in IHis.
      rewrite Heq.
      apply IHis.
      rewrite <- Heq.
      assumption.
Qed.

Lemma update_indexed_different
  (l : list index)
  (is : indexed_state l)
  (i : index)
  (j : index)
  (Heq : i <> j)
  (Hin : In i l /\ In j l)
  (news : state) :
  project_indexed l (update_indexed l is i news) j = project_indexed l is j.
Proof.
  induction is.
  - simpl.
    reflexivity.
  - simpl.
    destruct (decide (v = i)).
    + simpl.
      destruct (decide (v = j)).
      * rewrite e in e0. subst. elim Heq. reflexivity.
      * reflexivity.
    + simpl.
      destruct (decide (v = j)).
      * reflexivity.
      * apply IHis.
        destruct Hin.
        split.
        apply (in_fast l i v H n).
        apply (in_fast l j v H0 n0).
Qed.

Lemma update_indexed_idempotent
  (l : list index)
  (is : indexed_state l)
  (i : index)
  (Hin : In i l)
  (news : state) :
  update_indexed l (update_indexed l is i news) i news = update_indexed l is i news.

Proof.
  induction is.
  - simpl. reflexivity.
  - simpl.
    destruct (decide (v = i)) eqn : eq.
    + simpl. rewrite eq. reflexivity.
    + simpl. rewrite eq.
      assert (update_indexed l (update_indexed l is i news) i news = update_indexed l is i news). {
        apply IHis.
        apply (in_fast l i v Hin n).
      }
      rewrite H. reflexivity.
Qed.

Fixpoint all_bottom_f (l : list index) : indexed_state l :=
  match l with
  | [] => Empty
  | (h :: t) => Append h t Bottom (all_bottom_f t)
  end.

Definition all_bottom := all_bottom_f index_listing.

Definition update_consensus (big : state) (value : bool) :=
  match big with
  | Bottom => Bottom
  | Something cv f => Something value f
  end.

Definition update_state (big : state) (news : state) (i : index) : state :=
  match big with
  | Bottom => Bottom
  | Something cv f => Something cv (update_indexed index_listing f i news)
  end.

(* update_consensus doesn't touch state *)
Lemma update_consensus_clean
  (s : state)
  (i : index)
  (value : bool) :
  project s i = project (update_consensus s value) i.
Proof.
  unfold update_consensus.
  destruct s.
  - simpl. reflexivity.
  - unfold project. reflexivity.
Qed.

Lemma depth_consensus_clean
  (s : state)
  (value : bool) :
  depth s = depth (update_consensus s value).
Proof.
  unfold depth.
  destruct s; simpl; reflexivity.
Qed.

Lemma project_same
  (s : state)
  (news : state)
  (i : index)
  (Hnot_bottom : s <> Bottom) :
  project (update_state s news i) i = news.
Proof.
  unfold project.
  destruct s.
  - elim Hnot_bottom. reflexivity.
  - simpl. apply update_indexed_same.
    + reflexivity.
    + apply ((proj2 Hfinite) i).
Qed.

Lemma project_different
  (s : state)
  (news : state)
  (i j : index)
  (Hdif : i <> j)
  (Hnot_bottom : s <> Bottom) :
  project (update_state s news j) i = project s i.
Proof.
  unfold project.
  destruct s.
  - intuition.
  - unfold update_state.
    rewrite update_indexed_different.
    intuition.
    intuition.
    split.
    apply ((proj2 Hfinite) j).
    apply ((proj2 Hfinite) i).
Qed.

Lemma update_state_eq
      (big : state)
      (news : state)
      (i : index)
      (Hin : In i index_listing)
      (Heq : project big i = news)
      : update_state big news i = big.
Proof.
  intros.
  unfold update_state.
  destruct big.
  -reflexivity.
  - assert (Heqis : (update_indexed index_listing is i news) = is). {
      apply update_indexed_eq.
      unfold project in Heq.
      inversion Heq.
      reflexivity.
    }
    rewrite Heqis.
    reflexivity.
Qed.

Lemma update_state_idempotent
      (big : state)
      (news : state)
      (i : index)
      : update_state (update_state big news i) news i = update_state big news i.
Proof.
  unfold update_state.
  destruct big.
  - reflexivity.
  - specialize update_indexed_idempotent.
    intros.
    rewrite H.
    reflexivity.
    apply (proj2 Hfinite i).
Qed.

Fixpoint get_all_states
  (l : list index)
  (is : indexed_state l)
  : list state.
  intros.
  destruct is eqn:is_eqn.
  - exact [].
  - exact (s :: get_all_states l i).
  Defined.

     (* begin hide *)
    Lemma depth_parent_child_indexed
      (indices : list index)
      (i : index)
      (Hi : In i indices)
      (ls : indexed_state indices)
      : depth_indexed indices ls >= depth (project_indexed indices ls i).
    Proof.
      generalize dependent indices.
      induction ls.
      - auto.
      - simpl.
        destruct (decide (v = i)) eqn : Heqdec.
        + unfold depth_indexed. unfold depth. lia.
        + pose (in_fast l i v Hi n) as Hi'.
          specialize (IHls Hi').
          unfold depth_indexed in *. unfold depth in *. lia.
    Qed.

    Lemma depth_parent_child :
      forall (ls : indexed_state index_listing)
         (cv : bool)
         (i : index),
         depth (Something cv ls) >= S (depth (project_indexed index_listing ls i)).

      Proof.
        intros.
        specialize depth_parent_child_indexed.
        intros.
        specialize (H index_listing i ((proj2 Hfinite) i) ls).
        unfold depth at 1.
        unfold depth_indexed in H.
        lia.
   Qed.

(** Our only initial state will be Bottom. **)

Definition state00 := Bottom.

Definition initial_state_prop (s : state) : Prop :=
  exists (cv : bool),
  (s = Something cv all_bottom).

Lemma bottom_good : initial_state_prop (Something false all_bottom).
  Proof.
    unfold initial_state_prop.
    exists false.
    reflexivity.
  Qed.

Definition state0 : {s | initial_state_prop s} :=
  exist _ (Something false all_bottom) bottom_good.

(** Messages are pairs of indices and states.
    There are no initial messages.
    The type is trivially inhabitated by
    the pair of [index_self] and Bottom]. **)

Definition message : Type := (index * state).

Global Instance message_EqDecision : EqDecision message := _.

Definition initial_message_prop (m : message) : Prop := False.

Definition message00 := (index_self, state00).

(** The decision function extracts the consensus value
    from a state. It is possible that a state is undecided.
    We choose to encode this by making consensus values
    options of bool. In this way [None] signifies the
    absence of decision. **)

Definition decision (s : state) : option bool :=
  match s with
  | Bottom => None
  | Something c some => Some c
  end.

(** Get a list of everyone's decisions from the view
    of a given state **)

Definition global_decisions (s : state) : list (option bool) :=
  match s with
  | Bottom => []
  | Something c some => List.map decision (get_all_states index_listing some)
  end.

(** The value of the estimator is defined as the mode of all decisions,
    where possible decisions are <0>, <1> or <{0, 1}> (no decision).
    We choose to define the estimator as a relation between state and bool.
    If the mode value is a decisive one, the estimator will only relate
    to the chosen value, otherwise it will relate to both values.

    Currently, ties resolve generously (everyone equal to the mode is
    taken into account).
 **)

Definition in_mode (modes : list (option bool)) (b : bool) : Prop :=
  match (inb decide_eq (Some b) modes) with
  | true => True
  | false => (inb decide_eq None modes) = true
  end.

Global Instance in_mode_dec : RelDecision in_mode.
Proof.
  unfold RelDecision; intros modes b.
  unfold in_mode.
  destruct (inb decide_eq (Some b) modes) eqn : eq_b.
  - left. intuition.
  - destruct (inb decide_eq None modes); intuition.
Qed.

Definition estimator (s : state) (b : bool) : Prop :=
  let ob_dec := (option_eq_dec) in
  let decision_modes := mode (global_decisions s) in
  match s with
  | Bottom => True
  | Something c some => in_mode decision_modes b
  end.

(** Labels describe the type of transitions: either updates (with boolean values) or receiving of messages. **)

Inductive label_list : Type :=
| update (c : bool)
| receive.

(** Transitions:
    - Update <c> => updates the state at [index_self] with a new state which
                    contains <c> as a consensus value. A message is emitted to broadcast
                    this update: it contains the machine's index and its _previous state_.
    - Receive => Updates the view of global states with new information
                 about the node which sent the received message.
                 No message is emitted.
**)

Definition list_transition (l : label_list) (som : state * option message) : state * option message :=
  let (s, om) := som in
     match l with
     | update c => ((update_consensus (update_state s s index_self) c), Some (index_self, s))
     | receive => match om with
                  | Some m => ((update_state s (snd m) (fst m)), None)
                  | None => (s, None)
                  end
     end.

(** Validity:
    - Update <c> => <c> must be in the estimator of the given state.
    - Receive => A message must be received, sent by a _different_ node.
                 The sender's state in his own state list
                 should match our view of it in our state list. **)

Definition list_valid
  (est : state -> bool -> Prop)
  (l : label_list)
  (som : state * option message)
  :=
  let (s, om) := som in
  match l with
  | update c => est s c /\ om = None
  | receive => match om with
               | None => False
               | Some m => project s (fst m) = project (snd m) (fst m) /\ (snd m) <> Bottom /\ index_self <> (fst m)
               end
    end.

(** Finally, we are ready to instantiate the protocol as a VLSM **)

Instance VLSM_list_protocol : VLSM_type message :=
  { state := state
  ; label := label_list
  }.

Instance LSM_list : VLSM_sign VLSM_list_protocol :=
  { initial_state_prop := initial_state_prop
  ; initial_message_prop := initial_message_prop
  ; s0 := state0
  ; m0 := message00
  ; l0 := receive
  }.

Instance VLSM_list_machine
  (est : state -> bool -> Prop)
  : VLSM_class LSM_list :=
  { transition := list_transition
    ; valid := list_valid est
  }.

Definition VLSM_list
  (est : state -> bool -> Prop)
  : VLSM message := mk_vlsm (VLSM_list_machine est).

Definition mk_label (l : label_list) : @label _ VLSM_list_protocol := l.

Definition last_recorded (l : list index) (ls : indexed_state l) (who : index) : state :=
  project_indexed l ls who.

Definition last_sent (s : state) : state := project s index_self.

Fixpoint rec_history (s : state) (who : index) (d : nat) : list state :=
  match s, d with
  | Bottom, _ => []
  | _, 0 => []
  | (Something cv ls), (S d') => s :: rec_history (last_recorded index_listing ls who) who d'
  end.

Definition get_history (s : state) (who : index) : list state :=
   match s with
   | Bottom => []
   | Something cv ls => let child := last_recorded index_listing ls who in
                          rec_history child who (depth child)
   end.

  Definition state_eqb (s1 s2 : state) : bool :=
    match decide_eq s1 s2 with
    | left _ => true
    | right _ => false
    end.

  Lemma state_eqb_eq (s1 s2 : state) :
    (state_eqb s1 s2) = true <-> s1 = s2.
  Proof.
    unfold state_eqb.
    split.
    - destruct (decide (s1 = s2)).
      + intuition.
      + intros. discriminate H.
    - intros.
      destruct (decide (s1 = s2));
      intuition.
  Qed.

  Lemma state_eqb_neq (s1 s2 : state) :
    (state_eqb s1 s2) = false <-> s1 <> s2.
  Proof.
    unfold state_eqb.
    split;
    destruct (decide (s1 = s2));
    intuition.
  Qed.

  Definition send_oracle (s : state) (m : message)  : bool :=
    let who := fst m in
    let what := snd m in
    match decide (who = index_self) with
    | right _ => false
    | left _ => existsb (state_eqb what) (get_history s who)
    end.

  Definition receive_oracle (s : state) (m : message) : bool :=
    let who := fst m in
    let what := snd m in
    match decide (who = index_self) with
    | left _ => false
    | right _ => existsb (state_eqb what) (get_history s who)
    end.

    Definition not_send_oracle (s : state) (m : message)  : bool :=
      negb (send_oracle s m).

    Definition not_receive_oracle (s : state) (m : message) : bool :=
      negb (receive_oracle s m).

End ListNode.


Require Import Coq.Strings.String.
Require Import ExtLib.Structures.Applicative.
Require Import ExtLib.Data.Fun.
Require Import McExamples.Hoare.ILogic.

Set Implicit Arguments.
Set Strict Implicit.

Local Instance Applicative_Fun A : Applicative (Fun A) :=
{ pure := fun _ x _ => x
; ap := fun _ _ f x y => (f y) (x y)
}.

Module Type ImpLang.

  Definition var := string.
  Definition value := nat.

  (* States *)
  Parameter locals : Type.
  Parameter locals_upd : var -> value -> locals -> locals.
  Parameter locals_get : var -> locals -> value.

  (* Expressions *)
  Parameter iexpr : Type.
  Parameter iConst : value -> iexpr.
  Parameter iVar : var -> iexpr.
  Parameter iPlus : iexpr -> iexpr -> iexpr.
  Parameter iEq : iexpr -> iexpr -> iexpr.
  Parameter iLt : iexpr -> iexpr -> iexpr.

  Parameter eval_iexpr : iexpr -> locals -> value.

  (* Commands *)
  Parameter icmd : Type.

  Parameter Skip : icmd.
  Parameter Seq : icmd -> icmd -> icmd.
  Parameter Assign : var -> iexpr -> icmd.
  Parameter If : iexpr -> icmd -> icmd -> icmd.

  (* Logic for the Axiomatic Semantics *)
  Universe Uall Ulogic.
  Parameter HProp : Type@{Ulogic}. (* Predicates over the global state *)

  Parameter ILogicOps_HProp : ILogicOps@{Uall Ulogic} HProp.
  Parameter ILogic_HProp : ILogic HProp.
  Parameter EmbedOp_Prop_HProp : EmbedOp Prop HProp.
  Parameter Embed_Prop_HProp : Embed Prop HProp.

  Parameter SProp : Type@{Ulogic}. (* The specification logic *)

  Parameter ILogicOps_SProp : ILogicOps@{Uall Ulogic} SProp.
  Parameter ILogic_SProp : ILogic SProp.
  Parameter EmbedOp_Prop_SProp : EmbedOp Prop SProp.
  Parameter Embed_Prop_SProp : Embed Prop SProp.

  Definition lprop := locals -> HProp.

  Instance ILogicOps_lprop : ILogicOps@{Uall Ulogic} lprop := _.
  Instance ILogic_lprop : ILogic lprop := _.

  Instance EmbedOp_HProp_lprop : EmbedOp@{Ulogic Ulogic} HProp lprop := _.
  Instance Embed_HProp_lprop : Embed HProp lprop := _.

  (* Axiomatics Semantics *)
  Parameter triple : lprop -> icmd -> lprop -> SProp.

  (** Consequence **)
  Axiom Conseq_rule
  : forall G P P' Q' Q c,
      G |-- embed (P |-- P') ->
      G |-- embed (Q' |-- Q) ->
      G |-- triple P' c Q' ->
      G |-- triple P c Q.

  (** Quantifier Rules **)
  Axiom triple_exL
  : forall G P c Q,
      (G |-- Forall x : value, triple (P x) c Q) ->
      G |-- triple (lexists P) c Q.

  Axiom triple_pureL
  : forall (P : Prop) G c Q R,
      (G //\\ embed P |-- triple Q c R) ->
      G |-- triple (land (embed (embed P)) Q) c R.

  Lemma entails_exL
    : forall (P : value -> locals -> HProp) Q,
      (forall x, P x |-- Q) ->
      lexists P |-- Q.
  Proof.
    intros. apply lexistsL. eassumption.
  Qed.

  Lemma go_lower
    : forall (P Q : lprop) (G : SProp),
      G |-- lforall (fun x : locals => embed (P x |-- Q x)) ->
      G |-- @embed Prop SProp EmbedOp_Prop_SProp (P |-- Q).
  Proof.
    intros.
    etransitivity; [ eassumption | clear ].
    unfold embed. simpl.
    etransitivity; [ eapply embedlforall | ].
    simpl. reflexivity.
  Qed.
  Lemma go_lower_raw
    : forall (P Q : lprop),
      (forall x : locals, P x |-- Q x) ->
      (P |-- Q).
  Proof.
    red; simpl; intros.
    eapply H.
  Qed.

  (** Skip **)
  Axiom Skip_rule_refl
  : forall G P,
      G |-- triple P Skip P.

  Theorem Skip_rule
  : forall G P Q,
      G |-- embed (P |-- Q) ->
      G |-- triple P Skip Q.
  Proof.
    intros.
    eapply Conseq_rule; [ | | eapply Skip_rule_refl ].
    - eassumption.
    - eapply embed_drop.
      intro. reflexivity.
  Qed.

  (** Sequence **)
  Axiom Seq_rule
  : forall G P Q R c1 c2,
      G |-- triple P c1 Q ->
      G |-- triple Q c2 R ->
      G |-- triple P (Seq c1 c2) R.

  Axiom SeqA_rule
  : forall G P Q c1 c2 c3,
      G |-- triple P (Seq c1 (Seq c2 c3)) Q ->
      G |-- triple P (Seq (Seq c1 c2) c3) Q.

  (** Assignment **)
  Axiom Assign_rule
  : forall G P x e,
    G |-- triple P
                 (Assign x e)
                 (fun l => Exists v' : value,
                             P  (locals_upd x v' l) //\\
                             embed (locals_get x l = eval_iexpr e (locals_upd x v' l))).

  (** Assert **)
  Parameter Assert : lprop -> icmd.

  Axiom Assert_rule
  : forall G (Q : lprop),
      G |-- triple Q (Assert Q) Q.

  (** If **)
  Axiom If_rule
  : forall (G : SProp) (P Q : lprop) (x : iexpr) (c1 c2 : icmd),
      G |-- triple (P //\\ (fun l : locals => embed (eval_iexpr x l <> 0))) c1 Q ->
      G |-- triple (P //\\ (fun l : locals => embed (eval_iexpr x l = 0))) c2  Q ->
      G |-- triple P (If x c1 c2) Q.

  Definition update {T} (f : locals -> locals) (m : locals -> T) (l : locals)
  : T := m (f l).

End ImpLang.


From Coq.QArith Require Import Qcanon.
From algebra Require Export cmra.
From algebra Require Import upred.
Local Arguments validN _ _ _ !_ /.
Local Arguments valid _ _  !_ /.
Local Arguments div _ _ !_ !_ /.

Inductive frac (A : Type) :=
  | Frac : Qp → A → frac A
  | FracUnit : frac A.
Arguments Frac {_} _ _.
Arguments FracUnit {_}.
Instance maybe_Frac {A} : Maybe2 (@Frac A) := λ x,
  match x with Frac q a => Some (q,a) | _ => None end.
Instance: Params (@Frac) 2.

Section cofe.
Context {A : cofeT}.
Implicit Types a b : A.
Implicit Types x y : frac A.

(* Cofe *)
Inductive frac_equiv : Equiv (frac A) :=
  | Frac_equiv q1 q2 a b : q1 = q2 → a ≡ b → Frac q1 a ≡ Frac q2 b
  | FracUnit_equiv : FracUnit ≡ FracUnit.
Existing Instance frac_equiv.
Inductive frac_dist : Dist (frac A) :=
  | Frac_dist q1 q2 a b n : q1 = q2 → a ≡{n}≡ b → Frac q1 a ≡{n}≡ Frac q2 b
  | FracUnit_dist n : FracUnit ≡{n}≡ FracUnit.
Existing Instance frac_dist.

Global Instance Frac_ne q n : Proper (dist n ==> dist n) (@Frac A q).
Proof. by constructor. Qed.
Global Instance Frac_proper q : Proper ((≡) ==> (≡)) (@Frac A q).
Proof. by constructor. Qed.
Global Instance Frac_inj : Inj2 (=) (≡) (≡) (@Frac A).
Proof. by inversion_clear 1. Qed.
Global Instance Frac_dist_inj n : Inj2 (=) (dist n) (dist n) (@Frac A).
Proof. by inversion_clear 1. Qed.

Program Definition frac_chain (c : chain (frac A)) (q : Qp) (a : A)
    (H : maybe2 Frac (c 0) = Some (q,a)) : chain A :=
  {| chain_car n := match c n return _ with Frac _ b => b | _ => a end |}.
Next Obligation.
  intros c q a ? n i ?; simpl.
  destruct (c 0) eqn:?; simplify_eq/=.
  by feed inversion (chain_cauchy c n i).
Qed.
Instance frac_compl : Compl (frac A) := λ c,
  match Some_dec (maybe2 Frac (c 0)) with
  | inleft (exist (q,a) H) => Frac q (compl (frac_chain c q a H))
  | inright _ => c 0
  end.
Definition frac_cofe_mixin : CofeMixin (frac A).
Proof.
  split.
  - intros mx my; split.
    + by destruct 1; subst; constructor; try apply equiv_dist.
    + intros Hxy; feed inversion (Hxy 0); subst; constructor; try done.
      apply equiv_dist=> n; by feed inversion (Hxy n).
  - intros n; split.
    + by intros [q a|]; constructor.
    + by destruct 1; constructor.
    + destruct 1; inversion_clear 1; constructor; etrans; eauto.
  - by inversion_clear 1; constructor; done || apply dist_S.
  - intros n c; unfold compl, frac_compl.
    destruct (Some_dec (maybe2 Frac (c 0))) as [[[q a] Hx]|].
    { assert (c 0 = Frac q a) by (by destruct (c 0); simplify_eq/=).
      assert (∃ b, c n = Frac q b) as [y Hy].
      { feed inversion (chain_cauchy c 0 n);
          eauto with lia congruence f_equal. }
      rewrite Hy; constructor; auto.
      by rewrite (conv_compl n (frac_chain c q a Hx)) /= Hy. }
    feed inversion (chain_cauchy c 0 n); first lia;
       constructor; destruct (c 0); simplify_eq/=.
Qed.
Canonical Structure fracC : cofeT := CofeT frac_cofe_mixin.
Global Instance frac_discrete : Discrete A → Discrete fracC.
Proof. by inversion_clear 2; constructor; done || apply (timeless _). Qed.
Global Instance frac_leibniz : LeibnizEquiv A → LeibnizEquiv (frac A).
Proof. by destruct 2; f_equal; done || apply leibniz_equiv. Qed.

Global Instance Frac_timeless q (a : A) : Timeless a → Timeless (Frac q a).
Proof. by inversion_clear 2; constructor; done || apply (timeless _). Qed.
Global Instance FracUnit_timeless : Timeless (@FracUnit A).
Proof. by inversion_clear 1; constructor. Qed.
End cofe.

Arguments fracC : clear implicits.

(* Functor on COFEs *)
Definition frac_map {A B} (f : A → B) (x : frac A) : frac B :=
  match x with
  | Frac q a => Frac q (f a) | FracUnit => FracUnit
  end.
Instance: Params (@frac_map) 2.

Lemma frac_map_id {A} (x : frac A) : frac_map id x = x.
Proof. by destruct x. Qed.
Lemma frac_map_compose {A B C} (f : A → B) (g : B → C) (x : frac A) :
  frac_map (g ∘ f) x = frac_map g (frac_map f x).
Proof. by destruct x. Qed.
Lemma frac_map_ext {A B : cofeT} (f g : A → B) x :
  (∀ x, f x ≡ g x) → frac_map f x ≡ frac_map g x.
Proof. by destruct x; constructor. Qed.
Instance frac_map_cmra_ne {A B : cofeT} n :
  Proper ((dist n ==> dist n) ==> dist n ==> dist n) (@frac_map A B).
Proof. intros f f' Hf; destruct 1; constructor; by try apply Hf. Qed.
Definition fracC_map {A B} (f : A -n> B) : fracC A -n> fracC B :=
  CofeMor (frac_map f).
Instance fracC_map_ne A B n : Proper (dist n ==> dist n) (@fracC_map A B).
Proof. intros f f' Hf []; constructor; by try apply Hf. Qed.

Section cmra.
Context {A : cmraT}.
Implicit Types a b : A.
Implicit Types x y : frac A.

(* CMRA *)
Instance frac_valid : Valid (frac A) := λ x,
  match x with Frac q a => (q ≤ 1)%Qc ∧ ✓ a | FracUnit => True end.
Instance frac_validN : ValidN (frac A) := λ n x,
  match x with Frac q a => (q ≤ 1)%Qc ∧ ✓{n} a | FracUnit => True end.
Global Instance frac_empty : Empty (frac A) := FracUnit.
Instance frac_core : Core (frac A) := λ _, ∅.
Instance frac_op : Op (frac A) := λ x y,
  match x, y with
  | Frac q1 a, Frac q2 b => Frac (q1 + q2) (a ⋅ b)
  | Frac q a, FracUnit | FracUnit, Frac q a => Frac q a
  | FracUnit, FracUnit => FracUnit
  end.
Instance frac_div : Div (frac A) := λ x y,
  match x, y with
  | _, FracUnit => x
  | Frac q1 a, Frac q2 b =>
     match q1 - q2 with Some q => Frac q (a ÷ b) | None => FracUnit end%Qp
  | FracUnit, _ => FracUnit
  end.

Lemma Frac_op q1 q2 a b : Frac q1 a ⋅ Frac q2 b = Frac (q1 + q2) (a ⋅ b).
Proof. done. Qed.

Definition frac_cmra_mixin : CMRAMixin (frac A).
Proof.
  split.
  - intros n []; destruct 1; constructor; by cofe_subst.
  - constructor.
  - do 2 destruct 1; split; by cofe_subst.
  - do 2 destruct 1; simplify_eq/=; try case_match; constructor; by cofe_subst.
  - intros [q a|]; rewrite /= ?cmra_valid_validN; naive_solver eauto using O.
  - intros n [q a|]; destruct 1; split; auto using cmra_validN_S.
  - intros [q1 a1|] [q2 a2|] [q3 a3|]; constructor; by rewrite ?assoc.
  - intros [q1 a1|] [q2 a2|]; constructor; by rewrite 1?comm ?[(q1+_)%Qp]comm.
  - intros []; by constructor.
  - done.
  - by exists FracUnit.
  - intros n [q1 a1|] [q2 a2|]; destruct 1; split; eauto using cmra_validN_op_l.
    trans (q1 + q2)%Qp; simpl; last done.
    rewrite -{1}(Qcplus_0_r q1) -Qcplus_le_mono_l; auto using Qclt_le_weak.
  - intros [q1 a1|] [q2 a2|] [[q3 a3|] Hx];
      inversion_clear Hx; simplify_eq/=; auto.
    + rewrite Qp_op_minus. by constructor; [|apply cmra_op_div; exists a3].
    + rewrite Qp_minus_diag. by constructor.
  - intros n [q a|] y1 y2 Hx Hx'; last first.
    { by exists (∅, ∅); destruct y1, y2; inversion_clear Hx'. }
    destruct Hx, y1 as [q1 b1|], y2 as [q2 b2|].
    + apply (inj2 Frac) in Hx'; destruct Hx' as [-> ?].
      destruct (cmra_extend n a b1 b2) as ([z1 z2]&?&?&?); auto.
      exists (Frac q1 z1,Frac q2 z2); by repeat constructor.
    + exists (Frac q a, ∅); inversion_clear Hx'; by repeat constructor.
    + exists (∅, Frac q a); inversion_clear Hx'; by repeat constructor.
    + exfalso; inversion_clear Hx'.
Qed.
Canonical Structure fracR : cmraT := CMRAT frac_cofe_mixin frac_cmra_mixin.
Global Instance frac_cmra_unit : CMRAUnit fracR.
Proof. split. done. by intros []. apply _. Qed.
Global Instance frac_cmra_discrete : CMRADiscrete A → CMRADiscrete fracR.
Proof.
  split; first apply _.
  intros [q a|]; destruct 1; split; auto using cmra_discrete_valid.
Qed.

Lemma frac_validN_inv_l n y a : ✓{n} (Frac 1 a ⋅ y) → y = ∅.
Proof.
  destruct y as [q b|]; [|done]=> -[Hq ?]; destruct (Qcle_not_lt _ _ Hq).
  by rewrite -{1}(Qcplus_0_r 1) -Qcplus_lt_mono_l.
Qed.
Lemma frac_valid_inv_l y a : ✓ (Frac 1 a ⋅ y) → y = ∅.
Proof. intros. by apply frac_validN_inv_l with 0 a, cmra_valid_validN. Qed.

(** Internalized properties *)
Lemma frac_equivI {M} (x y : frac A) :
  (x ≡ y)%I ≡ (match x, y with
               | Frac q1 a, Frac q2 b => q1 = q2 ∧ a ≡ b
               | FracUnit, FracUnit => True
               | _, _ => False
               end : uPred M)%I.
Proof.
  uPred.unseal; do 2 split; first by destruct 1.
  by destruct x, y; destruct 1; try constructor.
Qed.
Lemma frac_validI {M} (x : frac A) :
  (✓ x)%I ≡ (if x is Frac q a then ■ (q ≤ 1)%Qc ∧ ✓ a else True : uPred M)%I.
Proof. uPred.unseal. by destruct x. Qed.

(** ** Local updates *)
Global Instance frac_local_update_full p a :
  LocalUpdate (λ x, if x is Frac q _ then q = 1%Qp else False) (λ _, Frac p a).
Proof.
  split; first by intros ???.
  by intros n [q b|] y; [|done]=> -> /frac_validN_inv_l ->.
Qed.
Global Instance frac_local_update `{!LocalUpdate Lv L} :
  LocalUpdate (λ x, if x is Frac _ a then Lv a else False) (frac_map L).
Proof.
  split; first apply _. intros n [p a|] [q b|]; simpl; try done.
  intros ? [??]; constructor; [done|by apply (local_updateN L)].
Qed.

(** Updates *)
Lemma frac_update_full (a1 a2 : A) : ✓ a2 → Frac 1 a1 ~~> Frac 1 a2.
Proof.
  move=> ? n y /frac_validN_inv_l ->. split. done. by apply cmra_valid_validN.
Qed.
Lemma frac_update (a1 a2 : A) p : a1 ~~> a2 → Frac p a1 ~~> Frac p a2.
Proof.
  intros Ha n [q b|] [??]; split; auto.
  apply cmra_validN_op_l with (core a1), Ha. by rewrite cmra_core_r.
Qed.
End cmra.

Arguments fracR : clear implicits.

(* Functor *)
Instance frac_map_cmra_monotone {A B : cmraT} (f : A → B) :
  CMRAMonotone f → CMRAMonotone (frac_map f).
Proof.
  split; try apply _.
  - intros n [p a|]; destruct 1; split; auto using validN_preserving.
  - intros [q1 a1|] [q2 a2|] [[q3 a3|] Hx];
      inversion Hx; setoid_subst; try apply: cmra_unit_least; auto.
    destruct (included_preserving f a1 (a1 ⋅ a3)) as [b ?].
    { by apply cmra_included_l. }
    by exists (Frac q3 b); constructor.
Qed.

Program Definition fracRF (F : rFunctor) : rFunctor := {|
  rFunctor_car A B := fracR (rFunctor_car F A B);
  rFunctor_map A1 A2 B1 B2 fg := fracC_map (rFunctor_map F fg)
|}.
Next Obligation.
  by intros F A1 A2 B1 B2 n f g Hfg; apply fracC_map_ne, rFunctor_ne.
Qed.
Next Obligation.
  intros F A B x. rewrite /= -{2}(frac_map_id x).
  apply frac_map_ext=>y; apply rFunctor_id.
Qed.
Next Obligation.
  intros F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -frac_map_compose.
  apply frac_map_ext=>y; apply rFunctor_compose.
Qed.

Instance fracRF_contractive F :
  rFunctorContractive F → rFunctorContractive (fracRF F).
Proof.
  by intros ? A1 A2 B1 B2 n f g Hfg; apply fracC_map_ne, rFunctor_contractive.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal86.

Set Printing Depth 1000.
Definition lfind_eval  y:=
plus y Zero.

Compute lfind_eval  (Succ (Succ (Succ (Succ (Succ Zero))))).

Compute lfind_eval  (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Zero).


(* Verification of the Schreier-Sims subgroup chain algorithm. *)

From permlib Require Import util perm order Schreier_Sims.

Arguments singletonM : simpl never.

Module Schreier.
Import Schreier.
Section Vector.

Variable k : positive.
Variable gen : list perm.
Notation build := (build gen k).
Notation build_step := (build_step gen).
Notation generators := (generators gen k).

Definition Sound (orb : orbit) :=
  ∀ i π, orb !! i = Some π -> Generates gen π ∧ π !!! k = i.

Definition Complete (orb : orbit) :=
  ∀ π, Generates gen π -> is_Some (orb !! (π !!! k)).

Definition Value_Bound (π : perm) (n : positive) :=
  ∀ i, π !!! i ≠ i -> π !!! i ≤ n.

Implicit Types s : state.
Implicit Types orb : orbit.
Implicit Types cur : list (positive * perm).
Implicit Types p : positive * perm.

Section Soundness.

Lemma iterate_invariant {X} (P : X -> Prop) n f x :
  P x -> (∀ y, P y -> P (f y)) -> P (iterate n f x).
Proof.
revert x; induction n; firstorder.
Qed.

Lemma foldl_invariant {A B} (P : B -> Prop) (f : B -> A -> B) l :
  (∀ a b, a ∈ l -> P b -> P (f b a)) -> ∀ b0, P b0 -> P (foldl f b0 l).
Proof.
intros Hf; induction l; intros b0 H0; cbn. done.
apply IHl; intros; apply Hf; auto; apply elem_of_cons; tauto.
Qed.

Definition Sound_State (s : state) :=
  Sound s.1 ∧ ∀ i π, (i, π) ∈ s.2 -> s.1 !! i = Some π.

Theorem build_sound n :
  Sound_State (build n).
Proof.
unfold build; apply iterate_invariant.
- split; intros i π; cbn; intros.
  + apply lookup_singleton_Some in H as [-> <-]; split.
    apply generates_e. done.
  + apply elem_of_list_singleton in H; injection H; intros -> ->.
    apply lookup_insert.
- intros [orb cur]; cbn; intros Horb.
  apply foldl_invariant. intros [i π] [orb' cur'] H1 H2; cbn.
  apply foldl_invariant. intros σ [orb'' cur''] H3 H4; cbn.
  3: firstorder; list_simplifier; decompose_elem_of_list.
  2: firstorder. destruct (_ !! _) eqn:Hi; cbn. tauto.
  split; intros j τ; cbn; intros Hj.
  + apply lookup_insert_Some in Hj as [[<- <-]|[]]; [|firstorder].
    apply Horb, Horb in H1 as [Hπ Hk]; split.
    apply generates_compose. done. apply generates_generator; done.
    rewrite lookup_perm_compose; congruence.
  + apply elem_of_cons in Hj as [].
    injection H; intros <- <-; apply lookup_insert.
    apply H4 in H; cbn in H; etrans; [apply lookup_insert_ne|].
    congruence. done.
Qed.

End Soundness.

Section Completeness.

Lemma build_step_complete w s :
  w ⊆ gen ->
  let (orb, _) := iterate (length w) build_step s in
  is_Some (orb !! (comp w !!! k)).
Proof.
induction w; intros; cbn.
(* We have to determine the right pre-condition for the list of current indices.
Each index from which new indices are reachable must be present. *)
Admitted.

Variable n : positive.
Hypothesis exhaustive : ∀ π, π ∈ gen -> Value_Bound π n.

Lemma build_complete :
  Complete (build (Pos.to_nat n)).1.
Proof.
intros _ [w [? ->]].
(* We need the Pigeon-Hole-Principle to show that a prefix of w with length at
most n has the same value at k, so we can apply build_step_complete. *)
Admitted.

End Completeness.

Section Schreiers_lemma.

Variable orb : orbit.
Hypothesis sound : Sound orb.
Hypothesis complete : Complete orb.

Lemma generators_sound_1 :
  Forall (Generates gen) (generators orb).
Proof.
Admitted.

Lemma generators_sound_2 π :
  Generates (generators orb) π -> π !!! k = k.
Proof.
Admitted.

Lemma generators_complete π :
  Generates gen π -> π !!! k = k -> Generates (generators orb) π.
Proof.
Admitted.

End Schreiers_lemma.

End Vector.
End Schreier.

Module Sims.
Import Sims.
Section Filter.

Variable n : nat.
Notation filter := (filter n).

Lemma filter_sound gen π :
  Generates (values (filter gen)) π -> Generates gen π.
Proof.
Admitted.

Lemma filter_complete gen π :
  Generates gen π -> Generates (values (filter gen)) π.
Proof.
Admitted.

End Filter.
End Sims.

Module SGChain.
Import SGChain.
Section Order.

Variable gen : list perm.
Variable ks : list positive.

Hypothesis ks_complete : ∀ k π, π ∈ gen ∧ π !!! k ≠ k -> k ∈ ks.

Theorem order_spec :
  Group_Order gen (order (build gen ks)).
Proof.
Admitted.

End Order.
End SGChain.