Require Import
        CertifiedExtraction.Extraction.Internal
        CertifiedExtraction.Extraction.External.Core
        CertifiedExtraction.Extraction.External.Loops
        CertifiedExtraction.Extraction.External.GenericADTMethods
        CertifiedExtraction.Extraction.External.FacadeADTs.

Ltac loop_unify_with_nil_t :=
  match goal with
  | [  |- context[Cons (T := list ?A) _ (ret ?val) _] ] => is_evar val; unify val (@nil A)
  end.

Ltac loop_t :=
  repeat (intros || unfold Fold || solve [PreconditionSet_t; Lifted_t] || compile_do_side_conditions || clean_DropName_in_ProgOk || rewrite Propagate_ret || eapply CompileSeq || eauto 2).

Lemma CompileLoopBase :
  forall `{FacadeWrapper (Value av) A} `{FacadeWrapper (Value av) A'} `{FacadeWrapper av (list A)}
    lst init vhead vtest vlst vret fpop fempty fdealloc facadeBody env (ext: StringMap.t (Value av)) tenv (f: Comp A' -> A -> Comp A'),
    GLabelMap.MapsTo fpop (Axiomatic (List_pop A)) env ->
    GLabelMap.MapsTo fempty (Axiomatic (List_empty A)) env ->
    GLabelMap.MapsTo fdealloc (Axiomatic (FacadeImplementationOfDestructor (list A))) env ->
    PreconditionSet tenv ext [[[vhead; vtest; vlst; vret]]] ->
    (forall head (acc: Comp A') (s: list A),
        {{ [[`vret ~~> acc as _]] :: [[`vhead ->> head as _]] :: tenv }}
          facadeBody
        {{ [[`vret ~~> (f acc head) as _]] :: tenv }} ∪
        {{ [vtest |> wrap (bool2w false)] :: [vlst |> wrap s] :: ext }} // env) ->
    {{ [[`vret ~~> init as _]] :: [[`vlst ->> lst as _]] :: tenv }}
      (Seq (Fold vhead vtest vlst fpop fempty facadeBody) (Call (DummyArgument vtest) fdealloc (vlst :: nil)))
    {{ [[`vret ~~> (fold_left f lst init) as _]] :: tenv }} ∪ {{ ext }} // env.
Proof.
  unfold DummyArgument; loop_t.

  rewrite TelEq_swap by loop_t;
    eapply CompileCallEmpty_spec; loop_t.

  2:eapply CompileCallFacadeImplementationOfDestructor; loop_t.

  loop_unify_with_nil_t.

  loop_t.
  generalize dependent init;
  induction lst; loop_t.

  move_to_front vtest;
  apply CompileWhileFalse_Loop; loop_t.

  eapply CompileWhileTrue; [ loop_t.. | ].

  apply generalized @CompileCallPop; loop_t.

  move_to_front vlst; apply ProgOk_Chomp_Some; loop_t.
  move_to_front vtest; apply ProgOk_Chomp_Some; loop_t.
  computes_to_inv; subst; defunctionalize_evar; eauto.

  rewrite TelEq_swap; eauto.
  apply CompileCallEmpty_spec; loop_t.

  loop_t.
Qed.

Lemma CompileLoop :
  forall `{FacadeWrapper (Value av) A} `{FacadeWrapper (Value av) A'} `{FacadeWrapper av (list A)}
    lst init vhead vtest vlst vret fpop fempty fdealloc facadeBody facadeConclude
    env (ext: StringMap.t (Value av)) tenv tenv' (f: Comp A' -> A -> Comp A'),
    GLabelMap.MapsTo fpop (Axiomatic (List_pop A)) env ->
    GLabelMap.MapsTo fempty (Axiomatic (List_empty A)) env ->
    GLabelMap.MapsTo fdealloc (Axiomatic (FacadeImplementationOfDestructor (list A))) env ->
    PreconditionSet tenv ext [[[vhead; vtest; vlst; vret]]] ->
    {{ [[`vret ~~> (fold_left f lst init) as _]] :: tenv }}
      facadeConclude
    {{ [[`vret ~~> (fold_left f lst init) as _]] :: tenv' }} ∪ {{ ext }} // env ->
    (forall head (acc: Comp A') (s: list A),
        {{ [[`vret ~~> acc as _]] :: [[`vhead ->> head as _]] :: tenv }}
          facadeBody
        {{ [[`vret ~~> (f acc head) as _]] :: tenv }} ∪
        {{ [vtest |> wrap (bool2w false)] :: [vlst |> wrap s] :: ext }} // env) ->
    {{ [[`vret ~~> init as _]] :: [[`vlst ->> lst as _]] :: tenv }}
      (Seq (Seq (Fold vhead vtest vlst fpop fempty facadeBody) (Call (DummyArgument vtest) fdealloc (vlst :: nil))) facadeConclude)
    {{ [[`vret ~~> (fold_left f lst init) as _]] :: tenv' }} ∪ {{ ext }} // env.
Proof.
  eauto using @CompileSeq, @CompileLoopBase.
Qed.

Lemma CompileLoopAlloc :
  forall `{FacadeWrapper (Value av) A} `{FacadeWrapper (Value av) A'} `{FacadeWrapper av (list A)}
    lst init vhead vtest vlst vret fpop fempty fdealloc facadeInit facadeBody facadeConclude
    env (ext: StringMap.t (Value av)) tenv tenv' (f: Comp A' -> A -> Comp A'),
    GLabelMap.MapsTo fpop (Axiomatic (List_pop A)) env ->
    GLabelMap.MapsTo fempty (Axiomatic (List_empty A)) env ->
    GLabelMap.MapsTo fdealloc (Axiomatic (FacadeImplementationOfDestructor (list A))) env ->
    PreconditionSet tenv ext [[[vhead; vtest; vlst; vret]]] ->
    {{ [[`vlst ->> lst as _]] :: tenv }}
      facadeInit
    {{ [[`vret ~~> init as _]] :: [[`vlst ->> lst as _]] :: tenv }} ∪ {{ ext }} // env ->
    {{ [[`vret ~~> (fold_left f lst init) as _]] :: tenv }}
      facadeConclude
    {{ [[`vret ~~> (fold_left f lst init) as _]] :: tenv' }} ∪ {{ ext }} // env ->
    (forall head (acc: Comp A') (s: list A),
        {{ [[`vret ~~> acc as _]] :: [[`vhead ->> head as _]] :: tenv }}
          facadeBody
        {{ [[`vret ~~> (f acc head) as _]] :: tenv }} ∪
        {{ [vtest |> wrap (bool2w false)] :: [vlst |> wrap s] :: ext }} // env) ->
    {{ [[`vlst ->> lst as _]] :: tenv }}
      (Seq facadeInit (Seq (Seq (Fold vhead vtest vlst fpop fempty facadeBody) (Call (DummyArgument vtest) fdealloc (vlst :: nil))) facadeConclude))
    {{ [[`vret ~~> (fold_left f lst init) as _]] :: tenv' }} ∪ {{ ext }} // env.
Proof.
  eauto using @CompileSeq, @CompileLoop.
Qed.

Definition revmap {A B} f := fun seq => @map A B f (rev seq).

Open Scope list_scope.

Lemma revmap_fold_helper:
  forall (A A' : Type) (f : A -> A') (a : A) (vv : list A) (base : list A'),
    revmap f (a :: vv) ++ base = revmap f vv ++ f a :: base.
Proof.
  unfold revmap; intros; simpl.
  rewrite map_rev.
  rewrite map_app.
  simpl.
  rewrite <- app_assoc.
  simpl.
  rewrite <- map_rev.
  reflexivity.
Qed.

Lemma revmap_fold_generalized :
  forall {A B} (f: A -> B) (seq: list A) (base: list B),
    fold_left (fun acc elem => f elem :: acc) seq base = (@revmap A B f seq) ++ base.
Proof.
  induction seq; simpl; intros.
  - reflexivity.
  - rewrite revmap_fold_helper; eauto.
Qed.

Lemma revmap_fold :
  forall {A B} (f: A -> B) (seq: list A),
    fold_left (fun acc elem => f elem :: acc) seq nil = @revmap A B f seq.
Proof.
  intros.
  rewrite <- (app_nil_r (revmap f seq)).
  apply revmap_fold_generalized.
Qed.

Lemma revmap_fold_comp_generalized :
  forall {A B} (f: A -> B) (seq: list A) base,
    Monad.equiv
      (fold_left (fun cacc elem => (acc <- cacc; ret (f elem :: acc))%comp) seq base)
      ( b <- base;
        ret ((@revmap A B f seq) ++ b)).
Proof.
  intros; etransitivity.
  2: apply Monad.computes_under_bind; intros; rewrite <- revmap_fold_generalized; apply SetoidMorphisms.equiv_refl.

  generalize dependent base; induction seq; simpl;
  [ | setoid_rewrite IHseq ];
  split; intros; computes_to_inv; subst; eauto using BindComputes.
Qed.

Lemma revmap_fold_comp :
  forall {A B} (f: A -> B) (seq: list A),
    Monad.equiv
      (fold_left (fun cacc elem => (acc <- cacc; ret (f elem :: acc))%comp) seq (ret nil))
      (ret (@revmap A B f seq)).
Proof.
  intros.
  rewrite <- (app_nil_r (revmap f seq)).
  rewrite revmap_fold_comp_generalized.
  split; intros; computes_to_inv; subst; eauto using BindComputes.
Qed.

Lemma CompileMap_ADT :
  forall {av A A'} `{FacadeWrapper av (list A)} `{FacadeWrapper av (list A')} `{FacadeWrapper (Value av) A} `{FacadeWrapper av A'}
    (lst: list A) vhead vhead' vtest vlst vret vtmp fpop fempty falloc fdealloc fcons facadeBody facadeCoda env (ext: StringMap.t (Value av)) tenv tenv' (f: A -> A'),
    GLabelMap.MapsTo fpop (Axiomatic (List_pop A)) env ->
    GLabelMap.MapsTo fempty (Axiomatic (List_empty A)) env ->
    GLabelMap.MapsTo falloc (Axiomatic (FacadeImplementationOfConstructor (list A') nil)) env ->
    GLabelMap.MapsTo fdealloc (Axiomatic (FacadeImplementationOfDestructor (list A))) env ->
    GLabelMap.MapsTo fcons (Axiomatic (FacadeImplementationOfMutation_ADT A' (list A') cons)) env ->
    (* GLabelMap.MapsTo fdealloc_one (Axiomatic (FacadeImplementationOfDestructor A)) env -> *)
    PreconditionSet tenv ext [[[vhead; vhead'; vtest; vlst; vret; vtmp]]] ->
    {{ [[`vret ->> (revmap f lst) as _]] :: tenv }}
      facadeCoda
    {{ [[`vret ->> (revmap f lst) as _]] :: tenv' }} ∪ {{ ext }} // env ->
    (forall head (s: list A) (s': list A'),
        {{ [[`vhead ->> head as _]] :: tenv }}
          facadeBody
        {{ [[`vhead' ->> f head as _]] :: tenv }} ∪
        {{ [vret |> wrap s'] :: [vtest |> wrap (bool2w false)] :: [vlst |> wrap s] :: ext }} // env) ->
    {{ [[`vlst ->> lst as _]] :: tenv }}
      (Seq
         (Call vret falloc nil)
         (Seq
            (Seq
               (Fold vhead vtest vlst fpop fempty
                     (Seq facadeBody
                          (Call vtmp fcons (vret :: vhead' :: nil))))
               (Call vtest fdealloc (vlst :: nil)))
            facadeCoda))
    {{ [[`vret ->> (revmap f lst) as _]] :: tenv' }} ∪ {{ ext }} // env.
Proof.
  intros.
  setoid_rewrite <- revmap_fold_comp.
  apply CompileLoopAlloc; eauto.
  PreconditionSet_t; eauto.
  eapply (CompileCallFacadeImplementationOfConstructor (A := list A')); loop_t.
  setoid_rewrite revmap_fold_comp; eassumption.
  intros.
  rewrite SameValues_Fiat_Bind_TelEq.
  move_to_front vret.
  apply miniChomp'; intros.
  hoare.
  apply ProgOk_Chomp_Some; loop_t; defunctionalize_evar; eauto.
  apply CompileCallFacadeImplementationOfMutation_ADT; compile_do_side_conditions.
Qed.

Lemma CompileMap_SCA :
  forall {av A} `{FacadeWrapper av (list A)} `{FacadeWrapper av (list W)} `{FacadeWrapper (Value av) A}
    (lst: list A) vhead vhead' vtest vlst vret vtmp fpop fempty falloc fdealloc fcons facadeBody facadeCoda env (ext: StringMap.t (Value av)) tenv tenv' (f: A -> W),
    GLabelMap.MapsTo fpop (Axiomatic (List_pop A)) env ->
    GLabelMap.MapsTo fempty (Axiomatic (List_empty A)) env ->
    GLabelMap.MapsTo falloc (Axiomatic (FacadeImplementationOfConstructor (list W) nil)) env ->
    GLabelMap.MapsTo fdealloc (Axiomatic (FacadeImplementationOfDestructor (list A))) env ->
    GLabelMap.MapsTo fcons (Axiomatic (FacadeImplementationOfMutation_SCA (list W) cons)) env ->
    (* GLabelMap.MapsTo fdealloc_one (Axiomatic (FacadeImplementationOfDestructor A)) env -> *)
    PreconditionSet tenv ext [[[vhead; vhead'; vtest; vlst; vret; vtmp]]] ->
    {{ [[`vret ->> (revmap f lst) as _]] :: tenv }}
      facadeCoda
    {{ [[`vret ->> (revmap f lst) as _]] :: tenv' }} ∪ {{ ext }} // env ->
    (forall head (s: list A) (s': list W),
        {{ [[`vhead ->> head as _]] :: tenv }}
          facadeBody
        {{ [[`vhead' ->> f head as _]] :: tenv }} ∪
        {{ [vret |> wrap s'] :: [vtest |> wrap (bool2w false)] :: [vlst |> wrap s] :: ext }} // env) ->
    {{ [[`vlst ->> lst as _]] :: tenv }}
      (Seq
         (Call vret falloc nil)
         (Seq
            (Seq
               (Fold vhead vtest vlst fpop fempty
                     (Seq facadeBody
                          (Call vtmp fcons (vret :: vhead' :: nil))))
               (Call vtest fdealloc (vlst :: nil)))
            facadeCoda))
    {{ [[`vret ->> (revmap f lst) as _]] :: tenv' }} ∪ {{ ext }} // env.
Proof.
  intros.
  setoid_rewrite <- revmap_fold_comp.
  apply CompileLoopAlloc; eauto.
  PreconditionSet_t; eauto.
  eapply (CompileCallFacadeImplementationOfConstructor (A := list W)); loop_t.
  setoid_rewrite revmap_fold_comp; eassumption.
  intros.
  rewrite SameValues_Fiat_Bind_TelEq.
  move_to_front vret.
  apply miniChomp'; intros.
  hoare.
  apply ProgOk_Chomp_Some; loop_t; defunctionalize_evar; eauto.
  apply CompileCallFacadeImplementationOfMutation_SCA; unfold DummyArgument; compile_do_side_conditions.
Qed.

(* NOTE: Could prove lemma for un-reved map using temp variable *)

Lemma ret_fold_fold_ret_lemma :
  forall {TElem TAcc} (f: TAcc -> TElem -> TAcc) lst (init: TAcc) init_comp,
    Monad.equiv (ret init) init_comp ->
    Monad.equiv (ret (fold_left f lst init))
                (fold_left (fun (acc: Comp TAcc) x => (a <- acc; ret (f a x))%comp) lst init_comp).
Proof.
  induction lst; simpl; intros.
  - trivial.
  - etransitivity; [ apply IHlst | reflexivity ].
    unfold Monad.equiv in *; repeat (cleanup_pure || computes_to_inv || subst).
    + eapply BindComputes; try rewrite <- H; apply ReturnComputes.
    + rewrite <- H in *; computes_to_inv; subst; apply ReturnComputes.
Qed.

Lemma ret_fold_fold_ret :
  forall {TElem TAcc} (f: TAcc -> TElem -> TAcc) lst (init: TAcc),
    Monad.equiv (ret (fold_left f lst init))
                (fold_left (fun (acc: Comp TAcc) x => (a <- acc; ret (f a x))%comp) lst (ret init)).
Proof.
  intros; apply ret_fold_fold_ret_lemma; apply SetoidMorphisms.equiv_refl.
Qed.

Lemma CompileLoop_ret :
  forall {av A} `{FacadeWrapper (Value av) A} `{FacadeWrapper (Value av) A'} `{FacadeWrapper av (list A)}
    lst init facadeBody facadeConclude vhead vtest vlst vret env (ext: StringMap.t (Value av)) tenv tenv' fpop fempty fdealloc (f: A' -> A -> A'),
    GLabelMap.MapsTo fpop (Axiomatic (List_pop A)) env ->
    GLabelMap.MapsTo fempty (Axiomatic (List_empty A)) env ->
    GLabelMap.MapsTo fdealloc (Axiomatic (FacadeImplementationOfDestructor (list A))) env ->
    PreconditionSet tenv ext [[[vhead; vtest; vlst; vret]]] ->
    (forall head acc (s: list A),
        {{ [[`vret ->> acc as _]] :: [[`vhead ->> head as _]] :: tenv }}
          facadeBody
        {{ [[`vret ->> (f acc head) as _]] :: tenv }} ∪ {{ [vtest |> wrap (bool2w false)] :: [vlst |> wrap s] :: ext }} // env) ->
    {{ [[`vret ->> (fold_left f lst init) as _]] :: tenv }}
      facadeConclude
    {{ [[`vret ->> (fold_left f lst init) as _]] :: tenv' }} ∪ {{ ext }} // env ->
    {{ [[`vret ->> init as _]] :: [[`vlst ->> lst as _]] :: tenv }}
      (Seq (Seq (Fold vhead vtest vlst fpop fempty facadeBody) (Call (DummyArgument vtest) fdealloc (vlst :: nil))) facadeConclude)
    {{ [[`vret ->> (fold_left f lst init) as _]] :: tenv' }} ∪ {{ ext }} // env.
Proof.
  intros.
  setoid_rewrite ret_fold_fold_ret.
  eapply CompileSeq.
  apply CompileLoopBase; eauto.
  2: apply ProkOk_specialize_to_ret; intros * h; apply ret_fold_fold_ret in h; computes_to_inv; subst; eauto.
  intros; rewrite SameValues_Fiat_Bind_TelEq.
  apply miniChomp'; intros; eauto.
Qed.

Lemma CompileLoopAlloc_ret :
  forall {av A} `{FacadeWrapper (Value av) A} `{FacadeWrapper (Value av) A'} `{FacadeWrapper av (list A)}
    lst init facadeInit facadeBody facadeConclude vhead vtest vlst vret env (ext: StringMap.t (Value av)) tenv tenv' fpop fempty fdealloc (f: A' -> A -> A'),
    GLabelMap.MapsTo fpop (Axiomatic (List_pop A)) env ->
    GLabelMap.MapsTo fempty (Axiomatic (List_empty A)) env ->
    GLabelMap.MapsTo fdealloc (Axiomatic (FacadeImplementationOfDestructor (list A))) env ->
    PreconditionSet tenv ext [[[vhead; vtest; vlst; vret]]] ->
    {{ [[`vlst ->> lst as _]] :: tenv }}
      facadeInit
    {{ [[`vret ->> init as _]] :: [[`vlst ->> lst as _]] :: tenv }} ∪ {{ ext }} // env ->
    (forall head acc (s: list A),
        {{ [[`vret ->> acc as _]] :: [[`vhead ->> head as _]] :: tenv }}
          facadeBody
        {{ [[`vret ->> (f acc head) as _]] :: tenv }} ∪ {{ [vtest |> wrap (bool2w false)] :: [vlst |> wrap s] :: ext }} // env) ->
    {{ [[`vret ->> (fold_left f lst init) as _]] :: tenv }}
      facadeConclude
    {{ [[`vret ->> (fold_left f lst init) as _]] :: tenv' }} ∪ {{ ext }} // env ->
    {{ [[`vlst ->> lst as _]] :: tenv }}
      (Seq facadeInit (Seq (Seq (Fold vhead vtest vlst fpop fempty facadeBody) (Call (DummyArgument vtest) fdealloc (vlst :: nil))) facadeConclude))
    {{ [[`vret ->> (fold_left f lst init) as _]] :: tenv' }} ∪ {{ ext }} // env.
Proof.
  eauto using @CompileSeq, @CompileLoop_ret.
Qed.


(** * OR instruction *)
Require Import x86proved.x86.instrrules.core.
Import x86.instrrules.core.instrruleconfig.

(** ** Generic OR *)
Lemma OR_rule s (ds:DstSrc s) (v1: VWORD s) :
   |-- specAtDstSrc ds (fun D v2 =>
       basic (D v1 ** OSZCP?)
             (BOP _ OP_OR ds)
             (let v := orB v1 v2 in
              D v ** OSZCP false (msb v) (v == #0) false (lsb v))).
Proof. do_instrrule_triple. Qed.

(** We make this rule an instance of the typeclass, and leave
    unfolding things like [specAtDstSrc] to the getter tactic
    [get_instrrule_of]. *)
Global Instance: forall s (ds : DstSrc s), instrrule (BOP s OP_OR ds) := @OR_rule.


Require Import Utils.
Require Import Maps.
Require Import PropertyGraph.
Require Import Cypher.
Require Import BindingTable.
Require Import Semantics.
Require Import PatternE.
Require Import ExecutionPlan.
Require TraverseOpImpl.

Import PartialMap.Notations.
Import TotalMap.Notations.
Import PropertyGraph.
Import ExecutionPlan.
Import FilterMode.
Import ExpandMode.
Import MatchMode.
Import UpdateNotations.

Module ExecutionPlanImpl : ExecutionPlan.Spec.

  Definition scan_vertices (n : Name.t)
                           (graph : PropertyGraph.t) :
    option BindingTable.t :=
    Some (map (fun v => n |-> Value.GVertex v) (vertices graph)).

  Section filter_by_label.
    Variable mode : FilterMode.t.
    Variable n : Name.t.
    Variable l : PropertyGraph.label.
    Variable graph : PropertyGraph.t.
    Variable table : BindingTable.t.

    Definition vertex_has_label (r : Rcd.t) : bool :=
      match r n with
      | Some (Value.GVertex v) => In_decb l (vlabels graph v)
      | _ => false
      end.

    Definition edge_has_label (r : Rcd.t) : bool :=
      match r n with
      | Some (Value.GEdge e) => elabel graph e ==b l
      | _ => false
      end.

    Definition has_label : Rcd.t -> bool :=
      match mode with
      | Vertices => vertex_has_label
      | Edges => edge_has_label
      end.

    Definition filter_by_label : option BindingTable.t :=
      Some (filter has_label table).
  End filter_by_label.

  #[local]
  Hint Unfold filter_by_label has_label vertex_has_label edge_has_label : filter_by_label_db.

  Section expand.
    Variable mode : ExpandMode.t.
    Variable n_from n_edge n_to : Name.t.
    Variable d : Pattern.direction.
    Variable graph : PropertyGraph.t.
    Variable table : BindingTable.t.

    Definition expand_all_single (r : Rcd.t) : option BindingTable.t :=
      match r n_from, r n_edge, r n_to with
      | Some (Value.GVertex v_from), None, None =>
        Some (map (fun '(e, v_to) => n_to   |-> Value.GVertex v_to;
                                     n_edge |-> Value.GEdge e; r)
          match d with
          | Pattern.OUT  => out_edges graph v_from
          | Pattern.IN   => in_edges  graph v_from
          | Pattern.BOTH => out_edges graph v_from ++
                            in_edges  graph v_from
          end)
      | _, _, _ => None
      end.

    Definition expand_into_single (r : Rcd.t) : option BindingTable.t :=
      match r n_from, r n_edge, r n_to with
      | Some (Value.GVertex v_from), None, Some (Value.GVertex v_to) =>
          Some (map (fun e => n_to   |-> Value.GVertex v_to;
                              n_edge |-> Value.GEdge e; r)
          match d with
          | Pattern.OUT  => edges_between graph v_from v_to
          | Pattern.IN   => edges_between graph v_to   v_from
          | Pattern.BOTH => edges_between graph v_from v_to ++
                            edges_between graph v_to   v_from
          end)
      | _, _, _ => None
      end.

    Definition expand_single (r : Rcd.t) : option BindingTable.t :=
      match mode with
      | All => expand_all_single r
      | Into => expand_into_single r
      end.

    Definition expand : option BindingTable.t :=
      option_map (@List.concat Rcd.t) (fold_option (map expand_single table)).
  End expand.

  #[local]
  Hint Unfold expand expand_single expand_all_single expand_into_single : expand_db.

  Definition return_all (graph : PropertyGraph.t) (table : BindingTable.t) :=
    Some (map Rcd.explicit_proj table).

  (** If the inputs are well-formed then the operation will return the result *)

  Theorem scan_vertices_wf graph n (Hwf : PropertyGraph.wf graph) :
    exists table', scan_vertices n graph = Some table'.
  Proof using. now eexists. Qed.

  Theorem filter_by_label_wf graph table ty mode n l
                             (Hwf : PropertyGraph.wf graph)
                             (Htype : BindingTable.of_type table ty)
                             (Hty : match mode with
                                    | Vertices => ty n = Some Value.GVertexT
                                    | Edges    => ty n = Some Value.GEdgeT
                                    end) :
    exists table', filter_by_label mode n l graph table = Some table'.
  Proof using.
    autounfold with filter_by_label_db.
    all: induction table as [| r table IH]; ins; eauto.
  Qed.

  Theorem filter_vertices_by_label_wf graph table ty n l
                                    (Hwf : PropertyGraph.wf graph)
                                    (Htype : BindingTable.of_type table ty)
                                    (Hty : ty n = Some Value.GVertexT) :
    exists table', filter_by_label Vertices n l graph table = Some table'.
  Proof using. eapply filter_by_label_wf with (mode := Vertices); eassumption. Qed.

  Theorem filter_edges_by_label_wf graph table ty n l
                                 (Hwf : PropertyGraph.wf graph)
                                 (Htype : BindingTable.of_type table ty)
                                 (Hty : ty n = Some Value.GEdgeT) :
    exists table', filter_by_label Edges n l graph table = Some table'.
  Proof using. eapply filter_by_label_wf with (mode := Edges); eassumption. Qed.

  Theorem expand_wf graph table ty mode n_from n_edge n_to d
                    (Hwf : PropertyGraph.wf graph)
                    (Htype : BindingTable.of_type table ty)
                    (Hty_from : ty n_from = Some Value.GVertexT)
                    (Hty_edge : ty n_edge = None)
                    (Hty_to   : match mode with
                                | All => ty n_to = None
                                | Into => ty n_to = Some Value.GVertexT
                                end) :
    exists table', expand mode n_from n_edge n_to d graph table = Some table'.
  Proof using.
    all: autounfold with expand_db.

    eenough (exists t, fold_option _ = Some t) as [t Hfold].
    { rewrite Hfold. now eexists. }

    apply fold_option_some; intros a HIn; simpls.
    apply in_map_iff in HIn as [r [? ?]]; subst.

    edestruct BindingTable.type_of_GVertexT with (k := n_from) as [v_from Hv_from];
      try eassumption.
    rewrite Hv_from.

    destruct mode.
    2: edestruct BindingTable.type_of_GVertexT with (k := n_to) as [v_to Hv_to];
        try eassumption.
    2: rewrite Hv_to.
    all: repeat erewrite BindingTable.type_of_None; try eassumption.
    all: now eexists.
  Qed.

  Theorem expand_all_wf graph table ty n_from n_edge n_to d
                  (Hwf : PropertyGraph.wf graph)
                  (Htype : BindingTable.of_type table ty)
                  (Hty_from : ty n_from = Some Value.GVertexT)
                  (Hty_edge : ty n_edge = None)
                  (Hty_to   : ty n_to   = None) :
    exists table', expand All n_from n_edge n_to d graph table = Some table'.
  Proof using. eapply expand_wf with (mode := All); eassumption. Qed.

  Theorem expand_into_wf graph table ty n_from n_edge n_to d
                  (Hwf : PropertyGraph.wf graph)
                  (Htype : BindingTable.of_type table ty)
                  (Hty_from : ty n_from = Some Value.GVertexT)
                  (Hty_edge : ty n_edge = None)
                  (Hty_to   : ty n_to   = Some Value.GVertexT) :
    exists table', expand Into n_from n_edge n_to d graph table = Some table'.
  Proof using. eapply expand_wf with (mode := Into); eassumption. Qed.

  Theorem return_all_wf graph table :
    exists table', return_all graph table = Some table'.
  Proof using. now eexists. Qed.

  (** If the operation returned some table then the type of the table is correct *)

  Theorem scan_vertices_type graph table' n
                           (Hres : scan_vertices n graph = Some table') :
    BindingTable.of_type table' (n |-> Value.GVertexT).
  Proof using.
    unfold scan_vertices in Hres.
    injection Hres as Hres. subst. intros r' HIn.
    apply in_map_iff in HIn as [r [Heq HIn]].
    subst.
    solve_type_of.
  Qed.

  Theorem filter_by_label_type graph table table' ty mode n l
                             (Hres : filter_by_label mode n l graph table = Some table')
                             (Htype : BindingTable.of_type table ty) :
    BindingTable.of_type table' ty.
  Proof using.
    generalize dependent table'.
    destruct mode.
    all: autounfold with filter_by_label_db.
    all: induction table; ins; desf; eauto with type_of_db.
  Qed.

  Theorem expand_single_type graph r table' mode n_from n_edge n_to d
    (Hres : expand_single mode n_from n_edge n_to d graph r = Some table') :
      BindingTable.of_type table'
        (n_to |-> Value.GVertexT; n_edge |-> Value.GEdgeT; Rcd.type_of r).
  Proof using.
    autounfold with expand_db in *.
    desf.
    all: intros r' HIn'.
    all: apply in_map_iff in HIn'; desf.
    all: solve_type_of_extension r (Rcd.type_of r).
  Qed.

  Theorem expand_type graph table table' ty mode n_from n_edge n_to d
                          (Hres : expand mode n_from n_edge n_to d graph table = Some table')
                          (Htype : BindingTable.of_type table ty) :
    BindingTable.of_type table'
      (n_to |-> Value.GVertexT; n_edge |-> Value.GEdgeT; ty).
  Proof using.
    unfold expand in *.
    unfold option_map in Hres; desf.
    destruct mode.

    all: apply BindingTable.of_type_concat; intros table' HIn_tables'.
    all: eassert (Hmap : In (Some table') (map _ table))
          by (eapply fold_option_In; eauto).

    all: apply in_map_iff in Hmap as [r ?]; desf.
    all: assert (Rcd.type_of r = ty) as Hty by auto; subst.
    all: eauto using expand_single_type.
  Qed.

  Theorem return_all_type graph table table' ty
                          (Hres : return_all graph table = Some table')
                          (Htype : BindingTable.of_type table ty) :
    BindingTable.of_type table' (Rcd.explicit_projT ty).
  Proof using.
    intros r' HIn.
    unfold return_all in Hres.
    injection Hres as ?; subst.
    apply in_map_iff in HIn as [r [? HIn]]; subst.
    rewrite Rcd.type_of_explicit_proj.
    now rewrite Htype with r.
  Qed.

  (** scan_vertices specification *)

  Theorem scan_vertices_spec graph table' n v
    (Hres : scan_vertices n graph = Some table')
    (HIn : In v (vertices graph)) :
      In (n |-> Value.GVertex v) table'.
  Proof using.
    unfold scan_vertices in Hres.
    inj_subst.
    apply in_map_iff.
    exists v. auto.
  Qed.

  Theorem scan_vertices_spec' graph table' n r'
    (Hres : scan_vertices n graph = Some table')
    (HIn : In r' table') :
      exists v, r' = (n |-> Value.GVertex v) /\ In v (vertices graph).
  Proof using.
    unfold scan_vertices in Hres.
    inj_subst.
    apply in_map_iff in HIn as [v [Heq HIn]].
    subst. exists v. auto.
  Qed.

  (** filter_by_label specification *)

  Theorem vertex_has_label_true_iff graph n l r :
    vertex_has_label n l graph r = true <->
      exists v, r n = Some (Value.GVertex v) /\ In l (vlabels graph v).
  Proof using.
    split; ins.
    all: unfold vertex_has_label in *.
    all: desf; normalize_bool.
    { eexists. split; eauto. }
    now rewrite -> In_decb_true_iff.
  Qed.

  Theorem edge_has_label_true_iff graph n l r :
    edge_has_label n l graph r = true <->
      exists e, r n = Some (Value.GEdge e) /\ elabel graph e = l.
  Proof using.
    split; ins.
    all: unfold edge_has_label in *.
    all: desf.
    { eexists. split. { eauto. }
      now rewrite <- equiv_decb_true_iff. }
    now rewrite -> equiv_decb_true_iff.
  Qed.

  Theorem filter_by_label_spec graph table table' mode n l r
    (Hres : filter_by_label mode n l graph table = Some table') :
      match mode with
      | Vertices => In r table' <-> In r table /\
          (exists v, r n = Some (Value.GVertex v) /\ In l (vlabels graph v))
      | Edges    => In r table' <-> In r table /\
          (exists e, r n = Some (Value.GEdge e) /\ elabel graph e = l)
      end.
  Proof using.
    unfold filter_by_label, has_label in Hres.
    inj_subst.
    destruct mode; ins.
    all: rewrite filter_In.
    1: rewrite -> vertex_has_label_true_iff; try eassumption.
    2: rewrite -> edge_has_label_true_iff; try eassumption.
    all: reflexivity.
  Qed.

  Theorem filter_vertices_by_label_spec graph table table' n l v r
    (Hres : filter_by_label Vertices n l graph table = Some table')
    (Hval : r n = Some (Value.GVertex v)) (Hlabel : In l (vlabels graph v))
    (HIn : In r table) : In r table'.
  Proof using.
    rewrite -> filter_by_label_spec with (mode := Vertices); eauto.
  Qed.

  Theorem filter_vertices_by_label_spec' graph table table' n l r'
    (Hres : filter_by_label Vertices n l graph table = Some table')
    (HIn : In r' table') : In r' table /\
        exists v, r' n = Some (Value.GVertex v) /\ In l (vlabels graph v).
  Proof using.
    rewrite <- filter_by_label_spec with (mode := Vertices); eauto.
  Qed.

  Theorem filter_edges_by_label_spec graph table table' n l e r
    (Hres : filter_by_label Edges n l graph table = Some table')
    (Hval : r n = Some (Value.GEdge e)) (Hlabel : elabel graph e = l)
    (HIn : In r table) : In r table'.
  Proof using.
    rewrite -> filter_by_label_spec with (mode := Edges); eauto.
  Qed.

  Theorem filter_edges_by_label_spec' graph table table' n l r'
    (Hres : filter_by_label Edges n l graph table = Some table')
    (HIn : In r' table') : In r' table /\
        exists e, r' n = Some (Value.GEdge e) /\ elabel graph e = l.
  Proof using.
    rewrite <- filter_by_label_spec with (mode := Edges); eauto.
  Qed.

  (** expand specification *)

  Theorem expand_single_spec graph table' r r' mode n_from n_edge n_to d
    (Hres : expand_single mode n_from n_edge n_to d graph r = Some table') :
      expansion_of graph r' r mode n_from n_edge n_to d <-> In r' table'.
  Proof using.
    split; ins.
    all: unfold expansion_of, expansion_of', Path.matches_direction in *.

    - destruct mode; desf.
      all: autounfold with expand_db in Hres.
      all: rewrite Hval_from, Hval_to in Hres; desf.
      all: apply in_map_iff.
      all: try exists (e, v_to).
      all: try exists e.
      all: split; [ reflexivity | ].
      all: try apply in_or_app.
      all: try rewrite -> in_edges_In.
      all: try rewrite -> out_edges_In.
      all: repeat rewrite -> edges_between_In.
      all: unfold e_from, e_to; destruct (ends graph e); desf.
      all: auto.

    - all: autounfold with expand_db in Hres.
      destruct mode; desf.
      all: match goal with
           | [ H : In _ (map _ _) |- _ ] => apply in_map_iff in H; desf
           end.
      all: try match goal with
           | [ H : In _ (_ ++ _) |- _ ] => apply in_app_or in H
           end; desf.
      all: match goal with
           | [ H : In _ (out_edges       _ _) |- _ ] =>
               apply out_edges_In in H
           | [ H : In _ (in_edges        _ _) |- _ ] =>
               apply in_edges_In in H
           | [ H : In _ (edges_between _ _ _) |- _ ] =>
               apply edges_between_In in H
           end; desf.
      all: do 3 eexists.
      all: splits; eauto.

      all: unfold e_from, e_to in *; edestruct (ends graph _); desf; simpls.
      all: auto.
  Qed.

  Theorem expand_spec graph table table' r r' mode n_from n_edge n_to d
      (Hres : expand mode n_from n_edge n_to d graph table = Some table')
      (Hexp : expansion_of graph r' r mode n_from n_edge n_to d)
      (HIn : In r table) : In r' table'.
  Proof using.
    unfold expand in *.

    edestruct (fold_option _) as [tables' | ] eqn:Hfold.
    2: now inv Hres.
    simpls; inj_subst.

    eassert (Hmap : In (_ r) (map _ table)) by (now eapply in_map).

    eassert (exists table', _ r = Some table') as [table' Hres].
    { eapply fold_option_some_inv in Hfold as [table' Heq]; eauto. }

    apply in_concat. exists table'. split.
    2: now eapply expand_single_spec; eauto.
    eapply fold_option_In; eauto.
    unfold BindingTable.t in *.
    now rewrite <- Hres.
  Qed.

  Theorem expand_spec' graph table table' r' mode n_from n_edge n_to d
    (Hres : expand mode n_from n_edge n_to d graph table = Some table')
    (HIn : In r' table') :
      exists r, In r table /\
                expansion_of graph r' r mode n_from n_edge n_to d.
  Proof using.
    unfold expand in *.
    edestruct (fold_option _) as [tables' | ] eqn:?.
    2: now inv Hres.
    simpls; inj_subst.

    apply in_concat in HIn as [table' ?]; desf.
    eassert (Hmap : In (Some table') (map _ table)).
    { eapply fold_option_In; eassumption. }

    apply in_map_iff in Hmap as [r ?]; desf.
    exists r. split.
    { assumption. }
    eapply expand_single_spec; eassumption.
  Qed.

  (* return_all specification *)

  Theorem return_all_spec graph table table' r
    (Hres : return_all graph table = Some table')
    (HIn : In r table) :
      In (Rcd.explicit_proj r) table'.
  Proof using.
    unfold return_all in *.
    injection Hres as ?; subst.
    eapply in_map in HIn.
    eassumption.
  Qed.

  Theorem return_all_spec' graph table table' r'
    (Hres : return_all graph table = Some table')
    (HIn : In r' table') :
      exists r, In r table /\ r' = Rcd.explicit_proj r.
  Proof using.
    unfold return_all in *.
    injection Hres as ?; subst.
    apply in_map_iff in HIn as [r ?]; desf.
    eauto.
  Qed.

  (* traversion *)

  Definition traverse := TraverseOpImpl.traverse.
  Definition traverse_wf := TraverseOpImpl.traverse_wf.
  Definition traverse_type := TraverseOpImpl.traverse_type.
  Definition traverse_spec := TraverseOpImpl.traverse_spec.
  Definition traverse_spec' := TraverseOpImpl.traverse_spec'.
End ExecutionPlanImpl.


(** Heaps for code/packages

  This module introduces the notion of heap for storing memory in packages.
*)

From Coq Require Import Utf8.
From Relational Require Import OrderEnrichedCategory
  OrderEnrichedRelativeMonadExamples.
Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format".
From mathcomp Require Import ssrnat ssreflect ssrfun ssrbool ssrnum eqtype
  choice reals distr seq all_algebra fintype realsum.
Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format".
From extructures Require Import ord fset fmap.
From Mon Require Import SPropBase.
From Crypt Require Import Prelude Axioms ChoiceAsOrd SubDistr Couplings
  RulesStateProb UniformStateProb UniformDistrLemmas StateTransfThetaDens
  StateTransformingLaxMorph chUniverse pkg_core_definition pkg_notation
  pkg_tactics pkg_composition.
Require Import Equations.Prop.DepElim.
From Equations Require Import Equations.

(* Must come after importing Equations.Equations, who knows why. *)
From Crypt Require Import FreeProbProg.

Set Equations With UIP.
Set Equations Transparent.

Import SPropNotations.
Import PackageNotation.
Import RSemanticNotation.

Set Bullet Behavior "Strict Subproofs".
Set Default Goal Selector "!".
Set Primitive Projections.

Definition pointed_value := ∑ (t : chUniverse), t.

Definition raw_heap := {fmap Location -> pointed_value}.
Definition raw_heap_choiceType := [choiceType of raw_heap].

Definition check_loc_val (l : Location) (v : pointed_value) :=
  l.π1 == v.π1.

Definition valid_location (h : raw_heap) (l : Location) :=
  match h l with
  | None => false
  | Some v => check_loc_val l v
  end.

Definition valid_heap : pred raw_heap :=
  λ h, domm h == fset_filter (valid_location h) (domm h).

Definition heap_defaults := ∀ a : chUniverse, a.

Definition heap_init : heap_defaults.
Proof.
  intros a. induction a.
  - exact tt.
  - exact 0.
  - exact false.
  - exact (IHa1, IHa2).
  - exact emptym.
  - exact None.
  - exact (fintype.Ordinal n.(cond_pos)).
Defined.

Definition heap := { h : raw_heap | valid_heap h }.

Definition heap_choiceType := [choiceType of heap].

Lemma heap_ext :
  ∀ (h₀ h₁ : heap),
    h₀ ∙1 = h₁ ∙1 →
    h₀ = h₁.
Proof.
  intros [h₀ v₀] [h₁ v₁] e. simpl in e. subst.
  f_equal. apply eq_irrelevance.
Qed.

Definition cast_pointed_value {A} (p : pointed_value) (e : A = p.π1) : Value A.
Proof.
  subst. exact p.π2.
Defined.

Lemma cast_pointed_value_K :
  ∀ p e,
    cast_pointed_value p e = p.π2.
Proof.
  intros p e.
  assert (e = erefl).
  { apply eq_irrelevance. }
  subst. reflexivity.
Qed.

Lemma cast_pointed_value_ext :
  ∀ A p e1 q e2,
    p = q →
    @cast_pointed_value A p e1 = @cast_pointed_value A q e2.
Proof.
  intros A p e1 q e2 e. subst.
  cbn.
  assert (ee : e2 = erefl).
  { apply eq_irrelevance. }
  rewrite ee. reflexivity.
Qed.

Lemma get_heap_helper :
  ∀ h ℓ p,
    valid_heap h →
    h ℓ = Some p →
    ℓ.π1 = p.π1.
Proof.
  intros h ℓ p vh e.
  assert (hℓ : exists v, h ℓ = Some v).
  { eexists. eauto. }
  move: hℓ => /dommP hℓ.
  unfold valid_heap in vh.
  move: vh => /eqP vh.
  rewrite vh in hℓ.
  rewrite in_fset_filter in hℓ.
  move: hℓ => /andP [vℓ hℓ].
  unfold valid_location in vℓ.
  rewrite e in vℓ.
  unfold check_loc_val in vℓ.
  move: vℓ => /eqP. auto.
Qed.

Equations? get_heap (map : heap) (ℓ : Location) : Value ℓ.π1 :=
  get_heap map ℓ with inspect (map ∙1 ℓ) := {
  | @exist (Some p) e => cast_pointed_value p _
  | @exist None e => heap_init (ℓ.π1)
  }.
Proof.
  destruct map as [h vh]. simpl in e.
  eapply get_heap_helper. all: eauto.
Defined.

Program Definition set_heap (map : heap) (l : Location) (v : Value l.π1)
: heap :=
  setm map l (l.π1 ; v).
Next Obligation.
  intros map l v.
  unfold valid_heap.
  destruct map as [rh valid_rh].
  cbn - ["_ == _"].
  apply /eqP.
  apply eq_fset.
  move => x.
  rewrite domm_set.
  rewrite in_fset_filter.
  destruct ((x \in l |: domm rh)) eqn:Heq.
  - rewrite andbC. cbn.
    symmetry. apply /idP.
    unfold valid_location.
    rewrite setmE.
    destruct (x == l) eqn:H.
    + cbn. move: H. move /eqP => H. subst. apply chUniverse_refl.
    + move: Heq. move /idP /fsetU1P => Heq.
      destruct Heq.
      * move: H. move /eqP => H. contradiction.
      * destruct x, l. rewrite mem_domm in H0.
        unfold isSome in H0.
        destruct (rh (x; s)) eqn:Hrhx.
        ** cbn. unfold valid_heap in valid_rh.
            move: valid_rh. move /eqP /eq_fset => valid_rh.
            specialize (valid_rh (x; s)).
            rewrite in_fset_filter in valid_rh.
            rewrite mem_domm in valid_rh.
            assert (valid_location rh (x;s)) as Hvl.
            { rewrite Hrhx in valid_rh. cbn in valid_rh.
              rewrite andbC in valid_rh. cbn in valid_rh.
              rewrite -valid_rh. auto. }
            unfold valid_location in Hvl.
            rewrite Hrhx in Hvl.
            cbn in Hvl.
            assumption.
        ** assumption.
  - rewrite andbC. auto.
Qed.

#[program] Definition empty_heap : heap := emptym.
Next Obligation.
  by rewrite /valid_heap domm0 /fset_filter -fset0E.
Qed.

Lemma get_empty_heap :
  ∀ ℓ,
    get_heap empty_heap ℓ = heap_init (ℓ.π1).
Proof.
  intros ℓ. reflexivity.
Qed.

Lemma get_set_heap_eq :
  ∀ h ℓ v,
    get_heap (set_heap h ℓ v) ℓ = v.
Proof.
  intros h ℓ v.
  funelim (get_heap (set_heap h ℓ v) ℓ).
  2:{
    pose proof e as ep. simpl in ep.
    rewrite setmE in ep. rewrite eqxx in ep. noconf ep.
  }
  rewrite -Heqcall. clear Heqcall.
  pose proof e as ep. simpl in ep.
  rewrite setmE in ep. rewrite eqxx in ep. noconf ep.
  rewrite (cast_pointed_value_K (ℓ0.π1 ; v)).
  reflexivity.
Qed.

Lemma get_set_heap_neq :
  ∀ h ℓ v ℓ',
    ℓ' != ℓ →
    get_heap (set_heap h ℓ v) ℓ' = get_heap h ℓ'.
Proof.
  intros h ℓ v ℓ' ne.
  funelim (get_heap (set_heap h ℓ v) ℓ').
  - rewrite -Heqcall. clear Heqcall.
    pose proof e as ep. simpl in ep.
    rewrite setmE in ep.
    eapply negbTE in ne. rewrite ne in ep.
    funelim (get_heap h ℓ).
    2:{
      rewrite -e in ep. noconf ep.
    }
    rewrite -Heqcall. clear Heqcall.
    apply cast_pointed_value_ext.
    rewrite -e in ep. noconf ep. reflexivity.
  - rewrite -Heqcall. clear Heqcall.
    clear H. simpl in e. rewrite setmE in e.
    eapply negbTE in ne. rewrite ne in e.
    funelim (get_heap h ℓ).
    1:{
      rewrite -e in e0. noconf e0.
    }
    rewrite -Heqcall. reflexivity.
Qed.

Lemma set_heap_contract :
  ∀ s ℓ v v',
    set_heap (set_heap s ℓ v) ℓ v' = set_heap s ℓ v'.
Proof.
  intros s ℓ v v'.
  apply heap_ext. destruct s as [h vh]. simpl.
  apply setmxx.
Qed.

Lemma get_heap_set_heap :
  ∀ s ℓ ℓ' v,
    ℓ != ℓ' →
    get_heap s ℓ = get_heap (set_heap s ℓ' v) ℓ.
Proof.
  intros s ℓ ℓ' v ne.
  rewrite get_set_heap_neq. 2: auto.
  reflexivity.
Qed.

Lemma set_heap_commut :
  ∀ s ℓ v ℓ' v',
    ℓ != ℓ' →
    set_heap (set_heap s ℓ v) ℓ' v' =
    set_heap (set_heap s ℓ' v') ℓ v.
Proof.
  intros s ℓ v ℓ' v' ne.
  apply heap_ext. destruct s as [h vh]. simpl.
  apply setmC. auto.
Qed.


Require Import Coq.Sorting.Permutation.
Require Import Coq.Sorting.Sorting.
Require Import Coq.Structures.Orders.
Require Import VST.veric.base.
Import compcert.lib.Maps.

Require Import compcert.cfrontend.Ctypes.

(* TODO: This is obviously true. Ask Xavior to remove the definition list_norepet.*)
Lemma list_norepet_NoDup: forall {A: Type} (l: list A), list_norepet l <-> NoDup l.
Proof.
intros; split; intro;
induction H; constructor; auto.
Qed.

Lemma PTree_In_fst_elements {A: Type}: forall (T: PTree.t A) i,
  In i (map fst (PTree.elements T)) <-> exists a, PTree.get i T = Some a.
Proof.
  intros.
  split; intros.
  + apply list_in_map_inv in H.
    destruct H as [[i0 a] [? ?]].
    simpl in H; subst i0.
    apply PTree.elements_complete in H0.
    eauto.
  + destruct H as [a ?].
    apply PTree.elements_correct in H.
    apply (in_map fst) in H.
    auto.
Qed.

Lemma PTree_gs {A: Type}: forall (T: PTree.t A) i j x,
  (exists a, PTree.get i T= Some a) ->
  exists a, PTree.get i (PTree.set j x T) = Some a.
Proof.
  intros.
  destruct H.
  destruct (Pos.eq_dec i j).
  + subst.
    rewrite PTree.gss; eauto.
  + rewrite PTree.gso; eauto.
Qed.

Lemma PTree_gs_equiv {A: Type}: forall (T: PTree.t A) i j x,
  (exists a, PTree.get i T= Some a) \/ i = j <->
  exists a, PTree.get i (PTree.set j x T) = Some a.
Proof.
  intros.
  split; intros.
  + destruct H; [apply PTree_gs; auto |].
    subst; rewrite PTree.gss; eauto.
  + destruct (Pos.eq_dec i j); auto.
    rewrite PTree.gso in H by auto.
    auto.
Qed.

Lemma PTree_set_In_fst_elements {A: Type}: forall (T: PTree.t A) i i' a',
  In i (map fst (PTree.elements T)) ->
  In i (map fst (PTree.elements (PTree.set i' a' T))).
Proof.
  intros.
  rewrite PTree_In_fst_elements in H |- *.
  apply PTree_gs; auto.
Qed.

Fixpoint relative_defined_type {A: Type} (l: list (ident * A)) (t: type): Prop :=
  match t with
  | Tarray t' _ _ => relative_defined_type l t'
  | Tstruct id _ => In id (map fst l)
  | Tunion id _ => In id (map fst l)
  | _ => True
  end.

Lemma relative_defined_type_mono: forall {A B: Type} (l1: list (ident * A)) (l2: list (ident * B)) (t: type),
  (forall i, In i (map fst l1) -> In i (map fst l2)) ->
  relative_defined_type l1 t ->
  relative_defined_type l2 t.
Proof.
  intros.
  induction t; auto.
  + simpl in *.
    firstorder.
  + simpl in *.
    firstorder.
Qed.

Lemma relative_defined_type_equiv: forall {A B: Type} (l1: list (ident * A)) (l2: list (ident * B)) (t: type),
  (forall i, In i (map fst l1) <-> In i (map fst l2)) ->
  (relative_defined_type l1 t <-> relative_defined_type l2 t).
Proof.
  intros.
  split; apply relative_defined_type_mono;
  firstorder.
Qed.

Inductive ordered_composite: list (positive * composite) -> Prop :=
| ordered_composite_nil: ordered_composite nil
| ordered_composite_cons: forall i co l,
    Forall (relative_defined_type l) (map type_member (co_members co)) ->
    ordered_composite l ->
    ordered_composite ((i, co) :: l).

Module composite_reorder.

(* Use merge sort instead *)
(* Sort rank from higher to lower *)
Module CompositeRankOrder <: TotalLeBool.
  Definition t := (positive * composite)%type.
  Definition leb (x y: t) := Nat.leb (co_rank (snd y)) (co_rank (snd x)).

  Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true.
  Proof.
    intros.
    unfold leb.
    rewrite !Nat.leb_le.
    lia.
  Qed.

  Theorem leb_trans: Transitive (fun x y => is_true (leb x y)).
  Proof.
    hnf; intros; unfold leb, is_true in *.
    rewrite !Nat.leb_le in *.
    lia.
  Qed.

End CompositeRankOrder.

Module CompositeRankSort := Sort CompositeRankOrder.

Section composite_reorder.

Context (cenv: composite_env)
        (cenv_consistent: composite_env_consistent cenv).

Definition rebuild_composite_elements := CompositeRankSort.sort (PTree.elements cenv).

Inductive ordered_and_complete: list (positive * composite) -> Prop :=
| ordered_and_complete_nil: ordered_and_complete nil
| ordered_and_complete_cons: forall i co l,
    (forall i' co',
        cenv ! i' = Some co' ->
        (co_rank co' < co_rank co)%nat ->
        In (i', co') l) ->
    ordered_and_complete l ->
    ordered_and_complete ((i, co) :: l).

Theorem RCT_Permutation: Permutation rebuild_composite_elements (PTree.elements cenv).
Proof.
  symmetry.
  apply CompositeRankSort.Permuted_sort.
Qed.

Lemma RCT_ordered_and_complete: ordered_and_complete rebuild_composite_elements.
Proof.
  pose proof RCT_Permutation.
  assert (forall i co, cenv ! i = Some co -> In (i, co) rebuild_composite_elements).
  {
    intros.
    eapply Permutation_in.
    + symmetry; apply RCT_Permutation.
    + apply PTree.elements_correct; auto.
  }
  clear H.
  pose proof CompositeRankSort.StronglySorted_sort (PTree.elements cenv) CompositeRankOrder.leb_trans.
  pose proof app_nil_l rebuild_composite_elements.
  unfold rebuild_composite_elements in *.
  set (l := (CompositeRankSort.sort (PTree.elements cenv))) in H1 at 1 |- *.
  revert H1; generalize (@nil (positive * composite)).
  clearbody l.
  induction l; intros.
  + constructor.
  + specialize (IHl (l0 ++ a :: nil)).
    rewrite <- app_assoc in IHl.
    specialize (IHl H1).
    destruct a as [i co]; constructor; auto.
    intros.
    apply H0 in H2.
    rewrite <- H1 in H2, H.
    clear - H2 H3 H.
    induction l0.
    - destruct H2; auto.
      exfalso; inv H0.
      lia.
    - inv H.
      destruct H2.
      * exfalso.
        subst.
        rewrite Forall_forall in H5.
        specialize (H5 (i, co)).
        rewrite in_app in H5.
        specialize (H5 (or_intror (or_introl eq_refl))).
        unfold is_true in H5.
        rewrite Nat.leb_le in H5; simpl in H5.
        lia.
      * apply IHl0; auto.
Qed.

Theorem RCT_ordered: ordered_composite rebuild_composite_elements.
Proof.
  pose proof RCT_ordered_and_complete.
  assert (forall i co, In (i, co) rebuild_composite_elements -> complete_members cenv (co_members co) = true /\ co_rank co = rank_members cenv (co_members co)).
  {
    intros.
    eapply Permutation_in in H0; [| exact RCT_Permutation].
    apply PTree.elements_complete in H0; auto.
    split.
    + apply co_consistent_complete.
      eapply cenv_consistent; eauto.
    + apply co_consistent_rank.
      eapply cenv_consistent; eauto.
  }
  induction H.
  + constructor.
  + specialize (IHordered_and_complete (fun i co HH => H0 i co (or_intror HH))).
    constructor; auto.
    clear IHordered_and_complete H1.
    specialize (H0 _ _ (or_introl eq_refl)).
    assert (rank_members cenv (co_members co) <= co_rank co)%nat by lia.
    destruct H0 as [? _].
    induction (co_members co) as [| [i0 t0 |]].
    - constructor.
    - simpl in H0; rewrite andb_true_iff in H0; destruct H0.
      simpl in H1; pose proof Nat.max_lub_r _ _ _ H1.
      apply Nat.max_lub_l in H1.
      constructor; auto; clear IHm H2 H3.
      simpl.
      induction t0; try solve [simpl; auto].
      * (* array *)
        spec IHt0; auto.
        spec IHt0; [simpl in H1; lia |].
        auto.
      * (* struct *)
        simpl in H0, H1 |- *.
        destruct (cenv ! i1) eqn:?H; [| inv H0].
        specialize (H _ _ H2).
        spec H; [lia |].
        apply (in_map fst) in H; auto.
      * (* union *)
        simpl in H0, H1 |- *.
        destruct (cenv ! i1) eqn:?H; [| inv H0].
        specialize (H _ _ H2).
        spec H; [lia |].
        apply (in_map fst) in H; auto.
    - constructor. simpl; auto.
       auto.
Qed.

End composite_reorder.

End composite_reorder.

Module type_func.
Section type_func.

Context {A: Type}
        (f_default: type -> A)
        (f_array: A -> type -> Z -> attr -> A)
        (f_struct: A -> ident -> attr -> A)
        (f_union: A -> ident -> attr -> A)
        (f_member: struct_or_union -> list (member * A) -> A).

Fixpoint F (env: PTree.t A) (t: type): A :=
  match t with
  | Tarray t n a => f_array (F env t) t n a
  | Tstruct id a =>
      match env ! id with
      | Some v => f_struct v id a
      | None => f_default t
      end
  | Tunion id a =>
      match env ! id with
      | Some v => f_union v id a
      | None => f_default t
      end
  | _ => f_default t
  end.

Definition Complete (cenv: composite_env) (env: PTree.t A): Prop :=
  forall i,
    (exists co, PTree.get i cenv = Some co) <->
    (exists a, PTree.get i env = Some a).

Definition f_members (co: composite) (env: PTree.t A) : A :=
  f_member (co_su co)
            (map (fun m => (m, F env (type_member m))) (co_members co)).

Definition Consistent (cenv: composite_env) (env: PTree.t A): Prop :=
  forall i co a,
    PTree.get i cenv = Some co ->
    PTree.get i env = Some a ->
    a = f_members co env.

Definition Env (l: list (positive * composite)): PTree.t A :=
  fold_right
    (fun (ic: positive * composite) env =>
       let (i, co) := ic in PTree.set i (f_members co env) env)
    (PTree.empty A)
    l.

Lemma F_PTree_set: forall t env i a,
  ~ In i (map fst (PTree.elements env)) ->
  relative_defined_type (PTree.elements env) t ->
  F env t = F (PTree.set i a env) t.
Proof.
  intros.
  induction t; auto.
  + simpl.
    apply IHt in H0.
    rewrite H0; auto.
  + simpl in H0 |- *.
    rewrite PTree.gso; auto.
    intro; subst; tauto.
  + simpl in H0 |- *.
    rewrite PTree.gso; auto.
    intro; subst; tauto.
Qed.

Lemma relative_defined_type_PTree_set: forall t (env: PTree.t A) i a,
  relative_defined_type (PTree.elements env) t ->
  relative_defined_type (PTree.elements (PTree.set i a env)) t.
Proof.
  intros.
  revert H; apply relative_defined_type_mono.
  intros; apply PTree_set_In_fst_elements; auto.
Qed.

Section Consistency_Induction_Step.

Context (cenv: composite_env)
        (env: PTree.t A)
        (l: list (positive * composite))
        (i0: positive)
        (co0: composite).

Hypothesis NOT_IN_LIST: ~ In i0 (map fst l).

Hypothesis RDT_list: Forall (relative_defined_type l) (map type_member (co_members co0)).

Hypothesis CENV0: PTree.get i0 cenv = Some co0.

Hypothesis IH_In_equiv: forall i, In i (map fst l) <-> In i (map fst (PTree.elements env)).

Hypothesis IH_RDT:
  forall i co a,
    PTree.get i cenv = Some co ->
    PTree.get i env = Some a ->
    Forall (relative_defined_type (PTree.elements env)) (map type_member (co_members co)).

Hypothesis IH_main:
  Consistent cenv env.

Lemma NOT_IN: ~ In i0 (map fst (PTree.elements env)).
Proof.
  intros.
  rewrite <- IH_In_equiv; auto.
Qed.

Lemma RDT_PTree: Forall (relative_defined_type (PTree.elements env)) (map type_member (co_members co0)).
Proof.
  intros.
  revert RDT_list; apply Forall_impl.
  intros t.
  apply relative_defined_type_mono.
  firstorder.
Qed.

Lemma establish_In_equiv:
  forall i, In i (map fst ((i0, co0) :: l)) <-> In i (map fst (PTree.elements (PTree.set i0 (f_members co0 env) env))).
Proof.
  intros.
  specialize (IH_In_equiv i).
  rewrite PTree_In_fst_elements in IH_In_equiv |- *.
  rewrite <- PTree_gs_equiv.
  simpl In.
  assert (i0 = i <-> i = i0) by (split; intros; congruence).
  tauto.
Qed.

Lemma establish_RDT:
  forall i co a,
    PTree.get i cenv = Some co ->
    PTree.get i (PTree.set i0 (f_members co0 env) env) = Some a ->
    Forall (relative_defined_type (PTree.elements (PTree.set i0 (f_members co0 env) env))) (map type_member (co_members co)).
Proof.
  pose proof RDT_PTree as RDT_PTree.
  intros i co a CENV ENV.
  destruct (Pos.eq_dec i i0).
  + subst i0; rewrite CENV in CENV0; inversion CENV0; subst co0; clear CENV0.
    rewrite PTree.gss in ENV.
    inversion ENV; clear a ENV H0.
    revert RDT_PTree.
    apply Forall_impl; intros t.
    apply relative_defined_type_PTree_set.
  + rewrite PTree.gso in ENV by auto.
    specialize (IH_RDT _ _ _ CENV ENV).
    revert IH_RDT.
    apply Forall_impl; intros t.
    apply relative_defined_type_PTree_set.
Qed.

Lemma establish_main:
  Consistent cenv (PTree.set i0 (f_members co0 env) env).
Proof.
  pose proof NOT_IN as NOT_IN.
  pose proof RDT_PTree as RDT_PTree.
  intros i co a CENV ENV.
  destruct (Pos.eq_dec i i0).
  + subst i0; rewrite CENV in CENV0; inversion CENV0; subst co0; clear CENV0.
    rewrite PTree.gss in ENV.
    inversion ENV; clear a ENV H0.
    unfold f_members.
    f_equal.
    apply map_ext_in.
    intros. simpl.
    f_equal.
    apply F_PTree_set; auto.
    rewrite Forall_forall in RDT_PTree; apply RDT_PTree.
    apply (in_map type_member) in H; auto.
  + rewrite PTree.gso in ENV by auto.
    specialize (IH_main _ _ _ CENV ENV).
    subst a.
    unfold f_members.
    f_equal.
    apply map_ext_in.
    intros. simpl.
    f_equal.
    apply F_PTree_set; auto.
    specialize (IH_RDT _ _ _ CENV ENV).
    rewrite Forall_forall in IH_RDT; apply IH_RDT.
    apply (in_map type_member) in H; auto.
Qed.

End Consistency_Induction_Step.

Lemma Consistency: forall cenv l,
  Permutation l (PTree.elements cenv) ->
  ordered_composite l ->
  Consistent cenv (Env l).
Proof.
  intros.
  assert (forall i co, In (i, co) l -> PTree.get i cenv = Some co).
  {
    intros.
    apply PTree.elements_complete.
    eapply Permutation_in; eauto.
  }
  assert (NoDup (map fst l)).
  {
    eapply Permutation_NoDup; [symmetry; apply Permutation_map; eassumption |].
    rewrite <- list_norepet_NoDup.
    apply PTree.elements_keys_norepet.
  }
  clear H.
  assert (
    (forall i, In i (map fst l) <-> In i (map fst (PTree.elements (Env l)))) /\
    (forall i co a,
      PTree.get i cenv = Some co ->
      PTree.get i (Env l) = Some a ->
      Forall (relative_defined_type (PTree.elements (Env l))) (map type_member (co_members co))) /\
    Consistent cenv (Env l)); [| tauto].
  induction l as [| [i0 co0] l].
  + split; [| split]; hnf; intros.
    - simpl; tauto.
    - unfold Env in H3; simpl in H3.
      rewrite PTree.gempty in H3; inv H3.
    - unfold Env in H3; simpl in H3.
      rewrite PTree.gempty in H3; inv H3.
  + inv H0.
    rename H4 into RDT_list; specialize (IHl H6); clear H6.
    assert (CENV0: PTree.get i0 cenv = Some co0).
    { apply H1; left; auto. }
    spec IHl; [| clear H1].
    { intros; apply H1; right; auto. }
    inv H2.
    rename H1 into NOT_IN_LIST; specialize (IHl H3); clear H3.
    destruct IHl as [IH_In_equiv [IH_RDT IH_main]].
    split; [| split].
    - apply establish_In_equiv; auto.
    - eapply establish_RDT; eauto.
    - eapply establish_main; eauto.
Qed.

Lemma Completeness: forall cenv l,
  Permutation l (PTree.elements cenv) ->
  Complete cenv (Env l).
Proof.
  intros.
  intro.
  rewrite <- !PTree_In_fst_elements.
  pose proof PTree.elements_keys_norepet cenv.
  rewrite list_norepet_NoDup in H0.
  rewrite <- H in H0 |- *; clear H.
  induction l.
  + simpl; tauto.
  + destruct a as [i0 co0].
    inv H0.
    specialize (IHl H3).
    simpl.
    rewrite PTree_In_fst_elements, <- PTree_gs_equiv, <- PTree_In_fst_elements.
    assert (i = i0 <-> i0 = i) by (split; intros; congruence).
    tauto.
Qed.

End type_func.

End type_func.

Corollary composite_reorder_consistent {A: Type}:
  forall cenv f_default f_array f_struct f_union f_members,
    composite_env_consistent cenv ->
    type_func.Consistent f_default f_array f_struct f_union f_members cenv (@type_func.Env A f_default f_array f_struct f_union f_members (composite_reorder.rebuild_composite_elements cenv)).
Proof.
  intros.
  apply type_func.Consistency.
  + apply composite_reorder.RCT_Permutation.
  + apply composite_reorder.RCT_ordered; auto.
Qed.

Corollary composite_reorder_complete {A: Type}:
  forall cenv f_default f_array f_struct f_union f_members,
    type_func.Complete cenv (@type_func.Env A f_default f_array f_struct f_union f_members (composite_reorder.rebuild_composite_elements cenv)).
Proof.
  intros.
  apply type_func.Completeness.
  apply composite_reorder.RCT_Permutation.
Qed.

Fixpoint plain_members (m: members) : bool :=
 match m with
 | Member_plain i t :: m' => plain_members m'
 | _ :: _ => false
 | nil => true
 end.

Section cuof.

Context (cenv: composite_env).

Fixpoint complete_legal_cosu_type t :=
  match t with
  | Tarray t' _ _ => complete_legal_cosu_type t'
  | Tstruct id _ => match cenv ! id with
                    | Some co => match co_su co with
                                 | Struct => plain_members (co_members co)
                                 | Union => false
                                 end
                    | _ => false
                    end
  | Tunion id _ => match cenv ! id with
                   | Some co => match co_su co with
                                | Struct => false
                                | Union => plain_members (co_members co)
                                end
                   | _ => false
                   end
  | Tfunction _ _ _
  | Tvoid => false
  | _ => true
  end.

Fixpoint composite_complete_legal_cosu_type (m: members): bool :=
  match m with
  | nil => true
  | m1 :: m' => complete_legal_cosu_type (type_member m1) && composite_complete_legal_cosu_type m'
  end.

Definition composite_env_complete_legal_cosu_type: Prop :=
  forall (id : positive) (co : composite),
    cenv ! id = Some co -> composite_complete_legal_cosu_type (co_members co) = true.

End cuof.

Lemma complete_legal_cosu_type_complete_type: forall cenv: composite_env,
  forall t,
    complete_legal_cosu_type cenv t = true ->
    complete_type cenv t = true.
Proof.
  intros.
  induction t; auto.
  + simpl in *.
    destruct (cenv ! i); auto.
  + simpl in *.
    destruct (cenv ! i); auto.
Qed.


Require Import ABS.Rel.Definitions.
Require Import ABS.Rel.Adequacy.
Require Import ABS.Rel.Compat.
Require Import ABS.Rel.Parametricity.
Require Import ABS.Lang.BindingsFacts.
Require Import ABS.Lang.Static.
Require Import ABS.Lang.StaticFacts.
Require Import ABS.Lang.Context.
Require Import FunctionalExtensionality.

Implicit Types EV HV V L : Set.

Section section_congruence.

Hint Resolve ok_wf_lbl ok_wf_ty ok_wf_eff ok_wf_tm ok_wf_hd.
Hint Resolve XLEnv_inv_wf_XEnv.
Hint Resolve EV_map_XLEnv HV_map_XLEnv LEnv_lookup_inv_binds.
Hint Constructors ok_lbl.
Hint Unfold compose.

Fixpoint
congruence_tm n EV HV V L (t₁ t₂ : tm EV HV V L)
(Π : LEnv EV HV L) (P : HV → F) (Γ : V → ty EV HV L)
(T : ty EV HV L) (𝓔 : eff EV HV L) (T0 : ty0)
C (OK_C : ok_ctx C P Γ Π T 𝓔 T0) {struct OK_C} :
n ⊨ 【 Π P Γ ⊢ t₁ ≼ˡᵒᵍ t₂ : T # 𝓔 】 →
n ⊨ 【 LEnv_empty ∅→ ∅→ ⊢ (ctx_plug C t₁) ≼ˡᵒᵍ (ctx_plug C t₂) : T0 # [] 】
.
Proof.
intro H.
destruct OK_C as [
  |
  |
  |
  ???? C s ??????? OK_C OK_s |
  ???? C s ??????? OK_C OK_s |
  ???? C ????? OK_C |
  ???? C P Γ Π 𝔽 T T'' OK_C |
  ???? C P Γ Π S T E T'' OK_C |
  ???? C E P Γ Π T ? T'' OK_C OK_E |
  ???? C h P Γ Π 𝔽 T 𝓔 T'' OK_C OK_h |
  ???? C t 𝔽 β P Γ Π T 𝓔 T' T'' h ? OK_C OK_t |
  ???? C s P Γ Π S T E T'' OK_C OK_s |
  ???? C t P Γ Π S T E T'' OK_C OK_t |
  ???? C P Γ Π T1 E1 T2 E2 T'' OK_C
] ; simpl ctx_plug.
+ apply H ; rewrite empty_def ; try rewrite keys_def ;
    try rewrite map_nil ; simpl ; shelve.
+ eapply congruence_tm ; try exact OK_C.
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ ; simpl.
  eapply compat_tm_down ; [intro;eauto|eauto|eauto|eauto|].
  intros X FrX.
  ispecialize H (Ξ & X ~ (L_bind_ty f T, L_bind_eff f E)).
  ispecialize H (env_ext f (lid_f X)).
  ispecialize H.
  { iintro_prop ; constructor ; eauto. }
  simpl in H.
  unshelve erewrite L_bind_map_ty, L_map_ty_id in H ; [eauto|eauto| |eauto|].
  unshelve erewrite L_bind_map_eff, L_map_eff_id in H ; [eauto|eauto| |eauto|].
  repeat erewrite L_bind_bind_tm with (g := env_ext f (lid_f X)).
  match goal with
  | [ H : ?n ⊨ ⟦ _ _ ?Γ ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ |- ?n ⊨ ⟦ _ _ ?Γ' ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ ] =>
    replace Γ' with Γ ; [ exact H | ]
  end.
  { extensionality x ; unfold compose.
    unshelve erewrite L_bind_map_ty, L_map_ty_id ; eauto.
    intro ; erewrite L_map_lid_id ; eauto.
  }
  { intro α ; destruct α ; simpl ; [auto|].
    unshelve erewrite L_bind_map_lid, L_map_lid_id, L_bind_lid_id ; auto.
  }
  { intro α ; destruct α ; simpl ; [auto|].
    unshelve erewrite L_bind_map_lid, L_map_lid_id, L_bind_lid_id ; auto.
  }
  { intro ; erewrite L_map_lid_id ; auto. }
  { intro ; erewrite L_map_lid_id ; auto. }
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl ; eapply compat_tm_val.
  repeat unshelve erewrite L_bind_map_ty, L_bind_ty_id, L_map_ty_id ;
    [auto|auto|auto|auto| |auto|auto|auto|auto|auto|auto].
  eapply compat_val_up ; [reflexivity|reflexivity|reflexivity|eauto|].
  destruct (f β) as [|X] eqn:EQ_fβ ; simpl ; [auto|].
  eapply compat_hd_def ; [eauto|eauto|].
  match goal with
  | [ H : ?n ⊨ ⟦ _ _ ?Γ ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ |- ?n ⊨ ⟦ _ _ ?Γ' ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ ] =>
    replace Γ' with Γ ; [ exact H | ]
  end.
  extensionality x ; unfold compose.
  destruct x as [|[|x]] ; simpl.
  - unshelve erewrite L_bind_map_ty, L_bind_ty_id, L_map_ty_id ; eauto.
  - unshelve erewrite L_bind_map_ty, L_bind_ty_id, L_map_ty_id ; eauto.
  - auto.
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl ; eapply compat_tm_let ; [|exact H].
  apply parametricity_tm_n ; [ eauto | intro ; eauto | ].
  eapply ok_wf_tm in OK_s ; [|eauto].
  match goal with
  | [ H : wf_tm ?Ξ ?P ?Γ ?t ?T ?E |- wf_tm ?Ξ ?P ?Γ' ?t ?T ?E ] =>
    replace Γ' with Γ ; [ exact H | ]
  end.
  extensionality x ; crush.
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl ; apply compat_tm_let with (S := L_bind_ty f S).
  { match goal with
    | [ H : ?n ⊨ ⟦ _ _ ?Γ ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ |- ?n ⊨ ⟦ _ _ ?Γ' ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ ] =>
      replace Γ' with Γ ; [ exact H | ]
    end.
    extensionality x ; crush.
  }
  apply parametricity_tm_n ; [ eauto | intro ; eauto | eauto ].
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-* ; apply compat_tm_val ; apply compat_val_efun.
  match goal with
  | [ H : ?n ⊨ ⟦ _ _ ?Γ ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ |- ?n ⊨ ⟦ _ _ ?Γ' ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ ] =>
    replace Γ' with Γ ; [ exact H | ]
  end.
  extensionality x ; unfold compose.
  rewrite L_bind_EV_map_ty ; auto.
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-* ; apply compat_tm_val ; apply compat_val_hfun.
  match goal with
  | [ H : ?n ⊨ ⟦ _ _ ?Γ ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ |- ?n ⊨ ⟦ _ _ ?Γ' ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ ] =>
    replace Γ' with Γ ; [ exact H | ]
  end.
  extensionality x ; unfold compose.
  rewrite L_bind_HV_map_ty ; auto.
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-* ; apply compat_tm_val ; apply compat_val_fun.
  match goal with
  | [ H : ?n ⊨ ⟦ _ _ ?Γ ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ |- ?n ⊨ ⟦ _ _ ?Γ' ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ ] =>
    replace Γ' with Γ ; [ exact H | ]
  end.
  extensionality x ; auto.
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-*.
  erewrite <- EV_L_bind_ty ; [ eapply compat_tm_eapp ; eauto | auto ].
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-*.
  erewrite <- HV_L_bind_ty with (g₂ := HV_substfun _) ; [|auto].
  eapply compat_tm_happ ; [reflexivity|reflexivity| |exact H|].
  - rewrite lbl_L_bind_hd.
    eapply ok_wf_lbl ; [ eauto | ].
    inversion OK_h ; crush.
  - eapply parametricity_hd_n ; [eauto|intro ; eauto|eauto].
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  destruct (f β) as [|X] eqn:EQ_fβ ; simpl ; [auto|].
  erewrite <- HV_L_bind_ty with (g₂ := HV_substfun _) ; [|auto].
  rewrite EQ_fβ.
  erewrite HV_bind_ty_eq
    with (g := HV_substfun (hd_def 𝔽 (lid_f X) (L_bind_tm f t₁))) ;
  [ | destruct p ; simpl ; [ rewrite lbl_L_bind_hd | ] ; crush ].
  match goal with
  | [ H : LEnv_lookup β _ = _ |- _ ] =>
    eapply LEnv_lookup_inv_binds in H as Binds ; eauto
  end.
  eapply compat_tm_happ ; [reflexivity|reflexivity| | |].
  - constructor.
    eauto using get_some_inv.
  - eapply parametricity_tm_n ; [eauto|intro ; eauto|].
    eapply ok_wf_tm in OK_t ; eauto.
  - eapply compat_hd_def ; [eauto|eauto|].
    match goal with
    | [ H : ?n ⊨ ⟦ _ _ ?Γ ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ |- ?n ⊨ ⟦ _ _ ?Γ' ⊢ _ ≼ˡᵒᵍ _ : _ # _ ⟧ ] =>
      replace Γ' with Γ ; [ exact H | ]
    end.
    extensionality x ; unfold compose.
    destruct x as [|[|x]] ; simpl ; [| |auto].
    * unshelve erewrite L_bind_map_ty, L_bind_ty_id, L_map_ty_id ; eauto.
    * unshelve erewrite L_bind_map_ty, L_bind_ty_id, L_map_ty_id ; eauto.
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-* ; eapply compat_tm_app ; [exact H|].
  eapply parametricity_tm_n ; [eauto|intro ; eauto|eauto].
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  simpl in H|-* ; eapply compat_tm_app ; [|exact H].
  eapply parametricity_tm_n ; [eauto|intro ; eauto|].
  eapply ok_wf_tm in OK_t ; eauto.
+ eapply congruence_tm ; [exact OK_C|].
  iintro Ξ ; iintro f ; iintro HΞΠ ; ielim_prop HΞΠ.
  iespecialize H ; ispecialize H ; [eauto|].
  eapply compat_sub with (𝓔 := L_bind_eff f E1) ; eauto using subty_st, L_bind_se.
Qed.

End section_congruence.

Section section_soundness.

Hint Rewrite dom_empty union_empty_l Xs_ctx_plug.

Theorem soundness EV HV V L (t₁ t₂ : tm EV HV V L) (Closed_t₁ : Xs_tm t₁ = \{})
(Π : LEnv EV HV L) (P : HV → F) (Γ : V → ty EV HV L)
(T : ty EV HV L) (𝓔 : eff EV HV L) :
⊨ 【 Π P Γ ⊢ t₁ ≼ˡᵒᵍ t₂ : T # 𝓔 】 →
【 Π P Γ ⊢ t₁ ≼ᶜᵗˣ t₂ : T # 𝓔 】.
Proof.
intro Ht.
intros C T0 OK_C Closed_C.
eapply adequacy ; [ | crush ].
intro n.
eapply congruence_tm with (n := n) in Ht as HCt ; [|exact OK_C].
iespecialize HCt.
ispecialize HCt ; [ iintro_prop ; constructor | ].
erewrite L_bind_tm_id, L_bind_tm_id, L_bind_ty_id, L_bind_eff_id in HCt ;
  [|auto|auto|auto|auto].
replace (L_bind_ty ∅→ ∘ ∅→) with (∅→ : ∅ → ty0) in HCt ; [|extensionality x ; auto].
exact HCt.
Qed.

End section_soundness.


Require Import Coq.Lists.List.
Require Import Logic.LogicGenerator.Utils.
Require Import Logic.LogicGenerator.ConfigLang.

Import ListNotations.

Definition how_connectives :=
  [ primitive_connective join;
    FROM_model_TO_impp;
    FROM_join_TO_sepcon].

Definition how_judgements :=
  [ FROM_model_TO_provable ].

Definition transparent_names :=
  [ provable : parameter].

Definition primitive_rule_classes :=
  [ join_is_SA ].


From mathcomp
Require Import ssreflect ssrfun fingroup.

Require Import commfingroup.
Require Import Cheerios.Cheerios.
Require Import serializable.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GroupScope.

Module SerializableCommFinGroup.

Structure mixin_of (gT : commFinGroupType) := Mixin {
  ser_gT : gT -> IOStreamWriter.t ;
  deser_gT : ByteListReader.t gT ;
  _ : serialize_deserialize_id_spec ser_gT deser_gT
}.

Structure type : Type := Pack {
  sort : commFinGroupType;
  _ : mixin_of sort
}.

Definition mixin T :=
  let: Pack _ m := T return mixin_of (sort T) in m.

Module Import Exports.
Coercion sort : type >-> commFinGroupType.
Coercion mixin : type >-> mixin_of.
Notation serializableCommFinGroupType := type.
Notation SerializableCommFinGroupMixin := Mixin.
Notation SerializableCommFinGroupType T m := (@Pack T m).
End Exports.

End SerializableCommFinGroup.
Export SerializableCommFinGroup.Exports.

Section SerializableCommGroupDefs.

Variable gT : serializableCommFinGroupType.

Lemma ser_gT_deser_gT_id :
  serialize_deserialize_id_spec (SerializableCommFinGroup.ser_gT gT) (SerializableCommFinGroup.deser_gT gT).
Proof. by case: gT => ? []. Qed.

Definition serCFG_serializableMixin := SerializableMixin ser_gT_deser_gT_id.

Canonical serCFG_serializableType := Eval hnf in SerializableType gT serCFG_serializableMixin.

End SerializableCommGroupDefs.