(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model Really minimal *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
(* Definition of co_locs already included in the prelude *)
(* Definition of cross already included in the prelude *)
Definition generate_orders s pco := cross (co_locs pco (partition s)).
Definition generate_cos pco := generate_orders W pco.
Variable co : relation events.
Definition witness_conditions := generate_cos co0 co.
Definition model_conditions := True.
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW generate_orders generate_cos witness_conditions model_conditions : cat.

Definition valid (c : candidate) :=
  exists co : relation (events c),
    witness_conditions c co /\
    True.

(* End of translation of model Really minimal *)


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Layers of VMM                                          *)
(*                                                                     *)
(*          Refinement proof for MALInit layer                         *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file provide the contextual refinement proof between MBoot layer and MALInit layer*)
Require Import BootGenDef.
Require Import BootGenLemma.

(** * Definition of the refinement relation*)
Section Refinement.

  Section WITHMEM.

    Context `{Hstencil: Stencil}.
    Context `{Hmem: Mem.MemoryModel}.
    Context `{Hmwd: UseMemWithData mem}.

    Global Instance: LoadStoreProp' (HD:= mboot_data_prf).
    Proof.
      accessor_prop_tac.
    Qed.

    Lemma flatmem_load_correct0:
      forall (s: stencil) ι (m1 m2: mem) (d1: HDATAOps) (d2: LDATAOps) chunk n v b,
        FlatMem.load chunk (HP d1) n = v ->
        MatchExtcallStates (one_crel (CompatRelOps0:= rel_ops) HDATAOps LDATAOps) s ι m1 d1 m2 d2 ->
        0 <= n <= adr_max - size_chunk chunk ->
        (align_chunk chunk | n) ->
        find_symbol s FlatMem_LOC = Some b ->
        exists v',
          Mem.load (mem:= mwd LDATAOps) chunk (m2, d2) b n = Some v' /\
          val_inject ι v v'.
    Proof.
      intros. inv H0.
      inv match_match. inv H.
      rewrite H3 in H4; inv H4.
      assert (HOS1: n + size_chunk chunk <= adr_max).
      {
        revert H1; clear; intros.
        omega.
      }
      assert (HOS2: n >= 0) by omega.
      pose proof (size_chunk_pos chunk) as HOS3.
      destruct H0 as [v1[v2[HL1[HV1[HL2 HM]]]]].
      assert (HW1: adr_max = n + (adr_max - n)) by omega.
      rewrite HW1 in HL1, HL2. clear HW1.
      eapply Mem.loadbytes_split in HL1; try omega.
      eapply FlatMem.loadbytes_split in HL2; try omega.
      rewrite Z.add_0_l in HL1, HL2.
      destruct HL1 as (bs11 & bs12 & HL11 & HL12 & Hca1).
      destruct HL2 as (bs21 & bs22 & HL21 & HL22 & Hca2).
      assert (Heq1: length bs11 = length bs21).
      {
        erewrite Mem.loadbytes_length; eauto 1.
        erewrite FlatMem.loadbytes_length; eauto 1.
      }
      assert (Heq2: length bs12 = length bs22).
      {
        erewrite Mem.loadbytes_length; eauto 1.
        erewrite FlatMem.loadbytes_length; eauto 1.
      }
      clear HL21.
      assert (HW2: adr_max - n = size_chunk chunk + (adr_max - n - size_chunk chunk)) by omega.
      rewrite HW2 in HL12, HL22. clear HW2.
      eapply Mem.loadbytes_split in HL12; try omega.
      eapply FlatMem.loadbytes_split in HL22; try omega.
      destruct HL12 as (bs121 & bs122 & HL121 & HL122 & Hca11).
      destruct HL22 as (bs221 & bs222 & HL221 & HL222 & Hca21).
      assert (Heq3: length bs121 = length bs221).
      {
        erewrite Mem.loadbytes_length; eauto 1.
        erewrite FlatMem.loadbytes_length; eauto 1.
      }
      assert (Heq4: length bs122 = length bs222).
      {
        erewrite Mem.loadbytes_length; eauto 1.
        erewrite FlatMem.loadbytes_length; eauto 1.
      }
      clear HL222.
      exploit Mem.loadbytes_load; eauto.
      intros HL1'.
      erewrite FlatMem.loadbytes_load; eauto.
      simpl. lift_trivial.
      rewrite HL1'.
      refine_split'; eauto 1.
      eapply decode_val_inject; eauto.
      clear HL221.
      subst.
      eapply list_forall2_sep in HM; auto.
      destruct HM as [_ HM].
      eapply list_forall2_sep in HM; auto.
      apply HM.
    Qed.

    Ltac pattern2_refinement_simpl:=
      pattern2_refinement_simpl' (@relate_AbData).

    Lemma flatmem_store_correct0:
      forall v v' (s: stencil) ι (m1 m2: mem) (d1 d1': HDATAOps) d2 chunk n b,
        flatmem_store' d1 chunk n v = Some d1' ->
        MatchExtcallStates (one_crel (CompatRelOps0:= rel_ops) HDATAOps LDATAOps) s ι m1 d1 m2 d2 ->
        0 <= n <= adr_max - size_chunk chunk ->
        (align_chunk chunk | n) ->
        val_inject ι v v' ->
        find_symbol s FlatMem_LOC = Some b ->
        exists m2',
          Mem.store chunk m2 b n v' = Some m2' /\
          MatchExtcallStates (one_crel (CompatRelOps0:= rel_ops) HDATAOps LDATAOps) s ι m1 d1' m2' d2.
    Proof.
      intros. inv H0.
      inv match_match. inv H0.
      rewrite H6 in H4; inv H4.
      destruct H5 as [v1[v2[HL1[HV1[HL2 HM]]]]].
      assert (HV: Mem.valid_access m2 chunk b n Writable).
      {
        unfold Mem.valid_access.
        split; try assumption.
        unfold Mem.range_perm in *. intros.
        Transparent Z.sub.
        eapply HV1. omega.
      }
      Opaque Z.sub.
      pose proof (Mem.valid_access_store _ _ _ _ v' HV) as HST.
      destruct HST as [m2' HST].
      rewrite HST.
      refine_split'; eauto 1. functional inversion H.
      econstructor; eauto 1; pattern2_refinement_simpl.
      constructor. econstructor; try eassumption.
      Transparent Z.sub.
      assert (HW1: adr_max = n + (adr_max - n)) by omega.
      rewrite HW1 in HL1, HL2 |- *.
      pose proof (size_chunk_pos chunk) as HOS3.
      eapply Mem.loadbytes_split in HL1; try omega.
      eapply FlatMem.loadbytes_split in HL2; try omega.
      rewrite Z.add_0_l in HL1, HL2.
      destruct HL1 as (bs11 & bs12 & HL11 & HL12 & Hca1).
      destruct HL2 as (bs21 & bs22 & HL21 & HL22 & Hca2).
      assert (Heq1: length bs11 = length bs21).
      {
        erewrite Mem.loadbytes_length; eauto 1.
        erewrite FlatMem.loadbytes_length; eauto 1.
      }
      assert (Heq2: length bs12 = length bs22).
      {
        erewrite Mem.loadbytes_length; eauto 1.
        erewrite FlatMem.loadbytes_length; eauto 1.
      }
      assert (HW2: adr_max - n = size_chunk chunk + (adr_max - n - size_chunk chunk)) by omega.
      rewrite HW2 in HL12, HL22 |- *.
      eapply Mem.loadbytes_split in HL12; try omega.
      eapply FlatMem.loadbytes_split in HL22; try omega.
      destruct HL12 as (bs121 & bs122 & HL121 & HL122 & Hca11).
      destruct HL22 as (bs221 & bs222 & HL221 & HL222 & Hca21).
      assert (Heq3: length bs121 = length bs221).
      {
        erewrite Mem.loadbytes_length; eauto 1.
        erewrite FlatMem.loadbytes_length; eauto 1.
      }
      assert (Heq4: length bs122 = length bs222).
      {
        erewrite Mem.loadbytes_length; eauto 1.
        erewrite FlatMem.loadbytes_length; eauto 1.
      }
      exploit Mem.loadbytes_store_same; eauto.
      intros HL1'.
      refine_split'; eauto 1.
      + eapply Mem.loadbytes_concat; try omega.
        * erewrite Mem.loadbytes_store_other; eauto 1.
          right; right; left. reflexivity.
        * rewrite Z.add_0_l.
          eapply Mem.loadbytes_concat; try omega.
          {
            erewrite Mem.loadbytes_store_same; eauto 1.
          }
          {
            erewrite Mem.loadbytes_store_other; eauto 1.
            right; right; right. reflexivity.
          }
      + rewrite <- HW2. rewrite <- HW1.
        unfold Mem.range_perm in *. intros.
        eapply Mem.perm_store_1; eauto.
      + assert (HF1: FlatMem.store chunk (HP d1) n v = HP d1 {HP : FlatMem.store chunk (HP d1) n v}) by reflexivity.
        rewrite <- HF1. clear HF1.
        pose proof (FlatMem.loadbytes_store_same chunk (HP d1) n v _ refl_equal) as HL2'.
        destruct HL2' as [HL2'|HL2'].
        * assert (HF: FlatMem.loadbytes (FlatMem.store chunk (HP d1) n v) 0
                                        (n + (size_chunk chunk + (4294967296 - n - size_chunk chunk)))
                      = bs21 ++ encode_val chunk v ++ bs222).
          {
            eapply FlatMem.loadbytes_concat; try omega.
            - erewrite FlatMem.loadbytes_store_other; eauto 1.
              right; left. reflexivity.
            - rewrite Z.add_0_l.
              eapply FlatMem.loadbytes_concat; try omega.
              + unfold flatmem_store. simpl. assumption.
              + erewrite FlatMem.loadbytes_store_other; eauto 1.
                right; right. reflexivity.
          }
          rewrite HF.
          clear HF HL2' HL222 HL221 HL21. subst.
          eapply list_forall2_sep in HM; auto.
          destruct HM as [HM1 HM].
          eapply list_forall2_sep in HM; auto.
          destruct HM as [_ HM2].
          apply list_forall2_app; eauto 1.
          apply list_forall2_app; eauto 1.
          eapply encode_val_inject; eauto.
        * assert (HF: FlatMem.loadbytes (FlatMem.store chunk (HP d1) n v) 0
                                        (n + (size_chunk chunk + (4294967296 - n - size_chunk chunk)))
                      = bs21 ++ (list_repeat (length (encode_val chunk v)) Undef) ++ bs222).
          {
            eapply FlatMem.loadbytes_concat; try omega.
            - erewrite FlatMem.loadbytes_store_other; eauto 1.
              right; left. reflexivity.
            - rewrite Z.add_0_l.
              eapply FlatMem.loadbytes_concat; try omega.
              + unfold flatmem_store. simpl. assumption.
              + erewrite FlatMem.loadbytes_store_other; eauto 1.
                right; right. reflexivity.
          }
          rewrite HF.
          clear HF HL2' HL222 HL221 HL21. subst.
          eapply list_forall2_sep in HM; auto.
          destruct HM as [HM1 HM].
          eapply list_forall2_sep in HM; auto.
          destruct HM as [_ HM2].
          apply list_forall2_app; eauto 1.
          apply list_forall2_app; eauto 1.
          apply list_forall2_memval_undef_chunk.
    Qed.

  End WITHMEM.

End Refinement.


(** Here we define signatures for HITs *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.Combinatorics.FiniteSets.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.categories.HSET.All.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.

Require Import prelude.
Require Import syntax.containers.
Require Import syntax.W_types.

Definition hit_signature
  : UU
  := ∑ (point_constr : container)
       (path_arg : container),
     ∏ (s : shapes path_arg),
       W point_constr (positions path_arg s)
       ×
       W point_constr (positions path_arg s).

(*
nattrans

W C X
≃
y X ⇒ (X → W C X)

∏ (s : shapes path_arg), W point_constr (positions path_arg s)
≃
∏ (s : shapes path_arg),
  nattrans (yoneda (positions path_arg s)) (W point_constr)
 *)

Definition point_constr
           (Σ : hit_signature)
  : container
  := pr1 Σ.

Definition path_index
           (Σ : hit_signature)
  : hSet
  := shapes (pr12 Σ).

Definition path_arg
           (Σ : hit_signature)
           (s : path_index Σ)
  : hSet
  := positions (pr12 Σ) s.

Definition path_lhs
           (Σ : hit_signature)
           (s : path_index Σ)
  : W (point_constr Σ) (path_arg Σ s)
  := pr1 (pr22 Σ s).

Definition path_rhs
           (Σ : hit_signature)
           (s : path_index Σ)
  : W (point_constr Σ) (path_arg Σ s)
  := pr2 (pr22 Σ s).

Definition make_hit_signature
           (point_constr : container)
           (path_arg : container)
           (path_lhs : ∏ (s : shapes path_arg),
                       W point_constr (positions path_arg s))
           (path_rhs : ∏ (s : shapes path_arg),
                       W point_constr (positions path_arg s))
  : hit_signature
  := point_constr ,, (path_arg ,, λ s, path_lhs s ,, path_rhs s).

Definition is_finitary_hit
           (Σ : hit_signature)
  : UU
  := is_finitary (point_constr Σ) × is_finitary (pr12 Σ).


Require Import
        Coq.Strings.String
        Coq.Vectors.Vector.

Require Import
        Fiat.Computation
        Fiat.Narcissus.BinLib.CharString
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.WordFacts
        Fiat.Narcissus.Common.ComposeCheckSum
        Fiat.Narcissus.Common.ComposeIf
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.Automation.Solver
        Fiat.Narcissus.Formats.CInt
        Fiat.Narcissus.Formats.NatOpt
        Fiat.Narcissus.Formats.FixListOpt
        compcert.lib.Integers.

Module IntFormatr := CInt.Make(Wordsize_32).

Import IntFormatr.

Instance ByteStringQueueMonoid : Monoid ByteString := ByteStringQueueMonoid.

Definition Simple_Format_Spec
           (p : int * list int) :=
        format_nat 8 (|snd p|)
  ThenC format_int Int.wordsize (fst p)
  ThenC format_list (format_int Int.wordsize) (snd p)
  DoneC.

Definition Simply_OK (p : int * list int) :=
  ((|snd p|) < pow2 8)%nat.

Definition Simple_Format_decoder
  : CorrectDecoderFor Simply_OK Simple_Format_Spec.
Proof.
  start_synthesizing_decoder.
  normalize_compose monoid.
  repeat first [apply innt_decode_correct; auto
               | solve [ intros; apply intrange]
               | intros; simpl; match goal with |- _ /\ _ => split; intuition eauto end
               | decode_step idtac].
  synthesize_cache_invariant.
  cbv beta; optimize_decoder_impl.
Defined.

Definition Simple_Format_decoder_impl :=
  Eval simpl in (fst (projT1 Simple_Format_decoder)).

Print Simple_Format_decoder_impl.

Lemma foo {C} {numBytes}
  : forall (v : Vector.t byte (S numBytes)) (k : int -> ByteString -> unit -> option (C * ByteString * unit)),
    (`(a, b0, d) <- decode_int
      (monoidUnit := ByteString_QueueMonoidOpt) 8 (build_aligned_ByteString v) tt;
       k a b0 d) =
    Let n := byteToInt32 (Vector.nth v Fin.F1) in
    k n (build_aligned_ByteString (Vector.tl v)) ().
