Require Import Cosa.Lib.Header.
Require Import Cosa.Lib.Relation.
Require Import Cosa.Interaction.Transition.

(** Interaction structures, due to Peter Hancock, are an intentional
    representation of transition systems with disjunctive (angelic)
    and conjunctive (demonic) non-determinism. They are a very generic
    kind of data and therefore can be used in various way. One of the
    most important way is that it can be used to represent an
    interface, where capabilities (in form of command) are provided by
    an implementer, and a user can issue commands to advance the
    internal state. They can also be used as proof inference systems,
    which we shall leverage for certificate checking.

    The definition of interaction structures given here is expanded,
    but an alternative definition is [A -> Fam (Fam B)], where
    [Fam X = { i:Type & I -> X}] is the type of families on [X] with
    an arbitrary index. *)

Record Interaction {A B:Type} := {
  Com : A -> Type; (** Issuable commands *)
  Resp : forall {a:A}, Com a -> Type; (** Responses *)
  Output : forall {a:A} {c:Com a}, Resp c -> B (** Output state *)
}.
Arguments Interaction _ _ : clear implicits.

Definition Interface (A:Type) := Interaction A A.

(** Predicate transformers *)

(** For any complete lattice Ω, interaction structures act on
    "predicates" mapping into Ω. Mapping commands to a join and
    responses to a meet. *)
Definition Angelic {A B} Γ (i:Interaction A B) : (B->rel Γ) -> (A->rel Γ) :=
  fun X a => Join (fun c:i.(Com) a => Meet (fun x:i.(Resp) c => X(i.(Output) x)))
.

Instance angelic_increasing {A B} Γ (i:Interaction A B) :
  Proper (@sub (B::Γ) ==> @sub (A::Γ)) (Angelic Γ i)
.
Proof.
  unfold Proper, respectful, Subset, Angelic.
  intros p q p_sub_q;simpl; intros a.
  apply Join_increasing; simpl; intros c.
  apply Meet_increasing; simpl.
  eauto.
Qed.

(** Dually, we can map commands to a meet and responses to a join. *)
Definition Demonic {A B} Γ (i:Interaction A B) : (B->rel Γ) -> (A->rel Γ) :=
  fun X a => Meet (fun c:i.(Com) a => Join (fun x:i.(Resp) c => X(i.(Output) x)))
.

Instance demonic_increasing {A B} Γ (i:Interaction A B) :
  Proper (@sub (B::Γ) ==> @sub (A::Γ)) (Demonic Γ i)
.
Proof.
  unfold Proper, respectful, Subset, Demonic.
  intros p q p_sub_q; simpl; intros a.
  apply Meet_increasing; simpl; intros c.
  apply Join_increasing; simpl.
  eauto.
Qed.

(** Sequence *)

Definition skip {S} : Interface S := {|
  Com s := unit ;
  Resp s c := unit ;
  Output s c x := s
|}.

Definition seq {S T U} (i:Interaction S T) (j:Interaction T U) : Interaction S U := {|
  Com s := { c₁ : i.(Com) s & forall x₁:i.(Resp) c₁, j.(Com) (i.(Output) x₁) } ;
  Resp s c := { x₁ : i.(Resp) (projT1 c) & j.(Resp) (projT2 c x₁) };
  Output s c x := j.(Output) (projT2 x)
|}.

(** "Monadic" unit and bind *)
Definition munit {S A} (a:A) : Interaction S (A*S) := {|
  Com s := unit ;
  Resp s c := unit ;
  Output s c x := (a,s)
|}.

Definition curry {A S T} (i:A->Interaction S T) : Interaction (A*S) T := {|
  Com s := (i (fst s)).(Com) (snd s);
  Resp s c := (i (fst s)).(Resp) c;
  Output s c x := (i (fst s)).(Output) x
|}.

Definition bind {S T U A} (i:Interaction S (A*T)) (j:A->Interaction T U) : Interaction S U :=
  seq i (curry j)
.

(** Cartesian product *)

Definition pi {A S T} (i:A->Interaction S T) : Interaction S T := {|
  Com s := forall a:A, (i a).(Com) s ;
  Resp s c := { a:A & (i a).(Resp) (c a) } ;
  Output s c x := (i (projT1 x)).(Output) (projT2 x)
|}.

(** Sum *)

Definition sigma {A S T} (i:A->Interaction S T) : Interaction S T := {|
  Com s := { a:A & (i a).(Com) s } ;
  Resp s c := (i (projT1 c)).(Resp) (projT2 c) ;
  Output s c x := (i (projT1 c)).(Output) x
|}.

(** Tensor product *)

Definition tensor {S₁ T₁ S₂ T₂} (i:Interaction S₁ T₁) (j:Interaction S₂ T₂) : Interaction (S₁*S₂) (T₁*T₂) := {|
  Com s := (i.(Com) (fst s) * j.(Com) (snd s))%type ;
  Resp s c := (i.(Resp) (fst c) * j.(Resp) (snd c))%type ;
  Output s c x := (i.(Output) (fst x) , j.(Output) (snd x))
|}.

(** Angelic iteration *)

Inductive Prog {S} {i:Interface S} {s:S} : Type:=
 | ret : Prog
 | issue (c:i.(Com) s) (k:forall (x:i.(Resp) c), @Prog S i (i.(Output) x)) : Prog
.
Arguments Prog {S} i _ : clear implicits.

