Set Warnings "-notation-overridden".
From mathcomp Require Import all_ssreflect boolp.
Set Warnings "notation-overridden".
From Relational Require Import OrderEnrichedCategory OrderEnrichedRelativeMonadExamples.
From Crypt Require Import ChoiceAsOrd choice_type.
From Crypt Require Import SubDistr.

(*so that Next Obligation doesnt introduce variables by itself:*)
Obligation Tactic := try (Tactics.program_simpl ; fail) ; simpl.

(*
In this file we pack pairs of free probabilistic computations into a
(order enriched) relative monad instance (see ord_relativeMonad).

Some informations about free monads:

The unary Free monad can be parametrized by a collection of operations S
and arities for those operations (somth of type S -> choiceType).
Concretely S could be the collection {(sample_bollean p) | p in [01]}, ie
one Bernouilli sampling operation for each probability p. In this case
the arity predicate (ar : S -> choiceType) would map each operation to bool
(or rather the choiceType instance for bool).
Indeed we expect the environment to either return true or false after
a Bernouilli sampling operation has been issued to it.

We take S = { X: choice_type & SDistr X }, that is, each subdistribution
sampling from a choiceType present in choice_type (a small universe of choiceTypes)
is considered as being part of our probabilistic signature (S,P)
where P : S -> choiceType is the first projection.

NOTE regarding ancient design:

Note that before we were specifying a probabilistic operation with
an ITree like event type
Inductive probE : Type -> Type :=
  |Bern : unit_interval R -> probE bool
  |Poisson : (λ : unit_interval R) → probE nat.
The parameter of the inductive is supposed to be the type of the valued
returned by the environment after an operation has been issued. The
parameters of the constructors are supposed to represent the information
we would like to pass when we issue an operation. For instance when
sampling uniformly a boolean we need to provide a probability p : [O,1].
We were using this last way of specifying sampling operations generically
and we were translating this signature
internally into a collection of operations S and an
arity predicate ar : S -> choiceType
*)

Section Extensionality_for_ordfunctors.
  (*work in progress*)

  (*the following relies on proof irrelevance (see file axioms)*)
  (*/!\ also need the arrow map*)
  Lemma functor_ext : forall (C D : ord_category) (F G : ord_functor C D),
  (forall A : C, F A = G A) -> F = G.
  Proof.
    intros C D F G H.  apply boolp.funext in H.
    destruct F as [F F2 F3 F4 F5]. destruct G as [G G2 G3 G4 G5].
    simpl in H.
    move: F2 F3 F4 F5 G2 G3 G4 G5.
    rewrite !H. intuition. assert (FG2 : F2 = G2).
  Abort.

End Extensionality_for_ordfunctors.

Section RelativeFreeMonad.
  (*This section defines a unary free monad relative to choice_incl.
   In this section the free relative monad is parametrized by an arbitrary
   set S of operations. In subsequent sections this set S is an actual set of
   probabilistic operations. *)

  (* A signature where S is the type of operations and P describes the
     arity of each operations *)
  Context (S : Type) (P : S  -> choiceType).

  Inductive rFreeF (A : choiceType) : Type :=
  | retrFree : A -> rFreeF A
  | ropr     : forall s, (P s -> rFreeF A) -> rFreeF A.

  Arguments ropr [A] _ _.

  Fixpoint bindrFree {A B : choiceType} (c : rFreeF A)
  (k : TypeCat ⦅ choice_incl A ; rFreeF B ⦆ )
  : rFreeF B :=
    match c with
    | retrFree a => k a
    | ropr s ar  => ropr s (fun p => bindrFree (ar p) k)
    end.

  Definition callrFree (s : S) : rFreeF (P s) := ropr s (fun k => retrFree _ k).

  Program Definition rFree : ord_relativeMonad choice_incl :=
    @mkOrdRelativeMonad ord_choiceType TypeCat choice_incl rFreeF _ _ _ _ _ _.
  Next Obligation. constructor. assumption. Defined.
  Next Obligation.
    intros A B. intros ff mm. exact (bindrFree mm ff).
  Defined.
  Next Obligation.
    cbv ; intuition. f_equal. apply funext. move=> a. eapply H.
  Qed.
  Next Obligation.
    intro A. apply funext.
    intro c. elim: c.
      simpl. reflexivity.
    intros s ar IH. simpl. f_equal. apply funext.
    assumption.
  Qed.
  Next Obligation.
    intros.
    apply funext. intro c. induction c.
      simpl. reflexivity.
    simpl. f_equal. apply funext. intro p.
    eapply H.
  Qed.

End RelativeFreeMonad.

Section Unary_free_prob_monad.

  (* the type of probabilistic operations*)
  Definition P_OP  := { X : choice_type & SDistr X }.

  (* the arities for operations in OPP*)
  Definition P_AR : P_OP -> choiceType :=
    fun op => chElement ( projT1 op ).

  Definition rFreePr := rFree P_OP P_AR.

End Unary_free_prob_monad.

Section Pairs_of_probabilistic_computations.
  (*We want to obtain a product of relative monads, the product of rFreePr
  with itself. We use the support for product of relative
  monads provided by the dm4all devlopment .*)

  Definition rFreeProb_squ_fromProd :=
    product_rmon rFreePr rFreePr.

  (*alias for retro compatibility*)
  Definition rFreeProb_squ := rFreeProb_squ_fromProd.

End Pairs_of_probabilistic_computations.


Require Import HoTT.HIT.quotient
  HoTT.Basics.PathGroupoids
  HoTT.Types.Universe
  HoTT.Basics.Trunc
  HoTT.Basics.Decidable.
Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.theory.rings
  HoTT.Classes.theory.dec_fields.

Module Frac.

Section contents.
Universe UR.
Context `{Funext} `{Univalence} (R:Type@{UR})
  `{IsIntegralDomain R} `{DecidablePaths R}.

Record Frac@{} : Type
  := frac { num: R; den: R; den_ne_0: PropHolds (den <> 0) }.
  (* We used to have [den] and [den_nonzero] bundled,
     which did work relatively nicely with Program, but the
     extra messyness in proofs etc turned out not to be worth it. *)