Proof.
  unfold LetIn; intros.
  unfold decode_int, WordOpt.decode_word.
  rewrite aligned_decode_char_eq; simpl.
  f_equal.
  pattern numBytes, v; apply Vector.caseS; simpl; intros.
  destruct h.
  destruct intval0; simpl; intros; intuition eauto.
  - compute; apply mkint_eq; reflexivity.
  - repeat first [compute in intrange0; destruct intrange0; congruence
                 | destruct p as [p | p | ]; simpl
                 | compute; apply mkint_eq; reflexivity].
  - compute in intrange0; destruct p; destruct intrange0; congruence.
Qed.

Lemma foo2 {C} {numBytes}
  : forall (v : Vector.t byte (S numBytes)) (k : nat -> ByteString -> unit -> option (C * ByteString * unit)),
    (`(a, b0, d) <- decode_nat
      (monoidUnit := ByteString_QueueMonoidOpt) 8 (build_aligned_ByteString v) tt;
       k a b0 d) =
    Let n := BinInt.Z.to_nat (Byte.intval (Vector.nth v Fin.F1)) in
    k n (build_aligned_ByteString (Vector.tl v)) ().
Proof.
  intros.
  unfold decode_nat, WordOpt.decode_word.
  rewrite aligned_decode_char_eq; simpl.
  f_equal.
  pattern numBytes, v; apply Vector.caseS; simpl; intros.
  destruct h.
  destruct intval0; simpl; intros; intuition eauto.
  - repeat first [compute in intrange0; destruct intrange0; congruence
                 | destruct p as [p | p | ]; simpl
                 | compute; reflexivity].
Qed.

Lemma foo3 {C} {numBytes}
  : forall (v : Vector.t byte (S (S (S (S numBytes))))) (k : int -> ByteString -> unit -> option (C * ByteString * unit)),
    (`(a, b0, d) <- decode_int
      (monoidUnit := ByteString_QueueMonoidOpt) Int.wordsize (build_aligned_ByteString v) tt;
       k a b0 d) =
    Let n := wordToInt (Core.append_word (byteToWord (Vector.nth v (Fin.FS (Fin.FS (Fin.FS Fin.F1)))))
                                         (Core.append_word (byteToWord (Vector.nth v (Fin.FS (Fin.FS Fin.F1))))
                                            (Core.append_word (byteToWord (Vector.nth v (Fin.FS Fin.F1)))
                                                              (byteToWord (Vector.nth v Fin.F1)))))
    in
    k n (build_aligned_ByteString (Vector.tl (Vector.tl (Vector.tl (Vector.tl v))))) ().