(* arnaud: TProg et RProg sont assez mystérieux avec tous ces arguments implicites. Il vaudrait peut-être bien de les expliquer un peu mieux, ou peut-être de rendre plus d'arguments explicites… *)
Fixpoint TProg {S} {i:Interface S} {s} (p:Prog i s) : Type :=
  match p with
  | ret => unit
  | issue c k => { x:i.(Resp) c & TProg (k x) }
  end
.

Fixpoint RProg {S} {i:Interface S} {s} {p:Prog i s} (x:TProg p) : S :=
  match p return TProg p -> S with
  | ret => fun _ => s
  | issue c k => fun x => RProg (projT2 x)
  end x
.

Definition angelic_iteration {S} (i:Interface S) : Interface S := {|
  Com s := Prog i s ;
  Resp s c := TProg c ;
  Output s c x := RProg x
|}.

(*** Demonic iteration ***)

(* TODO *)

(*** Angelic extension of transition structure. ***)
Definition angelic_extension {S T} (t:Transition S T) : Interaction S T := {|
  Com := t.(trans) ;
  Resp s c := unit ;
  Output s c x := t.(next) s c
|}.

(*** Demonic extension of transition structure. ***)
Definition demonic_extension {S T} (t:Transition S T) : Interaction S T := {|
  Com s := unit ;
  Resp s c := t.(trans) s ;
  Output s c x := t.(next) s x
|}.

(** Extension of a function *)
Definition functional_extension {S T} (f:S->T) : Interaction S T := {|
  Com s := unit ;
  Resp s c := unit ;
  Output s c x := f s
|}.

(*** Interaction structures as proof systems ***)

(* Interfaces are seen as a set of inference rules, where the states
   are the goals or judgement to be proved.

   The type of proofs for a given set of inference rules is just like
   the type of programs except there is no way to return the current
   goal: the proof is finished when there are no goals left to prove,
   i.e. when issuing a command whose return type is the empty type. *)
Inductive Proof_of {S} {i:Interface S} {s:S} : Type:=
 | rule (c:i.(Com) s) (k:forall (x:i.(Resp) c), @Proof_of S i (i.(Output) x)) : Proof_of
.
Arguments Proof_of {S} i _ : clear implicits.


Require Import Coq.Sets.Ensembles Bedrock.Platform.AutoSep Bedrock.Platform.Malloc.
Require Import Bedrock.Platform.Facade.examples.FiatADTs.

Infix "===" := (@Same_set W).

Definition empty := Empty_set W.
Notation "%0" := empty.

(* Who knows why this wrapper is necessary to keep the tactics happy.... *)
Module Type HAS.
  Parameter has : Ensemble W -> W -> Prop.
  Axiom has_eq : has = Ensembles.In _.
End HAS.

Module Has : HAS.
  Definition has := Ensembles.In W.
  Theorem has_eq : has = Ensembles.In _.
    auto.
  Qed.
End Has.

Import Has.
Export Has.

Infix "%has" := has (at level 70).

Definition add := Ensembles.Add W.
Infix "%+" := add (at level 50).

Definition sub := Subtract W.
Infix "%-" := sub (at level 50).

Section adt.
  Variable P : Ensemble W -> W -> HProp.
  Variable res : nat.

  Definition newS := SPEC("extra_stack") reserving res
    PRE[_] mallocHeap 0
    POST[R] P %0 R * mallocHeap 0.

  Definition deleteS := SPEC("extra_stack", "self") reserving res
    Al s,
    PRE[V] P s (V "self") * mallocHeap 0
    POST[R] [| R = $0 |] * mallocHeap 0.

  Definition memS := SPEC("extra_stack", "self", "n") reserving res
    Al s,
    PRE[V] P s (V "self") * mallocHeap 0
    POST[R] [| s %has V "n" \is R |] * P s (V "self") * mallocHeap 0.

  Definition addS := SPEC("extra_stack", "self", "n") reserving res
    Al s,
    PRE[V] P s (V "self") * mallocHeap 0
    POST[R] [| R = $0 |] * P (s %+ V "n") (V "self") * mallocHeap 0.

  Definition removeS := SPEC("extra_stack", "self", "n") reserving res
    Al s,
    PRE[V] P s (V "self") * mallocHeap 0
    POST[R] [| R = $0 |] * P (s %- V "n") (V "self") * mallocHeap 0.

  Definition cardinal_is (s : Ensemble W) (R : W) :=
    exists n, cardinal _ s n /\ R = natToWord _ n.

  Definition sizeS := SPEC("extra_stack", "self") reserving res
    Al s,
    PRE[V] P s (V "self") * mallocHeap 0
    POST[R] [| cardinal_is s R |] * P s (V "self") * mallocHeap 0.
End adt.


(** * K(A), the naive homotopy category of C(A) *)
(** ** Contents
- Definition of K(A)
*)
Require Import UniMath.Foundations.UnivalenceAxiom.
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.Foundations.NaturalNumbers.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.Algebra.BinaryOperations.
Require Import UniMath.Algebra.Monoids.
Require Import UniMath.Algebra.Groups.

Require Import UniMath.NumberSystems.Integers.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.TransportMorphisms.
Require Import UniMath.CategoryTheory.limits.zero.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.equalizers.
Require Import UniMath.CategoryTheory.limits.coequalizers.
Require Import UniMath.CategoryTheory.limits.kernels.
Require Import UniMath.CategoryTheory.limits.cokernels.
Require Import UniMath.CategoryTheory.limits.pushouts.
Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import UniMath.CategoryTheory.limits.BinDirectSums.
Require Import UniMath.CategoryTheory.Monics.
Require Import UniMath.CategoryTheory.Epis.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Equivalences.Core.

Require Import UniMath.CategoryTheory.CategoriesWithBinOps.
Require Import UniMath.CategoryTheory.PrecategoriesWithAbgrops.
Require Import UniMath.CategoryTheory.PreAdditive.
Require Import UniMath.CategoryTheory.Additive.
Require Import UniMath.CategoryTheory.Abelian.
Require Import UniMath.CategoryTheory.AbelianToAdditive.
Require Import UniMath.CategoryTheory.AdditiveFunctors.

Require Import UniMath.HomologicalAlgebra.Complexes.

Local Open Scope cat.

Unset Kernel Term Sharing.
Global Opaque hz.

Local Open Scope hz_scope.
Opaque hz isdecrelhzeq hzplus hzminus hzone hzzero iscommringops ZeroArrow ishinh.

(** * Homotopies of complexes and K(A), the naive homotopy category of A. *)
(** ** Introduction
   We define homotopy of complexes and the naive homotopy category K(A). A homotopy χ from complex
   X to a complex Y is a family of morphisms χ^i : X^i --> Y^{i-1}. Note that a homotopy χ induces
   a morphism of complexes h : X --> Y by setting
                      # h^i = χ^i · d^{i-1}_Y + d^i_X · χ^{i+1}. #
                      $ h^i = χ^i · d^{i-1}_Y + d^i_X · χ^{i+1}. $
   The subset of morphisms in Mor(X, Y) which are of the form h form an abelian subgroup of
   Mor(X, Y). Also, if f : Z_1 --> X and g : Y --> Z_2 are morphisms of complexes, then f · h and
   h · g have paths to morphisms induced by homotopies. These are given (f^i · χ^i) and
   (χ^i · g^{i-1}), respectively.

   These are the properties that are enough to form the quotient category of C(A) using
   [Quotcategory_Additive]. We call the resulting category the naive homotopy category of A, and
   denote it by K(A). The objects of K(A) are objects of C(A) and Mor_{K(A)}(X, Y) =
   Mor_{C(A)}(X, Y) / (the subgroup of null-homotopic morphisms, [ComplexHomotSubgrp]).

   Homotopies are defined in [ComplexHomot]. The induced morphisms of a homotopy is constructed in
   [ComplexHomotMorphism]. The subgroup of morphisms coming from homotopies is defined in
   [ComplexHomotSubgrp]. Pre- and postcomposition of morphisms coming from homotopies are morphisms
   coming from homotopies are proven in [ComplexHomotSubgrop_comp_right] and
   [ComplexHomotSubgrop_comp_left]. The naive homotopy category K(A) is constructed in
   [ComplexHomot_Additive].
*)
Section complexes_homotopies.

  Variable A : CategoryWithAdditiveStructure.

  Definition ComplexHomot (C1 C2 : Complex A) : UU := ∏ (i : hz), A⟦C1 i, C2 (i - 1)⟧.

  (** This lemma shows that the squares of the morphism map, defined by the homotopy H, commute. *)
  Local Lemma ComplexHomotMorphism_comm {C1 C2 : Complex A} (H : ComplexHomot C1 C2) (i : hz) :
    to_binop (C1 i) (C2 i)
             (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrminusplus i 1))
                         (H i · Diff C2 (i - 1)))
             (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrplusminus i 1))
                         (Diff C1 i · H (i + 1))) ·
             Diff C2 i =
    Diff C1 i · to_binop (C1 (i + 1)) (C2 (i + 1))
         (transportf (precategory_morphisms (C1 (i + 1))) (maponpaths C2 (hzrminusplus (i + 1) 1))
                     (H (i + 1) · Diff C2 (i + 1 - 1)))
         (transportf (precategory_morphisms (C1 (i + 1))) (maponpaths C2 (hzrplusminus (i + 1) 1))
                     (Diff C1 (i + 1) · H (i + 1 + 1))).
  Proof.
    (* First we get rid of the ZeroArrows *)
    rewrite to_postmor_linear'. rewrite to_premor_linear'.
    assert (e0 : (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrminusplus i 1))
                             (H i · Diff C2 (i - 1)) ·
                             Diff C2 i) = ZeroArrow (Additive.to_Zero A) _ _).
    {
      induction (hzrminusplus i 1). cbn. rewrite <- assoc.
      rewrite (@DSq A C2 (i - 1)). apply ZeroArrow_comp_right.
    }
    rewrite e0. clear e0.
    assert (e1 : (Diff C1 i · transportf (precategory_morphisms (C1 (i + 1)))
                       (maponpaths
                          C2 (hzrplusminus (i + 1) 1)) (Diff C1 (i + 1) · H (i + 1 + 1))) =
                 ZeroArrow (Additive.to_Zero A) _ _).
    {
      rewrite <- transport_target_postcompose. rewrite assoc. rewrite (@DSq A C1 i).
      rewrite ZeroArrow_comp_left. apply transport_target_ZeroArrow.
    }
    rewrite e1. clear e1.
    rewrite <- PreAdditive_unel_zero. rewrite to_lunax'. rewrite to_runax'.
    (* Here the idea is to apply cancel_precomposition *)
    rewrite transport_target_postcompose. rewrite <- assoc. apply cancel_precomposition.
    (* Other application of cancel_precomposition *)
    rewrite transport_compose. rewrite transport_target_postcompose. apply cancel_precomposition.
    (* Follows frm transport of differentials *)
    apply pathsinv0. rewrite <- maponpathsinv0.
    use (pathscomp0 _ (transport_hz_section A C2 1 (Diff C2) _ _ (hzrplusminus i 1))).
    use transportf_paths. apply maponpaths. apply isasethz.
  Qed.

  (** Every homotopy H of complexes induces a morphism of complexes. The morphism is defined by
      taking the map C1 i --> C2 i to be the sum
                         (H i) · (Diff C2 (i - 1)) + (Diff C1 i) · (H (i + 1)).
      Note that we need to use transportf because the targets are not definitionally equal. The
      target of the first is C2 (i - 1 + 1) and the second target is C2 (i + 1 - 1). We transport
      these to C2 i. *)
  Definition ComplexHomotMorphism {C1 C2 : Complex A} (H : ComplexHomot C1 C2) : Morphism C1 C2.
  Proof.
    use make_Morphism.
    - intros i.
      use (@to_binop A (C1 i) (C2 i)).
      + exact (transportf _ (maponpaths C2 (hzrminusplus i 1)) ((H i) · (Diff C2 (i - 1)))).
      + exact (transportf _ (maponpaths C2 (hzrplusminus i 1)) ((Diff C1 i) · (H (i + 1)))).
    - intros i. exact (ComplexHomotMorphism_comm H i).
  Defined.

  (** For all complexes C1 and C2, we define a subset of C1 --> C2 to consist of all the morphisms
      which have a path to a morphism induced by a homotopy H by [ComplexHomotMorphism]. Our goal is
      to show that this subset is an abelian subgroup, and thus we can form the quotient group. *)
  Definition ComplexHomotSubset (C1 C2 : Complex A) :
    @hsubtype ((ComplexPreCat_Additive A)⟦C1, C2⟧) :=
    (fun (f : ((ComplexPreCat_Additive A)⟦C1, C2⟧)) =>
       ∃ (H : ComplexHomot C1 C2), ComplexHomotMorphism H = f).

  (** This lemma shows that the subset [ComplexHomotSubset] satisfies the axioms of a subgroup. *)
  Lemma ComplexHomotisSubgrop (C1 C2 : Complex A) :
    @issubgr (@to_abgr (ComplexPreCat_Additive A) C1 C2) (ComplexHomotSubset C1 C2).
  Proof.
    use tpair.
    - use tpair.
      + intros f g. induction f as [f1 f2]. induction g as [g1 g2].
        use (squash_to_prop f2).
        { apply propproperty. }
        intros f3.
        use (squash_to_prop g2).
        { apply propproperty. }
        intros g3.
        induction f3 as [f3 f4].
        induction g3 as [g3 g4].
        use hinhpr. cbn.
        use tpair.
        * intros i.
          use to_binop.
          -- exact (f3 i).
          -- exact (g3 i).
        * cbn.
          rewrite <- f4. rewrite <- g4.
          use MorphismEq.
          intros i. cbn.
          rewrite to_postmor_linear'.
          rewrite to_premor_linear'.
          assert (e0 : (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrplusminus i 1))
                                   (to_binop (C1 i) (C2 (i + 1 - 1)) (Diff C1 i · f3 (i + 1))
                                             (Diff C1 i · g3 (i + 1)))) =
                       to_binop (C1 i) (C2 i)
                                (transportf (precategory_morphisms (C1 i))
                                            (maponpaths C2 (hzrplusminus i 1))
                                            (Diff C1 i · f3 (i + 1)))
                                (transportf (precategory_morphisms (C1 i))
                                            (maponpaths C2 (hzrplusminus i 1))
                                            (Diff C1 i · g3 (i + 1)))).
          {
            induction (hzrplusminus i 1). apply idpath.
          }
          cbn in e0. rewrite e0. clear e0.
          assert (e1 : (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrminusplus i 1))
                                   (to_binop (C1 i) (C2 (i - 1 + 1)) (f3 i · Diff C2 (i - 1))
                                             (g3 i · Diff C2 (i - 1)))) =
                       to_binop (C1 i) (C2 i)
                                (transportf (precategory_morphisms (C1 i))
                                            (maponpaths C2 (hzrminusplus i 1))
                                            (f3 i · Diff C2 (i - 1)))
                                (transportf (precategory_morphisms (C1 i))
                                            (maponpaths C2 (hzrminusplus i 1))
                                            (g3 i · Diff C2 (i - 1)))).
          {
            induction (hzrminusplus i 1). apply idpath.
          }
          cbn in e1. rewrite e1. clear e1.
          set (tmp := @assocax (@to_abgr A (C1 i) (C2 i))). cbn in tmp.
          rewrite tmp. rewrite tmp. apply maponpaths.
          rewrite <- tmp. rewrite <- tmp.
          set (tmp' := @commax (@to_abgr A (C1 i) (C2 i))). cbn in tmp'.
          rewrite tmp'.
          rewrite (tmp' _ (transportf (precategory_morphisms (C1 i))
                                      (maponpaths C2 (hzrplusminus i 1))
                                      (Diff C1 i · g3 (i + 1)))).
          apply maponpaths.
          apply tmp'.
      (* ZeroMorphisms *)
      + use hinhpr.
        use tpair.
        * intros i. exact (ZeroArrow (Additive.to_Zero A) _ _).
        * cbn. use MorphismEq. intros i. cbn. rewrite ZeroArrow_comp_left.
          rewrite transport_target_ZeroArrow.
          rewrite ZeroArrow_comp_right. rewrite transport_target_ZeroArrow.
          rewrite <- PreAdditive_unel_zero. rewrite to_lunax'. apply idpath.
    - intros f H. use (squash_to_prop H).
      { apply propproperty. }
      intros H'. clear H.
      induction H' as [homot eq]. use hinhpr.
      use tpair.
      + intros i. exact (grinv (to_abgr (C1 i) (C2 (i - 1))) (homot i)).
      + cbn. rewrite <- eq. use MorphismEq. intros i. cbn.
        set (tmp := @PreAdditive_invrcomp A _ _ _ (Diff C1 i) (homot (i + 1))).
        unfold to_inv in tmp. cbn in tmp. cbn. rewrite <- tmp. clear tmp.
        assert (e0 : (transportf (precategory_morphisms (C1 i))
                                 (maponpaths C2 (hzrplusminus i 1))
                                 (grinv (to_abgr (C1 i) (C2 (i + 1 - 1)))
                                        (Diff C1 i · homot (i + 1)))) =
                     to_inv (transportf (precategory_morphisms (C1 i))
                                        (maponpaths C2 (hzrplusminus i 1))
                                        (Diff C1 i · homot (i + 1)))).
        {
          unfold to_inv. cbn. induction (hzrplusminus i 1). apply idpath.
        }
        cbn in e0. rewrite e0. clear e0.
        assert (e1 : (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrminusplus i 1))
                                 (grinv (to_abgr (C1 i) (C2 (i - 1)))
                                        (homot i) · Diff C2 (i - 1))) =
                     to_inv (transportf (precategory_morphisms (C1 i))
                                        (maponpaths C2 (hzrminusplus i 1))
                                        (homot i · Diff C2 (i - 1)))).
        {
          unfold to_inv. cbn. induction (hzrminusplus i 1). cbn.
          set (tmp := @PreAdditive_invlcomp A (C1 i) (C2 (i - 1)) (C2 (i - 1 + 1))
                                            (homot i) (Diff C2 (i - 1))).
          apply pathsinv0. unfold to_inv in tmp.
          apply tmp.
        }
        cbn in e1. rewrite e1. clear e1.
        set (tmp' := @commax (@to_abgr A (C1 i) (C2 i))). cbn in tmp'. rewrite tmp'. clear tmp'.
        set (tmp := @grinvop (@to_abgr A (C1 i) (C2 i))). cbn in tmp. unfold to_inv.
        apply pathsinv0.
        apply tmp.
  Qed.

  Definition ComplexHomotSubgrp (C1 C2 : Complex A) :
    @subabgr (@to_abgr (ComplexPreCat_Additive A) C1 C2).
  Proof.
    use subgrconstr.
    - exact (ComplexHomotSubset C1 C2).
    - exact (ComplexHomotisSubgrop C1 C2).
  Defined.

  (** Pre- and postcomposition with morphisms in ComplexHomotSubset is in ComplexHomotSubset. *)
  Lemma ComplexHomotSubgrop_comp_left (C1 : Complex A) {C2 C3 : Complex A}
        (f : ((ComplexPreCat_Additive A)⟦C2, C3⟧)) (H : ComplexHomotSubset C2 C3 f) :
    ∏ (g : ((ComplexPreCat_Additive A)⟦C1, C2⟧)), ComplexHomotSubset C1 C3 (g · f).
  Proof.
    intros g.
    use (squash_to_prop H).
    { apply propproperty. }
    intros HH.
    use hinhpr.
    induction HH as [homot eq].
    use tpair.
    - intros i. exact ((MMor g i) · (homot i)).
    - cbn. rewrite <- eq. use MorphismEq. intros i. cbn. rewrite assoc.
      rewrite <- (MComm g i). rewrite transport_target_postcompose.
      rewrite transport_target_postcompose.
      rewrite <- assoc. rewrite <- assoc. rewrite <- to_premor_linear'.
      rewrite <- transport_target_postcompose. rewrite <- transport_target_postcompose.
      apply idpath.
  Qed.

  Lemma ComplexHomotSubgrop_comp_right {C1 C2 : Complex A} (C3 : Complex A)
        (f : ((ComplexPreCat_Additive A)⟦C1, C2⟧)) (H : ComplexHomotSubset C1 C2 f) :
    ∏ (g : ((ComplexPreCat_Additive A)⟦C2, C3⟧)), ComplexHomotSubset C1 C3 (f · g).
  Proof.
    intros g.
    use (squash_to_prop H).
    { apply propproperty. }
    intros HH.
    use hinhpr.
    induction HH as [homot eq].
    use tpair.
    - intros i. exact ((homot i) · (MMor g (i - 1))).
    - cbn. rewrite <- eq. use MorphismEq. intros i. cbn. rewrite <- assoc.
      rewrite (MComm g (i - 1)). rewrite assoc. rewrite assoc.
      assert (e0 : (transportf (precategory_morphisms (C1 i)) (maponpaths C3 (hzrminusplus i 1))
                               (homot i · Diff C2 (i - 1) · MMor g (i - 1 + 1))) =
                   (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrminusplus i 1))
                               (homot i · Diff C2 (i - 1))) · (MMor g i)).
      {
        induction (hzrminusplus i 1). apply idpath.
      }
      cbn in e0. rewrite e0. clear e0.
      assert (e1 : (transportf (precategory_morphisms (C1 i)) (maponpaths C3 (hzrplusminus i 1))
                               (Diff C1 i · homot (i + 1) · MMor g (i + 1 - 1))) =
                   (transportf (precategory_morphisms (C1 i)) (maponpaths C2 (hzrplusminus i 1))
                               (Diff C1 i · homot (i + 1))) · (MMor g i)).
      {
        induction (hzrplusminus i 1). apply idpath.
      }
      cbn in e1. rewrite e1. clear e1.
      rewrite <- to_postmor_linear'. apply idpath.
  Qed.

  (** ** Naive homotopy category
     We know that the homotopies from C1 to C2 form an abelian subgroup of the abelian group of all
     morphisms from C1 to C2, by [ComplexHomotSubgrp]. We also know that composition of a morphism
     with a morphism coming from a homotopy, is a morphism which comes from a homotopy, by
     [ComplexHomotSubgrop_comp_left] and [ComplexHomotSubgrop_comp_right]. This is enough to
     invoke our abstract construction Quotcategory_Additive, to construct the naive homotopy
     category. *)
  Local Lemma ComplexHomot_Additive_Comp :
    PreAdditiveComps (ComplexPreCat_Additive A)
                     (λ C1 C2 : ComplexPreCat_Additive A, ComplexHomotSubgrp C1 C2).
  Proof.
    intros C1 C2. split.
    - intros C3 f H g.
      apply ComplexHomotSubgrop_comp_right. apply H.
    - intros C3 f g H.
      apply ComplexHomotSubgrop_comp_left. apply H.
  Qed.

  (** Here we construct K(A). *)
  Definition ComplexHomot_Additive : CategoryWithAdditiveStructure :=
    Quotcategory_Additive
      (ComplexPreCat_Additive A) ComplexHomotSubgrp ComplexHomot_Additive_Comp.

  Definition ComplexHomotFunctor :
    AdditiveFunctor (ComplexPreCat_Additive A) ComplexHomot_Additive :=
    QuotcategoryAdditiveFunctor
      (ComplexPreCat_Additive A) ComplexHomotSubgrp ComplexHomot_Additive_Comp.
  Arguments ComplexHomotFunctor : simpl never.

  Lemma ComplexHomotFunctor_issurj {C1 C2 : ComplexPreCat_Additive A}
        (f : ComplexHomot_Additive⟦C1, C2⟧) : ∥ hfiber (# ComplexHomotFunctor) f ∥.
  Proof.
    apply issurjsetquotpr.
  Qed.

  Lemma ComplexHomotFunctor_rel_mor {C1 C2 : ComplexPreCat_Additive A}
        (f g : (ComplexPreCat_Additive A)⟦C1, C2⟧) (H : subgrhrel (ComplexHomotSubgrp C1 C2) f g) :
    # ComplexHomotFunctor f = # ComplexHomotFunctor g.
  Proof.
    apply abgrquotpr_rel_image. apply H.
  Qed.

  Lemma ComplexHomotFunctor_rel_mor' {C1 C2 : ComplexPreCat_Additive A}
        (f g : (ComplexPreCat_Additive A)⟦C1, C2⟧) (H : ComplexHomot C1 C2)
        (H' : to_binop _ _ f (to_inv g) = ComplexHomotMorphism H) :
    # ComplexHomotFunctor f = # ComplexHomotFunctor g.
  Proof.
    apply ComplexHomotFunctor_rel_mor.
    use hinhpr.
    use tpair.
    - cbn. use tpair.
      + exact (ComplexHomotMorphism H).
      + use hinhpr.
        use tpair.
        * exact H.
        * apply idpath.
    - exact (! H').
  Qed.

  Lemma ComplexHomotFunctor_mor_rel {C1 C2 : ComplexPreCat_Additive A}
        (f g : (ComplexPreCat_Additive A)⟦C1, C2⟧)
        (H : # ComplexHomotFunctor f = # ComplexHomotFunctor g) :
    subgrhrel (ComplexHomotSubgrp C1 C2) f g.
  Proof.
    use (@abgrquotpr_rel_paths _ (binopeqrel_subgr_eqrel (ComplexHomotSubgrp C1 C2))).
    apply H.
  Qed.

  Lemma ComplexHomotFunctor_im_to_homot {C1 C2 : ComplexPreCat_Additive A}
        (f g : (ComplexPreCat_Additive A)⟦C1, C2⟧)
        (H : # ComplexHomotFunctor f = # ComplexHomotFunctor g) :
    ∥ ∑ h : ComplexHomot C1 C2, ComplexHomotMorphism h = to_binop _ _ f (to_inv g) ∥.
  Proof.
    use (squash_to_prop (ComplexHomotFunctor_mor_rel f g H) (propproperty _)). intros h.
    induction h as [b hh]. cbn in b. unfold ComplexHomotSubset in b.
    use (squash_to_prop (pr2 b) (propproperty _)). intros hhh.
    induction hhh as [H1 H2]. cbn in hh. cbn in H2.
    use hinhpr.
    use tpair.
    - exact H1.
    - exact (H2 @ hh).
  Qed.

  Lemma ComplexHomotPreCompHomot {C1 C2 C3 : ComplexPreCat_Additive A}
        (f1 : (ComplexPreCat_Additive A)⟦C1, C2⟧) (f2 f3 : (ComplexPreCat_Additive A)⟦C2, C3⟧)
        (H : # ComplexHomotFunctor f2 = # ComplexHomotFunctor f3) :
    ∥ ∑ (h : ComplexHomot C1 C3),
    ComplexHomotMorphism h = to_binop _ _ (f1 · f2) (to_inv (f1 · f3)) ∥.
  Proof.
    assert (e : # ComplexHomotFunctor (f1 · f2) = # ComplexHomotFunctor (f1 · f3)).
    {
      rewrite functor_comp. rewrite H. rewrite functor_comp. apply idpath.
    }
    exact (ComplexHomotFunctor_im_to_homot (f1 · f2) (f1 · f3) e).
  Qed.

  Lemma ComplexHomotPostCompHomot {C1 C2 C3 : ComplexPreCat_Additive A}
        (f1 f2 : (ComplexPreCat_Additive A)⟦C1, C2⟧) (f3 : (ComplexPreCat_Additive A)⟦C2, C3⟧)
        (H : # ComplexHomotFunctor f1 = # ComplexHomotFunctor f2) :
    ∥ ∑ (h : ComplexHomot C1 C3),
    ComplexHomotMorphism h = to_binop _ _ (f1 · f3) (to_inv (f2 · f3)) ∥.
  Proof.
    assert (e : # ComplexHomotFunctor (f1 · f3) = # ComplexHomotFunctor (f2 · f3)).
    {
      rewrite functor_comp. rewrite H. rewrite functor_comp. apply idpath.
    }
    exact (ComplexHomotFunctor_im_to_homot (f1 · f3) (f2 · f3) e).
  Qed.

  (** Commutativity of squares *)

  Lemma ComplexHomotComm2 {C1 C2 C3 C4 : ob ComplexHomot_Additive}
        {f1 : C1 --> C2} {f2 : C2 --> C4} {g1 : C1 --> C3} {g2 : C3 --> C4}
        (f1' : hfiber (# ComplexHomotFunctor) f1) (f2' : hfiber (# ComplexHomotFunctor) f2)
        (g1' : hfiber (# ComplexHomotFunctor) g1) (g2' : hfiber (# ComplexHomotFunctor) g2)
        (H : f1 · f2 = g1 · g2) :
    # ComplexHomotFunctor ((hfiberpr1 _ _ f1') · (hfiberpr1 _ _ f2')) =
    # ComplexHomotFunctor ((hfiberpr1 _ _ g1') · (hfiberpr1 _ _ g2')).
  Proof.
    rewrite functor_comp. rewrite functor_comp.
    rewrite (hfiberpr2 _ _ f1'). rewrite (hfiberpr2 _ _ f2').
    rewrite (hfiberpr2 _ _ g1'). rewrite (hfiberpr2 _ _ g2').
    exact H.
  Qed.

  Lemma ComplexHomotComm3 {C1 C2 C3 C4 C5 C6 : ob ComplexHomot_Additive}
        {f1 : C1 --> C2} {f2 : C2 --> C3} {f3 : C3 --> C6}
        {g1 : C1 --> C4} {g2 : C4 --> C5} {g3 : C5 --> C6}
        (f1' : hfiber (# ComplexHomotFunctor) f1) (f2' : hfiber (# ComplexHomotFunctor) f2)
        (f3' : hfiber (# ComplexHomotFunctor) f3)
        (g1' : hfiber (# ComplexHomotFunctor) g1) (g2' : hfiber (# ComplexHomotFunctor) g2)
        (g3' : hfiber (# ComplexHomotFunctor) g3)
        (H : f1 · f2 · f3 = g1 · g2 · g3 ) :
    # ComplexHomotFunctor ((hfiberpr1 _ _ f1') · (hfiberpr1 _ _ f2') · (hfiberpr1 _ _ f3')) =
    # ComplexHomotFunctor ((hfiberpr1 _ _ g1') · (hfiberpr1 _ _ g2') · (hfiberpr1 _ _ g3')).
  Proof.
    rewrite functor_comp. rewrite functor_comp. rewrite functor_comp. rewrite functor_comp.
    rewrite (hfiberpr2 _ _ f1'). rewrite (hfiberpr2 _ _ f2'). rewrite (hfiberpr2 _ _ f3').
    rewrite (hfiberpr2 _ _ g1'). rewrite (hfiberpr2 _ _ g2'). rewrite (hfiberpr2 _ _ g3').
    exact H.
  Qed.

  Lemma ComplexHomotComm4 {C1 C2 C3 C4 C5 C6 C7 C8 : ob ComplexHomot_Additive}
        {f1 : C1 --> C2} {f2 : C2 --> C3} {f3 : C3 --> C4} {f4 : C4 --> C8}
        {g1 : C1 --> C5} {g2 : C5 --> C6} {g3 : C6 --> C7} {g4 : C7 --> C8}
        (f1' : hfiber (# ComplexHomotFunctor) f1) (f2' : hfiber (# ComplexHomotFunctor) f2)
        (f3' : hfiber (# ComplexHomotFunctor) f3) (f4' : hfiber (# ComplexHomotFunctor) f4)
        (g1' : hfiber (# ComplexHomotFunctor) g1) (g2' : hfiber (# ComplexHomotFunctor) g2)
        (g3' : hfiber (# ComplexHomotFunctor) g3) (g4' : hfiber (# ComplexHomotFunctor) g4)
        (H : f1 · f2 · f3 · f4 = g1 · g2 · g3 · g4) :
    # ComplexHomotFunctor ((hfiberpr1 _ _ f1') · (hfiberpr1 _ _ f2') · (hfiberpr1 _ _ f3')
                                               · (hfiberpr1 _ _ f4')) =
    # ComplexHomotFunctor ((hfiberpr1 _ _ g1') · (hfiberpr1 _ _ g2') · (hfiberpr1 _ _ g3')
                                               · (hfiberpr1 _ _ g4')).
  Proof.
    rewrite functor_comp. rewrite functor_comp. rewrite functor_comp. rewrite functor_comp.
    rewrite functor_comp. rewrite functor_comp.
    rewrite (hfiberpr2 _ _ f1'). rewrite (hfiberpr2 _ _ f2'). rewrite (hfiberpr2 _ _ f3').
    rewrite (hfiberpr2 _ _ f4').
    rewrite (hfiberpr2 _ _ g1'). rewrite (hfiberpr2 _ _ g2'). rewrite (hfiberpr2 _ _ g3').
    rewrite (hfiberpr2 _ _ g4').
    exact H.
  Qed.

End complexes_homotopies.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 Term Preservation Proof

*)

Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax Cyclone_Static_Semantics_Kinding_And_Context_Well_Formedness.
Require Export Cyclone_Dynamic_Semantics.
Require Export Cyclone_Classes Cyclone_Inductions Cyclone_LN_Tactics Cyclone_LN_Extra_Lemmas_And_Automation.
Require Export Cyclone_WFC_Lemmas.
Require Export Cyclone_WFU_Lemmas.
Require Export Cyclone_Context_Weakening_Proof.
Require Export Cyclone_Substitutions_Proof.
Require Export Cyclone_LN_Types_Lemmas.
Require Export Cyclone_Get_Lemmas.
Require Export Cyclone_Admit_Environment.
Require Export Cyclone_Canonical_Forms_Proof.
Close Scope list_scope.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

(* Try and formulate these, due to the value cases it's a bit funny. *)
Lemma A_14_Term_Progress_1:
  forall u g h,
    htyp u g h g ->
    refp h u ->
    forall e t,
      ltyp empty u g e t ->
      (exists x p, e = (p_e x p)) \/
      (exists h' e', L h (e_s e) h' e').
Proof.
  (* try one with a bad induction to get a feel. *)
  introv htypd refpd ltypd.
  induction ltypd.
  left.
  exists* (fevar x) p.
  right.
  destruct(classicT(Value e)).
  (* apply A_9_Canonical_Forms_4. *)
  admit. (* canonical forms lemma *)

Admitted.

Lemma A_14_Term_Progress_2:
  forall u g h,
    htyp u g h g ->
    refp h u ->
    forall e t,
      rtyp empty u g e t ->
      Value e \/
      (exists h' e', R h (e_s e) h' e').
Admitted.

Lemma A_14_Term_Progress_3:
  forall u g h,
    htyp u g h g ->
    refp h u ->
    forall s t,
      styp empty u g s t ->
      (exists v, Value v /\ s = (retn v)) \/
      (exists v, Value v /\ s = (e_s v)) \/
      (exists h' s', S h s h' s').
Admitted.


Require Import mathcomp.ssreflect.all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

From Ltac2 Require Import Ltac2.
Set Default Proof Mode "Classic".
From Utils Require Import Utils.
From Named Require Import Exp ARule.
From Named Require Import ImCore Pf.
From Named Require Import SimpleSubst.
Import Exp.Notations ARule.Notations.
Require Import String.

Set Default Proof Mode "Classic".

Definition stlc :=
  [::[:> "G" : #"env", "A" : #"ty", "B" : #"ty",
      "e" : #"el" (#"ext" %"G" %"A") %"B",
      "G'" : #"env",
      "g" : #"sub" %"G'" %"G"
      ----------------------------------------------- ("lambda_subst")
      #"el_subst" %"g" (#"lambda" %"A" %"e")
      = #"lambda" %"A" (#"el_subst" (#"snoc" (#"cmp" #"wkn" %"g") #"hd") %"e")
      : #"el" %"G'" (#"->" %"A" %"B")
  ];
  [:> "G" : #"env", "A" : #"ty", "B" : #"ty",
      "e" : #"el"%"G" (#"->" %"A" %"B"),
      "e'" : #"el" %"G" %"A",
      "G'" : #"env",
      "g" : #"sub" %"G'" %"G"
      ----------------------------------------------- ("app_subst")
      #"el_subst" %"g" (#"app" %"e" %"e'")
      = #"app" (#"el_subst" %"g" %"e") (#"el_subst" %"g" %"e'")
      : #"el" %"G'" %"B"
  ];
  [:> "G" : #"env",
      "A" : #"ty",
      "B" : #"ty",
      "e" : #"el" (#"ext" %"G" %"A") %"B",
      "e'" : #"el" %"G" %"A"
      ----------------------------------------------- ("STLC_beta")
      #"app" (#"lambda" %"A" %"e") %"e'"
      = #"el_subst" (#"snoc" #"id" %"e'") %"e"
      : #"el" %"G" %"B"
  ];
  [:| "G" : #"env",
       "A" : #"ty",
       "B" : #"ty",
       "e" : #"el" %"G" (#"->" %"A" %"B"),
       "e'" : #"el" %"G" %"A"
       -----------------------------------------------
       #"app" "e" "e'" : #"el" %"G" %"B"
  ];
  [:| "G" : #"env",
       "A" : #"ty",
       "B" : #"ty",
       "e" : #"el" (#"ext" %"G" %"A") %"B"
       -----------------------------------------------
       #"lambda" "A" "e" : #"el" %"G" (#"->" %"A" %"B")
  ];
  [:| "t" : #"ty", "t'": #"ty"
      -----------------------------------------------
      #"->" "t" "t'" : #"ty"
  ]]%arule++subst_lang.

Import OptionMonad.
Definition simple_subst_to_pf_ty (e:exp) : option pf :=
  match e with
  | var x => Some (pvar x)
  | con "->" [:: B; A] =>
    do pA <- simple_subst_to_pf_ty A;
       pB <- simple_subst_to_pf_ty B;
       ret (pcon "->" [:: pB; pA])
  | _ => None
  end.

Fixpoint simple_subst_to_pf_env (e:exp) : option pf :=
  match e with
  | var x => Some (pvar x)
  | con "emp" [::] => Some (pcon "emp" [::])
  | con "ext" [:: A; G] =>
    do pa <- simple_subst_to_pf_ty A;
       pG <- simple_subst_to_pf_env G;
       ret (pcon "ext" [:: pa; pG])
  | _ => None
  end.

Definition simple_subst_to_pf_sort (t:sort) : option pf :=
  match t with
  | scon "env" [::] => Some (pcon "env" [::])
  | scon "ty" [::] => Some (pcon "ty" [::])
  | scon "sub" [:: G'; G] =>
    do pG' <- simple_subst_to_pf_env G';
       pG <- simple_subst_to_pf_env G;
       ret (pcon "sub" [:: pG'; pG])
  | scon "el" [:: A; G] =>
    do pa <- simple_subst_to_pf_ty A;
       pG <- simple_subst_to_pf_env G;
       ret (pcon "el" [:: pa; pG])
  | _ => None
  end.

Fixpoint simple_subst_to_pf_sub (c : pf_ctx) (e :exp) G_l : option (pf * pf) :=
  match e with
  | var x =>
    do (pcon "sub" [:: G_r;_]) <- named_list_lookup_err c x;
       ret (pvar x, G_r)
  | con "id" [::] =>
    do ret (pcon "id" [:: G_l], G_l)
  | con "cmp" [:: g; f] =>
    do (p_f,G_fr) <- simple_subst_to_pf_sub c f G_l;
       (p_g, G_gr) <- simple_subst_to_pf_sub c g G_fr;
       ret (pcon "cmp" [:: p_g; p_f; G_gr; G_fr; G_l], G_gr)
  | con "forget" [::] =>
    do ret (pcon "forget" [:: G_l], pcon "emp" [::])
  | con "snoc" [:: e; f] =>
    do (p_f,G_fr) <- simple_subst_to_pf_sub c f G_l;
       (p_e, pA) <- simple_subst_to_pf_el c e G_l;
       ret (pcon "snoc" [:: p_e; p_f; pA; G_fr; G_l], pcon "ext" [:: pA; G_fr])
  | con "wkn" [::] =>
    do (pcon "ext" [:: A; G]) <- Some G_l;
       ret (pcon "wkn" [:: A; G], G)
  | _ => None
  end
with simple_subst_to_pf_el c e G : option (pf * pf) :=
       match e with
       | var x =>
         do (pcon "el" [:: A; _]) <- named_list_lookup_err c x;
         ret (pvar x, A)
       | con "el_subst" [:: e; f] =>
         do (p_f,G_fr) <- simple_subst_to_pf_sub c f G;
            (p_e, pA) <- simple_subst_to_pf_el c e G_fr;
            ret (pcon "el_subst" [:: p_e; pA; p_f; G_fr; G], pA)
      | con "hd" [::] =>
        do (pcon "ext" [:: A; G]) <- Some G;
           ret (pcon "hd" [:: A; G], A)
       | con "lambda" [:: e; A] =>
         do pA <- simple_subst_to_pf_ty A;
            (p_e, pB) <- simple_subst_to_pf_el c e (pcon "ext" [:: pA; G]);
            ret (pcon "lambda" [:: p_e; pB; pA; G], pcon "->" [:: pB; pA])
       | con "app" [:: e'; e] =>
         do (p_e, pcon "->" [:: pB; pA]) <- simple_subst_to_pf_el c e G;
            (p_e', _) <- simple_subst_to_pf_el c e' G;
            ret (pcon "app" [:: p_e'; p_e; pB; pA; G], pB)
       | _ => None
       end.

Definition simple_subst_to_pf_term (c : pf_ctx) (e :exp) t : option pf :=
  match t with
  | pcon "env" [::] => simple_subst_to_pf_env e
  | pcon "ty" [::] => simple_subst_to_pf_ty e
  | pcon "sub" [:: _ ; G_l] =>
    do (p,_) <- simple_subst_to_pf_sub c e G_l;
       ret p
  | pcon "el" [:: _ ; G] =>
    do (p,_) <- simple_subst_to_pf_el c e G;
       ret p
  | _ => None
  end.

Fixpoint simple_subst_to_pf_ctx (c : ctx) : option pf_ctx :=
  match c with
  | [::] => do ret [::]
  | (n,t)::c' =>
    do pc' <- simple_subst_to_pf_ctx c';
       pt <- simple_subst_to_pf_sort t;
       ret (n,pt)::pc'
  end.

Definition simple_subst_to_pf_rule (r : rule) : option rule_pf :=
  match r with
  | sort_rule c args =>
    do pc <- simple_subst_to_pf_ctx c;
    ret sort_rule_pf pc args
  | term_rule c args t =>
    do pt <- simple_subst_to_pf_sort t;
       pc <- simple_subst_to_pf_ctx c;
    ret term_rule_pf pc args pt
  | sort_le c t1 t2 =>
    do pt1 <- simple_subst_to_pf_sort t1;
       pt2 <- simple_subst_to_pf_sort t2;
       pc <- simple_subst_to_pf_ctx c;
    ret sort_le_pf pc pt1 pt2
  | term_le c e1 e2 t =>
    do pt <- simple_subst_to_pf_sort t;
       pc <- simple_subst_to_pf_ctx c;
       pe1 <- simple_subst_to_pf_term pc e1 pt;
       pe2 <- simple_subst_to_pf_term pc e2 pt;
    ret term_le_pf pc pe1 pe2 pt
end.

Fixpoint simple_subst_to_pf_lang (l : lang) : option pf_lang :=
  match l with
  | [::] => do ret [::]
  | (n,r)::l' =>
    do pl' <- simple_subst_to_pf_lang l';
       pr <- simple_subst_to_pf_rule r;
       ret (n,pr)::pl'
  end.

Lemma simple_stlc_wf : wf_lang stlc.
Proof.
  prove_wf_with_fn simple_subst_to_pf_lang.
Qed.

Derive elab_stlc
       SuchThat (Some elab_stlc = simple_subst_to_pf_lang stlc)
  As elab_stlc_pf.
Proof.
  compute; reflexivity.
Qed.


Require Import Verdi.GhostSimulations.

Require Import VerdiRaft.Raft.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Require Import VerdiRaft.CommonTheorems.
Require Import VerdiRaft.StateMachineSafetyInterface.
Require Import VerdiRaft.SortedInterface.
Require Import VerdiRaft.UniqueIndicesInterface.
Require Import VerdiRaft.LogMatchingInterface.
Require Import VerdiRaft.MaxIndexSanityInterface.
Require Import VerdiRaft.CommitRecordedCommittedInterface.
Require Import VerdiRaft.LeaderCompletenessInterface.
Require Import VerdiRaft.LastAppliedCommitIndexMatchingInterface.

Require Import VerdiRaft.SpecLemmas.

Require Import VerdiRaft.AppliedEntriesMonotonicInterface.

Section AppliedEntriesMonotonicProof.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {si : sorted_interface}.
  Context {lmi : log_matching_interface}.
  Context {uii : unique_indices_interface}.
  Context {smsi : state_machine_safety_interface}.
  Context {misi : max_index_sanity_interface}.
  Context {crci : commit_recorded_committed_interface}.
  Context {lci : leader_completeness_interface}.
  Context {lacimi : lastApplied_commitIndex_match_interface}.

  Lemma findAtIndex_max_thing :
    forall net h e i,
      raft_intermediate_reachable net ->
      In e (log (nwState net h)) ->
      eIndex e > i ->
      1 <= i ->
      exists e',
        findAtIndex (log (nwState net h)) i = Some e'.
  Proof using lmi si.
    intros.
    find_copy_apply_lem_hyp logs_sorted_invariant.
    pose proof log_matching_invariant.
    eapply_prop_hyp raft_intermediate_reachable raft_intermediate_reachable.
    unfold log_matching, log_matching_hosts, logs_sorted in *.
    intuition.
    match goal with
      | H : forall _ _, _ <= _ <= _ -> _ |- _ =>
        specialize (H h i);
          conclude H ltac:(intuition; find_apply_lem_hyp maxIndex_is_max; eauto; omega)
    end.
    break_exists_exists. intuition. apply findAtIndex_intro; eauto using sorted_uniqueIndices.
  Qed.

  Lemma entries_max_thing :
    forall net p es,
      raft_intermediate_reachable net ->
      In p (nwPackets net) ->
      mEntries (pBody p) = Some es ->
      es <> nil ->
      1 <= maxIndex es.
  Proof using lmi.
    intros.
    find_apply_lem_hyp maxIndex_non_empty.
    break_exists; intuition; find_rewrite.
    find_apply_lem_hyp log_matching_invariant.
    unfold log_matching, log_matching_nw in *.
    intuition. destruct (pBody p) eqn:?; simpl in *; try congruence.
    find_apply_hyp_hyp. intuition. find_inversion.
    find_apply_hyp_hyp. omega.
  Qed.

  Lemma deghost_snd :
    forall net h,
      snd (nwState net h) = nwState (deghost net) h.
  Proof using.
    intros. unfold deghost in *. simpl.
    repeat break_match; subst; simpl.
    repeat find_rewrite. reflexivity.
  Qed.

  Lemma lt_committed_committed :
    forall net e e' t h,
      log_matching (deghost net) ->
      committed net e t ->
      eIndex e' <= eIndex e ->
      In e (log (snd (nwState net h))) ->
      In e' (log (snd (nwState net h))) ->
      committed net e' t.
  Proof using.
    intros.
    unfold committed in *.
    break_exists_exists. intuition.
    unfold log_matching, log_matching_hosts in *.
    intuition. unfold entries_match in *.
    rewrite deghost_snd in *.
    match goal with
      | H : forall _ _ _ _ _, _  |- In _ (_ (_ _ ?x)) =>
        specialize (H h x e e e')
    end; intuition eauto.
  Qed.

  Lemma logs_contiguous :
    forall net h,
      raft_intermediate_reachable net ->
      contiguous_range_exact_lo (log (nwState net h)) 0.
  Proof using lmi.
    intros.
    find_apply_lem_hyp log_matching_invariant.
    unfold log_matching, log_matching_hosts in *.
    intuition.
    unfold contiguous_range_exact_lo.
    intuition eauto.
    find_apply_hyp_hyp. intuition.
  Qed.

  Lemma entries_gt_0 :
    forall net p es e,
      raft_intermediate_reachable net ->
      In p (nwPackets net) ->
      mEntries (pBody p) = Some es ->
      In e es ->
      0 < eIndex e.
  Proof using lmi.
    intros.
    find_apply_lem_hyp log_matching_invariant.
    unfold log_matching, log_matching_nw in *.
    intuition. destruct (pBody p) eqn:?; simpl in *; try congruence.
    find_inversion.
    find_apply_hyp_hyp. intuition.
    find_apply_hyp_hyp. omega.
  Qed.

  Lemma entries_gt_pli :
    forall net p e t n pli plt es ci,
      raft_intermediate_reachable net ->
      In p (nwPackets net) ->
      pBody p = AppendEntries t n pli plt es ci ->
      In e es ->
      pli < eIndex e.
  Proof using lmi.
    intros.
    find_apply_lem_hyp log_matching_invariant.
    unfold log_matching, log_matching_nw in *.
    intuition. destruct (pBody p) eqn:?; simpl in *; try congruence.
    find_inversion.
    find_apply_hyp_hyp. intuition.
  Qed.

  Lemma sorted_app :
    forall l l',
      sorted (l ++ l') ->
      sorted l.
  Proof using.
    induction l; simpl in *; intros; intuition eauto.
    - apply H0. intuition.
    - apply H0. intuition.
  Qed.

  Lemma handleMessage_applied_entries :
    forall net h h' m st' ms,
      raft_intermediate_reachable net ->
      In {| pBody := m; pDst := h; pSrc := h' |} (nwPackets net) ->
      handleMessage h' h m (nwState net h) = (st', ms) ->
      applied_entries (nwState net) = applied_entries (update name_eq_dec (nwState net) h st').
  Proof using misi smsi uii lmi si.
    intros. symmetry.
    unfold handleMessage in *. break_match; repeat break_let; repeat find_inversion.
    - apply applied_entries_log_lastApplied_update_same;
      eauto using handleRequestVote_same_log, handleRequestVote_same_lastApplied.
    - apply applied_entries_log_lastApplied_update_same;
      eauto using handleRequestVoteReply_same_log, handleRequestVoteReply_same_lastApplied.
    - find_copy_eapply_lem_hyp handleAppendEntries_logs_sorted;
      eauto using logs_sorted_invariant.
      apply applied_entries_safe_update; eauto using handleAppendEntries_same_lastApplied.
      find_apply_lem_hyp handleAppendEntries_log_detailed. intuition.
      + repeat find_rewrite. auto.
      + subst.
        find_copy_apply_lem_hyp state_machine_safety_invariant.
        unfold state_machine_safety in *. intuition.
        find_copy_apply_lem_hyp max_index_sanity_invariant. intuition.
        find_copy_apply_lem_hyp logs_sorted_invariant.
        unfold logs_sorted, maxIndex_sanity in *. intuition.
        apply removeAfterIndex_same_sufficient; eauto.
        * intros.
          copy_eapply_prop_hyp state_machine_safety_nw In;
            unfold commit_recorded in *.
            simpl in *; repeat (forwards; eauto; concludes).
            intuition; try omega;
            exfalso;
            find_eapply_lem_hyp findAtIndex_max_thing; eauto; try break_exists; try congruence;
            eauto using entries_max_thing;
            find_apply_lem_hyp logs_contiguous; auto; omega.
        * intros.
          find_copy_apply_lem_hyp log_matching_invariant.
          unfold log_matching, log_matching_hosts in *. intuition.
          match goal with
            | H : forall _ _, _ <= _ <= _ -> _ |- _ => specialize (H h (eIndex e));
                forward H
          end;
            copy_eapply_prop_hyp log_matching_nw AppendEntries; eauto;
            repeat (forwards; [intuition eauto; omega|]; concludes);
            intuition; [eapply le_trans; eauto|].
          match goal with
            | H : exists _, _ |- _ => destruct H as [e']
          end.
          intuition.
          copy_eapply_prop_hyp state_machine_safety_nw In;
            unfold commit_recorded in *;
            simpl in *; repeat (forwards; [intuition eauto; omega|]; concludes).
          match goal with H : _ /\ (_ \/ _) |- _ => clear H end.
          intuition; try omega;
          [|find_copy_apply_lem_hyp UniqueIndices_invariant;
             unfold UniqueIndices in *; intuition;
             eapply rachet; [symmetry|idtac|idtac|idtac|idtac]; eauto].
          exfalso.
          find_eapply_lem_hyp findAtIndex_max_thing; eauto; try break_exists; try congruence;
          eauto using entries_max_thing.
      + repeat find_rewrite.
        find_copy_apply_lem_hyp state_machine_safety_invariant.
        find_copy_apply_lem_hyp max_index_sanity_invariant.
        unfold state_machine_safety, maxIndex_sanity in *. intuition.
        find_copy_apply_lem_hyp logs_sorted_invariant.
        unfold logs_sorted in *. intuition.
        eapply removeAfterIndex_same_sufficient'; eauto using logs_contiguous.
        * intros. eapply entries_gt_0; intuition eauto.
        * intros.
          copy_eapply_prop_hyp state_machine_safety_nw In;
            unfold commit_recorded in *;
            simpl in *; repeat (forwards; [intuition eauto; omega|]; concludes).
          match goal with H : _ /\ (_ \/ _) |- _ => clear H end.
          intuition; try omega; try solve [find_apply_lem_hyp logs_contiguous; auto; omega].
          exfalso.
          subst.
          break_exists. intuition.
          find_false.
          find_apply_lem_hyp maxIndex_non_empty.
          break_exists. intuition. repeat find_rewrite.
          f_equal.
          find_apply_lem_hyp findAtIndex_elim. intuition.
          eapply uniqueIndices_elim_eq with (xs := log st'); eauto using sorted_uniqueIndices.
          unfold state_machine_safety_nw in *.
          eapply_prop_hyp commit_recorded In; intuition; eauto; try omega;
          try solve [find_apply_lem_hyp logs_contiguous; auto; omega].
          unfold commit_recorded. intuition.
      + repeat find_rewrite.
        find_copy_apply_lem_hyp logs_sorted_invariant.
        unfold logs_sorted in *. intuition.
        eapply removeAfterIndex_same_sufficient'; eauto using logs_contiguous.
        * { intros. do_in_app. intuition.
            - eapply entries_gt_0; eauto. reflexivity.
            - find_apply_lem_hyp removeAfterIndex_in.
              find_apply_lem_hyp logs_contiguous; eauto.
          }
        * find_apply_lem_hyp max_index_sanity_invariant.
          unfold maxIndex_sanity in *. intuition.
        * intros.
          find_copy_apply_lem_hyp state_machine_safety_invariant.
          unfold state_machine_safety in *. break_and.
          copy_eapply_prop_hyp state_machine_safety_nw In; eauto.
          simpl in *. intuition eauto. forwards; eauto. concludes.
          forwards; [unfold commit_recorded in *; intuition eauto|].
          concludes.
          intuition; apply in_app_iff;
          try solve [right; eapply removeAfterIndex_le_In; eauto; omega];
          exfalso.
          find_eapply_lem_hyp findAtIndex_max_thing; eauto using entries_max_thing.
          break_exists; congruence.
      + break_exists. intuition. subst.
        repeat find_rewrite.
        find_copy_apply_lem_hyp logs_sorted_invariant.
        unfold logs_sorted in *. intuition.
        eapply removeAfterIndex_same_sufficient'; eauto using logs_contiguous.
        * { intros. do_in_app. intuition.
            - eapply entries_gt_0; eauto. reflexivity.
            - find_apply_lem_hyp removeAfterIndex_in.
              find_apply_lem_hyp logs_contiguous; eauto.
          }
        * find_apply_lem_hyp max_index_sanity_invariant.
          unfold maxIndex_sanity in *. intuition.
        * {
            intros.
            find_copy_apply_lem_hyp state_machine_safety_invariant.
            unfold state_machine_safety in *. break_and.
            copy_eapply_prop_hyp state_machine_safety_nw In; eauto.
            simpl in *. intuition eauto. forwards; eauto. concludes.
            forwards; [unfold commit_recorded in *; intuition eauto|].
            concludes.
            intuition; apply in_app_iff;
            try solve [right; eapply removeAfterIndex_le_In; eauto; omega].
            subst.
            find_apply_lem_hyp maxIndex_non_empty.
            break_exists. intuition. repeat find_rewrite.
            find_apply_lem_hyp findAtIndex_elim. intuition.
            find_false. f_equal.
            eapply uniqueIndices_elim_eq with (xs := log (nwState net h));
              eauto using sorted_uniqueIndices.
            unfold state_machine_safety_nw in *.
            eapply rachet; eauto using sorted_app, sorted_uniqueIndices.
            copy_eapply_prop_hyp commit_recorded In; intuition; eauto; try omega;
            unfold commit_recorded; intuition.
            - exfalso.
              pose proof entries_gt_pli.
              eapply_prop_hyp AppendEntries AppendEntries;
                [|idtac|simpl; eauto|]; eauto. omega.
            -  exfalso.
              pose proof entries_gt_pli.
              eapply_prop_hyp AppendEntries AppendEntries;
                [|idtac|simpl; eauto|]; eauto. omega.
          }
    - apply applied_entries_log_lastApplied_update_same;
      eauto using handleAppendEntriesReply_same_log, handleAppendEntriesReply_same_lastApplied.
  Qed.

  Theorem handleTimeout_log :
    forall h st out st' ps,
      handleTimeout h st = (out, st', ps) ->
      log st' = log st.
  Proof using.
    intros. unfold handleTimeout, tryToBecomeLeader in *.
    break_match; find_inversion; subst; auto.
  Qed.

  Lemma handleInput_applied_entries :
    forall net h inp os st' ms,
      raft_intermediate_reachable net ->
      handleInput h inp (nwState net h) = (os, st', ms) ->
      applied_entries (nwState net) = applied_entries (update name_eq_dec (nwState net) h st').
  Proof using misi.
    intros. symmetry.
    unfold handleInput in *. break_match; repeat break_let; repeat find_inversion.
    - apply applied_entries_log_lastApplied_update_same;
      eauto using handleTimeout_log, handleTimeout_lastApplied.
    - apply applied_entries_safe_update; eauto using handleClientRequest_lastApplied.

      destruct (log st') using (handleClientRequest_log_ind ltac:(eauto)); auto.

      simpl in *. break_if; auto.
      exfalso.
      do_bool.
      find_apply_lem_hyp max_index_sanity_invariant.
      unfold maxIndex_sanity, maxIndex_lastApplied in *.
      intuition.
      match goal with
        | H : forall _, _ |- _ => specialize (H h)
      end. omega.
  Qed.

  Lemma doGenericServer_applied_entries :
    forall ps h sigma os st' ms,
      raft_intermediate_reachable (mkNetwork ps sigma) ->
      doGenericServer h (sigma h) = (os, st', ms) ->
      exists es, applied_entries (update name_eq_dec sigma h st') = (applied_entries sigma) ++ es.
  Proof using lacimi si.
    intros.
    unfold doGenericServer in *. break_let. find_inversion.
    use_applyEntries_spec. subst. simpl in *. unfold raft_data in *.
    simpl in *.
    break_if; [|rewrite applied_entries_safe_update; simpl in *; eauto using app_nil_r].
    do_bool.
    match goal with
      | |- context [update _ ?sigma ?h ?st] => pose proof applied_entries_update sigma h st
    end.
    simpl in *.
    assert (commitIndex (sigma h) >= lastApplied (sigma h)) by omega.
    concludes. intuition.
    - find_rewrite. eauto using app_nil_r.
    - pose proof applied_entries_cases sigma.
      intuition; repeat find_rewrite; eauto.
      match goal with | H : exists _, _ |- _ => destruct H as [h'] end.
      repeat find_rewrite.
      find_apply_lem_hyp argmax_elim. intuition.
      match goal with
        | H : forall _: name, _ |- _ =>
          specialize (H h'); conclude H ltac:(eauto using all_fin_all)
      end.
      rewrite_update. simpl in *.
      update_destruct_hyp; subst; rewrite_update; simpl in *.
      + apply rev_exists.
        erewrite removeAfterIndex_le with (i := lastApplied (sigma h')) (j := commitIndex (sigma h')); [|omega].
        eauto using removeAfterIndex_partition.
      + apply rev_exists.
        match goal with
          | _ : ?h <> ?h' |- exists _, removeAfterIndex ?l (commitIndex (?sigma ?h)) = _ =>
            pose proof removeAfterIndex_partition (removeAfterIndex l (commitIndex (sigma h)))
                 (lastApplied (sigma h'))
        end. break_exists_exists.
        repeat match goal with | H : applied_entries _ = _ |- _ => clear H end.
        find_rewrite. f_equal.
        erewrite <- removeAfterIndex_le; eauto.
        find_copy_apply_lem_hyp logs_sorted_invariant. unfold logs_sorted in *.
        intuition. find_copy_apply_lem_hyp lastApplied_commitIndex_match_invariant.
        eapply removeAfterIndex_same_sufficient; eauto;
        intros;
        eapply_prop_hyp lastApplied_commitIndex_match le; intuition eauto.
  Qed.

  Theorem applied_entries_monotonic' :
    forall failed net failed' net' os,
      raft_intermediate_reachable net ->
      (@step_failure _ _ failure_params (failed, net) (failed', net') os) ->
      exists es,
        applied_entries (nwState net') = applied_entries (nwState net) ++ es.
  Proof using lacimi misi smsi uii lmi si.
    intros. match goal with H : step_failure _ _ _ |- _ => invcs H end.
    - unfold RaftNetHandler in *. repeat break_let. subst.
      find_inversion.
      match goal with
        | Hdl : doLeader ?st ?h = _,
          Hdgs : doGenericServer ?h ?st' = _ |- context [update _ (nwState ?net) ?h ?st''] =>
          replace st with (update name_eq_dec (nwState net) h st h) in Hdl by eauto using update_eq;
            replace st' with (update name_eq_dec (update name_eq_dec (nwState net) h st) h st' h) in Hdgs by eauto using update_eq;
            let H := fresh "H" in
            assert (update name_eq_dec (nwState net) h st'' =
                    update name_eq_dec (update name_eq_dec (update name_eq_dec (nwState net) h st) h st') h st'') by (repeat rewrite update_overwrite; auto); unfold data in *; simpl in *; rewrite H; clear H
      end.
      find_copy_apply_lem_hyp doLeader_appliedEntries.
      find_copy_eapply_lem_hyp RIR_handleMessage; eauto.
      find_eapply_lem_hyp RIR_doLeader; simpl in *; eauto.
      find_apply_lem_hyp handleMessage_applied_entries; auto; [|destruct p; find_rewrite; in_crush].
      unfold raft_data in *. simpl in *. unfold raft_data in *. simpl in *.
      match goal with
        | H : applied_entries (update _ (update _ _ _ _) _ _) =
              applied_entries (update _ _ _ _) |- _ =>
          symmetry in H
      end.
      repeat find_rewrite.
      repeat match goal with H : applied_entries _ = applied_entries _ |- _ => clear H end.
      eauto using doGenericServer_applied_entries.
    - unfold RaftInputHandler in *. repeat break_let. subst.
      find_inversion.
      match goal with
        | Hdgs : doGenericServer ?h ?st' = _,
          Hdl : doLeader ?st ?h = _ |- context [update _ (nwState ?net) ?h ?st''] =>
          replace st with (update name_eq_dec (nwState net) h st h) in Hdl by eauto using update_eq;
            replace st' with (update name_eq_dec (update name_eq_dec (nwState net) h st) h st' h) in Hdgs by eauto using update_eq;
            let H := fresh "H" in
            assert (update name_eq_dec (nwState net) h st'' =
                    update name_eq_dec (update name_eq_dec (update name_eq_dec (nwState net) h st) h st') h st'') by (repeat rewrite update_overwrite; auto); unfold data in *; simpl in *; rewrite H; clear H
      end.
      find_copy_apply_lem_hyp doLeader_appliedEntries.
      find_copy_eapply_lem_hyp RIR_handleInput; eauto.
      find_eapply_lem_hyp RIR_doLeader; simpl in *; eauto.
      find_apply_lem_hyp handleInput_applied_entries; auto.
      unfold raft_data in *. simpl in *. unfold raft_data in *. simpl in *.
      match goal with
        | H : applied_entries (update _ (update _ _ _ _) _ _) =
              applied_entries (update _ _ _ _) |- _ =>
          symmetry in H
      end.
      repeat find_rewrite.
      repeat match goal with H : applied_entries _ = applied_entries _ |- _ => clear H end.
      eauto using doGenericServer_applied_entries.
    - exists nil; intuition.
    - exists nil; intuition.
    - exists nil; intuition.
    - exists nil.
      rewrite app_nil_r.
      apply applied_entries_log_lastApplied_same;
        intros; unfold reboot in *; update_destruct_max_simplify; auto.
  Qed.

  Theorem applied_entries_monotonic :
    forall e failed net failed' net' os,
      raft_intermediate_reachable net ->
      (@step_failure _ _ failure_params (failed, net) (failed', net') os) ->
      In e (applied_entries (nwState net)) ->
      In e (applied_entries (nwState net')).
  Proof using lacimi misi smsi uii lmi si.
    intros. find_eapply_lem_hyp applied_entries_monotonic'; eauto.
    break_exists. find_rewrite. in_crush.
  Qed.

  Instance aemi : applied_entries_monotonic_interface.
  Proof.
    split;
    eauto using applied_entries_monotonic,
                applied_entries_monotonic'.
  Qed.

End AppliedEntriesMonotonicProof.