Lemma Frac_ishset' : IsHSet Frac.
Proof.
assert (E : sigT (fun n : R => sigT (fun d : R => ~ d = 0 )) <~> Frac).
- issig.
- apply (trunc_equiv' _ E).
Qed.

Global Instance Frac_ishset@{} : IsHSet Frac
  := ltac:(first [exact Frac_ishset'@{UR Ularge Set}|
                  exact Frac_ishset'@{}]).

Local Existing Instance den_ne_0.

Global Instance Frac_inject@{} : Cast R Frac.
Proof.
intros x. apply (frac x 1 _).
Defined.

Global Instance Frac_0@{} : Zero Frac := ('0 : Frac).
Global Instance Frac_1@{} : One Frac := ('1 : Frac).

Instance pl@{} : Plus Frac.
Proof.
intros q r; refine (frac (num q * den r + num r * den q) (den q * den r) _).
Defined.

Definition equiv@{} := fun x y => num x * den y = num y * den x.

Global Instance equiv_equiv_rel@{} : EquivRel equiv.
Proof.
split.
- intros x. hnf. reflexivity.
- intros x y. unfold equiv.
  apply symmetry.
- intros x y z. unfold equiv.
  intros E1 E2.
  apply (mult_left_cancel (den y)).
  + solve_propholds.
  + rewrite !mult_assoc, !(mult_comm (den y)).
    rewrite E1, <-E2.
    rewrite <-!mult_assoc. rewrite (mult_comm (den x)).
    reflexivity.
Qed.

Global Instance equiv_dec@{} : forall x y: Frac, Decidable (equiv x y)
  := fun x y => decide_rel (=) (num x * den y) (num y * den x).

Lemma pl_respect@{} : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 ->
  equiv (q1 + r1) (q2 + r2).
Proof.
unfold equiv;intros q1 q2 Eq r1 r2 Er.
simpl.
rewrite plus_mult_distr_r.
rewrite <-(associativity (num q1) (den r1)).
rewrite (associativity (den r1)), (mult_comm (den r1)), <-(associativity (den q2)).
rewrite (associativity (num q1)), Eq.
rewrite (mult_comm (den q2)), <-(associativity (num r1)), (associativity (den q1)).
rewrite (mult_comm (den q1)), <-(associativity (den r2)), (associativity (num r1)).
rewrite Er.
rewrite (mult_comm (den r1)), <-(associativity (num q2)), (associativity (den q1)).
rewrite (mult_comm (den q1)), <-(associativity (den r2)), (associativity (num q2)).
rewrite <-(associativity (num r2)), (associativity (den r1)),
  (mult_comm _ (den q2)).
rewrite (mult_comm (den r1)), (associativity (num r2)).
apply symmetry;apply plus_mult_distr_r.
Qed.

Lemma pl_comm@{} : forall q r, equiv (pl q r) (pl r q).
Proof.
intros q r;unfold equiv;simpl.
rewrite (mult_comm (den r)), plus_comm. reflexivity.
Qed.

Lemma pl_assoc@{} : forall q r t, equiv (pl q (pl r t)) (pl (pl q r) t).
Proof.
intros;unfold equiv;simpl.
apply ap011;[|apply symmetry,associativity].
rewrite plus_mult_distr_r.
rewrite (plus_mult_distr_r _ _ (den t)).
rewrite plus_assoc. apply ap011;[apply ap011|].
- apply associativity.
- rewrite <-(associativity (num r)), <-(associativity (num r) (den q)).
  rewrite (mult_comm (den t)). reflexivity.
- rewrite (mult_comm (den q));apply symmetry,associativity.
Qed.

Instance ml@{} : Mult Frac.
Proof.
intros q r; refine (frac (num q * num r) (den q * den r) _).
Defined.

Lemma ml_respect@{} : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 ->
  equiv (q1 * r1) (q2 * r2).
Proof.
unfold equiv;intros q1 q2 Eq r1 r2 Er.
simpl.
rewrite <-(associativity (num q1)), (associativity (num r1)).
rewrite (mult_comm (num r1)), <-(associativity (den q2)), (associativity (num q1)).
rewrite Eq, Er.
rewrite <-(associativity (num q2)), (associativity (den q1)), (mult_comm (den q1)).
rewrite <-(simple_associativity (num r2)), <-(simple_associativity (num q2)).
reflexivity.
Qed.

Instance neg@{} : Negate Frac.
Proof.
intros q;refine (frac (- num q) (den q) _).
Defined.

Lemma neg_respect@{} : forall q r, equiv q r -> equiv (- q) (- r).
Proof.
unfold equiv;simpl;intros q r E.
rewrite <-2!negate_mult_distr_l. rewrite E;reflexivity.
Qed.

Lemma nonzero_num@{} x : ~ equiv x 0 <-> num x <> 0.
Proof.
split; intros E F; apply E.
- red. rewrite F. simpl. rewrite 2!mult_0_l. reflexivity.
- red in F;simpl in F. rewrite mult_1_r, mult_0_l in F. trivial.
Qed.

Lemma pl_0_l@{} x : equiv (0 + x) x.
Proof.
red;simpl. rewrite mult_1_r, mult_0_l, mult_1_l, plus_0_l. reflexivity.
Qed.

Lemma pl_0_r@{} x : equiv (x + 0) x.
Proof.
red;simpl. rewrite 2!mult_1_r, mult_0_l, plus_0_r. reflexivity.
Qed.

Lemma pl_neg_l@{} x : equiv (- x + x) 0.
Proof.
red;simpl.
rewrite mult_1_r, mult_0_l.
rewrite <-plus_mult_distr_r.
rewrite plus_negate_l.
apply mult_0_l.
Qed.

Lemma ml_assoc@{} q r t : equiv (ml q (ml r t)) (ml (ml q r) t).
Proof.
red;simpl.
rewrite (associativity (num q)), (associativity (den q)).
reflexivity.
Qed.

Instance dec_rec@{} : DecRecip Frac := fun x =>
  match decide_rel (=) (num x) 0 with
  | inl _ => 0
  | inr P => frac (den x) (num x) P
  end.

Lemma dec_recip_respect@{} : forall q r, equiv q r -> equiv (/ q) (/ r).
Proof.
unfold equiv,dec_recip,dec_rec;intros q r E;simpl.
destruct (decide_rel paths (num q) 0) as [E1|E1],
(decide_rel paths (num r) 0) as [E2|E2];simpl.
- trivial.
- rewrite E1 in E;rewrite mult_0_l in E.
  destruct E2.
  apply (right_cancellation_ne_0 mult (den q));try solve_propholds.
  rewrite mult_0_l;apply symmetry,E.
- rewrite E2 in E;rewrite mult_0_l in E.
  destruct E1.
  apply (right_cancellation_ne_0 mult (den r));try solve_propholds.
  rewrite mult_0_l;trivial.
- rewrite (mult_comm (den q)), (mult_comm (den r)).
  apply symmetry, E.
Qed.

End contents.

Arguments Frac R {Rzero} : rename.
Arguments frac {R Rzero} _ _ _ : rename.
Arguments num {R Rzero} _ : rename.
Arguments den {R Rzero} _ : rename.
Arguments den_ne_0 {R Rzero} _ _ : rename.
Arguments equiv {R _ _} _ _.

Section morphisms.
Context {R1} `{IsIntegralDomain R1} `{DecidablePaths R1}.
Context {R2} `{IsIntegralDomain R2} `{DecidablePaths R2}.
Context `(f : R1 -> R2) `{!IsSemiRingPreserving f} `{!IsInjective f}.

Definition lift (x : Frac R1) : Frac R2.
Proof.
apply (frac (f (num x)) (f (den x))).
apply isinjective_ne_0.
apply (den_ne_0 x).
Defined.

Lemma lift_respects : forall q r, equiv q r -> equiv (lift q) (lift r).
Proof.
unfold equiv;simpl;intros q r E.
rewrite <-2!preserves_mult.
apply ap,E.
Qed.

End morphisms.

End Frac.
Import Frac.

Module FracField.

Section contents.
(* NB: we need a separate IsHSet instance
   so we don't need to depend on everything to define F. *)
Universe UR.
Context `{Funext} `{Univalence} {R:Type@{UR} } `{IsHSet R} `{IsIntegralDomain R}
  `{DecidablePaths R}.

Local Existing Instance den_ne_0.

(* Add Ring R: (stdlib_ring_theory R). *)

Definition F@{} := quotient equiv.

Global Instance class@{} : Cast (Frac R) F := class_of _.

(* injection from R *)

Global Instance inject@{} : Cast R F := Compose class (Frac_inject _).

Definition path@{} {x y} : equiv x y -> ' x = ' y := related_classes_eq _.

Definition F_rect@{i} (P : F -> Type@{i}) {sP : forall x, IsHSet (P x)}
  (dclass : forall x : Frac R, P (' x))
  (dequiv : forall x y E, (path E) # (dclass x) = (dclass y))
  : forall q, P q
  := quotient_ind equiv P dclass dequiv.

Definition F_compute P {sP} dclass dequiv x
 : @F_rect P sP dclass dequiv (' x) = dclass x := 1.

Definition F_compute_path P {sP} dclass dequiv q r (E : equiv q r)
  : apD (@F_rect P sP dclass dequiv) (path E) = dequiv q r E
  := quotient_ind_compute_path _ _ _ _ _ _ _ _.

Definition F_ind@{i} (P : F -> Type@{i}) {sP : forall x, IsHProp (P x)}
  (dclass : forall x : Frac R, P (' x)) : forall x, P x.
Proof.
apply (@F_rect P (fun _ => trunc_hprop) dclass).
intros;apply path_ishprop.
Qed.

Definition F_ind2@{i j} (P : F -> F -> Type@{i}) {sP : forall x y, IsHProp (P x y)}
  (dclass : forall x y : Frac R, P (' x) (' y)) : forall x y, P x y.
Proof.
apply (@F_ind (fun x => forall y, _)).
- intros;apply Forall.trunc_forall@{UR i j}.
- intros x.
  apply (F_ind _);intros y.
  apply dclass.
Qed.

Definition F_ind3@{i j} (P : F -> F -> F -> Type@{i})
  {sP : forall x y z, IsHProp (P x y z)}
  (dclass : forall x y z : Frac R, P (' x) (' y) (' z))
  : forall x y z, P x y z.
Proof.
apply (@F_ind (fun x => forall y z, _)).
- intros;apply Forall.trunc_forall@{UR j j}.
- intros x.
  apply (F_ind2@{i j} _). auto.
Qed.

Definition F_rec@{i} {T : Type@{i} } {sT : IsHSet T}
  : forall (dclass : Frac R -> T)
  (dequiv : forall x y, equiv x y -> dclass x = dclass y),
  F -> T
  := quotient_rec equiv.

Definition F_rec_compute T sT dclass dequiv x
  : @F_rec T sT dclass dequiv (' x) = dclass x
  := 1.

Definition F_rec2@{i j} {T:Type@{i} } {sT : IsHSet T}
  : forall (dclass : Frac R -> Frac R -> T)
  (dequiv : forall x1 x2, equiv x1 x2 -> forall y1 y2, equiv y1 y2 ->
    dclass x1 y1 = dclass x2 y2),
  F -> F -> T
  := @quotient_rec2@{UR UR j i} _ _ _ _ _ (BuildhSet _).

Definition F_rec2_compute {T sT} dclass dequiv x y
  : @F_rec2 T sT dclass dequiv (' x) (' y) = dclass x y
  := 1.

(* Relations, operations and constants *)

Global Instance F0@{} : Zero F := ('0 : F).
Global Instance F1@{} : One F := ('1 : F).

Global Instance Fplus@{} : Plus F.
Proof.
refine (F_rec2 (fun x y => ' (Frac.pl _ x y)) _).
intros. apply path. apply Frac.pl_respect;trivial.
Defined.

Definition Fplus_compute@{} q r : (' q) + (' r) = ' (Frac.pl _ q r)
  := 1.

Global Instance Fneg@{} : Negate F.
Proof.
refine (F_rec (fun x => ' (Frac.neg _ x)) _).
intros;apply path; eapply Frac.neg_respect;try apply _. trivial.
Defined.

Definition Fneg_compute@{} q : - (' q) = ' (Frac.neg _ q) := 1.

Global Instance Fmult@{} : Mult F.
Proof.
refine (F_rec2 (fun x y => ' (Frac.ml _ x y)) _).
intros. apply path. apply Frac.ml_respect;trivial.
Defined.

Definition Fmult_compute@{} q r : (' q) * (' r) = ' (Frac.ml _ q r)
  := 1.

Instance Fmult_comm@{} : Commutative Fplus.
Proof.
hnf. apply (F_ind2 _).
intros;apply path, Frac.pl_comm.
Qed.

Instance F_ring@{} : IsRing F.
Proof.
repeat split;
first [change sg_op with mult; change mon_unit with 1|
       change sg_op with plus; change mon_unit with 0].
- apply _.
- hnf. apply (F_ind3 _).
  intros;apply path. apply Frac.pl_assoc.
- hnf. apply (F_ind _).
  intros;apply path, Frac.pl_0_l.
- hnf. apply (F_ind _).
  intros;apply path, Frac.pl_0_r.
- hnf. apply (F_ind _).
  intros;apply path, Frac.pl_neg_l.
- hnf;intros.
  rewrite (commutativity (f:=plus)).
  revert x;apply (F_ind _).
  intros;apply path, Frac.pl_neg_l.
- apply _.
- apply _.
- hnf; apply (F_ind3 _).
  intros;apply path, Frac.ml_assoc.
- hnf. apply (F_ind _).
  intros;apply path. red;simpl.
  rewrite 2!mult_1_l. reflexivity.
- hnf. apply (F_ind _).
  intros;apply path. red;simpl.
  rewrite 2!mult_1_r. reflexivity.
- hnf; apply (F_ind2 _).
  intros;apply path.
  red;simpl.
  rewrite (mult_comm (num y)), (mult_comm (den y)).
  reflexivity.
- hnf. apply (F_ind3 _).
  intros a b c;apply path.
  red;simpl.
  rewrite <-!(mult_assoc (num a)).
  rewrite <-plus_mult_distr_l.
  rewrite <-(mult_assoc (num a)). apply ap.
  rewrite (mult_comm (den a) (den c)), (mult_comm (den a) (den b)).
  rewrite (mult_assoc (num b)), (mult_assoc (num c)).
  rewrite <-plus_mult_distr_r.
  rewrite <-(mult_assoc _ (den a) (den a * _)).
  apply ap.
  rewrite (mult_comm (den b)), <-mult_assoc. apply ap.
  rewrite (mult_comm (den a)). apply associativity.
Qed.

Global Instance Fdec_rec@{} : DecRecip F.
Proof.
refine (F_rec (fun x => ' (Frac.dec_rec _ x)) _).
intros. apply path. apply Frac.dec_recip_respect;trivial.
Defined.

Lemma classes_eq_related@{} : forall q r, ' q = ' r -> equiv q r.
Proof.
apply classes_eq_related@{UR UR Ularge Ularge Uhuge};apply _.
Qed.

Lemma class_neq@{} : forall q r, ~ equiv q r -> ~ ' q = ' r.
Proof.
intros q r E1 E2;apply E1;apply classes_eq_related, E2.
Qed.

Lemma classes_neq_related@{} : forall q r, ~ ' q = ' r -> ~ equiv q r.
Proof.
intros q r E1 E2;apply E1,path,E2.
Qed.

Lemma dec_recip_0@{} : / 0 = 0.
Proof.
unfold dec_recip. simpl.
unfold Frac.dec_rec;simpl.
destruct (decide_rel paths 0 0) as [_|E].
- reflexivity.
- destruct E;reflexivity.
Qed.

Lemma dec_recip_nonzero_aux@{} : forall q, ~ ' q = 0 -> ~ num q = 0.
Proof.
intros q E;apply classes_neq_related in E.
apply Frac.nonzero_num in E. trivial.
Qed.

Lemma dec_recip_nonzero@{} : forall q (E : ~ ' q = 0),
  / (' q) = ' (frac (den q) (num q) (dec_recip_nonzero_aux q E)).
Proof.
intros. apply path.
red;simpl. unfold Frac.dec_rec.
apply classes_neq_related, Frac.nonzero_num in E.
destruct (decide_rel paths (num q) 0) as [E'|?];[destruct E;apply E'|].
simpl. reflexivity.
Qed.

Global Instance F_field@{} : IsDecField F.
Proof.
split;try apply _.
- red. apply class_neq.
  unfold equiv;simpl. rewrite 2!mult_1_r. solve_propholds.
- apply dec_recip_0.
- apply (F_ind (fun x => _ -> _)).
  intros x E.
  rewrite (dec_recip_nonzero _ E).
  apply path;red;simpl. rewrite mult_1_r,mult_1_l.
  apply mult_comm.
Qed.

Lemma dec_class@{} : forall q r, Decidable (class q = class r).
Proof.
intros q r.
destruct (dec (equiv q r)) as [E|E].
- left. apply path,E.
- right. intros E'.
  apply E. apply (classes_eq_related _ _ E').
Defined.

Global Instance F_dec@{} : DecidablePaths F.
Proof.
hnf. apply (F_ind2 _).
apply dec_class.
Qed.

Lemma mult_num_den@{} q :
  ' q = (' num q) / ' den q.
Proof.
apply path. red. simpl.
rewrite mult_1_l. unfold Frac.dec_rec.
simpl. destruct (decide_rel paths (den q) 0) as [E|E];simpl.
- destruct (den_ne_0 q E).
- rewrite mult_1_r. reflexivity.
Qed.

Lemma recip_den_num@{} q :
  / ' q = (' den q) / 'num q.
Proof.
apply path;red;simpl.
unfold Frac.dec_rec;simpl.
destruct (decide_rel paths (num q) 0) as [E|E];simpl.
- rewrite (mult_0_r (Azero:=Azero)), 2!mult_0_l. reflexivity.
- rewrite mult_1_l,mult_1_r. reflexivity.
Qed.

(* A final word about inject *)
Global Instance inject_sr_morphism@{} : IsSemiRingPreserving (cast R F).
Proof.
repeat (split; try apply _).
- intros x y. apply path. change ((x + y) * (1 * 1) = (x * 1 + y * 1) * 1).
  rewrite !mult_1_r. reflexivity.
- intros x y. apply path. change ((x * y) * (1 * 1) = x * y * 1).
  rewrite !mult_1_r. reflexivity.
Qed.

Global Instance inject_injective@{} : IsInjective (cast R F).
Proof.
repeat (split; try apply _).
intros x y E. apply classes_eq_related in E.
red in E. simpl in E. rewrite 2!mult_1_r in E;trivial.
Qed.

End contents.

Arguments F R {_ _ _}.

Module Lift.

Section morphisms.
Universe UR1 UR2.
Context `{Funext} `{Univalence}.
Context {R1:Type@{UR1} } `{IsIntegralDomain R1} `{DecidablePaths R1}.
Context {R2:Type@{UR2} } `{IsIntegralDomain R2} `{DecidablePaths R2}.
Context `(f : R1 -> R2) `{!IsSemiRingPreserving f} `{!IsInjective f}.

Definition lift@{} : F R1 -> F R2.
Proof.
apply (F_rec (fun x => class (Frac.lift f x))).
intros;apply path,Frac.lift_respects;trivial.
Defined.

Global Instance lift_sr_morphism@{i} : IsSemiRingPreserving lift.
Proof.
(* This takes a few seconds. *)
split;split;red.
- apply (F_ind2@{UR1 UR2 i} _).
  intros;simpl.
  apply @path. (* very slow or doesn't terminate without the @ but fast with it *)
  red;simpl.
  repeat (rewrite <-(preserves_mult (f:=f)) || rewrite <-(preserves_plus (f:=f))).
  reflexivity.
- simpl. apply path.
  red;simpl. rewrite (preserves_0 (f:=f)). rewrite 2!mult_0_l. reflexivity.
- apply (F_ind2@{UR1 UR2 i} _).
  intros;simpl. apply @path.
  red;simpl.
  rewrite <-!(preserves_mult (f:=f)). reflexivity.
- simpl. apply path.
  red;simpl. apply commutativity.
Qed.

Global Instance lift_injective@{i} : IsInjective lift.
Proof.
red.
apply (F_ind2@{UR1 i i} (fun _ _ => _ -> _)).
intros x y E.
simpl in E.
apply classes_eq_related in E. red in E;simpl in E.
apply path. red.
apply (injective f). rewrite 2!(preserves_mult (f:=f)).
apply E.
Qed.
End morphisms.

End Lift.

End FracField.


Require Import compcert_imports. Import CompcertLibraries.

Require Import semantics.
Require Import semantics_lemmas.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section closed_safety.

Variable (G C D Z M : Type).

Variable sem : CoreSemantics G C M.

Variable ge : G.

Fixpoint safeN (n : nat) (c : C) (m : M) : Prop :=
  match n with
    | O => True
    | S n' =>
      match halted sem c with
        | None =>
          (exists c', exists m', corestep sem ge c m c' m') /\
          (forall c' m', corestep sem ge c m c' m' -> safeN n' c' m')
        | Some i => True
      end
  end.

Fixpoint safeN_det (n : nat) (c : C) (m : M) : Prop :=
  match n with
    | O => True
    | S n' =>
      match halted sem c with
        | None => exists c', exists m',
                    corestep sem ge c m c' m' /\ safeN_det n' c' m'
        | Some i => True
      end
  end.

Lemma det_safeN_det n c m :
  corestep_fun sem ->
  safeN_det n c m ->
  safeN n c m.
Proof.
intros Hfun; revert c m; induction n; simpl; auto.
intros c m.
destruct (halted sem c); auto.
intros [c' [m' [Hstep Hsafe]]].
split.
exists c', m'; auto.
intros c'' m'' Hstep'.
destruct (Hfun _ _ _ _ _ _ _ Hstep Hstep').
subst c' m'; apply IHn; auto.
Qed.

Lemma safe_downward1 n c m : safeN (S n) c m -> safeN n c m.
Proof.
revert c m; induction n; simpl; intros; auto.
destruct (halted sem c); auto.
destruct H as [H H0].
destruct H as [c' [m' H2]].
split. exists c', m'; auto.
intros c'' m'' H3.
specialize (H0 _ _ H3). destruct n; auto.
Qed.

Lemma safe_downward (n n' : nat) c m :
  le n' n -> safeN n c m -> safeN n' c m.
Proof.
do 2 intro. revert c m H0. induction H; auto.
intros. apply IHle. apply safe_downward1. auto.
Qed.

Lemma safe_corestep_forward c m c' m' n :
  corestep sem ge c m c' m' -> safeN (S n) c m ->
  safeN n c' m'.
Proof.
simpl; intros.
generalize H as H'; intro.
eapply corestep_not_halted in H; rewrite H in H0.
destruct H0 as [H1 H2]. clear H H1.
apply H2; auto.
Qed.

Lemma safe_corestepN_forward c m c' m' n n0 :
  corestepN sem ge n0 c m c' m' ->
  safeN (n + S n0) c m -> safeN n c' m'.
Proof.
intros.
revert c m c' m' n H H0.
induction n0; intros; auto.
simpl in H; inv H.
eapply safe_downward in H0; eauto. omega.
simpl in H. destruct H as [c2 [m2 [STEP STEPN]]].
eapply IHn0; eauto.
assert (Heq: (n + S (S n0) = S (n + S n0))%nat) by omega.
rewrite Heq in H0.
eapply safe_corestep_forward in H0; eauto.
Qed.

Lemma safe_corestep_backward:
  forall c m c' m' n,
    corestep_fun sem ->
    corestep sem ge c m c' m' -> safeN (n - 1) c' m' -> safeN n c m.
Proof.
simpl; intros.
revert c m c' m' H H0 H1.
induction n; simpl; intros; auto.
erewrite corestep_not_halted; eauto.
split.
exists c', m'; auto.
intros c'' m'' Hstep.
assert (Heq: (n = S n - 1)%nat) by omega.
rewrite Heq; simpl.
assert (n - 0 = n)%nat as -> by omega.
destruct (H _ _ _ _ _ _ _ H0 Hstep).
subst c''; subst m''; auto.
Qed.

Lemma safe_corestepN_backward:
  forall c m c' m' n n0,
    corestep_fun sem ->
    corestepN sem ge n0 c m c' m' -> safeN (n - n0) c' m' -> safeN n c m.
Proof.
simpl; intros.
revert c m c' m' n H H0 H1.
induction n0; intros; auto.
simpl in H0; inv H0.
solve[assert (Heq: (n = n - 0)%nat) by omega; rewrite Heq; auto].
simpl in H0. destruct H0 as [c2 [m2 [STEP STEPN]]].
assert (H2: safeN (n - 1 - n0) c' m').
eapply safe_downward in H1; eauto. omega.
specialize (IHn0 _ _ _ _ (n - 1)%nat H STEPN H2).
eapply safe_corestep_backward; eauto.
Qed.

Lemma corestep_star_fun :
  corestep_fun sem ->
  forall c m c' m' c'' m'' n,
  corestepN sem ge n c m c' m' ->
  corestepN sem ge n c m c'' m'' ->
  c'=c'' /\ m'=m''.
Proof.
intro FUN. intros. revert c m H H0. induction n; auto.
simpl. intros ? ?. inversion 1; subst. inversion 1; subst.
split; auto.
simpl.
intros c m H H2.
destruct H as [c2 [m2 [STEP STEPN]]].
destruct H2 as [c2' [m2' [STEP' STEPN']]].
assert (c2 = c2' /\ m2 = m2').
  unfold corestep_fun in FUN. eapply FUN; eauto.
inv H.
eapply IHn; eauto.
Qed.

End closed_safety.

(** Behaviors-related stuff; should probably go in a new file. *)

Definition terminates {G C M} (csem : CoreSemantics G C M)
    (ge : G) (c : C) (m : M) :=
  exists c' m', corestep_star csem ge c m c' m'
  /\ exists v, halted csem c' = Some v.

Definition safe {G C M} (csem : CoreSemantics G C M) ge c m :=
  forall n, safeN csem ge n c m.

Definition forever_steps_or_halted {G C M} (csem : CoreSemantics G C M) ge c m :=
  forall n, safeN_det csem ge n c m.

Lemma safeN_safeN_det G C M (csem : CoreSemantics G C M) ge c m n :
  safeN csem ge n c m ->
  safeN_det csem ge n c m.
Proof.
revert c m; induction n; auto.
intros c m; simpl.
destruct (halted csem c); auto.
intros [[c' [m' Hhlt]] H].
exists c', m'; split; auto.
Qed.

Lemma safe_forever_steps_or_halted G C M (csem : CoreSemantics G C M) ge c m :
  safe csem ge c m ->
  forever_steps_or_halted csem ge c m.
Proof.
intros H n; specialize (H n); apply safeN_safeN_det; auto.
Qed.

Inductive behavior : Type := Termination | Divergence | Going_wrong.

Inductive has_behavior {G C M} (csem : CoreSemantics G C M) ge c m : behavior -> Prop :=
  | Terminates :
      terminates csem ge c m -> has_behavior csem ge c m Termination
  | Diverges :
      forever_steps_or_halted csem ge c m -> ~terminates csem ge c m ->
      has_behavior csem ge c m Divergence
  | Goes_wrong :
      ~safe csem ge c m -> has_behavior csem ge c m Going_wrong.

Inductive behavior_refines : behavior -> behavior -> Prop :=
  | Equitermination : behavior_refines Termination Termination
  | Equidivergence : behavior_refines Divergence Divergence
  | Any_going_wrong : forall any, behavior_refines any Going_wrong.


From Rela Require Import Aexp.
From Rela Require Import Bexp.
From Rela Require Import Com.
From Rela Require Import Hoare_Triple.
From Rela Require Import Proc.
From Rela Require Import Sigma.
From Rela Require Import Loc.
From Coq Require Import Lists.List.
Import ListNotations.

(** Redefinition of set from Why3 **)

Module Why3_Set.

Definition set: (Loc.t -> nat) -> Loc.t -> nat -> Loc.t -> nat.
Proof.
intros m x y.
intros x'.
destruct (Loc.eq_dec x x') as [H|H].
exact y.
exact (m x').
Defined.

Lemma set'def:
  forall (f: Loc.t -> nat ) (x: Loc.t) (v:nat) (y: Loc.t),
  ((y = x) -> ((set f x v y) = v)) /\ (~ (y = x) -> ((set f x v y) = (f y))).
Proof.
intros f x v y.
split.
+ intros.
 unfold set.
 destruct (Loc.eq_dec x y).
  * reflexivity.
  * contradiction n.
    rewrite H. reflexivity.
+ intros.
  unfold set.
  destruct (Loc.eq_dec x y).
  * contradiction H.
    rewrite e. reflexivity.
  * reflexivity.
Qed.

Lemma set''def:
  forall (f: Loc.t -> nat ) (x: Loc.t) (v w:nat) (y: Loc.t),
  (y = x -> v = w -> ((set f x v y) = w)).
Proof.
intros f x v w y H1 H2.
unfold set.
destruct (Loc.eq_dec x y).
  * rewrite H2. reflexivity.
  * contradiction n.
    rewrite H1. reflexivity.
Qed.

End Why3_Set.

Import Why3_Set.

(** Boolean evaluation as Prop **)

Module Assn_b.

Import Bool.Bool.

Definition bassn b :=
  fun st => (Is_true (beval st b)).

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
Proof.
intros. unfold bassn. apply Is_true_eq_left. auto.
Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false ->  ~((bassn b) st).
Proof.
intros. unfold bassn. apply negb_prop_elim.
apply Is_true_eq_left.
apply negb_true_iff. auto.
Qed.

End Assn_b.

Import Assn_b.

(** Definition of a verification condition generator **)

Definition history: Type := list Sigma.sigma.

Definition empty_history: history := [].

Definition suite : Type := Sigma.sigma -> history -> Prop.

Fixpoint tc (c : com) (m : Sigma.sigma) (h : history)
            (cl: Phi.phi) (s : suite) : Prop :=
    match c with
    | CSkip => forall m', m = m' -> s m' (m :: h)
    | CAss x a => forall m', (m' = set m x (aeval m a)) -> s m' (m :: h)
    | CAssr x a => forall m', (m' = set m (m x) (aeval m a)) -> s m' (m :: h)
    | CAssert b => forall m', b (m :: h) -> m = m' -> s m' (m :: h)
    | CSeq p1 p2 => tc p1 m h cl (fun m' h => tc p2 m' h cl s)
    | CIf b p1 p2 => (bassn b m -> tc p1 m h cl (fun m' _ => s m' (m :: h))) /\
                     (~bassn b m  -> tc p2 m h cl (fun m' _ => s m' (m :: h)))
    | CWhile b p inv => inv (m :: h) ->
                        forall m', inv (m' :: h) -> beval m' b = false -> s m' (m :: h)
    | CCall f => (get_pre (cl f)) m ->
                  forall m',  (get_post (cl f)) m' m -> s m' (m :: h)
    end.

(** Facts about verification condition generator **)

Ltac ltc1 := intros m l s1 s2 H H0;
             simpl; intros;
             simpl in H0;
             apply H; apply H0; assumption.

Lemma consequence_tc_suite :
forall p cl m l (s1 s2 : suite),
(forall s l, s1 s l -> s2 s l) ->
tc p m l cl s1 -> tc p m l cl s2.
Proof.
intros p cl.
induction p.
  * ltc1.
  * ltc1.
  * ltc1.
  * ltc1.
  * intros.
    simpl. simpl in H0.
    eapply IHp1.
    - intros.
      eapply IHp2.
       + apply H.
       + apply H1.
    - assumption.
  * intros.
    simpl. simpl in H0.
    intros. destruct H0.
    split.
    - intros.
      specialize (IHp1 m l (fun (m' : sigma) (_ : list sigma) => s1 m' (m :: l))
      (fun (m' : sigma) (_ : list sigma) => s2 m' (m :: l))).
      apply IHp1.
      + intros. apply H. apply H3.
      + apply H0. assumption.
     - intros.
       specialize (IHp2 m l (fun (m' : sigma) (_ : list sigma) => s1 m' (m :: l))
      (fun (m' : sigma) (_ : list sigma) => s2 m' (m :: l))).
        apply IHp2.
      + intros. apply H. apply H3.
      + apply H1. assumption.
  * ltc1.
  * ltc1.
Qed.

Ltac ltc2 := intros m l s1 s2 H H0;
             simpl; intros;
             split;[ apply H; try assumption; subst; reflexivity
                   | apply H0; try assumption; subst; reflexivity].

Lemma tc_split :
forall p cl m l (s1 s2 : suite),
tc p m l cl s1 -> tc p m l cl s2 ->
tc p m l cl (fun m' h => s1 m' h /\ s2 m' h).
Proof.
intros p cl.
induction p.
+ ltc2.
+ ltc2.
+ ltc2.
+ ltc2.
+ simpl. intros.
  apply (consequence_tc_suite _ _ _ _ (fun m h => tc p2 m h cl s1 /\ tc p2 m h cl s2)).
  * intros. destruct H1. apply IHp2. assumption. assumption.
  * apply IHp1. assumption. assumption.
+ intros.
  simpl. simpl in H, H0.
  split.
  * intros.
    apply IHp1.
    apply H. assumption.
    apply H0. assumption.
  * intros.
    apply IHp2.
    apply H. assumption.
    apply H0. assumption.
+ ltc2.
+ ltc2.
Qed.

(** Definition of a verification condition generator for the auxiliary goals **)

Fixpoint tc' (c : com) (m : Sigma.sigma) (h : history)
            (cl: Phi.phi) : Prop :=
    match c with
    | CSkip => True
    | CAss x a => True
    | CAssr x a => True
    | CAssert b => b (m :: h)
    | CSeq p1 p2 => tc' p1 m h cl /\
                    tc p1 m h cl (fun m' h => tc' p2 m' h cl)
    | CIf b p1 p2 =>
                    (bassn b m -> tc' p1 m h cl) /\
                    (~bassn b m -> tc' p2 m h cl)
    | CWhile b p inv => inv (m :: h) /\
                     (forall m', bassn b m' -> inv (m' :: h)-> tc' p m' h cl) /\
                     (forall m', bassn b m' -> inv (m' :: h) ->
                                  tc p m' h cl (fun m'' _ => inv (m'' :: h)))
    | CCall f => (get_pre (cl f)) m
    end.

(** Definition of a verification condition generator for procedures **)

Definition tc_p (ps: Psi.psi) (cl : Phi.phi) : Prop :=
    forall f m, (get_pre (cl f)) m ->
    tc' (ps f) m empty_history cl /\
    tc (ps f) m empty_history cl (fun m' _ => get_post (cl f) m' m).

(** Facts about verification condition generator for procedures **)

Lemma tc_p_empty_psi : forall psi, tc_p psi Phi.empty_phi.
Proof.
unfold tc_p.
intros.
simpl in H.
unfold empty_precondition in H.
contradiction.
Qed.

(** Verification of trivial procedure contract **)
Module Trivial_proc.

Parameter f : Proc.t.

Definition f_psi (x': Proc.t) :=
        if Proc.eqb x' f then CSkip else Psi.empty_psi x'.

Definition f_phi (x': Proc.t) :=
        if Proc.eqb x' f then
        ((fun _ => True), (fun _ _ => True))
        else Phi.empty_phi x'.

Example tc_p_update : tc_p f_psi f_phi.
Proof.
unfold tc_p.
unfold f_psi, f_phi.
intros.
destruct (Proc.eqb f0 f).
- split.
  * simpl in H.
    simpl. apply H.
  * simpl in H.
    simpl. intros. apply H.
- intros.
  simpl in H.
  unfold empty_precondition in H.
  contradiction.
Qed.

End Trivial_proc.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Import nuprl_props.

Lemma choice_teq :
  forall A v1 B1 v2 B2,
    (forall a1 a2 : CTerm,
       equality a1 a2 A
       -> tequality (substc a1 v1 B1) (substc a2 v2 B2))
    -> {f : forall a1 a2 : CTerm,
            forall e : equality a1 a2 A,
              per
        , forall a1 a2 : CTerm,
          forall e : equality a1 a2 A,
            nuprl (substc a1 v1 B1) (substc a2 v2 B2) (f a1 a2 e)}.
Proof.
  introv F.
  exists (fun a1 a2 e => projT1 (F a1 a2 e)); sp; destruct (F a1 a2 e); sp.
Qed.

Lemma choice_spteq :
  forall F1 F2,
    (forall x y : CTerm, tequality (F1 x y) (F2 x y))
    -> {f : forall x y : CTerm, per
        , forall x y : CTerm, nuprl (F1 x y) (F2 x y) (f x y)}.
Proof.
  introv F.
  exists (fun a1 a2 => projT1 (F a1 a2)); sp; destruct (F x y); sp.
Qed.

Lemma choice_teqi :
  forall i A v1 B1 v2 B2,
    (forall a1 a2 : CTerm,
       equality a1 a2 A
       -> equality (substc a1 v1 B1) (substc a2 v2 B2) (mkc_uni i))
    -> {f : forall a1 a2 : CTerm,
            forall e : equality a1 a2 A,
              per
        , forall a1 a2 : CTerm,
          forall e : equality a1 a2 A,
            nuprli i (substc a1 v1 B1) (substc a2 v2 B2) (f a1 a2 e)}.
Proof.
  introv F.

  assert (forall a1 a2 : CTerm,
            equality a1 a2 A ->
            {eq : per , nuprli i (substc a1 v1 B1) (substc a2 v2 B2) eq}) as fn.
  (* begin proof of the assert *)
  introv e.
  generalize (F a1 a2 e); intro es.
  unfold equality in es; exrepnd.
  inversion es1; try not_univ.
  duniv j h.
  allrw univi_exists_iff; exrepnd.
  computes_to_value_isvalue; GC.
  discover; exrepnd.
  allfold (nuprli j0).
  exists eqa; sp.
  (* end proof of the assert *)

  exists (fun a1 a2 e => projT1 (fn a1 a2 e)); sp; destruct (fn a1 a2 e); sp.
Qed.

Lemma choice_spteqi :
  forall i F1 F2,
    (forall x y : CTerm, equality (F1 x y) (F2 x y) (mkc_uni i))
    -> {f : forall x y : CTerm, per
        , forall x y : CTerm, nuprli i (F1 x y) (F2 x y) (f x y)}.
Proof.
  introv F.

  assert (forall x y : CTerm,
            {eq : per , nuprli i (F1 x y) (F2 x y) eq}) as fn.
  (* begin proof of the assert *)
  introv.
  generalize (F x y); intro es.
  unfold equality in es; exrepnd.
  inversion es1; try not_univ.
  duniv j h.
  allrw univi_exists_iff; exrepnd.
  computes_to_value_isvalue; GC.
  discover; exrepnd.
  allfold (nuprli j0).
  exists eqa; sp.
  (* end proof of the assert *)

  exists (fun x y => projT1 (fn x y)); sp; destruct (fn x y); sp.
Qed.

Lemma choice_eq :
  forall A v B F1 F2,
    (forall a1 a2 : CTerm,
       equality a1 a2 A
       -> equality (F1 a1) (F2 a2) (substc a1 v B))
    -> {f : forall a1 a2 : CTerm,
            forall e : equality a1 a2 A,
              per
        , forall a1 a2 : CTerm,
          forall e : equality a1 a2 A,
            nuprl (substc a1 v B) (substc a1 v B) (f a1 a2 e)
            # f a1 a2 e (F1 a1) (F2 a2)}.
Proof.
  introv F.
  exists (fun a1 a2 e => projT1 (F a1 a2 e)); sp; destruct (F a1 a2 e); sp.
Qed.

Lemma choice_teq1 :
  forall A eqa v1 B1 v2 B2,
    nuprl A A eqa
    -> (forall a1 a2 : CTerm,
          equality a1 a2 A
          -> tequality (substc a1 v1 B1) (substc a2 v2 B2))
    -> {f : (forall a1 a2 (e : eqa a1 a2), per)
        , forall a1 a2 (e : eqa a1 a2),
            nuprl (substc a1 v1 B1) (substc a2 v2 B2) (f a1 a2 e)}.
Proof.
  introv na F.
  exists (fun a1 a2 e =>
            projT1 (F a1 a2 (existT (fun eq => nuprl A A eq # eq a1 a2) eqa (na, e))));
    sp; destruct (F a1 a2 (existT (fun eq => nuprl A A eq # eq a1 a2) eqa (na, e))); sp.
Qed.

Lemma choice_teq2 :
  forall eqp eqa P ap A bp1 ba1 B1 bp2 ba2 B2,
    nuprl P P eqp
    -> (forall p1 p2 (ep : eqp p1 p2),
          nuprl (substc p1 ap A) (substc p2 ap A) (eqa p1 p2 ep))
    -> (forall p1 p2 : CTerm,
          equality p1 p2 P
          -> forall a1 a2 : CTerm,
               equality a1 a2 (substc p1 ap A)
               -> tequality (lsubstc2 bp1 p1 ba1 a1 B1) (lsubstc2 bp2 p2 ba2 a2 B2))
    -> {f : (forall p1 p2 (ep : eqp p1 p2) a1 a2 (ea : eqa p1 p2 ep a1 a2), per)
        , forall p1 p2 (ep : eqp p1 p2) a1 a2 (ea : eqa p1 p2 ep a1 a2),
            nuprl (lsubstc2 bp1 p1 ba1 a1 B1)
                  (lsubstc2 bp2 p2 ba2 a2 B2)
                  (f p1 p2 ep a1 a2 ea)}.
Proof.
  introv np na F.

  exists (fun p1 p2 ep a1 a2 ea =>
            projT1 (F p1 p2
                      (existT (fun eq => nuprl P P eq # eq p1 p2) eqp (np, ep))
                      a1 a2
                      (existT (fun eq => nuprl (substc p1 ap A)
                                               (substc p1 ap A) eq
                                         # eq a1 a2)
                              (eqa p1 p2 ep)
                              (nuprl_refl (substc p1 ap A)
                                          (substc p2 ap A)
                                          (eqa p1 p2 ep)
                                          (na p1 p2 ep),
                               ea)))); sp.

  destruct (F p1 p2 exI(eqp, (np, ep)) a1 a2
              exI(eqa p1 p2 ep,
                  (nuprl_refl (substc p1 ap A) (substc p2 ap A)
                              (eqa p1 p2 ep) (na p1 p2 ep), ea))); sp.
Qed.


(* Aquinas Hobor, Le Xuan Bach *)

Require Import msl.msl_standard.
Require Import share_dec_base.

Module Type SIMPLIFIER.
  Declare Module sv : SV.
  Declare Module es : INTERNAL_EQUATION_SYSTEM with Module sv := sv.
  Import es.

  Parameter simplify : equation_system -> option equation_system.
  Axiom simplify_Some: forall es es',
    simplify es = Some es' ->
    equiv es es'.
  Axiom simplifiy_None: forall es,
    simplify es = None ->
    forall ctx, ~ eval ctx es.
End SIMPLIFIER.

Module Type DECOMPOSER.
  Declare Module sv : SV.
  Declare Module es : INTERNAL_EQUATION_SYSTEM with Module sv := sv.
  Declare Module simp : SIMPLIFIER with Module sv := sv with Module es := es.
  Import es.

  Parameter decompose_context : context -> (context * context).
  Parameter decompose : equation_system -> (equation_system * equation_system).
  Axiom decompose_ok: forall es es' es'',
    decompose es = (es', es'') ->
    forall ctx ctx' ctx'',
      decompose_context ctx = (ctx', ctx'') ->
      (@eval _ _ Prop _ ctx es <-> ((eval ctx' es') /\ (eval ctx'' es''))).
End DECOMPOSER.

Module Share_Dec (sv : SV)
                 (es : INTERNAL_EQUATION_SYSTEM with Module sv := sv)
                 (simp : SIMPLIFIER with Module sv := sv with Module es := es)
                 (dcomp : DECOMPOSER with Module sv := sv with Module es := es with Module simp := simp).
  Import es.

  Definition oneStage (es : equation_system) : option (equation_system * equation_system) :=
    option_map dcomp.decompose (simp.simplify es).
  Lemma oneStage_Some : forall es es' es'',
    oneStage es = Some (es', es'') ->
    forall ctx ctx' ctx'',
      dcomp.decompose_context ctx = (ctx', ctx'') ->
      (@eval _ _ Prop _ ctx es <-> ((eval ctx' es') /\ (eval ctx'' es''))).
  Proof.
    intros.
    unfold oneStage in H.
    remember (simp.simplify es).
    icase o.
    symmetry in Heqo.
    apply simp.simplify_Some in Heqo.
    simpl in H. inversion H.
    apply dcomp.decompose_ok with (ctx := ctx) (ctx' := ctx') (ctx'' := ctx'') in H2.
    rewrite <- H2.
    unfold equiv in Heqo.
    unfold impl in *.
    destruct Heqo.
    spec H1 ctx. spec H3 ctx. tauto.
    trivial.
  Qed.

  Definition share_dec (es : equation_system) : bool :=
    true.
  Lemma
    spec H1 ctx. spec H3 ctx. tauto.

    tauto.

 tauto.
    simpl in *.

 tauto.
    apply Heqo.
    rewrite <- Heqo in H2.
    spec
  Axiom simplify_Some: forall es es',
    simplify es = Some es' ->
    equiv es es'.

(* Extraction Magic *)
Extraction Language Ocaml.

Set Extraction AutoInline.

Require Import ExtrOcamlBasic.
Require Import ExtrOcamlString.

Extraction Inline proj1_sig sigT_of_sig projT1.
Extract Inductive bool => "bool" [ "true" "false" ].
Extract Inductive sumbool => "bool" [ "true" "false" ].
Extract Inductive prod => "(*)"  [ "(,)" ].
Extract Inductive sigT => "(*)"  [ "(,)" ].

Extraction "share_dec.ml" Solver.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C Aprime Cprimeprime Bprime Bprimeprime : Universe, ((wd_ A Aprime /\ (wd_ A B /\ (wd_ A C /\ (wd_ C Aprime /\ (wd_ B C /\ (wd_ B Aprime /\ (wd_ Cprimeprime Aprime /\ (wd_ Bprime A /\ (wd_ Bprime Aprime /\ (wd_ Bprime Bprimeprime /\ (wd_ Aprime Bprimeprime /\ (col_ Bprimeprime A Aprime /\ col_ Bprime Aprime Bprimeprime)))))))))))) -> col_ Bprime Aprime A)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import HoTT.
Require Import HoTT.Categories.Functor.
From GR.bicategories Require Import
     bicategory.bicategory bicategory.examples.prod
     lax_functor.lax_functor.

Section ProdFunctor.
  Context {C D₁ D₂ : BiCategory}.
  Variable (F₁ : LaxFunctor C D₁) (F₂ : LaxFunctor C D₂).

  Definition lax_prod_d : LaxFunctor_d C (prod D₁ D₂).
  Proof.
    make_laxfunctor.
    - exact (fun z => (F₁ z,F₂ z)).
    - exact (fun X Y => Fmor F₁ _ _ * Fmor F₂ _ _)%functor.
    - intros X Y Z g f ; simpl in *.
      exact (Fcomp₁ F₁ g f,Fcomp₁ F₂ g f).
    - intros X.
      exact (Fid F₁ X,Fid F₂ X).
  Defined.

  Definition lax_prod_d_is_lax : is_lax lax_prod_d.
  Proof.
    make_is_lax ; intros ; (apply path_prod' ; [apply F₁ | apply F₂]).
  Qed.

  Definition lax_prod : LaxFunctor C (prod D₁ D₂)
    := Build_LaxFunctor lax_prod_d lax_prod_d_is_lax.
End ProdFunctor.

Global Instance prod_is_pseudo
           `{Univalence}
           {C D₁ D₂ : BiCategory}
           (F₁ : LaxFunctor C D₁) (F₂ : LaxFunctor C D₂)
           `{is_pseudo _ _ F₁} `{is_pseudo _ _ F₂}
  : is_pseudo (lax_prod F₁ F₂).
Proof.
  split ; apply _.
Defined.

Definition pseudo_prod
           `{Univalence}
           {C D₁ D₂ : BiCategory}
           (F₁ : PseudoFunctor C D₁) (F₂ : PseudoFunctor C D₂)
  : PseudoFunctor C (prod D₁ D₂).
Proof.
  make_pseudo_functor_lax.
  - exact (lax_prod F₁ F₂).
  - exact (prod_is_pseudo F₁ F₂).
Defined.


Require Import Verdi.Verdi.
Require Import Verdi.HandlerMonad.
Require Import Verdi.NameOverlay.
Require Import Verdi.LabeledNet.

Require Import AggregationDefinitions.
Require Import TreeAux.

Require Import Sumbool.
Require String.

Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.ssrbool.
Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.fintype.
Require Import mathcomp.ssreflect.finset.
Require Import mathcomp.fingroup.fingroup.

Require Import commfingroup.

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

Set Implicit Arguments.

Module TreeAggregation (Import NT : NameType)
 (NOT : NameOrderedType NT) (NSet : MSetInterface.S with Module E := NOT)
 (NOTC : NameOrderedTypeCompat NT) (NMap : FMapInterface.S with Module E := NOTC)
 (Import RNT : RootNameType NT)
 (Import CFG : CommutativeFinGroup)
 (Import ANT : AdjacentNameType NT)
 (Import TA : TAux NT NOT NSet NOTC NMap)
 (Import AD : ADefs NT NOT NSet NOTC NMap CFG).

Import GroupScope.

Inductive Msg : Type :=
| Aggregate : m -> Msg
| Fail : Msg
| Level : option lv -> Msg
| New : Msg.

Definition Msg_eq_dec : forall x y : Msg, {x = y} + {x <> y}.
decide equality; first exact: m_eq_dec.
case: o; case: o0.
- move => n m.
  case (lv_eq_dec n m) => H_dec; first by rewrite H_dec; left.
  right.
  move => H_eq.
  injection H_eq => H_eq'.
  by rewrite H_eq' in H_dec.
- by right.
- by right.
- by left.
Defined.

Inductive Input : Type :=
| Local : m -> Input
| SendAggregate : Input
| AggregateRequest : String.string -> Input
| LevelRequest : String.string -> Input
| Broadcast : Input.

Definition Input_eq_dec : forall x y : Input, {x = y} + {x <> y}.
decide equality; auto using String.string_dec, m_eq_dec.
Defined.

Inductive Output : Type :=
| AggregateResponse : String.string -> m -> Output
| LevelResponse : String.string -> option lv -> Output.

Definition Output_eq_dec : forall x y : Output, {x = y} + {x <> y}.
decide equality; auto using String.string_dec; first exact: m_eq_dec.
case: o; case: o0.
- move => lv0 lv1.
  case (lv_eq_dec lv0 lv1) => H_dec; first by rewrite H_dec; left.
  right.
  move => H_eq.
  injection H_eq => H_eq'.
  by rewrite H_eq' in H_dec.
- by right.
- by right.
- by left.
Defined.

Record Data :=  mkData {
  local : m ;
  aggregate : m ;
  adjacent : NS ;
  balance : NM ;
  broadcast : bool ;
  levels : NL
}.

Definition InitData (n : name) :=
  {| local := 1 ;
     aggregate := 1 ;
     adjacent := NSet.empty ;
     balance := NMap.empty m ;
     broadcast := false ;
     levels := NMap.empty lv |}.

Inductive Label : Type :=
| Tau : Label
| RecvFail : name -> name -> Label
| RecvNew : name -> name -> Label
| RecvLevel : name -> name -> Label
| RecvAggregate : name -> name -> Label
| DeliverBroadcast : name -> Label
| DeliverLevelRequest : name -> Label
| DeliverSendAggregate : name -> Label
| DeliverLocal : name -> Label
| DeliverAggregateRequest : name -> Label.

Definition Label_eq_dec : forall x y : Label, {x = y} + {x <> y}.
decide equality; auto using name_eq_dec.
Defined.

Definition Handler (S : Type) := GenHandler (name * Msg) S Output Label.

Definition RootNetHandler (me src : name) (msg : Msg) : Handler Data :=
st <- get ;;
match msg with
| Aggregate m_msg =>
  match NMap.find src st.(balance) with
  | Some m_src =>
    put {| local := st.(local) ;
           aggregate := st.(aggregate) * m_msg ;
           adjacent := st.(adjacent) ;
           balance := NMap.add src (m_src * (m_msg)^-1) st.(balance) ;
           broadcast := st.(broadcast) ;
           levels := st.(levels) |}
  | None => nop
  end ;;
  ret (RecvAggregate me src)
| Level _ => ret (RecvLevel me src)
| Fail =>
  match NMap.find src st.(balance) with
  | Some m_bal =>
    put {| local := st.(local) ;
           aggregate := st.(aggregate) * m_bal ;
           adjacent := NSet.remove src st.(adjacent) ;
           balance := NMap.remove src st.(balance) ;
           broadcast := st.(broadcast) ;
           levels := st.(levels) |}
  | None =>
    put {| local := st.(local) ;
           aggregate := st.(aggregate) ;
           adjacent := NSet.remove src st.(adjacent) ;
           balance := st.(balance) ;
           broadcast := st.(broadcast) ;
           levels := st.(levels) |}
  end ;;
  ret (RecvFail me src)
| New =>
  put {| local := st.(local) ;
         aggregate := st.(aggregate) ;
         adjacent := NSet.add src st.(adjacent) ;
         balance := NMap.add src 1 st.(balance) ;
         broadcast := st.(broadcast) ;
         levels := st.(levels) |} ;;
  send (src, Level (Some 0)) ;;
  ret (RecvNew me src)
end.

Definition NonRootNetHandler (me src: name) (msg : Msg) : Handler Data :=
st <- get ;;
match msg with
| Aggregate m_msg =>
  match NMap.find src st.(balance) with
  | Some m_src =>
    put {| local := st.(local) ;
           aggregate := st.(aggregate) * m_msg ;
           adjacent := st.(adjacent) ;
           balance := NMap.add src (m_src * (m_msg)^-1) st.(balance) ;
           broadcast := st.(broadcast) ;
           levels := st.(levels) |}
  | None => nop
  end ;;
  ret (RecvAggregate me src)
| Level None =>
  (if olv_eq_dec (level st.(adjacent) st.(levels)) (level st.(adjacent) (NMap.remove src st.(levels))) then
    put {| local := st.(local) ;
           aggregate := st.(aggregate) ;
           adjacent := st.(adjacent) ;
           balance := st.(balance) ;
           broadcast := st.(broadcast) ;
           levels := NMap.remove src st.(levels) |}
  else
    put {| local := st.(local) ;
           aggregate := st.(aggregate) ;
           adjacent := st.(adjacent) ;
           balance := st.(balance) ;
           broadcast := true ;
           levels := NMap.remove src st.(levels) |}) ;;
  ret (RecvLevel me src)
| Level (Some lv') =>
  (if olv_eq_dec (level st.(adjacent) st.(levels)) (level st.(adjacent) (NMap.add src lv' st.(levels))) then
    put {| local := st.(local) ;
           aggregate := st.(aggregate) ;
           adjacent := st.(adjacent) ;
           balance := st.(balance) ;
           broadcast := st.(broadcast) ;
           levels := NMap.add src lv' st.(levels) |}
  else
    put {| local := st.(local) ;
           aggregate := st.(aggregate) ;
           adjacent := st.(adjacent) ;
           balance := st.(balance) ;
           broadcast := true ;
           levels := NMap.add src lv' st.(levels) |}) ;;
   ret (RecvLevel me src)
| Fail =>
  match NMap.find src st.(balance) with
  | Some m_bal =>
    if olv_eq_dec (level st.(adjacent) st.(levels)) (level (NSet.remove src st.(adjacent)) (NMap.remove src st.(levels))) then
      put {| local := st.(local) ;
             aggregate := st.(aggregate) * m_bal ;
             adjacent := NSet.remove src st.(adjacent) ;
             balance := NMap.remove src st.(balance) ;
             broadcast := st.(broadcast) ;
             levels := NMap.remove src st.(levels) |}
    else
      put {| local := st.(local) ;
             aggregate := st.(aggregate) * m_bal ;
             adjacent := NSet.remove src st.(adjacent) ;
             balance := NMap.remove src st.(balance) ;
             broadcast := true ;
             levels := NMap.remove src st.(levels) |}
  | None =>
    if olv_eq_dec (level st.(adjacent) st.(levels)) (level (NSet.remove src st.(adjacent)) (NMap.remove src st.(levels))) then
      put {| local := st.(local) ;
             aggregate := st.(aggregate) ;
             adjacent := NSet.remove src st.(adjacent) ;
             balance := st.(balance) ;
             broadcast := st.(broadcast) ;
             levels := NMap.remove src st.(levels) |}
    else
      put {| local := st.(local) ;
             aggregate := st.(aggregate) ;
             adjacent := NSet.remove src st.(adjacent) ;
             balance := st.(balance) ;
             broadcast := true ;
             levels := NMap.remove src st.(levels) |}
  end ;;
  ret (RecvFail me src)
| New =>
  put {| local := st.(local) ;
         aggregate := st.(aggregate) ;
         adjacent := NSet.add src st.(adjacent) ;
         balance := NMap.add src 1 st.(balance) ;
         broadcast := st.(broadcast) ;
         levels := st.(levels) |} ;;
  when (sumbool_not _ _ (olv_eq_dec (level st.(adjacent) st.(levels)) None))
    (send (src, Level (level st.(adjacent) st.(levels)))) ;;
  ret (RecvNew me src)
end.

Definition NetHandler (me src : name) (msg : Msg) : Handler Data :=
if root_dec me then RootNetHandler me src msg
else NonRootNetHandler me src msg.

Definition send_level_fold (lvo : option lv) (n : name) (res : Handler Data) : Handler Data :=
send (n, Level lvo) ;; res.

Definition send_level_adjacent (lvo : option lv) (fs : NS) : Handler Data :=
NSet.fold (send_level_fold lvo) fs (ret Tau).

Definition RootIOHandler (me : name) (i : Input) : Handler Data :=
st <- get ;;
match i with
| Local m_msg =>
  put {| local := m_msg ;
         aggregate := st.(aggregate) * m_msg * st.(local)^-1 ;
         adjacent := st.(adjacent) ;
         balance := st.(balance) ;
         broadcast := st.(broadcast);
         levels := st.(levels) |} ;;
  ret (DeliverLocal me)
| SendAggregate =>
  ret (DeliverSendAggregate me)
| AggregateRequest client_id =>
  write_output (AggregateResponse client_id st.(aggregate)) ;;
  ret (DeliverAggregateRequest me)
| Broadcast =>
  ret (DeliverBroadcast me)
| LevelRequest client_id =>
  write_output (LevelResponse client_id (Some 0)) ;;
  ret (DeliverLevelRequest me)
end.

Definition NonRootIOHandler (me : name) (i : Input) : Handler Data :=
st <- get ;;
match i with
| Local m_msg =>
  put {| local := m_msg;
         aggregate := st.(aggregate) * m_msg * st.(local)^-1;
         adjacent := st.(adjacent);
         balance := st.(balance);
         broadcast := st.(broadcast);
         levels := st.(levels) |} ;;
  ret (DeliverLocal me)
| SendAggregate =>
  when (sumbool_not _ _ (m_eq_dec st.(aggregate) 1))
  (match parent st.(adjacent) st.(levels) with
  | None => nop
  | Some dst =>
    match NMap.find dst st.(balance) with
    | Some m_dst =>
      send (dst, (Aggregate st.(aggregate))) ;;
      put {| local := st.(local);
             aggregate := 1;
             adjacent := st.(adjacent);
             balance := NMap.add dst (m_dst * st.(aggregate)) st.(balance);
             broadcast := st.(broadcast);
             levels := st.(levels) |}
    | None => nop
    end
  end) ;;
  ret (DeliverSendAggregate me)
| AggregateRequest client_id =>
  write_output (AggregateResponse client_id st.(aggregate)) ;;
  ret (DeliverAggregateRequest me)
| Broadcast =>
  when st.(broadcast)
  (send_level_adjacent (level st.(adjacent) st.(levels)) st.(adjacent) ;;
  put {| local := st.(local);
         aggregate := st.(aggregate);
         adjacent := st.(adjacent);
         balance := st.(balance);
         broadcast := false;
         levels := st.(levels) |}) ;;
  ret (DeliverBroadcast me)
| LevelRequest client_id =>
  write_output (LevelResponse client_id (level st.(adjacent) st.(levels))) ;;
  ret (DeliverLevelRequest me)
end.

Definition IOHandler (me : name) (i : Input) : Handler Data :=
if root_dec me then RootIOHandler me i
else NonRootIOHandler me i.

Instance TreeAggregation_BaseParams : BaseParams :=
  {
    data := Data;
    input := Input;
    output := Output
  }.

Instance TreeAggregation_LabeledMultiParams : LabeledMultiParams TreeAggregation_BaseParams :=
  {
    lb_name := name ;
    lb_msg  := Msg ;
    lb_msg_eq_dec := Msg_eq_dec ;
    lb_name_eq_dec := name_eq_dec ;
    lb_nodes := nodes ;
    lb_all_names_nodes := all_names_nodes ;
    lb_no_dup_nodes := no_dup_nodes ;
    label := Label ;
    label_silent := Tau ;
    lb_init_handlers := InitData ;
    lb_net_handlers := fun dst src msg s =>
                        runGenHandler s (NetHandler dst src msg) ;
    lb_input_handlers := fun nm msg s =>
                        runGenHandler s (IOHandler nm msg)
  }.

Instance TreeAggregation_MultiParams : MultiParams TreeAggregation_BaseParams := unlabeled_multi_params.

Instance TreeAggregation_NameOverlayParams : NameOverlayParams TreeAggregation_MultiParams :=
  {
    adjacent_to := adjacent_to ;
    adjacent_to_dec := adjacent_to_dec ;
    adjacent_to_symmetric := adjacent_to_symmetric ;
    adjacent_to_irreflexive := adjacent_to_irreflexive
  }.

Instance TreeAggregation_FailMsgParams : FailMsgParams TreeAggregation_MultiParams :=
  {
    msg_fail := Fail
  }.

Instance TreeAggregation_NewMsgParams : NewMsgParams TreeAggregation_MultiParams :=
  {
    msg_new := New
  }.

Lemma net_handlers_NetHandler :
  forall dst src m st os st' ms,
    net_handlers dst src m st = (os, st', ms) ->
    exists lb, NetHandler dst src m st = (lb, os, st', ms).
Proof.
intros.
simpl in *.
unfold unlabeled_net_handlers, lb_net_handlers in *.
repeat break_let.
simpl in *.
find_inversion.
exists l0; auto.
Qed.

Lemma NetHandler_cases :
  forall dst src msg st lb out st' ms,
    NetHandler dst src msg st = (lb, out, st', ms) ->
    (exists m_msg m_src, msg = Aggregate m_msg /\ lb = RecvAggregate dst src /\ NMap.find src st.(balance) = Some m_src /\
     st'.(local) = st.(local) /\
     st'.(aggregate) = st.(aggregate) * m_msg /\
     st'.(adjacent) = st.(adjacent) /\
     st'.(balance) = NMap.add src (m_src * (m_msg)^-1) st.(balance) /\
     st'.(broadcast) = st.(broadcast) /\
     st'.(levels) = st.(levels) /\
     out = [] /\ ms = []) \/
    (exists m_msg, msg = Aggregate m_msg /\ lb = RecvAggregate dst src /\ NMap.find src st.(balance) = None /\
     st' = st /\
     out = [] /\ ms = []) \/
    (root dst /\ msg = Fail /\ lb = RecvFail dst src /\ exists m_bal, NMap.find src st.(balance) = Some m_bal /\
     st'.(local) = st.(local) /\
     st'.(aggregate) = st.(aggregate) * m_bal /\
     st'.(adjacent) = NSet.remove src st.(adjacent) /\
     st'.(balance) = NMap.remove src st.(balance) /\
     st'.(broadcast) = st.(broadcast) /\
     st'.(levels) = st.(levels) /\
     out = [] /\ ms = []) \/
    (~ root dst /\ msg = Fail /\ lb = RecvFail dst src /\
     exists m_bal, NMap.find src st.(balance) = Some m_bal /\
     level st.(adjacent) st.(levels) = level (NSet.remove src st.(adjacent)) (NMap.remove src st.(levels)) /\
     st'.(local) = st.(local) /\
     st'.(aggregate) = st.(aggregate) * m_bal /\
     st'.(adjacent) = NSet.remove src st.(adjacent) /\
     st'.(balance) = NMap.remove src st.(balance) /\
     st'.(broadcast) = st.(broadcast) /\
     st'.(levels) = NMap.remove src st.(levels) /\
     out = [] /\ ms = []) \/
    (~ root dst /\ msg = Fail /\ lb = RecvFail dst src /\
     exists m_bal, NMap.find src st.(balance) = Some m_bal /\
     level st.(adjacent) st.(levels) <> level (NSet.remove src st.(adjacent)) (NMap.remove src st.(levels)) /\
     st'.(local) = st.(local) /\
     st'.(aggregate) = st.(aggregate) * m_bal /\
     st'.(adjacent) = NSet.remove src st.(adjacent) /\
     st'.(balance) = NMap.remove src st.(balance) /\
     st'.(broadcast) = true /\
     st'.(levels) = NMap.remove src st.(levels) /\
     out = [] /\ ms = []) \/
    (root dst /\ msg = Fail /\ lb = RecvFail dst src /\ NMap.find src st.(balance) = None /\
     st'.(local) = st.(local) /\
     st'.(aggregate) = st.(aggregate) /\
     st'.(adjacent) = NSet.remove src st.(adjacent) /\
     st'.(balance) = st.(balance) /\
     st'.(broadcast) = st.(broadcast) /\
     st'.(levels) = st.(levels) /\
     out = [] /\ ms = []) \/
    (~ root dst /\ msg = Fail /\ lb = RecvFail dst src /\ NMap.find src st.(balance) = None /\
     level st.(adjacent) st.(levels) = level (NSet.remove src st.(adjacent)) (NMap.remove src st.(levels)) /\
     st'.(local) = st.(local) /\
     st'.(aggregate) = st.(aggregate) /\
     st'.(adjacent) = NSet.remove src st.(adjacent) /\
     st'.(balance) = st.(balance) /\
     st'.(broadcast) = st.(broadcast) /\
     st'.(levels) = NMap.remove src st.(levels) /\
     out = [] /\ ms = []) \/
    (~ root dst /\ msg = Fail /\ lb = RecvFail dst src /\ NMap.find src st.(balance) = None /\
     level st.(adjacent) st.(levels) <> level (NSet.remove src st.(adjacent)) (NMap.remove src st.(levels)) /\
     st'.(local) = st.(local) /\
     st'.(aggregate) = st.(aggregate) /\
     st'.(adjacent) = NSet.remove src st.(adjacent) /\
     st'.(balance) = st.(balance) /\
     st'.(broadcast) = true /\
     st'.(levels) = NMap.remove src st.(levels) /\
     out = [] /\ ms = []) \/
    (root dst /\ exists lvo, msg = Level lvo /\ lb = RecvLevel dst src /\
     st' = st /\
     out = [] /\ ms = []) \/
    (~ root dst /\ exists lv_msg, msg = Level (Some lv_msg) /\ lb = RecvLevel dst src /\
     level st.(adjacent) st.(levels) = level st.(adjacent) (NMap.add src lv_msg st.(levels)) /\
     st'.(local) = st.(local) /\
     st'.(aggregate) = st.(aggregate) /\
     st'.(adjacent) = st.(adjacent) /\
     st'.(balance) = st.(balance) /\
     st'.(broadcast) = st.(broadcast) /\
     st'.(levels) = NMap.add src lv_msg st.(levels) /\
     out = [] /\ ms = []) \/
    (~ root dst /\ exists lv_msg, msg = Level (Some lv_msg) /\ lb = RecvLevel dst src /\
     level st.(adjacent) st.(levels) <> level st.(adjacent) (NMap.add src lv_msg st.(levels)) /\
     st'.(local) = st.(local) /\
     st'.(aggregate) = st.(aggregate) /\
     st'.(adjacent) = st.(adjacent) /\
     st'.(balance) = st.(balance) /\
     st'.(broadcast) = true /\
     st'.(levels) = NMap.add src lv_msg st.(levels) /\
     out = [] /\ ms = []) \/
    (~ root dst /\ msg = Level None /\ lb = RecvLevel dst src /\
     level st.(adjacent) st.(levels) = level st.(adjacent) (NMap.remove src st.(levels)) /\
     st'.(local) = st.(local) /\
     st'.(aggregate) = st.(aggregate) /\
     st'.(adjacent) = st.(adjacent) /\
     st'.(balance) = st.(balance) /\
     st'.(broadcast) = st.(broadcast) /\
     st'.(levels) = NMap.remove src st.(levels) /\
     out = [] /\ ms = []) \/
    (~ root dst /\ msg = Level None /\ lb = RecvLevel dst src /\
     level st.(adjacent) st.(levels) <> level st.(adjacent) (NMap.remove src st.(levels)) /\
     st'.(local) = st.(local) /\
     st'.(aggregate) = st.(aggregate) /\
     st'.(adjacent) = st.(adjacent) /\
     st'.(balance) = st.(balance) /\
     st'.(broadcast) = true /\
     st'.(levels) = NMap.remove src st.(levels) /\
     out = [] /\ ms = []) \/
    (root dst /\ msg = New /\ lb = RecvNew dst src /\
     st'.(local) = st.(local) /\
     st'.(aggregate) = st.(aggregate) /\
     st'.(adjacent) = NSet.add src st.(adjacent) /\
     st'.(balance) = NMap.add src 1 st.(balance) /\
     st'.(broadcast) = st.(broadcast) /\
     st'.(levels) = st.(levels) /\
     out = [] /\ ms = [(src, Level (Some 0))]) \/
    (~ root dst /\ msg = New /\ lb = RecvNew dst src /\ level st.(adjacent) st.(levels) = None /\
     st'.(local) = st.(local) /\
     st'.(aggregate) = st.(aggregate) /\
     st'.(adjacent) = NSet.add src st.(adjacent) /\
     st'.(balance) = NMap.add src 1 st.(balance) /\
     st'.(broadcast) = st.(broadcast) /\
     st'.(levels) = st.(levels) /\
     out = [] /\ ms = []) \/
    (~ root dst /\ msg = New /\ lb = RecvNew dst src /\ exists lv, level st.(adjacent) st.(levels) = Some lv /\
     st'.(local) = st.(local) /\
     st'.(aggregate) = st.(aggregate) /\
     st'.(adjacent) = NSet.add src st.(adjacent) /\
     st'.(balance) = NMap.add src 1 st.(balance) /\
     st'.(broadcast) = st.(broadcast) /\
     st'.(levels) = st.(levels) /\
     out = [] /\ ms = [(src, Level (Some lv))]).
Proof.
move => dst src msg st lb out st' ms.
rewrite /NetHandler /RootNetHandler /NonRootNetHandler.
case: msg => [m_msg||olv_msg|]; monad_unfold; case root_dec => /= H_dec H_eq; repeat break_let; repeat break_match; repeat break_if; repeat find_injection.
- by left; exists m_msg, a.
- by right; left; exists m_msg.
- by left; exists m_msg, a.
- by right; left; exists m_msg.
- right; right; left.
  repeat split => //.
  by exists a.
- by right; right; right; right; right; left.
- right; right; right; left.
  repeat split => //.
  exists a.
  simpl.
  move: Heqb.
  by case olv_eq_dec.
- right; right; right; right; left.
  repeat split => //.
  exists a.
  simpl.
  move: Heqb.
  by case olv_eq_dec.
- right; right; right; right; right; right; left.
  move: Heqb.
  by case olv_eq_dec.
- right; right; right; right; right; right; right; left.
  move: Heqb.
  by case olv_eq_dec.
- right; right; right; right; right; right; right; right; left.
  split => //.
  by exists olv_msg.
- right; right; right; right; right; right; right; right; right; left.
  split => //.
  exists l2.
  move: Heqb.
  by case olv_eq_dec.
- right; right; right; right; right; right; right; right; right; right; left.
  split => //.
  exists l2.
  move: Heqb.
  by case olv_eq_dec.
- right; right; right; right; right; right; right; right; right; right; right; left.
  move: Heqb.
  by case olv_eq_dec.
- right; right; right; right; right; right; right; right; right; right; right; right; left.
  move: Heqb.
  by case olv_eq_dec.
- by right; right; right; right; right; right; right; right; right; right; right; right; right; left.
- unfold sumbool_not in *.
  break_match => //.
  right; right; right; right; right; right; right; right; right; right; right; right; right; right; right.
  move: n {Heqb}.
  case H_lv: level => [lv|] H_neq //.
  repeat split => //.
  by exists lv.
- unfold sumbool_not in *.
  break_match => //.
  by right; right; right; right; right; right; right; right; right; right; right; right; right; right; left.
Qed.

Lemma input_handlers_IOHandler :
  forall h i d os d' ms,
    input_handlers h i d = (os, d', ms) ->
    exists lb, IOHandler h i d = (lb, os, d', ms).
Proof.
intros.
simpl in *.
unfold unlabeled_input_handlers, lb_input_handlers in *.
repeat break_let.
find_inversion.
by exists l0; auto.
Qed.

Lemma send_level_fold_app :
  forall ns st olv nm lb,
snd (fold_left
       (fun (a : Handler Data) (e : NSet.elt) => send_level_fold olv e a) ns
       (fun s : Data => (lb, [], s, nm)) st) =
snd (fold_left
       (fun (a : Handler Data) (e : NSet.elt) => send_level_fold olv e a) ns
       (fun s : Data => (lb, [], s, [])) st) ++ nm.
Proof.
elim => //=.
move => n ns IH st olv nm lb.
rewrite {1}/send_level_fold /=.
monad_unfold.
rewrite /=.
rewrite IH.
rewrite app_assoc.
by rewrite -IH.
Qed.

Instance TreeAggregation_TreeMsg : TreeMsg :=
  {
    tree_msg := Msg ;
    tree_level := Level
  }.

Lemma send_level_adjacent_fst_eq :
forall fs olv st,
  snd (send_level_adjacent olv fs st) = level_adjacent olv fs.
Proof.
move => fs olv st.
rewrite /send_level_adjacent /level_adjacent.
rewrite 2!NSet.fold_spec.
move: olv st.
elim: NSet.elements => [|n ns IH] //=.
move => olv st.
rewrite {2}/level_fold {2}/send_level_fold.
rewrite (@fold_left_level_fold_eq TreeAggregation_TreeMsg).
have IH' := IH olv st.
rewrite -IH'.
monad_unfold.
by rewrite -send_level_fold_app.
Qed.

Lemma fst_fst_fst_tt_send_level_fold :
forall ns nm olv st lb,
fst
  (fst
     (fst
        (fold_left
           (fun (a : Handler Data) (e : NSet.elt) =>
              send_level_fold olv e a) ns
           (fun s : Data => (lb, [], s, nm)) st))) = lb.
Proof.
elim => //=.
move => n ns IH nm olv st lb.
by rewrite IH.
Qed.

Lemma send_level_adjacent_fst_fst_eq :
forall fs olv st,
  fst (fst (fst (send_level_adjacent olv fs st))) = Tau.
Proof.
move => fs olv st.
rewrite /send_level_adjacent.
rewrite NSet.fold_spec.
by rewrite fst_fst_fst_tt_send_level_fold.
Qed.

Lemma snd_fst_fst_out_send_level_fold :
forall ns nm olv st lb,
snd
  (fst
     (fst
        (fold_left
           (fun (a : Handler Data) (e : NSet.elt) =>
              send_level_fold olv e a) ns
           (fun s : Data => (lb, [], s, nm)) st))) = [].
Proof.
elim => //=.
move => n ns IH nm olv st lb.
by rewrite IH.
Qed.

Lemma snd_fst_st_send_level_fold :
forall ns nm olv st lb,
snd (fst
        (fold_left
           (fun (a : Handler Data) (e : NSet.elt) =>
              send_level_fold olv e a) ns
           (fun s : Data => (lb, [], s, nm)) st)) = st.
Proof.
elim => //=.
move => n ns IH nm olv st lb.
by rewrite IH.
Qed.

Lemma send_level_adjacent_snd_fst_fst :
forall fs olv st,
  snd (fst (fst (send_level_adjacent olv fs st))) = [].
Proof.
move => fs olv st.
rewrite /send_level_adjacent.
rewrite NSet.fold_spec.
by rewrite snd_fst_fst_out_send_level_fold.
Qed.

Lemma send_level_adjacent_snd_fst :
forall fs olv st,
  snd (fst (send_level_adjacent olv fs st)) = st.
Proof.
move => fs olv st.
rewrite /send_level_adjacent.
rewrite NSet.fold_spec.
by rewrite snd_fst_st_send_level_fold.
Qed.

Lemma send_level_adjacent_eq :
  forall fs olv st,
  send_level_adjacent olv fs st = (Tau, [], st, level_adjacent olv fs).
Proof.
move => fs olv st.
case H_eq: send_level_adjacent => [[[u o] s b]].
have H_eq'_1 := send_level_adjacent_fst_fst_eq fs olv st.
rewrite H_eq /= in H_eq'_1.
have H_eq'_2 := send_level_adjacent_fst_eq fs olv st.
rewrite H_eq /= in H_eq'_2.
have H_eq'_3 := send_level_adjacent_snd_fst_fst fs olv st.
rewrite H_eq /= in H_eq'_3.
have H_eq'_4 := send_level_adjacent_snd_fst fs olv st.
rewrite H_eq /= in H_eq'_4.
by rewrite H_eq'_1 H_eq'_2 H_eq'_3 H_eq'_4.
Qed.

Lemma IOHandler_cases :
  forall h i st lb out st' ms,
      IOHandler h i st = (lb, out, st', ms) ->
      (exists m_msg, i = Local m_msg /\ lb = DeliverLocal h /\
         st'.(local) = m_msg /\
         st'.(aggregate) = st.(aggregate) * m_msg * st.(local)^-1 /\
         st'.(adjacent) = st.(adjacent) /\
         st'.(balance) = st.(balance) /\
         st'.(broadcast) = st.(broadcast) /\
         st'.(levels) = st.(levels) /\
         out = [] /\ ms = []) \/
      (root h /\ i = SendAggregate /\ lb = DeliverSendAggregate h /\
         st' = st /\
         out = [] /\ ms = []) \/
      (~ root h /\ i = SendAggregate /\ lb = DeliverSendAggregate h /\
       st.(aggregate) <> 1 /\
       exists dst m_dst, parent st.(adjacent) st.(levels) = Some dst /\ NMap.find dst st.(balance) = Some m_dst /\
       st'.(local) = st.(local) /\
       st'.(aggregate) = 1 /\
       st'.(adjacent) = st.(adjacent) /\
       st'.(balance) = NMap.add dst (m_dst * st.(aggregate)) st.(balance) /\
       st'.(broadcast) = st.(broadcast) /\
       st'.(levels) = st.(levels) /\
       out = [] /\ ms = [(dst, Aggregate st.(aggregate))]) \/
      (~ root h /\ i = SendAggregate /\ lb = DeliverSendAggregate h /\
       st.(aggregate) = 1 /\
       st' = st /\
       out = [] /\ ms = []) \/
      (~ root h /\ i = SendAggregate /\
       st.(aggregate) <> 1 /\
       parent st.(adjacent) st.(levels) = None /\
       st' = st /\
       out = [] /\ ms = []) \/
      (~ root h /\ i = SendAggregate /\ lb = DeliverSendAggregate h /\
       st.(aggregate) <> 1 /\
       exists dst, parent st.(adjacent) st.(levels) = Some dst /\ NMap.find dst st.(balance) = None /\
       st' = st /\
       out = [] /\ ms = []) \/
      (exists client_id, i = AggregateRequest client_id /\
       st' = st /\
       out = [AggregateResponse client_id (aggregate st)] /\ ms = []) \/
      (root h /\ i = Broadcast /\ st' = st /\ lb = DeliverBroadcast h /\
       out = [] /\ ms = []) \/
      (~ root h /\ i = Broadcast /\ lb = DeliverBroadcast h /\ st.(broadcast) = true /\
       st'.(local) = st.(local) /\
       st'.(aggregate) = st.(aggregate) /\
       st'.(adjacent) = st.(adjacent) /\
       st'.(balance) = st.(balance) /\
       st'.(broadcast) = false /\
       st'.(levels) = st.(levels) /\
       out = [] /\ ms = level_adjacent (level st.(adjacent) st.(levels)) st.(adjacent)) \/
      (~ root h /\ i = Broadcast /\ lb = DeliverBroadcast h /\ st.(broadcast) = false /\
       st' = st /\
       out = [] /\ ms = []) \/
      (root h /\ exists client_id, i = LevelRequest client_id /\ lb = DeliverLevelRequest h /\
       st' = st /\
       out = [LevelResponse client_id (Some 0)] /\ ms = []) \/
      (~ root h /\ exists client_id, i = LevelRequest client_id /\ lb = DeliverLevelRequest h /\
       st' = st /\
       out = [LevelResponse client_id (level st.(adjacent) st.(levels))] /\ ms = []).
Proof.
move => h i st lb out st' ms.
rewrite /IOHandler /RootIOHandler /NonRootIOHandler.
case: i => [m_msg||client_id|client_id|]; monad_unfold; case root_dec => /= H_dec H_eq; repeat break_let; repeat find_injection; repeat break_match; repeat break_let; repeat find_injection.
- by left; exists m_msg.
- by left; exists m_msg.
- by right; left.
- unfold sumbool_not in *.
  break_match => //.
  right; right; left.
  repeat split => //.
  by exists n, a.
- unfold sumbool_not in *.
  break_match => //.
  right; right; right; right; right; left.
  repeat split => //.
  by exists n.
- unfold sumbool_not in *.
  break_match => //.
  by right; right; right; right; left.
- unfold sumbool_not in *.
  break_match => //.
  by right; right; right; left.
- right; right; right; right; right; right; left.
  by exists client_id.
- right; right; right; right; right; right; left.
  by exists client_id.
- right; right; right; right; right; right; right; right; right; right; left.
  split => //.
  by exists client_id.
- right; right; right; right; right; right; right; right; right; right; right.
  split => //.
  by exists client_id.
- by right; right; right; right; right; right; right; left.
- find_rewrite_lem send_level_adjacent_eq.
  find_injection.
  right; right; right; right; right; right; right; right; left.
  by rewrite /= app_nil_r -2!app_nil_end.
- by right; right; right; right; right; right; right; right; right; left.
Qed.

Ltac net_handler_cases :=
  find_apply_lem_hyp NetHandler_cases;
  intuition idtac; try break_exists;
  intuition idtac; subst;
  repeat find_rewrite.

Ltac io_handler_cases :=
  find_apply_lem_hyp IOHandler_cases;
  intuition idtac; try break_exists;
  intuition idtac; subst;
  repeat find_rewrite.

End TreeAggregation.


From Undecidability.L Require Import L LTactics.
From Complexity.Complexity Require Import NP Definitions Monotonic.

Record canEnumTerms (X__cert : Type) `{R__cert : encodable X__cert} : Type :=
  {
    f__toTerm : X__cert -> term;
    comp__toTerm :> polyTimeComputable f__toTerm;
    inSize__toTerm : nat -> nat;
    complete__toTerm : (forall s:term, exists x:X__cert, f__toTerm x = s /\ size (enc x) <= inSize__toTerm (size (enc s)));
    polyIn__toTerm : inOPoly inSize__toTerm;
    monoIn__toTerm : monotonic inSize__toTerm;
  }.

Arguments canEnumTerms : clear implicits.
Arguments canEnumTerms _ {_}.

#[export]
Hint Extern 2 (computableTime (f__toTerm _) _) => unshelve (simple apply @comp__polyTC);simple apply @comp__toTerm :typeclass_instances.
Smpl Add 10 (simple apply polyIn__toTerm) : inO.
Smpl Add 10 (simple apply monoIn__toTerm) : inO.

Lemma canEnumTerms_compPoly (X__cert : Type) `{R__cert : encodable X__cert}:
  canEnumTerms X__cert -> exists H : canEnumTerms X__cert, inhabited (polyTimeComputable (time__polyTC H))
                                      /\ inhabited (polyTimeComputable (inSize__toTerm H))
                                      /\ inhabited (polyTimeComputable (resSize__rSP H)).
Proof.
  intros Hin.
  destruct (polyTimeComputable_compTime (comp__toTerm Hin)) as (?&?).
  destruct (inOPoly_computable (polyIn__toTerm Hin)) as (p'&?&Hbounds&?&?).
  unshelve eexists. eexists (f__toTerm Hin) p'. 5:cbn.
  1,3,4,5:now eauto using comp__toTerm.
  intros s. destruct (complete__toTerm Hin s) as (c&<-&Hc).
  eexists;split. easy. now rewrite <- Hbounds.
Qed.


Require Export CatSem.CAT.rmonad.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Section rmonad_hom.

Variables obC obD : Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable C : Cat_struct morC.
Variable D : Cat_struct morD.
Variable F : Functor C D.

Section rmonad_hom.

Variables P Q : RMonad F.

Class RMonad_Hom_struct (tau : forall c : obC, morD (P c) (Q c)) := {
  rmonad_hom_rweta : forall c:obC,
      rweta c ;; tau c == rweta c ;
  rmonad_hom_rkl : forall c d (f : morD (F c) (P d)),
      rkleisli f ;; tau d == tau c ;; rkleisli (f ;; tau d)
}.

Record RMonad_Hom := {
  rmonad_hom :> forall c, morD (P c) (Q c);
  rmonad_hom_struct :> RMonad_Hom_struct rmonad_hom
}.

Section RMonad_Hom_NT.

Variable tau : forall c : obC, morD (P c) (Q c).

Variable tua : RMonad_Hom_struct tau.

(** trivial lemmata *)

Lemma rmon_hom_rweta (c : obC) : rweta c ;; tau c == rweta c.
Proof.
  apply rmonad_hom_rweta.
Qed.

Lemma rmon_hom_rkl (c d : obC) (f : morD (F c) (P d)) :
   rkleisli f ;; tau d == tau c ;; rkleisli (f ;; tau d).
Proof.
  apply rmonad_hom_rkl.
Qed.

Hint Rewrite rmon_hom_rweta : rmonad.
Hint Resolve rmon_hom_rkl : rmonad.
Hint Rewrite rmon_hom_rkl.

Obligation Tactic := idtac.

Program Instance RMonad_Hom_NT :
  NT_struct (F:=RMFunc P) (G:=RMFunc Q) tau.
Next Obligation.
Proof.
  simpl.
  intros c d f.
  unfold rlift.
  rewrite (rmonad_hom_rkl).
  rewrite assoc.
  rmonad.
Qed.

End RMonad_Hom_NT.

End rmonad_hom.

Section RMonad_id_comp.

Variable P : RMonad F.

Obligation Tactic := rmonad.

Program Instance RMonad_id_s :
  RMonad_Hom_struct (P:=P) (fun _ => id _ ).

Definition RMonad_id := Build_RMonad_Hom RMonad_id_s.

Variables Q R : RMonad F.
Variable S : RMonad_Hom P Q.
Variable T : RMonad_Hom Q R.

Program Instance RMonad_comp_s :
  RMonad_Hom_struct (fun c => S c ;; T c).
Next Obligation.
Proof.
  rewrite <- assoc.
  rewrite (rmon_hom_rweta S).
  rewrite (rmon_hom_rweta T).
  cat.
Qed.
Next Obligation.
Proof.
  rewrite <- assoc.
  rewrite (rmon_hom_rkl S).
  rewrite assoc.
  rewrite (rmon_hom_rkl T).
  rmonad.
Qed.

Definition RMonad_comp := Build_RMonad_Hom RMonad_comp_s.

End RMonad_id_comp.

Lemma RMonad_Hom_equiv (P Q: RMonad F) :
   Equivalence (A:=RMonad_Hom P Q) (fun M N => forall x, M x == N x).
Proof.
  intros P Q;
  constructor.
  unfold Reflexive.
  cat.
  unfold Symmetric;
  intros; apply hom_sym;
  auto.
  unfold Transitive.
  intros.
  etransitivity; auto.
Qed.

Definition RMonad_Hom_oid (P Q: RMonad F) :=
           Build_Setoid (RMonad_Hom_equiv P Q).

Obligation Tactic := simpl; intros; try apply assoc; cat.

Program Instance RMONAD_struct : Cat_struct RMonad_Hom := {
  mor_oid := RMonad_Hom_oid ;
  comp := RMonad_comp ;
  id := RMonad_id
}.
Next Obligation.
Proof.
  unfold Proper; do 2 red.
  simpl.
  intros x y H x' y' H' z;
  rewrite H;
  rewrite H';
  cat.
Qed.

Definition RMONAD := Build_Cat RMONAD_struct.

End rmonad_hom.

Existing Instance rmonad_hom_struct.

Hint Rewrite rmon_hom_rweta : rmonad.
Hint Resolve rmon_hom_rkl : rmonad.
Hint Rewrite rmon_hom_rkl : rmonad.


(** ** Weak Head Normalisation *)

Require Import core fintype.
Import ScopedNotations.
From Chapter9 Require Export preservation.

Definition E_ {m} (L: tm m -> Prop)  (s : tm m) : Prop :=
  exists v, star step s v /\ L v.

Fixpoint L {m} (A : ty): tm m -> Prop :=
  match A with
  | Base => fun s => exists v, star step s v /\ value v
  | Fun A1 A2 => fun e => match e with
                      | (lam B s) => forall k (xi: fin m -> fin k) v, L A1 v -> E_ (L A2) (subst_tm (scons v (xi >> var_tm)) s)
                      | _ => False
                      end
  end.

Lemma L_ren {m n} s A (xi: fin m -> fin n) :
  L A s -> L A (ren_tm xi s).
Proof.
  revert m n s xi. induction A; eauto; intros m n s xi.
  - intros (?&?&?).
    exists (x⟨xi⟩). split.
    + substify. eauto using mstep_inst.
    + destruct x; eauto.
  - intros.
    destruct s; try contradiction.
    intros k zeta v H''. cbn in H. specialize (H _ (xi >> zeta) _ H'').
    destruct H as (?&?&?).
    exists x. split; eauto. asimpl. eauto.
Qed.

Definition G {m k} (Gamma : ctx m) : (fin m -> tm k)  -> Prop :=
  fun σ => forall (x : fin m), L (Gamma x) (σ x) .

Definition has_ty_sem {m} (Gamma : ctx m) (s: tm m) (A: ty) : Prop :=
  forall k (sigma: fin m -> tm k), G Gamma sigma -> E_ (L A) (subst_tm sigma s).

Lemma val_inclusion {m} A (e: tm m) :
  L A e -> E_ (L A) e.
Proof. intros. unfold E_. exists e. split; eauto. Qed.

Lemma wn_fundamental_lam {m} Gamma (s: tm m) A:
  has_type Gamma s A -> has_ty_sem Gamma s A.
Proof.
  intros C. unfold has_ty_sem, E_. induction C; subst; intros.
  - eauto.
  - apply val_inclusion. asimpl.
    intros m. intros.
    assert (G (S1 .: Gamma) (v .: (sigma >> ren_tm xi))).     { unfold G. intros [|]; cbn; eauto.
      - cbn in *. specialize (H f). now apply L_ren. }
    (* TODO here we don't apply ext_tm because the goal is not an equality. How do we solve this?
     1. waybe write another tactic that does something like
     assert (H: s[sigma] = ?x) by now asimpl.
     rewrite H
     which would take the instantiation as an argument (or somehow infer it maybe with `match Goal with _ |- context[ subst_tm ... ])

    2. don't use simple apply in asimpl' but rather rewrite so that the normal asimpl tactic works here. But then we have the problem that ext_tm is much too general since we can rewrite every substitution with it. Maybe setoid rewriting can do it. We should somehow say that we can only rewrite with ext_tm if the substitution contains something that would be rewritten by renComp' (i.e. the one with funext)
    To do that we could form a predicate on subsitutions P : (nat -> tm) -> Prop
    with constructors for the atomic cases for renComp', renRen', etc. (so <xi> >> [sigma] / [sigma] >> [sigma], etc.)
    and other congruence constructors.
    Then declare a Proper instance to rewrite with ext_tm if the substitution fulfills the predicate.
    This might work but to build the proof of the predicate we probably need typeclasses which will probably lead to pain.

     *)
    (* assert (M[(@var_tm (S k) var_zero) .: sigma >> (ren_tm shift)][v .: xi >> (@var_tm m)] = M[_]) by (now asimpl). *)
    asimpl.
    (* rewrite renComp'_tm. *)
    specialize (IHC _ _ H1).
    destruct (IHC) as (v'&?&?).
    exists v'; split; eauto.
    revert H2.
    unfold funcomp.
    setoid_rewrite rinstInst_tm'. eauto using mstep_inst.
  - destruct (IHC1 _ _  H) as (v1&?&?).
    destruct (IHC2  _ _ H) as (v2&?&?).
    destruct v1; try contradiction.
    cbn in H1.
    destruct (H1 _ id _ H3) as (v&?&?).
    exists v; split; eauto. asimpl.
    enough (star step (app  (lam t v1) v2) v).
    + eapply star_trans.
      eapply mstep_app; eauto. assumption.
    + eapply star_trans.
      * eright. econstructor; eauto. constructor.
      * now asimpl in H4.
Qed.


Require Import Verdi.Verdi.

Require Import FMapList.
Require Import String.

Require Import Verdi.FMapVeryWeak.
Require Import Verdi.StateMachineHandlerMonad.

Definition key := string.
Definition value := string.

Inductive input : Set :=
| Put : key -> value -> input
| Get : key -> input
| Del : key -> input
| CAS : key -> option value -> value -> input
| CAD : key -> value -> input.

Inductive output : Set :=
| Response : key -> option value -> option value -> output. (* uniform response *)

Module VarDFunctor (Map : VWS
                       with Definition E.t := string
                       with Definition E.eq := @eq string).

Definition key_eq_dec := string_dec.
Definition value_eq_dec := string_dec.

Definition val_eq_dec : forall v v' : option value, {v = v'} + {v <> v'}.
  decide equality.
  auto using value_eq_dec.
Defined.

Theorem input_eq_dec : forall x y: input, {x = y} + {x <> y}.
Proof.
  decide equality;
  auto using key_eq_dec, value_eq_dec, val_eq_dec.
Defined.

Theorem output_eq_dec : forall x y: output, {x = y} + {x <> y}.
Proof.
  decide equality;
  auto using key_eq_dec, value_eq_dec, val_eq_dec.
Defined.

Definition data :=
  Map.t string.

Definition beq_key (k1 k2 : key) :=
  if string_dec k1 k2 then true else false.

Definition getk k : GenHandler1 data (option value) :=
  db <- get ;;
  ret (Map.find k db).

Definition setk k v : GenHandler1 data unit := modify (fun db => Map.add k v db).

Definition delk k : GenHandler1 data unit := modify (fun db => Map.remove k db).

Definition resp k v old : GenHandler1 data output :=
  write_output (Response k v old).

Definition VarDHandler' (inp : input) : GenHandler1 data output :=
  match inp with
    | Get k => v <- getk k ;; resp k v v
    | Put k v => old <- getk k ;; setk k v ;; resp k (Some v) old
    | Del k => old <- getk k ;; delk k ;; resp k None old
    | CAS k v v' =>
      old <- getk k ;;
          if (val_eq_dec old v) then
            (setk k v' ;; resp k (Some v') old)
          else
            resp k old old
    | CAD k v =>
      old <- getk k ;;
          if (val_eq_dec old (Some v)) then
            (delk k ;; resp k None old)
          else
            resp k old old
  end.

Definition runHandler (h : input -> GenHandler1 data output)
           (inp : input) (d : data) : output * data :=
  runGenHandler1 d (h inp).

Definition VarDHandler := runHandler VarDHandler'.

Definition init_map := Map.empty string.

#[global]
Instance vard_base_params : BaseParams :=
  {
    data := data ;
    input := input ;
    output := output
  }.

#[global]
Instance vard_one_node_params : OneNodeParams _ :=
  {
    init := init_map ;
    handler := VarDHandler
  }.

Definition input_key (i : input) : key :=
  match i with
    | Get k => k
    | Put k _ => k
    | Del k => k
    | CAS k _ _ => k
    | CAD k _ => k
  end.

Definition operate (op : input) (curr : option value) :=
  match op with
    | Get _ => (curr, curr)
    | Put _ v => (Some v, curr)
    | Del _ => (None, curr)
    | CAS _ v v' => if val_eq_dec curr v then (Some v', curr) else (curr, curr)
    | CAD _ v => if val_eq_dec curr (Some v) then (None, curr) else (curr, curr)
  end.

Fixpoint interpret (k : key) (ops : list input) (init : option value) :=
  match ops with
    | [] => (init, init)
    | op :: ops =>
      (operate op (fst (interpret k ops init)))
  end.

Definition inputs_with_key (trace : list (input * output)) (k : key) : list input :=
  filterMap (fun ev => if key_eq_dec k (input_key (fst ev)) then
                            Some (fst ev)
                          else
                            None)
            trace.

Inductive trace_correct : list (input * output) -> Prop :=
| TCnil : trace_correct []
| TCApp : forall t i v o, trace_correct t ->
                     interpret (input_key i)
                               (i :: (rev (inputs_with_key t (input_key i))))
                               None = (v, o) ->
                     trace_correct (t ++ [(i, Response (input_key i) v o)]).

Inductive trace_correct' : data -> list (input * output) -> Prop :=
| TC'nil : forall st, trace_correct' st []
| TC'App : forall st t i v o, trace_correct' st t ->
                         interpret (input_key i)
                                   (i :: (rev (inputs_with_key t (input_key i))))
                                   (Map.find (input_key i) st) = (v, o) ->
                         trace_correct' st (t ++ [(i, Response (input_key i) v o)]).

Lemma trace_correct'_trace_correct :
  forall trace,
    trace_correct' init trace ->
    trace_correct trace.
Proof.
  intros.
  remember init as x. induction H.
  - constructor.
  - subst. constructor; auto.
    find_rewrite_lem Map.empty_o. auto.
Qed.

Definition trace_state_correct (trace : list (input * output)) (st : data) (st' : data) :=
  forall k,
    fst (interpret k (rev (inputs_with_key trace k)) (Map.find k st)) = Map.find k st'.

Ltac vard_unfold :=
  unfold runHandler,
  getk,
  setk,
  delk,
  resp in *; monad_unfold.

Lemma trace_well_formed :
  forall st st' trace,
    step_1_star st st' trace ->
    (trace = [] \/ exists t i o, trace = t ++ [(i, o)]).
Proof.
  intros.
  find_apply_lem_hyp refl_trans_1n_n1_trace.
  invcs H; intuition.
  right. exists cs. invcs H1. unfold VarDHandler, VarDHandler' in *.
  vard_unfold.
  repeat break_match; simpl in *; repeat find_inversion; repeat eexists; eauto.
Qed.

Lemma inputs_with_key_plus_key :
  forall l k i o,
    input_key i = k ->
    inputs_with_key (l ++ [(i, o)]) k =
    (inputs_with_key l k) ++ [i].
Proof.
  induction l; intros; simpl in *.
  - unfold inputs_with_key. simpl in *.
    repeat break_match; congruence.
  - unfold inputs_with_key in *.
    simpl in *.
    repeat break_match; simpl in *; f_equal; eauto.
Qed.

Lemma inputs_with_key_plus_not_key :
  forall l k i o,
    input_key i <> k ->
    inputs_with_key (l ++ [(i, o)]) k =
    (inputs_with_key l k).
Proof.
  induction l; intros; simpl in *.
  - unfold inputs_with_key. simpl in *.
    repeat break_match; congruence.
  - unfold inputs_with_key in *.
    simpl in *.
    repeat break_match; simpl in *; eauto; try discriminate.
    repeat find_inversion.
    f_equal. eauto.
Qed.

Theorem step_1_star_trace_state_correct :
  forall st st' trace,
    step_1_star st st' trace ->
    trace_state_correct trace st st'.
Proof.
  intros.
  find_apply_lem_hyp refl_trans_1n_n1_trace.
  induction H; auto.
  - unfold trace_state_correct. auto.
  - unfold trace_state_correct in *. intros.
    invcs H0. unfold VarDHandler, VarDHandler' in *.
    vard_unfold. repeat break_match; simpl in *; repeat find_inversion.
    + destruct (key_eq_dec k0 k).
      * rewrite inputs_with_key_plus_key; simpl in *; auto.
        rewrite rev_unit. simpl in *.
        subst.
        symmetry; apply Map.add_eq_o.
        reflexivity.
      * rewrite inputs_with_key_plus_not_key; simpl in *; eauto.
        rewrite Map.add_neq_o; auto.
    + destruct (key_eq_dec k0 k).
      * rewrite inputs_with_key_plus_key; simpl in *; auto.
        rewrite rev_unit. simpl in *.
        subst. eauto.
      * rewrite inputs_with_key_plus_not_key; simpl in *; eauto.
    + destruct (key_eq_dec k0 k).
      * rewrite inputs_with_key_plus_key; simpl in *; auto.
        rewrite rev_unit. simpl in *.
        subst. eauto.
        rewrite Map.remove_eq_o; auto.
      * rewrite inputs_with_key_plus_not_key; simpl in *; eauto.
        rewrite Map.remove_neq_o; auto.
    + destruct (key_eq_dec k0 k).
      * subst. rewrite inputs_with_key_plus_key; simpl in *; auto.
        rewrite rev_unit. simpl in *.
        break_if; [rewrite Map.add_eq_o; auto | idtac].
        exfalso. intuition.
      * rewrite inputs_with_key_plus_not_key; simpl in *; eauto.
        rewrite Map.add_neq_o; auto.
    + destruct (key_eq_dec k0 k).
      * rewrite inputs_with_key_plus_key; simpl in *; auto.
        rewrite rev_unit. simpl in *.
        subst. break_if.
        -- subst.
           exfalso. intuition.
        -- simpl in *.
           apply IHrefl_trans_n1_trace.
      * rewrite inputs_with_key_plus_not_key; simpl in *; eauto.
    + destruct (key_eq_dec k0 k).
      * { subst. rewrite inputs_with_key_plus_key; simpl in *; auto.
          rewrite rev_unit. simpl in *.
          break_if; simpl in *.
          - symmetry. rewrite Map.remove_eq_o; auto.
          - exfalso. intuition.
            match goal with
              | H : _ -> False |- _ => apply H
            end.
            find_higher_order_rewrite. auto.
        }
      * rewrite inputs_with_key_plus_not_key; simpl in *; eauto.
        rewrite Map.remove_neq_o; auto.
    + destruct (key_eq_dec k0 k).
      * subst. rewrite inputs_with_key_plus_key; simpl in *; auto.
        rewrite rev_unit. simpl in *.
        break_if; simpl in *; intuition.
        exfalso. intuition.
        match goal with
          | H : _ -> False |- _ => apply H
        end.
        find_higher_order_rewrite. auto.
      * rewrite inputs_with_key_plus_not_key; simpl in *; eauto.
Qed.

Lemma trace_state_correct_trace_correct :
  forall st st' st'' trace t,
    trace_state_correct trace st st' ->
    trace_correct' st trace ->
    step_1 st' st'' t ->
    trace_correct' st (trace ++ t).
Proof.
  intros.
  invcs H1; simpl in *.
  unfold VarDHandler, VarDHandler' in *.
  vard_unfold.
  repeat break_match; simpl in *; repeat find_inversion; constructor; auto;
  simpl in *; f_equal; eauto;
  break_if; simpl in *;  f_equal; eauto; unfold trace_state_correct in *;
  exfalso; subst; repeat find_higher_order_rewrite;
  intuition.
Qed.

Theorem step_1_star_trace_correct' :
  forall st st' trace,
    step_1_star st st' trace ->
    trace_correct' st trace.
Proof.
  intros.
  find_apply_lem_hyp refl_trans_1n_n1_trace.
  induction H.
  - constructor.
  - find_apply_lem_hyp refl_trans_n1_1n_trace.
    find_apply_lem_hyp step_1_star_trace_state_correct; auto.
    eapply trace_state_correct_trace_correct; eauto.
Qed.

Theorem step_1_star_trace_correct :
  forall st trace,
    step_1_star init st trace ->
    trace_correct trace.
Proof.
  intros.
  find_apply_lem_hyp step_1_star_trace_correct'.
  eauto using trace_correct'_trace_correct.
Qed.

Open Scope string_scope.
Example trace_correct_eg0 :
  trace_correct [(Put "james" "awesome", Response "james" (Some "awesome") None)].
Proof.
  rewrite <- app_nil_l.
  constructor.
  - constructor.
  - simpl. auto.
Qed.
End VarDFunctor.

Module LogTimeVarD := VarDFunctor(LogTimeStringMap).
Module LinearTimeVarD := VarDFunctor(LinearTimeStringMap).

Module VarD := LogTimeVarD.

Export VarD.


Section Soundness.

  Load "PTS_spec".

  Notation typ2 := (typ the_PTS) (only parsing).
  Notation wf_type2 := (wf_type the_PTS) (only parsing).

Section SoundnessDef.

  Variable R : red_rule.

  Definition rule_sound :=
    forall (e : env) (x y : term),
    R e x y -> forall T : term, typ the_PTS e x T -> typ the_PTS e y T.

End SoundnessDef.

Section Sound_context.

  Variable the_rule : Basic_rule.

  Let R := Rule the_rule.
  Let Rlifts : R_lift R := R_lifts the_rule.

  Hint Resolve Rlifts: pts.

  Hypothesis
    incl_R_le_type :
      forall (e : env) (x y : term), ctxt R e x y -> le_type e y x.

  Theorem red_incl_le_type :
   forall (e : env) (x y : term), red R e x y -> le_type e y x.
simple induction 1; intros; auto with pts.
apply le_type_trans with y0; auto with pts.
Qed.

  Theorem red_in_env :
   forall (e : env) (u v t T : term),
   typ the_PTS (Ax u :: e) t T ->
   forall s : sort,
   typ the_PTS e v (Srt s) -> red R e u v -> typ the_PTS (Ax v :: e) t T.
intros.
apply subtype_in_env with (1 := H).
constructor.
constructor.
red in |- *.
auto with pts.
apply red_incl_le_type.
trivial with pts.

apply wf_var with s; trivial with pts.
Qed.

  Theorem ctxt_sound : rule_sound R -> rule_sound (ctxt R).
red in |- *.
simple induction 2; auto with pts; intros.
Inversion_typ H3.
apply typ_conv_wf with (Prod M U); auto with pts.
apply type_conv with (Prod M' U) s; auto with pts.
Inversion_typ H5.
apply type_abs with s3; auto with pts.
apply type_prod with s1 s2; auto with pts.
apply red_in_env with M s1; auto with pts.

apply red_in_env with M s1; auto with pts.

apply incl_R_le_type.
auto with pts.

apply type_correctness with (Abs M N); auto with pts.

Inversion_typ H3.
apply typ_conv_wf with (Prod N U); auto with pts.
apply type_abs with s; auto with pts.

apply type_correctness with (Abs N M); auto with pts.

Inversion_typ H3.
apply typ_conv_wf with (subst M2 Ur); auto with pts.
apply type_app with V; auto with pts.

apply type_correctness with (App M1 M2); auto with pts.

Inversion_typ H3.
apply typ_conv_wf with (subst M2 Ur); auto with pts.
cut (wf_type the_PTS e0 (Prod V Ur)); intros.
inversion_clear H7.
Inversion_typ H8.
apply type_conv with (subst N2 Ur) s2; auto with pts.
apply type_app with V; auto with pts.

apply red_incl_le_type.
unfold subst in |- *.
apply red_subst_l with e0; auto with pts.

replace (Srt s2) with (subst M2 (Srt s2)); auto with pts.
apply substitution with V; auto with pts.

apply type_correctness with M1; auto with pts.

apply type_correctness with (App M1 M2); auto with pts.

Inversion_typ H3.
apply typ_conv_wf with (Srt s3); auto with pts.
apply type_prod with s1 s2; auto with pts.
apply red_in_env with M1 s1; auto with pts.

apply type_correctness with (Prod M1 M2); auto with pts.

Inversion_typ H3.
apply typ_conv_wf with (Srt s3); auto with pts.
apply type_prod with s1 s2; auto with pts.

apply type_correctness with (Prod M1 M2); auto with pts.
Qed.

End Sound_context.

  Theorem incl_sound :
   forall P Q : red_rule,
   (forall (e : env) (x y : term), P e x y -> Q e x y) ->
   rule_sound Q -> rule_sound P.
unfold rule_sound in |- *.
intros.
apply H0 with x; auto with pts.
Qed.

  Theorem union_sound :
   forall P Q : red_rule,
   rule_sound P -> rule_sound Q -> rule_sound (reunion P Q).
red in |- *.
simple induction 3; intros.
apply H with x; auto with pts.

apply H0 with x; auto with pts.
Qed.

  Theorem clos_trans_sound :
   forall P : red_rule,
   rule_sound P -> rule_sound (fun e : env => clos_trans term (P e)).
red in |- *.
simple induction 2; intros; auto with pts.
apply H with x0; auto with pts.
Qed.

  Theorem clos_refl_trans_sound :
   forall P : red_rule, rule_sound P -> rule_sound (R_rt P).
red in |- *.
simple induction 2; intros; auto with pts.
apply H with x0; auto with pts.
Qed.

End Soundness.