(*
  This module defines the functional unit entries for floating
  point arithmetic.

  TODO: WARNING: check that the instructions set exceptions on invalid rounding modes.
*)
Require Import Kami.AllNotations.
Require Import FpuKami.Definitions.
Require Import FpuKami.MulAdd.
Require Import FpuKami.Compare.
Require Import FpuKami.NFToIN.
Require Import FpuKami.INToNF.
Require Import FpuKami.Classify.
Require Import FpuKami.ModDivSqrt.
Require Import FpuKami.Round.
Require Import ProcKami.FU.
Require Import ProcKami.RiscvIsaSpec.Insts.Fpu.FpuFuncs.
Require Import List.
Import ListNotations.

Section Fpu.
  Context `{procParams: ProcParams}.

  Variable fpuParamsSingle : FpuParams.
  Variable fpuParamsDouble : FpuParams.

  Local Notation single_expWidthMinus2 := (@expWidthMinus2 fpuParamsSingle).
  Local Notation single_sigWidthMinus2 := (@sigWidthMinus2 fpuParamsSingle).
  Local Notation double_expWidthMinus2 := (@expWidthMinus2 fpuParamsDouble).
  Local Notation double_sigWidthMinus2 := (@sigWidthMinus2 fpuParamsDouble).

  Local Definition single_Flen := single_expWidthMinus2 + 1 + 1 + (single_sigWidthMinus2 + 1 + 1).
  Local Definition double_Flen := double_expWidthMinus2 + 1 + 1 + (double_sigWidthMinus2 + 1 + 1).

  Open Scope kami_expr.

  Definition Float_double
    :  FUEntry
    := {|
         fuName := "float_double";
         fuFunc
           := fun ty (sem_in_pkt_expr : RoundInput single_expWidthMinus2 single_sigWidthMinus2 ## ty)
                => LETE sem_in_pkt
                     :  RoundInput single_expWidthMinus2 single_sigWidthMinus2
                     <- sem_in_pkt_expr;
                   RoundNF_def_expr double_expWidthMinus2 double_sigWidthMinus2 #sem_in_pkt;
         fuInsts
           := [
                {|
                  instName   := "fcvt.d.s";
                  xlens      := xlens_all;
                  extensions := ["D"];
                  ext_ctxt_off := ["fs"];
                  uniqId
                    := [
                         fieldVal instSizeField ('b"11");
                         fieldVal opcodeField   ('b"10100");
                         fieldVal rs2Field      ('b"00000");
                         fieldVal funct7Field   ('b"0100001")
                       ];
                  inputXform
                    := (fun ty (cfg_pkt : ContextCfgPkt @# ty) context_pkt_expr
                          => LETE context_pkt <- context_pkt_expr;
                             RetE
                               (STRUCT {
                                  "in"
                                    ::= @bitToNF fpuParamsSingle ty
                                          (@fp_get_float fpuParamsSingle ty
                                             Rlen
                                             Flen
                                             (#context_pkt @% "reg1"));
                                  "afterRounding" ::= $$false;
                                  "roundingMode"  ::= rounding_mode (#context_pkt)
                                } : RoundInput single_expWidthMinus2 single_sigWidthMinus2 @# ty));
                  outputXform
                    := (fun ty (sem_out_pkt_expr : OpOutput double_expWidthMinus2 double_sigWidthMinus2 ## ty)
                        => LETE sem_out_pkt <- sem_out_pkt_expr;
                             LETC val1: RoutedReg <- (STRUCT {
                                                    "tag"  ::= (Const ty (natToWord RoutingTagSz FloatRegTag) : RoutingTag @# ty);
                                                    "data" ::= (OneExtendTruncLsb Rlen (NFToBit (#sem_out_pkt @% "out")) : Bit Rlen @# ty)
                                                     });
                             LETC val2: RoutedReg <- (STRUCT {
                                                    "tag"  ::= (Const ty (natToWord RoutingTagSz FflagsTag) : RoutingTag @# ty);
                                                    "data" ::= (csr (#sem_out_pkt @% "exceptionFlags") : Bit Rlen @# ty)
                                                     });
                             LETC fstVal
                               :  ExecUpdPkt
                               <- (noUpdPkt ty)
                                    @%["val1" <- (Valid #val1)]
                                    @%["val2" <- (Valid #val2)];
                             RetE
                               (STRUCT {
                                  "fst"
                                    ::= #fstVal;
                                  "snd" ::= Invalid
                                } : PktWithException ExecUpdPkt @# ty));
                  optMemParams := None;
                  instHints   := falseHints<|hasFrs1 := true|><|hasFrd := true|>
                |}
              ]
       |}.

  Definition Double_float
    :  FUEntry
    := {|
         fuName := "double_float";
         fuFunc
           := fun ty (sem_in_pkt_expr : RoundInput double_expWidthMinus2 double_sigWidthMinus2 ## ty)
                => LETE sem_in_pkt
                     :  RoundInput double_expWidthMinus2 double_sigWidthMinus2
                     <- sem_in_pkt_expr;
                   RoundNF_def_expr single_expWidthMinus2 single_sigWidthMinus2 #sem_in_pkt;
         fuInsts
           := [
                {|
                  instName   := "fcvt.s.d";
                  xlens      := xlens_all;
                  extensions := ["D"];
                  ext_ctxt_off := ["fs"];
                  uniqId
                    := [
                         fieldVal instSizeField ('b"11");
                         fieldVal opcodeField   ('b"10100");
                         fieldVal rs2Field      ('b"00001");
                         fieldVal funct7Field   ('b"0100000")
                       ];
                  inputXform
                    := (fun ty (cfg_pkt : ContextCfgPkt @# ty) context_pkt_expr
                          => LETE context_pkt <- context_pkt_expr;
                             RetE
                               (STRUCT {
                                  "in"
                                    ::= @bitToNF fpuParamsDouble ty
                                          (@fp_get_float fpuParamsDouble ty
                                             Rlen
                                             Flen
                                             (#context_pkt @% "reg1"));
                                  "afterRounding" ::= $$false;
                                  "roundingMode"  ::= rounding_mode (#context_pkt)
                                } : RoundInput double_expWidthMinus2 double_sigWidthMinus2 @# ty));
                  outputXform
                    := (fun ty (sem_out_pkt_expr : OpOutput single_expWidthMinus2 single_sigWidthMinus2 ## ty)
                        => LETE sem_out_pkt <- sem_out_pkt_expr;
                             LETC val1: RoutedReg <- (STRUCT {
                                                    "tag"  ::= (Const ty (natToWord RoutingTagSz FloatRegTag) : RoutingTag @# ty);
                                                    "data" ::= (OneExtendTruncLsb Rlen (NFToBit (#sem_out_pkt @% "out")) : Bit Rlen @# ty)
                                          });
                             LETC val2: RoutedReg <- (STRUCT {
                                                    "tag"  ::= (Const ty (natToWord RoutingTagSz FflagsTag) : RoutingTag @# ty);
                                                    "data" ::= (csr (#sem_out_pkt @% "exceptionFlags") : Bit Rlen @# ty)
                                          });
                             LETC fstVal
                               :  ExecUpdPkt
                               <- (noUpdPkt ty)
                                    @%["val1" <- (Valid #val1)]
                                    @%["val2" <- (Valid #val2)];
                             RetE
                               (STRUCT {
                                  "fst"
                                    ::= #fstVal;
                                  "snd" ::= Invalid
                                } : PktWithException ExecUpdPkt @# ty));
                  optMemParams := None;
                  instHints   := falseHints<|hasFrs1 := true|><|hasFrd := true|>
                |}
              ]
       |}.

  Close Scope kami_expr.

End Fpu.


(** * Push-Button Synthesis of Montgomery Reduction *)
Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Coq.Lists.List.
Require Import Coq.derive.Derive.
Require Import Crypto.Util.ErrorT.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.ModInv.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import Crypto.Util.ZUtil.Tactics.RewriteModSmall.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Crypto.Stringification.Language.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.FancyMontgomeryReduction.
Require Import Crypto.BoundsPipeline.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.Fancy.Compiler.
Require Import Crypto.PushButtonSynthesis.ReificationCache.
Require Import Crypto.PushButtonSynthesis.Primitives.
Require Import Crypto.PushButtonSynthesis.FancyMontgomeryReductionReificationCache.
Require Import Crypto.PushButtonSynthesis.InvertHighLow.
Import ListNotations.
Local Open Scope string_scope. Local Open Scope Z_scope. Local Open Scope list_scope. Local Open Scope bool_scope.

Import
  Language.Compilers
  Language.Wf.Compilers
  Stringification.Language.Compilers.
Import Compilers.API.

Import COperationSpecifications.Primitives.

Import COperationSpecifications.MontgomeryReduction.

Import Associational Positional FancyMontgomeryReduction.MontgomeryReduction.

Local Set Keyed Unification. (* needed for making [autorewrite] fast, c.f. COQBUG(https://github.com/coq/coq/issues/9283) *)

Local Opaque reified_montred_gen. (* needed for making [autorewrite] not take a very long time *)

Section rmontred.
  Context {output_language_api : ToString.OutputLanguageAPI}
          {pipeline_opts : PipelineOptions}
          {pipeline_to_string_opts : PipelineToStringOptions}
          {synthesis_opts : SynthesisOptions}
          (N R N' : Z) (n : nat)
          (machine_wordsize : machine_wordsize_opt).

  Let value_range := r[0 ~> (2^machine_wordsize - 1)%Z]%zrange.
  Let flag_range := r[0 ~> 1]%zrange.
  Let bound := Some value_range.
  Let consts_list := [N; N'].
  Let R' := Z.modinv R N.

  Definition possible_values_of_machine_wordsize
    := [1; machine_wordsize / 2; machine_wordsize; 2 * machine_wordsize]%Z.
  Local Arguments possible_values_of_machine_wordsize / .

  Local Notation possible_values := possible_values_of_machine_wordsize.

  Local Instance no_select_size : no_select_size_opt := no_select_size_of_no_select machine_wordsize.
  Local Instance split_mul_to : split_mul_to_opt := split_mul_to_of_should_split_mul machine_wordsize possible_values.
  Local Instance split_multiret_to : split_multiret_to_opt := split_multiret_to_of_should_split_multiret machine_wordsize possible_values.

  Local Instance fancy_args : translate_to_fancy_opt
    := (Some {| BoundsPipeline.invert_low log2wordsize := invert_low log2wordsize consts_list;
                BoundsPipeline.invert_high log2wordsize := invert_high log2wordsize consts_list;
                BoundsPipeline.value_range := value_range;
                BoundsPipeline.flag_range := flag_range |}).

  Local Instance fancy_args_good : translate_to_fancy_opt_correct.
  Proof using consts_list value_range.
    cbv [translate_to_fancy_opt_correct translate_to_fancy fancy_args invert_low invert_high constant_to_scalar constant_to_scalar_single consts_list fold_right];
      split; intros; break_innermost_match_hyps; Z.ltb_to_lt; subst; congruence.
  Qed.

  (** Note: If you change the name or type signature of this
        function, you will need to update the code in CLI.v *)
  Definition check_args {T} (requests : list string) (res : Pipeline.ErrorT T)
    : Pipeline.ErrorT T
    := fold_right
         (fun '(b, e) k => if b:bool then Error e else k)
         res
         [
            ((negb (1 <? R))%Z, Pipeline.Value_not_ltZ "R ≤ 1" 1 R);
            ((n =? 0)%nat, Pipeline.Values_not_provably_distinctZ "n = 0" (Z.of_nat n) 0);
            ((R' =? 0)%Z, Pipeline.No_modular_inverse "R⁻¹ mod N" R N);
            (negb ((R * R') mod N =? 1 mod N)%Z, Pipeline.Values_not_provably_equalZ "(R * R') mod N ≠ 1 mod N" ((R * R') mod N) (1 mod N));
            (negb ((N * N') mod R =? (-1) mod R)%Z, Pipeline.Values_not_provably_equalZ "(N * N') mod R ≠ (-1) mod R" ((N * N') mod R) ((-1) mod R));
            (negb (2 ^ machine_wordsize =? R)%Z, Pipeline.Values_not_provably_equalZ "2^machine_wordsize ≠ R" (2^machine_wordsize) R);
            ((negb (0 <? N))%Z, Pipeline.Value_not_ltZ "N ≤ 0" 0 N);
            ((negb (N <? R))%Z, Pipeline.Value_not_ltZ "R ≤ N" R N);
            ((negb (0 <=? N'))%Z, Pipeline.Value_not_leZ "N' < 0" 0 N');
            ((negb (N' <? R))%Z, Pipeline.Value_not_ltZ "R ≤ N'" R N');
            ((negb (2 <=? machine_wordsize))%Z, Pipeline.Value_not_leZ "machine_wordsize < 2" 2 machine_wordsize)].

  Local Arguments Z.mul !_ !_.

  Local Ltac use_curve_good_t :=
    repeat first [ assumption
                 | progress cbv [EquivModulo.Z.equiv_modulo]
                 | progress rewrite ?Z.mul_0_r, ?Pos.mul_1_r, ?Z.mul_1_r in *
                 | reflexivity
                 | lia
                 | progress cbn in *
                 | progress intros
                 | solve [ auto with zarith ]
                 | rewrite Z.log2_pow2 by use_curve_good_t ].

  Context (requests : list string)
          (curve_good : check_args requests (Success tt) = Success tt).

  Lemma use_curve_good
    : 0 <= N < R
      /\ 0 <= N' < R
      /\ N <> 0
      /\ R > 1
      /\ EquivModulo.Z.equiv_modulo R (N * N') (-1)
      /\ EquivModulo.Z.equiv_modulo N (R * R') 1
      /\ n <> 0%nat
      /\ 2 <= machine_wordsize
      /\ 2 ^ machine_wordsize = R.
  Proof using curve_good.
    prepare_use_curve_good ().
    { use_curve_good_t. }
    { use_curve_good_t. }
    { use_curve_good_t. }
  Qed.

  Definition montred
    := Pipeline.BoundsPipeline
         false (* subst01 *)
         possible_values
         (reified_montred_gen
            @ GallinaReify.Reify N @ GallinaReify.Reify R @ GallinaReify.Reify N' @ GallinaReify.Reify (machine_wordsize:Z))
         (bound, (bound, tt))
         bound.

  Definition smontred (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "montred" montred
          (fun _ _ _ => @nil string).

  Local Ltac solve_montred_preconditions :=
    repeat first [ lia
           | apply use_curve_good
           | progress (push_Zmod; pull_Zmod)
           | progress autorewrite with zsimplify_fast
           | rewrite Z.div_add' by lia
           | rewrite Z.div_small by lia
           | progress Z.rewrite_mod_small ].

  Local Strategy -100 [montred]. (* needed for making Qed not take forever *)
  Local Strategy -100 [montred']. (* needed for making prove_correctness not take forever *)
  Lemma montred_correct res (Hres : montred = Success res)
    : montred_correct N R R' (API.Interp res).
  Proof using n curve_good.
    cbv [montred_correct]; intros.
    rewrite <- MontgomeryReduction.montred'_correct with (R:=R) (N':=N') (Zlog2R:=machine_wordsize) (n:=n) (lo:=lo) (hi:=hi) by solve_montred_preconditions.
    prove_correctness' ltac:(fun _ => idtac) use_curve_good.
    { cbv [ZRange.type.base.option.is_bounded_by ZRange.type.base.is_bounded_by bound is_bounded_by_bool value_range upper lower].
      rewrite Bool.andb_true_iff, !Z.leb_le. lia. }
    { cbv [ZRange.type.base.option.is_bounded_by ZRange.type.base.is_bounded_by bound is_bounded_by_bool value_range upper lower].
      rewrite Bool.andb_true_iff, !Z.leb_le. lia. }
  Qed.

  Lemma Wf_montred res (Hres : montred = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.
End rmontred.

Module Export Hints.
#[global]
  Hint Opaque
       montred
  : wf_op_cache.
#[global]
  Hint Immediate
       Wf_montred
  : wf_op_cache.
End Hints.


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 E Eprime P A B C A1 B1 C1 N C1prime M : Universe, ((wd_ N E /\ (wd_ A C /\ (wd_ B P /\ (wd_ A B /\ (wd_ N M /\ (wd_ M C1 /\ (wd_ N C1 /\ (wd_ C1 C1prime /\ (wd_ N C1prime /\ (wd_ E Eprime /\ (wd_ N Eprime /\ (wd_ P A /\ (wd_ P C /\ (wd_ C1prime A1 /\ (wd_ N A1 /\ (wd_ N B1 /\ (wd_ M C1prime /\ (wd_ N N /\ (wd_ A1 Eprime /\ (col_ P A B /\ (col_ C B P /\ (col_ N E C1 /\ (col_ N E B1 /\ (col_ N E A1 /\ (col_ M C1 C1prime /\ (col_ N C1prime N /\ (col_ N C1 N /\ col_ N A1 C1))))))))))))))))))))))))))) -> col_ P A C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Goal (forall T : Type, T = T) -> Type.
Proof.
  intro H.
  Fail specialize (H _).
Abort.


(*

Author:  Adam Petz, ampetz@ku.edu
*)
Require Import Maps Impl_vm.
Require Import Coq.Arith.EqNat.
Require Import Term StVM StAM
        MonadVM GenStMonad ConcreteEvidence VmSemantics.
(*Require Import Coq.ZArith.ZArith_base Coq.Strings.String Coq.Strings.Ascii. *)
(* Require Import ExtLib.Data.Monads.StateMonad ExtLib.Data.Monads.ReaderMonad
ExtLib.Structures.Monads ExtLib.Data.Monads.IdentityMonad. *)
Require Import List.

(* Import MonadNotation. *)
Import ListNotations.
(* Local Open Scope monad_scope. *)

(*
Definition Policy := nat.

Record AM_Env : Type := mkAM_Env
                          { myPolicy : Policy}.

Definition init_env := (mkAM_Env 0).
 *)

(* ident is the identity monad, acting as a place-holder for the base monad.
   TODO:  eventually we need this to be IO (or something that models IO) *)
Definition AM := St AM_St.     (* readerT AM_Env (stateT AM_St ident). *)

(*
Definition am_newNonce (bs :BS) : AM EvidenceC :=
  (*let myPol := asks myPolicy in *)
  am_st <- get ;;
  let mm := am_nonceMap am_st in
  let i := am_nonceId am_st in
  let appm := st_aspmap am_st in
  let sigm := st_sigmap am_st in
  (*let plm := am_pl am_st in *)

  let newMap := map_set mm i bs in
  let newId := i + 1 in
  put (mkAM_St newMap newId appm sigm (*plm*)) ;;
      ret (nnc i bs mtc).
*)

Definition runAM {A:Type} (k:(AM A)) (* (env:AM_Env) *) (st:AM_St) : (option A) * AM_St :=
  runSt k st.

(*
Definition incNonce := runAM (am_newNonce 42) empty_amst.
Check incNonce.
Compute (incNonce).

Check annotated.
*)

Definition am_run_t (t:Term) (e:EvidenceC) : AM EvidenceC :=
  let annt := annotated t in
  let start_st := mk_st e [] 0 [] in
  ret (st_ev (run_vm annt start_st)).

Definition t1 := (att 1 (lseq (asp (ASPC 44 [])) (asp SIG))).
Definition t2 := (lseq (asp (ASPC 44 [])) (asp SIG)).

(*
Compute (am_run_t t2 mtc empty_amst).
*)

(*
Definition am_proto_1 :=
  n2 <- am_newNonce 42 ;;
    n <- am_newNonce 43 ;;
    am_run_t t2 n.

Compute (runAM am_proto_1 empty_amst).
*)

(*
Fixpoint nonces (e:EvidenceC) (l:list nat) : list nat :=
  match e with
  | nnc i _ e' => nonces e' ([i] ++ l)
  | _ => l
  end.
 *)

(** * Helper functions for Appraisal *)

Definition am_get_app_asp (p:Plc) (i:ASP_ID) : AM ASP_ID :=
  m <- gets st_aspmap ;;
  let maybeId := map_get m (p,i) in
  match maybeId with
  | Some i' => ret i'
  | None => failm
  end.

Definition am_get_sig_asp (p:Plc) : AM ASP_ID :=
  m <- gets st_sigmap ;;
  let maybeId := map_get m p in
  match maybeId with
  | Some i' => ret i'
  | None => failm
  end.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University
  Copyright 2018 Cornell University

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

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

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

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

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export alphaeq4.
Require Export stronger_continuity_defs4.
Require Export per_props_nat2.
Require Export per_props_squash.
Require Export sequents_tacs.

Definition mod_fun_type {o} (x : NVar) : @NTerm o :=
  mk_function
    mk_tnat
    x
    (mk_fun (mk_natk2nat (mk_var x))  mk_natU).

Lemma lsubstc_mod_fun_type {o} :
  forall v w (s : @CSub o) c,
    alphaeqc (lsubstc (mod_fun_type v) w s c) modulus_fun_type_u.
Proof.
  introv.
  unfold mod_fun_type.
  lsubst_tac.
  allrw @lsubstc_mkc_tnat.
  unfold modulus_fun_type.

  apply implies_alphaeqc_mkc_function; eauto 2 with slow.
  introv.
  repeat substc_lsubstc_vars3.
  eapply alphaeqc_trans;[|apply alphaeqc_sym;apply substc_mkcv_fun].

  match goal with
    | [ |- context[lsubstc (mk_fun ?a ?b) ?w ?s ?c] ] =>
      pose proof (lsubstc_mk_fun_ex a b s w c) as h;
        exrepnd; clear_irr
  end.
  eapply alphaeqc_trans;[exact h1|]; clear h1.

  apply alphaeqc_mkc_fun.

  - eapply alphaeqc_trans;[|apply alphaeqc_sym;apply substc_mkcv_fun].
    eapply alphaeqc_trans;
      [|apply alphaeqc_sym;apply alphaeqc_mkc_fun;
        [apply mkcv_natk_substc
        |apply alphaeqc_refl]
      ].
    rw @mkcv_tnat_substc.
    rw @mkc_var_substc.

    eapply alphaeqc_trans;[apply lsubstc_mk_natk2nat_sp1|].
    eauto 2 with slow.

  - eapply alphaeqc_trans;[apply lsubstc_mk_natU|].
    rw @csubst_mk_cv; eauto 3 with slow.
Qed.

Lemma lsubstc_nat2nat_to_nat {o} :
  forall w (s : @CSub o) c,
    alphaeqc
      (lsubstc (mk_fun mk_nat2nat mk_tnat) w s c)
      (mkc_fun nat2nat mkc_tnat).
Proof.
  introv.
  unfold alphaeqc; simpl.
  eapply alpha_eq_trans;[apply csubst_mk_fun|].
  autorewrite with slow.
  apply alpha_eq_mk_fun; auto.
  unfold mk_nat2nat.
  eapply alpha_eq_trans;[apply csubst_mk_fun|].
  autorewrite with slow; auto.
Qed.
Hint Resolve lsubstc_nat2nat_to_nat : slow.

(* XXXXXXXXXX *)

Definition mk_sqexists {o} (a : @NTerm o) v b := mk_squash (mk_exists a v b).

Definition strong_continuous_type {o} (x M f n : NVar) (F : @NTerm o) :=
  mk_sqexists
    (mod_fun_type x)
    M
    (mk_all
       mk_nat2nat
       f
       (mk_sqexists
          mk_tnat
          n
          (mk_equality
             (mk_apply2 (mk_var M) (mk_var n) (mk_var f))
             (mk_apply F (mk_var f))
             mk_natU))).

Definition rule_strong_continuity {o}
           (F : @NTerm o)
           (x M f n : NVar)
           (H : barehypotheses) :=
    mk_rule
      (mk_baresequent H (mk_conclax (strong_continuous_type x M f n F)))
      [ mk_baresequent H (mk_conclax (mk_member F (mk_fun mk_nat2nat mk_tnat))) ]
      [].

Lemma rule_strong_continuity_true {p} :
  forall lib
         (F : NTerm)
         (x M f n : NVar)
         (H : @barehypotheses p)
         (d1 : M <> f)
         (d2 : n <> f)
         (d3 : n <> M)
         (d4 : !LIn M (free_vars F))
         (d5 : !LIn f (free_vars F))
         (d6 : !LIn n (free_vars F)),
    rule_true lib (rule_strong_continuity
                     F
                     x M f n
                     H).
Proof.
  unfold rule_strong_continuity, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  rename Hyp into hyp1.
  destruct hyp1 as [wc1 hyp1].
  destseq; allsimpl; proof_irr; GC.
  unfold closed_extract; simpl.

  exists (@covered_axiom p (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  vr_seq_true.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as h; exrepnd; clear hyp1.

  allunfold @strong_continuous_type.
  allunfold @mk_sqexists.
  lsubst_tac.

  apply member_if_inhabited in h1.
  apply tequality_mkc_member in h0; repnd.
  allrw @fold_equorsq.
  clear h2.

  lsubst_tac.
  allrw @lsubstc_mkc_tnat.
  eapply member_respects_alphaeqc_r in h1;
    [|apply alphaeqc_mkc_fun;[apply lsubstc_mk_nat2nat|apply alphaeqc_refl] ].
  autodimp h0 hyp.
  { clear - h1.
    lsubst_tac.
    eapply member_respects_alphaeqc_r;
      [apply alphaeqc_sym;apply alphaeqc_mkc_fun;[apply lsubstc_mk_nat2nat|apply alphaeqc_refl]|].
    autorewrite with slow in *; auto. }
  eapply alphaeqc_preserving_equality in h0;
    [|apply lsubstc_nat2nat_to_nat];[].

  dup h1 as memF.
  dup h0 as eqF.

  prove_and teq.

  - apply tequality_mkc_squash.

    unfold mk_exists.
    lsubst_tac.

    apply tequality_product.
    dands.

    + eapply tequality_respects_alphaeqc_left;
      [apply alphaeqc_sym; apply lsubstc_mod_fun_type|].
      eapply tequality_respects_alphaeqc_right;
        [apply alphaeqc_sym; apply lsubstc_mod_fun_type|].
      apply type_modulus_fun_type_u.

    + intros M1 M2 em.
      eapply alphaeqc_preserving_equality in em;[|apply lsubstc_mod_fun_type].
      repeat substc_lsubstc_vars3.

      unfold mk_all.
      lsubst_tac.

      apply tequality_function; dands.

      * eapply tequality_respects_alphaeqc_left;
        [apply alphaeqc_sym; apply lsubstc_mk_nat2nat|].
        eapply tequality_respects_alphaeqc_right;
          [apply alphaeqc_sym; apply lsubstc_mk_nat2nat|].
        apply type_nat2nat.

      * intros f1 f2 en2n.
        eapply alphaeqc_preserving_equality in en2n;[|apply lsubstc_mk_nat2nat].
        repeat substc_lsubstc_vars3.
        lsubst_tac.
        apply tequality_mkc_squash.
        allrw @lsubstc_mkc_tnat.

        apply tequality_product; dands; eauto 3 with slow.
        { apply type_tnat. }

        intros n1 n2 en.
        repeat substc_lsubstc_vars3.
        a_lsubst_tac.

        apply tequality_mkc_equality_if_equal.

        { eapply tequality_respects_alphaeqc_left;
          [apply alphaeqc_sym; apply lsubstc_mk_natU|].
          eapply tequality_respects_alphaeqc_right;
            [apply alphaeqc_sym; apply lsubstc_mk_natU|].
          apply type_natU. }

        { eapply alphaeqc_preserving_equality;
          [|apply alphaeqc_sym; apply lsubstc_mk_natU].

          apply equality_in_function2 in em; repnd.
          clear em0.
          applydup em in en as e.
          eapply alphaeqc_preserving_equality in e;[|apply substc_mkcv_fun].
          rw @csubst_mk_cv in e.

          try (fold (@natU p) in e).
          eapply alphaeqc_preserving_equality in e;
            [|apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
              apply substc_mkcv_fun].
          eapply alphaeqc_preserving_equality in e;
            [|apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
              apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
              apply mkcv_natk_substc
            ].
          allrw @mkc_var_substc.
          allrw @mkcv_tnat_substc.

          try (fold (natk2nat n1) in e).

          applydup @equality_refl in en.
          apply (equality_nat2nat_to_natk2nat lib n1) in en2n; auto;[].

          apply equality_in_fun in e; repnd; clear e0 e1.
          apply e in en2n.
          allrw <- @mkc_apply2_eq; auto. }

        { eapply alphaeqc_preserving_equality;
          [|apply alphaeqc_sym; apply lsubstc_mk_natU].
          apply equality_in_fun in eqF; repnd; clear eqF0 eqF1.
          apply eqF in en2n; auto.
          apply equality_in_bunion_left; eauto 2 with slow. }

  - apply equality_in_mkc_squash; dands;
    try (spcast; apply computes_to_valc_refl; eauto 3 with slow);[].

    unfold mk_exists.
    lsubst_tac.

    exists (mkc_pair (spM_c (lsubstc F wt s1 ct0))
                     (mkc_lam f (mkcv_axiom f))).

    apply equality_in_product.
    dands.

    + eapply type_respects_alphaeqc;
      [apply alphaeqc_sym; apply lsubstc_mod_fun_type|].
      apply type_modulus_fun_type_u.

    + intros M1 M2 em.
      eapply alphaeqc_preserving_equality in em;[|apply lsubstc_mod_fun_type].
      repeat substc_lsubstc_vars3.

      unfold mk_all.
      lsubst_tac.

      apply tequality_function; dands.

      * eapply tequality_respects_alphaeqc_left;
        [apply alphaeqc_sym; apply lsubstc_mk_nat2nat|].
        eapply tequality_respects_alphaeqc_right;
          [apply alphaeqc_sym; apply lsubstc_mk_nat2nat|].
        apply type_nat2nat.

      * intros f1 f2 en2n.
        eapply alphaeqc_preserving_equality in en2n;[|apply lsubstc_mk_nat2nat].
        repeat substc_lsubstc_vars3.
        lsubst_tac.
        apply tequality_mkc_squash.
        allrw @lsubstc_mkc_tnat.

        apply tequality_product; dands; eauto 3 with slow.
        { apply type_tnat. }

        intros n1 n2 en.
        repeat substc_lsubstc_vars3.
        a_lsubst_tac.

        apply tequality_mkc_equality_if_equal.

        { eapply tequality_respects_alphaeqc_left;
          [apply alphaeqc_sym; apply lsubstc_mk_natU|].
          eapply tequality_respects_alphaeqc_right;
            [apply alphaeqc_sym; apply lsubstc_mk_natU|].
          apply type_natU. }

        { eapply alphaeqc_preserving_equality;
          [|apply alphaeqc_sym; apply lsubstc_mk_natU].

          apply equality_in_function2 in em; repnd.
          clear em0.
          applydup em in en as e.
          eapply alphaeqc_preserving_equality in e;[|apply substc_mkcv_fun].
          rw @csubst_mk_cv in e.

          try (fold (@natU p) in e).
          eapply alphaeqc_preserving_equality in e;
            [|apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
              apply substc_mkcv_fun].
          eapply alphaeqc_preserving_equality in e;
            [|apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
              apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
              apply mkcv_natk_substc
            ].
          allrw @mkc_var_substc.
          allrw @mkcv_tnat_substc.

          try (fold (natk2nat n1) in e).

          applydup @equality_refl in en.
          apply (equality_nat2nat_to_natk2nat lib n1) in en2n; auto;[].

          apply equality_in_fun in e; repnd; clear e0 e1.
          apply e in en2n.
          allrw <- @mkc_apply2_eq; auto. }

        { eapply alphaeqc_preserving_equality;
          [|apply alphaeqc_sym; apply lsubstc_mk_natU].
          apply equality_refl in memF.
          apply equality_in_fun in memF; repnd; clear memF0 memF1.
          apply memF in en2n; auto.
          apply equality_in_bunion_left; eauto 2 with slow. }

    + eexists; eexists; eexists; eexists; dands; spcast;
      try (apply computes_to_valc_refl; eauto 3 with slow).

      * eapply alphaeqc_preserving_equality;
        [|apply alphaeqc_sym; apply lsubstc_mod_fun_type].

        apply spM_in_modulus_fun_type_u; auto.

      * repeat substc_lsubstc_vars3.
        unfold mk_all.
        lsubst_tac.

        apply equality_in_function.
        dands.

        { eapply type_respects_alphaeqc;
          [apply alphaeqc_sym; apply lsubstc_mk_nat2nat|].
          eauto 3 with slow. }

        { intros f1 f2 en2n.
          eapply alphaeqc_preserving_equality in en2n;[|apply lsubstc_mk_nat2nat].
          repeat substc_lsubstc_vars3.
          lsubst_tac.
          apply tequality_mkc_squash.
          allrw @lsubstc_mkc_tnat.

          apply tequality_product; dands; eauto 3 with slow.
          { apply type_tnat. }

          intros n1 n2 en.
          repeat substc_lsubstc_vars3.
          a_lsubst_tac.

          apply tequality_mkc_equality_if_equal.

          { eapply tequality_respects_alphaeqc_left;
            [apply alphaeqc_sym; apply lsubstc_mk_natU|].
            eapply tequality_respects_alphaeqc_right;
              [apply alphaeqc_sym; apply lsubstc_mk_natU|].
            apply type_natU. }

          { eapply alphaeqc_preserving_equality;
            [|apply alphaeqc_sym; apply lsubstc_mk_natU].

            pose proof (spM_in_modulus_fun_type_u lib (lsubstc F wt s1 ct0) h1) as h.
            rw @equality_in_function in h; repnd.
            applydup h in en as e.
            eapply alphaeqc_preserving_equality in e;[|apply substc_mkcv_fun].
            rw @csubst_mk_cv in e.

            try (fold (@natU p) in e).
            eapply alphaeqc_preserving_equality in e;
              [|apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
                apply substc_mkcv_fun].
            eapply alphaeqc_preserving_equality in e;
              [|apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
                apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
                apply mkcv_natk_substc
              ].
            allrw @mkc_var_substc.
            allrw @mkcv_tnat_substc.

            try (fold (natk2nat n1) in e).

            applydup @equality_refl in en.
            apply (equality_nat2nat_to_natk2nat lib n1) in en2n; auto;[].

            apply equality_in_fun in e; repnd; clear e0 e1.
            apply e in en2n.
            allrw <- @mkc_apply2_eq; auto. }

          { eapply alphaeqc_preserving_equality;
            [|apply alphaeqc_sym; apply lsubstc_mk_natU].
            apply equality_refl in memF.
            apply equality_in_fun in memF; repnd; clear memF0 memF1.
            apply memF in en2n; auto.
            apply equality_in_bunion_left; eauto 2 with slow. }
        }

        { intros f1 f2 en2n.
          eapply alphaeqc_preserving_equality in en2n;[|apply lsubstc_mk_nat2nat].
          repeat substc_lsubstc_vars3.
          lsubst_tac.

          eapply equality_respects_cequivc_left;
            [apply cequivc_sym;apply cequivc_beta|].
          eapply equality_respects_cequivc_right;
            [apply cequivc_sym;apply cequivc_beta|].
          allrw @substc_mkcv_axiom.

          apply equality_in_mkc_squash; dands; spcast;
          try (apply computes_to_valc_refl; eauto 3 with slow);[].

          applydup @equality_refl in en2n as mf1.
          pose proof (spM_cond lib (lsubstc F wt s1 ct0) f1 h1 mf1) as h.
          exrepnd.

          allrw @lsubstc_mkc_tnat.

          exists (mkc_pair (mkc_nat n0) (@mkc_axiom p)).

          apply equality_in_product; dands; eauto 3 with slow.

          - intros n1 n2 en.
            repeat substc_lsubstc_vars3.
            a_lsubst_tac.

            apply tequality_mkc_equality_if_equal.

            { eapply tequality_respects_alphaeqc_left;
              [apply alphaeqc_sym; apply lsubstc_mk_natU|].
              eapply tequality_respects_alphaeqc_right;
              [apply alphaeqc_sym; apply lsubstc_mk_natU|].
              apply type_natU. }

            { eapply alphaeqc_preserving_equality;
              [|apply alphaeqc_sym; apply lsubstc_mk_natU].

              pose proof (spM_in_modulus_fun_type_u lib (lsubstc F wt s1 ct0) h1) as h.
              rw @equality_in_function in h; repnd.
              applydup h in en as e.
              eapply alphaeqc_preserving_equality in e;[|apply substc_mkcv_fun].
              rw @csubst_mk_cv in e.

              try (fold (@natU p) in e).
              eapply alphaeqc_preserving_equality in e;
                [|apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
                  apply substc_mkcv_fun].
              eapply alphaeqc_preserving_equality in e;
                [|apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
                  apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
                  apply mkcv_natk_substc
                ].
              allrw @mkc_var_substc.
              allrw @mkcv_tnat_substc.

              try (fold (natk2nat n1) in e).

              applydup @equality_refl in en.
              apply (equality_nat2nat_to_natk2nat lib n1) in en2n; auto;[].

              apply equality_in_fun in e; repnd; clear e0 e1.
              applydup @equality_refl in en2n as ef.
              apply e in ef.
              allrw <- @mkc_apply2_eq; auto. }

            { eapply alphaeqc_preserving_equality;
              [|apply alphaeqc_sym; apply lsubstc_mk_natU].
              apply equality_refl in memF.
              apply equality_in_fun in memF; repnd; clear memF0 memF1.
              apply memF in en2n; auto.
              apply equality_in_bunion_left; eauto 2 with slow. }

          - eexists; eexists; eexists; eexists; dands; spcast;
            try (apply computes_to_valc_refl; eauto 3 with slow);
            eauto 3 with slow.

            repeat substc_lsubstc_vars3.
            a_lsubst_tac.

            apply member_equality.
            eapply alphaeqc_preserving_equality;
              [|apply alphaeqc_sym; apply lsubstc_mk_natU].
            auto.
        }
Qed.


From Coq Require Import Init.Nat.
Require Import RuntimeDefinitions.

Fixpoint set_all_zeroes (mu: memory) (block: block_ID) (offset: data_offset) (block_size: nat) (current_size: nat) {struct current_size}: option memory :=
  match current_size with
  | 0 => Some mu
  | S new_size =>
    match (NatMap.find block mu) with
    | None => None
    | Some l =>
      match ((S offset) =? block_size) with
      | true => set_all_zeroes (NatMap.add block (NatMap.add offset (memory_value_data (data_value 0)) l) mu) (S block) 0 block_size new_size
      | false => set_all_zeroes (NatMap.add block (NatMap.add offset (memory_value_data (data_value 0)) l) mu) block (S offset) block_size new_size
      end
    end
  end.
Definition reinitialize_memory (e: raw_enclave_ID) (state: enclave_state) (mu: memory): option memory :=
  match state with
  | enclave_state_value _ E =>
    match (NatMap.find e E) with
    | None => None
    | Some mem_range =>
      match mem_range with
      | enclave_address_and_data l n =>
        match l with
        | address block offset =>
          match (NatMap.find block mu) with
          | None => None
          | Some x => set_all_zeroes mu block offset (length (NatMapProperties.to_list x)) n
          end
        end
      end
    end
  end.


(**************************************************************************)
(*   Mechanised Framework for Local Interactions & Distributed Algorithms *)
(*   T. Balabonski, P. Courtieu, R. Pelle, L. Rieg, X. Urbain             *)
(*   PACTOLE project                                                      *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence.    *)
(*                                                                        *)
(**************************************************************************)

(**************************************************************************)
(**  Mechanised Framework for Local Interactions & Distributed Algorithms
     T. Balabonski, P. Courtieu, R. Pelle, L. Rieg, X. Urbain
     PACTOLE project

     This file is distributed under the terms of the CeCILL-C licence.
                                                                          *)
(**************************************************************************)

Require Import Utf8.
Require Import List SetoidList.
Require Import Decidable.
Require Import Setoid Equalities Morphisms.
Require Import Compare_dec FinFun.
Require Import ZArith Arith_base Arith.Div2 Lia Psatz.
Require Import Pactole.Models.NoByzantine.
Require Import Pactole.CaseStudies.Exploration.Definitions.

Open Scope list_scope.
Set Implicit Arguments.
Typeclasses eauto := (bfs).

Section Tower.

(** Given an abitrary ring *)
Context {RR : RingSpec}.
(** There are kG good robots and no byzantine ones. *)
Variable kG : nat.
Instance Robots : Names := Robots kG 0.

(** Assumptions on the number of robots: it is non zero and strictly divides the ring size. *)
Hypothesis kdn : (ring_size mod kG = 0)%nat.
Hypothesis k_inf_n : (kG < ring_size)%nat.

(** There is no byzantine robot. *)
Instance NoByz : NoByzantine.
Proof using . now split. Qed.

Definition origin : location := of_Z 0.

Notation "!! config" := (@obs_from_config _ _ _ _ multiset_observation config origin) (at level 0).
Notation execute := (execute (UpdFun := UpdFun)).

(** In order to prove that at least one position is occupied, we define the list of positions. *)
Definition Vlist := Identifiers.enum ring_size.

Lemma Vlist_NoDup : NoDupA equiv Vlist.
Proof using . rewrite NoDupA_Leibniz. apply enum_NoDup. Qed.

Lemma Vlist_length : length Vlist = ring_size.
Proof using . apply enum_length. Qed.

(** As there is strictly less robots than location, there is an empty location. *)
Lemma ConfigExistsEmpty : forall config, ¬ (∀ pt, In pt (!! config)).
Proof using k_inf_n kdn.
generalize k_inf_n; intros Hkin config Hall.
assert (Hsize : size (!! config) < ring_size).
{ apply le_lt_trans with (cardinal (!! config)).
  - apply size_cardinal.
  - cut (cardinal (!! config) = kG); try lia; [].
    change (cardinal (make_multiset (List.map get_location (config_list config))) = kG).
    rewrite cardinal_make_multiset, config_list_spec, map_map, map_length.
    rewrite names_length. simpl. lia. }
assert (Hle : ring_size <= size (!! config)).
{ rewrite size_spec.
  assert (Hobs : forall pt, InA equiv pt (support (!! config))).
  { intro pt. specialize (Hall pt). now rewrite support_spec. }
  rewrite <- Vlist_length.
  apply (Preliminary.inclA_length setoid_equiv).
  - apply Vlist_NoDup.
  - repeat intro. apply Hobs. }
lia.
Qed.

Lemma Stopped_same : forall e, Stopped e -> e == Stream.tl e.
Proof using .
cofix Hcoind. intros e Hstop. constructor.
+ clear Hcoind. apply Hstop.
+ apply Hcoind. apply Hstop.
Qed.

Lemma Will_stop_tl : forall e, Will_stop e -> Will_stop (Stream.tl e).
Proof using .
intros e He. induction He.
+ left. match goal with H : Stopped _ |- _ => apply H end.
+ right. apply IHHe.
Qed.

(** No algorithm can stop on a starting configuration. *)
Theorem no_stop_on_starting_config : forall r d config,
  Fair d ->
  Explore_and_Stop r ->
  Valid_starting_config config ->
  ~Stopped (execute r d config).
Proof using k_inf_n kdn.
intros r d config.
generalize (@reflexivity execution equiv _ (execute r d config)).
generalize (execute r d config) at -2.
intros e Heqe Hfair Hsol Hvalid Hsto.
destruct (Hsol d config Hfair Hvalid) as [Hvisit Hstop].
assert (Hfalse :=  ConfigExistsEmpty config).
(* TODO: remove the use of classical logic: everything is decidable here *)
apply Logic.Classical_Pred_Type.not_all_ex_not in Hfalse.
destruct Hfalse as [loc Hfalse].
specialize (Hvisit loc).
rewrite <- Heqe in *.
induction Hvisit.
+ rewrite Heqe in *.
  match goal with H : Stream.instant _ _ |- _ => destruct H as [g Hg] end.
  rewrite (obs_from_config_In config origin) in Hfalse;
    destruct Hfalse.
  exists (Good g).
  apply Hg.
+ apply IHHvisit.
  - rewrite <- Heqe. symmetry. now apply Stopped_same.
  - apply Hsto.
  - now apply Will_stop_tl.
Qed.

(** In particular, there is a tower on any final configuration. *)
Lemma tower_on_final_config : forall r d config,
  Fair d ->
  Explore_and_Stop r ->
  Stopped (execute r d config) ->
  exists loc, ((!! config)[loc] > 1)%nat.
Proof using k_inf_n kdn.
intros r d config Hfair Hsol Hstop.
assert (Hequiv := @no_stop_on_starting_config r d config Hfair Hsol).
assert (Hvalid : ~Valid_starting_config config) by tauto.
apply config_not_injective in Hvalid.
destruct Hvalid as [id [id' [Hid Heq]]].
exists (config id).
assert (Hobs := obs_from_config_spec config origin (config id)).
assert (Hperm : exists l, PermutationA equiv (config_list config) (config id :: config id' :: l)).
{ assert (Hin : List.In id names) by apply In_names.
  assert (Hin' : List.In id' names) by apply In_names.
  assert (Hperm : exists l, PermutationA eq names (id :: id' :: l)).
  { rewrite <- InA_Leibniz in Hin, Hin'.
    apply PermutationA_split in Hin; autoclass; [].
    destruct Hin as [l' Hperm']. rewrite Hperm', InA_cons in Hin'.
    destruct Hin' as [| Hin']; try congruence; [].
    apply PermutationA_split in Hin'; autoclass; [].
    destruct Hin' as [l Hperm]. exists l. now rewrite Hperm', Hperm. }
  destruct Hperm as [l Hperm].
  exists (List.map config l).
  now rewrite config_list_spec, Hperm. }
destruct Hperm as [l Hperm].
rewrite Hobs.
(* FIXME: why does [rewrite Hperm] fail here? *)
rewrite (countA_occ_compat _ equiv_dec _ _ (reflexivity (config id))
          (PermutationA_map _ _ Hperm)).
simpl List.map. rewrite List.map_id. unfold Datatypes.id. simpl.
repeat destruct_match; solve [lia | exfalso; auto].
Qed.

Lemma exec_stopped r : forall d c, Fair d -> Will_stop (execute r d c) ->
  exists d' c', Fair d'/\ Stopped (execute r d' c').
(*exists e, exec_r_comp e r /\ Stopped e.*)
Proof using .
intros d' config' Hfair Hstop.
remember (execute r d' config') as e'.
revert Heqe'.
revert d' config' Hfair.
induction Hstop as [e' Hstop | e' Hstop IHstop].
+ intros d' config' Hfair Heq.
  exists d', config'; now rewrite Heq in *.
+ intros d' config' Hfair Heq.
  apply (IHstop (Stream.tl d') (Stream.hd (Stream.tl e'))).
  - destruct Hfair as [_ Hfair]. constructor; apply Hfair.
  - now rewrite Heq, execute_tail.
Qed.

Lemma no_exploration_k_inf_2 : forall r d config,
  Fair d ->
  Explore_and_Stop r ->
  Valid_starting_config config ->
  (kG > 1)%nat.
Proof using k_inf_n kdn.
intros r d config Hfair Hsol Hvalid.
assert (Hexr := exec_stopped r).
assert (Htower := tower_on_final_config).
destruct (Hsol d config Hfair Hvalid) as [Hvisit Hstop].
destruct (Hexr d config Hfair Hstop) as [d' [config' [Hfair' Hstop']]].
specialize (Htower r d' config' Hfair' Hsol Hstop').
destruct Htower.
assert (Hcard := cardinal_lower x (!! config')).
rewrite cardinal_obs_from_config in Hcard.
unfold nG, nB in *.
unfold Robots in *. simpl in *. lia.
Qed.

End Tower.

(* Prefer not to leave this here, so that make -vos does not fail here.
See Tower_Assumptions.v *)
(* Print Assumptions no_exploration_k_inf_2. *)

(*
(** Stronger result: in any successful sequential execution,
    the last starting configuration was seen at least [ring_size - kG + 1] rounds ago. *)

Fixpoint last_init_conf (l : list configuration) (a : configuration) :=
  match l with
  | nil => (False, nil)
  | config :: l' => if a =?= config
                    then (((List.Forall (fun x => ~ Valid_starting_config x ) l')
                          /\ Valid_starting_config a),l')
                    else last_init_conf l' a
  end.

(* Definition SequencialExecution (e : execution) : Prop :=
  Stream.forever
    (fun e' => forall r d conf,
         e' == execute r d conf /\
         (exists id, forall id', id' <> id /\ step (Stream.hd d) id' (conf id')
                                              = Moving false)) e. *)
Definition SequencialExecution : execution -> Prop :=
  Stream.forever (Stream.instant
    (fun config => forall da, exists id, forall id', id' <> id -> activate da id' = false)).

Fixpoint Biggest_list_of_exe (l : list configuration) (e : execution) : Prop :=
  match l with
  | nil => Stopped e
  | x :: nil => x == Stream.hd e /\ Stopped e
  | x :: y => x == Stream.hd e /\ ~ Stream.hd e == Stream.hd (Stream.tl e)
                               /\  Biggest_list_of_exe y (Stream.tl (Stream.tl e))
  end.

(* Lemma stop_tl : forall e, Stopped e -> Stopped (Stream.tl e).
Proof. intros e He. apply He. Qed. *)

Theorem TowerOnFinalConf : forall l r d config (e : execution) x,
    Valid_starting_config config ->
    e == execute r d config ->
    Biggest_list_of_exe l e ->
    let (P, l') := last_init_conf l config in
    P ->
    Explore_and_Stop r ->
    SequencialExecution e ->
    (forall config, List.In config l' ->
       exists pt, (!! config)[pt] = x -> (1 < x)%nat  -> (x < kG)%nat) ->
    (ring_size - kG + 1 <= length l')%nat.
Proof.
intros l r d config e x Hconfig Heq_e Hlist.
destruct (last_init_conf l config) as (P, l') eqn : Hlic.
intros HP Hvalid Hsequ Hl_conf.
assert ((length l' < ring_size - kG + 1)%nat
       -> False).
{ intros Hf.
  unfold last_init_conf in Hlic.
  induction l.
  * simpl in *.
    rewrite surjective_pairing in Hlic.
    simpl in *.
    assert (P = fst (P, l')) by intuition.
    rewrite <- Hlic in *.
    simpl in *.
    now rewrite <- H.
  * destruct (config =?=  a).
    + assert (HeqP : P = fst (P, l')) by intuition.
      assert (l' = snd (P, l')) by intuition.
      rewrite <- Hlic in *; cbn -[equiv] in *.
      rewrite HeqP in HP.
      intuition.
      assert (Valid_starting_config a).
      { revert_one @equiv. intro Heq. now rewrite <- Heq. }
      destruct (last_init_conf l) eqn : Hl.

    split.
    - intros.
      destruct Hsequ.
      specialize (H0 r d conf).
      destruct H0 as (He_conf, (id,Hid)).
      destruct l eqn : Hl.
    - simpl in *.
      destruct (Hvalid c Hconf) as (Hvisit, Hstop).
      assert (Hfalse :=  ConfExistsEmpty c).
      unfold is_visited in *.
      rewrite Heq_e in Hlist.
      now generalize (test Hvalid Heq_e Hconf Hlist).
    - destruct l0 eqn : Hl'.
       + simpl in *.
         destruct Hlist as (Hceq, Hstp).
         generalize (test Hvalid Heq_e Hconf).
         intros Htest.
         assert (Hval_t: ValidStartingConf t).
         rewrite Hceq.
         rewrite Heq_e.
         now simpl in *.
         assert (He_eq : eeq e (execute r d t)).
         rewrite Hceq.
         now rewrite Heq_e.
         generalize (test Hvalid He_eq Hval_t).
         intros Htest'.
         destruct Htest.
         now rewrite <- Heq_e.
       + destruct (Classical_Prop.classic (ValidStartingConf (last (t :: t0 :: l1) c)))
           as [Hv|Hnv].
         simpl in *.
         destruct ( Config.eq_dec (Stream.hd e) (Stream.hd (Stream.tl (Stream.tl e))));
           try easy.
         destruct Hlist as (Hceq, Hlist).
         assert (Hse : ~Stopped e).
         intros Hs.
         destruct Hs as (Hse, Hs).
         now unfold stop_now in Hse.
         destruct l1.
         * destruct (Classical_Prop.classic
                       (ValidStartingConfSolExplorationStop
                       r (Stream.tl (Stream.tl d)))) as [Hvrd|Hnvrd].
           assert (Heeq_to : eeq (Stream.tl (Stream.tl e)) (execute r (Stream.tl (Stream.tl d)) t0)).
           { rewrite Heq_e.
             destruct Hlist as (Hlist, Hstp).
             rewrite Heq_e in Hlist.
             repeat rewrite execute_tail in *.
             apply execute_compat; try easy.
           }
           destruct (test Hvrd Heeq_to Hv).
           now rewrite <- Heeq_to.
           unfold ValidStartingConfSolExplorationStop in *.
           apply Classical_Prop.NNPP.
           intro.
           apply Hnvrd.
           intros.
           destruct (Hvrd t0 Hv).  Heeq_to).
           admit.
         apply Classical_Pred_Type.not_all_not_ex.
         intros Hf.
         destruct Hnv.
         unfold ValidStartingConf.
         intros (ex, Hex).
         now specialize (Hf ex).
Qed.
 *)