Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import bedrock2.Array.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Syntax.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import coqutil.Word.Interface.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.Partition.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Bignum.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Operation.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.UnsaturatedSolinas.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.Tactics.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.UnsaturatedSolinas.
Require Import Crypto.Bedrock.Field.Synthesis.Examples.X25519_64.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.UnsaturatedSolinasHeuristics.
Require Import bedrock2.Semantics.
Import ListNotations.
Import Syntax.Coercions.
Local Open Scope Z_scope.

Existing Instances
         Defaults64.default_parameters names
         curve25519_bedrock2_funcs curve25519_bedrock2_specs
         curve25519_bedrock2_correctness.
Local Open Scope string_scope.

(* Notations to make spec more readable *)
Local Notation n := X25519_64.n.
Local Notation s := X25519_64.s.
Local Notation c := X25519_64.c.
Local Notation machine_wordsize := X25519_64.machine_wordsize.
Local Notation M := (UnsaturatedSolinas.m s c).
Local Notation weight :=
  (ModOps.weight (QArith_base.Qnum
                    (UnsaturatedSolinasHeuristics.limbwidth n s c))
                 (Z.pos (QArith_base.Qden
                           (UnsaturatedSolinasHeuristics.limbwidth n s c)))).
Local Notation eval := (Positional.eval weight n).
Local Notation n_bytes := (UnsaturatedSolinas.n_bytes s).
Local Notation loose_bounds := (UnsaturatedSolinasHeuristics.loose_bounds n s c).
Local Notation tight_bounds := (UnsaturatedSolinasHeuristics.tight_bounds n s c).
Local Notation prime_bytes_bounds_value :=
  (map (fun v : Z => Some {| ZRange.lower := 0; ZRange.upper := v |})
       (UnsaturatedSolinas.prime_bytes_upperbound_list s)).
Local Infix "*" := sep : sep_scope.
Delimit Scope sep_scope with sep.

Definition encode_decode : func :=
  let x := "x" in
  let tmp := "tmp" in
  ("encode_decode",
   ([x; tmp], [],
    (cmd.seq
       (cmd.call [] "curve25519_to_bytes" [expr.var tmp; expr.var x])
       (cmd.call [] "curve25519_from_bytes" [expr.var x; expr.var tmp])))).