Proof.
  unfold LetIn; intros.
  unfold decode_int, WordOpt.decode_word.
  unfold Int.wordsize, Wordsize_32.wordsize.
  rewrite DecodeBindOpt2_assoc.
  pose proof (@aligned_decode_char_eq' _ 3 v).
  match goal with
    |- context[Ifopt ?Z as _ Then _ Else _] => replace Z with
                                               (let (v', v'') := Vector_split 4 numBytes v in Some (VectorByteToWord v', build_aligned_ByteString v'')) by (rewrite <- H; reflexivity)
  end.
  unfold Vector_split, If_Opt_Then_Else, DecodeBindOpt2 at 1, If_Opt_Then_Else.
  unfold DecodeBindOpt2 at 1, If_Opt_Then_Else.
  repeat f_equal.
  rewrite Core.append_word_assoc; erewrite VectorByteToWord_cons; repeat f_equal.
  rewrite Core.append_word_assoc, <- !Eqdep_dec.eq_rect_eq_dec; eauto using Peano_dec.eq_nat_dec.
  f_equal.
  erewrite VectorByteToWord_cons; f_equal.
  rewrite <- !Eqdep_dec.eq_rect_eq_dec; eauto using Peano_dec.eq_nat_dec; f_equal.
  erewrite VectorByteToWord_cons; f_equal.
  rewrite <- !Eqdep_dec.eq_rect_eq_dec; eauto using Peano_dec.eq_nat_dec; f_equal.
  erewrite VectorByteToWord_cons; f_equal.
  rewrite <- !Eqdep_dec.eq_rect_eq_dec; eauto using Peano_dec.eq_nat_dec; f_equal.
  simpl; f_equal; rewrite !Vector_nth_tl, Vector_nth_hd; reflexivity.
  simpl; f_equal; rewrite !Vector_nth_tl, Vector_nth_hd; reflexivity.
  simpl; f_equal; rewrite !Vector_nth_tl, Vector_nth_hd; reflexivity.
  simpl; f_equal; rewrite Vector_nth_hd; reflexivity.
  Grab Existential Variables.
  omega.
  omega.
  omega.
Qed.

Definition ofbytes (hi himid hilo lo: byte) : int :=
  or (shl (repr (Byte.unsigned hi)) (repr 24))
     (or (shl (repr (Byte.unsigned himid)) (repr 16))
         (or (shl (repr (Byte.unsigned hilo)) (repr 8))
             (repr (Byte.unsigned lo)))).

Lemma wordToInt_ofbytes_eq
  : forall (hi himid hilo lo: byte),
    wordToInt (Core.append_word
                 (byteToWord lo)
                 (Core.append_word (byteToWord hilo) (Core.append_word (byteToWord himid)
                                                                       (byteToWord hi)))) =
    ofbytes hi himid hilo lo.
Proof.
Admitted.

Lemma foo4 {C} {numBytes}
  : forall (v : Vector.t byte (S (S (S (S numBytes))))) (k : int -> ByteString -> unit -> option (C * ByteString * unit)),
    (`(a, b0, d) <- decode_int
      (monoidUnit := ByteString_QueueMonoidOpt) Int.wordsize (build_aligned_ByteString v) tt;
       k a b0 d) =
    Let n := ofbytes (Vector.nth v Fin.F1)
                     (Vector.nth v (Fin.FS Fin.F1))
                     (Vector.nth v (Fin.FS (Fin.FS Fin.F1)))
                     (Vector.nth v (Fin.FS (Fin.FS (Fin.FS Fin.F1))))
    in
    k n (build_aligned_ByteString (Vector.tl (Vector.tl (Vector.tl (Vector.tl v))))) ().
Proof.
  intros; rewrite foo3.
  rewrite wordToInt_ofbytes_eq.
  reflexivity.
Qed.

Definition aligned_Simple_Format_decoder_impl (bs : Vector.t byte 32) :
  {n : option (int * list int * ByteString * ()) & n =
                                                        Simple_Format_decoder_impl (build_aligned_ByteString bs) ()}.
  eexists.
  symmetry; unfold Simple_Format_decoder_impl.
  erewrite (foo2 bs).
  apply f_equal; apply Coq.Logic.FunctionalExtensionality.functional_extensionality; intro.
  rewrite foo4.
  etransitivity.
  apply f_equal; apply Coq.Logic.FunctionalExtensionality.functional_extensionality; intro.
Abort.


(* begin hide *)
From Coq Require Import
     Arith.PeanoNat
     Logic.FunctionalExtensionality
     Lists.List
     Lia.

From Heapster Require Import
     Utils
     Permissions.

Import ListNotations.
(* end hide *)

(** * Memory model *)
(** ** Addresses *)
(** We use a block-offset address model. *)
Definition addr : Set := nat * nat.

(** Equality on addresses. *)
Definition eqb (a b : addr) : bool :=
  Nat.eqb (fst a) (fst b) && Nat.eqb (snd a) (snd b).

Lemma eqb_spec : forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros [x1 x2] [y1 y2]. destruct (eqb (x1, x2) (y1, y2)) eqn:?; constructor.
  - unfold eqb in Heqb. simpl in Heqb. symmetry in Heqb. apply Bool.andb_true_eq in Heqb.
    destruct Heqb. symmetry in H, H0.
    apply (Bool.reflect_iff _ _ (Nat.eqb_spec _ _)) in H.
    apply (Bool.reflect_iff _ _ (Nat.eqb_spec _ _)) in H0. subst. auto.
  - unfold eqb in Heqb. simpl in Heqb. apply Bool.andb_false_iff in Heqb.
    destruct Heqb.
    + intro. inversion H0. subst. rewrite Nat.eqb_refl in H. inversion H.
    + intro. inversion H0. subst. rewrite Nat.eqb_refl in H. inversion H.
Qed.

Lemma addr_dec : forall (a b : addr), {a = b} + {a <> b}.
Proof.
  intros [a1 a2] [b1 b2].
  destruct (Nat.eq_dec a1 b1); destruct (Nat.eq_dec a2 b2); subst; auto.
  - right. intros H. inversion H; subst. apply n. reflexivity.
  - right. intros H. inversion H; subst. apply n. reflexivity.
  - right. intros H. inversion H; subst. apply n. reflexivity.
Qed.

Lemma addr_neq_cases (b b' o o' : nat) :
  (b, o) <> (b', o') -> b <> b' \/ o <> o'.
Proof.
  intros.
  destruct (Nat.eq_dec b b'); destruct (Nat.eq_dec o o'); subst; auto.
Qed.

(** ** Memory definition *)
Inductive Value :=
| VNum : nat -> Value
| VPtr : addr -> Value.

Definition mem_block := nat -> option Value.

Variant logical_block :=
| LBlock (size : nat) (bytes : mem_block) : logical_block.

Definition memory := list (option logical_block).

(** ** Memory operations *)
(** Whether the block of [ptr] is allocated and is the offset of [ptr] within bounds. *)
Definition allocated (m : memory) (ptr : addr) : bool :=
  match nth_error m (fst ptr) with
  | Some (Some (LBlock size _)) => snd ptr <? size
  | _ => false
  end.

(** Read [m] at memory location [ptr]. [ptr] must be a valid location and allocated. *)
Definition read (m : memory) (ptr : addr) : option Value :=
  if allocated m ptr
  then match nth_error m (fst ptr) with
       | Some (Some (LBlock _ bytes)) => bytes (snd ptr)
       | _ => None
       end
  else None.

(** Returns the size of the block only if [ptr] has offset 0. *)
(** Note if we used [allocated] here then it doesn't work for size 0 blocks. *)
Definition sizeof (m : memory) (ptr : addr) : option nat :=
  if snd ptr =? 0
  then match nth_error m (fst ptr) with
       | Some (Some (LBlock size _)) => Some size
       | _ => None
       end
  else None.

(** Write [v] into [m] at address [ptr]. *)
Definition write (m : memory) (ptr : addr) (v : Value) : option memory :=
  if allocated m ptr
  then match nth_error m (fst ptr) with
       | Some (Some (LBlock size bytes)) =>
         Some (replace_list_index
                 m
                 (fst ptr)
                 (Some (LBlock size (fun o => if o =? snd ptr
                                           then Some v
                                           else bytes o))))
       | _ => None
       end
  else None.

(** Properties about memory operations *)
Lemma allocated_ptr_block m b o :
  allocated m (b, o) = true ->
  b < length m.
Proof.
  unfold allocated. simpl. intros.
  apply nth_error_Some. intro. rewrite H0 in H. inversion H.
Qed.

Lemma allocated_ptr_offset m b o size bytes :
  allocated m (b, o) = true ->
  nth_error m b = Some (Some (LBlock size bytes)) ->
  o < size.
Proof.
  unfold allocated. simpl. intros. rewrite H0 in H.
  rewrite <- (Bool.reflect_iff _ _ (Nat.ltb_spec0 _ _)) in H. auto.
Qed.

Lemma read_success_write m ptr v v' :
  read m ptr = Some v ->
  exists m', write m ptr v' = Some m'.
Proof.
  unfold read, write. intros.
  destruct (allocated m ptr), (nth_error m (fst ptr));
    try destruct o; try solve [inversion H].
  destruct l. eexists. reflexivity.
Qed.

Lemma write_success_read_eq m m' ptr v :
  write m ptr v = Some m' ->
  read m' ptr = Some v.
Proof.
  unfold read, write. intros.
  destruct (allocated m ptr) eqn:?, (nth_error m (fst ptr)) eqn:?;
           try destruct o; try solve [inversion H].
  destruct l. inversion H. clear H H1 m'. unfold allocated in *.
  rewrite nth_error_replace_list_index_eq.
  rewrite Heqo in Heqb. clear Heqo. rewrite Heqb. rewrite Nat.eqb_refl; auto.
Qed.

Lemma write_success_read_neq m m' ptr v :
  write m ptr v = Some m' ->
  forall ptr', ptr <> ptr' -> read m ptr' = read m' ptr'.
Proof.
  destruct ptr as [b o].
  unfold write. unfold read. simpl. intros.
  destruct (allocated m (b, o)) eqn:?; try solve [inversion H].
  destruct (nth_error m b) eqn:?; try solve [inversion H].
  destruct o0 eqn:?; try solve [inversion H].
  destruct l. inversion H; subst; clear H. destruct ptr' as [b' o']. simpl.
  pose proof (allocated_ptr_block _ _ _ Heqb0).
  destruct (addr_neq_cases _ _ _ _ H0).
  - unfold allocated. simpl. erewrite nth_error_replace_list_index_neq; eauto.
  - destruct (Nat.eq_dec b b').
    + subst. unfold allocated. simpl. rewrite nth_error_replace_list_index_eq; auto.
      rewrite Heqo0. destruct (o' <? size) eqn:?; auto.
      rewrite <- Nat.eqb_neq in H1. rewrite Nat.eqb_sym. rewrite H1. auto.
    + unfold allocated. simpl. erewrite nth_error_replace_list_index_neq; eauto.
Qed.

Lemma write_success_sizeof m m' ptr v :
  write m ptr v = Some m' ->
  forall ptr', sizeof m ptr' = sizeof m' ptr'.
Proof.
  destruct ptr as [b o].
  unfold write. unfold read. simpl. intros.
  destruct (allocated m (b, o)) eqn:?; try solve [inversion H].
  destruct (nth_error m b) eqn:?; try solve [inversion H].
  destruct o0 eqn:?; try solve [inversion H].
  destruct l. inversion H; subst; clear H. destruct ptr' as [b' o']. simpl.
  pose proof (allocated_ptr_block _ _ _ Heqb0).
  unfold sizeof. simpl. destruct (o' =? 0) eqn:?; auto.
  destruct (Nat.eq_dec b b').
  - subst. simpl. rewrite nth_error_replace_list_index_eq; auto.
    rewrite Heqo0. auto.
  - erewrite nth_error_replace_list_index_neq; eauto.
Qed.

Lemma write_success_length m m' ptr v :
  write m ptr v = Some m' ->
  length m = length m'.
Proof.
  destruct ptr as [b o].
  unfold write. unfold read. simpl. intros.
  destruct (allocated m (b, o)) eqn:?; try solve [inversion H].
  destruct (nth_error m b) eqn:?; try solve [inversion H].
  destruct o0 eqn:?; try solve [inversion H].
  destruct l. inversion H; subst; clear H.
  pose proof (allocated_ptr_block _ _ _ Heqb0).
  simpl. apply replace_list_index_length; auto.
Qed.

(** ** Helper definitions *)
(** [mem_at ptr v] creates a memory which is only defined at location [ptr]. *)
(** We use this for some sanity checks when we define memory permissions. *)
Definition mem_at (ptr : addr) (v : Value) : memory :=
  repeat None (fst ptr) ++ [Some (LBlock
                                    (snd ptr + 1)
                                    (fun o => if o =? snd ptr
                                           then Some v
                                           else None))].

(** Properties about [mem_at]. *)
Lemma allocated_mem_at ptr v : allocated (mem_at ptr v) ptr = true.
  destruct ptr as [b o]. unfold allocated, mem_at. simpl.
  induction b; simpl; auto. apply Nat.ltb_lt. lia.
Qed.

Lemma nth_error_mem_at ptr v :
  nth_error (mem_at ptr v) (fst ptr) =
  Some (Some (LBlock
                (snd ptr + 1)
                (fun o => if o =? snd ptr
                       then Some v
                       else None))).
Proof.
  destruct ptr as [b o]. simpl. induction b; auto.
Qed.

Lemma read_mem_at ptr v : read (mem_at ptr v) ptr = Some v.
Proof.
  destruct ptr as [b o]. unfold read.
  rewrite allocated_mem_at. rewrite nth_error_mem_at.
  rewrite Nat.eqb_refl. reflexivity.
Qed.

Lemma write_mem_at ptr v v' : write (mem_at ptr v) ptr v' = Some (mem_at ptr v').
Proof.
  destruct ptr as [b o]. unfold write.
  rewrite allocated_mem_at. rewrite nth_error_mem_at. f_equal.
  unfold mem_at. simpl.
  induction b; simpl; try solve [f_equal; auto].
  do 3 f_equal. apply functional_extensionality. intros.
  destruct (x =? o); auto.
Qed.

(** [replace_n] is used later for proving the [Free] rule. *)
Definition replace_n m b size bytes n : memory :=
  replace_list_index
    m b (Some (LBlock size (fun o => if andb (o <? size) (size - n <=? o)
                                  then None else bytes o))).

(** Properties of [replace_n]. *)
Lemma replace_n_0 m b size bytes :
  nth_error m b = Some (Some (LBlock size bytes)) ->
  replace_n m b size bytes 0 = m.
Proof.
  unfold replace_n. intros. f_equal.
  assert (b < length m).
  { apply nth_error_Some. intro. rewrite H in H0. inversion H0. }
  revert H H0. revert b.
  induction m; intros; simpl in *; try lia; auto.
  destruct b; f_equal; [| apply IHm; auto; lia].
  inversion H. rewrite Nat.sub_0_r.
  do 2 f_equal. apply functional_extensionality. intros.
  rewrite Nat.ltb_antisym. rewrite Bool.andb_negb_l. reflexivity.
Qed.

Lemma replace_n_same m b size bytes :
  replace_list_index m b (Some (LBlock (S size) (fun o : nat => if o <? S size then None else bytes o))) =
  replace_n m b (S size) bytes (S size).
Proof.
  unfold replace_n. do 4 f_equal. apply functional_extensionality. intros.
  rewrite Nat.sub_diag. simpl. rewrite Bool.andb_true_r. reflexivity.
Qed.

Lemma read_replace_n_neq ptr' n b len m bytes :
    b <> fst ptr' ->
    b < length m ->
    read m ptr' = read (replace_n m b len bytes n) ptr'.
Proof.
  unfold replace_n, read. intros Hneq Hlt.
  destruct (allocated m ptr') eqn:?.
  2: { unfold allocated in *.
       erewrite <- nth_error_replace_list_index_neq; eauto. rewrite Heqb0; auto. }
  pose proof (allocated_ptr_block _ _ _ Heqb0).
  unfold allocated in *. simpl.
  rewrite <- nth_error_replace_list_index_neq; eauto. rewrite Heqb0; auto.
Qed.

Lemma sizeof_replace_n ptr b m n size bytes :
  nth_error m b = Some (Some (LBlock size bytes)) ->
  b < length m ->
  sizeof m ptr = sizeof (replace_n m b size bytes n) ptr.
Proof.
  simpl. intros Hb Hlt. unfold replace_n, sizeof. destruct (snd ptr =? 0); auto.
  destruct (Nat.eq_dec (fst ptr) b).
  * rewrite e in *. simpl. rewrite nth_error_replace_list_index_eq; auto.
    rewrite Hb. auto.
  * simpl. erewrite <- nth_error_replace_list_index_neq; auto.
Qed.


Require Import Bedrock.Examples.AutoSep.

(** A very basic abstract predicate: pairs of words *)

Module Type PAIR.
  Parameter pair : W -> W -> W -> HProp.

  Axiom pair_extensional : forall a b p, HProp_extensional (pair a b p).

  Axiom pair_fwd : forall a b p,
    pair a b p ===> p =*> a * (p ^+ $4) =*> b.

  Axiom pair_bwd : forall a b p,
    p =*> a * (p ^+ $4) =*> b ===> pair a b p.
End PAIR.

Module Pair : PAIR.
  Open Scope Sep_scope.

  Definition pair (a b p : W) : HProp :=
    p =*> a * (p ^+ $4) =*> b.

  Theorem pair_extensional : forall a b p, HProp_extensional (pair a b p).
    reflexivity.
  Qed.

  Theorem pair_fwd : forall a b p,
    pair a b p ===> p =*> a * (p ^+ $4) =*> b.
    unfold pair; sepLemma.
  Qed.

  Theorem pair_bwd : forall a b p,
    p =*> a * (p ^+ $4) =*> b ===> pair a b p.
    unfold pair; sepLemma.
  Qed.
End Pair.

Import Pair.
Hint Immediate pair_extensional.

Definition firstS : spec := SPEC("p") reserving 0
  Al a, Al b,
  PRE[V] pair a b (V "p")
  POST[R] [| R = a |] * pair a b (V "p").

Definition updSecondS : spec := SPEC("p", "x") reserving 0
  Al a, Al b,
  PRE[V] pair a b (V "p")
  POST[_] pair a (V "x") (V "p").

Definition pair := bmodule "pair" {{
  bfunction "first"("p") [firstS]
    "p" <-* "p";;
    Return "p"
  end with bfunction "second"("p", "x") [updSecondS]
    "p" <- "p" + 4;;
    "p" *<- "x";;
    Return 0
  end
}}.

(*TIME Clear Timing Profile. *)

Definition hints : TacPackage.
  (*TIME idtac "pair:prepare". Time *)
  prepare pair_fwd pair_bwd.
Defined.

Theorem pairOk : moduleOk pair.
  (*TIME idtac "pair:verify". Time *)
  vcgen; abstract sep hints.
Qed.

(*TIME Print Timing Profile. *)


Add LoadPath "../..".
Require Import LFND_OkLib.
Require Import LFND_EmptyEquivLib.
Require Import LFND_Substitution.
Require Import LFND_Syntax.

Open Scope permut_scope.
Open Scope is5_scope.

Reserved Notation " G  '|=' Gamma '|-' M ':::' A" (at level 70).

Inductive types_LF : bg_LF -> ctx_LF -> te_LF -> ty -> Type :=

| t_hyp_LF: forall A G Gamma v
  (Ok: ok_Bg_LF (Gamma::G))
  (H: Mem (v, A) Gamma),
  G |= Gamma |- hyp_LF (fte v) ::: A

| t_lam_LF: forall L A B G Gamma M
  (Ok: ok_Bg_LF (Gamma::G))
  (H: forall v, v \notin L ->
    G |= (v, A)::Gamma |- M ^t^ (hyp_LF (fte v)) ::: B),
  G |= Gamma |- lam_LF A M ::: A ---> B

| t_appl_LF: forall A B G Gamma M N
  (Ok: ok_Bg_LF (Gamma::G))
  (H1: G |= Gamma |- M ::: A ---> B)
  (H2: G |= Gamma |- N ::: A),
  G |= Gamma |- appl_LF M N ::: B

| t_box_LF: forall G Gamma M A
  (Ok: ok_Bg_LF (G & Gamma))
  (H: G & Gamma |= nil |- M ::: A),
  G |= Gamma |- box_LF M ::: [*] A

| t_unbox_LF: forall G Gamma M A
  (Ok: ok_Bg_LF (Gamma :: G))
  (H: G |= Gamma |- M ::: [*] A),
  G |= Gamma |- unbox_LF M ::: A

| t_unbox_fetch_LF: forall G Gamma Gamma' M A
  (Ok: ok_Bg_LF (Gamma:: G & Gamma'))
  (H: G & Gamma' |= Gamma |- M ::: [*] A),
  forall G', G & Gamma ~=~ G' ->
    G' |= Gamma' |- unbox_LF M ::: A

where " G '|=' Gamma '|-' M ':::' A" := (types_LF G Gamma M A).

Inductive value_LF: te_LF -> Type :=
| val_lam_LF: forall A M, value_LF (lam_LF A M)
| val_box_LF: forall M, value_LF (box_LF M)
.

Reserved Notation " M |-> N " (at level 70).

Inductive step_LF: te_LF -> te_LF -> Type :=

| red_appl_lam_LF: forall M N A,
  lc_t_n_LF 1 M -> lc_t_LF N ->
  appl_LF (lam_LF A M) N |-> [N // bte 0] M

| red_unbox_box_LF: forall M,
  lc_t_LF M ->
  unbox_LF (box_LF M)|-> M

| red_appl_LF: forall M M' N,
  lc_t_LF M -> lc_t_LF N ->
  M |-> M'->
  appl_LF M N |-> appl_LF M' N

| red_unbox_LF: forall M M',
  lc_t_LF M -> M |-> M' ->
  unbox_LF M |-> unbox_LF M'

where " M |-> N " := (step_LF M N ).

Inductive steps_LF : te_LF -> te_LF -> Type :=
| single_step_LF: forall M M', M |-> M' -> steps_LF M M'
| multi_step_LF: forall M M' M'',
  M |-> M' -> steps_LF M' M'' -> steps_LF M M''
.

Lemma PPermutationG_LF:
forall G Gamma M A G',
  G |= Gamma |- M ::: A ->
  G ~=~ G' ->
  G' |= Gamma |- M ::: A.
intros; generalize dependent G'; induction X; intros; simpl in *.

constructor; [apply ok_Bg_LF_PPermut with (G:=Gamma::G)| ]; auto;
PPermut_LF_simpl.

apply t_lam_LF with (L:=L);
[apply ok_Bg_LF_PPermut with (G:=Gamma::G)| ]; auto; PPermut_LF_simpl.

apply t_appl_LF with (A:=A);
[apply ok_Bg_LF_PPermut with (G:=Gamma::G)| |]; auto; PPermut_LF_simpl.

constructor;
[apply ok_Bg_LF_PPermut with (G:=G & Gamma)|]; auto.

constructor;
[apply ok_Bg_LF_PPermut with (G:=Gamma::G)|]; auto.

apply t_unbox_fetch_LF with (G:=G) (Gamma:=Gamma); auto.
transitivityP G'; auto.
Qed.

Lemma PermutationGamma_LF:
forall G Gamma M A Gamma',
  G |= Gamma |- M ::: A ->
  Gamma *=* Gamma' ->
  G |= Gamma' |- M ::: A.
intros. generalize dependent Gamma'.
induction X; intros; simpl in *.

constructor;
[apply ok_Bg_LF_PPermut with (G:=Gamma::G) |
 apply Mem_permut with (l:=Gamma)]; auto.

apply t_lam_LF with (L:=L);
[apply ok_Bg_LF_PPermut with (G:=Gamma::G) |]; auto.

apply t_appl_LF with (A:=A);
[apply ok_Bg_LF_PPermut with (G:=Gamma::G) | |]; auto.

constructor;
[apply ok_Bg_LF_PPermut with (G:=G & Gamma) |]; auto.
apply PPermutationG_LF with (G:=G & Gamma);
auto.

constructor;
[apply ok_Bg_LF_PPermut with (G:= Gamma :: G) |]; auto.

apply t_unbox_fetch_LF with (G:=G) (Gamma:=Gamma);
[apply ok_Bg_LF_PPermut with (G:= Gamma :: G & Gamma') | |]; auto.
apply PPermutationG_LF with (G:=G & Gamma'); auto.
Qed.

Lemma WeakeningG_LF:
forall G Gamma M A Delta,
  G |= Gamma |- M ::: A ->
  ok_Bg_LF (Gamma::Delta::G) ->
  Delta :: G |= Gamma |- M ::: A.
intros; generalize dependent Delta; induction X;
intros; simpl in *; eauto using types_LF.

apply t_lam_LF with (L:=L \u used_vars_ctx_LF (Gamma:: Delta :: G));
auto; intros;
apply X; auto; apply ok_Bg_LF_fresh; auto;
apply notin_Mem; rewrite notin_union in H2; destruct H2; auto.

constructor;
[apply ok_Bg_LF_PPermut with (G:=Gamma::Delta::G) | rew_app ];
auto. rew_app; PPermut_LF_simpl. apply IHX; apply ok_Bg_LF_nil;
apply ok_Bg_LF_PPermut with (G:=Gamma::Delta::G); auto. PPermut_LF_simpl.

apply t_unbox_fetch_LF with (Gamma:=Gamma) (G:=Delta :: G);
[apply ok_Bg_LF_PPermut with (G:=Gamma'::Delta::G') | |]; auto;
rew_app. transitivityP (Gamma'::Delta::G & Gamma); auto; PPermut_LF_simpl.
apply IHX; eapply ok_Bg_LF_PPermut; eauto.
transitivityP (Gamma'::Delta::G & Gamma); auto; PPermut_LF_simpl.
transitivityP (Delta::G & Gamma); auto.
Qed.

Lemma WeakeningWithinContext_LF:
forall G Gamma M A,
  G |= Gamma |- M ::: A ->
  (forall Delta Delta' G',
    G' & Delta ~=~ G ->
    ok_Bg_LF (Gamma :: G' & (Delta ++ Delta')) ->
    G' & (Delta++Delta') |= Gamma |- M ::: A) *
  (forall Gamma',
    ok_Bg_LF ((Gamma++Gamma')::G) ->
    G |= Gamma ++ Gamma' |- M ::: A).
intros G Gamma M A H;
induction H; split; intros; subst.
constructor; auto.
constructor; auto; rewrite Mem_app_or_eq; left; auto.
apply t_lam_LF with
  (L:=L \u
    (used_vars_ctx_LF (Gamma :: G' & (Delta ++ Delta'))));
auto; intros; eapply X; eauto;
rew_app; apply ok_Bg_LF_fresh; eauto; apply notin_Mem;
rewrite notin_union in H3; destruct H3; auto.
apply t_lam_LF with
  (L:=L \u
    (used_vars_ctx_LF ((Gamma ++ Gamma') :: G)));
auto; intros; eapply X; eauto;
rew_app; apply ok_Bg_LF_fresh; eauto;
rewrite notin_union in H1; destruct H1; auto.
econstructor; eauto; [eapply IHtypes_LF1 | eapply IHtypes_LF2]; eauto.
econstructor; eauto; [eapply IHtypes_LF1 | eapply IHtypes_LF2]; eauto.
econstructor;
[apply ok_Bg_LF_PPermut with (G:=Gamma:: G' & (Delta++Delta')) | ];
auto. PPermut_LF_simpl.
apply PPermutationG_LF with (G:= ((G'& Gamma) & (Delta ++ Delta'))).
eapply IHtypes_LF. transitivityP (G' & Delta & Gamma); auto; PPermut_LF_simpl.
apply ok_Bg_LF_nil; apply ok_Bg_LF_PPermut
  with (G:=Gamma :: G' & (Delta ++ Delta'));
auto. PPermut_LF_simpl.
econstructor;
[apply ok_Bg_LF_PPermut with (G:=(Gamma++Gamma'):: G) | ];
auto. PPermut_LF_simpl.
eapply IHtypes_LF; auto.
apply ok_Bg_LF_nil; apply ok_Bg_LF_PPermut with (G:=(Gamma++Gamma') :: G);
auto. PPermut_LF_simpl.
constructor; eauto; eapply IHtypes_LF; eauto.
constructor; eauto; eapply IHtypes_LF; eauto.
assert (Delta::G'0 ~=~ G & Gamma).
  transitivityP G'; auto; transitivityP (G'0 & Delta); auto; PPermut_LF_simpl.
assert ({Gamma *=* Delta} + {~ Gamma *=* Delta}).
  eapply permut_dec; intros; destruct k; destruct k'; repeat decide equality.
  apply eq_var_dec.
destruct H3.
(* Gamma *=* Delta *)
assert (G'0 ~=~ G).
  apply PPermut_LF_last_rev with (Gamma:=Delta) (Gamma':=Gamma).
  symmetry; auto. transitivityP (Delta::G'0); auto; PPermut_LF_simpl.
apply t_unbox_fetch_LF with (G:=G'0) (Gamma:=Delta++Delta'); auto.
apply ok_Bg_LF_PPermut with (G:=Gamma'::G'0&(Delta++Delta')); auto.
apply PPermutationG_LF with (G:=G & Gamma'); auto.
apply PermutationGamma_LF with (Gamma:=Gamma++Delta'); auto.
eapply IHtypes_LF.
apply ok_Bg_LF_PPermut with (G:=Gamma'::G'0&(Delta++Delta')); auto.
transitivityP ((Gamma++Delta') :: G'0 & Gamma'); auto; PPermut_LF_simpl.
(* ~ Gamma *=* Delta *)
assert (G'0 & Delta ~=~ G & Gamma).
transitivityP (Delta::G'0); auto; PPermut_LF_simpl.
apply PPermut_LF_split_neq_T in H3; [ | intro; elim n; symmetry; auto].
destruct H3 as (t, (H4, H5)). destruct t as (t', tl);
destruct t' as (Gamma0, hd); simpl in *; subst.
apply t_unbox_fetch_LF with (G:=hd++tl & (Delta++Delta')) (Gamma:=Gamma).
apply ok_Bg_LF_PPermut
  with (G:=Gamma' :: (hd & Gamma0 ++ tl) & (Delta ++ Delta'));
auto; rew_app; PPermut_LF_simpl.
apply PPermutationG_LF with (G:=(hd& Gamma' ++ tl) & (Delta ++ Delta')).
eapply IHtypes_LF. rew_app; PPermut_LF_simpl.
apply PPermut_LF_last_rev with (Gamma:=Gamma0) (Gamma':=Gamma); auto.
transitivityP (Delta :: hd & Gamma0 ++ tl); auto; PPermut_LF_simpl.
apply ok_Bg_LF_PPermut
  with (G:=Gamma' :: (hd & Gamma0 ++ tl) & (Delta ++ Delta'));
auto; rew_app; PPermut_LF_simpl.
rew_app; PPermut_LF_simpl.
rew_app; PPermut_LF_simpl.
apply t_unbox_fetch_LF with (G:=G) (Gamma:=Gamma);
[apply ok_Bg_LF_PPermut with (G:=(Gamma'++Gamma'0):: G') | | ];
auto. transitivityP ((Gamma'++Gamma'0) :: G & Gamma); auto; PPermut_LF_simpl.
eapply IHtypes_LF; auto.
apply ok_Bg_LF_PPermut with (G:=(Gamma'++Gamma'0):: G'); auto.
transitivityP ((Gamma' ++ Gamma'0) ::G & Gamma); auto.
Qed.

Lemma WeakeningGamma_LF:
forall G Gamma M A Gamma',
  G |= Gamma |- M ::: A ->
  ok_Bg_LF ((Gamma++Gamma')::G) ->
  G |= Gamma ++ Gamma' |- M ::: A.
intros; eapply WeakeningWithinContext_LF; eauto.
Qed.

Lemma WeakeningWithinG:
forall G Gamma M A Delta Delta',
  G & Delta |= Gamma |- M ::: A ->
  ok_Bg_LF (Gamma :: G & (Delta ++ Delta')) ->
  G & (Delta++Delta')|= Gamma |- M ::: A.
intros; eapply WeakeningWithinContext_LF; eauto.
Qed.

Lemma types_weakened_LF:
forall G G' Gamma M A
  (Ok: ok_Bg_LF (Gamma::G ++ G'))
  (HT: emptyEquiv_LF G ++ G' |= nil |- M ::: A),
  G ++ G'|= Gamma |- M ::: A.
induction G; intros; simpl in *; rew_app in *; auto.
apply WeakeningGamma_LF with (Gamma':=Gamma) in HT; rew_app in *; auto.
assert (a :: G ++ G' ~=~ G ++ a::G') by PPermut_LF_simpl.
apply PPermutationG_LF with (G:=G ++ a:: G'); auto; apply IHG.
apply ok_Bg_LF_PPermut with (G:=Gamma :: a :: G ++ G'); auto.
assert (emptyEquiv_LF G ++ a :: G' ~=~
  (emptyEquiv_LF G ++ G') & (nil ++ a)).
  PPermut_LF_simpl.
apply PPermutationG_LF with (G:=(emptyEquiv_LF G  ++ G') & (nil ++ a)); auto.
eapply WeakeningWithinG.
rew_app.
apply ok_Bg_LF_empty_first in Ok.
assert (nil :: a :: G ++ G' ~=~ (nil :: G) ++ a :: G') by
  PPermut_LF_simpl.
apply ok_Bg_LF_PPermut with (G':=(nil::G)++ a::G') in Ok; auto.
eapply emptyEquiv_LF_ok_Bg_part in Ok; simpl in *; rew_app in *; auto.
assert (emptyEquiv_LF G & nil ++ G' ~=~  nil :: emptyEquiv_LF G ++ G') by
  PPermut_LF_simpl.
apply PPermutationG_LF with (G:= nil::emptyEquiv_LF G ++ G'); auto.
PPermut_LF_simpl.
apply ok_Bg_LF_nil. rew_app. apply emptyEquiv_LF_ok_Bg_part.
apply ok_Bg_LF_PPermut with (a::G ++ G');
try PPermut_LF_simpl.
eapply ok_Bg_LF_weakening; eauto.
Qed.

Lemma subst_t_LF_preserv_types:
forall G Gamma B M N v A
  (H_lc_t: lc_t_LF M)
  (HT: G |= Gamma |- N ::: B),
  (* "inner" substitution *)
  ( forall Gamma0,
    Gamma *=* ((v, A) :: Gamma0) ->
    emptyEquiv_LF G |= nil |- M ::: A ->
    G |= Gamma0 |- [M // fte v] N ::: B)
  *
  (* "outer" substitution *)
  ( forall G0 G' G'' Gamma',
    G ~=~ (G0 & ((v,A)::Gamma')) ->
    G' ~=~ (G0 & Gamma) ->
    G'' ~=~ (G0 & Gamma') ->
    emptyEquiv_LF G' |= nil |- M ::: A ->
    G'' |= Gamma |- [M // fte v] N ::: B).
intros.
generalize dependent v;
generalize dependent A;
generalize dependent M.
induction HT; split; intros;
simpl in *.

(* hyp *)
case_if.
inversion H1; subst.
assert (A = A0) by (eapply ok_Bg_LF_Mem_eq; eauto);
subst; replace G with (G ++ nil) by (rew_app; auto).
apply types_weakened_LF.
apply ok_Bg_LF_permut_first_tail with (C':=Gamma0)(x:=v)(A:=A0) in Ok;
auto; rew_app; auto. rew_app; auto.

constructor.
apply ok_Bg_LF_permut_first_tail with (C':=Gamma0) (x:=v0) (A:=A0) in Ok; eauto.
apply Mem_permut with (l' := (v0, A0) :: Gamma0) in H; eauto;
rewrite Mem_cons_eq in H; destruct H; auto.
inversion H; subst; elim H1; reflexivity.

case_if.
inversion H3; subst.
apply ok_Bg_LF_Mem_contradict with (v:=v) (A:=A) (A':=A0) (G':=G0) (C':=Gamma')
  in Ok; rew_app in *;
contradiction || eauto.
constructor; auto.
apply ok_Bg_LF_PPermut with (G:=(Gamma::G0) & Gamma').
apply ok_Bg_LF_PPermut with (G':=(Gamma::G0 & ((v0, A0)::Gamma'))) in Ok.
apply ok_Bg_LF_permut_no_last with (v:=v0)(A:=A0); auto.
transitivityP (Gamma::G0 & ((v0, A0) :: Gamma')); auto; PPermut_LF_simpl.
transitivityP (Gamma::G0 & Gamma'); auto; PPermut_LF_simpl.

(* lam *)
apply t_lam_LF with (L:=L \u \{v}).
apply ok_Bg_LF_permut_first_tail with (C:=Gamma) (x:=v) (A:=A0); auto.
intros.
rewrite notin_union in H1; rewrite notin_singleton in H1; destruct H1.
unfold open_LF in *;
rewrite <- subst_t_comm_LF; auto.
eapply X; auto;
permut_simpl || rew_app; eauto.

apply t_lam_LF with (L:=L \u \{v}).
apply ok_Bg_LF_PPermut with (G':=Gamma::G0 & ((v,A0)::Gamma')) in Ok.
apply ok_Bg_LF_PPermut with (G:=(Gamma::G0) & Gamma').
apply ok_Bg_LF_permut_no_last with (v:=v) (A:=A0); rew_app; auto.
transitivityP (Gamma::G0 & Gamma'); auto.
transitivityP (Gamma :: G0 & ((v, A0) :: Gamma')); auto.
intros.
rewrite notin_union in H3; rewrite notin_singleton in H3; destruct H3;
unfold open_LF in *;
rewrite <- subst_t_comm_LF; auto.
eapply X with (G0:=G0); eauto;
assert (emptyEquiv_LF G' ~=~
  emptyEquiv_LF (G0 ++ nil & ((v0, A) :: Gamma))).
transitivityP (emptyEquiv_LF(G0 & Gamma)).
  apply PPermut_emptyEquiv_LF; auto.
rew_app; eapply emptyEquiv_LF_last_change; auto.
rew_app in *.
apply PPermutationG_LF with (G:=emptyEquiv_LF G'); auto.

(* appl *)
econstructor;  [ | eapply IHHT1 | eapply IHHT2]; eauto.
apply ok_Bg_LF_permut_first_tail with (C':=Gamma0) (x:=v) (A:=A0) in Ok; eauto.

econstructor.
apply ok_Bg_LF_PPermut with (G:=Gamma:: G0 & Gamma'); auto.
apply ok_Bg_LF_PPermut with (G':=Gamma :: G0 & ((v,A0)::Gamma')) in Ok; auto.

apply ok_Bg_LF_permut_no_last_spec in Ok; rew_app; auto.
eapply IHHT1; eauto.
eapply IHHT2; eauto.

(* box *)
constructor.
apply ok_Bg_LF_permut_no_last with (v:=v) (A:=A0);
apply ok_Bg_LF_PPermut with (G:=G & Gamma); auto.
eapply IHHT; eauto.
rewrite emptyEquiv_LF_rewrite; rewrite emptyEquiv_LF_rewrite_last;
simpl; rew_app. apply PPermutationG_LF with (nil :: emptyEquiv_LF G).
apply WeakeningG_LF; auto.

repeat apply ok_Bg_LF_nil. apply ok_Bg_LF_emptyEquiv.
PPermut_LF_simpl.

constructor.

apply ok_Bg_LF_PPermut with (G:=G0 & Gamma & Gamma').
apply ok_Bg_LF_permut_no_last with (v:=v) (A:=A0).
apply ok_Bg_LF_PPermut with (G:=G & Gamma); auto.
transitivityP (G0 & ((v, A0) :: Gamma') & Gamma); auto; PPermut_LF_simpl.
transitivityP (G0 & Gamma' & Gamma); auto; PPermut_LF_simpl.
eapply IHHT with (G0:=G0 & Gamma) (Gamma':=Gamma'); auto.
transitivityP (G0 & ((v, A0) :: Gamma') & Gamma); auto; PPermut_LF_simpl.
transitivityP (G0 & Gamma' & Gamma); auto; PPermut_LF_simpl.
repeat rewrite emptyEquiv_LF_rewrite;
simpl; rew_app.
apply PPermutationG_LF with (G:=nil::emptyEquiv_LF G').
apply WeakeningG_LF; auto.
repeat apply ok_Bg_LF_nil; apply ok_Bg_LF_emptyEquiv.
transitivityP (nil :: (emptyEquiv_LF(G0 & Gamma))).
  PPermut_LF_simpl. apply PPermut_emptyEquiv_LF. auto.
rewrite emptyEquiv_LF_rewrite_last; simpl;
PPermut_LF_simpl.

(* unbox *)
econstructor; [ | eapply IHHT]; eauto;
apply ok_Bg_LF_permut_first_tail with (C':=Gamma0) (x:=v) (A:=A0) in Ok; eauto.

econstructor.
apply ok_Bg_LF_PPermut with (G:=G0 & Gamma & Gamma').
apply ok_Bg_LF_permut_no_last with (v:=v) (A:=A0).
apply ok_Bg_LF_PPermut with (G:=Gamma :: G); auto.
transitivityP (Gamma::G0 & ((v, A0) :: Gamma')); auto; PPermut_LF_simpl.
transitivityP (Gamma :: G0 & Gamma'); auto; PPermut_LF_simpl.
eapply IHHT; eauto.

(* unbox_fetch *)
apply t_unbox_fetch_LF with (G:=G) (Gamma:=Gamma); auto;
[ apply ok_Bg_LF_permut_no_last_spec with (v:=v) (A:=A0);
  apply ok_Bg_LF_PPermut with (G:= Gamma :: G & Gamma') |
  eapply IHHT; eauto]; auto.
rewrite emptyEquiv_LF_rewrite; simpl.
apply PPermutationG_LF with (emptyEquiv_LF G'); auto.
transitivityP (emptyEquiv_LF (G & Gamma)).
  apply PPermut_emptyEquiv_LF; auto.
  rewrite emptyEquiv_LF_rewrite; simpl; auto.

destruct (permut_dec (var * ty) Gamma ((v,A0)::Gamma'0)).
  intros; destruct k; destruct k'; repeat decide equality.
  apply eq_var_dec.
(* = *)
assert (G ~=~ G0).
  apply PPermut_LF_last_rev with (Gamma:=Gamma)(Gamma':=(v,A0)::Gamma'0);
  auto.
  transitivityP G'; auto.
apply t_unbox_fetch_LF with (G:=G) (Gamma:=Gamma'0).
apply ok_Bg_LF_PPermut with (Gamma' :: G & Gamma'0).
apply ok_Bg_LF_permut_no_last_spec with (v:=v)(A:=A0).
apply ok_Bg_LF_PPermut with (Gamma :: G & Gamma').
auto. transitivityP (((v,A0)::Gamma'0):: G & Gamma'); auto.
PPermut_LF_simpl. rew_app. transitivityP (Gamma' :: Gamma'0 :: G);
PPermut_LF_simpl; auto. transitivityP (Gamma'0 :: Gamma' :: G);
rew_app; PPermut_LF_simpl; auto. rew_app. constructor; auto.
PPermut_LF_simpl.
destruct IHHT with (M0:=M0) (A0:=A0) (v:=v); auto.
apply t; auto. apply PPermutationG_LF with (G:=emptyEquiv_LF G'0);
auto.
transitivityP (emptyEquiv_LF (G0 & Gamma')).
  apply PPermut_emptyEquiv_LF; auto.
apply PPermut_emptyEquiv_LF; auto.
transitivityP (G0 & Gamma'0); auto.
(* <> *)
assert ({ t |
  fst (fst t) *=* (v, A0)::Gamma'0 /\ G = snd (fst t) & fst (fst t) ++ (snd t)})
  as HP.
  apply PPermut_LF_split_neq_T with (Gamma:=Gamma) (G':=G0);
    auto; transitivityP G'; auto.
destruct HP as (t, (HPa, HPb)); destruct t as (t', GT);
destruct t' as (Gamma'', GH); simpl in *.
assert (GH & Gamma'' ++ GT ~=~ GH & ((v, A0)::Gamma'0) ++ GT)
  by PPermut_LF_simpl;
apply t_unbox_fetch_LF with (G:=GH ++ GT & (Gamma'0)) (Gamma:=Gamma).
subst;
apply ok_Bg_LF_PPermut with
  (G:= (((Gamma) :: (GH & (Gamma') ++ GT)) & (Gamma'0))).
apply ok_Bg_LF_permut_no_last_spec with (v:=v)(A:=A0).
apply ok_Bg_LF_PPermut with
  (G:=(Gamma):: (GH & (Gamma'') ++ GT) & (Gamma')); auto.
constructor; auto. PPermut_LF_simpl.
PPermut_LF_simpl.
destruct IHHT with (M0:=M0) (A0:=A0) (v:= v); auto.
eapply t0 with (Gamma'0:=Gamma'0) (G0:=GH ++ GT & Gamma')
  (G':=GH ++ GT & Gamma' & Gamma);subst; try PPermut_LF_simpl.
assert (GH ++ Gamma'' :: GT & Gamma ~=~ G0 & Gamma'').
  transitivityP G'; rew_app in *; auto.
transitivityP  (G0 & ((v, A0) :: Gamma'0)); auto.
assert (GH ++ GT & Gamma ~=~ G0).
  apply PPermut_LF_last_rev_simpl with (a:=Gamma'').
  transitivityP (GH ++ Gamma'' :: GT & Gamma);
    auto; PPermut_LF_simpl.
apply PPermutationG_LF with (G := emptyEquiv_LF G'0); auto.
transitivityP (emptyEquiv_LF (G0 & Gamma')).
apply PPermut_emptyEquiv_LF; auto.
transitivityP (emptyEquiv_LF (GH++GT& Gamma & Gamma'));
apply PPermut_emptyEquiv_LF; PPermut_LF_simpl; auto.
transitivityP ( G0 & Gamma'0); auto.
rew_app; PPermut_LF_simpl; apply PPermut_LF_last_rev_simpl
  with (a:=(v,A0)::Gamma'0). transitivityP G'; auto.
transitivityP (G & Gamma); auto; subst;
  PPermut_LF_simpl.
Qed.

Lemma subst_t_LF_preserv_types_inner:
forall G Gamma A B M N v
  (H_lc_t: lc_t_LF M)
  (HT: G |= (v, A) :: Gamma |- N ::: B)
  (HM: emptyEquiv_LF G |= nil |- M ::: A),
  G |= Gamma |- [M//fte v] N ::: B.
intros; eapply subst_t_LF_preserv_types with (Gamma := (v, A) :: Gamma); eauto.
Qed.

Lemma subst_t_LF_preserv_types_outer:
forall G0 G G' G'' Gamma Gamma' A B M N v
  (H_lc_t: lc_t_LF M)
  (G0G: G ~=~ (G0 & ((v, A) :: Gamma')))
  (G0G': G' ~=~ (G0 & Gamma))
  (G0G'': G'' ~=~ (G0 & Gamma'))
  (HM: emptyEquiv_LF G' |= nil |- M ::: A)
  (HT: G |= Gamma |- N ::: B),
  G'' |= Gamma |- [M // fte v] N ::: B.
intros; eapply subst_t_LF_preserv_types; eauto.
Qed.

Lemma merge_LF_preserv_types:
forall G Gamma M A
  (H: G |= Gamma |- M ::: A),
  (* outer *)
  (forall G0 G1 Gamma0 Delta0,
    G ~=~ Gamma0::Delta0::G0 ->
    G1 ~=~ (Gamma0++Delta0) :: G0 ->
    G1 |= Gamma |- M ::: A) *
  (* new or old - by PermutationGamma_LF *)
  (forall G0 Delta0,
    G ~=~ Delta0 :: G0 ->
    G0 |= Gamma ++ Delta0 |- M ::: A).
intros; induction H; repeat split; intros.
(* hyp *)
constructor; auto.
eapply ok_Bg_LF_concat with (G0:=Gamma::G0) (c1:=Gamma0) (c2:=Delta0)
  (G1:=Gamma::G) (G2:=Gamma::G1);
eauto. transitivityP (Gamma ::Gamma0 :: Delta0 :: G0); auto; PPermut_LF_simpl.
transitivityP (Gamma::(Gamma0 ++ Delta0) :: G0) ; PPermut_LF_simpl.
constructor.
eapply ok_Bg_LF_concat with (G0:=G0) (G1:=Gamma::G); eauto.
rewrite Mem_app_or_eq; left; auto.
(* lam *)
apply t_lam_LF with (L:=L).
eapply ok_Bg_LF_concat with (G0:=Gamma::G0) (G1:=Gamma::G); eauto.
transitivityP (Gamma::Gamma0 :: Delta0 :: G0); auto; PPermut_LF_simpl.
transitivityP (Gamma:: (Gamma0 ++ Delta0) :: G0); auto; PPermut_LF_simpl.
intros; eapply X; eauto.
apply t_lam_LF with (L:=L).
eapply ok_Bg_LF_concat with (G0:=G0) (G1:=Gamma::G); eauto.
intros; eapply X; eauto.
(* appl *)
apply t_appl_LF with (A:=A).
eapply ok_Bg_LF_concat with (G0:=Gamma::G0) (G1:=Gamma::G) (c1:=Gamma0)
  (c2:=Delta0); eauto;
try rewrite H2 || rewrite H1; eauto; PPermut_LF_simpl.
eapply IHtypes_LF1; eauto.
eapply IHtypes_LF2; eauto.
apply t_appl_LF with (A:=A).
eapply ok_Bg_LF_concat with (G0:=G0) (G1:=Gamma::G); eauto.
eapply IHtypes_LF1; eauto.
eapply IHtypes_LF2; eauto.
(* box *)
constructor.
eapply ok_Bg_LF_concat with (G0:=G0 & Gamma) (G1:=G & Gamma)
  (c1:=Gamma0) (c2:=Delta0); eauto.
transitivityP (Gamma ::Gamma0 :: Delta0 :: G0); auto; PPermut_LF_simpl.
transitivityP (Gamma::(Gamma0 ++ Delta0) :: G0) ; PPermut_LF_simpl.
eapply IHtypes_LF with (G0:=G0 & Gamma) (Gamma0:=Gamma0) (Delta0:=Delta0);
eauto.
transitivityP (Gamma ::Gamma0 :: Delta0 :: G0); auto; PPermut_LF_simpl.
transitivityP (Gamma::(Gamma0 ++ Delta0) :: G0) ; PPermut_LF_simpl.
constructor.
eapply ok_Bg_LF_concat with (G0:=G0) (G1:=G & Gamma)
  (c1:=Gamma) (c2:=Delta0); eauto; try PPermut_LF_simpl.
eapply IHtypes_LF with (G0:=G0) (Gamma0:=Gamma)
  (Delta0:=Delta0); eauto.
transitivityP (Delta0 :: G0 & Gamma); auto; PPermut_LF_simpl.
PPermut_LF_simpl.
(* unbox *)
constructor.
eapply ok_Bg_LF_concat with (G0:=Gamma::G0) (G1:=Gamma::G)
  (c1:=Gamma0)(c2:=Delta0); eauto;
try rewrite H0 || rewrite H1; PPermut_LF_simpl.
eapply IHtypes_LF; eauto.
constructor.
eapply ok_Bg_LF_concat with (G0:=G0) (G1:=Gamma::G); eauto.
eapply IHtypes_LF; eauto.
(* Gamma *=* Gamma0 \/ Gamma *=* Gamma1 \/ neither *)
assert (G & Gamma ~=~ Gamma0 :: Delta0 :: G0).
  transitivityP G'; auto.
assert (( prod (Gamma *=* Gamma0) (G ~=~ Delta0::G0)) +
        ( prod (Gamma *=* Delta0)  (G ~=~ Gamma0::G0)) +
        {t | Gamma *=* fst (fst t) /\ G0 = snd (fst t) & fst (fst t) ++ snd t}).
  assert ({Gamma *=* Gamma0} + {~ Gamma *=* Gamma0}).
  apply permut_dec. intros. destruct k; destruct k'; decide equality.
  apply eq_ty_dec. apply eq_var_dec.
  assert ({Gamma *=* Delta0} + {~ Gamma *=* Delta0}).
  apply permut_dec. intros. destruct k; destruct k'; decide equality.
  apply eq_ty_dec. apply eq_var_dec.
  destruct H3. left; left; split; auto.
  apply PPermut_LF_last_rev with (Gamma:=Gamma)
  (Gamma':=Gamma0); auto. transitivityP (Gamma0 :: Delta0 :: G0); auto;
                          PPermut_LF_simpl.
  destruct H4.
  left; right; split; auto. apply PPermut_LF_last_rev with (Gamma:=Gamma)
  (Gamma':=Delta0); auto; transitivityP (Gamma0 :: Delta0 :: G0); auto;
                          PPermut_LF_simpl.
  right.
  assert (G & Gamma ~=~ G0 & Delta0 & Gamma0)
    by (transitivityP (Gamma0 :: Delta0 :: G0); auto;
                          PPermut_LF_simpl).
  apply PPermut_LF_symmetric in H3.
  apply PPermut_LF_split_neq_T in H3; auto.
  destruct H3 as (t, (H3, H4)); destruct t; destruct p0; simpl in *.
  assert (G0 & Delta0 ~=~ (l1 ++ l) & Gamma).
    rewrite H4; PPermut_LF_simpl.
  apply PPermut_LF_split_neq_T in H5; auto.
  destruct H5 as (t, (H5, H6)); destruct t; destruct p0; simpl in *.
  exists (l3, l4, l2); split; auto; symmetry; auto.
  intro nn; symmetry in nn; elim n0; auto.
  intro nn; symmetry in nn; elim n; auto.
destruct H3. destruct s.
destruct p0;
apply t_unbox_fetch_LF with (G:=G0) (Gamma:=Gamma0++Delta0).
eapply ok_Bg_LF_concat
 with (G0:=G0 & Gamma') (G1:=Gamma::G & Gamma'); eauto.
transitivityP (Gamma0::G & Gamma'); auto; PPermut_LF_simpl.
apply PermutationGamma_LF with (Gamma:=Gamma++Delta0); auto.
eapply IHtypes_LF. PPermut_LF_simpl.
transitivityP ((Gamma0 ++ Delta0) :: G0); auto; PPermut_LF_simpl.
destruct p0.
apply t_unbox_fetch_LF with (G:=G0) (Gamma:=Delta0++Gamma0).
eapply ok_Bg_LF_concat
 with (G0:=G0 & Gamma') (G1:=Gamma::G & Gamma'); eauto.
transitivityP (Gamma::Gamma0::G0 & Gamma'); auto; PPermut_LF_simpl.
apply PermutationGamma_LF with (Gamma:=Gamma++Gamma0); auto.
eapply IHtypes_LF. PPermut_LF_simpl.
transitivityP ( (Gamma0 ++ Delta0) :: G0); auto; PPermut_LF_simpl.
destruct s. destruct x; destruct p0; simpl in *. destruct a.
apply t_unbox_fetch_LF with (G:=(Gamma0++Delta0)::l1++l) (Gamma:=l0).
eapply ok_Bg_LF_concat with (G0:=G0 & Gamma') (G1:=Gamma::G & Gamma')
  (c1:=Gamma0) (c2:=Delta0); subst; auto.
transitivityP ((G & Gamma) & Gamma'); [ | PPermut_LF_simpl].
transitivityP ((Gamma0 :: Delta0 :: l1 & l0 ++ l) & Gamma'); PPermut_LF_simpl.
transitivityP G'; auto. transitivityP (Gamma0 :: Delta0 :: l1 & l0 ++ l); auto.
PPermut_LF_simpl.
transitivityP ((Gamma0++Delta0)::l0::l1++l & Gamma'); [PPermut_LF_simpl |].
rew_app; auto.
apply PermutationGamma_LF with (Gamma:=Gamma); auto.
assert (G ~=~ Gamma0::Delta0::l1 ++ l).
  subst; apply PPermut_LF_last_rev with (Gamma:=Gamma) (Gamma':=l0); auto.
  transitivityP (Gamma0 :: Delta0 :: l1 & l0 ++ l); auto; PPermut_LF_simpl.
eapply IHtypes_LF with (Gamma0:=Gamma0) (Delta0:=Delta0) (G0:=l1 ++l & Gamma');
eauto. PPermut_LF_simpl. PPermut_LF_simpl.
transitivityP ((Gamma0 ++ Delta0) :: G0); auto; subst; PPermut_LF_simpl.
assert ((prod (Gamma *=* Delta0)  (G ~=~ G0)) +
        {t | fst (fst t) *=* Gamma /\ G0 = snd(fst t) & fst (fst t) ++ snd t}).
  assert ({Gamma *=* Delta0} + {~ Gamma *=* Delta0}).
  apply permut_dec. intros. destruct k; destruct k'; decide equality.
  apply eq_ty_dec. apply eq_var_dec.
  destruct H1. left; split; auto. apply PPermut_LF_last_rev with (Gamma:=Gamma)
  (Gamma':=Delta0); auto. transitivityP G'; auto. transitivityP (Delta0::G0);
                                                  auto; PPermut_LF_simpl.
  right.
  assert (G & Gamma ~=~ G0 & Delta0).
  transitivityP G'; auto; transitivityP (Delta0::G0); auto; PPermut_LF_simpl.
  apply PPermut_LF_symmetric in H1.
  apply PPermut_LF_split_neq_T in H1; auto.
  intro nn; symmetry in nn; elim n; auto.
destruct H1.
destruct p0. constructor.
eapply ok_Bg_LF_concat with (G0:=G0) (G1:=Gamma::G & Gamma'); eauto.
transitivityP (Gamma'::Delta0::G); auto; PPermut_LF_simpl.
apply PermutationGamma_LF with (Gamma:=Gamma++Gamma').
eapply IHtypes_LF.
transitivityP (Gamma'::G); auto; PPermut_LF_simpl.
permut_simpl; auto.
destruct s as (t, (H3a, H3b)); destruct t; destruct p0; simpl in *.
apply t_unbox_fetch_LF with (G:=l1++l) (Gamma:=Gamma).
eapply ok_Bg_LF_concat with (G0:=Gamma::(l1++l)) (G1:=Gamma::G & Gamma')
  (c1:=Gamma')(c2:=Delta0);
eauto.
transitivityP (G & Gamma & Gamma'); auto. transitivityP (G' & Gamma');
[ | PPermut_LF_simpl]. transitivityP (Delta0 :: G0 & Gamma');
PPermut_LF_simpl. subst; PPermut_LF_simpl.
PPermut_LF_simpl.
eapply IHtypes_LF with (Gamma0:=Gamma') (Delta0:=Delta0) (G0:= l1++l);
subst; try PPermut_LF_simpl. Focus 2. subst; PPermut_LF_simpl.
apply PPermut_LF_last_rev_simpl with Gamma.
transitivityP G'; auto.
transitivityP (Delta0 :: l1 & l0 ++ l); auto.
PPermut_LF_simpl.
Qed.

Lemma merge_LF_preserv_types_outer:
forall G G0 G1 Gamma Gamma0 Delta0 M A,
  G |= Gamma |- M ::: A ->
  G ~=~ Gamma0 :: Delta0 :: G0 ->
  G1 ~=~ (Gamma0 ++ Delta0) :: G0 ->
  G1 |= Gamma |- M ::: A.
intros; eapply merge_LF_preserv_types; eauto.
Qed.

Lemma merge_LF_preserv_types_new:
forall G G0 Gamma Delta M A,
  G |= Gamma |- M ::: A ->
  G ~=~ Delta::G0 ->
  G0 |= Gamma++Delta |- M ::: A.
intros; eapply merge_LF_preserv_types with (G:=G) (Gamma:=Gamma); eauto.
Qed.

Lemma merge_LF_preserv_types_old:
forall G G0 Gamma Delta M A,
  G |= Delta |- M ::: A ->
  G ~=~ Gamma::G0 ->
  G0 |= Gamma++Delta |- M ::: A.
intros;
apply PermutationGamma_LF with (Gamma:=Delta++Gamma).
eapply merge_LF_preserv_types; eauto.
auto.
Qed.

Lemma Progress_LF:
forall G M A
  (H_lc_t: lc_t_LF M)
  (HT: emptyEquiv_LF G |= nil |- M ::: A),
  value_LF M + (sigT (fun x => M |-> x)).
(* sigT (fun x => .. ) = { N & M |-> N}, but in tlc & is used for lists... *)
intros;
remember (@nil (var * ty)) as Ctx;
generalize dependent Ctx;
generalize dependent A;
generalize dependent G;
induction M; intros; eauto using value_LF;
inversion HeqCtx; subst.
(* hyp *)
inversion HT; subst;
rewrite Mem_nil_eq in H3;
contradiction.
(* appl *)
right; inversion HT; subst;
edestruct IHM1 with (A := A0 ---> A); eauto;
[inversion H_lc_t; subst; auto |
 inversion v; subst; inversion H4; subst |
 destruct s];
eexists; constructor; eauto;
inversion H_lc_t; auto; inversion H5; auto.
(* unbox *)
right; inversion HT; subst.
edestruct IHM with (A := [*]A); eauto; try inversion H_lc_t; auto; eauto.
inversion v; subst; inversion H3; subst; eexists; constructor; eauto;
inversion H_lc_t; inversion H2; auto.
destruct s; eexists; constructor; eauto;
inversion H_lc_t; auto.
assert (Gamma = nil) by
  ( apply emptyEquiv_LF_permut_empty with
    (G:= G0 & Gamma) (G':=G); auto;
    apply Mem_last); subst.
destruct IHM with (A := [*]A)
                  (Ctx := (@nil (var * ty)))
                  (G := G0 & nil);
eauto.
inversion H_lc_t; auto.
assert (emptyEquiv_LF (G0 & nil) = G0 & nil)
  by (eapply emptyEquiv_LF_PPermut_eq; eauto); rewrite H0; auto.
inversion v; subst; inversion H1; subst;
eexists; constructor; eauto; inversion H_lc_t; inversion H3; auto.
destruct s; eexists; constructor; eauto;
inversion H_lc_t; auto.
Qed.

Lemma Preservation_LF:
forall G M N A
  (HT: emptyEquiv_LF G |= nil |- M ::: A)
  (HS: M |-> N),
  emptyEquiv_LF G |= nil |- N ::: A.
intros; generalize dependent N.
remember (emptyEquiv_LF G) as G';
remember (@nil (var*ty)) as Gamma.
generalize dependent G.
induction HT; intros;
inversion HS; subst;
try (econstructor; eauto).

(* appl_lam *)
inversion HT1; subst;
unfold open_LF in *;
assert { v | v \notin L \u used_vars_te_LF M0} as HF by apply Fresh;
destruct HF as (v_fresh);
rewrite subst_t_neutral_free_LF with (v:=v_fresh);
[ eapply subst_t_LF_preserv_types_inner; eauto |
  rewrite notin_union in n; destruct n]; auto;
rewrite <- double_emptyEquiv_LF; auto.

(* unbox_box *)
inversion HT; subst;
replace (@nil (var * ty)) with (nil ++ (@nil (prod var ty)))
  by (rew_app; auto);
apply merge_LF_preserv_types_old with (G:=emptyEquiv_LF G0 & nil);
rew_app; auto.
transitivityP (emptyEquiv_LF (G0&nil)).
  rewrite emptyEquiv_LF_rewrite; auto.
  transitivityP (emptyEquiv_LF (nil :: G0)); auto.

apply PPermut_emptyEquiv_LF; PPermut_LF_simpl.

inversion HT; subst;
replace (@nil (var * ty)) with (nil ++ (@nil (prod var ty)))
  by (rew_app; auto);
apply merge_LF_preserv_types_old with (G:=G & nil & Gamma);
auto. transitivityP (nil :: G & Gamma); auto.
apply ok_Bg_LF_nil; apply ok_Bg_LF_empty.
assert (Gamma = nil).
  apply emptyEquiv_LF_PPermut in p; auto.
subst. replace (emptyEquiv_LF G0) with (G & nil).
apply IHHT with (G0:=G0); auto.
apply emptyEquiv_LF_PPermut_equal; auto.
apply emptyEquiv_LF_PPermut_equal; auto.
Qed.

Lemma value_no_step:
forall M,
  value_LF M ->
  forall N , M |-> N ->
             False.
induction M; intros;
try inversion H; subst;
inversion H0; subst;
rewrite IHM; eauto.
Qed.

Lemma lc_t_step_LF:
forall M N,
  lc_t_LF M ->
  M |-> N ->
  lc_t_LF N.
induction M; intros; inversion H0; inversion H; subst; try constructor; eauto.
apply lc_t_subst_t_LF_bound; auto.
eapply IHM1; eauto.
eapply IHM; eauto.
Qed.

Lemma types_LF_lc_t_LF:
forall G Gamma M A,
  G |= Gamma |- M ::: A -> lc_t_LF M.
intros; induction X; constructor; try apply IHHT;
unfold open_LF in *; auto.
assert { x |  x \notin L} by apply Fresh; destruct H1;
assert (x \notin L) by auto;
specialize H0 with x; apply H0 in H1;
apply lc_t_n_LF_subst_t in H0; auto; constructor.
Qed.


(* Syncer spec *)

From iris.program_logic Require Export weakestpre hoare.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import proofmode notation.

Section sync.
  Context `{!heapG Σ} (N : namespace).

  (* TODO: We could get rid of the x, and hard-code a unit. That would
     be no loss in expressiveness, but probably more annoying to apply.
     How much more annoying? And how much to we gain in terms of things
     becoming easier to prove? *)
  Definition synced R (f f': val) :=
    (□ ∀ P Q (x: val), {{ R ∗ P }} f x {{ v, R ∗ Q v }} →
                       {{ P }} f' x {{ Q }})%I.

  (* Notice that `s f` is *unconditionally safe* to execute, and only
     when executing the returned f' we have to provide a spec for f.
     This is crucial. *)
  (* TODO: Use our usual style with a generic post-condition. *)
  Definition is_syncer (R: iProp Σ) (s: val) :=
    (□ ∀ (f : val), WP s f {{ f', synced R f f' }})%I.

  Definition mk_syncer_spec (mk_syncer: val) :=
    ∀ (R: iProp Σ),
      {{{ R }}} mk_syncer #() {{{ s, RET s; is_syncer R s }}}.
End sync.


(* mell_msetoid example file for yalla library *)

(* output in Type *)

(** * Example of a concrete use of the yalla library: multi-set based MELL up to an equivalence relation *)

Require Import CMorphisms.

Require Import Injective.
Require Import fmsetoidlist_Type.
Require Import List_more.
Require Import Permutation_Type_more.

(** ** 0. load the [ll] library *)

Require ll_cut.

(** ** 1. define formulas *)

Inductive formula : Set :=
| var : formulas.Atom -> formula
| covar : formulas.Atom -> formula
| one : formula
| bot : formula
| tens : formula -> formula -> formula
| parr : formula -> formula -> formula
| oc : formula -> formula
| wn : formula -> formula.

Fixpoint dual A :=
match A with
| var x     => covar x
| covar x   => var x
| one       => bot
| bot       => one
| tens A B  => parr (dual B) (dual A)
| parr A B  => tens (dual B) (dual A)
| oc A      => wn (dual A)
| wn A      => oc (dual A)
end.

(** ** 2. define embedding into [formulas.formula] *)

Fixpoint mell2ll A :=
match A with
| var x    => formulas.var x
| covar x  => formulas.covar x
| one      => formulas.one
| bot      => formulas.bot
| tens A B => formulas.tens (mell2ll A) (mell2ll B)
| parr A B => formulas.parr (mell2ll A) (mell2ll B)
| oc A     => formulas.oc (mell2ll A)
| wn A     => formulas.wn (mell2ll A)
end.

Lemma mell2ll_inj : injective mell2ll.
Proof with try reflexivity.
intros A.
induction A ; intros B Heq ;
  destruct B ; inversion Heq ;
  try apply IHA in H0 ;
  try apply IHA1 in H0 ;
  try apply IHA2 in H1 ; subst...
Qed.

Lemma mell2ll_dual : forall A, formulas.dual (mell2ll A) = mell2ll (dual A).
Proof.
induction A ; simpl ;
  rewrite ? IHA ;
  rewrite ? IHA1 ;
  rewrite ? IHA2 ;
  reflexivity.
Qed.

Lemma mell2ll_map_wn : forall l,
  map mell2ll (map wn l) = map formulas.wn (map mell2ll l).
Proof with try reflexivity.
induction l...
simpl ; rewrite IHl...
Qed.

Lemma mell2ll_map_wn_inv : forall l1 l2,
  map formulas.wn l1 = map mell2ll l2 ->
    exists l2', l2 = map wn l2' /\ l1 = map mell2ll l2'.
Proof with try assumption ; try reflexivity.
induction l1 ; intros l2 Heq ;
  destruct l2 ; inversion Heq...
- exists nil ; split...
- apply IHl1 in H1.
  destruct f ; inversion H0 ; subst.
  destruct H1 as (l2' & Heq1 & H1) ; subst.
  exists (f :: l2') ; split...
Qed.

(** *** 2bis. sequents *)

Instance fmsetoid_formula : FinMultisetoid (list _) formula :=
  FMoidConstr_list formula.

(** ** 3. define proofs *)

Inductive mell : list formula -> Prop :=
| ax_r : forall X, mell (add (covar X) (add (var X) empty))
| ex_r : forall m1 m2, mell m1 -> meq m1 m2 -> mell m2
| one_r : mell (add one empty)
| bot_r : forall l, mell l -> mell (add bot l)
| tens_r : forall A B l1 l2,
              mell (add A l1) -> mell (add B l2) ->
              mell (add (tens A B) (sum l1 l2))
| parr_r : forall A B l,
             mell (add A (add B l)) ->
             mell (add (parr A B) l)
| oc_r : forall A l,
           mell (add A (fmmap wn l)) ->
           mell (add (oc A) (fmmap wn l))
| de_r : forall A l,
           mell (add A l) ->
           mell (add (wn A) l)
| wk_r : forall A l,
           mell l ->
           mell (add (wn A) l)
| co_r : forall A l,
           mell (add (wn A) (add (wn A) l)) ->
           mell (add (wn A) l).

Instance mell_meq : Proper (meq ==> iff) mell.
Proof.
intros m1 m2 Heq.
split ; intros Hmell.
- apply ex_r in Heq ; assumption.
- symmetry in Heq.
  apply ex_r in Heq ; assumption.
Qed.

(** ** 4. characterize corresponding [ll] fragment *)

(*
Definition mell_fragment A := exists B, A = mell2ll B.

Lemma mell_is_fragment : ll_prop.fragment mell_fragment.
Proof.
intros A HfA B Hsf.
induction Hsf ;
  try (apply IHHsf ;
       destruct HfA as [B0 HfA] ;
       destruct B0 ; inversion HfA ; subst ;
       eexists ; reflexivity).
assumption.
Qed.
*)

(** cut / axioms / mix0 / mix2 / permutation *)
Definition pfrag_mell := ll_def.mk_pfrag false ll_def.NoAxioms false false true.
(*                                       cut   axioms          mix0  mix2  perm  *)

(** ** 5. prove equivalence of proof predicates *)

Lemma mell2mellfrag : forall m,
  mell m -> inhabited (ll_def.ll pfrag_mell (map mell2ll (elts m))).
Proof with try eassumption ; try reflexivity.
intros l pi.
induction pi ;
  try destruct IHpi as [IHpi] ;
  try destruct IHpi1 as [IHpi1] ;
  try destruct IHpi2 as [IHpi2] ;
  constructor ; simpl ; rewrite ? map_app ;
  try (now (constructor ; eassumption)).
- apply meq_perm in X.
  eapply ll_def.ex_r...
  apply Permutation_Type_map...
- eapply ll_def.ex_r.
  + apply ll_def.tens_r.
    * assert (Helt := Permutation_Type_map mell2ll (elts_add A l1)).
      apply (ll_def.ex_r _ _ _ IHpi1) in Helt.
      simpl in Helt...
    * assert (Helt := Permutation_Type_map mell2ll (elts_add B l2)).
      apply (ll_def.ex_r _ _ _ IHpi2) in Helt.
      simpl in Helt...
  + apply Permutation_Type_cons...
    rewrite <- map_app.
    apply Permutation_Type_map.
    unfold sum ; unfold list2fm.
    simpl ; rewrite fold_id.
    apply Permutation_Type_app_comm.
- unfold fmmap.
  unfold list2fm.
  unfold add.
  unfold empty.
  simpl.
  rewrite fold_id.
  rewrite mell2ll_map_wn.
  unfold elts in IHpi.
  unfold add in IHpi.
  unfold fmmap in IHpi.
  unfold list2fm in IHpi.
  simpl in IHpi.
  rewrite fold_id in IHpi.
  rewrite mell2ll_map_wn in IHpi.
  apply ll_def.oc_r...
Qed.

Lemma mellfrag2mell : forall m,
  ll_def.ll pfrag_mell (map mell2ll (elts m)) -> mell m.
Proof with try eassumption ; try reflexivity.
intros m pi.
remember (map mell2ll (elts m)) as l.
revert m Heql ; induction pi ; intros m Heql ;
  try (now (destruct m ; inversion Heql ;
            destruct f ; inversion H0)) ;
  try (now inversion f).
- destruct m ; inversion Heql.
  destruct m ; inversion H1.
  destruct f ; inversion H0 ; subst.
  destruct f0 ; inversion H2 ; subst.
  destruct m ; inversion H3.
  apply ax_r.
- subst.
  simpl in p.
  apply Permutation_Type_map_inv in p.
  destruct p as [l' Heq HP] ; subst.
  eapply ex_r.
  + apply IHpi...
  + symmetry...
- decomp_map Heql ; subst.
  apply mell2ll_map_wn_inv in Heql3 ; destruct Heql3 as (l & Heq1 & Heq2) ; subst.
  apply Permutation_Type_map_inv in p ; destruct p as [l' Heq HP] ; subst.
  simpl in Heql ; unfold id in Heql ; subst.
  eapply ex_r ;
    [ apply IHpi ; rewrite <- mell2ll_map_wn ; rewrite <- ? map_app | ]...
  apply Permutation_Type_app_head.
  apply Permutation_Type_app_tail.
  symmetry in HP ; apply Permutation_Type_map...
- destruct m ; inversion Heql.
  destruct f ; inversion H0 ; subst.
  destruct m ; inversion H1.
  apply one_r.
- destruct m ; inversion Heql.
  destruct f ; inversion H0 ; subst.
  apply bot_r.
  apply IHpi...
- destruct m ; inversion Heql.
  destruct f ; inversion H0 ; subst.
  assert (Heq := H1).
  decomp_map H1 ; subst.
  apply (ex_r (add (tens f1 f2) (sum l3 l0))).
  + apply tens_r.
    * apply IHpi1...
    * apply IHpi2...
  + unfold sum.
    unfold list2fm.
    unfold add.
    simpl.
    apply Permutation_Type_cons...
    rewrite fold_id.
    apply Permutation_Type_app_comm.
- destruct m ; inversion Heql.
  destruct f ; inversion H0 ; subst.
  apply parr_r.
  apply IHpi...
- destruct m ; inversion Heql.
  destruct f ; inversion H0 ; subst.
  apply mell2ll_map_wn_inv in H1.
  destruct H1 as (m' & Heq1 & Heq2) ; subst.
  replace (oc f :: map wn m')
     with (add (oc f) (fmmap wn m')).
  + apply oc_r.
    apply IHpi.
    unfold add.
    unfold fmmap.
    unfold list2fm.
    simpl.
    rewrite fold_id.
    rewrite mell2ll_map_wn...
  + unfold fmmap.
    unfold list2fm.
    unfold add.
    simpl.
    rewrite fold_id...
- destruct m ; inversion Heql.
  destruct f ; inversion H0 ; subst.
  apply de_r.
  apply IHpi...
- destruct m ; inversion Heql.
  destruct f ; inversion H0 ; subst.
  apply wk_r.
  apply IHpi...
- destruct m ; inversion Heql.
  destruct f ; inversion H0 ; subst.
  apply co_r.
  apply IHpi.
  change (formulas.wn (mell2ll f)) with (mell2ll (wn f))...
- inversion a.
Qed.

(** ** 6. import properties *)

(** *** axiom expansion *)

Lemma ax_gen_r : forall A, mell (add (dual A) (add A empty)).
Proof.
intro A.
apply mellfrag2mell.
eapply ll_def.ex_r ; [ apply ll_def.ax_exp | ].
rewrite mell2ll_dual.
apply Permutation_Type_swap.
Qed.

(** *** cut admissibility *)

Lemma cut_r : forall A m1 m2,
  mell (add A m1) -> mell (add (dual A) m2) -> mell (sum m1 m2).
Proof with try eassumption.
intros A m1 m2 pi1 pi2.
apply mell2mellfrag in pi1 ; destruct pi1 as [pi1] ; simpl in pi1.
apply mell2mellfrag in pi2 ; destruct pi2 as [pi2] ; simpl in pi2.
apply mellfrag2mell.
eapply ll_def.ex_r ; [ | apply Permutation_Type_map ; symmetry ; apply elts_sum ].
rewrite map_app.
eapply ll_cut.cut_r_axfree...
- intros a ; destruct a.
- assert (Permutation_Type (map mell2ll (elts (add (dual A) m2)))
                           (map mell2ll (dual A :: elts m2)))
  as Helt2 by (apply Permutation_Type_map ; apply elts_add).
  simpl in Helt2 ; rewrite <- mell2ll_dual in Helt2.
  rewrite <- mell2ll_dual in pi2.
  eapply ll_def.ex_r ; [ | apply Helt2 ]...
Qed.