(** This file was written by Colm Bhandal, PhD student, Foundations and Methods group,
School of Computer Science and Statistics, Trinity College, Dublin, Ireland.*)

(***************************** Standard Imports *****************************)

Require Import Equality.

Require Import ComhCoq.Extras.LibTactics.

(***************************** Specialised Imports *****************************)

Require Import ComhCoq.GenTacs.
Require Import ComhCoq.StandardResults.
Require Import ComhCoq.ComhBasics.
Require Import ComhCoq.LanguageFoundations.
(*
Require Import ComhCoq.SoftwareLanguage.
Require Import ComhCoq.ProtAuxDefs.
Require Import ComhCoq.InterfaceLanguage.
Require Import ComhCoq.ModeStateLanguage.
Require Import ComhCoq.EntityLanguage.*)
Require Import ComhCoq.NetworkLanguage.
(*Require Import ComhCoq.EntAux.*)
Require Import ComhCoq.NetAuxBasics.
Require Import ComhCoq.NetAuxDefs.
Require Import ComhCoq.SoftwareLanguage.
Require Import ComhCoq.InterfaceLanguage.
Require Import ComhCoq.ModeStateLanguage.
Require Import ComhCoq.EntAuxDefs.
Require Import ComhCoq.ProtAuxDefs.
Require Import ComhCoq.EntAuxResults.

(*** Net Aux Results Imports ***)
Require Import ComhCoq.NARInsuff.
Require Import ComhCoq.NARMisc.
Require Import ComhCoq.NARMsgPosition.
Require Import ComhCoq.NAROvlpTime.

