(** * Definition of the part of boolean-returning CFG parser-recognizer that instantiates things to lists *)
Require Import Coq.Lists.List Coq.Strings.String Coq.Arith.Wf_nat.
Require Import Coq.Strings.Ascii.
Require Import Coq.omega.Omega.
Require Import Fiat.Common.StringOperations.
Require Import Fiat.Common.StringFacts.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.Equality.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.BaseTypes Fiat.Parsers.CorrectnessBaseTypes.
Require Import Fiat.Parsers.ContextFreeGrammar.Carriers.
Require Import Fiat.Common.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.List.ListFacts.

Set Implicit Arguments.
Local Open Scope type_scope.
Local Open Scope string_like_scope.

Local Arguments leb !_ !_.

Section recursive_descent_parser_list.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HLSP : StringLikeProperties Char} {G : pregrammar' Char}
          (Char_beq : Char -> Char -> bool).
  Definition rdp_list_nonterminals_listT : Type := list nat.
  Notation rdp_list_nonterminal_carrierT := default_nonterminal_carrierT.
  (** (nonterminal, production_index, drop_count) *)
  Notation rdp_list_production_carrierT := default_production_carrierT.

  Definition list_bin_eq
    := Eval unfold list_bin in list_bin EqNat.beq_nat.

  Definition rdp_list_is_valid_nonterminal : rdp_list_nonterminals_listT -> rdp_list_nonterminal_carrierT -> bool
    := fun ls nt => list_bin_eq nt ls.

  Local Ltac fix_list_bin_eq :=
    unfold rdp_list_is_valid_nonterminal;
    change list_bin_eq with (list_bin EqNat.beq_nat) in *.

  Local Notation valid_nonterminals := (map fst (pregrammar_productions G)).

  Definition rdp_list_initial_nonterminals_data
  : rdp_list_nonterminals_listT
    := up_to (List.length valid_nonterminals).

  Definition rdp_list_of_nonterminal
  : String.string -> rdp_list_nonterminal_carrierT
    := fun nt => first_index_default
                   (string_beq nt)
                   (List.length valid_nonterminals)
                   valid_nonterminals.
  Definition rdp_list_to_nonterminal
  : rdp_list_nonterminal_carrierT -> String.string
    := default_to_nonterminal (G := G).

  Definition rdp_list_to_production : rdp_list_production_carrierT -> production Char
    := default_to_production (G := G).

  Definition rdp_list_nonterminal_to_production : rdp_list_nonterminal_carrierT -> list rdp_list_production_carrierT
    := fun nt_idx
       => List.map
            (fun p_idx : nat => (nt_idx, (p_idx, 0)))
            (up_to (List.length (Lookup G (rdp_list_to_nonterminal nt_idx)))).

  Definition rdp_list_production_tl : rdp_list_production_carrierT -> rdp_list_production_carrierT
    := (default_production_tl (G := G)).

  Local Ltac t' :=
    idtac;
    match goal with
      | _ => assumption
      | _ => omega
      | _ => congruence
      | _ => discriminate
      | [ H : first_index_error _ _ = Some _ |- _ ] => apply first_index_error_Some_correct in H
      | [ H : first_index_error _ _ = None |- _ ] => rewrite first_index_error_None_correct in H
      | _ => intro
      | [ H : and _ _ |- _ ] => destruct H
      | [ H : ex _ |- _ ] => destruct H
      | [ H : string_beq _ _ = true |- _ ] => apply string_bl in H
      | _ => progress subst
      | [ |- nth _ _ _ = _ ] => apply nth_error_Some_nth
      | [ H : ?T |- _ <-> ?T ] => split; [ intro; assumption | intro ]
      | [ H : is_true (list_bin _ _ _) |- _ ] => apply (list_in_bl (@beq_nat_true)) in H
      | [ |- is_true (list_bin _ _ _) ] => apply list_in_lb; [ intros ???; subst; symmetry; apply beq_nat_refl | ]
      | [ H : In _ (up_to _) |- _ ] => apply in_up_to_iff in H
      | [ |- In _ (up_to _) ] => apply in_up_to_iff
      | [ H : In ?nt _ |- _ ] => let H' := fresh in assert (H' : string_beq nt nt = false) by eauto; exfalso; clear -H'
      | [ H : context[string_beq ?x ?x] |- _ ] => rewrite (string_lb eq_refl) in H
      | [ |- _ <-> _ ] => split
      | [ |- In (nth _ ?ls _) ?ls ] => apply nth_In; assumption
      | [ H : nth_error _ _ = Some _ |- _ ]
        => let H' := fresh in
           pose proof H as H';
             apply nth_error_In in H;
             apply nth_error_Some_short in H'
      | [ |- ?x < ?y ] => destruct (le_lt_dec y x); [ exfalso | assumption ]
      | [ H : context[nth ?nt ?ls ?d] |- _ ]
        => rewrite nth_overflow in H by assumption
      | [ H : In some_invalid_nonterminal _ |- _ ]
        => apply some_invalid_nonterminal_invalid in H
      | _ => progress simpl in *
      | [ |- In (nth _ (uniquize ?beq ?ls) _) ?ls ]
        => apply (uniquize_In _ beq)
      | [ H : In ?x (uniquize ?beq ?ls) |- In ?x ?ls ]
        => eapply uniquize_In; eexact H
      | [ H : forall elem, In elem (uniquize ?beq ?ls) -> ?beq ?nt elem = false,
            H' : In ?nt ?ls
            |- _ ]
        => exfalso; specialize (H nt)
      | _ => progress specialize_by ltac:(apply uniquize_In_refl; first [ apply string_lb; reflexivity | apply @string_bl | assumption ])
    end.

  Local Ltac t := repeat t'.

  Definition rdp_list_initial_nonterminals_correct'
  : forall nt,
      is_true (rdp_list_is_valid_nonterminal rdp_list_initial_nonterminals_data nt) <-> List.In (rdp_list_to_nonterminal nt) (Valid_nonterminals G).
  Proof.
    fix_list_bin_eq.
    unfold rdp_list_is_valid_nonterminal, rdp_list_to_nonterminal, rdp_list_initial_nonterminals_data, default_to_nonterminal.
    intro nt.
    t.
  Qed.

  Definition rdp_list_initial_nonterminals_correct
  : forall nt,
      is_true (rdp_list_is_valid_nonterminal rdp_list_initial_nonterminals_data (rdp_list_of_nonterminal nt)) <-> List.In nt (Valid_nonterminals G).
  Proof.
    fix_list_bin_eq.
    unfold rdp_list_is_valid_nonterminal, rdp_list_of_nonterminal, rdp_list_initial_nonterminals_data.
    intro nt.
    rewrite first_index_default_first_index_error.
    destruct (first_index_error (string_beq nt) valid_nonterminals) eqn:H'; t.
  Qed.

  Lemma rdp_list_find_to_nonterminal idx
  : List.first_index_error
      (string_beq (rdp_list_to_nonterminal idx))
      valid_nonterminals
    = bool_rect
        (fun _ => option _)
        (Some idx)
        (None)
        (Compare_dec.leb (S idx) (List.length valid_nonterminals)).
  Proof.
    apply default_find_to_nonterminal.
  Qed.

  Lemma rdp_list_to_of_nonterminal
  : forall nt,
      List.In nt (Valid_nonterminals G)
      -> rdp_list_to_nonterminal (rdp_list_of_nonterminal nt) = nt.
  Proof.
    unfold rdp_list_to_nonterminal, rdp_list_of_nonterminal, default_to_nonterminal.
    intro nt.
    rewrite first_index_default_first_index_error.
    destruct (first_index_error (string_beq nt) valid_nonterminals) eqn:H';
      t.
  Qed.

  Lemma rdp_list_of_to_nonterminal
  : forall nt,
      is_true (rdp_list_is_valid_nonterminal rdp_list_initial_nonterminals_data nt)
      -> rdp_list_of_nonterminal (rdp_list_to_nonterminal nt) = nt.
  Proof.
    pose proof (nonterminals_unique G) as HNoDup.
    hnf in HNoDup.
    simpl in *.
    unfold rdp_list_to_nonterminal, rdp_list_of_nonterminal, rdp_list_is_valid_nonterminal, rdp_list_initial_nonterminals_data, default_to_nonterminal.
    intros nt H.
    apply (list_in_bl (@beq_nat_true)), in_up_to_iff in H.
    revert nt H.
    replace valid_nonterminals with (uniquize string_beq valid_nonterminals) by (rewrite HNoDup; reflexivity).
    induction valid_nonterminals as [|x xs IHxs].
    { simpl; intros; omega. }
    { simpl in *.
      destruct (list_bin string_beq x (uniquize string_beq xs)) eqn:Hbin; try assumption.
      { apply (f_equal (@List.length _)) in HNoDup.
        simpl in *.
        pose proof (uniquize_shorter xs string_beq) as H'.
        rewrite HNoDup in H'.
        exfalso; clear -H'.
        omega. }
      apply (f_equal (@tl _)) in HNoDup; simpl @tl in HNoDup.
      specialize_by assumption.

      intros [|nt].
      { simpl.
        rewrite (string_lb eq_refl); trivial. }
      { simpl Datatypes.length.
        intro H.
        apply lt_S_n in H.
        etransitivity; [ | eapply (f_equal S), (IHxs _ H); clear IHxs ].
        rewrite first_index_default_S_cons; simpl.
        match goal with
          | [ |- context[string_beq ?x ?y] ]
            => destruct (string_beq x y) eqn:H'
        end; simpl;
        [ exfalso | reflexivity ].
        clear -Hbin H H'.
        apply string_bl in H'.
        subst.
        rewrite list_in_lb in Hbin; [ congruence | apply @string_lb | ].
        apply nth_In; assumption. } }
  Qed.

  Definition rdp_list_production_carrier_valid
  : rdp_list_production_carrierT -> bool
    := default_production_carrier_valid (G := G).

  Lemma rdp_list_production_tl_correct
  : forall p,
      rdp_list_to_production (rdp_list_production_tl p) = tl (rdp_list_to_production p).
  Proof.
    unfold rdp_list_to_production, rdp_list_production_tl, default_production_tl, default_to_production; simpl.
    intros [? [? p]]; rewrite tl_drop; simpl.
    do 2 try
       match goal with
         | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?; simpl
       end;
      repeat match goal with
               | _ => destruct p; reflexivity
               | _ => assumption
               | _ => omega
               | [ H : leb _ _ = false |- _ ] => apply leb_iff_conv in H
               | [ H : ?x < 1 |- _ ] => assert (x = 0) by omega; clear H
               | [ H : ?x = 0 |- context[?x] ] => rewrite H
               | [ H : ?x = nil |- context[?x] ] => rewrite H
               | [ H : List.length ?x = 0 |- _ ] => assert (x = nil) by (destruct x; simpl in *; trivial; discriminate); clear H
               | _ => progress simpl in *
               | _ => reflexivity
               | [ H : _ < S _ |- _ ] => apply le_S_n in H
               | _ => rewrite drop_all by assumption
               | [ |- nil = drop _ _ ] => symmetry; apply drop_all
               | [ |- context[List.length (tl ?x)] ] => destruct x eqn:?
             end.
  Qed.

  Local Arguments List.nth _ !_ !_ _.
  Local Arguments minus !_ !_.

  Lemma rdp_list_nonterminal_to_production_correct
  : forall nt,
      List.In nt (Valid_nonterminals G)
      -> List.map rdp_list_to_production (rdp_list_nonterminal_to_production (rdp_list_of_nonterminal nt))
         = Lookup G nt.
  Proof.
    intros nt Hvalid.
    unfold rdp_list_to_production, rdp_list_nonterminal_to_production, default_to_production.
    rewrite map_map; simpl.
    rewrite !rdp_list_to_of_nonterminal by assumption.
    rewrite <- list_to_productions_to_nonterminal.
    change default_to_nonterminal with rdp_list_to_nonterminal.
    rewrite rdp_list_to_of_nonterminal by assumption.
    induction (Lookup_string G nt) as [|p ps IHps]; simpl.
    { reflexivity. }
    { simpl.
      rewrite minus_diag; simpl.
      apply f_equal.
      etransitivity; [ | apply IHps ]; clear IHps.
      apply map_ext_in.
      intros a H; apply in_up_to_iff in H.
      rewrite NPeano.Nat.sub_succ_r.
      destruct (Datatypes.length ps - a) eqn:H'; try omega; [].
      reflexivity. }
  Qed.

  Lemma rdp_list_production_tl_valid
  : forall p,
      rdp_list_production_carrier_valid p -> rdp_list_production_carrier_valid (rdp_list_production_tl p).
  Proof.
    unfold rdp_list_production_carrier_valid, default_production_carrier_valid, rdp_list_production_tl, default_production_tl; simpl; trivial.
    repeat match goal with
             | _ => progress simpl in *
             | _ => intro
             | _ => progress unfold is_true in *
             | [ |- andb ?x ?y = true ] => apply Bool.andb_true_iff
             | [ H : andb ?x ?y = true |- _ ] => apply Bool.andb_true_iff in H
             | [ H : and _ _ |- _ ] => destruct H
             | [ H : ?x = true |- context[?x] ] => rewrite H
             | [ |- ?x = ?x ] => reflexivity
             | [ |- and _ _ ] => split
             | [ |- context[if ?e then _ else _] ] => destruct e eqn:?
           end.
  Qed.

  Local Arguments leb !_ !_.

  Lemma rdp_list_nonterminal_to_production_valid
  : forall nt,
      rdp_list_is_valid_nonterminal rdp_list_initial_nonterminals_data nt
      -> List.Forall rdp_list_production_carrier_valid (rdp_list_nonterminal_to_production nt).
  Proof.
    unfold rdp_list_production_carrier_valid, rdp_list_is_valid_nonterminal, rdp_list_initial_nonterminals_data, rdp_list_nonterminal_to_production.
    intros nt Hnt.
    apply Forall_map, Forall_forall; unfold compose; simpl; intros ? H.
    fix_list_bin_eq.
    apply list_in_bl in Hnt; [ | exact (EqNat.beq_nat_true) ].
    apply in_up_to_iff in Hnt.
    unfold default_production_carrier_valid; simpl.
    repeat (apply Bool.andb_true_iff; split); apply leb_iff.
    { rewrite map_length in Hnt.
      exact Hnt. }
    { apply in_up_to_iff in H.
      rewrite <- list_to_productions_to_nonterminal.
      exact H. }
    { omega. }
  Qed.

  Lemma rdp_list_production_carrier_valid_reachable (idx : rdp_list_production_carrierT)
        (Hvalid : rdp_list_production_carrier_valid idx)
  : production_is_reachable G (rdp_list_to_production idx).
  Proof.
    unfold production_is_reachable, rdp_list_production_carrier_valid, default_production_carrier_valid, rdp_list_production_carrierT in *.
    repeat setoid_rewrite Bool.andb_true_iff in Hvalid.
    repeat setoid_rewrite Compare_dec.leb_iff in Hvalid.
    destruct_head and.
    simpl in *.
    exists (rdp_list_to_nonterminal (fst idx)).
    unfold rdp_list_to_production, default_to_production in *; simpl in *.
    match goal with
      | [ |- appcontext[In (_ ++ Operations.List.drop ?n ?ls)%list _] ]
        => exists (Operations.List.take n ls)
    end.
    rewrite app_take_drop.
    split.
    { apply rdp_list_initial_nonterminals_correct'.
      unfold rdp_list_is_valid_nonterminal, rdp_list_initial_nonterminals_data.
      fix_list_bin_eq.
      apply list_in_lb; [ apply beq_nat_true_iff | ].
      rewrite map_length.
      apply in_up_to; assumption. }
    { unfold rdp_list_to_nonterminal.
      rewrite list_to_productions_to_nonterminal.
      destruct (Lookup_idx G (fst idx)) eqn:Heq.
      { simpl in *.
        omega. }
      { apply nth_In.
        simpl; omega. } }
  Qed.

  Definition filter_out_eq nt ls
    := Eval unfold filter_out in filter_out (EqNat.beq_nat nt) ls.

  Definition rdp_list_remove_nonterminal : rdp_list_nonterminals_listT -> rdp_list_nonterminal_carrierT -> rdp_list_nonterminals_listT
    := fun ls nt =>
         filter_out_eq nt ls.

  Local Ltac fix_filter_out_eq :=
    unfold rdp_list_remove_nonterminal;
    change filter_out_eq with (fun nt ls => filter_out (EqNat.beq_nat nt) ls); cbv beta;
    setoid_rewrite filter_out_filter.

  Local Ltac fix_eqs := try fix_filter_out_eq; try fix_list_bin_eq.

  Definition rdp_list_nonterminals_listT_R : rdp_list_nonterminals_listT -> rdp_list_nonterminals_listT -> Prop
    := ltof _ (@List.length _).
  Lemma filter_list_dec {T} f (ls : list T) : List.length (filter f ls) <= List.length ls.
  Proof.
    induction ls; trivial; simpl in *.
    repeat match goal with
             | [ |- context[if ?a then _ else _] ] => destruct a; simpl in *
             | [ |- S _ <= S _ ] => solve [ apply Le.le_n_S; auto ]
             | [ |- _ <= S _ ] => solve [ apply le_S; auto ]
           end.
  Qed.
  Lemma rdp_list_remove_nonterminal_dec : forall ls prods,
                                            @rdp_list_is_valid_nonterminal ls prods = true
                                            -> @rdp_list_nonterminals_listT_R (@rdp_list_remove_nonterminal ls prods) ls.
  Proof.
    intros ls prods H.
    unfold rdp_list_is_valid_nonterminal, rdp_list_nonterminals_listT_R, rdp_list_remove_nonterminal, ltof in *.
    fix_eqs.
    apply list_in_bl in H; [ | solve [ intros; apply beq_nat_true; trivial ] ].
    match goal with
      | [ H : In ?prods ?ls |- context[filter ?f ?ls] ]
        => assert (~In prods (filter f ls))
    end.
    { intro H'.
      apply filter_In in H'.
      destruct H' as [? H'].
      rewrite <- beq_nat_refl in H'.
      simpl in *; congruence. }
    { match goal with
        | [ |- context[filter ?f ?ls] ] => generalize dependent f; intros
      end.
      induction ls; simpl in *; try congruence.
      repeat match goal with
               | [ |- context[if ?x then _ else _] ] => destruct x; simpl in *
               | [ H : _ \/ _ |- _ ] => destruct H
               | _ => progress subst
               | [ H : ~(_ \/ _) |- _ ] => apply Decidable.not_or in H
               | [ H : _ /\ _ |- _ ] => destruct H
               | [ H : ?x <> ?x |- _ ] => exfalso; apply (H eq_refl)
               | _ => apply Lt.lt_n_S
               | _ => apply Le.le_n_S
               | _ => apply filter_list_dec
               | [ H : _ -> _ -> ?G |- ?G ] => apply H; auto
             end. }
  Qed.
  Lemma rdp_list_ntl_wf : well_founded rdp_list_nonterminals_listT_R.
  Proof.
    unfold rdp_list_nonterminals_listT_R.
    intro.
    apply well_founded_ltof.
  Defined.

  Lemma rdp_list_remove_nonterminal_1
  : forall ls ps ps',
      rdp_list_is_valid_nonterminal (rdp_list_remove_nonterminal ls ps) ps' = true
      -> rdp_list_is_valid_nonterminal ls ps' = true.
  Proof.
    unfold rdp_list_is_valid_nonterminal, rdp_list_remove_nonterminal.
    fix_eqs.
    repeat match goal with
             | _ => exfalso; congruence
             | _ => reflexivity
             | _ => assumption
             | [ |- appcontext[if ?E then _ else _] ] => destruct E
             | _ => intro
             | [ H : In _ (filter _ _) |- _ ] => apply filter_In in H
             | [ H : _ /\ _ |- _ ] => destruct H
             | [ H : ?T, H' : ~?T |- _ ] => destruct (H' H)
             | [ H : list_bin _ _ _ = true |- _ ] => apply list_in_bl in H; [ | solve [ intros; apply beq_nat_true; trivial ] ]
             | [ |- list_bin _ _ _ = true ] => apply list_in_lb
             | _ => progress subst
             | [ |- context[beq_nat ?x ?x] ] => rewrite <- beq_nat_refl
           end.
  Qed.

  Lemma rdp_list_remove_nonterminal_2
  : forall ls ps ps',
      rdp_list_is_valid_nonterminal (rdp_list_remove_nonterminal ls ps) ps' = false
      <-> rdp_list_is_valid_nonterminal ls ps' = false \/ ps = ps'.
  Proof.
    unfold rdp_list_is_valid_nonterminal, rdp_list_remove_nonterminal.
    fix_eqs.
    repeat match goal with
             | _ => exfalso; congruence
             | _ => reflexivity
             | _ => progress subst
             | _ => intro
             | [ H : @eq bool ?x ?y -> False |- _ ] => apply Bool.eq_true_not_negb in H
             | [ H : context[In _ (filter _ _)] |- _ ] => rewrite filter_In in H
             | [ H : _ /\ _ |- _ ] => destruct H
             | [ H : ?T, H' : ~?T |- _ ] => destruct (H' H)
             | [ |- true = false \/ _ ] => right
             | [ |- ?x = ?x \/ _ ] => left; reflexivity
             | [ H : ~(_ /\ ?x = ?x) |- _ ] => specialize (fun y => H (conj y eq_refl))
             | [ H : ~(?T /\ _), H' : ?T |- _ ] => specialize (fun y => H (conj H' y))
             | [ H : (?T /\ _) -> False, H' : ?T |- _ ] => specialize (fun y => H (conj H' y))
             | [ H : _ \/ _ |- _ ] => destruct H
             | [ |- _ <-> _ ] => split
             | [ H : appcontext[match ?E with left _ => _ | right _ => _ end] |- _ ] => destruct E
             | [ |- appcontext[match ?E with left _ => _ | right _ => _ end] ] => destruct E
             | [ H : _ |- _ ] => rewrite Bool.negb_involutive in H
             | [ H : string_beq _ _ = true |- _ ] => apply string_bl in H
             | [ H : context[string_beq ?x ?x] |- _ ] => rewrite (string_lb (eq_refl x)) in H
             | _ => progress simpl in *
             | [ H : list_bin _ _ _ = true |- _ ] => apply list_in_bl in H; [ | solve [ intros; apply beq_nat_true; trivial ] ]
             | [ |- list_bin _ _ _ = true ] => apply list_in_lb
             | [ |- context[list_bin ?x ?y ?z = false] ] => case_eq (list_bin x y z)
             | [ H : list_bin _ _ _ = false |- _ ] => apply Bool.not_true_iff_false in H
             | [ H : list_bin _ _ _ <> true |- _ ] => specialize (fun pf H' => H (list_in_lb pf H'))
             | [ H : ?A -> ?B |- _ ]
               => let H' := fresh in
                  assert (H' : A) by (intros; subst; rewrite <- ?beq_nat_refl; reflexivity);
                    specialize (H H'); clear H'
             | [ H : beq_nat _ _ = true |- _ ] => apply beq_nat_true in H
             | [ H : context[beq_nat ?x ?x] |- _ ] => rewrite <- beq_nat_refl in H
           end.
  Qed.

  Lemma rdp_list_remove_nonterminal_noninc (ls : rdp_list_nonterminals_listT) nonterminal
  : ~ rdp_list_nonterminals_listT_R ls (rdp_list_remove_nonterminal ls nonterminal).
  Proof.
    simpl. unfold ltof, rdp_list_remove_nonterminal.
    fix_eqs.
    intro H.
    cut (Datatypes.length ls < Datatypes.length ls); try omega.
    eapply Lt.lt_le_trans; [ eassumption | ].
    apply filter_list_dec.
  Qed.

  Lemma rdp_list_nonterminals_length_zero
  : forall ls,
      List.length ls = 0
      -> forall nt, rdp_list_is_valid_nonterminal ls nt = false.
  Proof.
    destruct ls; simpl; trivial; intro; exfalso; omega.
  Qed.

  Global Instance rdp_list_predata : @parser_computational_predataT Char
    := { nonterminals_listT := rdp_list_nonterminals_listT;
         initial_nonterminals_data := rdp_list_initial_nonterminals_data;
         of_nonterminal := rdp_list_of_nonterminal;
         to_nonterminal := rdp_list_to_nonterminal;
         production_carrierT := rdp_list_production_carrierT;
         to_production := rdp_list_to_production;
         nonterminal_to_production := rdp_list_nonterminal_to_production;
         production_tl := rdp_list_production_tl;
         production_carrier_valid := rdp_list_production_carrier_valid;
         is_valid_nonterminal := rdp_list_is_valid_nonterminal;
         remove_nonterminal := rdp_list_remove_nonterminal;
         nonterminals_length := @List.length _ }.

  Global Instance rdp_list_rdata' : @parser_removal_dataT' _ G rdp_list_predata
    := { nonterminals_length_zero := rdp_list_nonterminals_length_zero;
         remove_nonterminal_dec := rdp_list_remove_nonterminal_dec;
         remove_nonterminal_noninc := rdp_list_remove_nonterminal_noninc;
         to_of_nonterminal := rdp_list_to_of_nonterminal;
         of_to_nonterminal := rdp_list_of_to_nonterminal;
         production_tl_correct := rdp_list_production_tl_correct;
         nonterminal_to_production_correct := rdp_list_nonterminal_to_production_correct;
         production_tl_valid := rdp_list_production_tl_valid;
         nonterminal_to_production_valid := rdp_list_nonterminal_to_production_valid;
         initial_nonterminals_correct := rdp_list_initial_nonterminals_correct;
         initial_nonterminals_correct' := rdp_list_initial_nonterminals_correct';
         remove_nonterminal_1 := rdp_list_remove_nonterminal_1;
         remove_nonterminal_2 := rdp_list_remove_nonterminal_2 }.
End recursive_descent_parser_list.


Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.

From Equations Require Import Equations.
Set Equations With UIP.

Require Import Category.Lib.

Generalizable All Variables.
Set Transparent Obligations.

(** General utility library providing partial maps, built
    on a foundation isomorphic to association lists. *)

Section Map.

Import ListNotations.

Context {k v : Type}.

Inductive Map : Type :=
  | Add : k → v → Map → Map
  | Empty : Map.

Derive NoConfusion NoConfusionHom Subterm for Map.

Inductive MapsTo `{EqDec k} (i : k) (x : v) : Map -> Prop :=
  | MapsTo_hd i' x' m : i = i' -> x = x' → MapsTo (Add i' x' m)
  | MapsTo_tl i' x' m : i ≠ i' → MapsTo m -> MapsTo (Add i' x' m).

Fixpoint lookup `{EqDec k} (i : k) (m : Map) : option v :=
  match m with
  | Empty => None
  | Add i' x m =>
      if eq_dec i i'
      then Some x
      else lookup i m
  end.

Lemma pneq_dec `{EqDec k} {x y : k} (N : x ≠ y) :
  { N' | eq_dec x y = right N' }.
Proof.
  destruct (eq_dec x y); auto.
  - subst; contradiction.
  - now exists n.
Qed.

Fixpoint MapsTo_lookup `{EqDec k} i x m : MapsTo i x m ↔ lookup i m = Some x.
Proof.
  split; intros.
  - induction H0; subst; simpl.
    + now rewrite peq_dec_refl.
    + destruct (pneq_dec H0).
      now rewrite e.
  - induction m; simpl in *.
    + destruct (eq_dec i k0); subst.
      * inv H0.
        now left.
      * right; auto.
    + discriminate.
Qed.

#[export]
Program Instance Map_Setoid `{EqDec k} : Setoid (Map) := {|
  equiv := λ m1 m2, ∀ k, lookup k m1 = lookup k m2
|}.
Next Obligation.
  constructor; repeat intro; auto.
  transitivity (lookup k0 y); congruence.
Qed.

Fixpoint member `{EqDec k} (i : k) (m : Map) : bool :=
  match m with
  | Empty => false
  | Add i' _ m => if eq_dec i i' then true else member i m
  end.

#[export]
Program Instance member_respects `{EqDec k} :
  Proper (eq ==> equiv ==> eq) member.
Next Obligation.
  repeat intro; subst.
  specialize (H1 y).
  generalize dependent y0.
  induction x0; simpl; intros.
  - destruct (eq_dec y k0) eqn:Heqe; simpl.
    + subst.
      clear -H1.
      induction y0; simpl in *; auto.
      * destruct (eq_dec k0 k1) eqn:Heqe; simpl; auto.
      * congruence.
    + now apply IHx0.
  - induction y0; simpl in *; auto.
    destruct (eq_dec y k0) eqn:Heqe; simpl.
    + congruence.
    + now apply IHy0.
Qed.

Fixpoint toList (m : Map) : list (k * v) :=
  match m with
  | Empty => []
  | Add i x m => (i, x) :: toList m
  end.

Fixpoint fromList (l : list (k * v)) : Map :=
  match l with
  | [] => Empty
  | (i, x) :: xs => Add i x (fromList xs)
  end.

Lemma toList_fromList (l : list (k * v)) : toList (fromList l) = l.
Proof.
  induction l; simpl; auto.
  destruct a; simpl.
  now rewrite IHl.
Qed.

Lemma fromList_toList (m : Map) : fromList (toList m) = m.
Proof.
  induction m; simpl; auto.
  now rewrite IHm.
Qed.

Definition null (m : Map) : bool :=
  if m then false else true.

#[export]
Program Instance null_respects `{EqDec k} : Proper (equiv ==> eq) null.
Next Obligation.
  repeat intro.
  generalize dependent y.
  induction x, y; simpl; intros; auto.
  - specialize (H0 k0).
    rewrite peq_dec_refl in H0.
    discriminate.
  - specialize (H0 k0).
    rewrite peq_dec_refl in H0.
    discriminate.
Qed.

Fixpoint delete `{EqDec k} (i : k) (m : Map) : Map :=
  match m with
  | Empty => m
  | Add i' x m =>
      if eq_dec i i'
      then delete i m
      else Add i' x (delete i m)
  end.

Lemma delete_idem `{EqDec k} i m :
  delete i (delete i m) = delete i m.
Proof.
  induction m; simpl; auto.
  destruct (eq_dec i k0) eqn:Heqe; auto; simpl.
  rewrite Heqe.
  now rewrite IHm.
Qed.

Lemma delete_comm `{EqDec k} i j m :
  delete i (delete j m) = delete j (delete i m).
Proof.
  generalize dependent j.
  generalize dependent i.
  induction m; simpl; intros; auto.
  destruct (eq_dec i k0) eqn:Heqe1; auto; simpl.
  - destruct (eq_dec j k0) eqn:Heqe2; auto; simpl.
    now rewrite Heqe1.
  - destruct (eq_dec j k0) eqn:Heqe2; auto; simpl.
    rewrite Heqe1.
    now rewrite IHm.
Qed.

Fixpoint size (m : Map) : nat :=
  match m with
  | Add _ _ m => 1 + size m
  | Empty => 0
  end.

Lemma size_delete `{EqDec k} i m : (size (delete i m) <= size m)%nat.
Proof.
  induction m; simpl; auto.
  destruct (eq_dec i k0) eqn:Heqe;
  auto; simpl; lia.
Qed.

Equations compress `{EqDec k} (m : Map) : Map by wf (size m) :=
  compress Empty := Empty;
  compress (Add i' x m) := Add i' x (compress (delete i' m)).
Next Obligation.
  specialize (compress H m).
  pose proof (size_delete i' m); lia.
Qed.

Lemma compress_delete `{EqDec k} i m :
  compress (delete i m) = delete i (compress m).
Proof.
  generalize dependent i.
  apply FunctionalElimination_compress;
  simpl; intros; auto.
  destruct (eq_dec i i') eqn:Heqe.
  - subst.
    rewrite <- H1.
    now rewrite delete_idem.
  - simp compress; simpl.
    f_equal.
    rewrite <- H1.
    now rewrite delete_comm.
Qed.

Lemma size_compress `{EqDec k} m : (size (compress m) <= size m)%nat.
Proof.
  induction m; auto.
  simp compress; simpl.
  apply le_n_S.
  rewrite compress_delete.
  now rewrite size_delete.
Qed.

Fixpoint findWithDefault `{EqDec k} (d : v) (i : k) (m : Map) : v :=
  match m with
  | Empty => d
  | Add i' x m =>
      if eq_dec i i'
      then x
      else findWithDefault d i m
  end.

Definition empty : Map := Empty.

Definition singleton (i : k) (x : v) : Map := Add i x empty.

Fixpoint insert `{EqDec k} (i : k) (x : v) (m : Map) : Map :=
  match m with
  | Empty => singleton i x
  | Add i' x' m =>
      if eq_dec i i'
      then Add i x m
      else Add i' x' (insert i x m)
  end.

Lemma lookup_insert `{EqDec k} i j x m :
  lookup i (insert j x m) = if eq_dec i j then Some x else lookup i m.
Proof.
  destruct (eq_dec i j) eqn:Heqe1.
  - induction m; simpl; intros.
    + destruct (eq_dec j k0) eqn:Heqe2; simpl.
      * now rewrite Heqe1.
      * subst.
        now rewrite Heqe2.
    + now destruct (eq_dec i j).
  - induction m; simpl; intros.
    + destruct (eq_dec j k0) eqn:Heqe2; simpl.
      * rewrite Heqe1.
        subst.
        now rewrite Heqe1.
      * now rewrite IHm.
    + now destruct (eq_dec i j).
Qed.

Lemma lookup_delete `{EqDec k} i j m :
  lookup i (delete j m) = if eq_dec i j then None else lookup i m.
Proof.
  induction m; simpl.
  - destruct (eq_dec i j) eqn:Heqe1.
    + destruct (eq_dec j k0) eqn:Heqe2; auto.
      simpl; subst.
      now rewrite Heqe2.
    + destruct (eq_dec j k0) eqn:Heqe2; simpl; auto.
      * subst.
        now rewrite Heqe1.
      * now destruct (eq_dec i k0).
  - now destruct (eq_dec i j).
Qed.

Lemma compress_equiv `{EqDec k} m :
  m ≈ compress m.
Proof.
  apply FunctionalElimination_compress;
  repeat intro; auto.
  simpl in *.
  rewrite <- X.
  rewrite lookup_delete.
  now destruct (eq_dec k0 i').
Qed.

Lemma insert_delete `{EqDec k} i x m :
  insert i x (delete i m) ≈ insert i x m.
Proof.
  induction m; simpl; intros; auto.
  destruct (eq_dec i k0) eqn:Heqe.
  - subst.
    rewrite IHm; clear IHm.
    now rewrite lookup_insert.
  - simpl.
    rewrite Heqe; simpl.
    now rewrite IHm.
Qed.

Fixpoint insertWith `{EqDec k} (f : v → v → v) (i : k) (x : v) (m : Map) : Map :=
  match m with
  | Empty => singleton i x
  | Add i' x' m =>
      if eq_dec i i'
      then Add i (f x x') m
      else insertWith f i x m
  end.

Fixpoint insertWithKey `{EqDec k} (f : k → v → v → v) (i : k) (x : v) (m : Map) : Map :=
  match m with
  | Empty => singleton i x
  | Add i' x' m =>
      if eq_dec i i'
      then Add i (f i x x') m
      else insertWithKey f i x m
  end.

Fixpoint insertLookupWithKey `{EqDec k} (f : k → v → v → v) (i : k) (x : v) (m : Map) :
  option v * Map :=
  match m with
  | Empty => (None, singleton i x)
  | Add i' x' m =>
      if eq_dec i i'
      then (Some x', Add i (f i x x') m)
      else insertLookupWithKey f i x m
  end.

Fixpoint adjust `{EqDec k} (f : v → v) (i : k) (m : Map) : Map :=
  match m with
  | Empty => Empty
  | Add i' x' m =>
      if eq_dec i i'
      then Add i' (f x') m
      else Add i' x' (adjust f i m)
  end.

Fixpoint adjustWithKey `{EqDec k} (f : k → v → v) (i : k) (m : Map) : Map :=
  match m with
  | Empty => Empty
  | Add i' x' m =>
      if eq_dec i i'
      then Add i' (f i' x') m
      else Add i' x' (adjustWithKey f i m)
  end.

Fixpoint alter `{EqDec k} (f : option v → option v) (i : k) (m : Map) : Map :=
  match m with
  | Empty =>
      match f None with
      | None => empty
      | Some v => singleton i v
      end
  | Add i' x' m =>
      if eq_dec i i'
      then
        match f (Some x') with
        | None => m
        | Some v => Add i' v m
        end
      else Add i' x' (alter f i m)
  end.

End Map.

Arguments Map k v : clear implicits.

Fixpoint map `(f : v → b) `(m : Map k v) : Map k b :=
  match m with
  | Empty => Empty
  | Add i x m => Add i (f x) (map f m)
  end.

Fixpoint mapWithKey `(f : k → v → b) (m : Map k v) : Map k b :=
  match m with
  | Empty => Empty
  | Add i x m => Add i (f i x) (mapWithKey f m)
  end.

Fixpoint fold `(f : v → b → b) (z : b) `(m : Map k v) : b :=
  match m with
  | Empty => z
  | Add _ x m => fold f (f x z) m
  end.

Fixpoint foldrWithKey `(f : k → v → b → b) (z : b) (m : Map k v) : b :=
  match m with
  | Empty => z
  | Add i x m => f i x (foldrWithKey f z m)
  end.

Fixpoint foldlWithKey `(f : k → v → b → b) (z : b) (m : Map k v) : b :=
  match m with
  | Empty => z
  | Add i x m => foldlWithKey f (f i x z) m
  end.

Import ListNotations.

Fixpoint elems `(m : Map k v) : list v :=
  match m with
  | Empty => []
  | Add _ x m => x :: elems m
  end.

Fixpoint keys `(m : Map k v) : list k :=
  match m with
  | Empty => []
  | Add i _ m => i :: keys m
  end.

Definition assocs `(m : Map k v) : list (k * v) := toList m.

Fixpoint filter `(f : v → bool) `(m : Map k v) : Map k v :=
  match m with
  | Empty => Empty
  | Add i x m =>
      if f x
      then Add i x (filter f m)
      else filter f m
  end.

Fixpoint mapMaybe `(f : v → option b) `(m : Map k v) : Map k b :=
  match m with
  | Empty => Empty
  | Add i x m =>
      match f x with
      | Some x' => Add i x' (mapMaybe f m)
      | None => mapMaybe f m
      end
  end.


Require Export Structure.Cartisian.
Require Export Structure.Exponential.

Module CCC.

Section ClassDef.

Structure class_of (C: Category) := Class {
  base: CartCategory.class_of C;
  mixin: ExpCategory.mixin_of (CartCategory.Pack C base);
}.
Local Coercion base: class_of >-> CartCategory.class_of.
Local Coercion mixin: class_of >-> ExpCategory.mixin_of.

Structure type := Pack { sort: Category; _: class_of sort }.
Local Coercion sort: type >-> Category.

Variable (C: type).
Definition class := match C return class_of C with Pack _ c => c end.

Let xC := match C with Pack C _ => C end.
Notation xclass := (class: class_of xC).

Definition TopCategory := TopCategory.Pack C xclass.
Definition ProdCategory := ProdCategory.Pack C xclass.
Definition CartCategory := CartCategory.Pack C xclass.
Definition ExpCategory := ExpCategory.Pack C (ExpCategory.Class _ xclass xclass).

End ClassDef.

Module Exports.

Coercion base: class_of >-> CartCategory.class_of.
Coercion mixin: class_of >-> ExpCategory.mixin_of.
Coercion sort: type >-> Category.
Coercion TopCategory: type >-> TopCategory.type.
Canonical TopCategory.
Coercion ProdCategory: type >-> ProdCategory.type.
Canonical ProdCategory.
Coercion CartCategory: type >-> CartCategory.type.
Canonical CartCategory.
Coercion ExpCategory: type >-> ExpCategory.type.
Canonical ExpCategory.
Notation CCC := type.

End Exports.

End CCC.

Export CCC.Exports.

Section CartisianClosed.
Context {C: CCC}.

Section exp_1.
Context (c: C).

Definition expc1_to: c ^ 1 ~> c :=
  eval c 1 ∘ ⟨id (c ^ 1), !⟩.

Definition expc1_from: c ~> c ^ 1 :=
  transpose π₁.

Lemma expc1_inv_l: expc1_from ∘ expc1_to = id (c ^ 1).
Proof.
  unfold expc1_to, expc1_from.
  apply transpose_inv_inj.
  unfold transpose_inv.
  etransitivity.
  do 2 apply f_equal.
  symmetry.
  apply comp_id_l.
  setoid_rewrite fprod_comp.
  rewrite comp_assoc.
  setoid_rewrite eval_transpose.
  unfold fprod.
  rewrite <- comp_assoc, fork_comp.
  rewrite !comp_id_l.
  rewrite pi1_fork.
  do 2 f_equal.
  apply to_one_eq.
Qed.

Lemma expc1_inv_r: expc1_to ∘ expc1_from = id c.
Proof.
  unfold expc1_to, expc1_from.
  rewrite <- comp_assoc.
  rewrite fork_comp.
  rewrite comp_id_l.
  apply (iso_epic (prod_unitor_l c)).
  rewrite comp_id_l.
  simpl.
  unfold prod_unitor_l_to.
  rewrite <- comp_assoc, fork_comp.
  rewrite (to_one_eq _ (id 1 ∘ @π₂ _ c 1)).
  apply (eval_transpose (@π₁ _ c 1)).
Qed.

Definition expc1: c ^ 1 <~> c :=
  Isomorphism.Pack expc1_to (Isomorphism.Mixin _ _ _ expc1_to expc1_from expc1_inv_l expc1_inv_r).

Lemma exp_1_r: c ^ 1 ≃ c.
Proof.
  constructor.
  exact expc1.
Qed.

End exp_1.

End CartisianClosed.


Require Import Coq.Classes.RelationPairs.
Require Import Coq.Classes.Morphisms Coq.Setoids.Setoid.
Require Import Coq.Structures.Equalities.
Require Import Crypto.Util.Structures.Equalities.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SetoidSubst.
Require Import Crypto.Util.Prod.

Local Set Implicit Arguments.

Module ProdTyp (E1 : Typ) (E2 : Typ) <: Typ.
  Definition t := (E1.t * E2.t)%type.
End ProdTyp.

Module ProdHasEq (E1 : Eq) (E2 : Eq).
  Definition eq : relation (E1.t * E2.t) := RelProd E1.eq E2.eq.
End ProdHasEq.

Module ProdIsEq (E1 : EqualityType) (E2 : EqualityType).
  Local Notation eq := (RelProd E1.eq E2.eq).
  Global Instance eq_equiv : Equivalence eq | 5.
  Proof.
    constructor; exact _.
  Defined.
End ProdIsEq.

Module ProdIsEqOrig (E1 : EqualityTypeOrig) (E2 : EqualityTypeOrig).
  Local Notation eq := (RelProd E1.eq E2.eq).
  Definition eq_refl : Reflexive eq.
  Proof. split; (apply E1.eq_refl + apply E2.eq_refl). Defined.
  Definition eq_sym : Symmetric eq.
  Proof. cbv -[fst snd]; split; (apply E1.eq_sym + apply E2.eq_sym); (eapply proj1 + eapply proj2); eassumption. Defined.
  Definition eq_trans : Transitive eq.
  Proof. cbv -[fst snd]; split; (eapply E1.eq_trans + eapply E2.eq_trans); (eapply proj1 + eapply proj2); eassumption. Defined.
End ProdIsEqOrig.

Module ProdHasEqDec (E1 : Eq) (E2 : Eq) (E1Dec : HasEqDec E1) (E2Dec : HasEqDec E2).
  Local Notation eq := (RelProd E1.eq E2.eq).
  Definition eq_dec x y : {eq x y} + {~eq x y}.
  Proof.
    destruct (E1Dec.eq_dec (fst x) (fst y)); [ destruct (E2Dec.eq_dec (snd x) (snd y)); [ left; split | right; intros [? ?] ] | right; intros [? ?] ]; auto with nocore.
  Defined.
End ProdHasEqDec.

Module ProdHasEqb (E1 : Typ) (E2 : Typ) (E1b : HasEqb E1) (E2b : HasEqb E2).
  Definition eqb := prod_beq _ _ E1b.eqb E2b.eqb.
End ProdHasEqb.

Module ProdEqbNotation (E1 : Typ) (E2 : Typ) (E1s : HasEqb E1) (E2s : HasEqb E2).
  Module Import _ProdEqbNotation.
    Module T := ProdTyp E1 E2.
    Module E := ProdHasEqb E1 E2 E1s E2s.
  End _ProdEqbNotation.
  Include EqbNotation T E.
End ProdEqbNotation.

Module ProdEqbSpec (E1 : Typ) (E2 : Typ) (E1e : HasEq E1) (E2e : HasEq E2) (E1b : HasEqb E1) (E2b : HasEqb E2) (E1s : EqbSpec E1 E1e E1b) (E2s : EqbSpec E2 E2e E2b).
  Local Notation eq := (RelProd E1e.eq E2e.eq).
  Local Notation eqb := (prod_beq _ _ E1b.eqb E2b.eqb).
  Lemma eqb_eq x y : eqb x y = true <-> eq x y.
  Proof.
    destruct x as [x1 x2], y as [y1 y2]; cbv [eqb];
      rewrite Bool.andb_true_iff, E1s.eqb_eq, E2s.eqb_eq; reflexivity.
  Qed.
End ProdEqbSpec.

Module ProdHasEqBool (E1 : Eq) (E2 : Eq) (E1s : HasEqBool E1) (E2s : HasEqBool E2) := ProdHasEqb E1 E2 E1s E2s <+ ProdEqbSpec E1 E2 E1 E2 E1s E2s E1s E2s.

Module ProdUsualHasEqDec (E1 : UsualEq) (E2 : UsualEq) (E1Dec : HasEqDec E1) (E2Dec : HasEqDec E2).
  Definition eq_dec (x y : E1.t * E2.t) : {eq x y} + {~eq x y}.
  Proof.
    destruct (E1Dec.eq_dec (fst x) (fst y)); [ destruct (E2Dec.eq_dec (snd x) (snd y)); [ left; destruct x, y | right; intro; subst y; destruct x ] | right; intro; subst y; destruct x ]; cbn in *; subst; try reflexivity; eauto using eq_refl with nocore.
  Defined.
End ProdUsualHasEqDec.

Module ProdUsualEqbSpec (E1 : UsualBoolEq) (E2 : UsualBoolEq).
  Lemma eqb_eq x y : @prod_beq _ _ E1.eqb E2.eqb x y = true <-> eq x y.
  Proof.
    destruct x as [x1 x2], y as [y1 y2]; cbv [prod_beq].
    rewrite Bool.andb_true_iff, E1.eqb_eq, E2.eqb_eq;
      intuition congruence.
  Qed.
End ProdUsualEqbSpec.

Module ProdHasUsualEq (E1 : UsualEq) (E2 : UsualEq).
  Module Import _ProdHasUsualEq.
    Module E' := ProdTyp E1 E2.
  End _ProdHasUsualEq.
  Include HasUsualEq E'.
End ProdHasUsualEq.

Module ProdUsualEq (E1 : UsualEq) (E2 : UsualEq) <: UsualEq := ProdTyp E1 E2 <+ HasUsualEq.

Module ProdUsualIsEq (E1 : UsualEq) (E2 : UsualEq).
  Module Import _ProdUsualIsEq.
    Module E' := ProdUsualEq E1 E2.
  End _ProdUsualIsEq.
  Include UsualIsEq E'.
End ProdUsualIsEq.

Module ProdUsualIsEqOrig (E1 : UsualEq) (E2 : UsualEq).
  Module Import _ProdUsualIsEqOrig.
    Module E' := ProdUsualEq E1 E2.
  End _ProdUsualIsEqOrig.
  Include UsualIsEqOrig E'.
End ProdUsualIsEqOrig.

Module ProdMiniDecidableType (E1 : MiniDecidableType) (E2 : MiniDecidableType) <: MiniDecidableType.
  Include ProdTyp E1 E2.
  Module Import _ProdMiniDecidableType.
    Module E1' := Make_UDT E1.
    Module E2' := Make_UDT E2.
  End _ProdMiniDecidableType.
  Include ProdUsualHasEqDec E1' E2' E1' E2'.
End ProdMiniDecidableType.

Local Coercion is_true : bool >-> Sortclass.
Module ProdIsEqb (E1 : EqbType) (E2 : EqbType).
  Global Instance eqb_equiv : Equivalence (prod_beq _ _ E1.eqb E2.eqb) | 5.
  Proof.
    destruct E1.eqb_equiv, E2.eqb_equiv.
    split; repeat intro; destruct_head'_prod;
      cbn in *; cbv [is_true] in *; rewrite ?Bool.andb_true_iff in *;
      destruct_head'_and; split;
      multimatch goal with H : _ |- _ => eapply H end; eassumption.
  Qed.
End ProdIsEqb.

Module ProdUsualHasEqBool (E1 : UsualBoolEq) (E2 : UsualBoolEq) := ProdHasEqb E1 E2 E1 E2 <+ ProdUsualEqbSpec E1 E2.

Module ProdEq (E1 : Eq) (E2 : Eq) <: Eq := ProdTyp E1 E2 <+ ProdHasEq E1 E2.
Module ProdEqualityType (E1 : EqualityType) (E2 : EqualityType) <: EqualityType := ProdEq E1 E2 <+ ProdIsEq E1 E2.
Module ProdEqualityTypeOrig (E1 : EqualityTypeOrig) (E2 : EqualityTypeOrig) <: EqualityTypeOrig := ProdEq E1 E2 <+ ProdIsEqOrig E1 E2.
Module ProdEqualityTypeBoth (E1 : EqualityTypeBoth) (E2 : EqualityTypeBoth) <: EqualityTypeBoth := ProdEq E1 E2 <+ ProdIsEq E1 E2 <+ ProdIsEqOrig E1 E2.
Module ProdDecidableType (E1 : DecidableType) (E2 : DecidableType) <: EqualityType := ProdEqualityType E1 E2 <+ ProdHasEqDec E1 E2 E1 E2.
Module ProdDecidableTypeOrig (E1 : DecidableTypeOrig) (E2 : DecidableTypeOrig) <: EqualityTypeOrig := ProdEqualityTypeOrig E1 E2 <+ ProdHasEqDec E1 E2 E1 E2.
Module ProdDecidableTypeBoth (E1 : DecidableTypeBoth) (E2 : DecidableTypeBoth) <: EqualityTypeBoth := ProdEqualityTypeBoth E1 E2 <+ ProdHasEqDec E1 E2 E1 E2.
Module ProdBooleanEqualityType (E1 : BooleanEqualityType) (E2 : BooleanEqualityType) <: BooleanEqualityType := ProdEqualityType E1 E2 <+ ProdHasEqb E1 E2 E1 E2 <+ ProdEqbSpec E1 E2 E1 E2 E1 E2 E1 E2.
Module ProdBooleanDecidableType (E1 : BooleanDecidableType) (E2 : BooleanDecidableType) <: BooleanDecidableType := ProdBooleanEqualityType E1 E2 <+ ProdHasEqDec E1 E2 E1 E2.
Module ProdDecidableTypeFull (E1 : DecidableTypeFull) (E2 : DecidableTypeFull) <: DecidableTypeFull := ProdEq E1 E2 <+ ProdIsEq E1 E2 <+ ProdIsEqOrig E1 E2 <+ ProdHasEqDec E1 E2 E1 E2 <+ ProdHasEqBool E1 E2 E1 E2.

Module ProdEq' (E1 : Eq) (E2 : Eq) := ProdEq E1 E2 <+ EqNotation.
Module ProdEqualityType' (E1 : EqualityType) (E2 : EqualityType) := ProdEqualityType E1 E2 <+ EqNotation.
Module ProdEqualityTypeOrig' (E1 : EqualityTypeOrig) (E2 : EqualityTypeOrig) := ProdEqualityTypeOrig E1 E2 <+ EqNotation.
Module ProdEqualityTypeBoth' (E1 : EqualityTypeBoth) (E2 : EqualityTypeBoth) := ProdEqualityTypeBoth E1 E2 <+ EqNotation.
Module ProdDecidableType' (E1 : DecidableType) (E2 : DecidableType) := ProdDecidableType E1 E2 <+ EqNotation.
Module ProdDecidableTypeOrig' (E1 : DecidableTypeOrig) (E2 : DecidableTypeOrig) := ProdDecidableTypeOrig E1 E2 <+ EqNotation.
Module ProdDecidableTypeBoth' (E1 : DecidableTypeBoth) (E2 : DecidableTypeBoth) := ProdDecidableTypeBoth E1 E2 <+ EqNotation.
Module ProdBooleanEqualityType' (E1 : BooleanEqualityType) (E2 : BooleanEqualityType) := ProdBooleanEqualityType E1 E2 <+ EqNotation <+ EqbNotation.
Module ProdBooleanDecidableType' (E1 : BooleanDecidableType) (E2 : BooleanDecidableType) := ProdBooleanDecidableType E1 E2 <+ EqNotation <+ EqbNotation.
Module ProdDecidableTypeFull' (E1 : DecidableTypeFull) (E2 : DecidableTypeFull) := ProdDecidableTypeFull E1 E2 <+ EqNotation.

Module ProdUsualEqualityType (E1 : UsualEq) (E2 : UsualEq) <: UsualEqualityType := ProdUsualEq E1 E2 <+ UsualIsEq.
Module ProdUsualEqualityTypeOrig (E1 : UsualEq) (E2 : UsualEq) <: UsualEqualityTypeOrig := ProdUsualEq E1 E2 <+ UsualIsEqOrig.
Module ProdUsualEqualityTypeBoth (E1 : UsualEq) (E2 : UsualEq) <: UsualEqualityTypeBoth := ProdUsualEq E1 E2 <+ UsualIsEq <+ UsualIsEqOrig.

Module ProdUsualDecidableType (E1 : UsualDecidableType) (E2 : UsualDecidableType) <: UsualDecidableType
:= ProdUsualEq E1 E2 <+ UsualIsEq <+ ProdUsualHasEqDec E1 E2 E1 E2.
Module ProdUsualDecidableTypeOrig (E1 : UsualDecidableTypeOrig) (E2 : UsualDecidableTypeOrig) <: UsualDecidableTypeOrig
:= ProdUsualEq E1 E2 <+ UsualIsEqOrig <+ ProdUsualHasEqDec E1 E2 E1 E2.
Module ProdUsualDecidableTypeBoth (E1 : UsualDecidableTypeBoth) (E2 : UsualDecidableTypeBoth) <: UsualDecidableTypeBoth
 := ProdUsualDecidableType E1 E2 <+ UsualIsEqOrig.
Module ProdUsualBoolEq (E1 : UsualBoolEq) (E2 : UsualBoolEq) <: UsualBoolEq
:= ProdUsualEq E1 E2 <+ ProdUsualHasEqBool E1 E2.
Module ProdUsualDecidableTypeFull (E1 : UsualDecidableTypeFull) (E2 : UsualDecidableTypeFull) <: UsualDecidableTypeFull
 := ProdUsualEq E1 E2 <+ UsualIsEq <+ UsualIsEqOrig <+ ProdUsualHasEqDec E1 E2 E1 E2 <+ ProdUsualHasEqBool E1 E2.

Module ProdEqbType (E1 : EqbType) (E2 : EqbType) <: EqbType := ProdTyp E1 E2 <+ ProdHasEqb E1 E2 E1 E2 <+ ProdIsEqb E1 E2.


Require Import Omega.
Require Import Forcing.TemplateForcing.
Require Import Template.Typing Template.Ast Template.WeakSubst Template.LiftSubst.
From Template Require Export univ uGraph.

Require Import String.
Local Open Scope string_scope.

Require Import List.
Import ListNotations.
Open Scope list.

Import Environ.

Definition cat : category :=
  makeCatS "Obj" "Hom" "Id_hom" "Comp".

Definition ft_type c Σ σ :=
  (snd (otranslate_type otranslate (Environ.of_global_context Σ) (mkFCtxt σ cat []) tt c)).

Definition ft_term c Σ σ :=
  (snd (otranslate (Environ.of_global_context Σ) (mkFCtxt σ cat []) tt c)).

Definition ft_ctx Γ Σ σ  :=
  (snd (otranslate_context (Environ.of_global_context Σ) (mkFCtxt σ cat []) tt Γ)).

Definition leq_refl sigma t : leq_term sigma t t = true.
  induction t.
Admitted.

(** We assume the following sorts for the objects and morphisms of the base category *)
Axiom obj_sort : forall Σ Γ, Σ ;;; Γ |- tConst "Obj" [] : tSort [Universe.Expr.set].
Axiom hom_sort : forall Σ Γ t1 t2,
    Σ ;;; Γ |- t1 : tConst "Obj" [] ->
    Σ ;;; Γ |- t2 : tConst "Obj" [] ->
                    Σ ;;; Γ |- tApp (Ast.tConst "Hom" []) [t1; t2] : tSort [Universe.Expr.set].
Axiom id_hom_type : forall Σ Γ t,
    Σ ;;; Γ |- t : tConst "Obj" [] ->
    Σ ;;; Γ |- tApp (Ast.tConst "Id_hom" []) [t] : tApp (Ast.tConst "Hom" []) [t; t].

Lemma wf_init_graph : wf_graph init_graph.
Proof.
  constructor.
  - constructor.
    + apply SetoidList.InA_cons_tl. auto.
    + intuition. apply SetoidList.InA_cons_hd; auto.
      simpl. apply SetoidList.InA_cons_hd; eauto.
      (* NOTE: something is not right, either [wf_graph] or [init_graph] *)
Admitted.

Ltac setctx na :=
  match goal with
    |- ?Σ ;;; ?Γ |- _ : _ => set(na := Γ)
  end.

Ltac solve_rel :=
  let Γ' := fresh "Γ" in
  let H' := fresh in
  match goal with
    |- ?Σ ;;; ?Γ |- tRel ?n : _ =>
    setctx Γ';
    assert (H' : n < #|Γ'|) by (subst;simpl; omega);
    subst; apply type_Rel with (isdecl:=H')
  end.

Reserved Notation "E ## Γ |= σ" (at level 40).

(* TODO: think about the empty context case *)
Inductive fctx_valid E : context -> list forcing_condition -> Type :=
| fctx_valid_nil : E ## vass (nNamed "p") Relevant (tConst "Obj" nil) :: nil |= nil
| fctx_valid_cons_var Γ σ T t : E ## Γ |= σ -> (to_global_context E) ;;; Γ |- t : T ->
                            E ## (Γ ,, vass (nNamed "t") Relevant T) |= (σ ,, fcVar)
| fctx_valid_cons_lift Γ σ : E ## Γ |= σ ->
                        E ## (Γ ,,, get_ctx_lift cat E (last_condition σ)) |= (σ ,, fcLift)
where "E ## Γ |= σ" := (fctx_valid E Γ σ).

Lemma last_condition_sound σ Γ (Σ := ([], init_graph)) :
  type_local_env Σ Γ ->
  (of_global_context Σ) ## Γ |= σ ->
  Σ ;;; Γ |- tRel (last_condition σ) : tConst "Obj" [].
Proof.
  intros TyCtx FCvalid.
  induction FCvalid.
  - simpl. setctx Γ'.
         assert (H1 : 0 < #|Γ'|) by (subst;simpl; omega).
         subst. apply type_Rel with (n:=0) (isdecl:=H1).
  - simpl.
    pose [vass (nNamed "t") Relevant T] as Γ'.
    change (Σ;;; Γ ,,, Γ' |- lift0 #|Γ'| (tRel (last_condition σ)) : lift0 #|Γ'| (tConst "Obj" [])).
    assert (TyCtxΓ : type_local_env Σ Γ).
    { inversion TyCtx;subst;auto. }
    apply weakening.
    + simpl. constructor. apply wf_init_graph.
    + simpl.
      (* NOTE: here we do inversion again, because of some issues with [typing] being in [Type] *)
      inversion TyCtx;subst;auto.
    + apply IHFCvalid; eauto.
  - solve_rel.
Qed.

Lemma lam_q_f_sound (Σ := (nil,init_graph)) Γ σ t T :
  let E := (of_global_context Σ) in
  let fctx := (mkFCtxt σ cat []) in
  let ext := get_ctx_lift cat E (last_condition σ) in
  type_local_env Σ Γ ->
  Σ ;;; Γ ,,, ext |- t : T ->
  Σ ;;; Γ |- snd (λ_q_f E fctx) t : snd (Π_q_f E fctx) T.
Proof.
  simpl. intros TyCtx Ty.
  econstructor.
  + eapply obj_sort.
  + econstructor.
    * eapply hom_sort.
      ** pose (vass pos_name Relevant (tConst "Obj" []) :: nil) as Γ'.
         change
           (Σ;;; Γ ,,, Γ' |- lift0 #|Γ'| (tRel (last_condition σ)) : lift0 #|Γ'| (tConst "Obj" [])).
         apply weakening with (Γ' := Γ').
         *** simpl. constructor. apply wf_init_graph.
         *** simpl. constructor. apply TyCtx. econstructor. simpl. apply obj_sort.
         *** apply last_condition_sound.
             (* TODO : add Γ typed assumption *)
             admit.
             (* TODO : add forcing context validity assumption *)
             admit.
      ** solve_rel.
  Admitted.

Lemma Π_q_f_lift_sound (Σ := (nil,init_graph)) Γ σ T l :
  let σ_ext := σ ,, fcLift in
  let fctx_ext := (mkFCtxt σ_ext cat []) in
  let E := (of_global_context Σ) in
  let ext1 := get_ctx_lift cat E (last_condition σ) in
  let ext2 := get_ctx_lift cat E (last_condition σ_ext) in
  Σ ;;; Γ ,,, ext1 ,,, ext2  |- T : tSort l ->
  Σ ;;; Γ ,,, ext1 |- snd (Π_q_f E fctx_ext) T :
  tSort (Universe.sup [Universe.Expr.set]  (Universe.sup [Universe.Expr.set] l)).
Proof.
  simpl.
  intros H.
  apply type_Prod.
  ** apply obj_sort.
  ** apply type_Prod.
     *** apply hom_sort; solve_rel.
     *** eauto.
Qed.

Notation "'[' c ']ᵗ' " := (ft_term c) (at level 40).
Notation "⟦ Γ ⟧" := (ft_ctx Γ)  (at level 40).
Notation "'⟦' c '⟧ᵀ'" := (ft_type c) (at level 40).

Lemma context_traslation_valid E Γ σ :
  let Σ := to_global_context E in
  type_local_env Σ Γ ->
  E ## (⟦Γ⟧ Σ σ) |= σ.
Proof.
  intros ? TyCtx.
  Admitted.

Lemma forcing_context_soundness Σ Γ σ :
  type_local_env Σ Γ -> type_local_env Σ (⟦Γ⟧ Σ σ).
Admitted.

Lemma forcing_typing_soundness (Σ := (nil,init_graph)) Γ t T σ  :
  type_local_env Σ Γ ->
  Σ ;;; Γ |- t : T ->
  let Σ' := Σ in Σ' ;;; (⟦Γ⟧ Σ σ) |- ([t]ᵗ Σ σ) : (⟦T⟧ᵀ Σ σ).
Proof.
  intros TyCtx Ty.
  induction Ty; simpl.
  - simpl. unfold translate_var.
    unshelve econstructor; simpl.
    Focus 2. constructor.  admit.
  - destruct l;simpl.
    + (* Simplifying the applications in the type first*)
      eapply type_Conv.
      * unfold ft_term,otranslate,lambda_prefix,extend. simpl.
        apply lam_q_f_sound;simpl.
        ** apply forcing_context_soundness;assumption.
        ** eapply Π_q_f_lift_sound; apply type_Sort.
      * unfold ft_type. simpl. unfold mkOptApp.
        eapply type_App.
        ** eapply lam_q_f_sound;simpl.
           *** apply forcing_context_soundness;assumption.
           *** apply Π_q_f_lift_sound. unfold Universe.super. simpl.
               unfold Universe.type1,Universe.Expr.type1.
           (* TODO: show that [tSort [(Level.set, true)]] has type [tSort l] for some level l *)
           (* constructor [type_Sort] does not apply here. *)
               admit.
        ** (* typing_spine *)
           simpl. econstructor.
           *** eapply cumul_refl. apply leq_refl.
           *** apply last_condition_sound.
               **** apply forcing_context_soundness;assumption.
               **** apply context_traslation_valid. apply TyCtx.
           *** econstructor.
               **** eapply cumul_refl. apply leq_refl.
               **** simpl. apply id_hom_type. apply last_condition_sound.
                    ***** apply forcing_context_soundness;assumption.
                    ***** apply context_traslation_valid. apply TyCtx.
               **** simpl. econstructor.
      * simpl. unfold ft_type. simpl. unfold mkOptApp.

        (* constructor. simpl. *)
        (* apply Π_q_f_lift_sound. unfold Universe.super. simpl. *)
        (* unfold Universe.type1,Universe.Expr.type1. *)
       (* econstructor;simpl. Focus 4. *)
       (* eapply cumul_red_r. *)
       (* Focus 2. eapply red_beta. simpl. *)
       (* eapply cumul_red_r. *)
       (* Focus 2. eapply red_beta. simpl. *)
       (* eapply cumul_refl. apply leq_refl. *)
       (* econstructor. *)
       (* apply obj_sort. *)
       (* econstructor. econstructor.  *)

               (* econstructor. econstructor. *)
Admitted.


From stdpp Require Import prelude.
From Coq Require Import Reals.
From VLSM.Lib Require Import Preamble ListExtras ListSetExtras FinSetExtras.
From VLSM.Core Require Import VLSM VLSMProjections Composition.
From VLSM.Core Require Import SubProjectionTraces MessageDependencies Equivocation.
From VLSM.Core Require Import NoEquivocation FixedSetEquivocation TraceWiseEquivocation.

(** * Witnessed equivocation

  Although [is_equivocating_tracewise] provides a very precise notion of
  equivocation, it does not guarantee the monotonicity of the set of equivocators
  along a trace.

  The witnessed equivocation assumption is a possible way to address this issue.

  Starting from the (reasonable) assumption that for any state <<s>>, there is
  a trace ending in <<s>> whose [equivocating_senders_in_trace] are precisely
  the equivocators of <<s>> (the [WitnessedEquivocationCapability]),
  we can show that for each Free valid state there exists
  a valid trace with the [strong_trace_witnessing_equivocation_prop]erty,
  i.e., a trace whose every prefix is a witness for its corresponding end state
  (Lemma [free_has_strong_trace_witnessing_equivocation_prop]).
  In particular, the set of equivocators is monotonically increasing for such a
  trace (Lemma [strong_witness_equivocating_validators_prefix_monotonicity]).

  We then use this result to show that any Free valid state is also a valid
  state for the composition of nodes under the [fixed_equivocation_constraint]
  induced by its set of equivocators.
*)

Section sec_witnessed_equivocation.

Context
  `{EqDecision message}
  `{finite.Finite index}
  (IM : index -> VLSM message)
  `{forall i : index, HasBeenSentCapability (IM i)}
  `{forall i : index, HasBeenReceivedCapability (IM i)}
  `{finite.Finite validator}
  (Free := free_composite_vlsm IM)
  (PreFree := pre_loaded_with_all_messages_vlsm Free)
  (threshold : R)
  `{ReachableThreshold validator Cv threshold}
  (A : validator -> index)
  (sender : message -> option validator)
  `{RelDecision _ _ (is_equivocating_tracewise_no_has_been_sent IM A sender)}
  (Htracewise_BasicEquivocation : BasicEquivocation (composite_state IM) validator Cv threshold
    := equivocation_dec_tracewise IM threshold A sender)
  (equivocating_validators :=
    equivocating_validators (BasicEquivocation := Htracewise_BasicEquivocation))
  .

(**
  A trace witnesses the equivocation of its final state <<s>> if its set of
  equivocators is precisely that of the [equivocating_validators] of <<s>>.
*)
Definition trace_witnessing_equivocation_prop
  is tr
  (s := finite_trace_last is tr)
  : Prop :=
  forall v, v ∈ equivocating_validators s <->
    exists (m : message), (sender m = Some v) /\ equivocation_in_trace PreFree m tr.

Lemma equivocating_senders_in_trace_witnessing_equivocation_prop
  is tr
  (Htr : trace_witnessing_equivocation_prop is tr)
  (s := finite_trace_last is tr)
  : set_eq (elements (equivocating_validators s)) (equivocating_senders_in_trace IM sender tr).
Proof.
  split; intros v Hv.
  - by apply elem_of_elements, Htr in Hv; apply elem_of_equivocating_senders_in_trace.
  - by eapply elem_of_elements, Htr, elem_of_equivocating_senders_in_trace.
Qed.

(**
  A composition of VLSMs has the witnessed equivocation capability if towards any
  valid states there exist a trace witnessing its equivocation.
*)
Class WitnessedEquivocationCapability : Prop :=
{
  is_equivocating_tracewise_witness :
    forall s, valid_state_prop PreFree s ->
    exists is tr, finite_valid_trace_init_to PreFree is s tr /\
      trace_witnessing_equivocation_prop is tr
}.

Section sec_witnessed_equivocation_properties.

Context
  (Hke : WitnessedEquivocationCapability)
  (Hsender_safety : sender_safety_alt_prop IM A sender)
  .

Lemma initial_state_witnessing_equivocation_prop
  s
  (Hs : composite_initial_state_prop IM s)
  : trace_witnessing_equivocation_prop s [].
Proof.
  intros v.
  unfold finite_trace_last. simpl.
  rewrite <- elem_of_elements.
  replace (elements (equivocating_validators s)) with (@nil validator).
  simpl.
  split; [by inversion 1 |].
  intros [m [_ Hmsg]].
  - by elim (no_equivocation_in_empty_trace PreFree m).
  - by symmetry; apply elements_empty_iff, equivocating_validators_empty_in_initial_state.
Qed.

(**
  For any trace having the [trace_witnessing_equivocation_prop]erty,
  its final transition is monotonic w.r.t. the [equivocating_validators].
*)
Lemma equivocating_validators_witness_monotonicity
  (is s : composite_state IM)
  (tr : list (composite_transition_item IM))
  (Htr : finite_valid_trace_init_to PreFree is s tr)
  (item : composite_transition_item IM)
  (Hwitness : trace_witnessing_equivocation_prop is (tr ++ [item]))
  (s' := destination item)
  : equivocating_validators s ⊆ equivocating_validators s'.
Proof.
  intros v Hv.
  specialize (Hwitness v).
  rewrite finite_trace_last_is_last in Hwitness.
  apply Hwitness.
  apply equivocating_validators_is_equivocating_tracewise_iff in Hv.
  specialize (Hv _ _ Htr) as [m [Hmsg Heqv]].
  exists m. split; [done |].
  by apply equivocation_in_trace_prefix.
Qed.

(**
  Given a trace with the [trace_witnessing_equivocation_prop]erty,
  if the [equivocating_validators] for the destination of its last transition
  are  included in the [equivocating_validators] for the source of its last
  transition, the the trace without its last transition also has the
  [trace_witnessing_equivocation_prop]erty.
*)
Lemma input_valid_transition_reflects_trace_witnessing_equivocation_prop
  (is s : composite_state IM)
  (tr : list (composite_transition_item IM))
  (Htr : finite_valid_trace_init_to PreFree is s tr)
  (item : composite_transition_item IM)
  (Hwitness : trace_witnessing_equivocation_prop is (tr ++ [item]))
  (s' := destination item)
  (Hincl : equivocating_validators s' ⊆ equivocating_validators s)
  : trace_witnessing_equivocation_prop is tr.
Proof.
  apply finite_valid_trace_init_to_last in Htr as Hlst.
  intros v; split; simpl in *; rewrite Hlst in *.
  - intros Hv.
    by eapply equivocating_validators_is_equivocating_tracewise_iff
      with (ReachableThreshold0 := H11).
  - intros (msg & Hsender & Heqv).
    apply Hincl.
    specialize (Hwitness v);
    rewrite finite_trace_last_is_last in Hwitness;
    apply Hwitness.
    exists msg. split; [done |].
    by apply equivocation_in_trace_prefix.
Qed.

(**
  An equivocator for the destination of a transition is either an equivocation
  for the source as well, or it is the sender of the received message and that
  message is not sent by any trace witnessing the source of the transition.
*)
Lemma equivocating_validators_step_update
    l s om s' om'
    (Ht : input_valid_transition PreFree l (s, om) (s', om'))
    v
    : v ∈ equivocating_validators s' ->
      v ∈ equivocating_validators s \/
      (exists m, om = Some m /\
      sender m = Some v /\
      forall is tr
      (Htr : finite_valid_trace_init_to PreFree is s tr)
      (Hwitness : trace_witnessing_equivocation_prop is tr),
      ~ trace_has_message (field_selector output) m tr).
Proof.
  intro Hv.
  destruct (decide (v ∈ elements (equivocating_validators s))) as [Hnv | Hnv]
  ; rewrite elem_of_elements in Hnv; [by left | right].
  apply equivocating_validators_is_equivocating_tracewise_iff in Hv.
  destruct (transition_is_equivocating_tracewise_char IM A sender  _ _ _ _ _ Ht _ Hv)
    as [| Hom];
    [by contradict Hnv; apply equivocating_validators_is_equivocating_tracewise_iff |].
  destruct om as [m |]; simpl in Hom; [| by congruence].
  exists m; split_and!; [done.. |].
  intros is tr [Htr Hinit] Hwitness.
  specialize (extend_right_finite_trace_from_to _ Htr Ht) as Htr'.
  specialize (Hv _ _ (conj Htr' Hinit)).
  destruct Hv as [m' [Hm' [prefix [item [suffix [Heq Heqv]]]]]].
  destruct_list_last suffix suffix' item' Heqsuffix.
  - apply app_inj_tail in Heq. destruct Heq; subst.
    simpl in Heqv. destruct Heqv as [Heq_m Heqv].
    by inversion Heq_m.
  - elim Hnv.
    specialize (Hwitness v).
    apply finite_valid_trace_from_to_last in Htr as Hs.
    simpl in Hs, Hwitness. rewrite Hs in Hwitness.
    apply Hwitness. exists m'. split; [done |].
    exists prefix, item, suffix'.
    split; [| done].
    change (item :: suffix' ++ [item']) with ([item] ++ suffix' ++ [item']) in Heq.
    rewrite !app_assoc in Heq; apply app_inj_tail in Heq; rewrite <- !app_assoc in Heq.
    by destruct Heq as [-> _].
Qed.

(**
  Given a non-empty trace with the [trace_witnessing_equivocation_prop]erty,
  there are two disjoint possibilities concerning its last transition.

  (1) either it preserves the set of [equivocating_validators] and, in that case,
  the trace without the last transition has the
  [trace_witnessing_equivocation_prop]erty as well; or

  (2) The set of [equivocating_validators] of its destination is obtained
  by adding the sender of the message received in the transition to the
  set of [equivocating_validators] of its source, and, in that case, that message
  is not sent by any trace witnessing the source of the transition.
*)
Lemma equivocating_validators_witness_last_char
  (is : composite_state IM)
  (tr : list (composite_transition_item IM))
  (l : composite_label IM)
  (om : option message)
  (s' : composite_state IM)
  (om' : option message)
  (item  := {| l := l; input := om; destination := s'; output := om' |})
  (Htr_item : finite_valid_trace_init_to PreFree is s' (tr ++ [item]))
  (Hwitness : trace_witnessing_equivocation_prop is (tr ++ [item]))
  (s := finite_trace_last is tr)
  : equivocating_validators s ≡@{Cv} equivocating_validators s'
    /\ trace_witnessing_equivocation_prop is tr
    \/
    (exists m, om = Some m /\
     exists v, sender m = Some v /\
     v ∉ equivocating_validators s /\
     equivocating_validators s' ≡@{Cv} {[ v ]} ∪ (equivocating_validators s) /\
     forall (is : composite_state IM) (tr : list transition_item),
        finite_valid_trace_init_to PreFree is s tr ->
        trace_witnessing_equivocation_prop is tr ->
        ~ trace_has_message (field_selector output) m tr).
Proof.
  destruct Htr_item as [Htr Hinit].
  apply finite_valid_trace_from_to_app_split in Htr.
  destruct Htr as [Htr Hitem].
  inversion_clear Hitem. clear Htl. subst s.
  apply equivocating_validators_witness_monotonicity with (s := (finite_trace_last is tr))
    in Hwitness as Hincl
  ; [| by split].
  remember (finite_trace_last is tr) as s.
  destruct (option_bind _ _ sender om) as [v |] eqn: Heq_v.
  - destruct om as [m |]; [| by inversion Heq_v]. simpl in Heq_v.
    destruct (decide (set_eq (elements (equivocating_validators s)) (elements (equivocating_validators s')))).
    + apply set_eq_fin_set in s0; left; split; [done |].
      by apply
        (input_valid_transition_reflects_trace_witnessing_equivocation_prop
          _ _ _ (conj Htr Hinit) _ Hwitness);
      subst; intros ? ?; apply s0.
    + right. exists m; split; [done |]. exists v; split; [done |].
      specialize (equivocating_validators_step_update _ _ _ _ _ Ht) as Honly_v.
      simpl in Honly_v.
      assert (Hv : exists v, v ∈ equivocating_validators s' /\ v ∉ equivocating_validators s).
      {
        setoid_rewrite <- elem_of_elements.
        apply Exists_exists.
        apply neg_Forall_Exists_neg; [intro; apply elem_of_list_dec |].
        intro all. elim n.
        split; [| by rewrite Forall_forall in all].
        by unfold set_eq, subseteq, list_subseteq; setoid_rewrite elem_of_elements.
      }
      destruct Hv as [v' [Heqv Hneqv]].
      apply Honly_v in Heqv as Heq_v'.
      destruct Heq_v' as [| [_m [Heq_m [Heq_v' Hweqv]]]]; [by subst |].
      inversion Heq_m. subst _m. clear Heq_m.
      assert (v' = v) by congruence. subst v'. clear Heq_v'.
      split; [done |]. split; [| by subst].
      intro v'; split; intro Hv'.
      * apply elem_of_union.
        destruct (decide (v' ∈ elements (equivocating_validators s)))
          as [Hveqv | Hveqv]; rewrite elem_of_elements in Hveqv;
        [by right | left].
        apply elem_of_singleton.
        by apply Honly_v in Hv';
          destruct Hv' as [| [_m [Heq_m [Heq_v' _]]]]; [by subst |]; congruence.
      * by apply elem_of_union in Hv' as [Heq_v' | Hs'0]
        ; [by apply elem_of_singleton in Heq_v'; subst v' | by apply Hincl].
  - left; split.
    + subst; intro v; split; [by apply Hincl |].
      intros Hvs'.
      by eapply input_valid_transition_receiving_no_sender_reflects_equivocating_validators.
    + eapply input_valid_transition_reflects_trace_witnessing_equivocation_prop; [done | done |].
      by eapply input_valid_transition_receiving_no_sender_reflects_equivocating_validators.
Qed.

(** ** Strongly witnessed equivocation

  A stronger [trace_witnessing_equivocation_prop]erty requires that any
  prefix of a trace is witnessing equivocation for its corresponding final state.
*)
Definition strong_trace_witnessing_equivocation_prop is tr :=
    forall prefix suffix, prefix ++ suffix = tr ->
      trace_witnessing_equivocation_prop is prefix.

(**
  An advantage of the [strong_trace_witnessing_equivocation_prop]erty
  is that it guarantees monotonicity of [equivocating_validators] along the trace.
*)
Lemma strong_witness_equivocating_validators_prefix_monotonicity
  (is s : composite_state IM)
  (tr : list (composite_transition_item IM))
  (Htr : finite_valid_trace_init_to PreFree is s tr)
  (Hwitness : strong_trace_witnessing_equivocation_prop is tr)
  prefix suffix
  (Heqtr : prefix ++ suffix = tr)
  (ps := finite_trace_last is prefix)
  : equivocating_validators ps ⊆ equivocating_validators s.
Proof.
  revert prefix suffix Heqtr ps.
  induction Htr using finite_valid_trace_init_to_rev_ind; intros.
  - by apply app_eq_nil in Heqtr as []; subst.
  - remember {| input := iom |} as item.
    spec IHHtr.
    {
      intros pre suf Heq.
      specialize (Hwitness pre (suf ++ [item])).
      apply Hwitness.
      by subst; apply app_assoc.
    }
    destruct_list_last suffix suffix' _item Heqsuffix.
    + rewrite app_nil_r in Heqtr. subst. subst ps.
      by rewrite finite_trace_last_is_last.
    + rewrite app_assoc in Heqtr. apply app_inj_tail in Heqtr.
      destruct Heqtr as [Heqtr Heq_item]. subst _item.
      specialize (IHHtr _ _ Heqtr).
      transitivity (equivocating_validators s)
      ; [done |].
      specialize (Hwitness (tr ++ [item]) []).
      spec Hwitness. { apply app_nil_r. }
      replace sf with (destination item) by (subst; done).
      by apply (equivocating_validators_witness_monotonicity _ _ _ Htr _ Hwitness).
Qed.

(**
  The next two lemmas show that the [strong_trace_witnessing_equivocation_prop]erty
  is preserved by transitions in both the cases yielded by Lemma
  [equivocating_validators_witness_last_char] as part of the induction step in
  the proof of Lemma [preloaded_has_strong_trace_witnessing_equivocation_prop].
*)
Lemma strong_trace_witnessing_equivocation_prop_extend_eq
  s
  is tr'
  (Htr' : finite_valid_trace_init_to PreFree is s tr')
  is' tr''
  (Htr'' : finite_valid_trace_init_to PreFree is' s tr'')
  (Hprefix : strong_trace_witnessing_equivocation_prop is' tr'')
  item
  (Hwitness : trace_witnessing_equivocation_prop is (tr' ++ [item]))
  (Heq : equivocating_validators s ≡@{Cv} equivocating_validators (destination item))
  : strong_trace_witnessing_equivocation_prop is' (tr'' ++ [item]).
Proof.
  intros prefix suffix Heq_tr''_item.
  destruct_list_last suffix suffix' sitem Hsuffix_eq.
  - rewrite app_nil_r in Heq_tr''_item.
    subst.
    intro v. rewrite finite_trace_last_is_last.
    specialize (Hprefix tr'' []).
    spec Hprefix; [by apply app_nil_r |].
    apply valid_trace_get_last in Htr'' as Hlst'.
    split.
    + intros Hv. apply Heq in Hv.
      rewrite <- Hlst' in Hv.
      apply Hprefix in Hv.
      destruct Hv as [m [Hmsg Heqv]].
      exists m. split; [done |].
      by apply equivocation_in_trace_prefix.
    + intros [m [Hmsg Heqv]].
      apply equivocation_in_trace_last_char in Heqv.
      destruct Heqv as [Heqv | Heqv].
      * apply Heq. rewrite <- Hlst'.
        apply Hprefix.
        by exists m.
      * destruct Heqv as [Heq_om Heqv].
        assert (Heqv' : ~ trace_has_message (field_selector output) m tr').
        { intro Heqv'. elim Heqv.
          apply valid_trace_last_pstate in Htr' as Htr'_lst.
          destruct
            (has_been_sent_consistency Free
              _ Htr'_lst m)
            as [Hconsistency _].
          spec Hconsistency; [by exists is, tr', Htr' |].
          by specialize (Hconsistency is' tr'' Htr'').
        }
        specialize (Hwitness v).
        rewrite finite_trace_last_is_last in Hwitness.
        simpl in Hwitness.
        apply Hwitness.
        subst. exists m. split; [done |].
        by eexists tr', _, [].
  - rewrite app_assoc in Heq_tr''_item. apply app_inj_tail in Heq_tr''_item.
    destruct Heq_tr''_item as [Heq_tr'' Heq_item].
    by apply (Hprefix _ _ Heq_tr'').
Qed.

Lemma strong_trace_witnessing_equivocation_prop_extend_neq
  s
  is tr
  (Htr : finite_valid_trace_init_to PreFree is s tr)
  (Hprefix : strong_trace_witnessing_equivocation_prop is tr)
  item
  msg
  (Hmsg : input item = Some msg)
  (Hwneq : ¬ trace_has_message (field_selector output) msg tr)
  v
  (Hsender : sender msg = Some v)
  (Hneq : equivocating_validators (destination item) ≡@{Cv} {[ v ]} ∪ (equivocating_validators s))
  : strong_trace_witnessing_equivocation_prop is (tr ++ [item]).
Proof.
  intros prefix suffix Heq_tr''_item.
  destruct_list_last suffix suffix' sitem Hsuffix_eq.
  - rewrite app_nil_r in Heq_tr''_item.
    subst prefix suffix.
    intro v'. rewrite finite_trace_last_is_last. simpl.
    specialize (Hprefix tr []).
    spec Hprefix; [by apply app_nil_r |].
    apply valid_trace_get_last in Htr as Hlst'.
    split.
    + intros Hv'. apply Hneq in Hv'.
      apply elem_of_union in Hv'; rewrite elem_of_singleton in Hv'.
      rewrite <- Hlst' in Hv'.
      destruct Hv' as [Heq_v | Hv'].
      * subst.
        exists msg. split; [done |].
        by eexists tr, _, [].
      * apply Hprefix in Hv'.
        destruct Hv' as [m [? Heqv]].
        exists m. split; [done |].
        by apply equivocation_in_trace_prefix.
    + intros [m [? Heqv]].
      apply equivocation_in_trace_last_char in Heqv.
      apply Hneq, elem_of_union; rewrite elem_of_singleton.
      destruct Heqv as [Heqv | Heqv].
      * rewrite <- Hlst'.
        right.
        apply Hprefix.
        by exists m.
      * left. simpl in Heqv.
        by destruct Heqv as [Heq_om Heqv]; congruence.
  - rewrite app_assoc in Heq_tr''_item. apply app_inj_tail in Heq_tr''_item.
    destruct Heq_tr''_item as [Heq_tr'' Heq_item].
    by apply (Hprefix _ _ Heq_tr'').
Qed.

(**
  Proving that any state <<s>> has the [strong_trace_witnessing_equivocation_prop]erty
  proceeds via a more technical double induction over both:

  (1) the length of a trace witnessing the equivocation of <<s>>; and
  (2) the size of the set of equivocators of <<s>>.

  For the induction step we assume that the witnessing trace leading to <<s>> is
  of the form <<tr ++ [item>>. By Lemma [equivocating_validators_witness_last_char]
  we know that either <<tr>> is also a witnessing trace, in which case we can use
  the induction hypothesis via property (1), or the set of equivocators for the
  last state of <<tr>> is strictly included in that of <<s>>, allowing us to use
  the induction hypothesis via property (2).

  The conclusion then follows by the two helper lemmas above.
*)
Lemma preloaded_has_strong_trace_witnessing_equivocation_prop s
  (Hs : valid_state_prop PreFree s)
  : exists is' tr',
    finite_valid_trace_init_to PreFree is' s tr' /\
    strong_trace_witnessing_equivocation_prop is' tr'.
Proof.
  apply is_equivocating_tracewise_witness in Hs.
  destruct Hs as [is [tr [Htr Hwitness]]].
  apply finite_valid_trace_init_to_last in Htr as Hlst.
  subst s.
  apply finite_valid_trace_init_to_forget_last in Htr.
  remember (length tr) as n.
  remember (set_size (equivocating_validators (finite_trace_last is tr))) as m.
  revert m n is tr Heqm Heqn Htr Hwitness.
  pose
    (fun m n =>
    forall is tr,
    m = set_size (equivocating_validators (finite_trace_last is tr)) ->
    n = length tr ->
    finite_valid_trace PreFree is tr ->
    trace_witnessing_equivocation_prop is tr ->
    let s := finite_trace_last is tr in
    exists (is' : state) (tr' : list transition_item),
      finite_valid_trace_init_to PreFree is' s tr' /\
      (forall prefix suffix : list transition_item,
       prefix ++ suffix = tr' ->
       trace_witnessing_equivocation_prop is' prefix))
    as Pr.
  apply (Wf_nat.lt_wf_double_ind Pr).
  intros m n IHm IHn. intros is tr.
  destruct_list_last tr tr' item Htr_eq.
  - subst.
    intros _ _ Htr _.
    exists is, [].
    split.
    + by apply finite_valid_trace_init_add_last.
    + intros prefix suffix Heq_tr.
      apply app_eq_nil in Heq_tr. destruct Heq_tr. subst.
      by apply initial_state_witnessing_equivocation_prop, Htr.
  - rewrite finite_trace_last_is_last.
    intros ? Hn Htr'_item Hwitness.
    apply finite_valid_trace_init_add_last
      with (sf := destination item)
      in Htr'_item
    ; [| by apply finite_trace_last_is_last].
    destruct item as [l om s' om']. simpl in *.
    destruct
      (equivocating_validators_witness_last_char _ _ _ _ _ _ Htr'_item Hwitness)
      as [[Heq Hwitness'] | [msg [Heq_om [v [Hsender [Hnv Hneq]]]]]].
    + specialize (IHn (length tr')).
      rewrite app_length in Hn. simpl in Hn.
      spec IHn; [lia |].
      specialize (IHn is tr').
      spec IHn; [by subst m; setoid_rewrite Heq |].
      specialize (IHn eq_refl).
      destruct Htr'_item as [Htr'_item Hinit].
      apply finite_valid_trace_from_to_app_split in Htr'_item.
      destruct Htr'_item as [Htr' Hitem].
      spec IHn.
      {
        split; [| done].
        by apply finite_valid_trace_from_to_forget_last in Htr'.
      }
      specialize (IHn Hwitness').
      destruct IHn as [is' [tr'' [[Htr'' Hinit'] Hprefix]]].
      specialize
        (finite_valid_trace_from_to_app PreFree _ _ _ _ _ Htr'' Hitem)
        as Htr''_item.
      eexists is', _.
      split; [done |].
      by apply (strong_trace_witnessing_equivocation_prop_extend_eq _ is tr' (conj Htr' Hinit))
      ; [by split | done..].
    + subst. destruct Hneq as [Hneq Hwneq].
      match type of Hnv with
      | _ ∉ equivocating_validators ?st =>
        remember st as s
      end.
      specialize (is_equivocating_tracewise_witness s) as Hwitness'.
      spec Hwitness'.
      { apply proj1, finite_valid_trace_from_to_app_split, proj1
          , finite_valid_trace_from_to_last_pstate
          in Htr'_item.
        by subst.
      }
      destruct Hwitness' as [is' [tr''[Htr'' Hwitness']]].
      specialize (IHm (set_size (equivocating_validators s)) (length tr'')).
      spec IHm.
      {
        rewrite Hneq.
        setoid_rewrite size_union; [by rewrite size_singleton; unfold size; lia |].
        by intro v'; rewrite elem_of_singleton; intros ->.
      }
      specialize (IHm is' tr'').
      apply finite_valid_trace_init_to_last in Htr'' as Htr''_lst.
      simpl in *.
      rewrite Htr''_lst in IHm.
      specialize (IHm eq_refl eq_refl).
      spec IHm; [by apply finite_valid_trace_init_to_forget_last in Htr'' |].
      specialize (IHm Hwitness').
      destruct IHm as [is'' [tr''' [[Htr''' Hinit'] Hprefix]]].
      apply proj1, finite_valid_trace_from_to_app_split, proj2 in Htr'_item as Hitem.
      simpl in *.
      rewrite <- Heqs in Hitem.
      specialize
        (finite_valid_trace_from_to_app PreFree _ _ _ _ _ Htr''' Hitem)
        as Htr'''_item.
      eexists is'', _.
      split; [done |].
      specialize (Hprefix tr''' []) as Hwitness'''.
      spec Hwitness'''; [by apply app_nil_r |].
      specialize (Hwneq _ _ (conj Htr''' Hinit') Hwitness''').
      remember {| input := Some msg |} as item.
      specialize (strong_trace_witnessing_equivocation_prop_extend_neq
        _ _ _ (conj Htr''' Hinit') Hprefix item msg) as Hextend.
      spec Hextend; [by subst |].
      specialize (Hextend Hwneq _ Hsender).
      by apply Hextend; subst.
Qed.

(**
  A version of Lemma [preloaded_has_strong_trace_witnessing_equivocation_prop]
  guaranteeing that for any [valid_state] w.r.t. the Free composition there is
  a trace ending in that state which is valid w.r.t. the Free composition and
  it has the [strong_trace_witnessing_equivocation_prop]erty.
*)
Lemma free_has_strong_trace_witnessing_equivocation_prop s
  (Hs : valid_state_prop Free s)
  : exists is' tr',
    finite_valid_trace_init_to Free is' s tr' /\
    strong_trace_witnessing_equivocation_prop is' tr'.
Proof.
  apply (VLSM_incl_valid_state (vlsm_incl_pre_loaded_with_all_messages_vlsm Free))
    in Hs as Hpre_s.
  apply preloaded_has_strong_trace_witnessing_equivocation_prop in Hpre_s.
  destruct Hpre_s as [is [tr [Htr Hwitness]]].
  apply (all_pre_traces_to_valid_state_are_valid IM) in Htr
  ; [| done].
  by exists is, tr.
Qed.

End sec_witnessed_equivocation_properties.

End sec_witnessed_equivocation.

(** ** Witnessed equivocation and fixed-set equivocation

  The main result of this module is that, under witnessed equivocation
  assumptions, any trace with the [strong_trace_witnessing_equivocation_prop]erty
  which is valid for the free composition (guaranteed to exist by
  Lemma [free_has_strong_trace_witnessing_equivocation_prop]) is also valid
  for the composition constrained by the [fixed_equivocation_constrained] induced
  by the [equivocating_validators] of its final state.
*)

Section sec_witnessed_equivocation_fixed_set.

Context
  {message : Type}
  `{FinSet index Ci}
  `{!finite.Finite index}
  (IM : index -> VLSM message)
  `{forall i, HasBeenSentCapability (IM i)}
  `{forall i, HasBeenReceivedCapability (IM i)}
  (threshold : R)
  `{finite.Finite validator}
  `{ReachableThreshold validator Cv threshold}
  (A : validator -> index)
  (sender : message -> option validator)
  (Free := free_composite_vlsm IM)
  `{RelDecision _ _ (is_equivocating_tracewise_no_has_been_sent IM A sender)}
  (Htracewise_BasicEquivocation : BasicEquivocation (composite_state IM) validator Cv threshold
    := equivocation_dec_tracewise IM threshold A sender)
  `{FinSet message Cm}
  (message_dependencies : message -> Cm)
  `{!Irreflexive (msg_dep_happens_before message_dependencies)}
  `{forall i, MessageDependencies (IM i) message_dependencies}
  (Hfull : forall i, message_dependencies_full_node_condition_prop (IM i) message_dependencies)
  (no_initial_messages_in_IM : no_initial_messages_in_IM_prop IM)
  (can_emit_signed : channel_authentication_prop IM A sender)
  (Hsender_safety : sender_safety_alt_prop IM A sender :=
    channel_authentication_sender_safety IM A sender can_emit_signed)
  (Free_has_sender :=
    composite_no_initial_valid_messages_have_sender IM A sender
      can_emit_signed no_initial_messages_in_IM (free_constraint IM))
  (equivocating_validators :=
    equivocating_validators (BasicEquivocation := Htracewise_BasicEquivocation))
  .

Existing Instance Htracewise_BasicEquivocation.

(**
  Given the fact that the set of [equivocating_validators] can be empty,
  and the definition of the [fixed_equivocation_constraint] requires
  a non-empty set (to allow the composition of equivocators to exist),
  we default the constraint to the [composite_no_equivocation] one
  when there are no [equivocating_validators].
*)
Definition equivocating_validators_fixed_equivocation_constraint
  (s : composite_state IM)
  :=
  fixed_equivocation_constraint IM (Ci := Ci) (fin_sets.set_map A (equivocating_validators s)).

Lemma equivocators_can_emit_free m
  (Hmsg : valid_message_prop Free m)
  v
  (Hsender : sender m = Some v)
  sf
  (Hequivocating_v : v ∈ equivocating_validators sf)
  l s
  (Hv : composite_valid IM l (s, Some m))
  : can_emit
    (equivocators_composition_for_directly_observed IM (Ci := Ci) (fin_sets.set_map A (equivocating_validators sf)) s)
    m.
Proof.
  apply emitted_messages_are_valid_iff in Hmsg
    as [(_v & [_im Him] & Heqim) | Hiom]
  ; [by elim (no_initial_messages_in_IM _v _im) |].
  apply (VLSM_incl_can_emit (vlsm_incl_pre_loaded_with_all_messages_vlsm (free_composite_vlsm IM)))
    in Hiom.
  apply can_emit_composite_project in Hiom as [_v Hiom].
  specialize (Hsender_safety _ _ Hsender _ Hiom) as Heq_v. simpl in Heq_v.
  subst _v.
  eapply message_dependencies_are_sufficient in Hiom.
  unfold pre_loaded_free_equivocating_vlsm_composition, free_equivocating_vlsm_composition.
  specialize
    (@lift_to_composite_generalized_preloaded_VLSM_embedding
      message (sub_index (elements (C := Ci) (fin_sets.set_map A (equivocating_validators sf)))) _ (sub_IM IM (elements(fin_sets.set_map A (equivocating_validators sf))))
      (fun msg : message => msg ∈ message_dependencies m)
      (composite_has_been_directly_observed IM s))
    as Hproj.
  spec Hproj.
  {
    intros dm Hdm.
    destruct l as (i, li). simpl in Hv.
    apply (Hfull _ _ _ _ Hv) in Hdm.
    by exists i.
  }
  eapply VLSM_embedding_can_emit; [| done].
  unshelve eapply (Hproj (dexist (A v) _)).
  by apply elem_of_elements, elem_of_map_2.
Qed.

(** *** Main result of the section

  Any Free valid trace with the
  [strong_trace_witnessing_equivocation_prop]erty is also valid w.r.t. the
  composition using the [equivocating_validators_fixed_equivocation_constraint]
  induced by its final state.

  The proof proceeds by induction on the valid trace property.
  Lemmas [equivocating_validators_witness_monotonicity] and
  [fixed_equivocation_vlsm_composition_index_incl] are used to restate the
  induction hypothesis in terms of the final state after the last transition.
*)

Lemma strong_witness_has_fixed_equivocation is s tr
  (Htr : finite_valid_trace_init_to (free_composite_vlsm IM) is s tr)
  (Heqv : strong_trace_witnessing_equivocation_prop (Cv := Cv) IM threshold A sender is tr)
  : finite_valid_trace_init_to (fixed_equivocation_vlsm_composition IM (Ci := Ci)
      (fin_sets.set_map A (equivocating_validators s))) is s tr.
Proof.
  split; [| by apply Htr].
  induction Htr using finite_valid_trace_init_to_rev_ind.
  - eapply (finite_valid_trace_from_to_empty (fixed_equivocation_vlsm_composition IM
      (Ci := Ci) (fin_sets.set_map A (equivocating_validators si)))).
    by apply initial_state_is_valid.
  - spec IHHtr.
    { intros prefix. intros.
      apply (Heqv prefix (suffix ++  [{| l := l; input := iom; destination := sf; output := oom |}])).
      by subst; apply app_assoc.
    }
    apply (VLSM_incl_finite_valid_trace_init_to (vlsm_incl_pre_loaded_with_all_messages_vlsm Free))
      in Htr as Hpre_tr.
    assert
      (Htr_sf : finite_valid_trace_from_to
        (fixed_equivocation_vlsm_composition IM (Ci := Ci) (fin_sets.set_map A (equivocating_validators sf))) si s tr).
    { revert IHHtr.
      apply VLSM_incl_finite_valid_trace_from_to,
               fixed_equivocation_vlsm_composition_index_incl.
      apply elements_subseteq, set_map_subset.
      remember {| destination := sf |} as item.
      replace sf with (destination item) by (subst; done).
      eapply equivocating_validators_witness_monotonicity; [done |].
      by apply Heqv with (suffix := []), app_nil_r.
    }
    clear IHHtr.
    apply (extend_right_finite_trace_from_to _ Htr_sf).
    destruct Ht as [(Hs & Hiom & Hv & _) Ht].
    apply finite_valid_trace_from_to_last_pstate in Htr_sf as Hs'.
    specialize
      (Heqv
        (tr ++ [{| l := l; input := iom; destination := sf; output := oom |}])
        []).
    spec Heqv; [by apply app_nil_r |].
    destruct iom as [im |]; [| by repeat split; auto using option_valid_message_None].
    apply Free_has_sender in Hiom as _Hsender.
    destruct (sender im) as [v |] eqn: Hsender; [| by congruence].
    clear _Hsender.
    specialize (Heqv v).
    rewrite finite_trace_last_is_last in Heqv.
    simpl in Heqv.
    assert (Hpre_s : valid_state_prop (pre_loaded_with_all_messages_vlsm Free) s).
    { by apply proj1, finite_valid_trace_from_to_last_pstate in Hpre_tr. }
    destruct (@decide _ (composite_has_been_directly_observed_dec IM s im)).
    { repeat split
      ; [done | apply option_valid_message_Some | done | | done].
      - by apply (composite_directly_observed_valid IM _ s).
      - by left.
    }
    assert (Hequivocating_v : v ∈ equivocating_validators sf).
    { apply Heqv. exists im. split; [done |].
      eexists tr, _, [].
      split; [done |].
      split; [done |].
      intros Him_output.
      elim n.
      apply composite_has_been_directly_observed_sent_received_iff.
      left.
      specialize (proper_sent Free _ Hpre_s im) as Hsent_s.
      apply proj2 in Hsent_s. apply Hsent_s. clear Hsent_s.
      apply (has_been_sent_consistency Free _ Hpre_s im).
      by exists si, tr, Hpre_tr.
    }
    specialize (equivocators_can_emit_free _ Hiom _ Hsender _ Hequivocating_v  _ _ Hv) as Hemit_im.
    repeat split; [done | | done | by right | done].
    apply emitted_messages_are_valid.
    specialize
      (EquivPreloadedBase_Fixed_weak_embedding IM _ _ Hs') as Hproj.
    spec Hproj; [by intros; apply no_initial_messages_in_IM |].
    apply (VLSM_weak_embedding_can_emit Hproj).
    by apply (VLSM_incl_can_emit (Equivocators_Fixed_Strong_incl IM _  _ Hs')).
Qed.

(**
  As a corollary of the above, every valid state for the free composition is
  also a valid state for the composition with the
  [equivocating_validators_fixed_equivocation_constraint] induced by it.
*)
Lemma equivocating_validators_fixed_equivocation_characterization
  (Hke : WitnessedEquivocationCapability IM threshold A sender (Cv := Cv))
  : forall s,
    valid_state_prop Free s ->
    valid_state_prop
      (composite_vlsm IM (equivocating_validators_fixed_equivocation_constraint s)) s.
Proof.
  intros s Hs.
  destruct
    (free_has_strong_trace_witnessing_equivocation_prop IM threshold A sender _ s Hs)
    as [is [tr [Htr Heqv]]].
  cut (finite_valid_trace_from_to (composite_vlsm IM
    (equivocating_validators_fixed_equivocation_constraint s)) is s tr).
  { by intro Htr'; apply finite_valid_trace_from_to_last_pstate in Htr'. }
  by apply strong_witness_has_fixed_equivocation.
Qed.

End sec_witnessed_equivocation_fixed_set.