From Coq Require Import
     Relations
     List
     Lia.

Import ListNotations.
From RDS Require Import
     Relations
     DiscreteStream.

From ExtLib Require Import
     Structures.Monad
     Core.RelDec
     Structures.Maps
     Data.Map.FMapAList.

From ChargeCore Require Import
     Logics.ILogic
     Logics.ILInsts.

Section ETL.

  Variables (uid: Set) (atom: Set) (heap: Set).

  (* Facts we learn and by whom  we learned them *)
  Inductive fact : Set :=
  | Ret: atom -> fact
  | Says: uid -> fact -> fact.

  Coercion Ret: atom >-> fact.

  (* Toy programming language executed by each agent *)
  Inductive prog :=
  | Comp: prog
  | Send: uid -> fact -> prog
  | Recv: prog.

  (* A single agent at one point in time *)
  Record state := Agent {
      user: uid;
      mem: heap;
      exe: prog;
      db: list fact
    }.

  (* A trace of an agent through time *)
  Definition trace := stream state.

  (* Equality is decidable... *)
  Parameter eqdec_uid: RelDec (@eq uid).
  Global Existing Instance eqdec_uid.

  Parameter eqdec_atom: RelDec (@eq atom).
  Global Existing Instance eqdec_atom.

  Global Instance eqdec_fact: RelDec (@eq fact) := {
      rel_dec := fix rec(a b: fact) :=
        match a,b with
        | Ret a, Ret b => rel_dec a b
        | Says ua fa, Says ub fb =>
            andb (rel_dec ua ub) (rec fa fb)
        | _, _ => false
        end
    }.

  (* Each agent has a program -- a binary relation on (heap * prog) *)
  Variable (transition: uid -> heap*prog -> heap*prog -> Prop).
  Variable (transition_trans: forall u, transitive _ (transition u)).

  (* Transition function is functional & deterministic *)
  Variable (transition_determ: forall u s s' s'',
               transition u s s' ->
               transition u s s'' -> s' = s'').

  (* Toy Operational semantics of each agent *)
  Reserved Notation "a '-->' b" (at level 89).
  Inductive cstep: state -> state -> Prop :=
  | DoComp: forall st st' p' d (a: uid),
      transition a (st, Comp) (st', p') ->
      cstep (Agent a st Comp d) (Agent a st' p' d)
  where "a '-->' b" := (cstep a b).

  (* A distributed system is a list of traces *)
  Definition system := list trace.

  (* With an initial state *)
  Variable init_system: system -> Prop.

  (* Network (system) semantics *)
  Reserved Notation "a '==>' b" (at level 90).
  Inductive step: system -> system  -> Prop :=
  | LocalStep: forall a a' past hds tls,
    a --> a' ->
    hds ++ [ Continue a past ] ++ tls ==>
    hds ++ [ Continue a' (Continue a past) ] ++ tls
  | MsgDeliver: forall hds mid tls ua ub ha hb ha' hb' dba dbb m pa pb past past',
      transition ua (ha, Send ub m) (ha', pa) ->
      transition ub (hb, Recv) (hb', pb) ->
      hds
      ++ [ Continue  (Agent ua ha (Send ub m) dba) past ]
      ++ mid
      ++ [ Continue (Agent ub hb Recv dbb) past' ]
      ++ tls ==>
      hds
      ++ [ Continue (Agent ua ha pa dba)
             (Continue (Agent ua ha' (Send ub m) dba) past) ]
      ++ mid
      ++ [ Continue (Agent ub hb' pb (Says ua m :: dbb))
             (Continue (Agent ub hb Recv dbb) past') ]
      ++ tls
  where "a '==>' b" := (step a b).

  (* Transitive-reflexive closure of step *)
  Notation "a '==>*' b" := (step ^* a b) (at level 40).

  (***************** Logic ********************)
  Definition systemProp := (system -> Prop).
  Definition traceProp := (trace -> Prop).
  Definition stateProp := (state -> Prop).
  Definition atomProp := (atom -> Prop).
  Definition factProp := (fact -> Prop).

  (**************** Run the system ***************)
  Inductive Run: system -> Prop :=
    DoRun: forall s s', init_system s ->
           s ==>* s' ->
           Run s'.

  Definition check(P: systemProp): Prop :=
    forall s, Run s -> P s.

  (***************** Lifting ******************)
  Definition trace2system(P: traceProp): systemProp :=
    fun s => List.Forall P s.

  Definition system2trace(P: systemProp): traceProp :=
    fun str => P [str].

  Definition state2trace(P: stateProp): traceProp :=
    fun str => P (hd str).

  Definition fact2state(P: factProp): stateProp :=
    fun st => List.Exists P (db st).

  Inductive atom2fact(P: atomProp): factProp :=
    RetValid: forall a, P a -> atom2fact P (Ret a).

  Coercion system2trace: systemProp >-> traceProp.
  Coercion trace2system: traceProp >-> systemProp.
  Coercion state2trace: stateProp >-> traceProp.
  Coercion fact2state: factProp >-> stateProp.
  Coercion atom2fact: atomProp >-> factProp.

  (***************** Intuitionistic logic  *******************)
  Global Instance ILogicOps_systemProp : ILogicOps systemProp := _.
  Global Instance ILogicOps_traceProp : ILogicOps traceProp := _.
  Global Instance ILogicOps_stateProp : ILogicOps stateProp := _.

  (********************** Path restriction *******************)
  Definition restrict(users: list uid)(P: systemProp): systemProp :=
    fun s =>
      P (List.filter (fun str =>
                        List.existsb (rel_dec (user (hd str))) users) s).

  Definition noone(P: traceProp): systemProp :=
    fun s => List.Forall (fun x => ~ (P x)) s.

  Definition someone(P: traceProp): systemProp :=
    fun s => List.Exists P s.

  Declare Custom Entry etl.
  Declare Scope etl_scope.

  Notation "<{ e }>" := e (at level 0, e custom etl at level 99) : etl_scope.
  Notation "( x )" := x (in custom etl, x at level 99) : etl_scope.
  Notation "x" := x (in custom etl at level 0, x constr at level 0) : etl_scope.
  Notation "'_' '|-' e " :=
    (noone e)
      (at level 0, e custom etl at level 99) : etl_scope.
  Notation "'*' '|-' e " :=
    (trace2system e)
      (at level 0, e custom etl at level 99) : etl_scope.
  Notation "a '|-' e " :=
    (restrict a e)
      (at level 0, a constr, e custom etl at level 99) : etl_scope.

  (***************** Property impled by big-step *********************)
  Definition leads_to (P Q : systemProp) : Prop :=
    forall s t , P s -> s ==>* t -> Q t.

  Notation "a '->*' b" :=
    (leads_to a b)
      (in custom etl at level 90, a custom etl, b custom etl,
        right associativity) : etl_scope.

  Notation "x /\ y"   := (land x y) (in custom etl at level 50, left associativity).
  Notation "x \/ y"   := (lor x y) (in custom etl at level 50, left associativity).
  Notation "'True'"   := (ltrue) (in custom etl at level 0).
  Notation "'False'"  := (lfalse) (in custom etl at level 0).
  Notation "x -> y"   := (limpl x y) (in custom etl at level 50, left associativity).
  Notation "x <-> y"   :=
    (land (limpl x y) (limpl y x)) (in custom etl at level 50, left associativity).
  Notation "~ a"      := (limpl a lfalse) (in custom etl at level 40).
  Notation "'forall' a ',' b" := (lforall a b) (in custom etl at level 80).
  Notation "'exists' a ',' b" := (lexists a b) (in custom etl at level 80).

  (************** Temporal basic operators (stream) ********************)
  Definition next (P : traceProp) : traceProp :=
    fun str => P (tl str).

  CoInductive always (P : traceProp) : traceProp :=
    C_always :
      forall s0 (str : trace),
      P (Continue s0 str) -> always P str -> always P (Continue s0 str).

  Inductive eventually (P : traceProp) : traceProp :=
  | ev_h : forall str : trace, P str -> eventually P str
  | ev_t :
    forall s (str : trace),
      eventually P str -> eventually P (Continue s str).

  Inductive until (P Q : traceProp) : traceProp :=
  | until_h : forall str : trace, Q str -> until P Q str
  | until_t :
    forall s (str : trace),
      P (Continue s str) -> until P Q str -> until P Q (Continue s str).

  CoInductive unless (P Q : traceProp) : traceProp :=
  | unless_h : forall str : trace, Q str -> unless P Q str
  | unless_t :
    forall s (str : trace),
      P (Continue s str) -> unless P Q str -> unless P Q (Continue s str).

  Notation "[] a"  := (always a)  (in custom etl at level 90).
  Notation "{} a" := (eventually a) (in custom etl at level 90).

  (****************************** Temporal derived operators ***********************)
  Definition infinitely_often (P : traceProp) :
    traceProp := always (eventually P).

  Definition implies (P Q : traceProp) : traceProp :=
    always (fun str : trace => P str -> Q str).

  Definition is_followed (P Q : traceProp) (str : trace) : Prop :=
    P str -> eventually Q str.

  Definition is_always_followed (P Q : traceProp) :
    traceProp := always (is_followed P Q).

  Definition eventually_permanently (P : traceProp) :
    traceProp := eventually (always P).

  Definition once_always (P Q : traceProp) : traceProp :=
    implies P (always Q).

  Definition leads_to_via (P Q R : traceProp) :
    traceProp := implies P (until Q R).

  Definition once_until (P Q : traceProp) : traceProp :=
    leads_to_via P P Q.

  (************************** Epistemic Knowledge operators ***********************)
  Fixpoint powerset{T}(l: list T): list (list T) :=
    match l with
    | nil => [nil]
    | x :: xs =>
      let ps := powerset xs in
      ps ++ List.map (fun ss => x :: ss) ps
    end.

  Fixpoint trust(f: fact): atom :=
     match f with
     | Says _ f => trust f
     | Ret a => a
     end.

  Definition split_rumors(l: list fact): (list atom * list atom) :=
    let rumors := List.fold_left (fun acc i =>
                                    match i with
                                    | Says _ f => trust f :: acc
                                    | Ret a => acc
                                    end) l nil in
    let truths := List.fold_left (fun acc i =>
                                    match i with
                                    | Says _ f => acc
                                    | Ret a => a :: acc
                                    end) l nil in
    (rumors, truths).

  Definition possible_worlds(db: list fact): list (list atom) :=
    let (rums, atoms) := split_rumors db in
    List.map (fun l => l ++ atoms) (powerset rums).

  Definition over_db(st: state)(d: list atom): state :=
    match st with
    | Agent u h p l => Agent u h p (List.map Ret d)
    end.

  (* For this point in time, knowledge means to consider
     something valid in all possible worlds (Kripke) *)
  Definition kripke(P: stateProp): stateProp :=
    fun st => forall w, In w (possible_worlds (db st)) ->
                P st <-> P (over_db st w).

  Definition knows_uid(u: uid)(P: stateProp): systemProp :=
    fun s => forall a ts, In (Continue a ts) s ->
          user a = u ->
          kripke P a.

  Definition knows_all(P: stateProp): systemProp :=
    fun s => forall a ts, In (Continue a ts) s ->
                  kripke P a.

  Notation "'K[' x ']' a" :=
    (knows_uid x a) (in custom etl at level 90, x constr).
  Notation "'K[' '*' ']' a" :=
    (knows_all a) (in custom etl at level 90).

  (********************* Examples ********************)
  Local Open Scope etl_scope.

  Variable phi: atomProp.

  Check <{ _ |- {} False }>.
  Check <{ * |- [] K[*] phi /\ True }>.

  Theorem foo: check <{ _ |- {} False }>.
  Proof.
    cbv.
    intros sys HR.
    induction sys; intros; cbv in *.
    - constructor.
    - constructor.
  Admitted.

End ETL.


From VLSM.Lib Require Import Itauto.
From Coq Require Import FinFun FunctionalExtensionality.
From stdpp Require Import prelude finite.
From VLSM.Lib Require Import Preamble.
From VLSM.Core Require Import VLSM VLSMProjections Composition Validator ProjectionTraces.
From VLSM.Core Require Import SubProjectionTraces Equivocation Equivocation.NoEquivocation.

(** * Fixed Set Equivocation

  In this section we define fixed equivocation for the regular composition.

  Assuming that a only a fixed subset of the nodes (here called equivocating)
  are allowed to equivocate, inspired by the results leading to
  Lemma [equivocators_valid_trace_from_project] which links state equivocation
  to free composition, we can say that a message can be produced by a network
  of nodes allowed to equivocate, if it can be produced by their free composition
  [free_equivocating_vlsm_composition] preloaded with the current information
  (messages) available to it at the moment of production.
*)

Section sec_fixed_equivocation_without_fullnode.

Context
  {message : Type}
  `{FinSet index Ci}
  `{@finite.Finite index _}
  (IM : index -> VLSM message)
  `{forall i : index, HasBeenSentCapability (IM i)}
  `{forall i : index, HasBeenReceivedCapability (IM i)}
  (equivocating : Ci)
  (Free := free_composite_vlsm IM)
  (index_equivocating_prop : index -> Prop := sub_index_prop (elements equivocating))
  (equivocating_index : Type := sub_index (elements equivocating))
  (equivocating_IM := sub_IM IM (elements equivocating))
  .

(**
  [free_equivocating_vlsm_composition] is the free composition of the subset of
  nodes which are allowed to equivocate.
*)
Definition free_equivocating_vlsm_composition
  : VLSM message
  := @free_composite_vlsm message equivocating_index _ equivocating_IM.

(**
  [pre_loaded_free_equivocating_vlsm_composition] preloads the free composition
  of equivocating nodes all with the messages given by the <<messageSet>>.
*)
Definition pre_loaded_free_equivocating_vlsm_composition
  (messageSet : message -> Prop)
  := pre_loaded_vlsm free_equivocating_vlsm_composition messageSet.

(**
  Given a composite state <<s>>, we define the composition of equivocators
  preloaded with the messages directly observed in <<s>>.
*)
Definition equivocators_composition_for_directly_observed s
  := pre_loaded_free_equivocating_vlsm_composition (composite_has_been_directly_observed IM s).

(**
  The fixed equivocation constraint for the regular composition of nodes
  stipulates that a message can be received either if it [has_been_directly_observed]
  or it can be emitted by the free composition of equivocators pre-loaded with
  the messages directly observed in the current state.
*)
Definition fixed_equivocation s m
  := composite_has_been_directly_observed IM s m \/
    can_emit (equivocators_composition_for_directly_observed s) m.

Definition fixed_equivocation_constraint
  (l : composite_label IM)
  (som : composite_state IM * option message)
  : Prop
  :=
  let (s, om) := som in
  from_option (fixed_equivocation s) True om.

(**
  Composition of regular VLSMs under the [fixed_equivocation_constraint]s.

  In the remainder of this module we will refer to this as the <<Fixed>> VLSM.
*)
Definition fixed_equivocation_vlsm_composition : VLSM message
  := composite_vlsm IM fixed_equivocation_constraint.

Lemma fixed_equivocation_vlsm_composition_incl_free
  : VLSM_incl fixed_equivocation_vlsm_composition Free.
Proof.
  by apply constraint_free_incl.
Qed.

Lemma fixed_equivocation_vlsm_composition_incl_preloaded_free
  : VLSM_incl fixed_equivocation_vlsm_composition (pre_loaded_with_all_messages_vlsm Free).
Proof.
  apply VLSM_incl_trans with (machine Free).
  - by apply fixed_equivocation_vlsm_composition_incl_free.
  - by apply vlsm_incl_pre_loaded_with_all_messages_vlsm.
Qed.

(** ** A (seemingly) stronger definition for fixed-set equivocation

  A seemingly stronger fixed equivocation constraint requires that a received
  message either [has_been_sent] by a non-equivocating node
  or it can be emitted by the free composition of equivocators pre-loaded with
  messages which have been sent by non-equivocating nodes.

  We say seemingly because, as shown by the [Fixed_eq_StrongFixed] result,
  the compositions constrained by the two [fixed_equivocation_constraint]s
  are trace-equivalent.
*)

Section sec_strong_fixed_equivocation.

Definition sent_by_non_equivocating s m
  := exists i, i ∉ elements equivocating /\ has_been_sent (IM i) (s i) m.

#[export] Instance sent_by_non_equivocating_dec : RelDecision sent_by_non_equivocating.
Proof.
  intros s m.
  apply @Decision_iff with (P := Exists (fun i => has_been_sent (IM i) (s i) m)
    (filter (fun i => i ∉ elements equivocating) (enum index))).
  - rewrite Exists_exists. apply exist_proper. intro i.
    rewrite elem_of_list_filter. apply and_iff_compat_r.
    split; [intros [Hi Hl]; done | split; [done |]].
    by apply elem_of_enum.
  - by apply Exists_dec; intro i; apply has_been_sent_dec.
Qed.

Lemma sent_by_non_equivocating_are_sent s m
  (Hsent : sent_by_non_equivocating s m)
  : composite_has_been_sent IM s m.
Proof.
  by destruct Hsent as [i [Hi Hsent]]; exists i.
Qed.

Lemma sent_by_non_equivocating_are_directly_observed s m
  (Hsent : sent_by_non_equivocating s m)
  : composite_has_been_directly_observed IM s m.
Proof.
  apply composite_has_been_directly_observed_sent_received_iff; left.
  by apply sent_by_non_equivocating_are_sent.
Qed.

(**
  Given a composite state <<s>>, we define the composition of equivocators
  preloaded with the messages sent by non-equivocating nodes in <<s>>.
*)
Definition equivocators_composition_for_sent s
  := pre_loaded_free_equivocating_vlsm_composition (sent_by_non_equivocating s).

Definition strong_fixed_equivocation s m
  := sent_by_non_equivocating s m \/
    can_emit (equivocators_composition_for_sent s) m.

Definition strong_fixed_equivocation_constraint
  (l : composite_label IM)
  (som : composite_state IM * option message)
  : Prop
  :=
  let (s, om) := som in
  from_option (strong_fixed_equivocation s) True om.

Definition strong_fixed_equivocation_vlsm_composition : VLSM message
  := composite_vlsm IM strong_fixed_equivocation_constraint.

(**
  The composition of equivocators pre-loaded with only the messages sent by
  non-equivocators is included in that pre-loaded with all the directly observed
  messages.
*)
Lemma Equivocators_Strong_Fixed_incl base_s
  : VLSM_incl
      (equivocators_composition_for_sent base_s)
      (equivocators_composition_for_directly_observed base_s).
Proof.
  apply pre_loaded_vlsm_incl.
  by apply sent_by_non_equivocating_are_directly_observed.
Qed.

(**
  [strong_fixed_equivocation_constraint] is stronger than
  the [fixed_equivocation_constraint].
*)
Lemma strong_fixed_equivocation_subsumption s m
  : strong_fixed_equivocation s m -> fixed_equivocation s m.
Proof.
  intros [Hobs | Hemit]; [left | right].
  - by apply sent_by_non_equivocating_are_directly_observed.
  - revert Hemit. apply VLSM_incl_can_emit.
    by apply Equivocators_Strong_Fixed_incl.
Qed.

Lemma strong_fixed_equivocation_constraint_subsumption
  : strong_constraint_subsumption IM
    strong_fixed_equivocation_constraint
    fixed_equivocation_constraint.
Proof.
  intros l [s [m |]] Hc; [| done].
  by apply strong_fixed_equivocation_subsumption.
Qed.

Lemma StrongFixed_incl_Fixed
  : VLSM_incl strong_fixed_equivocation_vlsm_composition fixed_equivocation_vlsm_composition.
Proof.
  apply constraint_subsumption_incl.
  apply preloaded_constraint_subsumption_stronger.
  apply strong_constraint_subsumption_strongest.
  by apply strong_fixed_equivocation_constraint_subsumption.
Qed.

End sec_strong_fixed_equivocation.

End sec_fixed_equivocation_without_fullnode.

(** ** Extending the set of nodes allowed to equivocate *)

Section sec_fixed_equivocation_index_incl.

Context
  {message : Type}
  `{FinSet index Ci}
  `{@finite.Finite index _}
  (IM : index -> VLSM message)
  `{forall i : index, HasBeenSentCapability (IM i)}
  `{forall i : index, HasBeenReceivedCapability (IM i)}
  (indices1 indices2 : Ci)
  (Hincl : elements indices1 ⊆ elements indices2)
  .

Lemma equivocators_composition_for_directly_observed_index_incl_embedding
  (s : state)
  : VLSM_embedding
    (equivocators_composition_for_directly_observed IM indices1 s)
    (equivocators_composition_for_directly_observed IM indices2 s)
    (lift_sub_incl_label IM _ _ Hincl) (lift_sub_incl_state IM _ _).
Proof.
  by apply lift_sub_incl_preloaded_embedding.
Qed.

Lemma fixed_equivocation_index_incl_subsumption
  : forall s m,
    fixed_equivocation IM indices1 s m ->
    fixed_equivocation IM indices2 s m.
Proof.
  intros s m [Hobs | Hemit]; [by left |].
  right.
  specialize
    (equivocators_composition_for_directly_observed_index_incl_embedding s)
    as Hproj.
  by apply (VLSM_embedding_can_emit Hproj) in Hemit.
Qed.

Lemma fixed_equivocation_constraint_index_incl_subsumption
  : strong_constraint_subsumption IM
    (fixed_equivocation_constraint IM indices1)
    (fixed_equivocation_constraint IM indices2).
Proof.
  intros l (s, [m |]); [| done].
  by apply fixed_equivocation_index_incl_subsumption.
Qed.

Lemma fixed_equivocation_vlsm_composition_index_incl
  : VLSM_incl
    (fixed_equivocation_vlsm_composition IM indices1)
    (fixed_equivocation_vlsm_composition IM indices2).
Proof.
  apply constraint_subsumption_incl.
  apply preloaded_constraint_subsumption_stronger.
  apply strong_constraint_subsumption_strongest.
  by apply fixed_equivocation_constraint_index_incl_subsumption.
Qed.

End sec_fixed_equivocation_index_incl.

(** ** Restricting Fixed valid traces to only the equivocators

  In this section we study the properties of Fixed valid traces
  when projected to the composition of equivocator nodes.

  The main result, Lemma [fixed_finite_valid_trace_sub_projection]
  is a strengthening of Lemma [finite_valid_trace_sub_projection] for the
  [fixed_equivocation_constraint], showing that, when restricting
  a Fixed valid trace to only the transitions belonging to the equivocators,
  the obtained trace is valid for the composition of equivocators pre-loaded
  only with those messages sent by the non-equivocators in the original trace.
*)

Section sec_fixed_equivocator_sub_projection.

Context
  {message : Type}
  `{FinSet index Ci}
  `{@finite.Finite index _}
  (IM : index -> VLSM message)
  `{forall i, HasBeenSentCapability (IM i)}
  `{forall i, HasBeenReceivedCapability (IM i)}
  (equivocators : Ci)
  (Fixed := fixed_equivocation_vlsm_composition IM equivocators)
  (StrongFixed := strong_fixed_equivocation_vlsm_composition IM equivocators)
  (Free := free_composite_vlsm IM)
  (PreFree := pre_loaded_with_all_messages_vlsm Free)
  .

Definition Fixed_incl_Free : VLSM_incl Fixed Free := constraint_free_incl _ _.

Lemma Fixed_incl_Preloaded : VLSM_incl Fixed (pre_loaded_with_all_messages_vlsm Free).
Proof.
  eapply VLSM_incl_trans; [by apply Fixed_incl_Free |].
  by apply (vlsm_incl_pre_loaded_with_all_messages_vlsm Free).
Qed.

Definition preloaded_Fixed_incl_Preloaded :
  VLSM_incl (pre_loaded_with_all_messages_vlsm Fixed) (pre_loaded_with_all_messages_vlsm Free) :=
    preloaded_constraint_free_incl _ _.

Definition StrongFixed_incl_Free : VLSM_incl StrongFixed Free := constraint_free_incl _ _.

Lemma StrongFixed_incl_Preloaded : VLSM_incl StrongFixed (pre_loaded_with_all_messages_vlsm Free).
Proof.
  eapply VLSM_incl_trans; [by apply StrongFixed_incl_Free |].
  by apply (vlsm_incl_pre_loaded_with_all_messages_vlsm Free).
Qed.

Lemma in_futures_preserves_sent_by_non_equivocating s base_s
  (Hfuture_s : in_futures PreFree s base_s)
  : forall m : message,
    sent_by_non_equivocating IM equivocators s m ->
    sent_by_non_equivocating IM equivocators base_s m.
Proof.
  intros m (i & Hi & Hsent).
  exists i; split; [done |].
  eapply in_futures_preserving_oracle_from_stepwise; [| | done].
  - by apply has_been_sent_stepwise_props.
  - by apply (VLSM_projection_in_futures (preloaded_component_projection IM i)).
Qed.

Lemma in_futures_preserves_can_emit_by_equivocators_composition_for_sent s base_s
  (Hfuture_s : in_futures PreFree s base_s)
  : forall m : message,
    can_emit (equivocators_composition_for_sent IM equivocators s) m ->
    can_emit (equivocators_composition_for_sent IM equivocators base_s) m.
Proof.
  by apply VLSM_incl_can_emit, pre_loaded_vlsm_incl,
        in_futures_preserves_sent_by_non_equivocating.
Qed.

Lemma in_futures_preserves_strong_fixed_equivocation s base_s
  (Hfuture_s : in_futures PreFree s base_s)
  m
  (Hstrong : strong_fixed_equivocation IM equivocators s m)
  : strong_fixed_equivocation IM equivocators base_s m.
Proof.
  destruct Hstrong as [Hsent | Hemit]; [left | right].
  - by eapply in_futures_preserves_sent_by_non_equivocating.
  - by eapply in_futures_preserves_can_emit_by_equivocators_composition_for_sent.
Qed.

Lemma strong_fixed_equivocation_eqv_valid_message base_s m
  (Hstrong : strong_fixed_equivocation IM equivocators base_s m)
  : valid_message_prop (equivocators_composition_for_sent IM equivocators base_s) m.
Proof.
   destruct Hstrong as [Hobs | Hemit].
  - by apply initial_message_is_valid; right.
  - by apply emitted_messages_are_valid in Hemit.
Qed.

Lemma strong_fixed_equivocation_eqv_valid_message_in_futures base_s s
  (Hfuture_s : in_futures PreFree s base_s)
  m
  (Hstrong : strong_fixed_equivocation IM equivocators s m)
  : valid_message_prop (equivocators_composition_for_sent IM equivocators base_s) m.
Proof.
  destruct (in_futures_preserves_strong_fixed_equivocation _ _ Hfuture_s _ Hstrong)
    as [Hobs | Hemit].
  - by apply initial_message_is_valid; right.
  - by apply emitted_messages_are_valid in Hemit.
Qed.

Section sec_fixed_finite_valid_trace_sub_projection_helper_lemmas.

(**
  The results in this section are not meant to be used directly. They are just
  sub-lemmas of [fixed_finite_valid_trace_sub_projection_helper].

  We make an assumption (<<Hobs_s_protocol>>) which is later shown to hold
  for all Fixed valid states.

  We then restate (some of) these lemmas without the extra assumption.
*)

Context
  (base_s s : composite_state IM)
  (Hobs_s_protocol : forall m, composite_has_been_directly_observed IM s m ->
    strong_fixed_equivocation IM equivocators base_s m)
  .

(** See the lemma [fixed_input_has_strong_fixed_equivocation] below. *)
#[local] Lemma fixed_input_has_strong_fixed_equivocation_helper
  l m
  (Hv : input_valid Fixed l (s, Some m))
  : strong_fixed_equivocation IM equivocators base_s m.
Proof.
  destruct Hv as [_ [_ [_ [Hobs | Hemit]]]].
  - by apply Hobs_s_protocol.
  - right.
    clear -Hemit Hobs_s_protocol. revert Hemit.
    apply VLSM_incl_can_emit; simpl.
    apply basic_VLSM_incl; intros s0 **; [done | | by apply Hv | by apply H].
    destruct HmX as [Him | Hobs].
    + by apply initial_message_is_valid; left.
    + apply Hobs_s_protocol in Hobs as [Hsent | Hemit].
      * by apply initial_message_is_valid; right.
      * by apply emitted_messages_are_valid.
Qed.

#[local] Lemma fixed_input_valid_transition_sub_projection_helper
  (Hs_pr : valid_state_prop (equivocators_composition_for_sent IM equivocators base_s)
    (composite_state_sub_projection IM (elements equivocators) s))
  l
  (e : sub_index_prop (elements equivocators) (projT1 l))
  iom oom sf
  (Ht : input_valid_transition Fixed l (s, iom) (sf, oom))
  : input_valid_transition (equivocators_composition_for_sent IM equivocators base_s)
      (composite_label_sub_projection IM (elements equivocators) l e)
      (composite_state_sub_projection IM (elements equivocators) s, iom)
      (composite_state_sub_projection IM (elements equivocators) sf, oom).
Proof.
  destruct l as (i, li). simpl in *.
  repeat split.
  - done.
  - apply proj1 in Ht.
    destruct iom as [im |]; [| by apply option_valid_message_None].
    apply strong_fixed_equivocation_eqv_valid_message.
    by apply (fixed_input_has_strong_fixed_equivocation_helper _ _ Ht).
  - by apply Ht.
  - apply proj2 in Ht. simpl in Ht.
    simpl. unfold sub_IM at 2. simpl. unfold composite_state_sub_projection at 1. simpl.
    destruct (vtransition _ _ _) as (si', om').
    inversion_clear Ht. f_equal.
    clear.
    apply functional_extensionality_dep. intro sub_j.
    destruct_dec_sig sub_j j Hj Heqsub_j. subst.
    unfold composite_state_sub_projection at 2.
    by destruct (decide (i = j)); subst; state_update_simpl.
Qed.

(** See the lemma [fixed_output_has_strong_fixed_equivocation] below. *)
#[local] Lemma fixed_output_has_strong_fixed_equivocation_helper
  (Hs_pr : valid_state_prop (equivocators_composition_for_sent IM equivocators base_s)
    (composite_state_sub_projection IM (elements equivocators) s))
  sf
  (Hfuture : in_futures PreFree sf base_s)
  l iom om
  (Ht : input_valid_transition Fixed l (s, iom) (sf, Some om))
  : strong_fixed_equivocation IM equivocators base_s om.
Proof.
  destruct (decide (projT1 l ∈ elements equivocators)).
  - apply
      (fixed_input_valid_transition_sub_projection_helper Hs_pr _ e) in Ht.
    by right; eexists _, _, _.
  - left.
    exists (projT1 l). split; [done |].
    apply (VLSM_projection_in_futures
      (preloaded_component_projection IM (projT1 l))) in Hfuture.
    apply in_futures_preserving_oracle_from_stepwise with (field_selector output) (sf (projT1 l))
    ; [by apply has_been_sent_stepwise_props | done |].
    apply (VLSM_incl_input_valid_transition Fixed_incl_Preloaded) in Ht.
    specialize (VLSM_projection_input_valid_transition
      (preloaded_component_projection IM (projT1 l)) l (projT2 l)) as Hproject.
    spec Hproject.
    { unfold composite_project_label.
      destruct (decide _); [| by elim n0].
      replace e with (eq_refl (A := index) (x := projT1 l)); [done |].
      by apply Eqdep_dec.UIP_dec.
    }
    specialize (Hproject _ _ _ _ Ht).
    by apply (has_been_sent_step_update Hproject); left.
Qed.

End sec_fixed_finite_valid_trace_sub_projection_helper_lemmas.

(**
  Using the lemmas above we can now prove (by induction) a generic result,
  which has as part of the conclusion the "observability implies strong_fixed_equivocation"
  hypothesis assumed in the above section.
*)
Lemma fixed_finite_valid_trace_sub_projection_helper
  si s tr
  (Htr : finite_valid_trace_init_to Fixed si s tr)
  base_s
  (Hfuture : in_futures PreFree s base_s)
  : finite_valid_trace_from_to (equivocators_composition_for_sent IM equivocators base_s)
    (composite_state_sub_projection IM (elements equivocators) si)
    (composite_state_sub_projection IM (elements equivocators) s)
    (finite_trace_sub_projection IM (elements equivocators) tr) /\
    forall m, composite_has_been_directly_observed IM s m ->
      strong_fixed_equivocation IM equivocators base_s m.
Proof.
  induction Htr using finite_valid_trace_init_to_rev_ind.
  - split.
    + apply finite_valid_trace_from_to_empty.
      apply (composite_initial_state_sub_projection IM (elements equivocators) si) in Hsi.
      by apply initial_state_is_valid.
    + intros m Hobs; exfalso.
      eapply (@has_been_directly_observed_no_inits _ Free); [done |].
      by apply composite_has_been_directly_observed_free_iff.
  - apply (VLSM_incl_input_valid_transition Fixed_incl_Preloaded) in Ht as Hpre_t.
    assert (Hfuture_s : in_futures PreFree s base_s).
    {
      destruct Hfuture as [tr' Htr'].
      specialize (finite_valid_trace_from_to_extend _ _ _ _ Htr' _ _ _ _ Hpre_t) as Htr''.
      by eexists.
    }
    specialize (IHHtr Hfuture_s) as [Htr_pr Htr_obs].
    split; cycle 1.
    + intros m Hobs.
      eapply @has_been_directly_observed_step_update with (msg := m) (vlsm := Free) in Hpre_t.
      apply composite_has_been_directly_observed_free_iff, Hpre_t in Hobs.
      destruct Hobs as [Hitem | Hobs]
      ; [| by apply composite_has_been_directly_observed_free_iff, Htr_obs in Hobs].
      apply valid_trace_last_pstate in Htr.
      apply valid_trace_last_pstate in Htr_pr.
      destruct Hitem as [Hm | Hm]; subst.
      * by eapply fixed_input_has_strong_fixed_equivocation_helper; destruct Ht.
      * by eapply fixed_output_has_strong_fixed_equivocation_helper; cycle 3.
    + rewrite (finite_trace_sub_projection_app IM (elements equivocators));
      cbn; unfold pre_VLSM_projection_transition_item_project;
      cbn; unfold composite_label_sub_projection_option.
      case_decide as Hl.
      * eapply finite_valid_trace_from_to_app; [by apply Htr_pr |].
        apply finite_valid_trace_from_to_singleton.
        apply valid_trace_last_pstate in Htr_pr.
        by apply fixed_input_valid_transition_sub_projection_helper.
      * rewrite app_nil_r;
        replace (composite_state_sub_projection _ _ sf)
           with (composite_state_sub_projection IM (elements equivocators) s)
        ; [done |].
        destruct Ht as [_ Ht]; cbn in Ht;
        destruct l as (i, li), (vtransition _ _ _) as (si', om');
        inversion_clear Ht; clear -Hl.
        extensionality sub_j; destruct_dec_sig sub_j j Hj Heqsub_j;
        subst; unfold composite_state_sub_projection.
        by destruct (decide (i = j)); subst; state_update_simpl.
Qed.

(**
  Main result of this section: when restricting a Fixed valid trace to only
  the transitions belonging to the equivocators, the obtained trace is valid
  for the composition of equivocators pre-loaded with messages sent by the
  non-equivocators in the original trace.

  This is a simple corollary of Lemma [fixed_finite_valid_trace_sub_projection_helper]
  proved above.
*)
Lemma fixed_finite_valid_trace_sub_projection is f tr
  (Htr : finite_valid_trace_init_to Fixed is f tr)
  : finite_valid_trace_init_to
              (equivocators_composition_for_sent IM equivocators f)
              (composite_state_sub_projection IM (elements equivocators) is)
              (composite_state_sub_projection IM (elements equivocators) f)
              (finite_trace_sub_projection IM (elements equivocators) tr).
Proof.
  apply fixed_finite_valid_trace_sub_projection_helper with (base_s := f) in Htr as Htr_pr.
  - split; [by apply Htr_pr |].
    apply proj2 in Htr.
    by specialize (composite_initial_state_sub_projection IM (elements equivocators) is Htr).
  - apply in_futures_refl. apply valid_trace_last_pstate in Htr.
    by apply (VLSM_incl_valid_state Fixed_incl_Preloaded).
Qed.

(**
  Any message directly observed in a Fixed valid state has either been sent by the
  non-equivocating nodes, or it can be generated by the equivocating nodes
  using only the messages sent by the non-equivocating nodes.
*)
Lemma fixed_directly_observed_has_strong_fixed_equivocation f
  (Hf : valid_state_prop Fixed f)
  m
  (Hobs : composite_has_been_directly_observed IM f m)
  : strong_fixed_equivocation IM equivocators f m.
Proof.
  apply (VLSM_incl_valid_state Fixed_incl_Preloaded) in Hf as Hfuture.
  apply in_futures_refl in Hfuture.
  apply valid_state_has_trace in Hf as [is [tr Htr]].
  eapply fixed_finite_valid_trace_sub_projection_helper in Htr as Htr_pr; [| done].
  by apply Htr_pr.
Qed.

Lemma fixed_valid_state_sub_projection s f
  (Hsf : in_futures Fixed s f)
  : valid_state_prop
    (equivocators_composition_for_sent IM equivocators f)
    (composite_state_sub_projection IM (elements equivocators) s).
Proof.
  destruct Hsf as [tr Htr].
  apply finite_valid_trace_from_to_complete_left in Htr as [is [trs [Htr Hs]]].
  apply fixed_finite_valid_trace_sub_projection in Htr as Hpr_tr.
  apply proj1, finite_valid_trace_from_to_app_split, proj1, valid_trace_forget_last in Htr.
  rewrite (finite_trace_sub_projection_app IM (elements equivocators)) in Hpr_tr.
  apply proj1, finite_valid_trace_from_to_app_split, proj1, valid_trace_last_pstate in Hpr_tr.
  subst s. simpl.
  by rewrite <- (finite_trace_sub_projection_last_state IM _ _ _ _ Htr).
Qed.

(**
  The input of a Fixed input valid transition has the [strong_fixed_equivocation]
  property.
*)
Lemma fixed_input_has_strong_fixed_equivocation
  l s m
  (Ht : input_valid Fixed l (s, Some m))
  : strong_fixed_equivocation IM equivocators s m.
Proof.
  apply fixed_input_has_strong_fixed_equivocation_helper with (base_s := s) in Ht
  ; [done |].
  by apply fixed_directly_observed_has_strong_fixed_equivocation, Ht.
Qed.

(**
  The output of a Fixed input valid transition has the [strong_fixed_equivocation]
  property for its destination.
*)
Lemma fixed_output_has_strong_fixed_equivocation
  l s iom sf om
  (Ht : input_valid_transition Fixed l (s, iom) (sf, Some om))
  : strong_fixed_equivocation IM equivocators sf om.
Proof.
  apply input_valid_transition_origin in Ht as Hs.
  apply fixed_output_has_strong_fixed_equivocation_helper with s sf l iom.
  - intros m Hobs. apply in_futures_preserves_strong_fixed_equivocation with s.
    + apply (VLSM_incl_input_valid_transition Fixed_incl_Preloaded) in Ht.
      by eapply (input_valid_transition_in_futures PreFree).
    + by apply fixed_directly_observed_has_strong_fixed_equivocation.
  - apply input_valid_transition_in_futures in Ht.
    by apply fixed_valid_state_sub_projection.
  - apply in_futures_refl. apply input_valid_transition_destination in Ht.
    by apply (VLSM_incl_valid_state Fixed_incl_Preloaded).
  - done.
Qed.

End sec_fixed_equivocator_sub_projection.

(**
  [strong_fixed_equivocation_constraint] is not actually stronger/

  In this section we show that the compositions of nodes using
  the [fixed_equivocation_constraint] and the [strong_fixed_equivocation]
  are trace-equivalent.

  The importance of this result is that we can reduce the complexity of proofs
  involving fixed equivocation by using the [strong_fixed_equivocation] constraint
  in the hypotheses of a lemma and the "weaker" [fixed_equivocation_constraint]
  in the conclusion.
*)

Section sec_Fixed_eq_StrongFixed.

Context
  {message : Type}
  `{FinSet index Ci}
  `{@finite.Finite index _}
  (IM : index -> VLSM message)
  `{forall i, HasBeenSentCapability (IM i)}
  `{forall i, HasBeenReceivedCapability (IM i)}
  (equivocators : Ci)
  (Fixed := fixed_equivocation_vlsm_composition IM equivocators)
  (StrongFixed := strong_fixed_equivocation_vlsm_composition IM equivocators)
  (Free := free_composite_vlsm IM)
  (PreFree := pre_loaded_with_all_messages_vlsm Free)
  .

(**
  Given a Fixed valid state, the composition of the equivocators
  preloaded with all the directly observed messages in the state is not stronger
  than that preloaded with only the messages sent by non-equivocators.
*)
Lemma Equivocators_Fixed_Strong_incl base_s
  (Hbase_s : valid_state_prop Fixed base_s)
  : VLSM_incl
      (equivocators_composition_for_directly_observed IM equivocators base_s)
      (equivocators_composition_for_sent IM equivocators base_s).
Proof.
  apply basic_VLSM_incl.
  - by intros s Hincl.
  - intros l s m Hv HsY [Hinit | Hobs]
    ; [by apply initial_message_is_valid; left |].
    apply strong_fixed_equivocation_eqv_valid_message.
    by apply fixed_directly_observed_has_strong_fixed_equivocation.
  - by intros l s om (_ & _ & Hv) _ _.
  - by destruct 1.
Qed.

Lemma Equivocators_Fixed_Strong_eq base_s
  (Hbase_s : valid_state_prop Fixed base_s)
  : VLSM_eq
      (equivocators_composition_for_directly_observed IM equivocators base_s)
      (equivocators_composition_for_sent IM equivocators base_s).
Proof.
  split.
  - by apply Equivocators_Fixed_Strong_incl.
  - by apply Equivocators_Strong_Fixed_incl.
Qed.

(**
  The subsumption between [fixed_equivocation_constraint] and
  [strong_fixed_equivocation_constraint] holds under [input_valid] assumptions.
*)
Lemma fixed_strong_equivocation_subsumption
  : input_valid_constraint_subsumption IM
    (fixed_equivocation_constraint IM equivocators)
    (strong_fixed_equivocation_constraint IM equivocators).
Proof.
  intros l (s, om) Hv.
  destruct om as [m |]; [| done].
  apply proj1 in Hv as Hs.
  by eapply fixed_input_has_strong_fixed_equivocation.
Qed.

Lemma Fixed_incl_StrongFixed : VLSM_incl Fixed StrongFixed.
Proof.
  apply constraint_subsumption_incl. apply fixed_strong_equivocation_subsumption.
Qed.

Lemma Fixed_eq_StrongFixed : VLSM_eq Fixed StrongFixed.
Proof.
  split.
  - by apply Fixed_incl_StrongFixed.
  - by apply StrongFixed_incl_Fixed.
Qed.

End sec_Fixed_eq_StrongFixed.

(** ** Changing the behavior of equivocators within a trace

  By noting that the satisfaction of the [fixed_equivocation_constraint] actually
  only depends on the messages sent by non-equivocating nodes, it makes it much
  easier to establish results related to changing the behavior of equivocating
  nodes.

  In this section we essentially prove that given a Fixed valid state <<s>>,
  any valid trace over the composition of equivocators pre-loaded with the
  messages directly observed in <<s>> can be "lifted" to a Fixed valid trace in which
  the non-equivocators remain in their corresponding component-state given by <<s>>
  (lemma [EquivPreloadedBase_Fixed_weak_embedding]).
*)

Section sec_fixed_equivocator_lifting.

Context
  {message : Type}
  `{FinSet index Ci}
  `{@finite.Finite index _}
  (IM : index -> VLSM message)
  `{forall i, HasBeenSentCapability (IM i)}
  `{forall i, HasBeenReceivedCapability (IM i)}
  (equivocators : Ci)
  (Free := free_composite_vlsm IM)
  (Fixed := fixed_equivocation_vlsm_composition IM equivocators)
  (StrongFixed := strong_fixed_equivocation_vlsm_composition IM equivocators)
  (PreFree := pre_loaded_with_all_messages_vlsm Free)
  .

(**
  Replacing the state corresponding to the equivocators does not affect the
  [sent_by_non_equivocating] property.
*)
Lemma lift_sub_state_to_sent_by_non_equivocating_iff s eqv_is m
  : sent_by_non_equivocating IM equivocators s m <->
    sent_by_non_equivocating IM equivocators (lift_sub_state_to IM (elements equivocators) s eqv_is) m.
Proof.
  by split; intros [i [Hi Hsent]]; exists i; split; [done | | done |]
  ; revert Hsent; rewrite lift_sub_state_to_neq.
Qed.

(**
  The property above induces trace-equality for the corresponding
  [equivocators_composition_for_sent] compositions.
*)
Lemma restrict_observed_to_non_equivocating_incl s eqv_is
  : VLSM_incl
    (equivocators_composition_for_sent IM equivocators s)
    (equivocators_composition_for_sent IM equivocators
      (lift_sub_state_to IM (elements equivocators) s eqv_is)).
Proof.
  apply pre_loaded_vlsm_incl.
  by apply lift_sub_state_to_sent_by_non_equivocating_iff.
Qed.

Lemma restrict_observed_to_non_equivocating_incl_rev s eqv_is
  : VLSM_incl
    (equivocators_composition_for_sent IM equivocators
      (lift_sub_state_to IM (elements equivocators) s eqv_is))
    (equivocators_composition_for_sent IM equivocators s).
Proof.
  apply pre_loaded_vlsm_incl.
  by apply lift_sub_state_to_sent_by_non_equivocating_iff.
Qed.

(**
  Replacing the state corresponding to the equivocators does not affect the
  [strong_fixed_equivocation] property.
*)
Lemma lift_sub_state_to_strong_fixed_equivocation s eqv_is m
  : strong_fixed_equivocation IM equivocators s m <->
    strong_fixed_equivocation IM equivocators (lift_sub_state_to IM (elements equivocators) s eqv_is) m.
Proof.
  split; intros [Hs | Hs]; [left | right | left | right]; revert Hs.
  - by apply lift_sub_state_to_sent_by_non_equivocating_iff.
  - apply VLSM_incl_can_emit.
    by apply restrict_observed_to_non_equivocating_incl.
  - by apply lift_sub_state_to_sent_by_non_equivocating_iff.
  - apply VLSM_incl_can_emit.
    by apply restrict_observed_to_non_equivocating_incl_rev.
Qed.

(**
  The operation of replacing the state corresponding to the equivocators
  with a given initial state and removing all transitions belonging to
  non-equivocators in a trace induces a self-[VLSM_projection] on the
  fixed equivocation composition VLSM.
*)
Lemma remove_equivocating_transitions_fixed_projection eqv_is
  (Heqv_is : composite_initial_state_prop (sub_IM IM (elements equivocators)) eqv_is)
  : VLSM_projection StrongFixed StrongFixed
      (remove_equivocating_label_project IM (elements equivocators))
      (remove_equivocating_state_project IM (elements equivocators) eqv_is).
Proof.
  apply basic_VLSM_strong_projection.
  - intros [i liX] lY.
    unfold remove_equivocating_state_project;
    unfold remove_equivocating_label_project; cbn.
    case_decide as Hi; inversion_clear 1.
    intros s om [Hv Hc].
    split.
    + by cbn; rewrite lift_sub_state_to_neq.
    + destruct om as [m |]; [| done].
      by apply lift_sub_state_to_strong_fixed_equivocation.
  - intros [i liX] lY.
    unfold remove_equivocating_state_project;
    unfold remove_equivocating_label_project; cbn.
    case_decide as Hi; inversion_clear 1.
    intros s om s' om';
    rewrite lift_sub_state_to_neq by done;
    destruct (vtransition _ _ _) as (si', _om');
    inversion_clear 1.
    f_equal; extensionality j.
    by destruct (decide (i = j)); subst; state_update_simpl.
  - intros [i liX].
    unfold remove_equivocating_state_project;
    unfold remove_equivocating_label_project; cbn.
    case_decide as Hi; [| by congruence].
    intros _ s om s' om';
    destruct (vtransition _ _ _) as (si', _om') eqn: Hti;
    inversion_clear 1.
    extensionality j.
    unfold lift_sub_state_to.
    case_decide; [done |].
    by destruct (decide (i = j)); subst; state_update_simpl.
  - intros s Hs i.
    unfold remove_equivocating_state_project, lift_sub_state_to.
    case_decide as Hi.
    + by apply (Heqv_is (dexist i Hi)).
    + by apply Hs.
  - by intros m HFixed.
Qed.

Context
  (base_s : composite_state IM)
  (Hbase_s : valid_state_prop Fixed base_s)
  (EquivPreloadedBase := equivocators_composition_for_sent IM equivocators base_s)
  .

(**
  As a corollary of the above projection result, the state obtained by replacing
  the equivocator component of a Fixed valid state with initial states is
  still a Fixed valid state.
*)
Lemma fixed_equivocator_lifting_initial_state :
  weak_projection_initial_state_preservation EquivPreloadedBase Fixed
    (lift_sub_state_to IM (elements equivocators) base_s).
Proof.
  intros eqv_is Heqv_is.
  apply (VLSM_incl_valid_state (StrongFixed_incl_Fixed IM equivocators)).
  apply (VLSM_projection_valid_state (remove_equivocating_transitions_fixed_projection _ Heqv_is)).
  by apply (VLSM_incl_valid_state (Fixed_incl_StrongFixed IM equivocators)).
Qed.

Lemma lift_sub_state_to_sent_are_directly_observed s
  : forall m, sent_by_non_equivocating IM equivocators base_s m ->
    composite_has_been_directly_observed IM (lift_sub_state_to IM (elements equivocators) base_s s) m.
Proof.
  intros m Hsent.
  apply (lift_sub_state_to_sent_by_non_equivocating_iff base_s s m) in Hsent.
  by eapply sent_by_non_equivocating_are_directly_observed.
Qed.

Lemma strong_fixed_equivocation_lift_sub_state_to s
  : forall m, strong_fixed_equivocation IM equivocators base_s m ->
    fixed_equivocation IM equivocators (lift_sub_state_to IM (elements equivocators) base_s s) m.
Proof.
  intros.
  apply strong_fixed_equivocation_subsumption.
  by apply lift_sub_state_to_strong_fixed_equivocation.
Qed.

(** *** Main result of the section

  Given a valid state <<s>> for the <<Fixed>> composition (composition of
  nodes where only the <<equivocators>> are allowed to message-equivocate),
  we can "lift" any trace of the free composition of just the equivocators
  pre-loaded with the messages observed in <<s>> to a trace over the <<Fixed>>
  composition by simply setting the non-equivocating state components to those
  of <<s>>.

  This result is important for establishing the connection between limited
  equivocation and fixed equivocation (Lemma [strong_witness_has_fixed_equivocation]).

  We prove this as a [VLSM_weak_embedding] between the free composition of
  equivocators pre-loaded with the messages observed in <<s>> and the <<Fixed>>
  composition of all nodes. Note that this is a strengthening of Lemma
  [PreSubFree_PreFree_weak_embedding].
*)
Lemma EquivPreloadedBase_Fixed_weak_embedding
  (no_initial_messages_for_equivocators :
    forall i m, i ∈ equivocators -> ~ vinitial_message_prop (IM i) m)
  : VLSM_weak_embedding EquivPreloadedBase Fixed
      (lift_sub_label IM (elements equivocators)) (lift_sub_state_to IM (elements equivocators) base_s).
Proof.
  apply basic_VLSM_weak_embedding.
  - intros l s om Hv HsY HomY. split.
    + destruct Hv as [_ [_ [Hv _]]]; revert Hv; destruct l as (i, li).
      destruct_dec_sig i j Hj Heq; subst i; cbn; unfold sub_IM; cbn.
      by rewrite lift_sub_state_to_eq with (Hi := Hj).
    + destruct om as [m |]; [| done]; cbn.
      destruct Hv as (_ & Hm & _).
      apply emitted_messages_are_valid_iff in Hm.
      destruct Hm as [[Hinit | Hobs] | Hemit].
      * destruct Hinit as [i [[im Him] Heqm]].
        destruct_dec_sig i j Hj Heqi; subst; cbn.
        clear HomY; contradict Him.
        apply no_initial_messages_for_equivocators; cbn.
        by apply elem_of_elements, Hj.
      * by apply strong_fixed_equivocation_lift_sub_state_to; left.
      * by apply strong_fixed_equivocation_lift_sub_state_to; right.
  - intros (sub_i, li) s om s' om'.
    destruct_dec_sig sub_i j Hj Heq; subst;
    unfold input_valid_transition; cbn; unfold sub_IM; cbn;
    rewrite lift_sub_state_to_eq with (Hi := Hj);
    destruct (vtransition _ _ _) as (si', _om');
    intros [_ Ht]; inversion_clear Ht.
    f_equal; extensionality i.
    destruct (decide (i = j)); subst; state_update_simpl.
    + by rewrite lift_sub_state_to_eq with (Hi := Hj), !state_update_eq.
    + destruct (decide (i ∈ elements equivocators)).
      * rewrite !lift_sub_state_to_eq with (Hi := e), state_update_neq; [done |].
        by intros Hcontra%dsig_eq.
      * by state_update_simpl.
  - by intros s Hweak_proj; apply fixed_equivocator_lifting_initial_state.
  - intros l s m Hv HsY [[(i, Hi) [[im Him] Heqm]] | Hm].
    + apply initial_message_is_valid.
      by exists i, (exist _ im Him).
    + clear HsY. eapply composite_directly_observed_valid; [done |].
      by eapply sent_by_non_equivocating_are_directly_observed.
Qed.

End sec_fixed_equivocator_lifting.

(** ** Fixed equivocation over an empty set

  If the set of nodes allowed to equivocate is empty, intuitively, it follows
  that no message equivocation is allowed, since that would mean that at least
  one node would equivocate.
*)
Section sec_fixed_equivocation_no_equivocators.

Context
  {message : Type}
  `{FinSet index Ci}
  `{@finite.Finite index _}
  (IM : index -> VLSM message)
  `{forall i : index, HasBeenSentCapability (IM i)}
  `{forall i : index, HasBeenReceivedCapability (IM i)}
  .

Lemma strong_fixed_equivocation_no_equivocators
  : forall s m,
  strong_fixed_equivocation IM (@empty Ci _) s m <-> composite_has_been_sent IM s m.
Proof.
  intros s m.
  split.
  - intros [Hsent | Hemit].
    + by apply sent_by_non_equivocating_are_sent in Hsent.
    + by apply sub_no_indices_no_can_emit in Hemit; [| apply elements_empty].
  - intros Hsent.
    left.
    destruct Hsent as [i Hsent].
    exists i; split; [| done].
    by rewrite elem_of_elements; apply not_elem_of_empty.
Qed.

Lemma strong_fixed_equivocation_constraint_no_equivocators
  : forall l som,
    strong_fixed_equivocation_constraint IM (@empty Ci _) l som <->
    composite_no_equivocations IM l som.
Proof.
  intros.
  destruct som as (s, [m |]); [| done].
  simpl.
  specialize (strong_fixed_equivocation_no_equivocators s m).
  unfold composite_no_equivocations, composite_no_equivocations_except_from, sent_except_from.
  by cbn; itauto.
Qed.

Lemma strong_fixed_equivocation_vlsm_composition_no_equivocators
  : VLSM_eq (strong_fixed_equivocation_vlsm_composition IM (@empty Ci _))
      (composite_vlsm IM (composite_no_equivocations IM)).
Proof.
  split.
  - apply constraint_subsumption_incl.
    apply preloaded_constraint_subsumption_stronger.
    apply strong_constraint_subsumption_strongest.
    intros l som.
    by rewrite strong_fixed_equivocation_constraint_no_equivocators.
  - apply constraint_subsumption_incl.
    apply preloaded_constraint_subsumption_stronger.
    apply strong_constraint_subsumption_strongest.
    intros l som.
    by rewrite strong_fixed_equivocation_constraint_no_equivocators.
Qed.

Lemma fixed_equivocation_vlsm_composition_no_equivocators
  : VLSM_eq (fixed_equivocation_vlsm_composition IM (@empty Ci _))
      (composite_vlsm IM (composite_no_equivocations IM)).
Proof.
  eapply VLSM_eq_trans.
  - by apply Fixed_eq_StrongFixed.
  - by apply strong_fixed_equivocation_vlsm_composition_no_equivocators.
Qed.

End sec_fixed_equivocation_no_equivocators.

Section sec_fixed_non_equivocator_lifting.

Context
  {message : Type}
  `{FinSet index Ci}
  `{finite.Finite index}
  (IM : index -> VLSM message)
  `{forall i, HasBeenSentCapability (IM i)}
  `{forall i, HasBeenReceivedCapability (IM i)}
  (equivocators : Ci)
  (non_equivocators := list_to_set (enum index) ∖ equivocators)
  (Free := free_composite_vlsm IM)
  (Fixed := fixed_equivocation_vlsm_composition IM equivocators)
  (FixedNonEquivocating := pre_induced_sub_projection IM (elements non_equivocators)
                                (fixed_equivocation_constraint IM equivocators))
  (StrongFixed := strong_fixed_equivocation_vlsm_composition IM equivocators)
  (StrongFixedNonEquivocating := pre_induced_sub_projection IM (elements non_equivocators)
                                (strong_fixed_equivocation_constraint IM equivocators))
  (PreFree := pre_loaded_with_all_messages_vlsm Free)
  .

(**
  All valid traces in the induced projection of the composition under the
  strong fixed-equivocation constraint to the non-equivocating nodes can be lifted
  to valid traces of the constrained composition.
*)
Lemma lift_strong_fixed_non_equivocating
  : VLSM_embedding StrongFixedNonEquivocating StrongFixed
    (lift_sub_label IM (elements non_equivocators))
    (lift_sub_state IM (elements non_equivocators)).
Proof.
  apply induced_sub_projection_lift.
  intros s1 s2 Heq l om.
  destruct om as [m |]; [| by itauto].
  cut
    (forall m, sent_by_non_equivocating IM equivocators s1 m ->
      sent_by_non_equivocating IM equivocators s2 m).
  {
    intros Hsent_impl [[j [Hj Hsent]] | Hemit].
    - by left; apply Hsent_impl; exists j.
    - right. revert Hemit.
      by apply VLSM_incl_can_emit, pre_loaded_vlsm_incl.
  }
  clear m.
  intros m [i [Hi Hsent]].
  exists i. split; [done |].
  replace (s2 i) with (s1 i); [done |].
  assert (Hi' : i ∈ elements non_equivocators).
  {
    apply elem_of_elements, elem_of_difference.
    rewrite elem_of_list_to_set.
    split.
    - by apply elem_of_enum.
    - by rewrite <- elem_of_elements.
  }
  by eapply f_equal_dep with (x := dexist i Hi') in Heq.
Qed.

(**
  All valid traces in the induced projection of the composition under the
  fixed-equivocation constraint to the non-equivocating nodes can be lifted
  to valid traces of the constrained composition.
*)
Lemma lift_fixed_non_equivocating
  : VLSM_embedding FixedNonEquivocating Fixed
    (lift_sub_label IM (elements non_equivocators))
    (lift_sub_state IM (elements non_equivocators)).
Proof.
  constructor.
  intros sX trX Htr.
  apply
    (VLSM_incl_finite_valid_trace
      (StrongFixed_incl_Fixed IM equivocators)).
  apply (VLSM_embedding_finite_valid_trace lift_strong_fixed_non_equivocating).
  revert Htr.
  apply VLSM_incl_finite_valid_trace.
  apply induced_sub_projection_constraint_subsumption_incl.
  by apply fixed_strong_equivocation_subsumption.
Qed.

Lemma fixed_non_equivocating_projection_friendliness
  : projection_friendly_prop
      (induced_sub_projection_is_projection IM (elements non_equivocators)
        (fixed_equivocation_constraint IM equivocators)).
Proof.
  apply induced_sub_projection_friendliness.
  by apply lift_fixed_non_equivocating.
Qed.

(**
  The valid traces of the induced projection of the composition under the
  fixed-equivocation constraint to the non-equivocating nodes are precisely
  projections of traces of the constrained composition.
*)
Lemma fixed_non_equivocating_traces_char is tr
  : finite_valid_trace FixedNonEquivocating is tr <->
    exists eis etr,
    finite_valid_trace Fixed eis etr /\
    composite_state_sub_projection IM (elements non_equivocators) eis = is /\
    finite_trace_sub_projection IM (elements non_equivocators) etr = tr.
Proof.
  apply (projection_friendly_trace_char (induced_sub_projection_is_projection _ _ _)).
  by apply fixed_non_equivocating_projection_friendliness.
Qed.

End sec_fixed_non_equivocator_lifting.


From Coq Require Import List.
Import List.ListNotations.
Open Scope list_scope.
From Coq Require Import Sorting.Permutation.
From Coq Require Import Setoid.
From Coq Require Import Morphisms.
From Coq Require Import Program.Tactics.
From Coq Require Import NPeano.
From Coq Require Import Omega.

From Coq Require Import FSets.FMapPositive.
From Velus Require Import Common.
From Velus Require Import Environment.
From Velus Require Import Operators.
From Velus Require Import Clocks.
From Velus Require Import CoreExpr.CESyntax.
From Velus Require Import NLustre.NLSyntax.
From Velus Require Import NLustre.NLOrdered.
From Velus Require Import IndexedStreams.
From Velus Require Import CoindStreams.
From Velus Require Import IndexedToCoind.

From Velus Require Import CoreExpr.CESemantics.
From Velus Require Import CoreExpr.CEInterpreter.
From Velus Require Import NLustre.NLIndexedSemantics.
From Velus Require Import NLustre.NLCoindSemantics.

From Coq Require Import Setoid.

Module Type NLINDEXEDTOCOIND
       (Import Ids    : IDS)
       (Import Op     : OPERATORS)
       (Import OpAux  : OPERATORS_AUX          Op)
       (Import CESyn  : CESYNTAX               Op)
       (Import Syn    : NLSYNTAX           Ids Op       CESyn)
       (Import IStr   : INDEXEDSTREAMS         Op OpAux)
       (Import CStr   : COINDSTREAMS           Op OpAux)
       (Import ICStr  : INDEXEDTOCOIND         Op OpAux IStr CStr)
       (Import Ord    : NLORDERED          Ids Op       CESyn Syn)
       (CESem         : CESEMANTICS        Ids Op OpAux CESyn     IStr)
       (Indexed       : NLINDEXEDSEMANTICS Ids Op OpAux CESyn Syn IStr Ord CESem)
       (Import Interp : CEINTERPRETER      Ids Op OpAux CESyn     IStr     CESem)
       (CoInd         : NLCOINDSEMANTICS   Ids Op OpAux CESyn Syn CStr Ord).

  Section Global.

    Variable G : global.

    (** * SEMANTICS CORRESPONDENCE *)

    (** ** Variables *)

    (* (** An inversion principle for [sem_var]. *) *)
    (* Lemma sem_var_inv: *)
    (*   forall H x xs, *)
    (*     CESem.sem_var H x xs -> *)
    (*     exists xs', *)
    (*       Env.find x H = Some xs' *)
    (*       /\ xs ≈ xs'. *)
    (* Proof. *)
    (*   unfold CESem.sem_var, CESem.lift'. *)
    (*   intros * Sem. *)
    (*   destruct (Env.find x H) as [xs'|] eqn: E; simpl in *. *)
    (*   - exists xs'; intuition. *)
    (*     intro n; specialize (Sem n). *)
    (*     unfold CESem.sem_var_instant, CESem.restr_hist in Sem. *)
    (*     rewrite Env.Props.P.F.map_o in Sem. *)
    (*     setoid_rewrite E in Sem. *)
    (*     now inv Sem. *)
    (*   - specialize (Sem 0). *)
    (*     unfold CESem.sem_var_instant, CESem.restr_hist in Sem. *)
    (*     rewrite Env.Props.P.F.map_o in Sem. *)
    (*     now setoid_rewrite E in Sem. *)
    (* Qed. *)

    (** An inversion principle for [sem_vars]. *)
    Lemma sem_vars_inv_from:
      forall H xs xss,
        CESem.sem_vars H xs xss ->
        forall n,
          Forall2 (fun x k => IStr.sem_var H x (streams_nth k xss))
                  (skipn n xs) (seq n (length xs - n)).
    Proof.
      unfold CESem.sem_vars, IStr.lift.
      intros * Sem n.
      apply Forall2_forall2; split.
      - now rewrite skipn_length, seq_length.
      - intros x_d k_d n' x k Length Hskipn Hseq.
        rewrite skipn_length in Length.
        rewrite nth_skipn in Hskipn.
        rewrite nth_seq in Hseq; auto; subst.
        intro m; specialize (Sem m).
        apply Forall2_forall2 in Sem.
        eapply Sem; eauto.
        + now apply Nat.lt_add_lt_sub_r.
        + unfold streams_nth; eauto.
    Qed.

    Corollary sem_vars_inv:
      forall H xs xss,
        CESem.sem_vars H xs xss ->
        Forall2 (fun x k => IStr.sem_var H x (streams_nth k xss))
                xs (seq 0 (length xs)).
    Proof.
      intros * Sem; apply sem_vars_inv_from with (n:=0) in Sem.
      now rewrite Nat.sub_0_r in Sem.
    Qed.

    Corollary sem_vars_impl_from:
      forall n H xs xss,
      CESem.sem_vars H xs xss ->
      Forall2 (sem_var (tr_history_from n H)) xs (tr_streams_from n xss).
    Proof.
      intros * Sem.
      assert (length xs = length (xss n)) as Length by
            (unfold CESem.sem_vars, IStr.lift in Sem; specialize (Sem n);
             now apply Forall2_length in Sem).
      apply Forall2_forall2; split.
      - now rewrite tr_streams_from_length.
      - apply sem_vars_inv in Sem.
        intros x_d xs_d n' x xs' En' Ex Exs'.
        apply Forall2_forall2 in Sem as (? & Sem).
        assert (nth n' (seq 0 (length xs)) 0 = n') as Nth by
              (rewrite <-(Nat.sub_0_r (length xs)), plus_n_O;
               apply nth_seq; rewrite Nat.sub_0_r; auto).
        eapply Sem in Nth; eauto.
        apply (sem_var_impl_from n) in Nth.
        subst.
        rewrite nth_tr_streams_from_nth; auto.
        now rewrite <-Length.
    Qed.

    Corollary sem_vars_impl:
      forall H xs xss,
      CESem.sem_vars H xs xss ->
      Forall2 (sem_var (tr_history H)) xs (tr_streams xss).
    Proof. apply sem_vars_impl_from. Qed.
    Hint Resolve sem_vars_impl_from sem_vars_impl.

    (** ** exp level synchronous operators inversion principles

        The indexed semantics is inductive only instant-speaking, therefore we
        can't use usual tactics like inversion nor induction.
        We prove some lemmas to provide inversion-like tactics on the semantics
        of exps.
        These lemmas could be proven using the classical axiom of choice which
        gives, from an instant semantics entailment true at every instant,
        the existence of a stream verifying the general entailment.
        But we rather use the interpretor to seq_streams these witnesses, with 2
        benefits :
        1) this is a constructive way of obtaining a witness
        2) we don't rely on an axiom whose use would have to be be deeply
           justified since it would raise some logical contradictions in Coq
     *)

    (** This tactic automatically uses the interpretor to give a witness stream. *)
    Ltac interp_str b H x Sem :=
      let Sem_x := fresh "Sem_" x in
      let sol sem interp sound :=
          assert (sem b H x (interp b H x)) as Sem_x
              by (intro; match goal with n:nat |- _ => specialize (Sem n) end;
                  unfold interp, lift_interp; inv Sem; erewrite <-sound; eauto)
      in
      let sol' sem interp sound :=
          assert (sem H x (interp H x)) as Sem_x
              by (intro; match goal with n:nat |- _ => specialize (Sem n) end;
                  unfold interp, lift_interp'; inv Sem; erewrite <-sound; eauto)
      in
      match type of x with
      | exp => sol CESem.sem_exp interp_exp interp_exp_instant_sound
      | cexp => sol CESem.sem_cexp interp_cexp interp_cexp_instant_sound
      | ident => sol' IStr.sem_var interp_var interp_var_instant_sound
      | clock => sol IStr.sem_clock interp_clock interp_clock_instant_sound
      end.

    Lemma when_inv:
      forall H b e x k es,
        CESem.sem_exp b H (Ewhen e x k) es ->
        exists ys xs,
          CESem.sem_exp b H e ys
          /\ IStr.sem_var H x xs
          /\
          (forall n,
              (exists sc xc,
                  val_to_bool xc = Some k
                  /\ ys n = present sc
                  /\ xs n = present xc
                  /\ es n = present sc)
              \/
              (exists sc xc,
                  val_to_bool xc = Some (negb k)
                  /\ ys n = present sc
                  /\ xs n = present xc
                  /\ es n = absent)
              \/
              (ys n = absent
               /\ xs n = absent
               /\ es n = absent)).
    Proof.
      intros * Sem.
      interp_str b H e Sem.
      interp_str b H x Sem.
      do 2 eexists; intuition; eauto.
      specialize (Sem_e n); specialize (Sem_x n); specialize (Sem n); inv Sem.
      - left. exists sc, xc. repeat split; auto;
                               intuition CESem.sem_det.
      - right; left; exists sc, xc; intuition; try CESem.sem_det.
        now rewrite Bool.negb_involutive.
      - right; right; repeat split; auto; intuition CESem.sem_det.
    Qed.

    Lemma unop_inv:
      forall H b op e ty es,
        CESem.sem_exp b H (Eunop op e ty) es ->
        exists ys,
          CESem.sem_exp b H e ys
          /\
          (forall n,
              (exists c c',
                  ys n = present c
                  /\ sem_unop op c (typeof e) = Some c'
                  /\ es n = present c')
              \/
              (ys n = absent
               /\ es n = absent)).
    Proof.
      intros * Sem.
      interp_str b H e Sem.
      eexists; intuition; eauto.
      specialize (Sem_e n); specialize (Sem n); inv Sem.
      - left; exists c, c'; repeat split; auto; intuition CESem.sem_det.
      - right; repeat split; intuition CESem.sem_det.
    Qed.

    Lemma binop_inv:
      forall H b op e1 e2 ty es,
        CESem.sem_exp b H (Ebinop op e1 e2 ty) es ->
        exists ys zs,
          CESem.sem_exp b H e1 ys
          /\ CESem.sem_exp b H e2 zs
          /\
          (forall n,
              (exists c1 c2 c',
                  ys n = present c1
                  /\ zs n = present c2
                  /\ sem_binop op c1 (typeof e1) c2 (typeof e2) = Some c'
                  /\ es n = present c')
              \/
              (ys n = absent
               /\ zs n = absent
               /\ es n = absent)).
    Proof.
      intros * Sem.
      interp_str b H e1 Sem.
      interp_str b H e2 Sem.
      do 2 eexists; intuition; eauto.
      specialize (Sem_e1 n); specialize (Sem_e2 n); specialize (Sem n); inv Sem.
      - left; exists c1, c2, c'; repeat split; auto; intuition CESem.sem_det.
      - right; repeat split; auto; intuition CESem.sem_det.
    Qed.

    (** ** Semantics of exps *)

    Ltac use_spec Spec :=
      match goal with
        n: nat |- _ =>
        let m := fresh "m" in
        intro m; repeat rewrite init_from_nth;
        specialize (Spec (m + n));
        repeat match goal with
                 H: _ \/ _ |- _ => destruct H
               end;
        destruct_conjs; firstorder
      end.

    (** State the correspondence for [exp].
        Goes by induction on [exp] and uses the previous inversion lemmas. *)
    Hint Constructors when lift1 lift2.
    Lemma sem_exp_impl_from:
      forall n H b e es,
        CESem.sem_exp b H e es ->
        CoInd.sem_exp (tr_history_from n H) (tr_stream_from n b) e
                       (tr_stream_from n es).
    Proof.
      intros * Sem.
      revert dependent H; revert b es n.
      induction e; intros * Sem; unfold CESem.sem_exp, lift in Sem.

      - constructor.
        apply const_spec; use_spec Sem; inv Sem; auto.

      - constructor.
        apply sem_var_impl_from.
        intros n'; specialize (Sem n').
        now inv Sem.

      - apply when_inv in Sem as (ys & xs & ? & ? & Spec).
        econstructor; eauto using sem_var_impl_from.
        apply when_spec; use_spec Spec.

      - apply unop_inv in Sem as (ys & ? & Spec).
        econstructor; eauto.
        apply lift1_spec; use_spec Spec.

      - apply binop_inv in Sem as (ys & zs & ? & ? & Spec).
        econstructor; eauto.
        apply lift2_spec; use_spec Spec.
    Qed.

    Corollary sem_exp_impl:
      forall H b e es,
        CESem.sem_exp b H e es ->
        CoInd.sem_exp (tr_history H) (tr_stream b) e (tr_stream es).
    Proof. apply sem_exp_impl_from. Qed.
    Hint Resolve sem_exp_impl_from sem_exp_impl.

    (** An inversion principle for lists of [exp]. *)
    Lemma sem_exps_inv:
      forall H b es ess,
        CESem.sem_exps b H es ess ->
        exists ess',
          Forall2 (CESem.sem_exp b H) es ess'
          /\ forall n, ess n = List.map (fun es => es n) ess'.
    Proof.
      intros * Sem.
      exists (interp_exps' b H es); split.
      - eapply interp_exps'_sound; eauto.
      - intro n; specialize (Sem n); induction Sem; simpl; auto.
        f_equal; auto.
        unfold interp_exp; now apply interp_exp_instant_sound.
    Qed.

    (** Generalization for lists of [exp]. *)
    Corollary sem_exps_impl_from:
      forall n H b es ess,
        CESem.sem_exps b H es ess ->
        Forall2 (CoInd.sem_exp (tr_history_from n H) (tr_stream_from n b)) es
                (tr_streams_from n ess).
    Proof.
      intros * Sem.
      apply sem_exps_inv in Sem as (ess' & Sem & Eess').
      assert (length es = length (ess n)) as Length by
          (rewrite Eess', map_length; simpl; eapply Forall2_length; eauto).
      apply Forall2_forall2; split.
      - unfold_tr_streams; rewrite seq_streams_length; simpl; omega.
      - intros; subst.
        rewrite nth_tr_streams_from_nth; try omega.
        apply sem_exp_impl_from.
        eapply (Forall2_forall2_eq _ _ (@eq_refl exp) (eq_str_refl))
          in Sem as (? & Sem).
        + eapply Sem; eauto.
          unfold streams_nth.
          intros k; rewrite Eess'.
          change absent with ((fun es => es k) (fun _ => absent)).
          rewrite map_nth; eauto.
        + unfold CESem.sem_exp; clear.
          intros ?? E ?? E' Sem; subst.
          eapply CESem.lift_eq_str; eauto; reflexivity.
    Qed.

    Corollary sem_exps_impl:
      forall H b es ess,
        CESem.sem_exps b H es ess ->
        Forall2 (CoInd.sem_exp (tr_history H) (tr_stream b)) es (tr_streams ess).
    Proof. apply sem_exps_impl_from. Qed.
    Hint Resolve sem_exps_impl_from sem_exps_impl.

    (** An inversion principle for annotated [exp]. *)
    Lemma sem_aexp_inv:
      forall H b e es ck,
        CESem.sem_aexp b H ck e es ->
        CESem.sem_exp b H e es
        /\ exists bs,
            IStr.sem_clock b H ck bs
            /\ forall n,
              bs n = match es n with
                     | present _ => true
                     | absent => false
                     end.
    Proof.
      intros * Sem; split.
      - intro n; specialize (Sem n); inv Sem; auto.
      - exists (fun n => match es n with
                 | present _ => true
                 | absent => false
                 end); split; intro n; specialize (Sem n); inv Sem; auto.
    Qed.

    (** We deduce from the previous lemmas the correspondence for annotated
        [exp]. *)
    Corollary sem_aexp_impl_from:
      forall n H b e es ck,
        CESem.sem_aexp b H ck e es ->
        CoInd.sem_aexp (tr_history_from n H) (tr_stream_from n b) ck e
                        (tr_stream_from n es).
    Proof.
      cofix Cofix; intros * Sem.
      pose proof Sem as Sem';
        apply sem_aexp_inv in Sem' as (Sem' & bs & Sem_ck & Ebs);
        apply (sem_exp_impl_from n) in Sem';
        apply sem_clock_impl_from with (n:=n) in Sem_ck.
      rewrite (init_from_n es) in *.
      rewrite (init_from_n bs), Ebs in Sem_ck.
      destruct (es n); econstructor; eauto;
        rewrite init_from_tl, tr_history_from_tl;
        apply Cofix; auto.
    Qed.

    Corollary sem_aexp_impl:
      forall H b e es ck,
        CESem.sem_aexp b H ck e es ->
        CoInd.sem_aexp (tr_history H) (tr_stream b) ck e (tr_stream es).
    Proof. apply sem_aexp_impl_from. Qed.
    Hint Resolve sem_aexp_impl_from sem_aexp_impl.

    (** ** cexp level synchronous operators inversion principles *)

    Lemma merge_inv:
      forall H b x t f es,
        CESem.sem_cexp b H (Emerge x t f) es ->
        exists xs ts fs,
          IStr.sem_var H x xs
          /\ CESem.sem_cexp b H t ts
          /\ CESem.sem_cexp b H f fs
          /\
          (forall n,
              (exists c,
                  xs n = present true_val
                  /\ ts n = present c
                  /\ fs n = absent
                  /\ es n = present c)
              \/
              (exists c,
                  xs n = present false_val
                  /\ ts n = absent
                  /\ fs n = present c
                  /\ es n = present c)
              \/
              (xs n = absent
               /\ ts n = absent
               /\ fs n = absent
               /\ es n = absent)).
    Proof.
      intros * Sem.
      interp_str b H x Sem.
      interp_str b H t Sem.
      interp_str b H f Sem.
      do 3 eexists; intuition; eauto.
      specialize (Sem_x n); specialize (Sem_t n); specialize (Sem_f n);
        specialize (Sem n); inv Sem.
      - left; exists c; repeat split; auto; intuition CESem.sem_det.
      - right; left; exists c; repeat split; auto; intuition CESem.sem_det.
      - right; right; repeat split; auto; intuition CESem.sem_det.
    Qed.

    Lemma ite_inv:
      forall H b le t f es,
        CESem.sem_cexp b H (Eite le t f) es ->
        exists les ts fs,
          CESem.sem_exp b H le les
          /\ CESem.sem_cexp b H t ts
          /\ CESem.sem_cexp b H f fs
          /\
          (forall n,
              (exists c b ct cf,
                  les n = present c
                  /\ val_to_bool c = Some b
                  /\ ts n = present ct
                  /\ fs n = present cf
                  /\ es n = if b then present ct else present cf)
              \/
              (les n = absent
               /\ ts n = absent
               /\ fs n = absent
               /\ es n = absent)).
    Proof.
      intros * Sem.
      interp_str b H le Sem.
      interp_str b H t Sem.
      interp_str b H f Sem.
      do 3 eexists; intuition; eauto.
      specialize (Sem_le n); specialize (Sem_t n); specialize (Sem_f n);
        specialize (Sem n); inv Sem.
      - left; exists c, b0, ct, cf; repeat split; auto; intuition CESem.sem_det.
      - right; repeat split; auto; intuition CESem.sem_det.
    Qed.

    Lemma exp_inv:
      forall H b le es,
        CESem.sem_cexp b H (Eexp le) es ->
        CESem.sem_exp b H le es.
    Proof.
      intros * Sem n.
      now specialize (Sem n); inv Sem.
    Qed.

    (** [fby] is not a predicate but a function, so we directly state the
        correspondence.  *)
    Lemma fby_impl_from:
      forall n c xs,
        tr_stream_from n (Indexed.fby c xs) ≡
        sfby (Indexed.hold c xs n) (tr_stream_from n xs).
    Proof.
      cofix Cofix; intros.
      rewrite init_from_n; rewrite (init_from_n xs).
      unfold Indexed.fby at 1.
      destruct (xs n) eqn: E.
      - constructor; simpl; auto.
        rewrite Indexed.hold_abs; auto.
      - constructor; simpl; auto.
        erewrite (Indexed.hold_pres v); eauto.
    Qed.

    Corollary fby_impl:
      forall c xs,
      tr_stream (Indexed.fby c xs) ≡ sfby c (tr_stream xs).
    Proof.
      now setoid_rewrite fby_impl_from.
    Qed.

    (** ** Semantics of cexps *)

    (** State the correspondence for [cexp].
        Goes by induction on [cexp] and uses the previous inversion lemmas. *)
    Hint Constructors merge ite.
    Lemma sem_cexp_impl_from:
      forall n H b e es,
        CESem.sem_cexp b H e es ->
        CoInd.sem_cexp (tr_history_from n H) (tr_stream_from n b) e
                       (tr_stream_from n es).
    Proof.
      intros * Sem.
      revert dependent H; revert b es n.
      induction e; intros * Sem; unfold CESem.sem_cexp, IStr.lift in Sem.

      - apply merge_inv in Sem as (xs & ts & fs & ? & ? & ? & Spec).
        econstructor; eauto.
        apply merge_spec; use_spec Spec.

      - apply ite_inv in Sem as (bs & ts & fs & ? & ? & ? & Spec).
        econstructor; eauto.
        apply ite_spec; use_spec Spec.
        destruct H4.
        + apply val_to_bool_true' in H8; subst; firstorder.
        + apply val_to_bool_false' in H8; subst; firstorder.

      - apply exp_inv in Sem; constructor; auto.
    Qed.

    Corollary sem_cexp_impl:
      forall H b e es,
        CESem.sem_cexp b H e es ->
        CoInd.sem_cexp (tr_history H) (tr_stream b) e (tr_stream es).
    Proof. apply sem_cexp_impl_from. Qed.
    Hint Resolve sem_cexp_impl_from sem_cexp_impl.

    (** An inversion principle for annotated [cexp]. *)
    Lemma sem_caexp_inv:
      forall H b e es ck,
        CESem.sem_caexp b H ck e es ->
        CESem.sem_cexp b H e es
        /\ exists bs,
            IStr.sem_clock b H ck bs
            /\ (forall n, bs n = match es n with
                           | present _ => true
                           | absent => false
                           end).
    Proof.
      intros * Sem; split.
      - intro n; specialize (Sem n); inv Sem; auto.
      - exists (fun n => match es n with
                 | present _ => true
                 | absent => false
                 end); split; intro n; specialize (Sem n); inv Sem; auto.
    Qed.

    (** We deduce from the previous lemmas the correspondence for annotated
        [cexp]. *)
    Corollary sem_caexp_impl_from:
      forall n H b e es ck,
        CESem.sem_caexp b H ck e es ->
        CoInd.sem_caexp (tr_history_from n H) (tr_stream_from n b) ck e
                        (tr_stream_from n es).
    Proof.
      cofix Cofix; intros * Sem.
      pose proof Sem as Sem';
        apply sem_caexp_inv in Sem' as (Sem' & bs & Sem_ck & Ebs);
        apply (sem_cexp_impl_from n) in Sem';
        apply sem_clock_impl_from with (n:=n) in Sem_ck.
      rewrite (init_from_n es) in *.
      rewrite (init_from_n bs), Ebs in Sem_ck.
      destruct (es n); econstructor; eauto;
        rewrite init_from_tl, tr_history_from_tl;
        apply Cofix; auto.
    Qed.

    Corollary sem_caexp_impl:
      forall H b e es ck,
        CESem.sem_caexp b H ck e es ->
        CoInd.sem_caexp (tr_history H) (tr_stream b) ck e (tr_stream es).
    Proof. apply sem_caexp_impl_from. Qed.
    Hint Resolve sem_caexp_impl_from sem_caexp_impl.

    (** * RESET CORRESPONDENCE  *)

    (** We state the correspondence for [bools_of]. *)
    Lemma bools_of_impl_from:
      forall n xs rs,
        CESem.bools_of xs rs ->
        CStr.bools_of (tr_stream_from n xs) (tr_stream_from n rs).
    Proof.
      cofix Cofix; intros * Rst.
      pose proof Rst.
      specialize (Rst n).
      rewrite (init_from_n xs), (init_from_n rs).
      destruct (xs n); constructor; auto.
    Qed.

    Corollary bools_of_impl:
      forall xs rs,
        CESem.bools_of xs rs ->
        CStr.bools_of (tr_stream xs) (tr_stream rs).
    Proof. apply bools_of_impl_from. Qed.

    (** ** Properties about [count] and [mask] *)

    (** State the correspondance for [count].  *)
    Lemma count_impl_from:
      forall n (r: stream bool),
        count_acc (if r n then IStr.count r n - 1 else IStr.count r n)
                  (tr_stream_from n r)
        ≡ tr_stream_from n (IStr.count r).
    Proof.
      (* cofix-based proof encounter the guardness criterion (Why ??)  *)
      intros; apply ntheq_eqst; intro m.
      unfold Str_nth; revert n; induction m; intro; simpl.
      - destruct (r n) eqn: R; auto.
        apply count_true_ge_1 in R; rewrite Minus.minus_Sn_m; omega.
      - rewrite <-IHm; simpl; destruct (r n) eqn: R; destruct (r (S n));
          try (apply count_true_ge_1 in R; rewrite Minus.minus_Sn_m; auto);
          try (rewrite Nat.sub_succ, Nat.sub_0_r); auto.
    Qed.

    (** Generalizing is too intricate: we can use the generalized lemma above to
        deduce this one which states the correspondence for [mask]. *)
    Corollary mask_impl:
      forall k (r: stream bool) xss,
        wf_streams xss ->
        EqSts (tr_streams (IStr.mask k r xss))
              (List.map (CStr.mask k (tr_stream r)) (tr_streams xss)).
    Proof.
      intros * Const; unfold tr_streams, tr_stream.
      apply Forall2_forall2; split.
      - rewrite map_length, 2 tr_streams_from_length, mask_length; auto.
      - intros d1 d2 n' xs1 xs2 Len Nth1 Nth2.
        rewrite tr_streams_from_length in Len.
        rewrite <-Nth1, <-Nth2.
        assert (n' < length (tr_streams_from 0 xss)) by
            (rewrite mask_length in Len; auto;
             rewrite tr_streams_from_length; auto).
        rewrite map_nth' with (d':=d2), nth_tr_streams_from_nth; auto.
        rewrite mask_length in Len; auto.
        rewrite nth_tr_streams_from_nth; auto.
        unfold CStr.mask, IStr.mask.
        apply ntheq_eqst; intro m.
        unfold nth_tr_streams_from.
        rewrite init_from_nth, mask_nth, init_from_nth.
        unfold CStr.count, streams_nth.
        pose proof (count_impl_from 0 r) as Count.
        assert ((if r 0 then IStr.count r 0 - 1 else IStr.count r 0) = 0) as E
            by (simpl; destruct (r 0); auto).
        rewrite E in Count; rewrite Count, init_from_nth, Nat.eqb_sym.
        destruct (IStr.count r (m + 0) =? k); auto.
        apply nth_all_absent.
    Qed.

    (** * FINAL LEMMAS *)

    (** Correspondence for [clocks_of], used to give a base clock for node
        applications. *)
    Lemma tr_clocks_of_from:
      forall n xss,
        wf_streams xss ->
        CStr.clocks_of (tr_streams_from n xss) ≡ tr_stream_from n (CESem.clock_of xss).
    Proof.
      cofix Cofix; intros.
      constructor; simpl.
      - unfold CESem.clock_of, CESem.clock_of_instant.
        destruct (existsb (fun v : value => v <>b absent) (xss n)) eqn: E.
        + assert (forall v, v <> absent <-> (v <>b absent) = true)
            by (unfold nequiv_decb; setoid_rewrite Bool.negb_true_iff;
                setoid_rewrite not_equiv_decb_equiv; reflexivity).
          rewrite <-Exists_existsb with (P := fun v => hd v <> absent); auto.
          rewrite <-Exists_existsb with (P := fun v => v <> absent) in E; auto.
          apply Exists_In_tr_streams_from_hd in E; auto.
        + unfold nequiv_decb in *.
          apply existsb_Forall_neg, forallb_Forall in E.
          apply existsb_Forall_neg, forallb_Forall, Forall_forall.
          intros * Hin.
          eapply Forall_In_tr_streams_from_hd in E; eauto.
      - rewrite tr_streams_from_tl; auto.
    Qed.

    Corollary tr_clocks_of:
      forall xss,
        wf_streams xss ->
        CStr.clocks_of (tr_streams xss) ≡ tr_stream (CESem.clock_of xss).
    Proof. apply tr_clocks_of_from. Qed.

    Lemma sem_clocked_var_inv:
      forall b H x xs ck,
        IStr.sem_var H x xs ->
        CESem.sem_clocked_var b H x ck ->
        exists bs,
          IStr.sem_clock b H ck bs
          /\ (forall n, bs n = true <-> xs n <> absent).
    Proof.
      intros * Var Sem.
      assert (IStr.sem_clock b H ck (interp_clock b H ck)) as SemCk.
      { intro n; specialize (Sem n); specialize (Var n); destruct Sem as (Sem & Sem').
        unfold interp_clock, lift_interp.
        destruct (xs n).
        - erewrite <-interp_clock_instant_sound; eauto; apply Sem'; auto.
        - erewrite <-interp_clock_instant_sound; eauto; apply Sem; eauto.
      }
      exists (interp_clock b H ck); split; auto.
      intro n; specialize (Var n); specialize (SemCk n); specialize (Sem n);
        destruct Sem as (Sem & Sem').
      split.
      - intros E E'.
        rewrite E in SemCk; apply Sem in SemCk as (?&?).
        rewrite E' in Var.
        eapply sem_var_instant_det in Var; eauto; discriminate.
      - intro E; apply not_absent_present in E as (?& E).
        rewrite E in Var.
        assert (sem_clock_instant (b n) (H n) ck true)
          by (apply Sem; eauto).
        eapply sem_clock_instant_det; eauto.
    Qed.

    Lemma sem_clocked_var_impl_from:
      forall n H b x xs ck,
        IStr.sem_var H x xs ->
        CESem.sem_clocked_var b H x ck ->
        CoInd.sem_clocked_var (tr_history_from n H) (tr_stream_from n b) x ck.
    Proof.
      intros * Var Sem; eapply sem_clocked_var_inv in Sem as (bs & Clock & Spec); eauto.
      apply sem_var_impl_from with (n := n) in Var;
        apply sem_clock_impl_from with (n := n) in Clock.
      split; eauto.
      intros * Var'.
      eapply sem_var_det in Var; eauto.
      eexists; split; eauto.
      rewrite Var.
      clear - Spec.
      generalize n; clear n.
      cofix COFIX; intros.
      rewrite init_from_n, (init_from_n bs).
      destruct (xs n) eqn: E.
      - assert (bs n = false) as ->
            by (rewrite <-Bool.not_true_iff_false, Spec; auto).
        constructor; auto.
      - assert (bs n = true) as ->
            by (apply Spec; intro; congruence).
        constructor; auto.
    Qed.

    Corollary sem_clocked_var_impl:
      forall H b x xs ck,
        IStr.sem_var H x xs ->
        CESem.sem_clocked_var b H x ck ->
        CoInd.sem_clocked_var (tr_history H) (tr_stream b) x ck.
    Proof. apply sem_clocked_var_impl_from. Qed.

    Lemma sem_clocked_vars_impl:
      forall H b xs xss,
        CESem.sem_vars H (List.map fst xs) xss ->
        CESem.sem_clocked_vars b H xs ->
        CoInd.sem_clocked_vars (tr_history H) (tr_stream b) xs.
    Proof.
      unfold CESem.sem_clocked_vars; intros * Vars Sem.
      apply Forall_forall; intros (x, ck) Hin.
      apply sem_vars_inv in Vars.
      pose proof Hin as Hin'.
      apply in_map with (f := fst) in Hin.
      eapply Forall2_in_left in Vars as (?&?&?); eauto.
      eapply sem_clocked_var_impl; eauto.
      intro n; specialize (Sem n).
      eapply Forall_forall in Sem; eauto.
    Qed.
    Hint Resolve sem_clocked_vars_impl.

    (** The final theorem stating the correspondence for nodes applications.
        We have to use a custom mutually recursive induction scheme [sem_node_mult]. *)
    Hint Constructors CoInd.sem_equation.
    Theorem implies:
      forall f xss oss,
        Indexed.sem_node G f xss oss ->
        CoInd.sem_node G f (tr_streams xss) (tr_streams oss).
    Proof.
      induction 1 as [| |????????????????? IH| |??????????? Heqs IH]
                       using Indexed.sem_node_mult with
          (P_equation := fun b H e =>
                           Indexed.sem_equation G b H e ->
                           CoInd.sem_equation G (tr_history H) (tr_stream b) e);
        eauto.

      - econstructor; eauto.
        rewrite tr_clocks_of; eauto.
        edestruct Indexed.sem_node_wf; eauto.

      - econstructor; eauto.
        + rewrite tr_clocks_of; eauto.
          eapply wf_streams_mask.
          intro k; destruct (IH k) as (Sem &?).
          apply Indexed.sem_node_wf in Sem as (?&?); eauto.
        + apply bools_of_impl; eauto.
        + intro k; destruct (IH k) as (?&?).
          rewrite <- 2 mask_impl; eauto;
            eapply wf_streams_mask; intro n'; destruct (IH n') as (Sem &?);
              apply Indexed.sem_node_wf in Sem as (?&?); eauto.

      - econstructor; eauto; subst.
        rewrite <-fby_impl; eauto.

      - subst.
        CESem.assert_const_length xss.
        econstructor; eauto.
        + rewrite tr_clocks_of; eauto.
          eapply sem_clocked_vars_impl; eauto.
          rewrite map_fst_idck; eauto.
        + apply Forall_forall; intros * Hin.
          rewrite tr_clocks_of; auto.
          eapply Forall_forall in Heqs; eapply Forall_forall in IH; eauto.
    Qed.

  End Global.

End NLINDEXEDTOCOIND.


Require Import CertiGraph.graph.SpaceAdjMatGraph3.

Require Import CertiGraph.dijkstra.dijkstra_env.

(* A separate file with the underlying PQ spec-ed out *)
Require Export CertiGraph.binheap.binary_heap_malloc_spec.
Require Export CertiGraph.binheap.spec_binary_heap_pro.

(* Dijkstra-specific imports *)
Require Import CertiGraph.dijkstra.MathDijkGraph.
Require Export CertiGraph.dijkstra.dijkstra_spec_pure.

(* The first moment we become implementation-specific *)
Require Export CertiGraph.dijkstra.dijkstra3.
Require Import CertiGraph.dijkstra.dijkstra_constants.

Local Open Scope Z_scope.

Section DijkstraSpec.

  Context {Z_EqDec : EquivDec.EqDec Z eq}.

  Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.
  Definition Vprog : varspecs. mk_varspecs prog. Defined.
  Global Existing Instance CompSpecs.

  Definition getCell_spec :=
    DECLARE _getCell
    WITH sh: rshare,
         g: @DijkGG size inf,
         graph_ptr: pointer_val,
         addresses: list val,
         u: V,
         i : V
    PRE [tptr (tarray tint size), tint, tint]
      PROP (0 <= i < size;
          0 <= u < size)
      PARAMS (pointer_val_val graph_ptr;
           Vint (Int.repr u);
           Vint (Int.repr i))
      GLOBALS ()
      SEP (@SpaceAdjMatGraph size CompSpecs sh id g (pointer_val_val graph_ptr))
    POST [tint]
      PROP ()
      RETURN (Vint (Int.repr (Znth i (Znth u (@graph_to_mat size g id)))))
      SEP (@SpaceAdjMatGraph size CompSpecs sh id g (pointer_val_val graph_ptr)).

  Definition dijkstra_spec :=
    DECLARE _dijkstra
    WITH sh: rshare,
         g: DijkGG,
         graph_ptr : pointer_val,
         addresses : list val,
         dist_ptr : pointer_val,
         prev_ptr : pointer_val,
         src : V
    PRE [tptr (tarray tint size), tint, tptr tint, tptr tint]
      PROP (vvalid g src;
           12 * size <= Int.max_unsigned;
           connected_dir g src)
      PARAMS (pointer_val_val graph_ptr;
             Vint (Int.repr src);
             pointer_val_val dist_ptr;
             pointer_val_val prev_ptr)
      GLOBALS ()
      SEP (@SpaceAdjMatGraph size CompSpecs sh id g (pointer_val_val graph_ptr);
          data_at_ Tsh (tarray tint size) (pointer_val_val dist_ptr);
          data_at_ Tsh (tarray tint size) (pointer_val_val prev_ptr))
    POST [tvoid]
      EX prev: list V,
      EX dist: list V,
      PROP (forall dst,
               vvalid g dst ->
               @inv_popped size inf g src (VList g) prev dist dst)
      LOCAL ()
      SEP (@SpaceAdjMatGraph size CompSpecs sh id g (pointer_val_val graph_ptr);
          data_at Tsh (tarray tint size) (map Vint (map Int.repr prev)) (pointer_val_val prev_ptr);
          data_at Tsh (tarray tint size) (map Vint (map Int.repr dist)) (pointer_val_val dist_ptr)).

  Definition Gprog : funspecs :=
    ltac:(with_library prog [
                       getCell_spec;
                       dijkstra_spec;
                       mallocN_spec;
                       freeN_spec;
                       pq_remove_min_nc_spec;
                       pq_insert_nc_spec;
                       pq_size_spec;
                       pq_make_spec;
                       pq_edit_priority_spec;
                       pq_free_spec]).

End DijkstraSpec.


Require Import Coq.omega.Omega.
Require Import Bedrock.Platform.AutoSep.

Lemma allocate_array' : forall p n offset,
  allocated p offset n ===> Ex ls, [| length ls = n |] * array ls (p ^+ $ (offset)).
  induction n; simpl.

  sepLemma.
  instantiate (1 := nil); auto.
  sepLemma.

  intros; sepLemmaLhsOnly.
  etransitivity; [ eapply himp_star_frame; [ apply IHn | reflexivity ] | ]; clear IHn.
  sepLemmaLhsOnly.
  apply himp_ex_c; exists (x :: x0).
  sepLemma.
  etransitivity; [ eapply himp_star_frame; [ apply Arrays.ptsto32m'_in | reflexivity ] | ].
  etransitivity; [ | apply ptsto32m'_out ].
  simpl.
  destruct offset; simpl.
  replace (p ^+ natToW 0) with p by words; sepLemma.
  etransitivity; [ | apply ptsto32m'_shift_base ].
  instantiate (1 := 4); reflexivity.
  auto.
  replace (p ^+ natToW (S offset) ^+ $0) with (p ^+ natToW (S offset)) by words.
  sepLemma.
  etransitivity; [ | apply ptsto32m'_shift_base ].
  instantiate (1 := 4).
  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  replace (S offset + 4) with (S (S (S (S (S offset))))) by omega.
  reflexivity.
  auto.
Qed.

Inductive make_array : Prop := MakeArray.

Hint Constructors make_array.

Lemma allocate_array : forall p n,
  p = p
  -> make_array
  -> p =?> n ===> Ex ls, [| length ls = n |] * array ls p.
  intros; eapply Himp_trans; [ apply allocate_array' | ].
  replace (p ^+ $0) with p by words; apply Himp_refl.
Qed.

Lemma free_array' : forall p n offset,
  Ex ls, [| length ls = n |] * array ls (p ^+ $ (offset)) ===> allocated p offset n.
  sepLemma.
  etransitivity; [ apply ptsto32m_allocated | ].
  etransitivity; [ apply allocated_shift_base | ].
  3: sepLemma.
  unfold natToW; W_eq.
  auto.
Qed.

Inductive dissolve_array : Prop := DissolveArray.

Hint Constructors dissolve_array.

Lemma free_array : forall p n,
  p = p
  -> dissolve_array
  -> Ex ls, [| length ls = n |] * array ls p ===> p =?> n.
  intros; eapply Himp_trans; [ | apply free_array' ].
  replace (p ^+ $0) with p by words; apply Himp_refl.
Qed.

Lemma selN_updN_eq : forall v a n,
  (n < length a)%nat
  -> Array.selN (Array.updN a n v) n = v.
  induction a; destruct n; simpl; intuition.
Qed.

Lemma selN_upd_eq : forall v a n,
  (n < length a)%nat
  -> goodSize (length a)
  -> Array.selN (Array.upd a (natToW n) v) n = v.
  intros; rewrite upd_updN.
  apply selN_updN_eq; auto.
  eauto using goodSize_weaken.
Qed.

Lemma inc : forall n (w : W) l,
  n = wordToNat l
  -> w < natToW n
  -> w ^+ natToW 1 <= l.
  intros; subst.
  assert (exists b, w < b) by eauto.
  pre_nomega.
  destruct H.
  erewrite <- next; eauto.
  unfold natToW in *; rewrite natToWord_wordToNat in *.
  auto.
Qed.

Theorem natToW_wordToNat : forall w : W,
  natToW (wordToNat w) = w.
  intros; apply natToWord_wordToNat.
Qed.

Theorem wordToNat_inj : forall sz (u v : word sz),
  wordToNat u = wordToNat v
  -> u = v.
  intros; rewrite <- (natToWord_wordToNat u); rewrite <- (natToWord_wordToNat v); congruence.
Qed.

Ltac match_locals :=
  match goal with
    | [ _ : context[locals ?NS ?X _ _] |- context[locals ?NS ?Y _ _] ] => equate X Y
  end; descend.

Local Hint Extern 1 (@eq W _ _) => words.


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 D Aprime Bprime Cprime Dprime X Y E Z Eprime : Universe, ((wd_ X A /\ (wd_ X Aprime /\ (wd_ X C /\ (wd_ X Cprime /\ (wd_ Y B /\ (wd_ Y Bprime /\ (wd_ Y D /\ (wd_ Y Dprime /\ (wd_ A C /\ (wd_ B D /\ (wd_ A Aprime /\ (wd_ B Bprime /\ (wd_ C Cprime /\ (wd_ D Dprime /\ (wd_ Aprime Cprime /\ (wd_ Bprime Dprime /\ (wd_ A E /\ (wd_ Aprime Eprime /\ (wd_ B E /\ (wd_ Bprime Eprime /\ (wd_ Y A /\ (wd_ A B /\ (wd_ X B /\ (wd_ Aprime Dprime /\ (wd_ Dprime Eprime /\ (wd_ A D /\ (wd_ D E /\ (wd_ A Eprime /\ (wd_ E Aprime /\ (wd_ E Eprime /\ (wd_ Y E /\ (wd_ Y Z /\ (wd_ B Z /\ (wd_ E Z /\ (wd_ X E /\ (wd_ X Z /\ (wd_ A Z /\ (wd_ X Y /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ Aprime Bprime /\ (col_ X A C /\ (col_ X A Aprime /\ (col_ X A Cprime /\ (col_ Y B D /\ (col_ Y B Bprime /\ (col_ Y B Dprime /\ (col_ E A B /\ (col_ E C D /\ (col_ Eprime Aprime Bprime /\ (col_ Eprime E Z /\ (col_ B Bprime Eprime /\ (col_ E Bprime Eprime /\ col_ Bprime Aprime B))))))))))))))))))))))))))))))))))))))))))))))))))))) -> col_ Aprime Y B)).
Proof.
  time tac.
Qed.

End FOFProblem.