Instance spec_of_encode_decode : spec_of encode_decode :=
  fun functions =>
    forall x old_tmp px ptmp t m R,
      let xz := map word.unsigned x in
      list_Z_bounded_by tight_bounds xz ->
      (Bignum n px x * EncodedBignum n_bytes ptmp old_tmp * R)%sep m ->
      WeakestPrecondition.call
        functions encode_decode t m
        (px :: ptmp :: nil)
        (fun t' m' rets =>
           t = t' /\
           rets = []%list /\
           exists out tmp',
             let outz := map word.unsigned out in
             eval outz mod M = eval xz mod M
             /\ list_Z_bounded_by tight_bounds outz
             /\ (Bignum n px out
                 * EncodedBignum n_bytes ptmp tmp' * R)%sep m').

(* TODO: currently this extra step is required so the literal string isn't
  hidden *)
Instance spec_of_curve25519_to_bytes :
  spec_of "curve25519_to_bytes" := spec_of_to_bytes.
Instance spec_of_curve25519_from_bytes :
  spec_of "curve25519_from_bytes" := spec_of_from_bytes.

Ltac prove_bounds :=
  match goal with
  | H : list_Z_bounded_by tight_bounds ?x
    |- list_Z_bounded_by loose_bounds ?x =>
    apply UnsaturatedSolinas.relax_correct; apply H
  | H : list_Z_bounded_by ?b ?x |- list_Z_bounded_by ?b ?x =>
    apply H
  end.
Ltac prove_length :=
  match goal with
  | |- length _ = _ => rewrite ?map_length; solve [eauto]
  | |- length _ = X25519_64.n =>
    apply bounded_by_loose_bounds_length
      with (s:=X25519_64.s) (c:=X25519_64.c); prove_bounds
  | H : map Byte.byte.unsigned ?x = Partition.partition _ _ _
    |- length ?x = n_bytes =>
    erewrite <-map_length; erewrite H;
    rewrite length_partition; reflexivity
  end.
Ltac prove_preconditions :=
  lazymatch goal with
  | |- length _ = _ => prove_length
  | |- list_Z_bounded_by _ _ => prove_bounds
  end.

(* TODO: postcondition of to_bytes should include the bounds so that this proof
is not needed *)
Lemma bounded_by_prime_bytes_bounds x :
  0 <= x < M ->
  list_Z_bounded_by
    prime_bytes_bounds_value
    (Partition.partition (ModOps.weight 8 1) n_bytes x).
Proof.
  let weight := constr:(ModOps.weight 8 1) in
  change (prime_bytes_bounds_value) with
      ((ByteBounds.byte_bounds (n_bytes-1)%nat)
         ++ [Some {| ZRange.lower:=0;
                     ZRange.upper:=
                       ((s - 1) mod (weight n_bytes) / weight (n_bytes-1)%nat);
                  |}])%list.
  change n_bytes with (S (n_bytes-1)).
  rewrite partition_step, Util.list_Z_bounded_by_snoc.
  change (S (n_bytes-1)) with n_bytes.
  split; [ | solve [apply ByteBounds.partition_bounded_by] ].
  pose proof (@weight_positive (ModOps.weight 8 1)
                               ltac:(apply ModOps.wprops; lia))
    as weight_pos.
  pose proof (weight_pos n_bytes).
  pose proof (weight_pos (n_bytes-1)%nat).
  pose proof (Z.mod_pos_bound x (ModOps.weight 8 1 n_bytes)).
  pose proof (Z.mod_le x (ModOps.weight 8 1 n_bytes) ltac:(lia) ltac:(lia)).
  cbv [ZRange.is_bounded_by_bool]. cbn [ZRange.upper ZRange.lower].
  apply Bool.andb_true_iff; split; LtbToLt.Z.ltb_to_lt;
    [ apply Div.Z.div_nonneg; lia | ].
  apply Z.div_le_mono; [ lia | ].
  transitivity (M - 1); [ lia | ].
  vm_compute. congruence.
Qed.

Lemma encode_decode_correct :
  program_logic_goal_for_function! encode_decode.
Proof.
  straightline_init_with_change.

  repeat straightline.
  handle_call; [ prove_preconditions .. | ].
  repeat match goal with
           H : context [Freeze.bytes_n ?a ?b ?c] |- _ =>
           change (Freeze.bytes_n a b c) with n_bytes in H
         end.

  (* to_bytes doesn't explicitly mention bounds in the postcondition, so we need
     to extract them *)
  lazymatch goal with
    H : ?out = Partition.partition _ _ _ |- _ =>
    assert (list_Z_bounded_by prime_bytes_bounds_value out)
      by (rewrite H; apply bounded_by_prime_bytes_bounds;
          apply Z.mod_pos_bound; reflexivity)
  end.

  repeat straightline.
  handle_call; [ prove_preconditions .. | ].
  repeat match goal with
           H : context [Freeze.bytes_n ?a ?b ?c] |- _ =>
           change (Freeze.bytes_n a b c) with n_bytes in H
         end.

  repeat split; try reflexivity.
  sepsimpl_hyps.
  do 2 eexists; sepsimpl;
    lazymatch goal with
    | |- sep _ _ _ => ecancel_assumption
    | _ => idtac
    end.
  all: try prove_bounds.
  all: try prove_length.

  repeat match goal with
         | H : eval _ mod M = _ |- _ => rewrite H
         | H : map Byte.byte.unsigned _ = _ |- _ => rewrite H
         end.
  rewrite eval_partition
    by (apply UniformWeight.uwprops; lia).
  match goal with
    |- context [(((eval ?a) mod ?m1) mod ?m2) mod ?m1] =>
    let x1 := (eval vm_compute in m1) in
    let x2 := (eval vm_compute in m2) in
    change m2 with x2; change m1 with x1;
      pose proof (Z.mod_pos_bound (eval a) x1 ltac:(lia));
      rewrite (Z.mod_small _ x2) by lia
  end.
  rewrite Z.mod_mod by lia. reflexivity.
Qed.


Require Import Coq.Lists.List.
Require Import ExtLib.Tactics.Consider.
Require Import MirrorShard.Prover.
Require Import MirrorShard.Expr.

Set Implicit Arguments.
Set Strict Implicit.

Section prover.
  Variable ts : list type.
  Variable fs : functions ts.
  Variable prover : ProverT ts.

  Fixpoint provePures (facts : Facts prover) (ls : exprs ts) : exprs ts :=
    match ls with
      | nil => nil
      | l :: ls =>
        let ls' := provePures (Learn _ facts (l :: nil)) ls in
        if Prove _ facts l then ls'
        else l :: ls'
    end.

  Variable proverOk : ProverT_correct prover fs.

  Theorem provePuresOk : forall u g ls f ls',
    Valid proverOk u g f  ->
    Forall (ValidProp fs u g) ls ->
    provePures f ls = ls' ->
    AllProvable fs u g ls' ->
    AllProvable fs u g ls.
  Proof.
    induction ls; simpl; intros; auto.
    { inversion H0; clear H0; subst.
      consider (Prove prover f a).
      { intuition.
        { eapply ProverCorrect_ProverCorrect'.
          eapply Prove_correct; eauto.
          eauto. eauto. eauto. }
        { eapply IHls; [ | | reflexivity | eassumption ].
          eapply Learn_correct; eauto. repeat constructor.
          eapply ProverCorrect_ProverCorrect'.
          eapply Prove_correct; eauto. eauto. eauto. eauto.
          eauto. } }
      { intros. inversion H1; clear H1; subst.
        intuition. eapply IHls; [ | | reflexivity | eassumption ]; eauto.
        eapply Learn_correct; eauto. repeat constructor; auto. } }
  Qed.
End prover.


Require Import
        Fiat.Common.BoundedLookup.
Require Import
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.BaseFormats
        Fiat.Narcissus.Formats.WordOpt.
Require Import
        Coq.Vectors.Vector
        Bedrock.Word.

Section Enum.
  Context {len : nat}.
  Context {A : Type}.
  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : QueueMonoidOpt monoid bool}.

  Context {sz : nat}.
  Context {ta : t A (S len)}.
  Variable (tb : t (word sz) (S len)).

  Inductive NoDupVector {A}
    : forall {n}, Vector.t A n -> Prop :=
    NoDupVector_nil : NoDupVector (Vector.nil _)
  | NoDupVector_cons : forall (x : A) {n} (l : Vector.t A n),
      ~ Vector.In x l -> NoDupVector l -> NoDupVector (Vector.cons _ x _ l).

  Lemma NoDupVector_invert {A'}
    : forall n (l : Vector.t A' n),
      NoDupVector l
      -> match l with
         | Vector.nil => True
         | Vector.cons a _ l' =>
           ~ Vector.In a l' /\ NoDupVector l'
         end.
  Proof.
    clear; induction 1; eauto.
  Qed.

  Definition format_enum (idx : Fin.t _) :
    CacheFormat -> Comp (B * CacheFormat) :=
    format_word (nth tb idx).

  Definition encode_enum (idx : Fin.t _) :
    CacheFormat -> B * CacheFormat :=
    encode_word (nth tb idx).

  Lemma refine_format_enum :
    forall idx ce,
      refine (format_enum idx ce)
             (ret (encode_enum idx ce)).
  Proof.
    intros; reflexivity.
  Qed.

  Fixpoint word_indexed {n : nat}
           (w : word sz)
           (t : t (word sz) n) : Hopefully (Fin.t n)
    := match t in Vector.t _ n return Hopefully (Fin.t n) with
       | nil => OtherErrorInfo "Decoding enum error: index too large."
       | cons w' _ t' =>
         if (weqb w w') then Ok (Fin.F1) else
           match word_indexed w t' with
           | Ok f => Ok (Fin.FS f)
           | Error e => Error e
           end
       end.

  Definition decode_enum (b : B)
             (cd : CacheDecode)
    : Hopefully (Fin.t _ * B * CacheDecode) :=
    `(w, b', cd') <- decode_word (sz:=sz) b cd;
      HBind word_indexed w tb as idx With
      Ok (idx, b', cd').

  Lemma word_indexed_correct :
    forall n (i : Fin.t n) (t : t (word sz) n),
      NoDupVector t
      -> match word_indexed (nth t i) t with
      | Ok w' => i = w'
      | _ => False
      end.
  Proof.
    clear.
    induction i.
    - intro; pattern n, t; apply Vector.caseS; simpl; intros.
      rewrite (proj2 (weqb_true_iff h h)); eauto.
    - intro; generalize i (IHi (Vector.tl t)); clear.
      pattern n, t; apply Vector.caseS; simpl.
      intros h n0 t0 i; case_eq (word_indexed (nth t0 i) t0); intros;
        apply NoDupVector_invert in H1; intuition subst.
      case_eq (weqb (nth t0 t1) h); intros; eauto.
      apply weqb_true_iff in H0; subst.
      destruct H2; generalize t0 H; clear; induction t1.
      + intro; pattern n, t0; apply Vector.caseS; simpl; intros; econstructor.
      + intro; revert t1 IHt1; pattern n, t0; apply Vector.caseS;
          simpl; intros.
        case_eq (weqb (nth t t1) h); intros; eauto.
        * apply weqb_true_iff in H0; subst; econstructor.
        * rewrite H0 in H.
          econstructor 2; apply IHt1.
          destruct (word_indexed (nth t t1) t); try discriminate.
          f_equal; apply Fin.FS_inj; congruence.
  Qed.

  Lemma word_indexed_correct':
    forall n (v : Fin.t n) (w : word sz) (t : t (word sz) n),
      word_indexed w t = Ok v -> w = nth t v.
  Proof.
    clear.
    induction v.
    - intros w tb; pattern n, tb;
        eapply Vector.caseS; simpl.
      intros; destruct (weqb w h) eqn: ?.
      eapply weqb_true_iff; eauto.
      destruct ( word_indexed w t); try discriminate.
    - intros w tb.
      revert w v IHv.
      pattern n, tb; eapply Vector.rectS; simpl; intros.
      inversion v.
      intros; destruct (weqb w a) eqn: ?.
      discriminate.
      destruct (word_indexed w v) eqn : ? ; try discriminate.
      eapply IHv.
      rewrite Heqh.
      f_equal.
      eapply Fin.FS_inj.
      congruence.
  Qed.

  Theorem Enum_decode_correct
          (tb_OK : NoDupVector tb)
          {P : CacheDecode -> Prop}
          (P_OK : cache_inv_Property P (fun P => forall b cd, P cd -> P (addD cd b)))
    : CorrectDecoder monoid (fun _ => True)
                     (fun _ => True) eq format_enum decode_enum P
                     format_enum.
  Proof.
    apply_bijection_rule' with (fun w => word_indexed w tb);
      intuition eauto using Word_decode_correct.
    eapply word_indexed_correct in tb_OK.
    destruct word_indexed eqn:?; subst; intuition eauto.
    symmetry. eauto using word_indexed_correct'.

    derive_decoder_equiv;
      destruct (word_indexed w tb); injections; simpl; eauto; try discriminate.
  Qed.
End Enum.

Lemma VectorIn_cons {A} {n}
  : forall (v : Vector.t A n) a a',
    Vector.In a' (Vector.cons _ a _ v) -> a = a' \/ Vector.In a' v.
Proof.
  intros; inversion H; subst; eauto.
  apply Eqdep_dec.inj_pair2_eq_dec in H3; subst; eauto using Peano_dec.eq_nat_dec.
Qed.

Lemma forall_Vector_P {A} (P : A -> Prop) {n}
  : forall v : Vector.t A n,
    Vector.Forall P v
    -> forall idx, P (Vector.nth v idx).
Proof.
  induction v; simpl; intros.
  - inversion idx.
  - revert v IHv H; pattern n, idx; apply Fin.caseS; simpl;
      intros; inversion H; subst; eauto.
    eapply IHv.
    apply Eqdep_dec.inj_pair2_eq_dec in H2; subst; eauto using Peano_dec.eq_nat_dec.
Qed.

Ltac Discharge_NoDupVector :=
  match goal with
  |- NoDupVector _ =>
  repeat econstructor; intro;
  repeat match goal with
         | H : Vector.In _ _ |- _ =>
           first [apply VectorIn_cons in H; destruct H; try discriminate
                 | inversion H]
         end
  end.


(* PREAMBLE *)

From compcert.cfrontend           Require Csyntax Csem.
From compcert.common              Require Values.
From compcert.lib                 Require Coqlib.

From trancert.lib                 Require All.
From trancert.analysis            Require Appears ImmediatePointers.
From trancert.properties.memory   Require Alloc Free DropPerm Permissions.
From trancert.simulations.memory  Require injection.Properties.

Import Csem properties.State properties.Env List Memory.Mem BinNums Coqlib lib.All Maps PTree ZArith injection.Properties memory.Alloc.

Theorem alloc_left_unmapped_exact_inject:
  forall f m1 m1' m2  lo hi nb,
    inject f m1 m1' ->
    no_offset f ->
    alloc m1 lo hi = (m2, nb) ->
    inject f m2 m1'.
Proof.
  intros f m1 m1' m2 lo hi nb Hinject Hofs Halloc.
  exploit alloc_result; [apply Halloc|].
  intros ; subst.
  constructor.
  -  (* mi_inj *)
    constructor.
    + (* mi_perm *)
      intros b1 b2 delta ofs k p H H0.
      exploit perm_alloc_inv; [eapply Halloc | |]; eauto.
      intros.
      unfold Values.eq_block in *.
      exploit perm_inject; eauto.
      exploit Hofs; eauto; intro; subst.
      destruct (peq _ _); auto.
      * subst.
        inv Hinject.
        erewrite mi_freeblocks0 in H; [discriminate|apply Pos.lt_irrefl].
    + (* mi_align *)
      intros b1 b2 delta chunk ofs p Hmap Hrange.
      exploit Hofs; eauto; intro; subst.
      auto with zarith.
    + (* mi_memval *)
      intros b1 ofs b2 delta Hmap Hperm.
      erewrite alloc_mem_contents; try eapply Halloc.
      exploit Hofs; eauto; intro; subst.
      repeat rewrite  Maps.PMap.gsspec.
      destruct (peq b1 _).
      * subst b1.
        inv Hinject.
        rewrite -> mi_freeblocks0 in *; [discriminate|apply Pos.lt_irrefl].
      * exploit perm_alloc_inv; try apply  Halloc; eauto. intros Hperm'.
        destruct (Values.eq_block _ _); [contradiction|].
        destruct Hinject.
        destruct mi_inj0.
        eapply mi_memval0 in Hmap; eauto.
  - (* mi_freeblocks *)
    inv Hinject.
    unfold valid_block, Plt in *.
    intros b H.
    destruct (peq b (nextblock m1)).
    + subst. eapply mi_freeblocks0.
      eapply Pos.lt_irrefl.
    + destruct (plt b (nextblock m1)); eauto.
      exploit valid_block_alloc;
        unfold valid_block, Plt in *; eauto.
  - (* mi_mappedblocks *)
    intros b b' delta H.
    eapply mi_mappedblocks; eauto.
  - (* meminj_no_overlap *)
    eauto.
    destruct Hinject.
    unfold meminj_no_overlap in *.
    intros b1 b1' delta1 b2 b2' delta2 ofs1 ofs2 H H0 H1 H2 H3.
    eapply mi_no_overlap0; eauto;
      eapply perm_alloc_inv in H2; eauto;
        eapply perm_alloc_inv in H3; eauto;

          destruct (Values.eq_block b1 _), (Values.eq_block b2 _); subst; eauto; try congruence.
    + rewrite -> mi_freeblocks0 in H0; [discriminate|].
      apply Pos.lt_irrefl.
    + rewrite -> mi_freeblocks0 in H1; [discriminate|].
      apply Pos.lt_irrefl.
  - (* mi_representable *)
    intros b b' delta ofs H [Hperm | Hperm];
      inv Hinject.
    + eapply mi_representable0.
      apply H.
      left.
      eapply perm_alloc_inv in Hperm; eauto.
      destruct (Values.eq_block _ _); auto.
      * subst.
        erewrite -> inject_not_nextblock in H; eauto.
        discriminate. econstructor; eauto.
    + eapply mi_representable0.
      apply H.
      right.
      eapply perm_alloc_inv in Hperm; eauto.
      destruct (Values.eq_block _ _); auto.
      * subst.
        erewrite inject_not_nextblock in H; eauto.
        discriminate. econstructor; eauto.
  - (* mi_perm_inv *)
    intros b1 ofs b2 delta k p H H0.
    inv Hinject.
    exploit mi_perm_inv0 ; eauto.
    intros H1.
    destruct H1.
    + left. eapply perm_alloc_1; eauto.
    + right. intro. apply H1.
      eapply perm_alloc_inv in Halloc; eauto.
      destruct (Values.eq_block _ _); auto.
      subst.
      erewrite inject_not_nextblock in H; eauto.
      discriminate. econstructor; eauto.
Qed.

(** How to map blocks in an injected memory after performing [alloc]?

There are three cases:
- We perform parallel allocations in source and injected memory
 *)
Definition alloc_meminj (f: Values.meminj) (m1 m1': mem) : Values.meminj :=
  fun b => if peq b (nextblock m1) is left _ then Some (nextblock m1', 0%Z) else f b.

(**
- We skip an allocation in source memory, introducing a hole which will not be mapped.
 *)

Definition alloc_meminj_skip (f: Values.meminj) : Values.meminj := f.
(**
- We can also allocate any number of blocks in injected memory. In this case the mapping is left unchanged.
 *)

Theorem alloc_inject_exact_parallel:
  forall f m1 m1' m2  lo hi nb,
    inject f m1 m1' ->
    no_offset f ->
    alloc m1 lo hi = (m2, nb) ->
    exists m2' nb', alloc m1' lo hi = (m2', nb') /\ inject (alloc_meminj f m1 m1') m2 m2'.
Proof.
  intros f m1 m1' m2 lo hi nb Hinject Hofs Halloc.

  destruct (alloc m1' lo hi) as [m2' nb'] eqn: Halloc'.
  exists m2', nb'.
  exploit alloc_result; first by apply Halloc.
  exploit alloc_result; first by apply Halloc'.
  intros ; subst.
  split; auto.
  unfold alloc_meminj.
  constructor.
  -  (* mi_inj *)
    constructor.
    + (* mi_perm *)
      intros b1 b2 delta ofs k p H H0.
      exploit perm_alloc_inv; first (by eapply Halloc); eauto.
      intros.
      unfold Values.eq_block in *.
      destruct (peq _ _).
      * inv H. rewrite Z.add_0_r.
        unfold perm in *.
        erewrite alloc_mem_access in *; eauto.
        rewrite Maps.PMap.gss in H0.
        rewrite Maps.PMap.gss.
        assumption.
      * exploit perm_inject; eauto.

        intros H3.
        unfold perm in *.
        erewrite alloc_mem_access; eauto.
        erewrite alloc_mem_access in H0; eauto.
        rewrite -> Maps.PMap.gso in *; auto.
        intro H'; subst.
        eapply mi_mappedblocks in H; eauto.
        unfold valid_block in H.
        by eapply Pos.lt_irrefl in H.
    + (* mi_align *)
      intros b1 b2 delta chunk ofs p Hmap Hrange.
      destruct (peq _ _).
      inv Hmap; auto with zarith.
      exploit Hofs; eauto. intros; subst.
      auto with zarith.
    + (* mi_memval *)
      intros b1 ofs b2 delta Hmap Hperm.
      erewrite alloc_mem_contents with (m' := m2'); try eapply Halloc'.
      erewrite alloc_mem_contents; try eapply Halloc.
      repeat rewrite  Maps.PMap.gsspec.
      destruct (peq b1 _).
      * inv Hmap.
        rewrite get_init.
        constructor.

      * destruct (peq _ _).
        ** subst. eapply mi_mappedblocks in Hmap; eauto.
           by eapply Pos.lt_irrefl in Hmap.
        ** exploit perm_alloc_inv; try apply  Halloc; eauto.
           intros.
           destruct (Values.eq_block _ _); [contradiction|].
           destruct Hinject.
           destruct mi_inj0.
           exploit Hofs; eauto. intros; subst.
           exploit mi_memval0; eauto.
           inversion 1; econstructor.
           inv H3; econstructor.
           exploit Hofs; eauto. intros; subst.
           destruct (peq _ _); eauto.
           *** subst.
               erewrite mi_freeblocks0 in H4; eauto.
               **** discriminate.
               **** eapply Pos.lt_irrefl.
           *** reflexivity.
  - (* mi_freelocks *)
    intros b H.
    destruct (peq _ _).
    + subst.
      by eapply valid_new_block in Halloc.
    + destruct Hinject as [_ ? _ _ _ _].
      eapply mi_freeblocks0.
      unfold valid_block in *.
      contradict H.
      unfold Plt in *.
      erewrite nextblock_alloc; eauto.
      rewrite Pplus_one_succ_r.
      eapply (Pos.lt_trans _ (nextblock m1)); eauto.
      by apply Pos.lt_add_diag_r.
  - (* mi_mappedblocks *)
    intros b b' delta H.
    destruct (peq _ _).
    + subst. inv H.
      eapply valid_new_block; eauto 1.
    + eapply valid_block_alloc; eauto.
      eapply mi_mappedblocks; eauto.
  - (* meminj_no_overlap *)
    destruct Hinject.
    unfold meminj_no_overlap in *.
    intros b1 b1' delta1 b2 b2' delta2 ofs1 ofs2 Hneq Hf1 Hf2 Hperm1 Hperm2.
    destruct (peq b1 _), (peq b2 _); subst; eauto.
    + inv Hf1.
      clear n.
      destruct (peq (nextblock m1') b2'); auto.
      subst.
      exploit mi_mappedblocks0; eauto. by move /Pos.lt_irrefl.
    + inv Hf2. clear n.
      destruct (peq b1' (nextblock m1')); auto. subst.
      exploit mi_mappedblocks0; eauto. by move /Pos.lt_irrefl.
    +
      eapply mi_no_overlap0;[
        eapply Hneq
      | eauto
      | eauto
      | eapply perm_alloc_inv in Hperm1; eauto;
        destruct (Values.eq_block _ _); [contradiction|assumption]
      | eapply perm_alloc_inv in Hperm2; eauto;
        destruct (Values.eq_block _ _); [contradiction|assumption]
      ].
  - (* mi_representable *)
    intros b b' delta ofs H H0.
    destruct (peq _ _).
    + subst. inv H.
      split; auto with zarith.
      rewrite Z.add_0_r.
      apply Integers.Ptrofs.unsigned_range_2.
    + destruct Hinject.
      eapply mi_representable0; eauto.
      decomp; [left|right].
      * eapply perm_alloc_inv in H0; eauto.
        destruct (Values.eq_block _ _); auto.
        ** subst. erewrite inject_not_nextblock in H; eauto.
          discriminate. econstructor; eauto.
      * eapply perm_alloc_inv in H0; eauto.
        destruct (Values.eq_block _ _); auto.
        ** subst.
          erewrite inject_not_nextblock in H; eauto.
          discriminate. econstructor; eauto.
  - (* mi_perm_inv *)
    intros b1 ofs b2 delta k p H H0.
    destruct Hinject.
    eapply perm_alloc_inv in H0; eauto.
    destruct (peq b1 _).
    + subst. inv H.
      destruct (Values.eq_block _ _); [|congruence].
      rewrite -> Z.add_0_r in *.
      unfold perm.
      unfold perm_order'.
      erewrite alloc_mem_access ; eauto.
      rewrite -> Maps.PMap.gss in *.
      destruct (zle _ _), (zlt _ _); auto with zarith.
      simpl. left; constructor.
    + destruct (Values.eq_block b2 _).
      * subst. inv H. unfold perm, perm_order'.
        erewrite alloc_mem_access ; eauto.
        rewrite -> Maps.PMap.gso in *; auto.
        exploit mi_mappedblocks0; eauto.
        intros.
        by eapply Pos.lt_irrefl in H.
      * eapply mi_perm_inv0 in H; eauto.
        destruct H; [left|right].
        ** eapply perm_alloc_1; eauto.
        ** intro H'. apply H.
          eapply perm_alloc_inv in Halloc; eauto.
          destruct (Values.eq_block _ _); [contradiction|assumption].
Qed.

(**

Use [alloc_right_inject] for the case when a block in transformed memory is allocated, which has no corresponding block in the source memory

This theorem builds an [inject] instance for the case when we have allocated a block that we do not want to map.
 *)

Theorem alloc_mapper_incr:
  forall f m m',
    Memory.Mem.inject f  m m' ->
    Values.inject_incr f (alloc_meminj f m m') .
Proof.
  unfold alloc_meminj in *.
  intros f m m' H b1 b2 delta H'.
  destruct (peq _ _); auto.
  subst.
  inv H.
  unfold Memory.Mem.valid_block, Plt in *.
  pose proof (Pos.lt_irrefl (Memory.Mem.nextblock m)).
  eapply mi_freeblocks0 in H.
  congruence.
Qed.


(** * Linearize: Place all and only operations in let binders *)
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.SmartMap.
Require Import Crypto.Util.Tactics.

Local Open Scope ctype_scope.
Section language.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}.

  Local Notation flat_type := (flat_type base_type_code).
  Local Notation type := (type base_type_code).
  Local Notation Tbase := (@Tbase base_type_code).
  Local Notation Expr := (@Expr base_type_code op).

  Section with_var.
    Context {var : base_type_code -> Type}.
    Local Notation exprf := (@exprf base_type_code op var).
    Local Notation expr := (@expr base_type_code op var).

    Section under_lets.
      Fixpoint under_letsf {t} (e : exprf t)
        : forall {tC} (C : interp_flat_type var t -> exprf tC), exprf tC
        := match e in Syntax.exprf _ _ t return forall {tC} (C : interp_flat_type var t -> exprf tC), exprf tC with
           | LetIn _ ex _ eC
             => fun _ C => @under_letsf _ ex _ (fun v => @under_letsf _ (eC v) _ C)
           | TT => fun _ C => C tt
           | Var _ x => fun _ C => C x
           | Op _ _ op args as e => fun _ C => LetIn e C
           | Pair A x B y => fun _ C => @under_letsf A x _ (fun x =>
                                        @under_letsf B y _ (fun y =>
                                        C (x, y)))
           end.
    End under_lets.

    Fixpoint linearizef {t} (e : exprf t) : exprf t
      := match e in Syntax.exprf _ _ t return exprf t with
         | LetIn _ ex _ eC
           => under_letsf (@linearizef _ ex) (fun x => @linearizef _ (eC x))
         | TT => TT
         | Var _ x => Var x
         | Op _ _ op args
           => under_letsf (@linearizef _ args) (fun args => LetIn (Op op (SmartVarf args)) SmartVarf)
         | Pair A ex B ey
           => under_letsf (@linearizef _ ex) (fun x =>
              under_letsf (@linearizef _ ey) (fun y =>
              SmartVarf (t:=Prod A B) (x, y)))
         end.

    Definition linearize {t} (e : expr t) : expr t
      := match e in Syntax.expr _ _ t return expr t with
         | Abs _ _ f => Abs (fun x => linearizef (f x))
         end.
  End with_var.

  Definition Linearize {t} (e : Expr t) : Expr t
    := fun var => linearize (e _).
End language.

Global Arguments under_letsf {_ _ _ _} _ {tC} _.
Global Arguments linearizef {_ _ _ _} _.
Global Arguments linearize {_ _ _ _} _.
Global Arguments Linearize {_ _ _} _ var.


(********************************************************************************
* Formalization of lambda ex						        *
*									        *
* Flavio L. C. de Moura & Daniel L. Ventura, & Washington R. Segundo, 2015	*
*********************************************************************************)

Set Implicit Arguments.
Require Import Recdef. (*no caso de usarmos Function*)
Require Import Metatheory LambdaES_Defs LambdaES_Infra LambdaES_FV LambdaES_Tac.
Require Import Rewriting_Defs Rewriting_Lib.
Require Import Equation_C Lambda Lambda_Ex LambdaESLab_Defs LambdaESLab_Lib.

(** The extended reduction system is related to the lex-calculus
through a function that computes all the labelled substitutions. *)

Fixpoint xc (t: pterm) : pterm :=
  match t with
    | pterm_app t1 t2 => pterm_app (xc t1) (xc t2)
    | pterm_abs t1 => pterm_abs (xc t1)
    | pterm_sub t1 t2 => pterm_sub (xc t1) (xc t2)
    | pterm_sub' t1 t2 => (xc t1)^^(t2)
    | _ => t
  end.

(*==============================================================================================*)

Lemma var_gen_fv: forall E x, x = var_gen(E) <-> x \notin E.

Proof.
introv.
split.
intro Ha.
rewrite Ha.
apply var_gen_spec.

intro Hb.
destruct E.
Admitted.

(* versao de xc com a propriedade de regularidade lc => lc com Recdef*)

Function xc2 (t: pterm) {measure pterm_size t}: pterm :=
  match t with
    | pterm_app t1 t2 => pterm_app (xc2 t1) (xc2 t2)
    | pterm_abs t1 => let x := var_gen (fv t1)  in
                          pterm_abs (close (xc2 (t1^x)) x)
    | pterm_sub t1 t2 => let x := var_gen (fv t1)  in
                          pterm_sub (close (xc2 (t1^x)) x) (xc2 t2)
    | pterm_sub' t1 t2 => (xc2 t1)^^(t2)
    | _ => t
  end.

Proof.
intros. simpl.
auto with arith.

intros. simpl.
auto with arith.

intros. simpl.
unfold open.
rewrite <- pterm_size_open_var.
auto with arith.

intros. simpl.
auto with arith.

intros. simpl.
unfold open.
rewrite <- pterm_size_open_var.
auto with arith.

intros. simpl.
auto with arith.
Defined.

(*==============================================================================================*)

(* versao de xc com a propriedade de regularidade lc => lc a la Chargueraud
   porque nao definimos o caso: termo indefinido ?*)
(*
Definition xc2_body (xc_2: pterm -> pterm) (t: pterm): pterm :=
  match t with
    | pterm_app t1 t2 => pterm_app (xc_2 t1) (xc_2 t2)
    | pterm_abs t1 => let x := var_gen (fv t1)  in
                          pterm_abs (close (xc_2 (t1^x)) x)
    | pterm_sub t1 t2 => let x := var_gen (fv t1)  in
                          pterm_sub (close (xc_2 (t1^x)) x) (xc_2 t2)
    | pterm_sub' t1 t2 => (xc_2 t1)^^(t2)
    | _ => t
  end.

Definition xc_2 := fixmu xc_2_body pterm_size. *)

(*==============================================================================================*)

(** fv is compatible with open. TO BE MOVED: LambdaES_Defs. *)
Lemma fv_open: forall t u, fv(t ^^ u) << fv(t) \u fv(u).
Proof.
  unfold open.
  intros.
  generalize 0.
  induction t.
    intros.
    case n.
    simpl.
    case_nat.
    apply subset_union_weak_r.
    simpl.
    apply subset_union_weak_l.
    intros.
    simpl.
    case_nat.
    apply subset_union_weak_r.
    simpl.
    apply subset_union_weak_l.
    intros. simpl.
    apply subset_union_weak_l.
    intros.
    simpl.
    apply subset_trans with (F := fv ({n ~> u}t1) \u (fv t2 \u fv u)).
    apply subset_union_trans_r.
    apply IHt2.
Admitted.

(*==================================================================================================*)

Lemma xc_fv: forall t, fv (xc t) << fv(t).
Proof.
  induction t.
  simpl; reflexivity.
  simpl; reflexivity.
  simpl.
  rewrite IHt1.
  rewrite IHt2; reflexivity.
  assumption.
  simpl.
  rewrite IHt1.
  rewrite IHt2; reflexivity.
  simpl.
  apply subset_trans with (F := fv(xc(t1)) \u fv(t2)).
  apply fv_open.
  apply subset_union_trans_l. assumption.
Qed.

(*
Lemma xc_open_distr: forall t u, xc (t ^^ u) = (xc(t))^^ (xc(u)).
Proof.
  intros. unfold open. generalize 0 u. clear u.
  induction t.
  intro. simpl. case_nat; reflexivity.

  Focus 5.
  intros.
  simpl.
  unfold open.
  rewrite IHt1.
  assert ()
  rewrite <- IHt1 with (u := t2).

Lemma xc_open_term: forall t u, term u -> xc (t ^^ u) = (xc(t))^^ u.
Proof.
  intros. unfold open. generalize 0.
  generalize u H. clear u H.
  induction t.
  Focus 6.

  intro. simpl.
*)

Lemma term_open_term: forall x t, term t -> t^x = t.
Proof.
  unfold open.
  intros.
  generalize x 0; clear x.
  induction H.

  intros.
  simpl; reflexivity.

  intros.
  simpl.
  rewrite IHterm1.
  rewrite IHterm2; reflexivity.

  intros.
  simpl.
  pick_fresh z.
  assert (Q: ({S n ~> pterm_fvar x}t1)^z = t1^z).
  simpl.
Admitted.

Lemma xc_open: forall t x, x \notin fv(t) -> xc (t ^ x) = (xc t)^x.
Proof.
  intros. unfold open. generalize 0.
  induction t.
  unfold open.
  intro. unfold open_rec.
  case_nat.
  fold open_rec.
  simpl xc.
  unfold open_rec.
  case_nat. reflexivity.
  fold open_rec.
  simpl. case_nat. reflexivity.
  intro. simpl. reflexivity.

  intro. simpl.
  rewrite IHt1.
  rewrite IHt2. reflexivity.

  simpl fv in H.
  apply notin_union in H.
  destruct H; assumption.
  simpl fv in H.
  apply notin_union in H.
  destruct H; assumption.

  Focus 3.
  intros.
  simpl.

Admitted.

(*================================================================================================*)

(* Igualdade sintática para pré-termos*)

Lemma eq_abs: forall t u, t = u -> pterm_abs t = pterm_abs u.
Proof.
 intros t u.
 apply f_equal.
Qed.

Lemma eq_pterm_abs: forall t u L,  (forall x, x \notin L -> t^x = u^x) -> pterm_abs t = pterm_abs u.
Proof.
 intros t u L Ha.
 apply eq_abs.
 pick_fresh z.
 apply notin_union in Fr. destruct Fr as [Hb Hc].
 apply notin_union in Hb. destruct Hb as [Hba Hbb].
 apply open_var_inj with (x := z).
 trivial. trivial.
 apply Ha. trivial.
Qed.

Lemma eq_sub: forall t u v w, (t = v) -> (u = w) -> t[u] = (v[w]).
Proof.
 intros t u v w Ha Hb.
 assert (pterm_sub t = pterm_sub v) as Hc.
 apply f_equal. trivial.
 rewrite Hc.
 apply f_equal. trivial.
Qed.

Lemma eq_pterm_sub: forall t u t' u' L, (forall x, x \notin L -> t^x = t'^x) -> u = u' -> (t[u]) = (t'[u']).
Proof.
 intros t u t' u' L Ha Hb.
 apply eq_sub.
 pick_fresh z.
 apply notin_union in Fr. destruct Fr as [Hc Hd].
 apply notin_union in Hc. destruct Hc as [He Hf].
 apply notin_union in He. destruct He as [Hg Hh].
 apply notin_union in Hg. destruct Hg as [Hi Hj].
 apply open_var_inj with (x := z).
 trivial. trivial.
 apply Ha. trivial.
 trivial.
Qed.

(*==================================================================================*)

(*comutatividade para open_rec*)

Lemma open_rec_subs_comut: forall t u v j, {j~>u}(t[[v]]) = ({(S j)~>u}t[[{j~>u}v]]).
Proof.
 simpl. trivial.
Qed.

Lemma open_rec_xc_comut: forall t u, xc t ^^ u = xc(t[[u]]).
Proof.
 simpl. trivial.
Qed.

Lemma open_rec_xc2_comut: forall t u, xc2 t ^^ u = xc2(t[[u]]).
Proof.
  introv.
  apply eq_sym.
  rewrite xc2_equation.
  trivial.
Qed.

Lemma notin_set_subset: forall E F x, E << F -> x \notin F -> x \notin E.
Proof.
 introv Hs Hx.
Admitted.

Lemma open_xc2: forall t, exists L, forall x, x \notin L -> xc2 (t ^ x) = xc2 t ^ x.
Proof.
 unfold open.
 generalize 0.
 introv.
 exists (fv t).
 introv Hx.

 induction t.

 simpl.
 destruct (n === n0) as []eqn:He1. (*reducao para if then else*)
 rewrite xc2_equation. trivial.
 rewrite xc2_equation. trivial.

 simpl.
 rewrite xc2_equation. trivial.

 simpl in Hx.
 apply notin_union in Hx.
 destruct Hx as [Hxl Hxr].
 simpl.
 rewrite xc2_equation.
 apply eq_sym.
 rewrite xc2_equation.
 simpl.
 rewrite IHt1.
 rewrite IHt2.
 trivial. trivial. trivial.

 simpl in Hx.
 simpl.
 rewrite xc2_equation.
 apply eq_sym.
 rewrite xc2_equation.
 simpl.
 apply eq_abs.
 (*assert (x = var_gen (fv t)) as Ht.
 apply var_gen_fv.
 trivial.
 rewrite <- Ht.*)
 unfold open.
 apply eq_sym.
 rewrite IHt. (*problema com generalize, n, 0 e Sn*)
 rewrite <- close_open_term with (x:= x).
 pick_fresh z.
 (*apply notin_union in Fr.*)
 assert (z = var_gen (fv ({1 ~> pterm_fvar x}t))) as Hz.
 apply var_gen_fv.
 apply notin_set_subset with (F := (fv t \u {{x}})).
 apply fv_open_subset.
 rewrite  union_comm. trivial.
 rewrite <- Hz.
 unfold open.
 rewrite subst_com.
 unfold open  in IHt.
 rewrite IHt.
Admitted.

(*==================================================================================*)

Lemma xc_term_term: forall t, term t -> xc t = t.
Proof.
 (* intros t H.
  induction H.

  simpl; reflexivity.

  simpl.
  rewrite IHterm1.
  rewrite IHterm2; reflexivity.

  simpl.
  apply eq_pterm_abs with (L := L).
  intros x Ha.
  rewrite <- H0.
  rewrite xc_open_2 with (L := L).
  trivial. trivial.
  apply H. trivial. trivial.

  simpl.
  apply eq_pterm_sub with (L := L).
  intros x Ha.
  rewrite <- H0.
  rewrite xc_open_2 with (L := L).
  trivial. trivial.
  apply H. trivial. trivial. trivial.

  (*
  simpl.
  pick_fresh z.
  apply notin_union in Fr.
  destruct Fr.
  assert (Q: (xc t1)^z = t1^z).
  assert (U: xc(t1^z) = xc(t1)^z).
  apply xc_open; assumption.
  rewrite <- U.
  apply H0; assumption.
  apply open_var_inj with (x := z) in Q.
  rewrite Q; reflexivity.
Admitted.*)
 Qed.*)
Admitted.

Lemma term_lab_term: forall t, term t -> lab_term t.
Proof.
 introv Ha.
 induction Ha.

 apply lab_term_var.
 apply lab_term_app. trivial. trivial.
 apply lab_term_abs with (L:= L). trivial.
 apply lab_term_sub with (L:=L). trivial. trivial.
Qed.

Lemma xc2_reg: forall t, lab_term t -> term (xc2 t).
Proof.
 introv Ha.
 induction Ha.

 rewrite xc2_equation.
 apply term_var.

 rewrite xc2_equation.
 apply term_app. trivial. trivial.

 rewrite xc2_equation.
 apply body_to_term_abs.
 apply close_var_body.
 pick_fresh z.
 assert (z = var_gen(fv t1)) as Ha.
 apply var_gen_fv.
 apply notin_union_r2 with (E:= L). trivial.
 rewrite <- Ha.
 apply H0.
 apply notin_union_r1 with (F:= (fv t1)). trivial.

 rewrite xc2_equation.
 apply body_to_subs.
 apply close_var_body.
 pick_fresh z.
 assert (z = var_gen(fv t1)) as Hb.
 apply var_gen_fv.
 apply notin_union_r2 with (E:= L).
 apply notin_union_r1 with (F:= (fv t2)). trivial.
 rewrite <- Hb.
 apply H0.
 apply notin_union_r1 with (F:= fv t1).
 apply notin_union_r1 with (F:= fv t2). trivial.
 trivial.

 rewrite xc2_equation.
 apply body_open_term.
 unfold body.
 exists L.
 introv Ha.
 pick_fresh z.

Admitted.

Lemma xc2_term_term: forall t, term t -> xc2 t = t.
Proof.
 intros t Ha.
 induction Ha.

 rewrite xc2_equation.
 trivial.

 rewrite xc2_equation.
 rewrite IHHa1.
 rewrite IHHa2.
 trivial.

 rewrite xc2_equation.
 pick_fresh z.
 apply notin_union in Fr.
 destruct Fr as [Hb Hc].
 assert (z=var_gen (fv t1)) as Hd.
 apply var_gen_fv. trivial.
 rewrite <- Hd.
 rewrite H0.
 rewrite <- close_open_term.
 trivial. trivial. trivial.

 rewrite xc2_equation.
 pick_fresh z.
 apply notin_union in Fr.
 destruct Fr as [Hb Hc].
 apply notin_union in Hb.
 destruct Hb as [Hd He].
 assert (z=var_gen (fv t1)) as Hf.
 apply var_gen_fv.
 trivial.
 rewrite <- Hf.
 rewrite H0.
 rewrite <- close_open_term.
 rewrite IHHa.
 trivial. trivial. trivial.
Qed.

 Lemma xc_bswap: forall t, bswap(xc(t)) = xc(bswap(t)).
Proof.
  intro.
  unfold bswap.
   generalize 0.
  induction t.
  intro.
  assert (xc (pterm_bvar n) = pterm_bvar n).
  simpl xc; reflexivity.
  rewrite H.
  case (n0 === n).
  intro. rewrite e.
  simpl bswap_rec at 2. case_nat.
  simpl bswap_rec. case_nat.
  simpl xc; reflexivity.
  intro.
  case (S n0 === n).
  intro Hn0. rewrite <- Hn0.
  simpl bswap_rec.
  case_nat.
  simpl xc; reflexivity.
  case_nat.
  simpl; reflexivity.
  intro Hn0.
  unfold bswap_rec.
  case_nat.
  case_nat.
  contradiction.
  simpl xc; reflexivity.
  intro n.
  simpl bswap_rec. simpl; reflexivity.
  intro n.
  simpl bswap_rec.
  simpl xc at 3.
  fequal. apply IHt1. apply IHt2.
  intro n.
  simpl bswap_rec.
  simpl xc at 2.
  fequal. apply IHt.
  intro n.
  simpl bswap_rec.
  simpl xc at 3.
  fequal. apply IHt1. apply IHt2.
  intro n.
  simpl bswap_rec.
  simpl xc.
  rewrite <- IHt1.
Admitted.

 Lemma xc2_bswap: forall t, bswap(xc2(t)) = xc2(bswap(t)).
Proof.
 introv.
Admitted. (*precisamos desse caso geral ou de um mais especifico ?*)

Lemma xc_idempotent: forall t, xc(xc(t)) = t.
Proof.
  induction t.
  simpl; reflexivity.
  simpl; reflexivity.
  simpl. rewrite IHt1. rewrite IHt2; reflexivity.
  simpl. rewrite IHt; reflexivity.
  simpl. rewrite IHt1. rewrite IHt2; reflexivity.
  simpl.

Lemma xc_equations: forall t t', t =~e t' ->  xc t = xc t'.
Proof.
  intros t t' He.
  elim He.
  intros.
  elim H.
  intros.
  elim H0.
  intros; reflexivity.
  intros. simpl.
  unfold open. simpl.

  destruct H.
  induction H; trivial.
  induction t.
  induction n.
  simpl. simpl.
  Admitted.

   Lemma xc2_equations: forall t t', t =~e t' ->  xc2 t = xc2 t'.
Proof.
  introv He.
  destruct He as [t1|t2].
  destruct H.
  destruct H.

  trivial.

  rewrite xc2_equation.
  unfold open.
  apply eq_sym.
  rewrite xc2_equation.
  SearchAbout bswap.

  elim Hb.
  introv. trivial.
  introv Hc Hd.
  rewrite xc2_equation.
  rewrite xc2_equation.
  apply eq_sym.
  rewrite xc2_equation.
  unfold open. simpl.

  destruct H.
  induction H; trivial.
  induction t.
  induction n.
  simpl. simpl.
Admitted.

  Lemma xc_ex_equal: forall t t', t -->[ex] t' -> xc t = xc t'.
Proof.
  intros t t' Hex.
  destruct Hex.
  destruct H.
  destruct H.
  destruct H0.
  destruct H0.
  induction H0.
  assert (xc(t) = xc (pterm_bvar 0 [[t0]])).
  apply xc_equations; assumption.
  simpl in H2. unfold open in H2. simpl in H2.
  (*rewrite H.*)
Admitted.

  Lemma xc2_ex_equal: forall t t', lab_term t -> t -->[ex] t' -> xc2 t = xc2 t'.
Proof.
  introv Ht Hex.

  inversion Hex as [t1 Ha].
  inversion Ha as [t2 Hb].
  destruct Hb as [Hb Hc].
  destruct Hc as [Hc Hd].

  induction Ht.

  case Hc.

Admitted.

  (*
Lemma SN_lab_1 : forall S t u', lab_term S t -> ((U_lab t) -->lex u') ->
                 exists u, lab_term S u /\ (t -->[lex] u) /\ u' = U_lab u .
Proof.
 intros.
 case H0; clear H0. intros t0 H'.
 case H'; clear H'. intros u0 H'.
 destruct H'. destruct H1.
 induction H1. induction H1. destruct H1.
 exists (t0[[u]]). split.
 skip. split.

(*
 unfold body in H1. case H1; clear H1.
 intros L H1. apply lab_term_sub' with (L := L); intros;
 try apply term_to_lab_term; trivial.
 apply H1; trivial. skip. skip. split. skip. simpl.
 *)

 Admitted.

Lemma SN_lab_2 : forall S t, lab_term S t -> SN lab_lex t -> SN lex (U_lab t).
Proof.
 intros.
Admitted.

(** In order to prove the Perpetuality Theorem, IE Property is considered as a hypothesis, but in a future work the a formalization of this point needs to be done. A sofisticated approach with the extention of the lex grammar is used in D. Kesner's paper, and our intent is following the same steps of the pencil and paper proof.
*)

*)

Hypothesis IE_property : forall t u lv, body t -> term u->
                         SN lex u -> SN lex ((t ^^ u) // lv) -> SN lex ((t[u]) // lv).


Require Import Coq.Strings.String.
Require Import MirrorSolve.SMT.

Require Import MirrorSolve.FirstOrder.

Section SMTSig.
  Set Universe Polymorphism.
  Variable (sig: signature).

  Inductive packed_sfun :=
  | PSF: forall args r, sig.(sig_funs) args r -> packed_sfun
  | PSR : forall args, sig.(sig_sorts) -> sig.(sig_rels) args -> packed_sfun
  | PSL : forall X args r,
    (forall (x: X), sig.(sig_funs) args r) ->
    packed_sfun.

  Record smt_sig := MkSMTSig {
    sorts : list (sig.(sig_sorts) * smt_sort) ;
    funs : list (packed_sfun * smt_fun) ;
  }.
End SMTSig.

Register MkSMTSig as ms.smt.mk_smt_sig.
Register PSF as ms.smt.psf.
Register PSR as ms.smt.psr.
Register PSL as ms.smt.psl.


Require oeuf.Common.
Require Vector.

(* 2 deep total lookups *)
Inductive vecvec (A : Type) : forall (n :nat), Vector.t nat n -> Type :=
| empty :
    vecvec A O (Vector.nil nat)
| full :
    forall len (v : Vector.t A len)
           n (lens : Vector.t nat n) (vv : vecvec A n lens),
      vecvec A (S n) (Vector.cons nat len n lens).

(* Operation copied from Vectors *)
(* use this instead of destructing a vector *)
(* just destruct the index instead *)
Definition caseS {A} (* type parameter *)
           (P : forall {n}, Vector.t A (S n) -> Type) (* Property of nonempty vectors *)
           (H : forall h {n} t, @P n (Vector.cons A h _ t)) (* Proof that property holds on cons *)
           {n} (* implicit bound *)
           (v: Vector.t A (S n)) (* actual vector *)
  : P v := (* Property on that vector *)
match v with
| Vector.cons _ h _ t => H h t
| _ => fun devil => False_ind (@IDProp) devil
end.

(* like caseS, but for 2 dimensions *)
(*

Definition vvcaseS {A}
           (P : forall {n}, t A (S n) -> Type)

(* Operation copied from Vectors *)
Definition nth {A} :=
fix nth_fix {m} (v' : t A m) (p : Fin.t m) {struct v'} : A :=
match p in Fin.t m' return t A m' -> A with
 |Fin.F1 => caseS (fun n v' => A) (fun h n t => h)
 |Fin.FS p' => fun v => (caseS (fun n v' => Fin.t n -> A)
   (fun h n t p0 => nth_fix t p0) v) p'
end v'.

(* TODO: how do I write this? *)
Fixpoint lookup
         (A : Type)
         (n : nat)
         (lens : Vector.t nat n)
         (vv : vecvec A n lens)
         (idx1 : Fin.t n)
         (idx2 : Fin.t (Vector.nth lens idx1)) : nat :=
  match vv with
  | empty _ O (Vector.nil nat) =>
    match idx1 as Fin.t O with end
  | full _ len v n lens vv' => O
  end.
  inversion vv.
  - subst n. inversion idx1.
  - subst n.

    eapply Eqdep_dec.inj_pair2_eq_dec in H2;
      try eapply PeanoNat.Nat.eq_dec.

    subst lens.

*)


Require Import String.
Import List.
Import ListNotations.

Require Import Utilities.

Require Import Input_Properties.
Require Import Flood_Properties.
Require Import Flood_Box.

Require Import List_Properties.

Require Import extract_port_buffer_message_properties.
Require Import execute_flood_aux_properties.

Lemma fail_on_add_diff_message_implies_fails_before:
  forall buf buf' i i' j j' m m' c c',
  extract_port_buffer (add_message_to_all buf i' m' c') j i j' m c = (buf', None) ->
  (i', m', c') <> (i, m, c) ->
  exists buf'', extract_port_buffer buf j i j' m c = (buf'', None).
Proof.
  intros buf.
  induction buf;
  intros buf' i i' j j' m m' c c';
  intros H_extract_add H_ne.
  - simpl.
    exists [].
    reflexivity.
  - simpl in H_extract_add |- *.
    destruct j.
    + destruct (triple_and (Nat.eqb i i') (m =? m')%string (Nat.eqb c c')) eqn:and_eq.
      * apply tuple_nat_string_nat_not_eq_implies_or in H_ne.
        destruct H_ne.
        -- apply PeanoNat.Nat.eqb_neq in H.
           destruct (Nat.eqb i i') eqn:rem.
           ++ rewrite PeanoNat.Nat.eqb_sym in H.
              rewrite rem in H.
              discriminate.
           ++ unfold triple_and in and_eq.
              discriminate.
        -- destruct H.
           ++ apply eqb_neq in H.
              rewrite eqb_sym in H.
              rewrite H in and_eq.
              unfold triple_and in and_eq.
              destruct (Nat.eqb i i');
              discriminate.
           ++ apply PeanoNat.Nat.eqb_neq in H.
              destruct (Nat.eqb c c') eqn:rem.
              ** rewrite PeanoNat.Nat.eqb_sym in H.
                 rewrite rem in H.
                 discriminate.
              ** unfold triple_and in and_eq.
                 discriminate.
      * destruct (extract_message a i j' m c).
        inversion H_extract_add.
        exists (i0 :: buf).
        reflexivity.
    + destruct (extract_port_buffer (add_message_to_all buf i' m' c') j i j' m c) eqn:extract.
      inversion H_extract_add.
      subst. clear H_extract_add.
      assert (exists buf'' : In_transit_buffer, extract_port_buffer buf j i j' m c = (buf'', None))
        as H_extract_is_none
        by (eapply IHbuf;
            eassumption).
      destruct H_extract_is_none as [buf'' H_extract_is_none].
      exists (a :: buf'').
      rewrite H_extract_is_none.
      reflexivity.
Qed.

Lemma fail_on_extract_message_diff_message_implies_fails_before:
  forall port_buf port_buf' port_buf'' i i' j j' m m' c c' res,
  extract_message port_buf i' j' m' c' = (port_buf', res) ->
  extract_message port_buf' i j m c = (port_buf'', None) ->
  (i', m', c') <> (i, m, c) ->
  exists some_port_buf, extract_message port_buf i j m c = (some_port_buf, None).
Proof.
  intros port_buf.
  induction port_buf;
  intros port_buf' port_buf'' i i' j j' m m' c c' res;
  intros H_extract_first H_extract H_ne.
  - exists [].
    simpl.
    reflexivity.
  - simpl in H_extract_first |- *.
    destruct a.
    destruct p.
    destruct (triple_and (Nat.eqb i' n0) (m' =? s)%string (Nat.eqb c' n)) eqn:and_first.
    + destruct (triple_and (Nat.eqb i n0) (m =? s)%string (Nat.eqb c n)) eqn:and_second.
      * unfold triple_and in and_first, and_second.
        destruct (Nat.eqb i' n0) eqn:H_i'n0;
        destruct ((m' =? s)%string) eqn:H_m's;
        destruct (Nat.eqb c' n) eqn:H_c'n;
        destruct (Nat.eqb i n0) eqn:H_in0;
        destruct ((m =? s)%string) eqn:H_ms;
        destruct (Nat.eqb c n) eqn:H_cn;
          try discriminate.
        clear and_first. clear and_second.
        apply EqNat.beq_nat_true in H_i'n0.
        apply EqNat.beq_nat_true in H_in0.
        apply eqb_eq in H_m's.
        apply eqb_eq in H_ms.
        apply EqNat.beq_nat_true in H_c'n.
        apply EqNat.beq_nat_true in H_cn.
        subst.
        contradiction.
      * inversion H_extract_first.
        subst. clear H_extract_first.
        rewrite H_extract.
        exists ((n0, s, n) :: port_buf'').
        reflexivity.
    + destruct (extract_message port_buf i' j' m' c') eqn:extract_first.
      inversion H_extract_first.
      subst. clear H_extract_first.
      destruct (triple_and (Nat.eqb i n0) (m =? s)%string (Nat.eqb c n)) eqn:and_second;
      simpl in H_extract;
      rewrite and_second in H_extract.
      * inversion H_extract.
      * destruct (extract_message i0 i j m c) eqn:extract_second.
        inversion H_extract.
        subst. clear H_extract.
        assert (exists some_port_buf, extract_message port_buf i j m c = (some_port_buf, None))
          as H_must_fail
          by (eapply IHport_buf;
              eassumption).
        destruct H_must_fail as [some_port_buf H_must_fail].
        rewrite H_must_fail.
        exists ((n0, s, n) :: some_port_buf).
        reflexivity.
Qed.

Lemma fail_on_extract_port_buffer_same_port_implies_fail_before:
  forall buf buf' buf'' i i' j' jp jp' m m' c c' p,
  extract_port_buffer buf j' i' jp' m' c' = (buf', Some p) ->
  extract_port_buffer buf' j' i jp m c = (buf'', None) ->
  (i', m', c') <> (i, m, c) ->
  exists some_buf, extract_port_buffer buf j' i jp m c = (some_buf, None).
Proof.
  intros buf.
  induction buf;
  intros buf' buf'' i i' j' jp jp' m m' c c' p;
  intros H_extract_some H_extract_none H_diff;
  simpl in H_extract_some |- * .
  - inversion H_extract_some.
  - destruct j'.
    + destruct (extract_message a i' jp' m' c') eqn:extract_mes_some.
      inversion H_extract_some.
      subst. clear H_extract_some.
      simpl in H_extract_none.
      destruct (extract_message i0 i jp m c) eqn:extract_mes_none.
      inversion H_extract_none.
      subst. clear H_extract_none.
      assert (exists some_port_buf, extract_message a i jp m c = (some_port_buf, None))
        as H_res_none
        by (eapply fail_on_extract_message_diff_message_implies_fails_before;
            eassumption).
      destruct H_res_none as [some_port_buf H_res_none].
      rewrite H_res_none.
      exists (some_port_buf :: buf).
      reflexivity.
    + destruct (extract_port_buffer buf j' i' jp' m' c') eqn:extract_some.
      inversion H_extract_some.
      subst. clear H_extract_some.
      simpl in H_extract_none.
      destruct (extract_port_buffer i0 j' i jp m c) eqn:extract_none.
      inversion H_extract_none.
      subst. clear H_extract_none.
      assert (exists some_buf, extract_port_buffer buf j' i jp m c = (some_buf, None))
        as H_res_none
        by (eapply IHbuf;
            eassumption).
      destruct H_res_none as [some_buf H_res_none].
      rewrite H_res_none.
      exists (a :: some_buf).
      reflexivity.
Qed.

Lemma fail_on_extract_port_buffer_diff_port_implies_fail_before:
  forall buf buf' buf'' i i' j j' jp jp' m m' c c' p,
  extract_port_buffer buf j' i' jp' m' c' = (buf', Some p) ->
  extract_port_buffer buf' j i jp m c = (buf'', None) ->
  j <> j' ->
  exists some_buf, extract_port_buffer buf j i jp m c = (some_buf, None).
Proof.
  intros buf.
  induction buf;
  intros buf' buf'' i i' j j' jp jp' m m' c c' p;
  intros H_extract_first H_extract_fail H_ne;
  simpl in H_extract_first |- *.
  - inversion H_extract_first.
  - destruct j'.
    + destruct (extract_message a i' jp' m' c') eqn:extract_mes_first.
      inversion H_extract_first.
      subst. clear H_extract_first.
      simpl in H_extract_fail.
      destruct j.
      * contradiction.
      * destruct (extract_port_buffer buf j i jp m c) eqn:extract_second.
        inversion H_extract_fail.
        subst. clear H_extract_fail.
        exists (a :: i1).
        reflexivity.
    + destruct (extract_port_buffer buf j' i' jp' m' c') eqn:extract_first.
      inversion H_extract_first.
      subst. clear H_extract_first.
      simpl in H_extract_fail.
      destruct j.
      * destruct (extract_message a i jp m c) eqn:extract_mes_second.
        inversion H_extract_fail.
        subst. clear H_extract_fail.
        exists (i1 :: buf).
        reflexivity.
      * destruct (extract_port_buffer i0 j i jp m c) eqn:extract_second.
        inversion H_extract_fail.
        subst. clear H_extract_fail.
        assert (exists some_buf, extract_port_buffer buf j i jp m c = (some_buf, None))
          as H_must_fail
          by (eapply IHbuf;
              try apply PeanoNat.Nat.succ_inj_wd_neg;
              eassumption).
        destruct H_must_fail as [some_buf H_must_fail].
        rewrite H_must_fail.
        exists (a :: some_buf).
        reflexivity.
Qed.

Lemma fail_on_extract_diff_message_implies_fails_before:
  forall buf buf' buf'' i i' j jp j' jp' m m' c c' res,
  extract_port_buffer buf j' i' jp' m' c' = (buf', res) ->
  extract_port_buffer buf' j i jp m c = (buf'', None) ->
  (i', j', m', c') <> (i, j, m, c) ->
  exists some_buf, extract_port_buffer buf j i jp m c = (some_buf, None).
Proof.
  intros buf buf' buf'' i i' j jp j' jp' m m' c c' res.
  intros H_extract_prev H_extract_fail H_ne.
  destruct res.
  - assert (j < Datatypes.length buf \/ Datatypes.length buf <= j)
      as H_out_of_bounds_or_not
      by (apply PeanoNat.Nat.lt_ge_cases).
    destruct H_out_of_bounds_or_not as [H_in_bounds | H_out_bounds].
    + assert (j = j' \/ j <> j')
        as H_j_eq_dec
        by (apply nat_eq_dec).
      destruct H_j_eq_dec as [H_j_eq | H_j_not_eq].
      * subst.
        eapply fail_on_extract_port_buffer_same_port_implies_fail_before;
          try eassumption.
        unfold not.
        intros H_eq.
        inversion H_eq.
        subst.
        apply H_ne.
        reflexivity.
      * eapply fail_on_extract_port_buffer_diff_port_implies_fail_before;
        eassumption.
    + apply extract_port_buffer_out_of_bounds_implies_none
        with buf i j jp m c
        in H_out_bounds.
      exists buf.
      assumption.
  - apply extract_port_buffer_none_action_same_buffer in H_extract_prev.
    subst.
    exists buf''.
    assumption.
Qed.

Definition input_message_then_fail_extract_implies_earlier_deliver_def
  (inp : inputs) : Prop :=
  forall t1 n i j m c trace buf buf',
  nth_error inp t1 = Some (Send i (m, c)) ->
  execute_flood_rec inp (Flood_Box_init n) = (trace, buf) ->
  extract_port_buffer buf j i j m c = (buf', None) ->
  j < n ->
  exists t2, t1 < t2 /\ nth_error inp t2 = Some (Deliver i j (m, c)).

Lemma input_message_then_fail_extract_implies_earlier_deliver:
  forall inp,
  input_message_then_fail_extract_implies_earlier_deliver_def inp.
Proof.
  apply rev_ind;
  unfold input_message_then_fail_extract_implies_earlier_deliver_def.
  - intros.
    nth_error_empty.
  - intros action inp.
    intros IHinp.
    intros t1 n i j m c trace buf buf'.
    intros H_inp_send H_exec H_extract_fail H_jle.
    apply concat_inp_concats_trace_split in H_exec.
    destruct H_exec as [buf_inter H_exec].
    destruct H_exec as [trace_head H_exec].
    destruct H_exec as [trace_tail H_exec].
    destruct H_exec as [H_trace_concat H_exec].
    destruct H_exec as [H_exec_inp H_exec_send].
    apply nth_index_in_concat in H_inp_send.
    destruct H_inp_send as [H_inp_send | H_inp_send_tail].
    + destruct action;
      simpl in H_exec_send.
      * destruct p.
        inversion H_exec_send.
        subst. clear H_exec_send.
        assert ((n0, s, n1) = (i, m, c) \/ (n0, s, n1) <> (i, m, c))
          as H_same_or_diff_send_params
          by (apply tuple_nat_string_nat_eq_dec).
        destruct H_same_or_diff_send_params as [H_same_params | H_diff_params].
        -- inversion H_same_params.
           subst. clear H_same_params.
           assert (n = Datatypes.length buf_inter)
             as H_buf_length
             by (rewrite <- length_of_flood_init_is_param with (n := n);
                 eapply execute_inp_preserves_buffer_length;
                 eassumption).
           subst.
           assert (exists buf' res,
                    extract_port_buffer (add_message_to_all buf_inter i m c) j i j m c
                      = (buf', Some res))
             as H_extract_not_fail
             by (apply extract_from_buffer_with_message_just_added_cannot_fail;
                 assumption).
           destruct H_extract_not_fail as [buf'' H_extract_not_fail].
           destruct H_extract_not_fail as [res H_extract_not_fail].
           rewrite H_extract_not_fail in H_extract_fail.
           inversion H_extract_fail.
        -- assert (exists buf', extract_port_buffer buf_inter j i j m c = (buf', None))
             as H_extract_smaller_fail
             by (eapply fail_on_add_diff_message_implies_fails_before;
                 eassumption).
           destruct H_extract_smaller_fail as [some_buf H_extract_smaller_fail].
           assert (exists t2 : nat, t1 < t2 /\ nth_error inp t2 = Some (Deliver i j (m, c)))
           as H_deliver_in_inp
           by (eapply IHinp;
               eassumption).
           destruct H_deliver_in_inp as [t2 H_deliver_in_inp].
           destruct H_deliver_in_inp as [H_le H_deliver_in_inp].
           exists t2.
           split.
           ++ assumption.
           ++ apply nth_succes_larger.
              assumption.
      * destruct p.
        assert ((n0, n1, s, n2) = (i, j, m, c) \/ (n0, n1, s, n2) <> (i, j, m, c))
          as H_same_or_diff_deliver_params
          by (apply tuple_nat_nat_string_nat_eq_dec).
        destruct H_same_or_diff_deliver_params as [H_same_params | H_diff_params].
        -- inversion H_same_params.
           subst. clear H_same_params.
           exists (Datatypes.length inp).
           split.
           ++ apply nth_error_Some.
              unfold not.
              intros H_none.
              rewrite H_none in H_inp_send.
              discriminate.
           ++ rewrite nth_error_app2.
              ** rewrite PeanoNat.Nat.sub_diag.
                 simpl.
                 reflexivity.
              ** apply PeanoNat.Nat.le_refl.
        -- destruct (extract_port_buffer buf_inter n1 n0 n1 s n2) eqn:del_extract.
           destruct o;
           try (do 3 destruct p);
           inversion H_exec_send;
           subst; clear H_exec_send;
           assert (exists buf', extract_port_buffer buf_inter j i j m c = (buf', None))
             as H_extract_smaller_fail
             by (eapply fail_on_extract_diff_message_implies_fails_before;
                 eassumption);
           destruct H_extract_smaller_fail as [some_buf H_extract_smaller_fail];
           assert (exists t2 : nat, t1 < t2 /\ nth_error inp t2 = Some (Deliver i j (m, c)))
           as H_deliver_in_inp
           by (eapply IHinp;
               eassumption);
           destruct H_deliver_in_inp as [t2 H_deliver_in_inp];
           destruct H_deliver_in_inp as [H_le H_deliver_in_inp];
           exists t2;
           split;
           try (apply nth_succes_larger);
           assumption.
    + destruct H_inp_send_tail as [offset H_inp_send_tail].
      destruct H_inp_send_tail as [H_offset H_inp_send_tail].
      destruct offset;
      simpl in H_inp_send_tail.
      * inversion H_inp_send_tail.
        subst. clear H_inp_send_tail.
        simpl in H_exec_send.
        inversion H_exec_send.
        subst. clear H_exec_send.
        assert (n = Datatypes.length buf_inter)
          as H_buf_length
          by (rewrite <- length_of_flood_init_is_param with (n := n);
              eapply execute_inp_preserves_buffer_length;
              eassumption).
        subst.
        assert (exists buf' res,
                 extract_port_buffer (add_message_to_all buf_inter i m c) j i j m c
                   = (buf', Some res))
          as H_extract_not_fail
          by (apply extract_from_buffer_with_message_just_added_cannot_fail;
              assumption).
        destruct H_extract_not_fail as [buf'' H_extract_not_fail].
        destruct H_extract_not_fail as [res H_extract_not_fail].
        rewrite H_extract_not_fail in H_extract_fail.
        inversion H_extract_fail.
      * nth_error_empty.
Qed.

Definition send_then_deliver_inp_implies_input_output_pair_in_trace_def
  (inp : inputs) : Prop :=
  forall t1 t1' t2 n i j m c trace buf,
  nth_error inp t1 = Some (Send i (m, c)) ->
  nth_error inp t2 = Some (Deliver i j (m, c)) ->
  t1 < t2 ->
  no_late_specific_send inp t1 i m c ->
  execute_flood_rec inp (Flood_Box_init n) = (trace, buf) ->
  nth_error trace t1' = Some (Flood_Input i (m, c)) ->
  j < n ->
  exists t2', t1' < t2' /\ nth_error trace t2' = Some (Flood_Output i j (m, c)).

Lemma send_then_deliver_inp_implies_input_output_pair_in_trace:
  forall inp,
  send_then_deliver_inp_implies_input_output_pair_in_trace_def inp.
Proof.
  apply rev_ind;
  unfold send_then_deliver_inp_implies_input_output_pair_in_trace_def.
  - intros.
    nth_error_empty.
  - intros action inp.
    intros IHinp.
    intros t1 t1' t2 n i j m c trace buf'.
    intros H_inp_send H_inp_deliver H_t_le H_inp_no_late_send H_exec H_trace_input H_port_exists.
    apply concat_inp_concats_trace_split in H_exec.
    destruct H_exec as [buf H_exec].
    destruct H_exec as [trace_head H_exec].
    destruct H_exec as [trace_tail H_exec].
    destruct H_exec as [trace_concat H_exec].
    destruct H_exec as [exec_inp exec_action].
    apply nth_index_in_concat in H_inp_send.
    destruct H_inp_send as [H_inp_send_head | H_inp_send_tail].
    + apply nth_index_in_concat in H_inp_deliver.
      destruct H_inp_deliver as [H_inp_deliver_head | H_inp_deliver_tail].
      * rewrite trace_concat in H_trace_input.
        assert (exists t2' : nat, t1' < t2' /\
                  nth_error trace_head t2' = Some (Flood_Output i j (m, c)))
          as H_output_in_head
          by (eapply IHinp;
              try eapply no_late_specific_send_implies_shorter;
              try eapply send_in_inp_head_implies_send_in_trace_head;
              eassumption).
        destruct H_output_in_head as [t2' H_output_in_head].
        destruct H_output_in_head as [H_le_prime H_output_in_head].
        exists t2'.
        split.
        -- assumption.
        -- rewrite trace_concat.
           eapply nth_succes_larger.
           eassumption.
      * destruct H_inp_deliver_tail as [offset H_inp_deliver_tail].
        destruct H_inp_deliver_tail as [H_offset H_inp_deliver_tail].
        destruct offset;
        simpl in H_inp_deliver_tail.
        -- inversion H_inp_deliver_tail.
           subst. clear H_inp_deliver_tail.
           simpl in H_t_le.
           simpl in exec_action.
           destruct (extract_port_buffer buf j i j m c) eqn:extract.
           destruct o.
           ++ do 3 destruct p.
              inversion exec_action.
              subst. clear exec_action.
              apply extract_port_buffer_success_same_output in extract.
              destruct extract as [H_eq1 H_eq].
              destruct H_eq as [H_j_eq H_eq].
              destruct H_eq as [H_m_eq H_c_eq].
              subst.
              exists (S (Datatypes.length trace_head)).
              split.
              ** apply nth_error_concat_not_in_tail_implies_head in H_trace_input.
                 --- apply PeanoNat.Nat.lt_lt_succ_r.
                     apply nth_error_Some.
                     unfold not.
                     intros H_none.
                     rewrite H_none in H_trace_input.
                     inversion H_trace_input.
                 --- unfold not.
                     intros H_in.
                     inversion H_in;  (* fix name, to be constant - match goal? *)
                     inversion H;
                     inversion H0.
              ** rewrite nth_error_app2.
                 --- rewrite <- Minus.minus_Sn_m.
                     +++ rewrite PeanoNat.Nat.sub_diag.
                         simpl.
                         reflexivity.
                     +++ apply PeanoNat.Nat.le_refl.
                 --- apply PeanoNat.Nat.le_succ_diag_r.
           ++ inversion exec_action.
              subst. clear exec_action.
              assert (exists t2, t1 < t2 /\ nth_error inp t2 = Some (Deliver i j (m, c)))
                as H_earlier_deliver
                by (eapply input_message_then_fail_extract_implies_earlier_deliver;
                    eassumption).
              destruct H_earlier_deliver as [t2 H_earlier_deliver].
              destruct H_earlier_deliver as [H_t1_le_t2 H_inp_deliver].
              assert (exists t2' : nat, t1' < t2' /\
                        nth_error trace_head t2' = Some (Flood_Output i j (m, c)))
                as H_output_in_head
                by (eapply IHinp;
                    try eassumption;
                    try eapply no_late_specific_send_implies_shorter;
                    try eapply nth_different_tail_smaller;
                    try eassumption;
                    discriminate).
              destruct H_output_in_head as [t2' H_output_in_head].
              destruct H_output_in_head as [H_le H_output_in_head].
              exists t2'.
              split.
              ** assumption.
              ** eapply nth_succes_larger.
                 eassumption.
        --  nth_error_empty.
    + destruct H_inp_send_tail as [offset H_inp_send_tail].
      destruct H_inp_send_tail as [H_offset H_inp_send_tail].
      destruct offset;
      simpl in H_inp_send_tail.
      * inversion H_inp_send_tail.
        simpl in H_offset.
        subst. clear H_inp_send_tail.
        apply nth_different_tail_smaller in H_inp_deliver.
        -- apply PeanoNat.Nat.lt_le_incl in H_t_le.
           apply nth_error_None in H_t_le.
           rewrite H_inp_deliver in H_t_le.
           inversion H_t_le.
        -- unfold not.
           intros H_err.
           inversion H_err.
      * nth_error_empty.
Qed.

Theorem Flood_Box_Liveness:
  forall inp n trace,
  user_contract inp ->
  input_liveness inp n ->
  execute_flood inp n = trace ->
  flood_liveness trace n.
Proof.
  intros inp n trace.
  intros H_contract H_live_inp H_exec.
  unfold flood_liveness.
  intros i m c t1.
  intros H_nth j H_in.
  unfold execute_flood in H_exec.
  destruct (execute_flood_rec inp (Flood_Box_init n)) eqn:exec_rec.
  simpl in H_exec.
  subst.
  assert (exists t1', nth_error inp t1' = Some (Send i (m, c))/\
                      no_late_specific_send inp t1' i m c)
    as H_inp_send
    by (eapply input_in_trace_implies_late_send_in_inp;
        eassumption).
  destruct H_inp_send as [t1' H_inp_send].
  destruct H_inp_send as [H_inp_send H_inp_late_non_send].
  unfold input_liveness in H_live_inp.
  assert (exists t2 : nat, t1' < t2 /\ nth_error inp t2 = Some (Deliver i j (m, c)))
    as H_deliver_inp
    by (eapply H_live_inp;
        eassumption).
  destruct H_deliver_inp as [t2 H_deliver_inp].
  destruct H_deliver_inp as [H_t_le H_deliver_inp].
  eapply send_then_deliver_inp_implies_input_output_pair_in_trace;
  eassumption.
Qed.


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 O B C Bprime Cprime X Y B0 : Universe, ((wd_ Cprime O /\ (wd_ Bprime O /\ (wd_ B O /\ (wd_ B C /\ (wd_ C O /\ (wd_ X Y /\ (wd_ B0 O /\ (wd_ C Bprime /\ (wd_ Y C /\ (wd_ X C /\ (wd_ Y B /\ (wd_ X B /\ (wd_ B Bprime /\ (wd_ B B0 /\ (wd_ B Cprime /\ (wd_ Cprime C /\ (wd_ Cprime Bprime /\ (col_ O Bprime Cprime /\ (col_ B O C /\ (col_ O X Y /\ (col_ X Y B0 /\ (col_ C C Bprime /\ col_ O C Bprime)))))))))))))))))))))) -> col_ O B Bprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D A1 A2 A3 B1 B2 B3 C1 C2 C3 D1 D2 D3 O P Q R : Universe, ((wd_ A B /\ (wd_ B D /\ (wd_ A D /\ (wd_ C1 C2 /\ (wd_ C2 C3 /\ (wd_ C B /\ (wd_ C D /\ (wd_ A1 A2 /\ (wd_ A2 A3 /\ (wd_ A C /\ (wd_ D1 D2 /\ (wd_ D2 D3 /\ (wd_ B1 B2 /\ (wd_ B2 B3 /\ (wd_ P Q /\ (wd_ Q R /\ (col_ A B C /\ (col_ A D C /\ (col_ B O D /\ (col_ A O C /\ col_ D2 D1 D3)))))))))))))))))))) -> col_ C B D)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 O B C Bprime Cprime X Y : Universe, ((wd_ Cprime O /\ (wd_ Bprime O /\ (wd_ B O /\ (wd_ B C /\ (wd_ C O /\ (wd_ X Y /\ (wd_ Y C /\ (wd_ X C /\ (wd_ Y B /\ (wd_ X B /\ (wd_ B Bprime /\ (wd_ C C /\ (wd_ C Bprime /\ (wd_ B Cprime /\ (wd_ Cprime C /\ (wd_ Cprime Bprime /\ (col_ O Bprime Cprime /\ (col_ B O C /\ (col_ O X Y /\ (col_ X Y Cprime /\ (col_ X Y C /\ col_ Cprime O C))))))))))))))))))))) -> col_ O B Bprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Coq - Calculus of Inductive Constructions V5.10           *)
(*****************************************************************************)
(*                                                                           *)
(*          Basic Category Theory: epic, monic, iso                          *)
(*                                                                           *)
(*          Amokrane Saibi,  May 1994                                        *)
(*                                                                           *)
(*****************************************************************************)

Require Export Dual.

Set Implicit Arguments.
Unset Strict Implicit.

Section epic_monic_def.

Variables (C : Category) (a b : C).

(* epic *)

Definition Epic_law (f : a --> b) :=
  forall (c : C) (g h : b --> c), f o g =_S f o h -> g =_S h.

Structure > Epic : Type :=
  {Epic_mor : a --> b; Prf_isEpic :> Epic_law Epic_mor}.

(* monic *)

Definition Monic_law (f : b --> a) :=
  forall (c : C) (g h : c --> b), g o f =_S h o f -> g =_S h.

Structure > Monic : Type :=
  {Monic_mor : b --> a; Prf_isMonic :> Monic_law Monic_mor}.

End epic_monic_def.

(* iso *)

Section iso_def.

Variable C : Category.

Definition RIso_law (a b : C) (f : a --> b) (f1 : b --> a) := f1 o f =_S Id b.

Variable a b : C.

Definition AreIsos (f : a --> b) (f1 : b --> a) :=
  RIso_law f f1 /\ RIso_law f1 f.

Structure > Iso : Type :=
  {Iso_mor : a --> b; Inv_iso : b --> a; Prf_Iso :> AreIsos Iso_mor Inv_iso}.

Lemma Idl_inv : forall i : Iso, RIso_law (Iso_mor i) (Inv_iso i).
Proof.
simple induction i; unfold AreIsos in |- *; intros f g p; elim p; auto.
Qed.

Lemma Idr_inv : forall i : Iso, RIso_law (Inv_iso i) (Iso_mor i).
Proof.
simple induction i; unfold AreIsos in |- *; intros f g p; elim p; auto.
Qed.

Lemma Inv_iso_unique :
 forall f g : Iso, Iso_mor f =_S Iso_mor g -> Inv_iso f =_S Inv_iso g.
Proof.
intros f g H.
apply Trans with ((Inv_iso f o Iso_mor f) o Inv_iso g).
apply Trans with (Inv_iso f o Iso_mor f o Inv_iso g).
apply Trans with (Inv_iso f o Id a).
apply Idr.
apply Comp_l.
apply Trans with (Iso_mor g o Inv_iso g).
apply Sym; apply (Idr_inv g).
apply Comp_r; apply Sym; trivial.
apply Ass.
apply Trans with (Id b o Inv_iso g).
apply Comp_r; apply (Idl_inv f).
apply Idl.
Qed.

Lemma RightInv_epic :
 forall (h : a --> b) (h1 : b --> a), RIso_law h h1 -> Epic_law h.
Proof.
intros h h1 H.
unfold Epic_law in |- *; intros c f g H1.
apply Trans with (Id b o f).
apply Idl1.
apply Trans with (Id b o g).
apply Trans with ((h1 o h) o f).
apply Comp_r; apply Sym; trivial.
apply Trans with ((h1 o h) o g).
apply Trans with (h1 o h o f).
apply Ass1.
apply Trans with (h1 o h o g).
apply Comp_l; trivial.
apply Ass.
apply Comp_r; trivial.
apply Idl.
Qed.

End iso_def.

Coercion RightInv_epic : RIso_law >-> Epic_law.

(* initial *)

Section initial_def.

Variable C : Category.

Definition IsInitial (a : C) (h : forall b : C, a --> b) :=
  forall (b : C) (f : a --> b), f =_S h b.

Structure > Initial : Type :=
  {Initial_ob : C;
   MorI : forall b : C, Initial_ob --> b;
   Prf_isInitial :> IsInitial MorI}.

Definition At_most_1mor (a b : C) := forall f g : a --> b, f =_S g.

Lemma UniqueI : forall (i : Initial) (b : C), At_most_1mor (Initial_ob i) b.
Proof.
intros i b; red in |- *; intros f g.
apply Trans with (MorI i b).
apply (Prf_isInitial (i:=i)).
apply Sym; apply (Prf_isInitial (i:=i)).
Qed.

Lemma I_unic : forall i1 i2 : Initial, Iso (Initial_ob i1) (Initial_ob i2).
Proof.
intros i1 i2.
apply
 (Build_Iso (Iso_mor:=MorI i1 (Initial_ob i2))
    (Inv_iso:=MorI i2 (Initial_ob i1))); unfold AreIsos in |- *;
 unfold RIso_law in |- *; split.
apply (UniqueI (i:=i2) (b:=Initial_ob i2)).
apply (UniqueI (i:=i1) (b:=Initial_ob i1)).
Defined.

End initial_def.

(* terminal *)

Section terminal_def.

Variable C : Category.

Definition IsTerminal (b : C) (h : forall a : C, a --> b) :=
  forall (a : C) (f : a --> b), f =_S h a.

Structure > Terminal : Type :=
  {Terminal_ob : C;
   MorT : forall a : C, a --> Terminal_ob;
   Prf_isTerminal :> IsTerminal MorT}.

Lemma UniqueT : forall (t : Terminal) (a : C), At_most_1mor a (Terminal_ob t).
Proof.
intros t a; red in |- *; intros f g.
apply Trans with (MorT t a).
apply (Prf_isTerminal (t:=t)).
apply Sym; apply (Prf_isTerminal (t:=t)).
Qed.

End terminal_def.

Lemma Initial_dual :
 forall (C : Category) (a : C) (h : forall b : C, a --> b),
 IsInitial h -> IsTerminal (C:=Dual C) h.
Proof.
auto.
Qed.

Coercion Initial_dual : IsInitial >-> IsTerminal.

Definition IsTerminal' (C : Category) (b : C) (h : forall a : C, a --> b) :=
  IsInitial (C:=Dual C) h.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal45.

From lfind Require Import LFind.
Require Import Arith.
Require Import Extraction.
Extract Inductive nat => nat [ "(O)" "S" ].
Extract Inductive list => list [ "Nil" "Cons" ].
Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal45_theorem0_61_Nat_beq_refl/goal45_lfind_orig.ml"  adtind.goal45.insort Coq.Init.Datatypes.orb adtind.goal45.eqb adtind.goal45.mem.
Success.