(* Let's say we can show that a network is currSince m t i n, then we can show
that the time parameter to this relation is always greater than mL + max AN trans,
which is the lower bound for the pre-sent interval.*)
Theorem currSince_lower_bound (n : Network) (t : Time) (m : Mode)
  (i : nat) (p : reachableNet n) : currSince m t i n p ->
  msgLatency + Rmax adaptNotif transMax < t.
  (**Proof: Induction on currSince.*)
  intros. induction H.
  (*It's the base case that requires the most attention here. Well, we notice that
  the base case of currSince involves a proof of nextSince for the previous state.
  It also enforces the entity in the previous state to be in the state switchCurrState m.
  We prove elsewhere (NAROvlpTime::nextSince_switchCurr_lower) that nextSince, in this previous state,
  implies the lower bound. since the t is the same in the base case from premise to
  conclusion (passed on like a relay bat), this lower bound carries on to the t in
  currSince, and that's the base case done.*)
  apply (nextSince_switchCurr_lower n m i t p H H0).
  (*The inductive cases are the easy ones for once- because
  the parameter t to currSince is non-decreasing over these.*)
  assumption. apply Rplus_lt_weaken_rr. apply Rlt_le. delPos.
  assumption. Qed.

Lemma maxAnTrans_positive : 0 <= Rmax adaptNotif transMax.
  eapply Rle_trans;[ |apply Rmax_l]. timeNonneg. Qed.

(* If an entity has been awaiting a transition to a mode m for the past t time units,
and this t is bounded from below by mL + AN, then the entity in question has delivered
a message of <m, l0> to a sufficient radius r and l0, the position broadcast, differs
from the current position by at most Smax*t.*)
Theorem nextSince_fst_deliv_suff (n : Network) (t : Time) (m : Mode)
  (i : nat) (l : Position) (p : reachableNet n) :
  nextSince m t i n p -> inPosNet l i n ->
  forall q : msgLatency + Rmax adaptNotif transMax < t,
  let s := (Rplus_lt_weaken_lr msgLatency (Rmax adaptNotif transMax)
  t q maxAnTrans_positive) in
  let s' := Rlt_le msgLatency t s in
  exists l0 l1 r,
  delivered ([-[baseMode m, basePosition l0], l1, r-]) (minusTime t msgLatency s') i n p /\
  sufficient m r /\ dist2d l l0 <= speedMax*t.
  intros U0 U1 q. simpl.
  (*Well since mL + AN < t, then mL < t.*)
  assert (msgLatency < t) as MT. eapply Rplus_lt_weaken_lr. apply q.
  (*So by (NARMsgPosition::fst_delivered) we have that
  delivered <m, l0> r (t - mL) i n p /\ |l - l0| <= Smax*t.*)
  apply maxAnTrans_positive. lets FX : fst_delivered U0 U1 MT. decompEx3 FX l0 l1 r FD.
  decompAnd2 FD DE DI.
  (*This will do for our existential.*)
  exists l0 l1 r. splits;[my_applys_eq DE | | apply DI]. timering.
  (*So all that remains to be proven is the sufficiency of the radius r for the mode m.
  Now, again taking our inequality mL + AN < t we can easily obtain AN < t - mL.*)
  assert (adaptNotif < t - msgLatency) as AT. apply Rplus_lt_swap_ll in q.
  eapply Rle_lt_trans;[ |apply q]. apply Rmax_l.
  (*Also due to positive mL we have t - mL < t.*)
  assert (t - msgLatency < t). apply Rplus_lt_swap_rr. Rplus_lt_tac.
  apply msgLatency_positive.
  (*Hence by (deliv_next_suff) we get sufficient m r, and we're done.*)
  eapply deliv_next_suff. apply U0. apply DE. simpl. assumption. apply H.
  Qed.

(*TIDY*)

(*DELETE ON RECOMPILE*)
Lemma ovWait_del_pres_bkwd_net_strong n n' d m t x y i :
  n -ND- d -ND> n' -> ovWaitStateNet m t x y i n' ->
  ovWaitStateNet m t (x +dt+ d) (y +dt+ d) i n. Admitted.

Lemma init_ovWait_track_net m m' t' i x y n n' a :
  initStateNet m i n -> ovWaitStateNet m' t' x y i n' ->
  n -NA- a -NA> n' -> m = m' /\ x = t' /\ y = zeroTime.
  Admitted. (*#lift-track-net*)
(*Might prove a stronger version of this with the value of t' =
tx(m, m') + period m', where m is the current mode.*)

(*-TIDY*)

(* If we are in the wait state of the overlap component, and the y clock value is non-zero,
then a message containing the mode in question and some position was sent exactly
(period m - y) time units ago.  *)
Theorem ovWait_sent (n : Network) (m : Mode) (t x y : Time) (i : nat) (p : reachableNet n) :
  ovWaitStateNet m t x y i n -> 0 < y ->
  exists l q,
  sent [baseMode m, basePosition l] (minusTime (period m) y q) i n p.
  (*Induction on p.*)
  introz U. genDep2 x y. induction p; intros y U0 x U.
  (*
  (*The base case fails because we know all entities are dormant to begin with.*)
  initNet_contra U.
  (*The discrete inductive case has three major cases, which we get by applying a back
  tracking result for ovWait*)
  lets OWP : ovWait_prev_net_strong U s. or_flat.
  (*In the first case, our previous state was ovWait, in which case the I.H. and the
  discrete sent constructor will do.*)
  apply IHp in OR. ex_flat. exists x0 x1. constructor. assumption. assumption.
  (*In the ovReady case, we further have that y = period m, and the action linking
  the states is a tau consisting of output of outProc of m l*)
  ex_flat. lets ORWT : ovReady_wait_track_net H0 U s. and_flat.
  ex_flat. subst.
  (*Now we have the sent base case, because period m - period m = 0.*)
  exists x1 (Rle_refl (period m)).
  state_pred_elim H0 U. state_pred_elim H H2. subst.
  link_netentdisc_tac b. inversion H. subst. state_pred_elim H7 H5.
  subst. state_pred_elim H6 H9.
  lets OOTE : ovReady_ovWait_track_ent H H2 H9. and_flat. subst.
  ent_disc_pres_pos_tac. subst.
  assert (p0 <> p1) as PNE. unfold not. intro. subst.
  state_pred_elim H H2. subst. state_pred_elim H7 H8.
  subst. state_pred_elim H6 H11. lets TAU : procNeq_tau_net H1 H3 s PNE.
  subst. lets SB : sentBase p s H1 H3 AND0. apply SB in AND2.
  my_applys_eq AND2. apply timeEqR. simpl. ring.
  (*The case where the previous state was init fails, because we
  get y = 0, contradicting the positivity of y from the hypothesis.*)
  lets IOT : init_ovWait_track_net OR1 U s. and_flat.
  subst. false. eapply Rle_not_lt;[ | apply U0].
  apply Rle_refl.
  (*The delay inductive case follows by delay preservation,
  an application of I.H. and then the delay constructor for sent.*)
  lets OPB : ovWait_del_pres_bkwd_net_strong s U. apply IHp in OPB.
  ex_flat.
  assert (y <= period m) as YLE. eapply Rle_trans;[ | apply x1].
  simpl. Rplus_le_tac. apply Rlt_le. delPos. exists x0 YLE.
  match goal with [U : sent ?v ?t ?i ?n p |-
  sent ?v ?t' ?i ?n' (reachNetDel ?n ?n' ?d _ _)] =>
  replace t' with (delToTime (t +dt+ d)) end.
  constructor. assumption. apply timeEqR. simpl. ring.
  eapply Rlt_trans. apply U0. simpl. Rplus_lt_tac. delPos.
  Qed.*)
  Admitted. (*R*)

(* Let's say an entity has been awaiting transition to the mode m since t time units ago.
Then for any t' < t, we can assert that a message was sent containing the mode in
question m and some position l0 within the window t' and t' + period m. We also know
that the message was sent at most t units ago.*)
Theorem nextSince_periodic_sent (n : Network) (m : Mode) (t t' : Time)
  (i : nat) (p : reachableNet n) :
  nextSince m t i n p -> t' < t ->
  exists t'' l,
  t' < (time t'') <= t' + period m /\ t'' <= t /\
  sent [baseMode m, basePosition l] t'' i n p.
  (*The proof should resemble that of currSince_periodic_sent. Here's an illustrative
  intuitive diagram for it:
  nextSince-------------t------------
    [  period m )--------t'----------
        sent------------t''----------*)
  intros. gen t'.
  (*Induction on nextSince.*)
  induction H; intros.
  (*The base case with t = 0 fails becasue then we'd have t' < 0, which contradicts
  the non negativity of time.*)
  contradict H2. apply Rle_not_lt. simpl. timeNonneg.
  (*The discrete inductive case follows by simple application of the inductive hypothesis
  and then the discrete sent constructor.*)
  lets IH : IHnextSince H1. clear IHnextSince. decompEx2 IH t'' l W.
  andflat Y. exists t'' l. splits; try assumption. split; assumption.
  constructor. assumption.
  (*Leaving us with just the timed inductive case to solve. Here we apply
  (Misc::nextSince_rel_state) to get the possible states for nextSince.*)
  lets NR : nextSince_rel_state H.
  (*We show by (...EA::urgency...) that the only such state capable of delay is ovWait.*)
  lets ND : nextSince_del_ovWait w NR. decompEx4 ND m0 t0 x y OS. assert (m0 = m) as ME.
  eapply nextSince_ovWait_modes_eq. apply OS. apply H.
  (*We then proceed analogously to currSince_periodic_sent, case analysing on d <= t' or
  t' < d etc. only we use (ovWait_sent) in the place of (bcWait_sent).*)
  lets RO : Rle_or_lt d t'. elim_intro RO DT TD.
  (*In the former case, we can show then that t' = t'' + d for some t''.*)
  assert (exists t'', nonneg t' = (time t'') + d) as TX. apply RlePlusExistsR in DT.
  invertClearAs2 DT dt TE. decompAnd2 TE TP TL. rewrite Rplus_comm in TP.
  exists (mkTime (mknonnegreal dt TL)). apply TP. invertClearAs2 TX t'' TE.
  (*Now, we also know t' < t + d, so t'' < t*)
  assert (t'' < t) as TL. rewrite TE in H0. simpl in H0. Rplus_lt_tac.
  (*So we can apply the I.H. for t'' and the previous state*)
  apply IHnextSince in TL. clear IHnextSince. decompEx2 TL u l TA.
  andflat T.
  (*So our existential becomes u + d*)
  exists (u +dt+ d) l.
  (*Now we need to show inequality the sub-cases of our goal by a bit of algebraic manipulation*)
  splits. rewrite TE. simpl.
  split. Rplus_lt_tac. Rplus3_swap_2_3 t'' d (period m). Rplus_le_tac. simpl. Rplus_le_tac.
  (*Then apply the sent delay constructor and we're done.*)
  constructor. assumption.
  (*Now all that remains is the delay case where t' < d. Well we already know that the previous state
  was ovWait m0 t0 (x + d) (y + d). So by (ovWait_sent) we get
  sent <m, l> (period m - (x + d)) for the previous case*)
  assert (zeroTime < (delToTime (y +dt+ d))) as YD. simpl. replace 0 with (0 + 0).
  apply Rplus_le_lt_compat. timeNonneg. delPos. ring.
  lets SX : ovWait_sent p OS YD. decompEx2 SX l q SE.
  (*So for the current case our existential is period m - y*)
  assert (y <= period m0) as YL. simpl in q. eapply Rplus_le_weaken_lr.
  apply q. apply Rlt_le. delPos.
  exists (minusTime (period m0) y YL) l. simpl in q, YD. simpl. splits.
  (*And now we clean up the inequalitites.*)
  split. simpl. eapply Rlt_le_trans. apply TD. Rplus_le_tac.
  simpl. rewrite Rplus_comm. rewrite ME.
  Rminus_plus_zero (period m) y. Rplus_le_tac. apply Rplus_le_swap_rr.
  replace 0 with (0 + 0). apply Rplus_le_compat; timeNonneg. ring.
  rewrite <- ME in H. lets ON : ovWait_nextSince_time OS H. simpl in ON.
  apply Rminus_le_swap_lr. my_applys_eq ON. ring. generalize dependent YL.
  rewrite <- ME. intro YL. lets SD : sentDel p w SE. my_applys_eq SD.
  timering. Qed.

(*If we're in the tfsBc state, then we're not currSince.*)
Theorem tfsBc_not_currSince (n : Network) (m : Mode) (t  : Time)
  (i : nat) (p : reachableNet n) :
  tfsBcStateNet i n -> currSince m t i n p -> False. Admitted. (*1*)
(**Proof: Induction on currSince. The base case fails because tfsBcState is not switchListen.
The delay case is easy because by (...backwards del pres state...) the previous state is
tfsBc also, and we just apply the I.H. to get false. The discrete case proceeds by
(...backtracking...) on tfsBcState to get that the previous state was either tfsBc state or
tfsCurr. In the former case, applying the I.H. will do. In the latter, we can show that the
current mode is no longer m. We do this by showing that the mode was m in the previous
state (currSince-curr) and then showing that the mode transition relation is anti-reflexive
& by (...tracking...) we know the action linking the states is a synch on mCurr, so the new
mode must be different to m, which contradicts the currSince discrete constructor that
required the currMode to be m.*)

(*Relates the currSince relation to the state of the broadcast software
component. In particular, if we're currSince, then the broadcast component is either
waiting to broadcast or ready to broadcast.*)
Theorem currSince_bc_state (n : Network) (m : Mode) (t : Time)
  (i : nat) (p : reachableNet n) : currSince m t i n p ->
  (exists x, bcWaitStateNet m x i n) \/
  (exists l, bcReadyStateNet m l i n). Admitted. (*1*)
(**Proof: Induction on currSince. In the base case, we have that the overlap component has
gone from switchCurr to switchListen, in which case the broadcast component can be shown to
have stayed the same (...). But in a separate result (...EA::inter_component...) we can
show that switchCurrState m implies bcWaitState m, and since the broadcast component has
not changed across the transition, we have our left disjunct to satisfy our goal. Now,
for the inductive cases, we can apply the I.H. and then do a case analysis on the previous
state.
For the bcReady state, we can show (...fwd_track...) that it is either preserved or
transitions to bcWait by a discrete transition, giving us our goal. We can also show that
is urgent, allowing us to proceed with a contradiction in the delay inductive case.
For the bcWait state, it is easy to show (...delay_pres_state...) that the delay transition
preserves this state. For the discrete transition case, we assume that our goal does not
hold towards a contradiction. Well then the broadcast component must be in the sleeping
state. Then we can show (...tracking...) that the action linking the states must be a tau,
with the broadcast component contributing an input on trans. Now, it can be shown
(...activation...) that the only state willing to output on trans is tfsBc. But we can show
elsewhere (tfsBc_not_currSince) that tfsBc implies that we are not currSince, which
contradicts the hypothesis.*)

(** If we're currSince & we can delay, then we're in the bcWait state.*)
Corollary currSince_del_bcWait (n n' : Network) (m : Mode) (t : Time)
  (i : nat) (d : Delay) (p : reachableNet n) :
  n -ND- d -ND> n' -> currSince m t i n p ->
  exists x, bcWaitStateNet m (delToTime (x +dt+ d)) i n. Admitted. (*2*)
(**Proof: Apply currSince_bc_state and then eliminate bcReady as it is urgent*)

(* If we are in the wait state of the broadcast component with time x,
and we are currSince for time t, then x <= t.*)
Theorem bcWait_currSince_time (n : Network) (m : Mode) (x t: Time)
  (i : nat) (p : reachableNet n) :
  bcWaitStateNet m x i n -> currSince m t i n p -> period m - x <= t.
  Admitted. (*2*)
(**Proof: Induction on currSince.
Base case: x = period m, so <= t is trivial.
Discrete inductive: x and t preserved so I.H. carries forth.
Delay inductive: x decreases, t increases, so I.H. is more than enough.
*)

(* If we are in the wait state of the broadcast component, and the clock value is non-zero,
then a message containing the mode in question and some position was sent exactly
(period m - x) time units ago.*)
Theorem bcWait_sent (n : Network) (m : Mode) (x : Time)
  (i : nat) (p : reachableNet n) :
  bcWaitStateNet m x i n -> zeroTime < x ->
  exists l q,
  sent [baseMode m, basePosition l] (minusTime (period m) x q) i n p.
  intros. gen x.
  (*Induction on p.*)
  induction p; intros.
  (*The base case fails because we know all entities are sleeping to begin with.*)
  false. eapply initial_not_bcWait_net. apply i0. apply H.
  (*The discrete inductive case follows from the theorem (bcWait_bktrk_net).*)
  assert (x <> zeroTime) as Q. unfold not. intro F. rewrite F in H0.
  contradiction (Rlt_irrefl zeroTime).
  lets BB : bcWait_bktrk_net p H s. decompOr3 BB W1 W2 W3.
  apply IHp in W1. decompEx2 W1 l q V. exists l q. constructor. assumption.
  assumption. andflat Y. contradiction Q. invertClearAs2 W3 l L.
  andflat Y. rewrite <- Y1. exists l (Rle_refl x). constructor. my_applys_eq Y2.
  timering.
  (*The delay inductive case follows by an application of I.H. and then the delay
  constructor for sent.*)
  lets BD : bcWaitNet_del_bkwd s H. assert (zeroTime < x +dt+ d) as ZL.
  apply Rplus_lt_weaken_rl. timeNonneg. simpl.
  delPos. lets IH : IHp BD ZL. decompEx2 IH l q SE. assert (x <= period m) as q0.
  simpl in q. eapply Rplus_le_weaken_lr. apply q. apply Rlt_le. delPos. exists l q0.
  eapply sentDel in SE. my_applys_eq SE. timering. Qed.

(* Let's say an entity has been broadcasting in the current mode m since t time units ago.
Then for any t' < t, we can assert that a message was sent containing the mode in
question m and some position l0 within the window t' and t' + period m. We also know
that the message was sent at most t units ago.*)
Theorem currSince_periodic_sent (n : Network) (m : Mode) (t t' : Time)
  (i : nat) (p : reachableNet n) :
  currSince m t i n p -> t' < t ->
  exists t'' l, t' < (time t'')  /\ t'' <= t' + period m /\ t'' <= t /\
  sent [baseMode m, basePosition l] t'' i n p.
  (*Let us start with a little attempt at a sketch of what is to be proven:

  currSince-------------t------------
    [  period m )--------t'----------
        sent------------t''----------

  Now we proceed by induction on currSince.*)
  intros. generalize dependent t'. induction H; intros.
  (*In the base case, we have that the previous state was nextSince. In which case we
  apply (nextSince_periodic_sent) and the discrete sent constructor and we're done.*)
  addHyp (nextSince_periodic_sent n m t t' i p H H2). decompose [ex] H3.
  rename x into t''. rename x0 into l. exists t''. exists l. decompose [and] H5.
  clear H5. repeat (split; try assumption). constructor. assumption.
  (*The discrete inductive case is easy: apply I.H. and then discrete constructor for sent.*)
  apply IHcurrSince in H1. decompose [ex] H1. clear H1. decompose [and] H3.
  clear H3. rename x into t''. rename x0 into l. exists t''. exists l.
  clear IHcurrSince. repeat (split; try assumption). constructor. assumption.
  (*Which leaves the delay Here we do a case analysis on d <= t' or t' < d.*)
  addHyp (Rle_or_lt d t'). invertClear H1.
  (*In the former case, we can show then that t' = t'' + d for some t''.*)
  assert (exists t'', nonneg t' = (time t'') + d). apply RlePlusExistsR in H2.
  invertClear H2. rename x into t''. invertClear H1. rewrite Rplus_comm in H2.
  exists (mkTime (mknonnegreal t'' H3)). apply H2. invertClear H1. rename x into t''.
  (*Now, we also know t' < t + d, so t'' < t*)
  assert (t'' < t). rewrite H3 in H0. simpl in H0. eapply Rplus_lt_reg_r in H0.
  assumption.
  (*So we can apply the I.H. for t'' and the previous state*)
  apply IHcurrSince in H1. clear IHcurrSince. decompose [ex] H1. clear H1.
  rename x into u. rename x0 into l. decompose [and] H5. clear H5.
  (*So our existential becomes u + d*)
  exists (u +dt+ d). exists l.
  (*Now we need to show inequality the sub-cases of our goal by a bit of algebraic manipulation*)
  split. rewrite H3. apply Rplus_lt_compat_r. assumption. split. rewrite Rplus_comm.
  rewrite H3. rewrite <- Rplus_assoc. apply Rplus_le_compat_r. rewrite Rplus_comm.
  assumption. split. apply Rplus_le_compat_r. assumption.
  (*Then apply the sent delay constructor and we're done.*)
  constructor. assumption.
  (*Now all that remains is the delay case where t' < d. Well we know that the previous state
  was bcWait m (x + d)*)
  addHyp (currSince_del_bcWait n n' m t i d p w H). invertClear H1.
  (*So by (bcWait_sent) we get sent <m, l> (period m - (x + d)) for the previous case*)
  assert (zeroTime < (delToTime (x +dt+ d))). simpl. replace 0 with (0 + 0).
  apply Rplus_le_lt_compat. timeNonneg. delPos. ring.
  addHyp (bcWait_sent n m (x +dt+ d) i p H3 H1). decompose [ex] H4. clear H4.
  rename x1 into Q. rename x0 into l.
  (*So for the current case our existential is period m - x*)
  assert (x <= period m). simpl in Q. eapply Rplus_le_weaken_lr. apply Q.
  apply Rlt_le. delPos. exists (minusTime (period m) x H4). exists l. split.
  (*Now since t' < d < period m - x, then t' < period m - x.*)
  eapply Rlt_le_trans. apply H2. simpl. simpl in Q. apply Rplus_le_swap_lr.
  rewrite Rplus_comm. assumption. split.
  (*But we also clearly have that period m - x <= t' + period m*)
  simpl. rewrite Rplus_comm.
  apply Rminus_le_weaken_lr. timeNonneg. apply Rplus_le_weaken_rr. timeNonneg.
  apply Rle_refl. split. simpl. addHyp (bcWait_currSince_time n m (x +dt+ d) t i p H3 H).
  simpl in H5. apply Rminus_le_swap_lr. eapply Rle_trans;[ |apply H5].
  apply Req_le. ring.
  (*So now by the delay constructor of sent, we get sent <m, l> (period m - x) for the current
  state:
  currSince-------------t------------|---------------d-------------|
                          [  period m )------------t'------------|
                             sent---(period m - x)---------------|
  and we're done.*)
  replace (minusTime (nonneg (time (period m))) (nonneg (time x)) H4)
  with (delToTime (minusTime (nonneg (time (period m)))
  (nonneg (time (delToTime (x +dt+ d)))) Q +dt+ d)).
  constructor. assumption. apply timeEqR. simpl. ring. Qed.

(*If an entity in position l is currSince m t, then it has delivered a message <m, l0>
to a sufficient radius r and this happened t - mL time units ago. Also, l0 differs from
l by at most Smax*t.*)
Theorem currSince_fst_deliv_suff (n : Network) (m : Mode) (t : Time)
  (i : nat) (l : Position) (p : reachableNet n) :
  currSince m t i n p -> inPosNet l i n ->
  exists q,
  let s := (Rplus_lt_weaken_lr msgLatency (Rmax adaptNotif transMax) t q
  maxAnTrans_positive) in
  let s' := Rlt_le msgLatency t s in
  exists r l0 l1,
  delivered ([-[baseMode m, basePosition l0], l1, r-]) (minusTime t msgLatency s') i n p /\
  sufficient m r /\ dist2d l l0 <= speedMax*t.
  (*Induction on currSince.*)
  intro. generalize dependent l. induction H; intros.
  (*In the base case, we have that the previous entity was nextSince m t and in
  switchCurrState. Then by (nextSince_switchCurr_lower) we would get
  that mL + max AN trans < t.*)
  addHyp (nextSince_switchCurr_lower n m i t p H H0).
  (*From this we easily obtain mL + AN < t.*)
  assert (msgLatency + adaptNotif < t). eapply Rle_lt_trans;[ |apply H3].
  apply Rplus_le_compat. apply Rle_refl. apply Rmax_l.
  (*Also, it is clear by the discrete nature of the transition in this case that the
  position is preserved.*)
  addHyp (inPos_pres_disc n n' a l i w). rewrite <- H5 in H2.
  (*Hence by (nextSince_fst_deliv_suff) we have delivered <m, l0> r (t - mL) i n p /\
  sufficient m r /\ |l - l0| <= Smax*t for some r and l0.*)
  addHyp (nextSince_fst_deliv_suff n t m i l p H H2 H3). cbv zeta in H6.
  decompose [ex] H6. clear H6. rename x into l0. rename x0 into l1. rename x1 into r.
  decompose [and] H7. clear H7. exists H3. exists r. exists l0. exists l1.
  repeat (split; try assumption).
  (*This closely resembles our goal, the only difference being the
  delivered <m, l0> r (t - mL) i n p instead of delivered <m, l0> r (t - mL) i n' p'.
  This last touch is shown by the application of the discrete delivered constructor, and
  we're done with this case.*)
  constructor. assumption.
  (*The discrete inductive case is almost identical to the base case: backwards preservation of
  position, apply I.H., apply discrete constructor on delivered.*)
  addHyp (inPos_pres_disc n n' a l i w). rewrite <- H2 in H1.
  apply IHcurrSince in H1. clear IHcurrSince. cbv zeta in H1.
  decompose [ex] H1. clear H1. rename x into q. rename x0 into r. rename x1 into l0.
  rename x2 into l1. decompose [and] H4. clear H4. exists q. exists r. exists l0. exists l1.
  repeat (split; try assumption). constructor. assumption.
  (*The delay case is a little more complicated. We apply the result (inPos_del_bound_bkwd)
  to show that the previous state was inPosNet l1 i n, for some l1 with |l - l1| <= Smax*d.*)
  addHyp (inPos_del_bound_bkwd n n' d l i H0 w). invertClear H1. rename x into l0.
  invertClear H2.
  (*Then we apply the inductive hypothesis and tidy up a bit.*)
  apply IHcurrSince in H1. clear IHcurrSince. cbv zeta in H1. decompose [ex] H1.
  clear H1. rename x0 into r. rename x1 into l1. rename x2 into l2.
  decompose [and] H4. clear H4.
  (*Now, we have mL + max AN trans < t, so clearly mL + max AN trans < t + d*)
  assert (msgLatency + Rmax adaptNotif transMax < t +dt+ d) as q. apply Rplus_lt_weaken_rr.
  apply Rlt_le. delPos. assumption.
  (*Now we can use this last assertion as our existential and carry on with the goal.*)
  exists q. exists r. exists l1. exists l2. split.
  (*The proof of delivered carries over by the delay delivered constructor.*)
  replace (minusTime (nonneg (time (delToTime (t +dt+ d)))) (nonneg (time msgLatency))
  (Rlt_le (nonneg (time msgLatency)) (nonneg (time (delToTime (t +dt+ d))))
  (Rplus_lt_weaken_lr (nonneg (time msgLatency))
  (Rmax (nonneg (time adaptNotif)) (nonneg (time transMax)))
  (nonneg (time (delToTime (t +dt+ d)))) q maxAnTrans_positive))) with
  (delToTime (minusTime (nonneg (time t)) (nonneg (time msgLatency))
  (Rlt_le (nonneg (time msgLatency)) (nonneg (time t))
  (Rplus_lt_weaken_lr (nonneg (time msgLatency))
  (Rmax (nonneg (time adaptNotif)) (nonneg (time transMax)))
  (nonneg (time t)) x maxAnTrans_positive)) +dt+ d)). constructor. assumption. apply timeEqR. simpl. ring.
  (*The sufficiency of the message is preserved.*)
  split. assumption.
  (*The bound on the distance then is shown by the triangle inequality. Elaborating on this last
  point, we want to show |l - l0| <= Smax*(t + d). We have both that |l - l1| <= Smax*d and
  |l1 - l0| <= Smax*t. The triangle inequality also gives us
  that |l - l0| <= |l - l1| + |l1 - l0|. So we get our result by adding the inequalities
  and transitivity.*)
  eapply Rle_trans. eapply dist_tri_ineq. simpl. rewrite Rmult_plus_distr_l.
  rewrite Rplus_comm. apply Rplus_le_compat. apply H6. rewrite distSymmetric in H3.
  apply H3. Qed.

(*If an entity in position l is currSince m t, then it has delivered a message <m, l0> to a
sufficient radius r and this happened t' time units ago, with t' < t in the pre delivery
interval of m and the distance between the sent position and the current position being no
more than Smax*(mL + t').*)
Theorem pre_del_suff (n : Network) (m : Mode) (t : Time)
  (i : nat) (l : Position) (p : reachableNet n) :
  currSince m t i n p -> inPosNet l i n -> ~failSafe m ->
  exists t' r l0 l1,
  delivered ([-[baseMode m, basePosition l0], l1, r-]) t' i n p /\
  sufficient m r /\ t' [:] (preDeliveredInterval m) /\ t' < t /\
  dist2d l l0 <= speedMax*(msgLatency+ t'). intros.
  match goal with [ H : ~failSafe m |- _ ] => rename H into Q end.
  (*Let us first recall the definition of
  Ipd = (max AN trans, max AN trans + period m + trans m]).*)
  remember (preDeliveredInterval m) as h. unfold preDeliveredInterval in Heqh.
  (*Let u = mL + max AN trans + period m + trans m. Then we can do a case analysis on
  t <= u or u < t.*)
  remember (msgLatency + Rmax adaptNotif transMax + period m + trans m) as u.
  addHyp (Rle_or_le t u). invertClear H1.
  (*Case t <= u: Well, we can show by (currSince_fst_deliv_suff) that there is a sufficient
  message delivered at t' = t - mL and some position l0 is sent in that message such
  that |l - l0| <= Smax*(mL + t').*)
  addHyp (currSince_fst_deliv_suff n m t i l p H H0). simpl in H1. decompose [ex] H1.
  clear H1. decompose [and] H4. clear H4. rename x0 into r. rename x1 into l0.
  rename x2 into l1. remember (minusTime t msgLatency (Rlt_le msgLatency t
  (Rplus_lt_weaken_lr msgLatency (Rmax adaptNotif transMax) t x maxAnTrans_positive)))
  as t'.
  foldDist l l0 H6. assert (nonneg t = t' + msgLatency). rewrite Heqt'. simpl. ring.
  rewrite H3 in H6. rewrite Rplus_comm in H6.
  (*By the positivity of mL, it is easy to show t' < t.*)
  assert (t' < t). rewrite H3. apply Rlt_plus_r.
  apply msgLatency_positive.
  (*So now we can apply t', r, l0, and l1 as our existential witnesses and it just
  remains to show that t' : Ipd m.*)
  exists t' r l0 l1. split. assumption. split. assumption. split;[ |split;assumption].
  rewrite Heqh. replace (nonneg (time t')) with (nonneg (time t') +
  nonneg (time msgLatency) - nonneg (time msgLatency));[ | ring]. split.
  (*Well, since by (currSince_lower_bound) we have that mL + max AN trans < t,
  then max AN trans < t - mL = t', which is our lower bound done.*)
  addHyp (currSince_lower_bound n t m i p H). apply Rplus_lt_swap_ll in H7.
  rewrite H3 in H7. simpl. assumption.
  (*Also, since t <= u = mL + max AN trans + period m + trans m, then
  t - mL <= max AN trans + period m + trans m,which is our upper bound done.
  Case closed.*)
  simpl. rewrite Hequ in H2. rewrite Rplus_assoc in H2. rewrite Rplus_assoc in H2.
  apply Rplus_le_swap_rl in H2. rewrite H3 in H2. rewrite Rplus_assoc. assumption.
  (*Case u < t. Well we can easily show mL + max AN trans + trans m < t.
  We show this by transitivity via u*)
  assert (nonneg (time msgLatency) +
  Rmax (nonneg (time adaptNotif)) (nonneg (time transMax)) + nonneg (time (trans m)) < t).
  eapply Rlt_le_trans;[ |apply H2]. rewrite Hequ. apply Rplus_lt_compat_r.
  rewrite Rplus_assoc. repeat (apply Rplus_lt_compat_l). apply Rlt_plus_r.
  apply period_positive.
  (*so by (currSince_periodic_sent) we have that there was a sent message <m, l0> at a time
  t' within the window (mL + max AN trans + trans m, mL + max AN trans + period m + trans m]
  and t' <= t ($).*)
  remember (msgLatency +t+ (timeMax adaptNotif transMax) +t+ trans m) as w.
  assert (nonneg (time msgLatency) + Rmax (nonneg (time adaptNotif))
  (nonneg (time transMax)) + nonneg (time (trans m)) =
  nonneg ((msgLatency +t+ timeMax adaptNotif transMax) +t+ trans m)). simpl.
  ring. rewrite H3 in H1. rewrite <- Heqw in H1.
  addHyp (currSince_periodic_sent n m t w i p H H1). decompose [ex] H4.
  clear H4. decompose [and] H6. clear H6. rename x0 into l0. rename x into t'.
  assert (t' <= u). rewrite Hequ. eapply Rle_trans. apply H7. rewrite Heqw.
  rewrite <- H3. rewrite Rplus_assoc. rewrite Rplus_comm. rewrite Rplus_assoc.
  rewrite Rplus_comm. apply Rplus_le_compat_r. rewrite Rplus_comm. apply Rle_refl.
  rewrite Hequ in H6.
  (*By (sent-pos_bound) we can establish that |l - l0| <= Smax*t' (@).*)
  addHyp (sent_pos_bound n m t' i l l0 p H9 H0).
  (*Then by (sent_delivered) we know that this message was delivered to some radius r
  at time t'' = t' - mL ($$)*)
  assert (msgLatency < t'). eapply Rle_lt_trans;[ |apply H4]. rewrite Heqw.
  rewrite <- H3. rewrite Rplus_assoc. apply Rle_plus_r. apply Rle_zero_plus.
  rewrite <- timeMax_RMax. timeNonneg.
  timeNonneg.
  addHyp (sent_delivered n [baseMode m, basePosition l0] t' i p H9 H10).
  decompose [ex] H11. clear H11. rename x0 into l1. rename x into r.
  remember (minusTime (nonneg (time t')) (nonneg (time msgLatency))
  (Rlt_le (nonneg (time msgLatency)) (nonneg (time t')) H10)) as t''.
  (*We can show that t'' is within the window
  (max AN trans + trans m, max AN trans + period m + trans m]) (@@)*)
  assert ((Rmax adaptNotif transMax) + trans m < t'').
  rewrite Heqt''. simpl. apply Rplus_lt_swap_ll. rewrite <- Rplus_assoc.
  rewrite H3. rewrite <- Heqw. assumption.
  assert (t'' <= (Rmax adaptNotif transMax) + period m + trans m).
  rewrite Heqt''. simpl. apply Rplus_le_swap_rl. repeat rewrite <- Rplus_assoc.
  assumption.
  (*It is clear then that t'' is also within the window Ipd m, since the window
  mentioned above is contained within Ipd m*)
  assert (t'' [:] preDeliveredInterval m). split;simpl.
  eapply Rle_lt_trans;[ | apply H11]. apply Rle_plus_r. timeNonneg.
  assumption.
  (*Now, since from ($) t' <= t, then t'' < t, by ($$) and the
  positivity of mL*)
  assert (t'' < t). rewrite Heqt''. simpl. eapply Rlt_le_trans;[ |apply H5].
  apply Rplus_lt_swap_rr. apply Rlt_plus_r. apply msgLatency_positive.
  (*Also, rearranging ($$) we get t' = mL + t''*)
  assert (nonneg t' = msgLatency + t''). rewrite Heqt''. simpl. ring.
  (*Substituting into our earlier result (@) we get |l - l0| <= Smax*(mL + t'').*)
  rewrite H16 in H8.
  (*Now let's apply t'', r, l0 and l1 as our existential witnesses and prune the goal.*)
  exists t'' r l0 l1. rewrite Heqh. repeat (split;try assumption).
  (*We have now shown every sub-goal except the sufficiency of the delivered message.
  It can be shown that the coverage r must be sufficient for the mode m by assuming
  otherwise and proving a contradiction.*)
  addHyp (suffDec m r). appDisj H17. assumption.
  (*Well, it is clear from (@@) that AN < t''*)
  assert (adaptNotif < t''). eapply Rle_lt_trans;[ |apply H11].
  apply Rplus_le_weaken_rr. timeNonneg. apply Rmax_l.
  (*We have already shown that t'' < t so by (NARInsuff::insuff_react), we get that
  we are tfs m (t'' - AN).*)
  addHyp (insuff_react n m l0 l1 r t t'' i p H H13 H17 H15 n0 Q).
  (*Now, by (tfs_bound), this would imply t'' - AN <= trans m.*)
  decompExAnd H18 x LT TF. lets TB : tfs_bound TF.
  assert (minusTime t'' adaptNotif (Rlt_le adaptNotif t'' H17) <= trans m) as C1.
  eapply Rle_trans. apply LT. assumption.
  (*However, we also have by (@@) that max AN trans + trans m < t'' and so
  AN + trans m < t''*)
  assert (adaptNotif + trans m < t''). eapply Rle_lt_trans;[ |apply H11].
  apply Rplus_le_compat_r. apply Rmax_l.
  (*and so trans m < t'' - AN.*)
  simpl in C1. apply Rplus_lt_swap_ll in H18.
  (*Hence we arrive at a contradiction, which is that t'' - AN < t'' - AN*)
  apply False_ind. apply (Rlt_irrefl (t'' - adaptNotif)). eapply Rle_lt_trans.
  apply C1. assumption. Qed.
  (*So we must accept that the broadcast range was sufficient. This concludes the proof of
  all our sub-goals.*)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

Set Implicit Arguments.

Require Import ZArith Ndigits.
Require Import BigNumPrelude.
Require Import DoubleType.

Local Open Scope Z_scope.

Local Infix "<<" := Pshiftl_nat (at level 30).

Section DoubleBase.
 Variable w : Type.
 Variable w_0   : w.
 Variable w_1   : w.
 Variable w_Bm1 : w.
 Variable w_WW  : w -> w -> zn2z w.
 Variable w_0W  : w -> zn2z w.
 Variable w_digits : positive.
 Variable w_zdigits: w.
 Variable w_add: w -> w -> zn2z w.
 Variable w_to_Z   : w -> Z.
 Variable w_compare : w -> w -> comparison.

 Definition ww_digits := xO w_digits.

 Definition ww_zdigits := w_add w_zdigits w_zdigits.

 Definition ww_to_Z := zn2z_to_Z (base w_digits) w_to_Z.

 Definition ww_1 := WW w_0 w_1.

 Definition ww_Bm1 := WW w_Bm1 w_Bm1.

 Definition ww_WW xh xl : zn2z (zn2z w) :=
  match xh, xl with
  | W0, W0 => W0
  | _, _ => WW xh xl
  end.

 Definition ww_W0 h : zn2z (zn2z w) :=
  match h with
  | W0 => W0
  | _ => WW h W0
  end.

 Definition ww_0W l : zn2z (zn2z w) :=
  match l with
  | W0 => W0
  | _ => WW W0 l
  end.

 Definition double_WW (n:nat) :=
  match n return word w n -> word w n -> word w (S n) with
  | O => w_WW
  | S n =>
    fun (h l : zn2z (word w n)) =>
     match h, l with
     | W0, W0 => W0
     | _, _ => WW h l
     end
  end.

 Definition double_wB n := base (w_digits << n).

 Fixpoint double_to_Z (n:nat) : word w n -> Z :=
  match n return word w n -> Z with
  | O => w_to_Z
  | S n => zn2z_to_Z (double_wB n) (double_to_Z n)
  end.

 Fixpoint extend_aux (n:nat) (x:zn2z w) {struct n}: word w (S n) :=
  match n return word w (S n) with
  | O => x
  | S n1 => WW W0 (extend_aux n1 x)
  end.

 Definition extend (n:nat) (x:w) : word w (S n) :=
  let r := w_0W x in
  match r with
  | W0 => W0
  | _ => extend_aux n r
  end.

 Definition double_0 n : word w n :=
   match n return word w n with
   | O => w_0
   | S _ => W0
   end.

 Definition double_split (n:nat) (x:zn2z (word w n)) :=
  match x with
  | W0 =>
    match n return word w n * word w n with
    | O => (w_0,w_0)
    | S _ => (W0, W0)
    end
  | WW h l => (h,l)
  end.

 Definition ww_compare x y :=
  match x, y with
  | W0, W0 => Eq
  | W0, WW yh yl =>
    match w_compare w_0 yh with
    | Eq => w_compare w_0 yl
    | _ => Lt
    end
  | WW xh xl, W0 =>
    match w_compare xh w_0 with
    | Eq => w_compare xl w_0
    | _ => Gt
    end
  | WW xh xl, WW yh yl =>
    match w_compare xh yh with
    | Eq => w_compare xl yl
    | Lt => Lt
    | Gt => Gt
    end
  end.

 (* Return the low part of the composed word*)
 Fixpoint get_low (n : nat) {struct n}:
  word w n -> w :=
  match n return (word w n -> w) with
  | 0%nat => fun x => x
  | S n1 =>
      fun x =>
      match x with
      | W0 => w_0
      | WW _ x1 => get_low n1 x1
      end
  end.

 Section DoubleProof.
  Notation wB  := (base w_digits).
  Notation wwB := (base ww_digits).
  Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
  Notation "[[ x ]]" := (ww_to_Z x)  (at level 0, x at level 99).
  Notation "[+[ c ]]" :=
   (interp_carry 1 wwB ww_to_Z c) (at level 0, x at level 99).
  Notation "[-[ c ]]" :=
   (interp_carry (-1) wwB ww_to_Z c) (at level 0, x at level 99).
  Notation "[! n | x !]" := (double_to_Z n x) (at level 0, x at level 99).

  Variable spec_w_0   : [|w_0|] = 0.
  Variable spec_w_1   : [|w_1|] = 1.
  Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1.
  Variable spec_w_WW  : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|].
  Variable spec_w_0W  : forall l, [[w_0W l]] = [|l|].
  Variable spec_to_Z  : forall x, 0 <= [|x|] < wB.
  Variable spec_w_compare : forall x y,
     w_compare x y = Zcompare [|x|] [|y|].

  Lemma wwB_wBwB : wwB = wB^2.
  Proof.
   unfold base, ww_digits;rewrite Zpower_2; rewrite (Zpos_xO w_digits).
   replace (2 * Zpos w_digits) with (Zpos w_digits + Zpos w_digits).
   apply Zpower_exp; unfold Zge;simpl;intros;discriminate.
   ring.
  Qed.

  Lemma spec_ww_1    : [[ww_1]] = 1.
  Proof. simpl;rewrite spec_w_0;rewrite spec_w_1;ring. Qed.

  Lemma spec_ww_Bm1  : [[ww_Bm1]] = wwB - 1.
  Proof. simpl;rewrite spec_w_Bm1;rewrite wwB_wBwB;ring. Qed.

  Lemma lt_0_wB : 0 < wB.
  Proof.
   unfold base;apply Zpower_gt_0. unfold Zlt;reflexivity.
   unfold Zle;intros H;discriminate H.
  Qed.

  Lemma lt_0_wwB : 0 < wwB.
  Proof. rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_lt_0_compat;apply lt_0_wB. Qed.

  Lemma wB_pos: 1 < wB.
  Proof.
   unfold base;apply Zlt_le_trans with (2^1).  unfold Zlt;reflexivity.
   apply Zpower_le_monotone.  unfold Zlt;reflexivity.
   split;unfold Zle;intros H. discriminate H.
   clear spec_w_0W w_0W spec_w_Bm1 spec_to_Z spec_w_WW w_WW.
   destruct w_digits; discriminate H.
  Qed.

  Lemma wwB_pos: 1 < wwB.
  Proof.
   assert (H:= wB_pos);rewrite wwB_wBwB;rewrite <-(Zmult_1_r 1).
   rewrite Zpower_2.
   apply Zmult_lt_compat2;(split;[unfold Zlt;reflexivity|trivial]).
   apply Zlt_le_weak;trivial.
  Qed.

  Theorem wB_div_2:  2 * (wB / 2) = wB.
  Proof.
   clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W
    spec_to_Z;unfold base.
   assert (2 ^ Zpos w_digits = 2 * (2 ^ (Zpos w_digits - 1))).
   pattern 2 at 2; rewrite <- Zpower_1_r.
   rewrite <- Zpower_exp; auto with zarith.
   f_equal; auto with zarith.
   case w_digits; compute; intros; discriminate.
   rewrite H; f_equal; auto with zarith.
   rewrite Zmult_comm; apply Z_div_mult; auto with zarith.
  Qed.

  Theorem wwB_div_2 : wwB / 2 = wB / 2 * wB.
  Proof.
   clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W
    spec_to_Z.
   rewrite wwB_wBwB; rewrite Zpower_2.
   pattern wB at 1; rewrite <- wB_div_2; auto.
   rewrite <- Zmult_assoc.
   repeat (rewrite (Zmult_comm 2); rewrite Z_div_mult); auto with zarith.
  Qed.

  Lemma mod_wwB : forall z x,
   (z*wB + [|x|]) mod wwB = (z mod wB)*wB + [|x|].
  Proof.
   intros z x.
   rewrite Zplus_mod.
   pattern wwB at 1;rewrite wwB_wBwB; rewrite Zpower_2.
   rewrite Zmult_mod_distr_r;try apply lt_0_wB.
   rewrite (Zmod_small [|x|]).
   apply Zmod_small;rewrite wwB_wBwB;apply beta_mult;try apply spec_to_Z.
   apply Z_mod_lt;apply Zlt_gt;apply lt_0_wB.
   destruct (spec_to_Z x);split;trivial.
   change [|x|] with (0*wB+[|x|]). rewrite wwB_wBwB.
   rewrite Zpower_2;rewrite <- (Zplus_0_r (wB*wB));apply beta_lex_inv.
   apply lt_0_wB. apply spec_to_Z. split;[apply Zle_refl | apply lt_0_wB].
 Qed.

  Lemma wB_div : forall x y, ([|x|] * wB + [|y|]) / wB = [|x|].
  Proof.
   clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1.
   intros x y;unfold base;rewrite Zdiv_shift_r;auto with zarith.
   rewrite Z_div_mult;auto with zarith.
   destruct (spec_to_Z x);trivial.
  Qed.

  Lemma wB_div_plus : forall x y p,
   0 <= p ->
   ([|x|]*wB + [|y|]) / 2^(Zpos w_digits + p) = [|x|] / 2^p.
  Proof.
   clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1.
   intros x y p Hp;rewrite Zpower_exp;auto with zarith.
   rewrite <- Zdiv_Zdiv;auto with zarith.
   rewrite wB_div;trivial.
  Qed.

  Lemma lt_wB_wwB : wB < wwB.
  Proof.
   clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1.
   unfold base;apply Zpower_lt_monotone;auto with zarith.
   assert (0 < Zpos w_digits). compute;reflexivity.
   unfold ww_digits;rewrite Zpos_xO;auto with zarith.
  Qed.

  Lemma w_to_Z_wwB : forall x, x < wB -> x < wwB.
  Proof.
   intros x H;apply Zlt_trans with wB;trivial;apply lt_wB_wwB.
  Qed.

  Lemma spec_ww_to_Z : forall x, 0 <= [[x]] < wwB.
  Proof.
   clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1.
   destruct x as [ |h l];simpl.
   split;[apply Zle_refl|apply lt_0_wwB].
   assert (H:=spec_to_Z h);assert (L:=spec_to_Z l);split.
   apply Zplus_le_0_compat;auto with zarith.
   rewrite <- (Zplus_0_r wwB);rewrite wwB_wBwB; rewrite Zpower_2;
    apply beta_lex_inv;auto with zarith.
  Qed.

  Lemma double_wB_wwB : forall n, double_wB n * double_wB n = double_wB (S n).
  Proof.
   intros n;unfold double_wB;simpl.
   unfold base. rewrite Pshiftl_nat_S, (Zpos_xO (_ << _)).
   replace  (2 * Zpos (w_digits << n)) with
     (Zpos (w_digits << n) + Zpos (w_digits << n)) by ring.
   symmetry; apply Zpower_exp;intro;discriminate.
  Qed.

  Lemma double_wB_pos:
   forall n, 0 <= double_wB n.
 Proof.
 intros n; unfold double_wB, base; auto with zarith.
 Qed.

  Lemma double_wB_more_digits:
  forall n, wB <= double_wB n.
  Proof.
  clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1.
  intros n; elim n; clear n; auto.
    unfold double_wB, "<<"; auto with zarith.
  intros n H1; rewrite <- double_wB_wwB.
  apply Zle_trans with (wB * 1).
    rewrite Zmult_1_r; apply Zle_refl.
  apply Zmult_le_compat; auto with zarith.
  apply Zle_trans with wB; auto with zarith.
  unfold base.
  rewrite <- (Zpower_0_r 2).
  apply Zpower_le_monotone2; auto with zarith.
  unfold base; auto with zarith.
  Qed.

  Lemma spec_double_to_Z :
   forall n (x:word w n), 0 <= [!n | x!] < double_wB n.
  Proof.
  clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1.
  induction n;intros. exact (spec_to_Z x).
  unfold double_to_Z;fold double_to_Z.
  destruct x;unfold zn2z_to_Z.
  unfold double_wB,base;split;auto with zarith.
  assert (U0:= IHn w0);assert (U1:= IHn w1).
  split;auto with zarith.
  apply Zlt_le_trans with ((double_wB n - 1) * double_wB n + double_wB n).
  assert (double_to_Z n w0*double_wB n <= (double_wB n - 1)*double_wB n).
  apply Zmult_le_compat_r;auto with zarith.
  auto with zarith.
  rewrite <- double_wB_wwB.
  replace ((double_wB n - 1) * double_wB n + double_wB n) with (double_wB n * double_wB n);
   [auto with zarith | ring].
  Qed.

  Lemma spec_get_low:
  forall n x,
     [!n | x!] < wB ->  [|get_low n x|] = [!n | x!].
  Proof.
  clear spec_w_1 spec_w_Bm1.
  intros n; elim n; auto; clear n.
  intros n Hrec x; case x; clear x; auto.
  intros xx yy H1; simpl in H1.
  assert (F1: [!n | xx!] = 0).
    case (Zle_lt_or_eq 0 ([!n | xx!])); auto.
      case (spec_double_to_Z n xx); auto.
     intros F2.
     assert (F3 := double_wB_more_digits n).
    assert (F4: 0 <= [!n | yy!]).
      case (spec_double_to_Z n yy); auto.
    assert (F5: 1 * wB <=  [!n | xx!] * double_wB n);
     auto with zarith.
    apply Zmult_le_compat; auto with zarith.
    unfold base; auto with zarith.
  simpl get_low; simpl double_to_Z.
  generalize H1; clear H1.
  rewrite F1; rewrite Zmult_0_l; rewrite Zplus_0_l.
  intros H1; apply Hrec; auto.
  Qed.

  Lemma spec_double_WW : forall n (h l : word w n),
    [!S n|double_WW n h l!] = [!n|h!] * double_wB n + [!n|l!].
  Proof.
   induction n;simpl;intros;trivial.
   destruct h;auto.
   destruct l;auto.
  Qed.

  Lemma spec_extend_aux : forall n x, [!S n|extend_aux n x!] = [[x]].
  Proof. induction n;simpl;trivial. Qed.

  Lemma spec_extend : forall n x, [!S n|extend n x!] = [|x|].
  Proof.
   intros n x;assert (H:= spec_w_0W x);unfold extend.
   destruct (w_0W x);simpl;trivial.
   rewrite <- H;exact (spec_extend_aux n (WW w0 w1)).
  Qed.

  Lemma spec_double_0 : forall n, [!n|double_0 n!] = 0.
  Proof. destruct n;trivial. Qed.

  Lemma spec_double_split : forall n x,
   let (h,l) := double_split n x in
   [!S n|x!] = [!n|h!] * double_wB n + [!n|l!].
  Proof.
   destruct x;simpl;auto.
   destruct n;simpl;trivial.
   rewrite spec_w_0;trivial.
  Qed.

  Lemma wB_lex_inv: forall a b c d,
      a < c ->
      a * wB + [|b|] < c  * wB + [|d|].
  Proof.
   intros a b c d H1; apply beta_lex_inv with (1 := H1); auto.
  Qed.

  Ltac comp2ord := match goal with
   | |- Lt = (?x ?= ?y) => symmetry; change (x < y)
   | |- Gt = (?x ?= ?y) => symmetry; change (x > y); apply Zlt_gt
  end.

  Lemma spec_ww_compare : forall x y,
    ww_compare x y = Zcompare [[x]] [[y]].
  Proof.
   destruct x as [ |xh xl];destruct y as [ |yh yl];simpl;trivial.
   (* 1st case *)
   rewrite 2 spec_w_compare, spec_w_0.
   destruct (Zcompare_spec 0 [|yh|]) as [H|H|H].
   rewrite <- H;simpl. reflexivity.
   symmetry. change (0 < [|yh|]*wB+[|yl|]).
   change 0 with (0*wB+0). rewrite <- spec_w_0 at 2.
   apply wB_lex_inv;trivial.
   absurd (0 <= [|yh|]). apply Zlt_not_le; trivial.
   destruct (spec_to_Z yh);trivial.
   (* 2nd case *)
   rewrite 2 spec_w_compare, spec_w_0.
   destruct (Zcompare_spec [|xh|] 0) as [H|H|H].
   rewrite H;simpl;reflexivity.
   absurd (0 <= [|xh|]). apply Zlt_not_le; trivial.
   destruct (spec_to_Z xh);trivial.
   comp2ord.
   change 0 with (0*wB+0). rewrite <- spec_w_0 at 2.
   apply wB_lex_inv;trivial.
   (* 3rd case *)
   rewrite 2 spec_w_compare.
   destruct (Zcompare_spec [|xh|] [|yh|]) as [H|H|H].
   rewrite H.
   symmetry. apply Zcompare_plus_compat.
   comp2ord. apply wB_lex_inv;trivial.
   comp2ord. apply wB_lex_inv;trivial.
  Qed.

 End DoubleProof.

End DoubleBase.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Sorting.Permutation.
Require Import Logic.lib.Coqlib.
Require Import Logic.lib.List_Func_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.MinimumLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.

Section IterSepconRules.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {empL: EmpLanguage L}
        {iter_sepcon_L: IterSepconLanguage L}
        {iter_wand_L: IterWandLanguage L}
        {iter_sepcon_Def: NormalIterSepcon L}
        {iter_wand_Def: NormalIterWand L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {ipAX: IntuitionisticPropositionalLogic L Gamma}
        {sepconAX: SepconAxiomatization L Gamma}
        {wandAX: WandAxiomatization L Gamma}
        {empAX: EmpAxiomatization L Gamma}.

Lemma sepcon_iter_sepcon:
  forall xs ys,
    |-- iter_sepcon xs * iter_sepcon ys <--> iter_sepcon (xs ++ ys).
Proof.
  intros.
  rewrite !iter_sepcon_def.
  apply (@assoc_prodp_fold_left_equiv _ _ _ _ _ _ _ _ sepcon_Mono sepcon_Assoc sepcon_LU sepcon_RU).
Qed.

Lemma sepcon_iter_unfold_right_assoc:
  forall xs,
    |-- iter_sepcon xs <-->
        (fix f xs :=
           match xs with
           | nil => emp
           | cons x nil => x
           | cons x xs0 => x * f xs0
           end) xs.
Proof.
  intros.
  rewrite iter_sepcon_def.
  pose proof @assoc_fold_left_fold_right_equiv _ _ _ _ _ _ sepcon emp sepcon_Mono sepcon_Assoc sepcon_LU sepcon_RU.
  rewrite H.
  pose proof @fold_right_prodp_unfold _ _ _ _ _ _ sepcon sepcon_Mono emp sepcon_RU.
  apply H0.
Qed.

Lemma sepcon_iter_unfold_left_assoc:
  forall xs,
    |-- iter_sepcon xs <-->
        match xs with
        | nil => emp
        | x :: xs0 => (fix f xs x :=
                         match xs with
                         | nil => x
                         | x0 :: xs0 => f xs0 (x * x0)
                         end) xs0 x
        end.
Proof.
  intros.
  rewrite iter_sepcon_def.
  pose proof @fold_left_prodp_unfold _ _ _ _ _ _ sepcon sepcon_Mono emp sepcon_LU.
  apply H.
Qed.

(* TODO: Should this really be an instance? *)
Instance proper_iter_sepcon_impp:
  Proper (Forall2 (fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) iter_sepcon.
Proof.
  intros.
  hnf; intros.
  rewrite !iter_sepcon_def.
  exact (proper_fold_left' sepcon _ _ H emp emp (provable_impp_refl _)).
Qed.

(* TODO: Should this really be an instance? *)
Instance proper_iter_sepcon_iffp:
  Proper (Forall2 (fun x y => |-- iffp x y) ==> (fun x y => |-- iffp x y)) iter_sepcon.
Proof.
  intros.
  hnf; intros.
  rewrite !iter_sepcon_def.
  exact (proper_fold_left' sepcon _ _ H emp emp (provable_iffp_refl _)).
Qed.

(* TODO: Should this really be an instance? *)
Instance proper_iter_sepcon_Permutation: Proper (@Permutation expr ==> (fun x y => |-- iffp x y)) iter_sepcon.
Proof.
  intros.
  hnf; intros.
  rewrite !iter_sepcon_def.
  apply (@assoc_fold_left_Permutation _ _ _ _ _ _ _ sepcon_Mono sepcon_Comm sepcon_Assoc); auto.
Qed.

End IterSepconRules.


(** * Tarski Semantics *)

(** ** Generalized Theory Extension **)

Require Export ND.

Section GenCons.
  Context {Sigma : Signature}.
  Context {HdF : eq_dec Funcs} {HdP : eq_dec Preds}.
  Context {HeF : enumT Funcs} {HeP : enumT Preds}.

  Context {b : bottom}.
  Variable GBot : form.
  Hypothesis GBot_closed : closed GBot.

  Notation "⊥" := GBot.
  Notation "A ⊢G phi" := (@prv Sigma class b A phi) (at level 30).
  Notation "T ⊩G phi" := (@tprv Sigma class b T phi) (at level 30).

  Definition econsistent T T' := T' ⊩G ⊥ -> T ⊩G ⊥.

  (** **** Union *)

  Section Union.
    Variable f : nat -> theory.
    Hypothesis econsistent_f : forall n, econsistent (f n) (f (S n)).
    Hypothesis f_le : forall m n, m <= n -> f m ⊑ f n.

    Definition union (f : nat -> theory) := fun t => exists n, f n t.

    Lemma union_f phi :
      union f ⊩G phi -> exists n, f n ⊩G phi.
    Proof.
      intros (A & HA1 & HA2). enough (exists n, A ⊏ f n) as [n H] by now exists n, A.
      clear HA2; induction A.
      - exists 0; firstorder.
      - destruct IHA as [n Hn]; destruct (HA1 a) as [m Hm]; firstorder.
        exists (max n m); intros ? []; subst.
        + eapply f_le; [apply Nat.le_max_r | firstorder].
        + eapply f_le; [apply Nat.le_max_l | firstorder].
    Qed.

    Lemma union_sub n :
      f n ⊑ union f.
    Proof.
      firstorder.
    Qed.

    Lemma union_econsistent :
      econsistent (f 0) (union f).
    Proof.
      intros [n H] % union_f. induction n; unfold econsistent in *; eauto.
    Qed.

    Lemma union_closed :
      (forall n, closed_T (f n)) -> closed_T (union f).
    Proof.
      intros f_closed ? n [m H]. now apply f_closed with (n := m) (phi := phi).
    Qed.
  End Union.

  (** **** Explosion *)

  Section Explosion.
    Variable T : theory.
    Hypothesis Hclosed : closed_T T.

    Variable e : nat -> form.
    Hypothesis He : forall phi, exists n, e n = phi.

    Definition exp_axiom phi := ⊥ --> close phi.

    Lemma exp_axiom_lift phi A :
      exp_axiom phi el A -> exp_axiom phi el (map (subst_form form_shift) A).
    Proof.
      intros H. apply in_map_iff. exists (exp_axiom phi). split. 2: assumption.
      apply subst_unused_closed' with (xi := form_shift) (phi0 := exp_axiom phi).
      intros ?. constructor. apply GBot_closed. apply close_closed.
    Qed.

    Fixpoint exp n :=
      match n with
      | 0 => T
      | S n => exp n ⋄ exp_axiom (e n)
      end.
    Definition Exp := union exp.

    Lemma Exp_sub :
      T ⊑ Exp.
    Proof.
      apply union_sub with (n := 0) (f := exp).
    Qed.

    Lemma Exp_econsistent :
      econsistent T Exp.
    Proof.
      apply union_econsistent.
      - intros n (B & HB & Hprv) % prv_T_impl. use_theory B.
        opeirce (close (e n)). oimport Hprv. oapply 0. ctx.
      - induction 1; intros ?; firstorder.
    Qed.

    Lemma Exp_closed :
      closed_T Exp.
    Proof.
      apply union_closed. induction n; intuition. intros ? ? []; intuition; subst.
      constructor; [apply GBot_closed | apply close_closed].
    Qed.

    Definition exploding T := forall phi, (⊥ --> close phi) ∈ T.

    Lemma Exp_exploding :
      exploding Exp.
    Proof.
      intros phi. destruct (He phi) as [n Hn]. exists (S n). right; now subst.
    Qed.

    Lemma exploding_inherit T1 T2 :
      exploding T1 -> T1 ⊑ T2 -> exploding T2.
    Proof.
      firstorder.
    Qed.

  End Explosion.

  (** **** Proving with explosion axioms *)

  Notation "¬ phi" := (phi --> GBot) (at level 20).
  Notation "∃ phi" := (¬ ∀ ¬ phi) (at level 56, right associativity).

  Ltac ointro_all :=
    match goal with
    | [ |- ?A ⊢ ∀ ?phi] => apply AllI; cbn; asimpl
    end.

  Ltac ointro_impl :=
    match goal with
    | [ |- _  ⊢ (_ --> _)] => apply II
    | [ |- _  ⊢ (¬ _)] => apply II
    end.

  Ltac ointro := ointro_impl + ointro_all + fail "Nothing to intro!".
  Ltac ointros := repeat ointro.

  Lemma GExp A phi :
    (exp_axiom phi) el A -> A ⊢G ⊥ -> A ⊢G phi.
  Proof.
    intros Hel Hbot. apply close_extract. exact (IE (Ctx Hel) Hbot).
  Qed.

  Ltac oexfalso := apply GExp; [intuition |].

  Lemma GDN A phi :
    (exp_axiom phi) el A -> A ⊢G ¬ (¬ phi) -> A ⊢G phi.
  Proof.
    intros Hx H.
    oimport (Pc A phi GBot). oimport H. oapply 1. ointros. oexfalso. oapply 1. ctx.
  Qed.

  Ltac oindirect := apply GDN; [intuition| apply II].
  Ltac clean H := unfold subst1; rewrite! (subst_unused_closed' _ H).
  Ltac clean_GBot := clean GBot_closed.

  Lemma GExE A phi psi :
    exp_axiom psi el A -> A ⊢G (∃ phi) -> (phi :: map (subst_form form_shift) A) ⊢G psi[↑] -> A ⊢G psi.
  Proof.
    intros Hx Hex Hinst.
    oindirect. oimport Hex. oapply 0. ointros. clean_GBot. oapply 2. ouse Hinst.
  Qed.

  Ltac odestruct n := eapply GExE; [intuition|ctx_index n|]; cbn; asimpl.

  Lemma GExI A t phi :
    A ⊢G phi [t .: ids] -> A ⊢G ∃ phi.
  Proof.
    intros Hc. apply II.
    ospecialize 0 t. clean_GBot. oapply 0. ouse Hc.
  Qed.

  Ltac oexists t :=
    eapply (@GExI _ t); cbn; asimpl.

  Lemma GXM A phi psi :
    exp_axiom psi el A -> (phi :: A) ⊢G psi -> (¬ phi :: A) ⊢G psi -> A ⊢G psi.
  Proof.
    intros Hx Ht Hf. oindirect.
    oassert (¬ phi). ointros. oapply 1. ouse Ht. oapply 1. ouse Hf.
  Qed.

  Ltac oxm form :=
    apply (@GXM _ form); [intuition| |].

  Definition DPexp1 phi := exp_axiom (∃ (phi --> (∀ phi)[↑])).
  Definition DPexp2 phi := exp_axiom (phi [(var_term O) .: (shift >> (shift >> var_term))]).
  Definition DPexp3 phi := exp_axiom phi.

  Lemma GDP A phi :
    DPexp1 phi el A -> DPexp2 phi el A -> DPexp3 phi el A -> A ⊢G ∃ (phi --> (∀ phi)[↑]).
  Proof.
    intros ? H1 H2. do 2 apply exp_axiom_lift in H1. do 1 apply exp_axiom_lift in H2. oxm (∃ (¬ phi)).
    - odestruct 0. clean_GBot. oexists (var_term 0). ointros. oexfalso. clean_GBot. oapply 1. ctx.
    - oexists (var_term 0). ointros. oindirect. clean_GBot. oapply 2. oexists (var_term 0). clean_GBot. ctx.
  Qed.

  (** **** Henkin *)

  Section Henkin.
    Variable T : theory.
    Hypothesis Hclosed : closed_T T.
    Hypothesis Hexp : exploding T.

    Variable e : nat -> form.
    Hypothesis He : forall phi, exists n, e n = phi.
    Hypothesis Hunused : forall n m, n <= m -> unused m (e n).

    Definition henkin_axiom phi := (phi --> ((∀ phi)[↑])).

    Lemma henkin_axiom_unused n phi :
      unused n (∀ phi) -> unused (S n) (¬ (henkin_axiom phi)).
    Proof.
      inversion 1. unfold henkin_axiom. constructor; [| apply GBot_closed].
      capply uf_Impl. capply unused_after_subst. subst. intros x.
      decide (x = n). 1: subst; now left. right; constructor; congruence.
    Qed.

    Fixpoint henkin n :=
      match n with
      | O => T
      | S n => henkin n ⋄ subst_form ((var_term n)..) (henkin_axiom (e n))
      end.

    Lemma henkin_unused n :
      forall phi m, phi ∈ (henkin n) -> n <= m -> unused m phi.
    Proof.
      induction n; cbn.
      - intros. now apply Hclosed.
      - intros phi [| m] H1 H2. omega.
        assert (unused (S m) (e n)) by (apply Hunused; omega).
        assert (unused (S (S m)) (e n)) by (apply Hunused; omega).
        assert (unused m (e n)) by (apply Hunused; omega).
        destruct H1. capply IHn. omega. subst. constructor.
        + apply unused_after_subst. intros []; comp. 1: right; constructor; omega.
          decide (S m = n0). 1: subst; now left. right; constructor; omega.
        + constructor. asimpl. assumption.
    Qed.

    Lemma henkin_le m n :
      m <= n -> henkin m ⊑ henkin n.
    Proof.
      induction 1; firstorder.
    Qed.

    Definition Henkin := union henkin.

    Lemma Henkin_consistent :
      econsistent T Henkin.
    Proof.
      refine (union_econsistent _ henkin_le). intros n.
      assert (unused n (e n)) by now apply Hunused.
      cbn; intros (A & HA1 & HA2) % prv_T_impl.
      rewrite <- (subst_unused_closed' ((var_term n)..) GBot_closed) in HA2.
      apply -> (@nameless_equiv Sigma class b A (¬ (henkin_axiom (e n))) n) in HA2.
      - use_theory (exp_axiom GBot :: DPexp1 (e n) :: DPexp2 (e n) :: DPexp3 (e n) :: A). shelve.
        oimport (@GDP (exp_axiom GBot :: DPexp1 (e n) :: DPexp2 (e n) :: DPexp3 (e n) :: A) (e n)).
        odestruct 0. oimport HA2. shelve. clean_GBot. oapply 0. ctx.
      - apply henkin_axiom_unused; constructor; apply Hunused; omega.
      - intros ? H' % HA1. eapply henkin_unused. apply H'. constructor.
      Unshelve.
        + intros ? [<- | [<- | [ <- | [<- |]]]]. 5: intuition.
          all: apply henkin_le with (m := 0); [omega | apply Hexp].
        + intros ? ?. now do 6 right.
    Qed.

    Definition is_Henkin T := forall T' phi, T ⊑ T' -> (forall t, T' ⊩G phi[t..]) -> T' ⊩G ∀ phi.

    Lemma Henkin_is_Henkin :
      is_Henkin Henkin.
    Proof.
      intros T' phi HT' Hall. destruct (He phi) as [n Hn]. destruct (Hall (var_term n)) as (A & HA1 & HA2).
      use_theory (subst_form ((var_term n)..) (henkin_axiom phi) :: A).
      - intros ? [<- |]; [| intuition]; subst. apply HT'. exists (S n). now right.
      - oimport HA2. comp. oapply 1. ctx.
    Qed.

    Lemma is_Henkin_inherit T1 T2 :
      is_Henkin T1 -> T1 ⊑ T2 -> is_Henkin T2.
    Proof.
      firstorder.
    Qed.

    Lemma Henkin_T :
      T ⊑ Henkin.
    Proof.
      apply union_sub with (f := henkin) (n := 0).
    Qed.
  End Henkin.

  (** **** Omega *)

  Section Omega.
    Variable e : nat -> form.
    Hypothesis He : forall phi, exists n, e n = phi.

    Variable T : theory.
    Hypothesis Hexp : exploding T.
    Hypothesis Hhenkin : is_Henkin T.

    Definition maximal T := forall f, econsistent T (T ⋄ f) -> f ∈ T.

    Definition econsistent_join T phi := fun psi => T psi \/ (econsistent T (T ⋄ phi) /\ psi = phi).
    Infix "∘" := econsistent_join (at level 20).

    Lemma econsistent_join_sub T' phi :
      (T' ∘ phi) ⊑ (T' ⋄ phi).
    Proof.
      firstorder.
    Qed.

    Lemma consistent_join_step T' phi psi :
      T' ∘ psi ⊩G phi -> T' ⊩G phi \/ econsistent T' (T' ⋄ psi).
    Proof.
      intros (A & HA1 & HA2).
      enough (A ⊏ T' \/ econsistent T' (T' ⋄ psi)) as [] by ((left; exists A; intuition) + now right).
      clear HA2; induction A.
      - firstorder.
      - destruct (HA1 a), IHA; intuition. all: eauto with contains_theory.
    Qed.

    Fixpoint omega n : theory :=
      match n with
      | 0 => T
      | S n => omega n ∘ e n
      end.

    Lemma omega_le n m :
      n <= m -> omega n ⊑ omega m.
    Proof.
      induction 1; firstorder.
    Qed.

    Definition Omega : theory := union omega.

    Lemma econsistent_Omega :
      econsistent T Omega.
    Proof.
      refine (union_econsistent _ omega_le). intros n H. destruct (consistent_join_step H).
      all: firstorder.
    Qed.

    Lemma econsistency_inheritance T1 T2 T1' T2' :
      econsistent T1 T1' -> T1 ⊑ T2 -> T2' ⊑ T1' -> econsistent T2 T2'.
    Proof.
      firstorder.
    Qed.

    Lemma econsistency_trans T1 T2 T3 :
      econsistent T1 T2 -> econsistent T2 T3 -> econsistent T1 T3.
    Proof.
      firstorder.
    Qed.

    Lemma maximal_Omega :
      maximal Omega.
    Proof.
      intros phi H. destruct (He phi) as [n Hn].
      apply (union_sub (n := S n)); cbn; rewrite -> Hn. right; split; [| reflexivity].
      eapply econsistency_inheritance.
      + exact (econsistency_trans econsistent_Omega H).
      + apply omega_le with (n := 0). omega.
      + firstorder.
    Qed.

    Lemma econsistent_prv T' T'' phi :
      econsistent T' T'' -> T'' ⊩G phi -> econsistent T' (T'' ⋄ phi).
    Proof.
      intros HT Hphi Hbot. now apply HT, (prv_T_remove Hphi).
    Qed.

    Lemma maximal_prv T' phi :
      maximal T' -> T' ⊩G phi -> phi ∈ T'.
    Proof.
      intros Hin Hprv. now apply Hin, econsistent_prv.
    Qed.

    Lemma Omega_prv phi :
      Omega ⊩G phi -> phi ∈ Omega.
    Proof.
      intros Hprv. now apply (maximal_prv maximal_Omega).
    Qed.

    Lemma Omega_T :
      T ⊑ Omega.
    Proof.
      change T with (omega 0). apply (union_sub (n := 0)).
    Qed.

    Lemma Omega_impl phi psi :
      phi --> psi ∈ Omega <-> (phi ∈ Omega -> psi ∈ Omega).
    Proof.
      split.
      - intros Himp Hphi. apply Omega_prv.
        use_theory [phi --> psi; phi]. oapply 0. ctx.
      - intros H. apply maximal_Omega. intros (A & HA1 & HA2) % prv_T_impl.
        apply (prv_T_remove (phi := psi)).
        + apply elem_prv, H, Omega_prv.
          use_theory (exp_axiom phi :: exp_axiom psi :: A).
          * intros ? [<- | [ <- | H'']]; [apply Omega_T, Hexp | apply Omega_T, Hexp | now apply HA1].
          * oindirect. oimport HA2. oapply 0. ointros. oexfalso. oapply 2. ctx.
        + use_theory (psi :: A). oimport HA2. oapply 0. ointros. ctx.
    Qed.

    Lemma Omega_all phi :
      ∀ phi ∈ Omega <-> (forall t, phi[t..] ∈ Omega).
    Proof.
      split; intros Hprv.
      - intros t. apply Omega_prv. use_theory [∀ phi]. ospecialize 0 t. ctx.
      - apply Omega_prv, (Hhenkin Omega_T). eauto using elem_prv.
    Qed.
  End Omega.
End GenCons.

(** **** Conclusion *)

Section Composition.
  Context {Sigma : Signature}.
  Context {HdF : eq_dec Funcs} {HdP : eq_dec Preds}.
  Context {HeF : enumT Funcs} {HeP : enumT Preds}.

  Structure ConstructionInputs : Type :=
    {
      NBot : form ;
      NBot_closed : closed NBot ;

      variant : bottom ;

      In_T : theory ;
      In_T_closed : closed_T In_T ;

      enum : nat -> form ;
      enum_enum : forall phi, exists n, enum n = phi ;
      enum_unused : forall n m, n <= m -> unused m (enum n)
    }.

  Structure ConstructionOutputs (In : ConstructionInputs) :=
    {
      Out_T : theory ;
      Out_T_econsistent : @econsistent Sigma (variant In) (NBot In) (In_T In) Out_T ;
      Out_T_sub : In_T In ⊑ Out_T ;

      Out_T_prv : forall phi, @tprv Sigma class (variant In) Out_T phi -> phi ∈ Out_T ;
      Out_T_all : forall phi, ∀ phi ∈ Out_T <-> (forall t, phi[t..] ∈ Out_T) ;
      Out_T_impl : forall phi psi, phi --> psi ∈ Out_T <-> (phi ∈ Out_T -> psi ∈ Out_T)
    }.

  Lemma construct_construction (In : ConstructionInputs) :
    ConstructionOutputs In.
  Proof.
    destruct In as [NBot NBot_closed system T T_closed e e_enum e_unused].
    eexists (Omega NBot e (Henkin (Exp NBot T e) e)); cbn.
    + capply econsistency_trans. capply econsistency_trans. capply Exp_econsistent.
      capply Henkin_consistent. capply Exp_closed. capply Exp_exploding. capply econsistent_Omega.
    + transitivity (Henkin (Exp NBot T e) e). transitivity (Exp NBot T e).
      apply Exp_sub. apply Henkin_T. apply Omega_T.
    + capply Omega_prv.
    + capply Omega_all. capply Henkin_is_Henkin.
    + capply Omega_impl. capply exploding_inherit.
      - capply Exp_exploding.
      - capply Henkin_T.
  Qed.
End Composition.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From fourcolor Require Import cfmap cfreducible configurations.

(******************************************************************************)
(* Reducibility of configurations number 235 to 238, whose indices in         *)
(* the_configs range over segment [234, 238).                                 *)
(******************************************************************************)

Lemma red234to238 : reducible_in_range 234 238 the_configs.
Proof. CheckReducible. Qed.


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This files extends the implementation of finite over [positive] to finite
maps whose keys range over Coq's data type of binary naturals [N]. *)
From prelude Require Import pmap mapset.
From prelude Require Export prelude fin_maps.

Local Open Scope N_scope.

Record Nmap (A : Type) : Type := NMap { Nmap_0 : option A; Nmap_pos : Pmap A }.
Arguments Nmap_0 {_} _.
Arguments Nmap_pos {_} _.
Arguments NMap {_} _ _.

Instance Nmap_eq_dec `{∀ x y : A, Decision (x = y)} (t1 t2 : Nmap A) :
  Decision (t1 = t2).
Proof.
 refine
  match t1, t2 with
  | NMap x t1, NMap y t2 => cast_if_and (decide (x = y)) (decide (t1 = t2))
  end; abstract congruence.
Defined.
Instance Nempty {A} : Empty (Nmap A) := NMap None ∅.
Global Opaque Nempty.
Instance Nlookup {A} : Lookup N A (Nmap A) := λ i t,
  match i with
  | N0 => Nmap_0 t
  | Npos p => Nmap_pos t !! p
  end.
Instance Npartial_alter {A} : PartialAlter N A (Nmap A) := λ f i t,
  match i, t with
  | N0, NMap o t => NMap (f o) t
  | Npos p, NMap o t => NMap o (partial_alter f p t)
  end.
Instance Nto_list {A} : FinMapToList N A (Nmap A) := λ t,
  match t with
  | NMap o t =>
     default [] o (λ x, [(0,x)]) ++ (prod_map Npos id <$> map_to_list t)
  end.
Instance Nomap: OMap Nmap := λ A B f t,
  match t with NMap o t => NMap (o ≫= f) (omap f t) end.
Instance Nmerge: Merge Nmap := λ A B C f t1 t2,
  match t1, t2 with
  | NMap o1 t1, NMap o2 t2 => NMap (f o1 o2) (merge f t1 t2)
  end.
Instance Nfmap: FMap Nmap := λ A B f t,
  match t with NMap o t => NMap (f <$> o) (f <$> t) end.

Instance: FinMap N Nmap.
Proof.
  split.
  - intros ? [??] [??] H. f_equal; [apply (H 0)|].
    apply map_eq. intros i. apply (H (Npos i)).
  - by intros ? [|?].
  - intros ? f [? t] [|i]; simpl; [done |]. apply lookup_partial_alter.
  - intros ? f [? t] [|i] [|j]; simpl; try intuition congruence.
    intros. apply lookup_partial_alter_ne. congruence.
  - intros ??? [??] []; simpl. done. apply lookup_fmap.
  - intros ? [[x|] t]; unfold map_to_list; simpl.
    + constructor.
      * rewrite elem_of_list_fmap. by intros [[??] [??]].
      * by apply (NoDup_fmap _), NoDup_map_to_list.
    + apply (NoDup_fmap _), NoDup_map_to_list.
  - intros ? t i x. unfold map_to_list. split.
    + destruct t as [[y|] t]; simpl.
      * rewrite elem_of_cons, elem_of_list_fmap.
        intros [? | [[??] [??]]]; simplify_eq/=; [done |].
        by apply elem_of_map_to_list.
      * rewrite elem_of_list_fmap; intros [[??] [??]]; simplify_eq/=.
        by apply elem_of_map_to_list.
    + destruct t as [[y|] t]; simpl.
      * rewrite elem_of_cons, elem_of_list_fmap.
        destruct i as [|i]; simpl; [intuition congruence |].
        intros. right. exists (i, x). by rewrite elem_of_map_to_list.
      * rewrite elem_of_list_fmap.
        destruct i as [|i]; simpl; [done |].
        intros. exists (i, x). by rewrite elem_of_map_to_list.
  - intros ?? f [??] [|?]; simpl; [done|]; apply (lookup_omap f).
  - intros ??? f ? [??] [??] [|?]; simpl; [done|]; apply (lookup_merge f).
Qed.

(** * Finite sets *)
(** We construct sets of [N]s satisfying extensional equality. *)
Notation Nset := (mapset Nmap).
Instance Nmap_dom {A} : Dom (Nmap A) Nset := mapset_dom.
Instance: FinMapDom N Nmap Nset := mapset_dom_spec.

(** * Fresh numbers *)
Definition Nfresh {A} (m : Nmap A) : N :=
  match m with NMap None _ => 0 | NMap _ m => Npos (Pfresh m) end.
Lemma Nfresh_fresh {A} (m : Nmap A) : m !! Nfresh m = None.
Proof. destruct m as [[]]. apply Pfresh_fresh. done. Qed.

Instance Nset_fresh : Fresh N Nset := λ X,
  let (m) := X in Nfresh m.
Instance Nset_fresh_spec : FreshSpec N Nset.
Proof.
  split.
  - apply _.
  - intros X Y; rewrite <-elem_of_equiv_L. by intros ->.
  - unfold elem_of, mapset_elem_of, fresh; intros [m]; simpl.
    by rewrite Nfresh_fresh.
Qed.


Require Import FP.Data.Function.
Require Import FP.Data.Identity.
Require Import FP.Data.N.
Require Import FP.Data.NStructures.
Require Import FP.Data.Reader.
Require Import FP.Data.Option.
Require Import FP.Structures.Monad.
Require Import FP.Structures.Injection.
Require Import FP.Structures.MonadError.
Require Import FP.Structures.MonadFix.
Require Import FP.Structures.MonadPlus.
Require Import FP.Structures.MonadReader.
Require Import FP.Structures.Functor.
Require Import FP.Structures.MonadState.
Require Import FP.Structures.MonadDeriving.
Require Import FP.Structures.Foldable.
Require Import FP.Structures.Peano.
Require Import FP.Structures.MonadTrans.

Import FunctionNotation.

Inductive fuel_t m A := FuelT { un_fuel_t : reader_t N (option_t m) A }.
Arguments FuelT {m A} _.
Arguments un_fuel_t {m A} _.

Section MonadTrans.
  Definition fuel_t_lift {m} {M:Monad m} {A} : m A -> fuel_t m A :=
    FuelT '.' lift (m:=option_t m) '.' lift (m:=m).
End MonadTrans.

Section fuel_t_Monad.
  Context {m} {M:Monad m}.

  Definition mk_fuel_t {A} : (N -> m (option A)) -> fuel_t m A :=
    FuelT '.' ReaderT '.' compose OptionT.
  Definition run_fuel_t {A} (n:N) : fuel_t m A -> m (option A) :=
    run_option_t '.' run_reader_t n '.' un_fuel_t.
  Definition fun_fuel_t {A} : fuel_t m A -> N -> m (option A) :=
    flip run_fuel_t.

  Section MonadFix.
    Definition fuel_t_mfix {A B}
        (ff:(A -> fuel_t m B) -> A -> fuel_t m B) (a:A) : fuel_t m B :=
      mk_fuel_t $ fun n =>
        fold_mfix begin fun (f: N -> A -> m (option B)) (_n:N) (a:A) =>
           run_fuel_t n $ ff begin fun (a:A) =>
             mk_fuel_t $ fun (__n:N) => f _n a
           end a
        end n a.
    Global Instance fuel_t_MonadFix : MFix (fuel_t m) :=
      { mfix := @fuel_t_mfix }.
  End MonadFix.

  Global Instance fuel_t_reader_t_HasFunctorInjection
      : HasFunctorInjection (fuel_t m) (reader_t N (option_t m)) :=
    { finject := @un_fuel_t _ }.
  Global Instance reader_t_fuel_t_HasFunctorInjection
      : HasFunctorInjection (reader_t N (option_t m)) (fuel_t m) :=
    { finject := @FuelT _ }.

  Global Instance fuel_t_MBind
      : MBind (fuel_t m) :=
    Deriving_MBind (reader_t N (option_t m)).
  (*
  Global Instance fuel_t_MonadError {E} {ME:MonadError E m}
      : MonadError E (fuel_t m) :=
    iso_MonadError (reader_t N (option_t m)).
  Global Instance fuel_t_MonadState {S} {MS:MonadState S m}
      : MonadState S (fuel_t m) :=
    iso_MonadState (reader_t N (option_t m)).
  Global Instance fuel_t_MonadPlus {MP:MonadPlus m}
      : MonadPlus (fuel_t m) :=
    iso_MonadPlus (nMP:=reader_t_MonadPlus (MP:=option_t_MonadPlus_passthrough))
                  (reader_t N (option_t m)).
  Global Instance fuel_t_MonadReader {R} {MR:MonadReader R m}
      : MonadReader R (fuel_t m) :=
    iso_MonadReader (nMR:=reader_t_MonadReader_passthrough)
                    (reader_t N (option_t m)).
*)
End fuel_t_Monad.

Definition fuel := fuel_t identity.
Definition mk_fuel {A} : (N -> option A) -> fuel A :=
  mk_fuel_t '.' compose Identity.
Definition run_fuel {A} : N -> fuel A -> option A :=
  compose run_identity '.' run_fuel_t.


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

Require Import TreeAux.

Require Import Sumbool.
Require String.

Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.ssrbool.

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

Set Implicit Arguments.

Module Tree (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 ANT : AdjacentNameType NT)
 (Import TA : TAux NT NOT NSet NOTC NMap).

Inductive Msg : Set :=
| Fail : Msg
| Level : option lv -> Msg
| New : Msg.

Definition Msg_eq_dec : forall x y : Msg, {x = y} + {x <> y}.
decide equality.
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 : Set :=
| 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.
Defined.

Inductive Output : Set :=
| 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.
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 {
  adjacent : NS ;
  broadcast : bool ;
  levels : NL
}.

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

Inductive Label : Type :=
| Tau : Label
| RecvFail : name -> name -> Label
| RecvNew : name -> name -> Label
| RecvLevel : name -> name -> Label
| DeliverBroadcast : name -> Label
| DeliverLevelRequest : 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
| Level _ => ret (RecvLevel me src)
| Fail =>
  put {| adjacent := NSet.remove src st.(adjacent) ;
         broadcast := st.(broadcast) ;
         levels := st.(levels) |} ;;
  ret (RecvFail me src)
| New =>
  put {| adjacent := NSet.add src st.(adjacent) ;
         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
| Level None =>
  (if olv_eq_dec (level st.(adjacent) st.(levels)) (level st.(adjacent) (NMap.remove src st.(levels))) then
    put {| adjacent := st.(adjacent) ;
           broadcast := st.(broadcast) ;
           levels := NMap.remove src st.(levels) |}
  else
    put {| adjacent := st.(adjacent) ;
           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 {| adjacent := st.(adjacent) ;
           broadcast := st.(broadcast) ;
           levels := NMap.add src lv' st.(levels) |}
  else
    put {| adjacent := st.(adjacent) ;
           broadcast := true ;
           levels := NMap.add src lv' st.(levels) |}) ;;
  ret (RecvLevel me src)
| Fail =>
  (if olv_eq_dec (level st.(adjacent) st.(levels)) (level (NSet.remove src st.(adjacent)) (NMap.remove src st.(levels))) then
    put {| adjacent := NSet.remove src st.(adjacent) ;
           broadcast := st.(broadcast) ;
           levels := NMap.remove src st.(levels) |}
  else
    put {| adjacent := NSet.remove src st.(adjacent) ;
           broadcast := true ;
           levels := NMap.remove src st.(levels) |}) ;;
   ret (RecvFail me src)
| New =>
  put {| adjacent := NSet.add src st.(adjacent) ;
         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.

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

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
| 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
| Broadcast =>
  when st.(broadcast)
  (send_level_adjacent (level st.(adjacent) st.(levels)) st.(adjacent) ;;
  put {| adjacent := st.(adjacent);
         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 Tree_BaseParams : BaseParams :=
  {
    data := Data;
    input := Input;
    output := Output
  }.

Instance Tree_LabeledMultiParams : LabeledMultiParams Tree_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 Tree_MultiParams : MultiParams Tree_BaseParams := unlabeled_multi_params.

Instance Tree_NameOverlayParams : NameOverlayParams Tree_MultiParams :=
  {
    adjacent_to := adjacent_to ;
    adjacent_to_dec := adjacent_to_dec ;
    adjacent_to_symmetric := adjacent_to_symmetric ;
    adjacent_to_irreflexive := adjacent_to_irreflexive
  }.

Instance Tree_FailMsgParams : FailMsgParams Tree_MultiParams :=
  {
    msg_fail := Fail
  }.

Instance Tree_NewMsgParams : NewMsgParams Tree_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.
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) ->
    (root dst /\ msg = Fail /\ lb = RecvFail dst src /\
     st'.(adjacent) = NSet.remove src st.(adjacent) /\
     st'.(broadcast) = st.(broadcast) /\
     st'.(levels) = st.(levels) /\
     out = [] /\ ms = []) \/
    (~ root dst /\ msg = Fail /\ lb = RecvFail dst src /\
     level st.(adjacent) st.(levels) = level (NSet.remove src st.(adjacent)) (NMap.remove src st.(levels)) /\
     st'.(adjacent) = NSet.remove src st.(adjacent) /\
     st'.(broadcast) = st.(broadcast) /\
     st'.(levels) = NMap.remove src st.(levels) /\
     out = [] /\ ms = []) \/
    (~ root dst /\ msg = Fail /\ lb = RecvFail dst src /\
     level st.(adjacent) st.(levels) <> level (NSet.remove src st.(adjacent)) (NMap.remove src st.(levels)) /\
     st'.(adjacent) = NSet.remove src st.(adjacent) /\
     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) /\
     level st.(adjacent) st.(levels) = level st.(adjacent) (NMap.add src lv_msg st.(levels)) /\
     st'.(adjacent) = st.(adjacent) /\
     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) /\
     level st.(adjacent) st.(levels) <> level st.(adjacent) (NMap.add src lv_msg st.(levels)) /\
     st'.(adjacent) = st.(adjacent) /\
     st'.(broadcast) = true /\
     st'.(levels) = NMap.add src lv_msg st.(levels) /\
     out = [] /\ ms = []) \/
    (~ root dst /\ msg = Level None /\
     level st.(adjacent) st.(levels) = level st.(adjacent) (NMap.remove src st.(levels)) /\
     st'.(adjacent) = st.(adjacent) /\
     st'.(broadcast) = st.(broadcast) /\
     st'.(levels) = NMap.remove src st.(levels) /\
     out = [] /\ ms = []) \/
    (~ root dst /\ msg = Level None /\
     level st.(adjacent) st.(levels) <> level st.(adjacent) (NMap.remove src st.(levels)) /\
     st'.(adjacent) = st.(adjacent) /\
     st'.(broadcast) = true /\
     st'.(levels) = NMap.remove src st.(levels) /\
     out = [] /\ ms = []) \/
    (root dst /\ msg = New /\
     st'.(adjacent) = NSet.add src st.(adjacent) /\
     st'.(broadcast) = st.(broadcast) /\
     st'.(levels) = st.(levels) /\
     out = [] /\ ms = [(src, Level (Some 0))]) \/
    (~ root dst /\ msg = New /\ level st.(adjacent) st.(levels) = None /\
     st'.(adjacent) = NSet.add src st.(adjacent) /\
     st'.(broadcast) = st.(broadcast) /\
     st'.(levels) = st.(levels) /\
     out = [] /\ ms = []) \/
    (~ root dst /\ msg = New /\ exists lv, level st.(adjacent) st.(levels) = Some lv /\
     st'.(adjacent) = NSet.add src st.(adjacent) /\
     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 => [|olv|]; monad_unfold; case root_dec => /= H_dec H_eq; repeat break_let; repeat break_match; repeat break_if; repeat find_injection.
- by left.
- right; left.
  move: Heqb.
  by case olv_eq_dec.
- right; right; left.
  move: Heqb.
  by case olv_eq_dec.
- right; right; right; left.
  split => //.
  by exists olv.
- right; right; right; right; left.
  split => //.
  exists l2.
  move: Heqb.
  by case olv_eq_dec.
- right; right; right; right; right; left.
  split => //.
  exists l2.
  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.
- by 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.
  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; 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_net_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.

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 /= /Basics.flip /=.
rewrite (@fold_left_level_fold_eq Tree_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) ->
      (root h /\ i = Broadcast /\ lb = DeliverBroadcast h /\
       st' = st /\
       out = [] /\ ms = []) \/
      (~ root h /\ i = Broadcast /\ lb = DeliverBroadcast h /\
       st.(broadcast) = true /\
       st'.(adjacent) = st.(adjacent) /\
       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 => [client_id|]; monad_unfold; case root_dec => /= H_dec H_eq; repeat break_let; repeat break_match; repeat break_if; repeat find_injection.
- right; right; right; left.
  split => //.
  by exists client_id.
- right; right; right; right.
  split => //.
  by exists client_id.
- by left.
- find_rewrite_lem send_level_adjacent_eq.
  find_injection.
  right; left.
  simpl.
  by rewrite app_nil_r -2!app_nil_end.
- by 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 Tree.