Require Import Ctl.Paths.
Require Import Ctl.Definition.
Require Import Ctl.Basic.
Open Scope tprop_scope.

Require Import Setoid.
Require Import Glib.Glib.

Ltac tentails :=
  match goal with
  | |- ?R @?s ⊨ ⟨?P⟩ => change_no_check (P s)
  end.

Tactic Notation "tentails!" :=
  cbn;
  repeat match goal with
  | |- ?R @?s ⊨ ?P => unfold P
  end;
  change_no_check (?R @?s ⊨ ⟨?P⟩) with (P s);
  cbn.

Tactic Notation "tentails" "in" hyp(H) :=
  change (?R @?s ⊨ ⟨?P⟩) with (P s) in H.

Tactic Notation "tentails!" "in" hyp(H) :=
  cbn in H;
  repeat match type of H with
  | ?R @?s ⊨ ?P => unfold P in H
  end;
  progress change (?R @?s ⊨ ⟨?P⟩) with (P s) in H;
  cbn in H.

Tactic Notation "tentails" "in" "*" :=
  tentails;
  repeat match goal with
  | H : _ |- _ => tentails in H
  end.

Tactic Notation "tentails!" "in" "*" :=
  tentails!;
  repeat match goal with
  | H : _ |- _ => tentails! in H
  end.

(*
Tactic Notation "unfold_timpl" :=
  progress change_no_check (?R @?s ⊨ ?p ⟶ ?q) with (R @s ⊨ p -> R @s ⊨ q).
Tactic Notation "unfold_timpl" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?p ⟶ ?q) with (R @s ⊨ p -> R @s ⊨ q) in H.

Tactic Notation "unfold_tnot" :=
  progress change_no_check (?R @?s ⊨ ¬?P) with (R @s ⊭ P).
Tactic Notation "unfold_tnot" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ¬?P) with (R @s ⊭ P) in H.

Tactic Notation "unfold_tconj" :=
  progress change_no_check (?R @?s ⊨ ?P ∧ ?Q) with (R @s ⊨ P /\ R @s ⊨ Q).
Tactic Notation "unfold_tconj" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?P ∧ ?Q) with (R @s ⊨ P /\ R @s ⊨ Q) in H.

Tactic Notation "unfold_tbiimpl" :=
  progress change_no_check (?R @?s ⊨ ?P ⟷ ?Q) with (R @s ⊨ P <-> R @s ⊨ Q).
Tactic Notation "unfold_tbiimpl" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?P ⟷ ?Q) with (R @s ⊨ P <-> R @s ⊨ Q) in H.

Tactic Notation "unfold_AX" :=
  progress change_no_check (?R @?s ⊨ AX ?P) with (forall s', R s s' -> R @s' ⊨ P).
Tactic Notation "unfold_AX" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ AX ?P) with (forall s', R s s' -> R @s' ⊨ P) in H.

Tactic Notation "unfold_AG" :=
  progress change_no_check (?R @?s ⊨ AG ?P) with
    (forall n (p: path R n s) s', in_path s' p -> R @s' ⊨ P).
Tactic Notation "unfold_AG" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ AG ?P) with
    (forall n (p: path R n s) s', in_path s' p -> R @s' ⊨ P) in H.
*)

Tactic Notation "unfold_timpl" :=
  progress change_no_check (?R @?s ⊨ ?p ⟶ ?q) with (R @s ⊨ p -> R @s ⊨ q) +
  rewrite rew_timpl +
  setoid_rewrite rew_timpl.
Tactic Notation "unfold_timpl" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?p ⟶ ?q) with (R @s ⊨ p -> R @s ⊨ q) in H +
  rewrite rew_timpl in H +
  setoid_rewrite rew_timpl in H.

Tactic Notation "unfold_tnot" :=
  progress change_no_check (?R @?s ⊨ ¬?P) with (R @s ⊭ P) +
  rewrite rew_tnot +
  setoid_rewrite rew_tnot.
Tactic Notation "unfold_tnot" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ¬?P) with (R @s ⊭ P) in H +
  rewrite rew_tnot in H +
  setoid_rewrite rew_tnot in H.

Tactic Notation "unfold_tconj" :=
  progress change_no_check (?R @?s ⊨ ?P ∧ ?Q) with (R @s ⊨ P /\ R @s ⊨ Q) +
  rewrite rew_tconj +
  setoid_rewrite rew_tconj.
Tactic Notation "unfold_tconj" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?P ∧ ?Q) with (R @s ⊨ P /\ R @s ⊨ Q) in H +
  rewrite rew_tconj in H +
  setoid_rewrite rew_tconj in H.

Tactic Notation "unfold_tdisj" :=
  progress change_no_check (?R @?s ⊨ ?P ∨ ?Q) with (R @s ⊨ P \/ R @s ⊨ Q) +
  rewrite rew_tdisj +
  setoid_rewrite rew_tdisj.
Tactic Notation "unfold_tdisj" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?P ∨ ?Q) with (R @s ⊨ P ∨ R @s ⊨ Q) in H +
  rewrite rew_tdisj in H +
  setoid_rewrite rew_tdisj in H.

Tactic Notation "unfold_tbiimpl" :=
  progress change_no_check (?R @?s ⊨ ?P ⟷ ?Q) with (R @s ⊨ P <-> R @s ⊨ Q) +
  rewrite rew_tbiimpl +
  setoid_rewrite rew_tbiimpl.
Tactic Notation "unfold_tbiimpl" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ?P ⟷ ?Q) with (R @s ⊨ P <-> R @s ⊨ Q) in H +
  rewrite rew_tbiimpl in H +
  setoid_rewrite rew_tbiimpl in H.

Tactic Notation "unfold_tlift" :=
  progress change_no_check (?R @?s ⊨ ⟨?P⟩) with (P s) +
  rewrite rew_tlift +
  setoid_rewrite rew_tlift.
Tactic Notation "unfold_tlift" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ ⟨?P⟩) with (P s) in H +
  rewrite rew_tlift in H +
  setoid_rewrite rew_tlift in H.

Tactic Notation "unfold_AX" :=
  progress change_no_check (?R @?s ⊨ AX ?P) with (forall s', R s s' -> R @s' ⊨ P) +
  rewrite rew_AX +
  setoid_rewrite rew_AX.
Tactic Notation "unfold_AX" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ AX ?P) with (forall s', R s s' -> R @s' ⊨ P) in H +
  rewrite rew_AX in H +
  setoid_rewrite rew_AX in H.

Tactic Notation "unfold_EX" :=
  progress change_no_check (?R @?s ⊨ EX ?P) with (exists s', R s s' /\ R @s' ⊨ P) +
  rewrite rew_EX +
  setoid_rewrite rew_EX.
Tactic Notation "unfold_EX" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ EX ?P) with (exists s', R s s' /\ R @s' ⊨ P) in H +
  rewrite rew_EX in H +
  setoid_rewrite rew_EX in H.

Tactic Notation "unfold_AG" :=
  progress change_no_check (?R @?s ⊨ AG ?P) with
    (forall (p: path R s) s', in_path s' p -> R @s' ⊨ P) +
  rewrite rew_AG +
  setoid_rewrite rew_AG.
Tactic Notation "unfold_AG" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ AG ?P) with
    (forall (p: path R s) s', in_path s' p -> R @s' ⊨ P) in H +
  rewrite rew_AG in H +
  setoid_rewrite rew_AG in H.

Tactic Notation "unfold_EG" :=
  progress change_no_check (?R @?s ⊨ EG ?P) with
    (exists p: path R s, forall s', in_path s' p -> R @s' ⊨ P) +
  rewrite rew_EG +
  setoid_rewrite rew_EG.
Tactic Notation "unfold_EG" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ EG ?P) with
    (exists p: path R s, forall s', in_path s' p -> R @s' ⊨ P) in H +
  rewrite rew_EG in H +
  setoid_rewrite rew_EG in H.

Tactic Notation "unfold_AF" :=
  progress change_no_check (?R @?s ⊨ AF ?P) with
    (forall p: path R s, exists s', in_path s' p /\ R @s' ⊨ P) +
  rewrite rew_AF +
  setoid_rewrite rew_AF.
Tactic Notation "unfold_AF" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ AF ?P) with
    (forall p: path R s, exists s', in_path s' p /\ R @s' ⊨ P) in H +
  rewrite rew_AF in H +
  setoid_rewrite rew_AF in H.

Tactic Notation "unfold_EF" :=
  progress change_no_check (?R @?s ⊨ EF ?P) with
    (exists (p: path R s) s', in_path s' p /\ R @s' ⊨ P) +
  rewrite rew_EF +
  setoid_rewrite rew_EF.
Tactic Notation "unfold_EF" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ EF ?P) with
    (exists (p: path R s) s', in_path s' p /\ R @s' ⊨ P) in H +
  rewrite rew_EF in H +
  setoid_rewrite rew_EF in H.

Tactic Notation "unfold_AU" :=
  progress change_no_check (?R @?s ⊨ A[?P U ?Q]) with
    (forall p: path R s, exists sQ i,
      in_path_at sQ i p /\
      (forall sP, in_path_before sP i p -> R @sP ⊨ P) /\
      R @sQ ⊨ Q) +
  rewrite rew_AU +
  setoid_rewrite rew_AU.
Tactic Notation "unfold_AU" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ A[?P U ?Q]) with
    (forall p: path R s, exists sQ i,
      in_path_at sQ i p /\
      (forall sP, in_path_before sP i p -> R @sP ⊨ P) /\
      R @sQ ⊨ Q) in H +
  rewrite rew_AU in H +
  setoid_rewrite rew_AU in H.

Tactic Notation "unfold_EU" :=
  progress change_no_check (?R @?s ⊨ E[?P U ?Q]) with
    (exists (p: path R s) sQ i,
      in_path_at sQ i p /\
      (forall sP, in_path_before sP i p -> R @sP ⊨ P) /\
      R @sQ ⊨ Q) +
  rewrite rew_EU +
  setoid_rewrite rew_EU.
Tactic Notation "unfold_EU" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ E[?P U ?Q]) with
    (exists (p: path R s) sQ i,
      in_path_at sQ i p /\
      (forall sP, in_path_before sP i p -> R @sP ⊨ P) /\
      R @sQ ⊨ Q) in H +
  rewrite rew_EU in H +
  setoid_rewrite rew_EU in H.

Tactic Notation "unfold_AW" :=
  progress change_no_check (?R @?s ⊨ A[?P W ?Q]) with
    (forall p: path R s,
      (forall s', in_path s' p -> R @s' ⊨ P ∧ ¬Q) \/
      (exists sQ i,
        in_path_at sQ i p /\
        (forall sP, in_path_before sP i p -> R @sP ⊨ P) /\
        R @sQ ⊨ Q)) +
  rewrite rew_AW +
  setoid_rewrite rew_AW.
Tactic Notation "unfold_AW" "in" hyp(H) :=
  progress change_no_check (?R @?s ⊨ A[?P W ?Q]) with
    (forall p: path R s,
      (forall s', in_path s' p -> R @s' ⊨ P ∧ ¬Q) \/
      (exists sQ i,
        in_path_at sQ i p /\
        (forall sP, in_path_before sP i p -> R @sP ⊨ P) /\
        R @sQ ⊨ Q)) in H +
  rewrite rew_AW in H +
  setoid_rewrite rew_AW in H.

(* tintro - intro a timpl *)

Tactic Notation "tintro" :=
  match goal with
  | |- _ @_ ⊨ ¬_ => unfold_tnot; intro
  | |- _ @_ ⊨ _ ⟶ _ => unfold_timpl; intro
  end.

Tactic Notation "tintro" ident(x) :=
  match goal with
  | |- _ @_ ⊨ ¬_ => unfold_tnot; intro x
  | |- _ @_ ⊨ _ ⟶ _ => unfold_timpl; intro x
  end.

Tactic Notation "tintros" :=
  repeat tintro.
Tactic Notation "tintros" ident(x1) :=
  tintro x1.
Tactic Notation "tintros" ident(x1) ident(x2) :=
  tintro x1; tintros x2.
Tactic Notation "tintros" ident(x1) ident(x2) ident(x3) :=
  tintro x1; tintros x2 x3.
Tactic Notation "tintros" ident(x1) ident(x2) ident(x3) ident(x4) :=
  tintro x1; tintros x2 x3 x4.
Tactic Notation "tintros" ident(x1) ident(x2) ident(x3) ident(x4) ident(x5) :=
  tintro x1; tintros x2 x3 x4 x5.
Tactic Notation "tintros" ident(x1) ident(x2) ident(x3) ident(x4) ident(x6) :=
  tintro x1; tintros x2 x3 x4 x5 x6.

(* tsimpl - simple a tprop *)

Tactic Notation "tsimpl_step" :=
  unfold_timpl +
  unfold_tbiimpl +
  unfold_tnot +
  unfold_AX +
  unfold_EX +
  unfold_AG +
  unfold_EG +
  unfold_AF +
  unfold_EF +
  unfold_AU +
  unfold_EU +
  unfold_AW.

Tactic Notation "tsimpl_step" "in" hyp(H) :=
  unfold_timpl in H +
  unfold_tbiimpl in H +
  unfold_tnot in H +
  unfold_AX in H +
  unfold_EX in H +
  unfold_AG in H +
  unfold_EG in H +
  unfold_AF in H +
  unfold_EF in H +
  unfold_AU in H +
  unfold_EU in H +
  unfold_AW in H.

Tactic Notation "tsimpl" := repeat tsimpl_step.
Tactic Notation "tsimpl" "in" hyp(H) := repeat tsimpl_step in H.
Tactic Notation "tsimpl" "in" "*" :=
  try tsimpl;
  repeat match goal with
  | H: _ @_ ⊨ _ |- _ => tsimpl in H
  end.

(* tapply: carefully unfolds TProp hypothesis just enough to use apply *)

Ltac _tapply_unfold_step H :=
  match type of H with
  | _ @_ ⊨ _ ⟶ _ =>
      unfold_timpl in H
  | _ @_ ⊨ ¬ _ =>
      unfold_tnot in H
  | _ @_ ⊨ _ ⟷ _ =>
      unfold_tbiimpl in H
  | _ @_ ⊨ AX _ =>
      unfold_AX in H
  | _ @_ ⊨ AG _ =>
      unfold_AG in H
  end +
  unfold_timpl in H +
  unfold_tnot in H +
  unfold_tbiimpl in H +
  unfold_AX in H +
  unfold_AG in H.

Ltac _tapply_aux H :=
  apply H + (_tapply_unfold_step H; _tapply_aux H).

Ltac _tapply_aux_in H H2 :=
  apply H in H2 + (_tapply_unfold_step H; _tapply_aux_in H H2).

Ltac _etapply_aux H :=
  eapply H + (_tapply_unfold_step H; _etapply_aux H).

Ltac _etapply_aux_in H H2 :=
  eapply H in H2 + (_tapply_unfold_step H; _etapply_aux_in H H2).

Tactic Notation "tapply" uconstr(c) :=
  let Htemp := fresh in
  eset (Htemp := c);
  _tapply_aux Htemp;
  clear Htemp.

Tactic Notation "tapply" uconstr(c) "in" hyp(H) :=
  let Htemp := fresh in
  eset (Htemp := c);
  _tapply_aux_in Htemp H;
  clear Htemp.

Tactic Notation "etapply" uconstr(c) :=
  let Htemp := fresh in
  eset (Htemp := c);
  _etapply_aux Htemp;
  clear Htemp.

Tactic Notation "etapply" uconstr(c) "in" hyp(H) :=
  let Htemp := fresh in
  eset (Htemp := c);
  _etapply_aux_in Htemp H;
  clear Htemp.

Tactic Notation "tapplyc" hyp(H) :=
  tapply H; clear H.
Tactic Notation "tapplyc" hyp(H) "in" hyp(H2) :=
  tapply H in H2; clear H.
Tactic Notation "etapplyc" hyp(H) :=
  etapply H; clear H.
Tactic Notation "etapplyc" hyp(H) "in" hyp(H2) :=
  etapply H in H2; clear H.

Close Scope tprop_scope.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import Equivalence.
Require Import Morphisms.
Require Import Setoid.
Require Import EquivDec.
Require Import Program.
Require Import String.
Require Import List.
Require Import Arith.
Require Import Utils.
Require Import DataRuntime.
Require Import DData.
Require Import DDataNorm.
Require Import DNNRCBase.

Section DNNRCBaseEq.
  Context {fruntime:foreign_runtime}.
  Context {A plug_type:Set}.
  Context {eqdec:EqDec A eq}.
  Context {plug:AlgPlug plug_type}.

  (** Equivalence between expressions in the
      Distributed Nested Relational Calculus *)

  Definition dnnrc_base_eq (e1 e2:@dnnrc_base _ A plug_type) : Prop :=
    forall (h:brand_relation_t) (dcenv denv:dbindings),
      Forall (ddata_normalized h) (map snd dcenv) ->
      Forall (ddata_normalized h) (map snd denv) ->
      dnnrc_base_eval h dcenv denv e1 = dnnrc_base_eval h dcenv denv e2.

  Global Instance dnnrc_base_equiv : Equivalence dnnrc_base_eq.
  Proof.
    constructor.
    - unfold Reflexive, dnnrc_base_eq.
      intros; reflexivity.
    - unfold Symmetric, dnnrc_base_eq.
      intros; rewrite (H _ dcenv denv) by trivial; reflexivity.
    - unfold Transitive, dnnrc_base_eq.
      intros; rewrite (H _ dcenv denv) by trivial;
      rewrite (H0 _ dcenv denv) by trivial; reflexivity.
  Qed.

  (* all the dnnrc_base constructors are proper wrt. equivalence *)

  (* DNNRCGetConstant *)
  Global Instance dgetconstant_proper : Proper (eq ==> eq ==> dnnrc_base_eq) DNNRCGetConstant.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; subst; reflexivity.
  Qed.

  (* DNNRCVar *)
  Global Instance dvar_proper : Proper (eq ==> eq ==> dnnrc_base_eq) DNNRCVar.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; subst; reflexivity.
  Qed.

  (* DNNRCConst *)

  Global Instance dconst_proper : Proper (eq ==> eq ==> dnnrc_base_eq) DNNRCConst.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; subst; reflexivity.
  Qed.

  (* DNNRCBinop *)

  Global Instance dbinary_op_proper : Proper (eq ==> binary_op_eq ==> dnnrc_base_eq ==> dnnrc_base_eq ==> dnnrc_base_eq) DNNRCBinop.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl. subst.
    rewrite H1 by trivial.
    rewrite H2 by trivial.
    case_eq (dnnrc_base_eval h dcenv denv y1);
      case_eq (dnnrc_base_eval h dcenv denv y2); intros; simpl; trivial.
    destruct d0; destruct d; try reflexivity; simpl.
    rewrite H0; [reflexivity| | ].
    apply (dnnrc_base_eval_normalized_local h dcenv denv y1); try assumption.
    apply (dnnrc_base_eval_normalized_local h dcenv denv y1); try assumption.
  Qed.

  (* DNNRCUnnop *)

  Global Instance dunary_op_proper : Proper (eq ==> unary_op_eq ==> dnnrc_base_eq ==> dnnrc_base_eq) DNNRCUnop.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl. subst.
    rewrite H1 by trivial.
    case_eq (dnnrc_base_eval h dcenv denv y1); simpl; trivial; intros.
    destruct d; try reflexivity; simpl.
    rewrite H0; [reflexivity| ].
    apply (dnnrc_base_eval_normalized_local h dcenv denv y1); try assumption.
  Qed.

  (* DNNRCLet *)

  Global Instance dlet_proper : Proper (eq ==> eq ==> dnnrc_base_eq ==> dnnrc_base_eq ==> dnnrc_base_eq) DNNRCLet.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl. rewrite H0; clear H0; rewrite H1 by trivial; clear H1.
    case_eq (dnnrc_base_eval h dcenv denv y1); simpl; trivial; intros.
    rewrite H2; eauto.
    constructor; eauto.
    simpl.
    eapply (dnnrc_base_eval_normalized h dcenv denv y1); eauto.
  Qed.

  (* DNNRCFor *)

  Hint Resolve data_normalized_dcoll_in : qcert.

  Global Instance dfor_proper : Proper (eq ==> eq ==> dnnrc_base_eq ==> dnnrc_base_eq ==> dnnrc_base_eq) DNNRCFor.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl. rewrite H1 by trivial; clear H1. subst.
    case_eq (dnnrc_base_eval h dcenv denv y1); simpl; trivial; intros.
    destruct d; try reflexivity; simpl.
    { destruct d; try reflexivity; simpl.
      f_equal.
      apply lift_map_ext; intros.
      rewrite H2; simpl; eauto.
      constructor; [|assumption].
      assert (ddata_normalized h (Dlocal (dcoll l))).
      - eapply (dnnrc_base_eval_normalized _ dcenv denv); eauto.
      - inversion H1; subst; clear H1.
        econstructor.
        inversion H6; subst; clear H6.
        rewrite Forall_forall in H5.
        auto. }
    { f_equal.
      apply lift_map_ext; intros.
      rewrite H2; simpl; eauto.
      constructor; [|assumption].
      assert (ddata_normalized h (Ddistr l)).
      - eapply (dnnrc_base_eval_normalized _ dcenv denv); eauto.
      - inversion H1; subst; clear H1.
        constructor.
        rewrite Forall_forall in H6.
        auto. }
  Qed.

  (* DNNRCIf *)

  Global Instance dif_proper : Proper (eq ==> dnnrc_base_eq ==> dnnrc_base_eq ==> dnnrc_base_eq ==> dnnrc_base_eq) DNNRCIf.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl. subst. rewrite H0 by trivial; clear H0.
    case_eq (dnnrc_base_eval h dcenv denv y0); simpl; trivial; intros.
    destruct d; try reflexivity; simpl.
    destruct d; try reflexivity; simpl.
    destruct b; eauto.
  Qed.

  (* DNNRCEither *)
  Global Instance deither_proper : Proper (eq ==> dnnrc_base_eq ==> eq ==> dnnrc_base_eq ==> eq ==> dnnrc_base_eq ==> dnnrc_base_eq) DNNRCEither.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl. subst.
    rewrite H0 by trivial.
    match_case; intros ? eqq1. match_destr.
    - apply H2; simpl; eauto.
      rewrite Forall_forall; intros.
      inversion H; subst.
      unfold olift, checkLocal in eqq1.
      case_eq (dnnrc_base_eval h dcenv denv y0); intros; rewrite H1 in eqq1; try congruence;
      destruct d0; try congruence; inversion eqq1; subst.
      assert (ddata_normalized h (Dlocal (dleft d))).
      apply (@dnnrc_base_eval_normalized _ _ _ h dcenv _ denv y0); assumption.
      inversion H3; subst; clear H3.
      inversion H8; subst; clear H8.
      constructor; assumption.
      rewrite Forall_forall in H6. auto.
    - apply H4; simpl; eauto.
      rewrite Forall_forall; intros.
      inversion H; subst.
      unfold olift, checkLocal in eqq1.
      case_eq (dnnrc_base_eval h dcenv denv y0); intros; rewrite H1 in eqq1; try congruence;
      destruct d0; try congruence; inversion eqq1; subst.
      assert (ddata_normalized h (Dlocal (dright d))).
      apply (@dnnrc_base_eval_normalized _ _ _ h dcenv plug denv y0); assumption.
      inversion H3; subst; clear H3.
      inversion H8; subst; clear H8.
      constructor; assumption.
      rewrite Forall_forall in H6. auto.
  Qed.

  (* DNNRCGroupBy *)
  Global Instance dgroupby_proper : Proper (eq ==> eq ==> eq ==> dnnrc_base_eq ==>dnnrc_base_eq) DNNRCGroupBy.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl; subst.
    trivial.
  Qed.

  (* DNNRCCollect *)
  Global Instance dcollect_proper : Proper (eq ==> dnnrc_base_eq ==> dnnrc_base_eq) DNNRCCollect.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl. subst.
    rewrite H0 by trivial.
    reflexivity.
  Qed.

  (* DNNRCDispatch *)
  Global Instance ddispatch_proper : Proper (eq ==> dnnrc_base_eq ==> dnnrc_base_eq) DNNRCDispatch.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl. subst.
    rewrite H0 by trivial.
    reflexivity.
  Qed.

  Global Instance dalg_proper : Proper (eq ==> eq ==> Forall2 (fun n1 n2  => fst n1 = fst n2 /\ dnnrc_base_eq (snd n1) (snd n2)) ==> dnnrc_base_eq) DNNRCAlg.
  Proof.
    unfold Proper, respectful, dnnrc_base_eq.
    intros; simpl; subst.
    cut ((map
         (fun x : string * @dnnrc_base _ A plug_type =>
          match dnnrc_base_eval h dcenv denv (snd x) with
          | Some (Dlocal _) => None
          | Some (Ddistr coll) => Some (fst x, coll)
          | None => None
          end) x1) = (map
         (fun x : string * @dnnrc_base _ A plug_type =>
          match dnnrc_base_eval h dcenv denv (snd x) with
          | Some (Dlocal _) => None
          | Some (Ddistr coll) => Some (fst x, coll)
          | None => None
          end) y1)); [intros eqq; rewrite eqq; trivial | ].
    dependent induction H1; simpl; trivial.
    rewrite IHForall2 by trivial.
    destruct H as [eqq1 eqq2].
    rewrite eqq1, eqq2 by trivial.
    trivial.
  Qed.

End DNNRCBaseEq.

Notation "X ≡ᵈ Y" := (dnnrc_base_eq X Y) (at level 90) : dnnrc_scope.                             (* ≡ = \equiv *)


Require Import AutoSep Wrap StringOps XmlLex SinglyLinkedList Malloc.

Set Implicit Arguments.

(** * Definition of XML search language *)

Inductive pat :=

(* Match CDATA constant. *)
| Cdata (const : string)

(* Record CDATA at this position via two variables. *)
| Var (start len : string)

| TreeVar (start len : string)
(* Like [Var], but grabs a whole XML tree *)

(* Match a specific tag at this level in the XML tree, then continue into its children. *)
| Tag (tag : string) (inner : pat)

(* Match two different patterns at this level of the tree. *)
| Both (p1 p2 : pat)

(* Match one pattern and then another in the part of the XML tree right after the match of the first. *)
| Ordered (p1 p2 : pat).

(** Which program variables appear free in a pattern? *)
Fixpoint freeVar (p : pat) (x : string) : Prop :=
  match p with
    | Cdata _ => False
    | Var start len => x = start \/ x = len
    | TreeVar start len => x = start \/ x = len
    | Tag _ inner => freeVar inner x
    | Both p1 p2 => freeVar p1 x \/ freeVar p2 x
    | Ordered p1 p2 => freeVar p1 x \/ freeVar p2 x
  end.

(** Does the pattern avoid:
  * - double-binding a program variable?
  * - mentioning a huge string constant as a tag name? *)
Fixpoint wf (p : pat) : Prop :=
  match p with
    | Cdata const => goodSize (String.length const)
    | Var start len => start <> len
    | TreeVar start len => start <> len
    | Tag tag inner => goodSize (String.length tag) /\ wf inner
    | Both p1 p2 => wf p1 /\ wf p2 /\ (forall x, freeVar p1 x -> ~freeVar p2 x)
    | Ordered p1 p2 => wf p1 /\ wf p2 /\ (forall x, freeVar p1 x -> ~freeVar p2 x)
  end%type.

(** All pairs of start-length variables in a pattern *)
Fixpoint allCdatas (p : pat) : list (string * string) :=
  match p with
    | Cdata _ => nil
    | Var start len => (start, len) :: nil
    | TreeVar start len => (start, len) :: nil
    | Tag _ inner => allCdatas inner
    | Both p1 p2 => allCdatas p2 ++ allCdatas p1
    | Ordered p1 p2 => allCdatas p2 ++ allCdatas p1
  end.

(** * Compiling patterns into Bedrock chunks *)

Section Pat.
  Variable A : Type.
  Variables invPre : A -> vals -> HProp.
  Variables invPost : A -> vals -> W -> HProp.

  (* Do all start-length pairs in a list denote valid spans in a string of length "len"? *)
  Definition inBounds (cdatas : list (string * string)) (V : vals) :=
    List.Forall (fun p => wordToNat (V (fst p)) + wordToNat (V (snd p)) <= wordToNat (V "len"))%nat
    cdatas.

  (* Are all saved positions in a list valid pointers within a string of a given length? *)
  Definition stackOk (ls : list W) (len : W) :=
    List.Forall (fun x => x <= len) ls.

  (* Precondition and postcondition of search *)
  Definition invar :=
    Al a : A, Al bs, Al ls,
    PRE[V] array8 bs (V "buf") * xmlp (V "len") (V "lex") * sll ls (V "stack") * mallocHeap 0
      * [| length bs = wordToNat (V "len") |] * [| stackOk ls (V "len") |] * invPre a V
    POST[R] array8 bs (V "buf") * mallocHeap 0 * invPost a V R.

  (* Primary invariant, recording that a set of CDATA positions is in bounds. *)
  Definition inv cdatas :=
    Al a : A, Al bs, Al ls,
    PRE[V] array8 bs (V "buf") * xmlp (V "len") (V "lex") * sll ls (V "stack") * mallocHeap 0
      * [| length bs = wordToNat (V "len") |] * [| inBounds cdatas V |]
      * [| stackOk ls (V "len") |] * invPre a V
    POST[R] array8 bs (V "buf") * mallocHeap 0 * invPost a V R.

  (* Intermediate invariant, to use right after reading token position from the lexer. *)
  Definition invP cdatas :=
    Al a : A, Al bs, Al ls,
    PRE[V, R] array8 bs (V "buf") * xmlp' (V "len") R (V "lex") * mallocHeap 0
      * sll ls (V "stack")
      * [| length bs = wordToNat (V "len") |] * [| inBounds cdatas V |]
      * [| stackOk ls (V "len") |] * invPre a V
    POST[R'] array8 bs (V "buf") * mallocHeap 0 * invPost a V R'.

  (* Intermediater invariant, to use right after reading token length from the lexer. *)
  Definition invL cdatas start :=
    Al a : A, Al bs, Al ls,
    PRE[V, R] array8 bs (V "buf") * xmlp (V "len") (V "lex") * sll ls (V "stack") * mallocHeap 0
      * [| length bs = wordToNat (V "len") |] * [| inBounds cdatas V |]
      * [| stackOk ls (V "len") |]
      * [| wordToNat (V start) + wordToNat R <= wordToNat (V "len") |]%nat * invPre a V
    POST[R'] array8 bs (V "buf") * mallocHeap 0 * invPost a V R'.

  (* Alternate sequencing operator, which generates twistier code but simpler postconditions and VCs *)
  Definition SimpleSeq (ch1 ch2 : chunk) : chunk := fun ns res =>
    Structured nil (fun im mn H => Seq_ H (toCmd ch1 mn H ns res) (toCmd ch2 mn H ns res)).

  Infix ";;" := SimpleSeq : SP_scope.

  (* Workhorse pattern compilation function, taking as input:
   * p: an XML pattern to compile
   * level: tree depth at which this pattern is applied (starts at 1 for top-level pattern)
   * cdatas: list of start-length pairs denoting spans within the string we match against,
   *         set by earlier successfull matches of subpatterns
   * onSuccess: continuation code to run when the pattern matches fully
   *)
  Fixpoint Pat' (p : pat) (level : nat) (cdatas : list (string * string))
    (onSuccess : chunk) : chunk :=
    match p with
      | Cdata const =>
        (* Read next token. *)
        "res" <-- Call "xml_lex"!"next"("buf", "lex")
        [inv cdatas];;

        (* Now here's a gross hack to support XML-RPC, which has some positions where
         * "blah" and "<string>blah</string>" are equivalent. *)
        If ("res" = 1) {
          "level" <- (level + 1)%nat;;
          "res" <-- Call "xml_lex"!"next"("buf", "lex")
          [inv cdatas]
        } else {
          "level" <- level
        };;

        (* What type of token is it? *)
        If ("res" = 2) {
          (* We may have a match!  First, grab the boundaries of the matching string. *)
          "tagStart" <-- Call "xml_lex"!"tokenStart"("lex")
          [invP cdatas];;

          "tagLen" <-- Call "xml_lex"!"tokenLength"("lex")
          [invL cdatas "tagStart"];;

          If ("tagLen" = String.length const) {
            (* Now check if the CDATA content here matches the constant from the pattern. *)
            StringEq "buf" "len" "tagStart" "matched" const
            (fun a V => Ex ls, xmlp (V "len") (V "lex") * sll ls (V "stack") * mallocHeap 0
              * [| inBounds cdatas V |] * [| stackOk ls (V "len") |] * invPre a V)%Sep
            (fun bs a V R => array8 bs (V "buf") * mallocHeap 0 * invPost a V R)%Sep;;

            If ("matched" = 0) {
              (* Nope, not equal. *)
              Skip
            } else {
              (* Equal! *)
              If ("level" = level) {
                Skip
              } else {
                "level" <- level;;
                "res" <-- Call "xml_lex"!"next"("buf", "lex")
                [inv cdatas]
              };;
              onSuccess
            }
          } else {
            (* Tag is wrong length to match. *)
            Skip
          }
        } else {
          (* It's not CDATA.  Pattern doesn't match. *)
          Skip
        }

      | Var start len =>
        (* Read next token. *)
        "res" <-- Call "xml_lex"!"next"("buf", "lex")
        [inv cdatas];;

        (* Now here's a gross hack to support XML-RPC, which has some positions where
         * "blah" and "<string>blah</string>" are equivalent. *)
        If ("res" = 1) {
          "level" <- (level + 1)%nat;;
          "res" <-- Call "xml_lex"!"next"("buf", "lex")
          [inv cdatas]
        } else {
          "level" <- level
        };;

        (* What type of token is it? *)
        If ("res" = 2) {
          (* This is indeed CDATA!  Save the position and signal success. *)
          start <-- Call "xml_lex"!"tokenStart"("lex")
          [invP cdatas];;

          len <-- Call "xml_lex"!"tokenLength"("lex")
          [invL cdatas start];;

          If ("level" = level) {
            Skip
          } else {
            "level" <- level;;
            "res" <-- Call "xml_lex"!"next"("buf", "lex")
            [inv ((start, len) :: cdatas)]
          };;

          onSuccess
        } else {
          (* It's not CDATA.  Pattern doesn't match. *)
          Skip
        }

      | TreeVar start len =>
        start <-- Call "xml_lex"!"position"("lex")
        [inv cdatas];;

        (* Read next token. *)
        "res" <-- Call "xml_lex"!"next"("buf", "lex")
        [inv cdatas];;

        (* What type of token is it? *)
        If ("res" = 2) {
          (* This is the easy case: just CDATA.  Do like for [Var]. *)
          start <-- Call "xml_lex"!"tokenStart"("lex")
          [invP cdatas];;

          len <-- Call "xml_lex"!"tokenLength"("lex")
          [invL cdatas start];;

          onSuccess
        } else {
          If ("res" = 1) {
            (* It's an open tag, so we should keep lexing until encountering the matching closer. *)

            "level" <- level;;

            [inv cdatas]
            While ("level" >= level) {
              "res" <-- Call "xml_lex"!"next"("buf", "lex")
              [inv cdatas];;

              If ("res" = 1) {
                (* Open tag *)
                "level" <- "level" + 1
              } else {
                If ("res" = 3) {
                  (* Close tag *)
                  "level" <- "level" - 1
                } else {
                  Skip
                }
              }
            };;

            "level" <- level;;

            "res" <-- Call "xml_lex"!"position"("lex")
            [inv cdatas];;

            If (start > "res") {
              (* Shouldn't be possible, but we can't prove it ATM. *)
              Skip
            } else {
              len <- "res" - start;;

              If ("res" > "len") {
                (* Again, shouldn't be possible. *)
                Skip
              } else {
                onSuccess
              }
            }
          } else {
            (* This is not going to be a valid tree. *)
            Skip
          }
        }

      | Tag tag inner =>
        (* Initialize a variable storing the tree depth of our current position.
         * We'll consult this variable to see when we're at the proper depth for matching
         * the current pattern. *)
        "level" <- level;;

        (* Loop until level drops below the starting level (after which the pattern never applies again). *)
        [inv cdatas]
        While ("level" >= level) {
          (* Lex next token. *)
          "res" <-- Call "xml_lex"!"next"("buf", "lex")
          [inv cdatas];;

          (* What type of token is it? *)
          If ("res" = 1) {
            (* Open tag -- does it match? *)

            If ("level" > level) {
              (* We've descended too deep, so this position doesn't qualify. *)
              "level" <- "level" + 1;;
              Skip
            } else {
              "level" <- "level" + 1;;

              (* We may have a match!  First, grab the boundaries of the matching string. *)
              "tagStart" <-- Call "xml_lex"!"tokenStart"("lex")
              [invP cdatas];;

              "tagLen" <-- Call "xml_lex"!"tokenLength"("lex")
              [invL cdatas "tagStart"];;

              If ("tagLen" = String.length tag) {
                (* Now check if the tag name here matches the name from the pattern. *)
                StringEq "buf" "len" "tagStart" "matched" tag
                (fun a V => Ex ls, xmlp (V "len") (V "lex") * sll ls (V "stack") * mallocHeap 0
                  * [| inBounds cdatas V |] * [| stackOk ls (V "len") |] * invPre a V)%Sep
                (fun bs a V R => array8 bs (V "buf") * mallocHeap 0 * invPost a V R)%Sep;;

                If ("matched" = 0) {
                  (* Nope, not equal. *)
                  Skip
                } else {
                  (* Equal!  Continue with the nested pattern. *)
                  Pat' inner (S level) cdatas onSuccess
                }
              } else {
                (* Tag is wrong length to match. *)
                Skip
              }
            }
          } else {
            If ("res" = 3) {
              (* Close tag *)
              "level" <- "level" - 1
            } else {
              If ("res" = 0) {
                (* Done parsing.  Force exit from the loop. *)
                "level" <- 0
              } else {
                (* Ignore any other kind of token. *)
                Skip
              }
            }
          }
        }

      | Both p1 p2 =>
        (* Warning: shameless reuse here of variables for new purposes *)

        (* Get the current position, which we will save to return to later. *)
        "tagLen" <-- Call "xml_lex"!"position"("lex")
        [Al a : A, Al bs, Al ls,
          PRE[V, R] array8 bs (V "buf") * xmlp (V "len") (V "lex")
            * sll ls (V "stack") * mallocHeap 0 * [| R <= V "len" |]%word
            * [| length bs = wordToNat (V "len") |] * [| inBounds cdatas V |]
            * [| stackOk ls (V "len") |] * invPre a V
          POST[R'] array8 bs (V "buf") * mallocHeap 0 * invPost a V R'];;

        (* Allocate a new entry for the position stack. *)
        "tagStart" <-- Call "malloc"!"malloc"(0, 2)
        [Al a : A, Al bs, Al ls,
          PRE[V, R] array8 bs (V "buf") * xmlp (V "len") (V "lex")
            * sll ls (V "stack") * mallocHeap 0 * [| V "tagLen" <= V "len" |]%word
            * R =?> 2 * [| R <> 0 |] * [| freeable R 2 |]
            * [| length bs = wordToNat (V "len") |] * [| inBounds cdatas V |]
            * [| stackOk ls (V "len") |] * invPre a V
          POST[R'] array8 bs (V "buf") * mallocHeap 0 * invPost a V R'];;

        (* Save the current position in this entry, then push it onto the stack. *)
        "tagStart" *<- "tagLen";;
        "tagStart"+4 *<- "stack";;
        "stack" <- "tagStart";;

        (* Try matching the first pattern. *)
        Pat' p1 level cdatas
        ((* Make sure the stack is nonempty afterward.
          * Only buggy code here could lead to that outcome, but we aren't verifying at that level
          * of detail yet, so we use a run-time check. *)
        If ("stack" = 0) {
          (* We hope this case is impossible. *)
          Call "sys"!"abort"()
          [PREonly[_] [| False |]]
        } else {
          (* Stack nonempty!  Pop position off of stack (into "tagLen"). *)
          "tagLen" <-* "stack";;
          "tagStart" <- "stack";;
          "stack" <-* "stack"+4;;

          (* Free the popped stack entry. *)
          Call "malloc"!"free"(0, "tagStart", 2)
          [Al a : A, Al bs, Al ls,
            PRE[V] array8 bs (V "buf") * xmlp (V "len") (V "lex")
              * sll ls (V "stack") * mallocHeap 0 * [| V "tagLen" <= V "len" |]%word
              * [| length bs = wordToNat (V "len") |] * [| inBounds (allCdatas p1 ++ cdatas) V |]
              * [| stackOk ls (V "len") |] * invPre a V
          POST[R'] array8 bs (V "buf") * mallocHeap 0 * invPost a V R'];;

          (* Restore the position we popped. *)
          Call "xml_lex"!"setPosition"("lex", "tagLen")
          [inv (allCdatas p1 ++ cdatas)];;

          (* Now try matching the second pattern from the same initial position. *)
          Pat' p2 level (allCdatas p1 ++ cdatas)
          onSuccess
        })

      | Ordered p1 p2 =>
        (* Try matching the first pattern. *)
        Pat' p1 level cdatas (
          (* Loop lexing tokens until we return to the appropriate tree level. *)
          [inv (allCdatas p1 ++ cdatas)]
          While ("level" > level) {
            "res" <-- Call "xml_lex"!"next"("buf", "lex")
            [inv (allCdatas p1 ++ cdatas)];;

            If ("res" = 1) {
              (* Open tag *)
              "level" <- "level" + 1
            } else {
              If ("res" = 3) {
                (* Close tag *)
                "level" <- "level" - 1
              } else {
                Skip
              }
            }
          };;

          (* Now try matching the second pattern from the same initial position. *)
          Pat' p2 level (allCdatas p1 ++ cdatas)
          onSuccess
        )
    end%SP.

  Notation baseVars := ("buf" :: "len" :: "lex" :: "res"
    :: "tagStart" :: "tagLen" :: "matched" :: "stack" :: "level" :: nil).

  Definition noConflict pt := List.Forall (fun p => ~In (fst p) baseVars /\ ~In (snd p) baseVars
    /\ ~freeVar pt (fst p) /\ ~freeVar pt (snd p)).

  Notation "l ~~ im ~~> s" := (LabelMap.find l%SP im = Some (Precondition s None)) (at level 0).

  Lemma inBounds_sel : forall cdatas V, inBounds cdatas (sel V) = inBounds cdatas V.
    auto.
  Qed.

  Lemma Forall_impl2 : forall A (P Q R : A -> Prop) ls,
    List.Forall P ls
    -> List.Forall Q ls
    -> (forall x, P x -> Q x -> R x)
    -> List.Forall R ls.
    induction 1; inversion 1; eauto.
  Qed.

  Lemma incl_peel : forall A (x : A) ls ls',
    incl (x :: ls) ls'
    -> In x ls' /\ incl ls ls'.
    unfold incl; intuition.
  Qed.

  Ltac deDouble := simpl in *;
    repeat match goal with
             | [ H : incl nil _ |- _ ] => clear H
             | [ H : incl _ _ |- _ ] => apply incl_peel in H; destruct H
             | [ H : forall x, x = _ \/ x = _ -> _ |- _ ] =>
               generalize (H _ (or_introl _ eq_refl)); intro;
                 specialize (H _ (or_intror _ eq_refl))
             | [ H : forall x, freeVar _ _ \/ freeVar _ _ -> _ |- _ ] =>
               generalize (fun x H0 => H x (or_introl _ H0)); intro;
                 specialize (fun x H0 => H x (or_intror _ H0))
           end;
    intuition idtac; repeat match goal with
                              | [ H : False -> False |- _ ] => clear H
                            end.

  Lemma mult4_S : forall n,
    4 * S n = S (S (S (S (4 * n)))).
    simpl; intros; omega.
  Qed.

  Lemma invPre_sel : forall a V, invPre a (sel V) = invPre a V.
    auto.
  Qed.

  Lemma invPost_sel : forall a V R, invPost a (sel V) R = invPost a V R.
    auto.
  Qed.

  Ltac evalu :=
    match goal with
      | [ ns : list string |- _ ] =>
        repeat match goal with
                 | [ H : In _ ns |- _ ] => clear H
               end
    end; try rewrite mult4_S in *; repeat rewrite inBounds_sel in *;
    repeat rewrite invPre_sel in *; repeat rewrite invPost_sel in *;
    match goal with
      | [ _ : evalInstrs _ _ _ = _ |- _ ] => evaluate SinglyLinkedList.hints
      | [ _ : evalCond _ _ _ _ _ = _ |- _ ] => evaluate SinglyLinkedList.hints
      | _ => idtac
    end;
    repeat match goal with
             | [ H : In _ _ |- _ ] => clear H
             | [ H : evalInstrs _ _ _ = _ |- _ ] => clear H
           end;
    try match goal with
          | [ st : (settings * state)%type |- _ ] => destruct st; simpl in *
        end.

  Ltac finish := descend; repeat (step SinglyLinkedList.hints; descend); auto.

  Hint Extern 1 (@eq W _ _) => unfold natToW in *; words.

  Opaque mult.

  Lemma stackOk_cons : forall w len ws,
    w <= len
    -> stackOk ws len
    -> stackOk (w :: ws) len.
    constructor; auto.
  Qed.

  Hint Immediate stackOk_cons.

  Ltac noConflict := unfold noConflict; intros; eapply Forall_impl; [ | eauto ]; (cbv beta; simpl; tauto).

  Lemma noConflict_Both1 : forall p1 p2 cdatas,
    noConflict (Both p1 p2) cdatas
    -> noConflict p1 cdatas.
    noConflict.
  Qed.

  Lemma noConflict_Both2' : forall p1 p2 cdatas,
    noConflict (Both p1 p2) cdatas
    -> noConflict p2 cdatas.
    noConflict.
  Qed.

  Ltac allCdatas_freeVar := intros ? p;
    induction p; simpl; intuition; subst; auto;
      match goal with
        | [ H : _ |- _ ] => apply in_app_or in H; tauto
      end.

  Lemma allCdatas_freeVar1 : forall xy p,
    In xy (allCdatas p) -> freeVar p (fst xy).
    allCdatas_freeVar.
  Qed.

  Lemma allCdatas_freeVar2 : forall xy p,
    In xy (allCdatas p) -> freeVar p (snd xy).
    allCdatas_freeVar.
  Qed.

  Lemma noConflict_Both2 : forall p1 p2 cdatas,
    noConflict (Both p1 p2) cdatas
    -> (forall x, freeVar p1 x -> freeVar p2 x -> False)
    -> (forall x, freeVar p1 x -> ~In x baseVars)
    -> noConflict p2 (allCdatas p1 ++ cdatas).
    intros; apply Forall_app.
    2: eapply noConflict_Both2'; eauto.
    apply Forall_forall; intros.
    generalize (allCdatas_freeVar1 _ _ H2); intro.
    apply allCdatas_freeVar2 in H2.
    intuition eauto.
  Qed.

  Hint Immediate noConflict_Both1.
  Hint Extern 1 (noConflict _ (_ ++ _)) => eapply noConflict_Both2; [ eassumption | eassumption |
    simpl; intros; match goal with
                     | [ H : _, H' : freeVar _ _ |- _ ] => apply H in H'; tauto
                   end ].

  Hint Extern 1 (incl _ _) => hnf; simpl; intuition congruence.

  Lemma Forall_app1 : forall A P (ls1 ls2 : list A),
    List.Forall P (ls1 ++ ls2)
    -> List.Forall P ls1.
    induction ls1; inversion 1; eauto.
  Qed.

  Lemma Forall_app2 : forall A P (ls1 ls2 : list A),
    List.Forall P (ls1 ++ ls2)
    -> List.Forall P ls2.
    induction ls1; inversion 1; eauto.
  Qed.

  Lemma inBounds_app1 : forall ls1 ls2 x,
    inBounds (ls1 ++ ls2) x
    -> inBounds ls1 x.
    intros; eapply Forall_app1; eauto.
  Qed.

  Lemma inBounds_app2 : forall ls1 ls2 x,
    inBounds (ls1 ++ ls2) x
    -> inBounds ls2 x.
    intros; eapply Forall_app2; eauto.
  Qed.

  Hint Immediate inBounds_app1 inBounds_app2.

  Lemma inBounds_decons : forall x cdatas y,
    inBounds (x :: cdatas) y
    -> inBounds cdatas y.
    inversion 1; auto.
  Qed.

  Hint Immediate inBounds_decons.

  Lemma inBounds_assoc : forall ls1 ls2 ls3 x,
    inBounds ((ls1 ++ ls2) ++ ls3) x
    -> inBounds (ls1 ++ ls2 ++ ls3) x.
    intros; rewrite app_assoc; assumption.
  Qed.

  Lemma inBounds_assoc' : forall ls1 ls2 ls3 x,
    inBounds (ls1 ++ ls2 ++ ls3) x
    -> inBounds ((ls1 ++ ls2) ++ ls3) x.
    intros; rewrite <- app_assoc; assumption.
  Qed.

  Hint Immediate inBounds_assoc inBounds_assoc'.

  Lemma wplus_wminus : forall u v : W,
    u ^+ v ^- v = u.
    intros; words.
  Qed.

  Hint Rewrite wplus_wminus mult4_S : sepFormula.

  Ltac inBounds :=
    rewrite <- inBounds_sel;
      repeat match goal with
               | [ H : inBounds _ ?X |- _ ] =>
                 match X with
                   | sel _ => fail 1
                   | _ => rewrite <- inBounds_sel in H
                 end
             end;
      try (constructor; [ descend | ]);
        match goal with
          | [ H : inBounds _ _, H' : noConflict _ _ |- _ ] =>
            eapply Forall_impl2; [ apply H
              | (eapply noConflict_Both2; [ eassumption | eassumption |
                simpl; intros; match goal with
                                 | [ H : _, H' : freeVar _ _ |- _ ] => apply H in H'; tauto
                               end ]) || apply H'
              | cbv beta; simpl; intuition descend;
                repeat match goal with
                         | [ H : forall x, _ |- _ ] => rewrite <- H by congruence
                       end; assumption ]
        end.

  Ltac reger := repeat match goal with
                         | [ H : Regs _ _ = _ |- _ ] => rewrite H
                       end.

  Ltac inver :=
    match goal with
      | [ H : forall a : A, _ |- himp _ ?P ?Q ] =>
        match P with
          | context[invPre _ ?vs] =>
            match Q with
              | context[invPre _ ?vs'] =>
                match vs' with
                  | vs => fail 1
                  | _ => rewrite (H _ vs vs') by intuition descend
                end
            end
          | context[invPost _ ?vs _] =>
            match Q with
              | context[invPost _ ?vs' _] =>
                match vs' with
                  | vs => fail 1
                  | _ => rewrite (H _ vs vs') by intuition descend
                end
            end
        end
    end.

  Ltac bash :=
    unfold inv, invP, invL, localsInvariant; try rewrite mult4_S in *; reger; try inver; descend;
      try rewrite inBounds_sel; try rewrite invPre_sel in *; try rewrite invPost_sel in *;
        try match goal with
              | [ _ : inBounds ?cdatas _ |- interp _ (![?pre] _ ---> ![?post] _)%PropX ] =>
                match post with
                  | context[locals ?ns _ _ _] =>
                    match pre with
                      | context[locals ns ?vs _ _] =>
                        assert (inBounds cdatas vs) by inBounds
                    end
                end
              | [ H : context[invPost] |- ?P = ?Q ] =>
                match P with
                  | context[invPost ?a ?V _] =>
                    match Q with
                      | context[invPost a ?V' _] =>
                        rewrite (H a V V') by intuition
                    end
                end;
                match goal with
                  | [ H : forall x : string, _ -> sel ?V _ = sel ?V' _ |- _ ] =>
                    repeat match goal with
                             | [ |- context[V ?x] ] => change (V x) with (sel V x)
                             | [ |- context[V' ?x] ] => change (V' x) with (sel V' x)
                           end;
                    repeat rewrite H by intuition congruence
                end; reflexivity
            end;
        try match goal with
              | [ |- interp _ (![?pre] _ ---> ![?post] _)%PropX ] =>
                match post with
                  | context[locals ?ns _ _ _] =>
                    match pre with
                      | context[locals ns ?vs _ _] =>
                        match pre with
                          | context[invPre ?a ?vs'] =>
                            assert (unit -> invPre a vs' = invPre a vs) by
                              match goal with
                                | [ H : _ |- _ ] => intro; apply H; intuition descend
                              end
                          | context[invPost ?a ?vs' ?r] =>
                            assert (unit -> invPost a vs' r = invPost a vs r) by
                              match goal with
                                | [ H : _ |- _ ] => intro; apply H; intuition descend
                              end
                        end
                    end
                end;
                try match goal with
                      | [ _ : context[Var ?start ?len] |- _ ] =>
                        match post with
                          | context[locals ?ns _ _ _] =>
                            match pre with
                              | context[locals ns ?vs _ _] =>
                                assert (wordToNat (sel vs start) + wordToNat (sel vs len)
                                  <= wordToNat (sel vs "len"))%nat by descend
                            end
                        end
                    end
            end;
        step SinglyLinkedList.hints;
        try match goal with
              | [ H : unit -> invPre _ _ = invPre _ _ |- _ ] => rewrite (H tt)
              | [ H : unit -> invPost _ _ _ = invPost _ _ _ |- _ ] => rewrite (H tt)
            end.

  Ltac clear_fancier := match goal with
                          | [ H : importsGlobal _ |- _ ] =>
                            repeat match goal with
                                     | [ H' : context[H] |- _ ] => clear H'
                                   end; clear H
                        end.

  Ltac deSpec := simpl in *;
    repeat match goal with
             | [ H : LabelMap.find _ _ = _ |- _ ] => try rewrite H; clear H
           end; clear_fancier;
    try match goal with
          | [ st : (settings * state)%type |- _ ] => destruct st; simpl in *
        end.

  Ltac prove_Himp :=
    deSpec; apply Himp_ex; intro;
      repeat match goal with
               | [ V : vals |- _ ] =>
                 match goal with
                   | [ |- context[V ?x] ] => change (V x) with (sel V x)
                 end
             end;
      match goal with
        | [ H : context[invPre] |- ?P ===> ?Q ] =>
          match P with
            | context[invPre ?a ?V] =>
              match Q with
                | context[invPre a ?V'] =>
                  rewrite (H a V V') by intuition
              end
          end
      end;
      match goal with
        | [ H : forall x : string, _ |- _ ] =>
          repeat rewrite H by congruence; cancel auto_ext; inBounds
      end.

  Ltac invoke1 :=
    match goal with
      | [ |- _ ===> _ ] => prove_Himp
      | [ H : _ |- vcs _ ] => apply H; clear H
      | [ H : forall x, _, H' : interp _ _ |- _ ] => apply H in H'; clear H
      | [ |- vcs _ ] => wrap0
    end; try eassumption; try (rewrite app_assoc; eassumption); eauto; propxFo;
    try match goal with
          | [ st : (settings * state)%type |- _ ] => destruct st; simpl in *
        end.

  Ltac set_env :=
    match goal with
      | [ _ : context[locals ?ns ?vs ?res ?sp] |- context[locals ?ns ?vs' ?res ?sp'] ] =>
        match sp with
          | sp' => idtac
          | _ => let H := fresh in assert (H : sp = sp') by words; clear H
        end; equate vs' vs; descend
    end.

  Ltac prep_call :=
    match goal with
      | [ H : context[locals ?ns ?vs ?avail ?p]
        |- context[locals ?ns' _ ?avail' _] ] =>
      match avail' with
        | avail => fail 1
        | _ =>
          let offset := eval simpl in (4 * List.length ns) in
            change (locals ns vs avail p) with (locals_call ns vs avail p ns' avail' offset) in H;
              assert (ok_call ns ns' avail avail' offset)%nat
                by (split; [ simpl; omega
                  | split; [ simpl; omega
                    | split; [ NoDup
                      | reflexivity ] ] ])
      end;
      match goal with
        | [ H : interp _ _ |- _ ] => autorewrite with sepFormula in H; simpl in H
      end
    end.

  Ltac split_IH := match goal with
                     | [ IH : forall level : nat, _ |- _ ] =>
                       generalize (fun a b c d e f g h i j => proj1 (IH a b c d e f g h i j));
                         generalize (fun a b c d e f g h i j => proj2 (IH a b c d e f g h i j));
                           clear IH; intros
                   end.

  Ltac PatR := repeat split_IH; wrap0; deDouble; propxFo; repeat invoke1;
    deSpec; simp; repeat invoke1; try prep_call;
      evalu; try tauto; descend; try set_env; repeat bash; inBounds || eauto.

  Hint Constructors unit.

  Lemma StringMatch_ok : forall (x : W) n y,
    (wordToNat x + n <= wordToNat y)%nat
    -> x <= y.
    intros; nomega.
  Qed.

  Hint Immediate StringMatch_ok.

  Lemma stackOk_hd : forall w ws len,
    stackOk (w :: ws) len
    -> w <= len.
    inversion 1; auto.
  Qed.

  Lemma stackOk_tl : forall w ws len,
    stackOk (w :: ws) len
    -> stackOk ws len.
    inversion 1; auto.
  Qed.

  Hint Immediate stackOk_hd stackOk_tl.

  Lemma inBounds_easy : forall start len cdatas V k,
    inBounds ((start, len) :: cdatas) V
    -> noConflict (Var start len) cdatas
    -> "res" <> start
    -> "res" <> len
    -> inBounds ((start, len) :: cdatas) (upd V "res" k).
    intros.
    rewrite <- inBounds_sel in *.
    inversion_clear H.
    constructor.
    descend; assumption.
    eapply Forall_impl2.
    apply H4.
    apply H0.
    simpl; intuition idtac.
    descend.
  Qed.

  Hint Immediate inBounds_easy.

  Lemma inBounds_easyTree : forall start len cdatas V k w q,
    inBounds cdatas V
    -> noConflict (TreeVar start len) cdatas
    -> "res" <> start
    -> "res" <> len
    -> "len" <> len
    -> start <> len
    -> sel (upd (upd V "res" w) len q) "res" <= sel (upd (upd V "res" w) len q) "len"
    -> sel (upd V "res" w) start <= w
    -> inBounds ((start, len) :: cdatas) (upd (upd V "res" k) len (w ^- sel V start)).
    intros.
    autorewrite with sepFormula in *.
    rewrite <- inBounds_sel in *.
    constructor.
    descend.
    simpl in *.
    nomega.
    eapply Forall_impl2.
    apply H.
    apply H0.
    simpl; intuition idtac.
    descend.
  Qed.

  Hint Immediate inBounds_easyTree.

  Theorem PatR_correct : forall im mn H ns res,
    ~In "rp" ns
    -> incl baseVars ns
    -> (res >= 11)%nat
    -> "xml_lex"!"next" ~~ im ~~> nextS
    -> "xml_lex"!"position" ~~ im ~~> positionS
    -> "xml_lex"!"setPosition" ~~ im ~~> setPositionS
    -> "xml_lex"!"tokenStart" ~~ im ~~> tokenStartS
    -> "xml_lex"!"tokenLength" ~~ im ~~> tokenLengthS
    -> "malloc"!"malloc" ~~ im ~~> mallocS
    -> "malloc"!"free" ~~ im ~~> freeS
    -> "sys"!"abort" ~~ im ~~> abortS
    -> forall p level cdatas onSuccess,
      (forall x, freeVar p x -> In x ns /\ ~In x baseVars /\ x <> "rp")
      -> wf p
      -> noConflict p cdatas
      -> (forall a V V', (forall x, ~In x baseVars -> ~freeVar p x -> sel V x = sel V' x)
        -> invPre a V = invPre a V')
      -> (forall a V V' R, (forall x, ~In x baseVars -> ~freeVar p x -> sel V x = sel V' x)
        -> invPost a V R = invPost a V' R)
      -> (forall specs pre st,
        interp specs (Postcondition (toCmd onSuccess (im := im) mn H ns res pre) st)
        -> interp specs (inv (allCdatas p ++ cdatas) true (fun w => w) ns res st))
      -> (forall pre,
        (forall specs st, interp specs (pre st)
          -> interp specs (inv (allCdatas p ++ cdatas) true (fun w => w) ns res st))
        -> vcs (VerifCond (toCmd onSuccess (im := im) mn H ns res pre)))
      -> forall pre,
        (forall specs st, interp specs (pre st) -> interp specs (inv cdatas true (fun x => x) ns res st))
        -> (forall specs st, interp specs ((toCmd (Pat' p level cdatas onSuccess)
          (im := im) mn H ns res pre).(Postcondition) st)
          -> interp specs (inv cdatas true (fun x => x) ns res st))
        /\ vcs ((toCmd (Pat' p level cdatas onSuccess) (im := im) mn H ns res pre).(VerifCond)).
    induction p; abstract PatR.
  Qed.

  Notation PatVcs p onSuccess := (fun im ns res =>
    (~In "rp" ns) :: incl baseVars ns
    :: (forall x, freeVar p x -> In x ns /\ ~In x baseVars)
    :: wf p
    :: (forall specs mn H pre st,
      interp specs (Postcondition (toCmd onSuccess (im := im) mn H ns res pre) st)
      -> interp specs (inv (allCdatas p) true (fun w => w) ns res st))
    :: (res >= 11)%nat
    :: "xml_lex"!"next" ~~ im ~~> nextS
    :: "xml_lex"!"position" ~~ im ~~> positionS
    :: "xml_lex"!"setPosition" ~~ im ~~> setPositionS
    :: "xml_lex"!"tokenStart" ~~ im ~~> tokenStartS
    :: "xml_lex"!"tokenLength" ~~ im ~~> tokenLengthS
    :: "malloc"!"malloc" ~~ im ~~> mallocS
    :: "malloc"!"free" ~~ im ~~> freeS
    :: "sys"!"abort" ~~ im ~~> abortS
    :: (forall mn H pre,
      (forall specs st, interp specs (pre st)
        -> interp specs (inv (allCdatas p) true (fun w => w) ns res st))
      -> vcs (VerifCond (toCmd onSuccess (im := im) mn H ns res pre)))
    :: (forall a V V', (forall x, ~In x baseVars -> ~freeVar p x -> sel V x = sel V' x)
      -> invPre a V = invPre a V')
    ::  (forall a V V' R, (forall x, ~In x baseVars -> ~freeVar p x -> sel V x = sel V' x)
      -> invPost a V R = invPost a V' R)
    :: nil).

  Hint Extern 1 (noConflict _ nil) => constructor.
  Hint Extern 1 (inBounds nil _) => constructor.

  Definition Pat (p : pat) (onSuccess : chunk) : chunk.
    refine (WrapC (Pat' p 1 nil onSuccess)
      invar
      invar
      (PatVcs p onSuccess)
      _ _); abstract (wrap0;
        match goal with
          | [ H : wf _ |- _ ] => eapply PatR_correct in H;
            match goal with
              | [ |- Logic.ex _ ] => destruct H; PatR
              | [ |- vcs _ ] => destruct H; PatR
              | _ => try rewrite app_nil_r; eauto
            end; (intros; app; simpl; intuition congruence) || PatR
        end).
  Defined.

End Pat.


Require Import Proofs.Types.
Require BL.

Require Import Stupid.
Require Import InlinedMonoidBSFold.

Require Import Simple.
Require Import SimpleFold.

Require Import GHC.Base.
Require Import Proofs.GHC.Base.
Require Import Proofs.Data.Foldable.

Require Import GHC.List.
Require GHC.Char.

Require Import GHC.Base.

Require Import Proofs.Data.OldList.

Lemma assoc : forall s m2,
  (m2 <<>> (fromTuple (Stupid.length s, Stupid.length (OldList.words s), Stupid.length (OldList.lines s)))) =
  (BL.foldl' (fun (a : Counts) (b : Char) => a <<>> countChar b) (mempty <<>> m2) (BL.pack s)).
Proof.
  induction s; intro m2; autorewrite with hs_simpl.
  + rewrite BL.ByteString_foldl_nil. admit.
  + rewrite BL.ByteString_foldl_cons.
    rewrite <- Counts_assoc.
    rewrite <- IHs.
    rewrite <- Counts_assoc.
    f_equal.
    unfold countChar. unfold flux.
    destruct (Unicode.isSpace a) eqn:AS.
    destruct (a == newline) eqn:AN.
    ++ admit. (* can't be both space and newline *)
    ++ simpl. rewrite AN.
       destruct break as [ys zs] eqn:B.
       simpl.
       unfold op_zlzlzgzg__, Semigroup__Counts, Types.Semigroup__Counts_op_zlzlzgzg__; simpl.
       unfold op_zlzlzgzg__, Semigroup__Flux, Types.Semigroup__Flux_op_zlzlzgzg__; simpl.
       f_equal.
       destruct s. simpl in *. inversion B. simpl. admit.
       inversion B.
       hs_simpl.
Admitted.

Lemma stupid_inlined : forall s, toTuple (stupidCountFile s) = toTuple (countFile (BL.pack s)).
Proof.
  unfold stupidCountFile, countFile in *.
  intro s.
  induction s;
  autorewrite with hs_simpl.
  + rewrite BL.ByteString_foldl_nil. reflexivity.
  + rewrite BL.ByteString_foldl_cons.
Admitted.


Require Import CompCert.Events.
Require Import CompCert.Smallstep.
Require Import Common.Definitions.
Require Import Common.Util.
Require Import Common.Values.
Require Import Common.Memory.
Require Import Common.CompCertExtensions.
Require Import Common.Traces.
Require Import Common.Blame.
Require Import Source.Language.
Require Import Source.GlobalEnv.
Require Import Lib.Tactics.
Require Import Lib.Monads.
Require Import Lib.Extra.
Require Import Source.CS.
Import Source.CS.CS.

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype seq.
From mathcomp Require ssrnat.

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

Set Bullet Behavior "Strict Subproofs".

Import Source.

Module CS.

Instance state_turn : HasTurn state := {
  turn_of s iface := s_component s \in domm iface
}.

Corollary kstep_deterministic:
  forall G st t st1 st2,
    kstep G st t st1 -> kstep G st t st2 -> st1 = st2.
Proof.
  intros G st t st1 st2 Hkstep1 Hkstep2.
  apply eval_kstep_correct in Hkstep1.
  apply eval_kstep_correct in Hkstep2.
  rewrite Hkstep1 in Hkstep2.
  inversion Hkstep2.
  reflexivity.
Qed.

Section Semantics.

  Variable p: program.

  Hypothesis valid_program:
    well_formed_program p.

  Hypothesis complete_program:
    closed_program p.

  Let sem := sem p.

  Lemma trace_wb t cs cs' :
    Star sem cs t cs' ->
    well_bracketed_trace (stack_state_of cs) t.
  Proof.
    elim: cs t cs' / => //= s1 t1 s2 t2 s3 t Hstep Hstar IH -> {t}.
    case: s1 t1 s2 / Hstep Hstar IH=> //=.
    - (* Internal Return *)
      by move=> C stk mem k _ P v P_expr old <-; rewrite eqxx.
    - (* External Return *)
      move=> C stk mem k C' P v P_expr old.
      by rewrite eq_sym eqxx=> /eqP/negbTE -> /=.
    - (* Internal Call *)
      by move=> C stk mem k v _ _ old <-; rewrite eqxx.
    - (* External Call *)
      by move=> C stk mem k v _ C' old /eqP/negbTE ->; rewrite !eqxx.
  Qed.

  Lemma events_wf st t st' :
    Star sem st t st' ->
    all (well_formed_event (prog_interface p)) t.
  Proof.
  elim: st t st' / => // st1 t1 st2 t2 st3 t /= Hstep Hstar IH -> {t}.
  rewrite all_cat; case: st1 t1 st2 / Hstep {Hstar} => //=.
  - by move=> ????????? /eqP -> /imported_procedure_iff ->.
  - by move=> ????????  /eqP ->.
  Qed.

  Lemma trace_wf mainP t cs cs' :
    Star sem cs t cs' ->
    initial_state p cs ->
    prog_main p = Some mainP ->
    well_formed_program p ->
    well_formed_trace (prog_interface p) t.
  Proof.
    move=> Hstar Hinitial Hmain Hwf; rewrite /well_formed_trace.
    rewrite (events_wf Hstar) andbT.
    suffices <- : stack_state_of cs = stack_state0 by apply: trace_wb; eauto.
    by move: Hinitial; rewrite /initial_state /initial_machine_state Hmain => ->.
  Qed.

  (* Several alternative formulations are possible. One may include the ERet event
     in the star, express the inclusion of ECall in the trace via In, etc. *)
  Lemma eret_from_initial_star_goes_after_ecall_cs s0 t s1 s2 C' v C :
    CS.initial_state p s0 ->
    Star sem s0 t s1 ->
    Step sem s1 [:: ERet C' v C] s2 ->
    exists t1 s s' t2 P v',
      Star sem s0 t1 s /\
      Step sem s [ECall C P v' C'] s' /\
      Star sem s' t2 s1 /\
      t = t1 ** [ECall C P v' C'] ** t2.
  Proof.
    move=> Hinitial Hstar Hstep.
    have {Hstep} /trace_wb : Star sem s0 (t ++ [:: ERet C' v C]) s2.
      apply: star_trans; eauto; exact: star_one.
    have -> : stack_state_of s0 = stack_state0.
      by rewrite Hinitial /= /CS.initial_machine_state /=; case: prog_main.
    case/well_bracketed_trace_inv=> t1 [P [arg [t2 e]]].
    move: Hstar; rewrite {}e -[seq.cat]/Eapp.
    case/(star_middle1_inv (@singleton_traces p))=> s1' [s2' [Hstar1 [Hstep2 Hstar3]]].
    by exists t1, s1', s2', t2, P, arg; repeat split=> //.
  Qed.

End Semantics.

End CS.


Require Import floyd.base.
Require Import floyd.assert_lemmas.
Require Import floyd.client_lemmas.
Require Import floyd.nested_field_lemmas.
Require Import floyd.type_induction.
Require Import floyd.aggregate_type.
Require Import floyd.reptype_lemmas.
Require Import floyd.proj_reptype_lemmas.
Require Import Coq.Classes.RelationClasses.
Require Import floyd.sublist.

Section SINGLE_HOLE.

Context {cs: compspecs}.

Lemma gfield_dec: forall (gf0 gf1: gfield), {gf0 = gf1} + {gf0 <> gf1}.
Proof.
  intros.
  destruct gf0, gf1; try solve [right; congruence].
  + destruct (zeq i i0); [left | right]; congruence.
  + destruct (Pos.eq_dec i i0); [left | right]; congruence.
  + destruct (Pos.eq_dec i i0); [left | right]; congruence.
Defined.

Lemma rgfs_dec: forall rgfs0 rgfs1: list gfield, {rgfs0 = rgfs1} + {rgfs0 <> rgfs1}.
Proof.
  apply list_eq_dec.
  apply gfield_dec.
Defined.

Definition upd_gfield_reptype t gf (v: reptype t) (v0: reptype (gfield_type t gf)) : reptype t :=
  fold_reptype
  (match t, gf return (REPTYPE t -> reptype (gfield_type t gf) -> REPTYPE t)
  with
  | Tarray t0 n a, ArraySubsc i => upd_Znth i
(*zl_concat (zl_concat (zl_sublist 0 i v) (zl_singleton i v0)) (zl_sublist (i + 1) n v) *)
  | Tstruct id _, StructField i =>
      fun v v0 => upd_compact_prod _ v (i, field_type i (co_members (get_co id))) v0 member_dec
  | Tunion id _, UnionField i =>
      fun v v0 => upd_compact_sum _ v (i, field_type i (co_members (get_co id))) v0 member_dec
  | _, _ => fun v _ => v
  end (unfold_reptype v) v0).

Fixpoint upd_reptype (t: type) (gfs: list gfield) (v: reptype t) (v0: reptype (nested_field_type t gfs)): reptype t :=
  match gfs as gfs'
    return reptype (match gfs' with
                    | nil => t
                    | gf :: gfs0 => gfield_type (nested_field_type t gfs0) gf
                    end) -> reptype t
  with
  | nil => fun v0 => v0
  | gf :: gfs0 => fun v0 => upd_reptype t gfs0 v (upd_gfield_reptype _ gf (proj_reptype t gfs0 v) v0)
  end (eq_rect_r reptype v0 (eq_sym (nested_field_type_ind t gfs))).

Lemma upd_Znth_ints i xints v:
      upd_Znth i (map Vint xints) (Vint v) =
      map Vint ((sublist 0 i xints) ++
                v :: (sublist (i + 1) (Zlength (map Vint xints)) xints)).
Proof. unfold upd_Znth; intros. rewrite map_app. simpl.
  do 2 rewrite sublist_map; trivial.
Qed.

Require Import floyd.stronger.

Lemma upd_reptype_data_equal: forall t gfs v v0 v1, data_equal v0 v1 -> data_equal (upd_reptype t gfs v v0) (upd_reptype t gfs v v1).
Proof.
  intros.
  induction gfs as [| gf gfs].
  + exact H.
  + change (upd_reptype t (gf :: gfs) v v0) with
      (upd_reptype t gfs v (upd_gfield_reptype _ gf (proj_reptype t gfs v)
        (eq_rect_r reptype v0 (eq_sym (nested_field_type_ind t (gf :: gfs)))))).
    change (upd_reptype t (gf :: gfs) v v1) with
      (upd_reptype t gfs v (upd_gfield_reptype _ gf (proj_reptype t gfs v)
        (eq_rect_r reptype v1 (eq_sym (nested_field_type_ind t (gf :: gfs)))))).
    apply IHgfs.
    assert (data_equal (eq_rect_r reptype v0 (eq_sym (nested_field_type_ind t (gf :: gfs))))
              (eq_rect_r reptype v1 (eq_sym (nested_field_type_ind t (gf :: gfs)))))
      by (apply eq_rect_r_data_equal; auto).
    forget (eq_rect_r reptype v0 (eq_sym (nested_field_type_ind t (gf :: gfs)))) as V0.
    forget (eq_rect_r reptype v1 (eq_sym (nested_field_type_ind t (gf :: gfs)))) as V1.
    forget (proj_reptype t gfs v) as V.
    clear - H0.
    revert V0 V1 H0 V.
    destruct (nested_field_type t gfs), gf; unfold upd_gfield_reptype; intros; try reflexivity.
    - admit.
    - admit.
    - admit.
Admitted.

End SINGLE_HOLE.

Module zlist_hint_db.

Lemma Znth_sub_0_r: forall A i l (d: A), Znth (i - 0) l d = Znth i l d.
  intros.
  rewrite Z.sub_0_r by omega.
  auto.
Qed.

Lemma Znth_map_Vint: forall (i : Z) (l : list int),
  0 <= i < Zlength l -> Znth i (map Vint l) Vundef = Vint (Znth i l Int.zero).
Proof.
  intros i l.
  apply Znth_map.
Qed.

End zlist_hint_db.

(*Hint Rewrite @zl_constr_correct using solve [omega] : zl_nth_db.
Hint Rewrite zlist_hint_db.Znth_sub_0_r : zl_nth_db.
Hint Rewrite zlist_hint_db.Znth_map_Vint using solve [omega] : zl_nth_db.
Hint Rewrite (fun A d => @zl_sublist_correct A d _ (list_zlist_correct _ _)) using solve [omega] : zl_nth_db.
Hint Rewrite (fun A d => @zl_concat_correct_l A d _ (list_zlist_correct _ _)) using solve [omega] : zl_nth_db.
Hint Rewrite (fun A d => @zl_concat_correct_r A d _ (list_zlist_correct _ _)) using solve [omega] : zl_nth_db.

Hint Rewrite (fun A d => @zl_sub_concat_l A d _ (list_zlist_correct _ _)) using solve [omega] : zl_sub_db.
Hint Rewrite (fun A d => @zl_sub_concat_r A d _ (list_zlist_correct _ _)) using solve [omega] : zl_sub_db.
Hint Rewrite (fun A d => @zl_sub_concat_mid A d _ (list_zlist_correct _ _)) using solve [omega] : zl_sub_db.
Hint Rewrite (fun A d => @zl_sub_sub A d _ (list_zlist_correct _ _)) using solve [omega] : zl_sub_db.
Hint Rewrite (fun A d => @zl_sub_self A d _ (list_zlist_correct _ _)) using solve [omega] : zl_sub_db.
Hint Rewrite (fun A d => @zl_sub_empty A d _ (list_zlist_correct _ _)) using solve [omega] : zl_sub_db.
Hint Rewrite (fun A d => @zl_concat_empty_l A d _ (list_zlist_correct _ _)) using solve [omega] : zl_sub_db.
Hint Rewrite (fun A d => @zl_concat_empty_r A d _ (list_zlist_correct _ _)) using solve [omega] : zl_sub_db.
*)
Section POSE_TAC.

Context {cs: compspecs}.

Definition eq_pose {A} x y := @eq A x y.

Definition abs_pose t (v: reptype t) : Prop := True.

Definition concr_pose t (v: reptype t) : Prop := True.

End POSE_TAC.

Ltac abs_or_concr t v :=
  let t' := eval compute in t in
  match t' with
  | Tarray _ _ _ =>
    match v with
    | @nil _ => assert (concr_pose t v) by exact I
    | _ :: _ => assert (concr_pose t v) by exact I
    | _ => assert (abs_pose t v) by exact I
    end
  | Tstruct ?id _ =>
    let m := eval compute in (co_members (get_co id)) in
    match m with
    | @nil _ => assert (concr_pose t v) by exact I
    | _ :: @nil _ => assert (concr_pose t v) by exact I
    | _ => match v with
           | (_, _) => assert (concr_pose t v) by exact I
           | _ => assert (abs_pose t v) by exact I
           end
    end
  | Tunion ?id _ =>
    let m := eval compute in (co_members (get_co id)) in
    match m with
    | @nil _ => assert (concr_pose t v) by exact I
    | _ :: @nil _ => assert (concr_pose t v) by exact I
    | _ => match v with
           | (_, _) => assert (concr_pose t v) by exact I
           | _ => assert (abs_pose t v) by exact I
           end
    end
  end.

Transparent peq.

Ltac cbv_proj_struct H :=
    cbv beta zeta iota delta
    [proj_struct proj_compact_prod list_rect
    member_dec field_type Ctypes.field_type
     ident_eq peq Pos.eq_dec BinNums.positive_rec positive_rect
    sumbool_rec sumbool_rect bool_dec bool_rec bool_rect option_rec option_rect
    eq_rect_r eq_rect eq_rec_r eq_rec eq_sym eq_trans f_equal
    type_eq type_rec type_rect typelist_eq typelist_rec typelist_rect
    intsize_rec intsize_rect signedness_rec signedness_rect floatsize_rec floatsize_rect
    tvoid tschar tuchar tshort tushort tint
    tuint tbool tlong tulong tfloat tdouble tptr tarray noattr
    ] in H; simpl in H.

Ltac pose_proj_reptype_1 CS t gf v H :=
  assert (@proj_gfield_reptype CS t gf v = @proj_gfield_reptype CS t gf v) as H by reflexivity;
  let H0 := fresh "H" in
  let H1 := fresh "H" in
  let V := fresh "v" in
  let t' := eval compute in t in
  remember v as V eqn:H0 in H at 2;
  match type of V with
  | ?t_temp => change t_temp with (@reptype CS t) in V
  end;
  change (@proj_gfield_reptype CS t gf V) with (@proj_gfield_reptype CS t' gf V) in H;
  unfold proj_gfield_reptype in H at 2;
  pose proof unfold_reptype_JMeq t' V as H1;
  apply JMeq_eq in H1;
  rewrite H1 in H; clear H1;
  match type of H with
  | _ = proj_struct ?i ?m V ?d =>
    let v_res := fresh "v" in
    let H_eq := fresh "H" in
    remember (proj_struct i m V d) as v_res eqn:H_eq;
    let d' := eval vm_compute in d in change d with d' in H_eq;
    let m' := eval vm_compute in m in change m with m' in H_eq;
    cbv_proj_struct H_eq;
    subst v_res;
    subst V
(*  | _ = zl_nth ?i ?l =>
    subst V;
    autorewrite with zl_nth_db in H
*)
  | _ =>
    subst V
  end
.

Ltac pose_proj_reptype CS t gfs v H :=
  match gfs with
  | nil =>
      assert (eq_pose (@proj_reptype CS t gfs v) v) as H by reflexivity
  | ?gf :: ?gfs0 =>
     pose proof I as H;   (* *0* SEE LINE *1* *)
     let H0 := fresh "H" in
     pose_proj_reptype CS t gfs0 v H0;
     match type of H0 with
     | eq_pose (proj_reptype t gfs0 v) ?v0 =>
         let H1 := fresh "H" in
         match gfs0 with
         | nil => pose_proj_reptype_1 CS t gf v0 H1
         | _ => pose_proj_reptype_1 CS (nested_field_type t gfs0) gf v0 H1
         end;
         clear H;         (* *1* SEE LINE *0* *)
         match gfs0 with
         | nil => assert (eq_pose (@proj_reptype CS t gfs v) (@proj_gfield_reptype CS t gf v0)) as H
         | _ => assert (eq_pose (@proj_reptype CS t gfs v)
                   (@proj_gfield_reptype CS (nested_field_type t gfs0) gf v0)) as H
         end;
         [unfold eq_pose in *; rewrite <- H0; unfold proj_reptype, eq_rect_r; apply eq_sym, eq_rect_eq |];
         rewrite H1 in H;
         clear H1
     end
  end.

Ltac pose_upd_reptype_1 CS t gf v v0 H :=
  let t' := eval compute in t in
  assert (data_equal (@upd_gfield_reptype CS t gf v v0) (@upd_gfield_reptype CS t' gf v v0)) as H
    by reflexivity;
  unfold upd_gfield_reptype at 2 in H;
  let H0 := fresh "H" in
  pose proof unfold_reptype_JMeq t' v as H0;
  apply JMeq_eq in H0;
  rewrite H0 in H;
  clear H0;
  match t' with
  | Tarray _ _ _ => autorewrite with zl_sub_db in H
  | _ => idtac
  end;
  unfold upd_compact_prod, eq_rect_r in H; simpl in H;
  match type of H with
  | data_equal _ (fold_reptype ?v_res) =>
    pose proof (JMeq_eq (fold_reptype_JMeq t' v_res)) as H0;
    rewrite H0 in H;
    clear H0
  end.

Ltac pose_upd_reptype CS t gfs v v0 H :=
  match gfs with
  | nil =>
      assert (data_equal (@upd_reptype CS t gfs v v0) v0) as H by reflexivity
  | ?gf :: ?gfs0 =>
      pose proof I as H;   (* *2* SEE LINE *3* *)
      match goal with
      | HH : eq_pose (proj_reptype t gfs0 v) ?v1 |- _ =>
          let H_upd1 := fresh "H_upd1" in
          pose_upd_reptype_1 CS (nested_field_type t gfs0) gf v1 v0 H_upd1;
          match type of H_upd1 with
          | data_equal _ ?v1' =>
                  let H0 := fresh "H" in
                  pose_upd_reptype CS t gfs0 v v1' H0;
                  match type of H0 with
                  | data_equal _ ?v_res =>
                      clear H;         (* *3* SEE LINE *2* *)
                      assert (H: data_equal (@upd_reptype CS t gfs v v0) v_res);
                          [| clear H_upd1 H0]
                  end;
                 [change (@upd_reptype CS t gfs v v0) with
                   (@upd_reptype CS t gfs0 v (upd_gfield_reptype _ gf (proj_reptype t gfs0 v) v0));
                  unfold eq_pose in HH; rewrite HH;
                  eapply Equivalence.equiv_transitive;
                  [apply upd_reptype_data_equal; exact H_upd1 | exact H0]
                 | clear HH]
          end
      end
  end.

Module Type TestType.
End TestType.
Module Test : TestType.

Definition _f1 := 1%positive.
Definition _f2 := 2%positive.
Definition _f3 := 3%positive.
Definition _f4 := 4%positive.
Definition _f5 := 5%positive.
Definition cd1 := Composite 101%positive Struct ((_f1, tint) :: (_f2%positive, tint) :: nil) noattr.
Definition cd2 := Composite 102%positive Struct ((_f3, Tstruct 101%positive noattr) ::
                                 (_f4, Tstruct 101%positive noattr) ::
                                 (_f5, Tpointer (Tstruct 101%positive noattr) noattr) :: nil) noattr.
Definition cenv := match build_composite_env (cd1 :: cd2 :: nil) with Errors.OK env => env | _ => PTree.empty _ end.

Instance cs: compspecs.
  apply (mkcompspecs cenv).
+
  apply build_composite_env_consistent with (defs := cd1 :: cd2 :: nil).
  reflexivity.
  + intros ? ? ?.
    apply PTree.elements_correct in H.
    revert H.
    change co with (snd (id, co)) at 2.
    forget (id, co) as ele.
    revert ele.
    apply Forall_forall.
    assert (8 >= 8) by omega.
    assert (4 >= 4) by omega.
    repeat constructor; unfold composite_legal_alignas; assumption.
  + intros ? ? ?.
    apply PTree.elements_correct in H.
    revert H.
    change co with (snd (id, co)) at 2.
    forget (id, co) as ele.
    revert ele.
    apply Forall_forall.
    repeat constructor; unfold composite_legal_alignas; reflexivity.
Defined.

Definition t1 := Tstruct 101%positive noattr.
Definition t2 := Tstruct 102%positive noattr.
Definition v1: reptype t1 := (Vint Int.zero, Vint Int.one).
Definition v2: reptype t2 := ((Vint Int.zero, Vint Int.one), ((Vint Int.zero, Vint Int.one), Vundef)).

(*
Eval vm_compute in (reptype_gen t2).
Eval vm_compute in (proj_reptype t1 (StructField 1%positive :: nil) v1).
*)
Goal proj_reptype t1 (StructField _f1 :: nil) v1 = Vint Int.zero.
reflexivity.
Qed.

Goal proj_reptype t2 (StructField _f2 :: StructField _f3 :: nil) v2 = Vint Int.one.
unfold v2.
pose_proj_reptype cs t2
  (StructField _f2 :: StructField _f3 :: nil) ((Vint Int.zero, Vint Int.one, (Vint Int.zero, Vint Int.one, Vundef)): reptype (Tstruct 102%positive noattr)) HH.
eauto.
Time Qed. (* Cut down from 10 seconds to 4 seconds, magically. *)

Goal forall n l, 0 < n -> proj_reptype (tarray tint n) (ArraySubsc 0 :: nil) l = Znth 0 l Vundef.
intros.
pose_proj_reptype cs (tarray tint n) (ArraySubsc 0 :: nil) l HH.
exact HH.
Qed.

Goal data_equal (upd_reptype t2 (StructField 3%positive :: nil) v2 (Vint Int.one, Vint Int.one))
((Vint Int.one, Vint Int.one), ((Vint Int.zero, Vint Int.one), Vundef)).
set (v0 := (Vint Int.one, Vint Int.one)).
change (val * val)%type with (reptype (Tstruct 101%positive noattr)) in v0.
pose_proj_reptype cs (Tstruct 102%positive noattr) (StructField 3%positive :: nil) v2 H.
pose_upd_reptype cs (Tstruct 102%positive noattr) (StructField 3%positive :: nil) v2 v0 H1.
exact H1.
Qed.

Goal forall n l, 0 < n -> data_equal
    (upd_reptype (tarray tint n) (ArraySubsc 0 :: nil) l Vundef)
    (Vundef :: sublist 1 (Zlength l) l).
intros.
pose_proj_reptype cs (tarray tint n) (ArraySubsc 0 :: nil) l HH.
pose_upd_reptype cs (tarray tint n) (ArraySubsc 0 :: nil) l Vundef HHH.
exact HHH.
Qed.

End Test.


Add LoadPath "..".
Add LoadPath "../Labeled".
Add LoadPath "../Hybrid".

Require Import Shared.
Require Import Labeled.
Require Import Hybrid.
Require Import Arith.

Open Scope is5_scope.
Open Scope permut_scope.
Open Scope labeled_is5_scope.
Open Scope hybrid_is5_scope.

(* Context conversion *)

Fixpoint annotate_worlds_Hyb (w: var) (L: ctx_LF) : ctx_L :=
match L with
  | nil => nil
  | (x, T) :: L' => (w, (x, T)) :: annotate_worlds_Hyb w L'
end.

Definition Hyb_to_L_ctx (G: bg_Hyb) (Ctx: ctx_Hyb) :
  (list var) * ctx_L * var :=
  let Omega := map fst_ (Ctx :: G) in
  let Delta := flat_map (fun x => annotate_worlds_Hyb (fst_ x) (snd_ x))
    (Ctx :: G) in
  (Omega, Delta, fst Ctx).

Lemma annotate_worlds_Hyb_app:
forall l1 l2 x,
  annotate_worlds_Hyb x (l1++l2) =
  annotate_worlds_Hyb x l1 ++ annotate_worlds_Hyb x l2.
induction l1; intros; rew_app; simpl; auto; destruct a; simpl;
rewrite IHl1; rew_app; auto.
Qed.

Lemma permut_annotate_worlds_Hyb:
forall l l' x,
  l *=* l' -> annotate_worlds_Hyb x l *=* annotate_worlds_Hyb x l'.
induction l; intros.
apply permut_nil_eq in H; subst; auto.
assert (a::l *=* l') by auto;
apply permut_split_head in H; destruct H as (hd, (tl, H)); subst;
destruct a; simpl; repeat rewrite annotate_worlds_Hyb_app; simpl;
permut_simpl; replace (annotate_worlds_Hyb x hd ++ annotate_worlds_Hyb x tl)
with (annotate_worlds_Hyb x (hd++tl)) by (apply annotate_worlds_Hyb_app; auto).
apply IHl;
apply permut_cons_inv with (a:=(v,t)); rewrite H0; permut_simpl.
Qed.

Lemma PPermut_Hyb_flat_map_annotate_worlds_Hyb:
forall G G',
  G ~=~ G' ->
  flat_map (fun x => annotate_worlds_Hyb (fst_ x) (snd_ x)) G *=*
  flat_map (fun x => annotate_worlds_Hyb (fst_ x) (snd_ x)) G'.
induction G; intros.
remember (fun x : var * list (var * ty) =>
            annotate_worlds_Hyb (fst_ x) (snd_ x))
  as g;
apply PPermut_Hyb_nil_impl in H; subst; auto.
assert (a::G ~=~ G') by auto;
destruct a; apply PPermut_Hyb_split_head in H;
destruct H as (l', (hd, (tl, (Ha, Hb)))); subst;
rew_flat_map; simpl;
assert (l *=* l') by auto;
apply permut_annotate_worlds_Hyb with (x:=v) in Ha;
rewrite Ha; permut_simpl;
rewrite IHG with (G':=hd++tl); rew_flat_map; auto;
apply PPermut_Hyb_last_rev with (w:=v) (Gamma:=l) (Gamma':=l);
auto; transitivity ((v,l)::G); [ | rewrite H0]; PPermut_Hyb_simpl.
Qed.

Lemma ok_Hyb_to_L_ctx_ok_Omega_L:
forall G w Gamma Omega,
  ok_Hyb ((w, Gamma)::G) nil ->
  Omega *=* fst_ (fst_ (Hyb_to_L_ctx G (w, Gamma))) ->
  ok_Omega_L Omega.
induction G; intros; inversion H; subst;
[simpl in *; eauto | destruct a];
rew_map in *; simpl in *.
apply ok_Omega_L_permut with (O1:=w::nil);
  [symmetry | constructor]; auto; constructor.
rew_map in *; simpl in *.
inversion H6; subst;
assert (v::w::map fst_ G *=* Omega) by (rewrite H0; permut_simpl).
apply permut_split_head in H1; destruct H1 as (hd, (tl, H1)); subst.
apply ok_Omega_L_permut with (O1:=v::hd++tl); [permut_simpl | constructor].
apply ok_Hyb_not_Mem_fst with (w:=v) in H8; [ | apply Mem_here].
intro. apply Mem_permut with (l':=w::map fst_ G) in H1.
rewrite Mem_cons_eq in H1; destruct H1;
[ subst; elim H7; apply Mem_here | contradiction].
apply permut_cons_inv with (a:=v);
transitivity (hd & v ++ tl); [ | rewrite H0]; permut_simpl.
  apply IHG with (w:=w) (Gamma:=Gamma).
  inversion H6; subst; constructor; auto.
  apply ok_Hyb_used_weakening in H10; auto.
  apply permut_cons_inv with (a:=v);
    transitivity (hd & v ++ tl); [ | rewrite H0]; permut_simpl.
Qed.

Lemma ok_Hyb_to_L_ctx_ok_Gamma_L:
forall G Gamma w Delta U,
  ok_Hyb (flat_map snd_ ((w, Gamma)::G)) U ->
  Delta *=* snd_ (fst_ (Hyb_to_L_ctx G (w, Gamma))) ->
  ok_Gamma_L Delta U.
induction G; induction Gamma; intros; simpl in *; rew_app in *.
symmetry in H0; apply permut_nil_eq in H0; subst; constructor.
destruct a; simpl in *; inversion H; subst;
apply ok_Gamma_L_permut with (G1:=(w, (v, t)) :: annotate_worlds_Hyb w Gamma);
[symmetry | constructor]; auto; apply IHGamma with (w:=w); rew_app; auto.
destruct a; simpl in *;
apply ok_Gamma_L_permut with (G1:=annotate_worlds_Hyb v l ++ flat_map
         (fun x : var * list (var * ty) =>
            annotate_worlds_Hyb (fst_ x) (snd_ x))
         G); [symmetry |]; auto;
apply IHG with (w:=v) (Gamma:=l); auto; permut_simpl.
destruct a0; destruct a; simpl in *; inversion H; subst;
apply ok_Gamma_L_permut with
  (G1:=((w, (v, t)) :: annotate_worlds_Hyb w Gamma) ++
       annotate_worlds_Hyb v0 l ++
       flat_map
         (fun x : var * list (var * ty) =>
            annotate_worlds_Hyb (fst_ x) (snd_ x))
         G); [symmetry |]; auto;
rew_app; constructor; auto;
apply IHGamma with (w:=w); auto; permut_simpl.
Qed.

Lemma ok_Hyb_to_L_ctx_ok_L:
forall G w Gamma Omega Delta,
  ok_Bg_Hyb ((w, Gamma)::G) ->
  Omega *=* fst_ (fst_ (Hyb_to_L_ctx G (w, Gamma))) ->
  Delta *=* snd_ (fst_ (Hyb_to_L_ctx G (w, Gamma))) ->
  ok_L Omega Delta.
intros; destruct H; split;
[eapply ok_Hyb_to_L_ctx_ok_Omega_L |
 eapply ok_Hyb_to_L_ctx_ok_Gamma_L]; eauto.
Qed.

Lemma Mem_preserved_world_L:
forall G w Gamma Omega,
  Omega *=* fst_ (fst_ (Hyb_to_L_ctx G (w, Gamma))) ->
  forall w0 Gamma0,
    Mem (w0, Gamma0) ((w, Gamma)::G) ->
    Mem w0 Omega.
induction G; intros; simpl in *.
rewrite Mem_cons_eq in H0; destruct H0;
[ | rewrite Mem_nil_eq in H0; contradiction];
inversion H0; subst; apply Mem_permut with (l:=map fst_ ((w, Gamma)::nil));
[symmetry; auto | rew_map; simpl; apply Mem_here].
destruct a;
eapply Mem_permut with (l:=map fst_ ((w, Gamma) :: (v, l) :: G));
[symmetry; auto | ]; rewrite Mem_cons_eq in H0; destruct H0.
inversion H0; subst; rew_map; simpl; apply Mem_here.
destruct (eq_var_dec w0 v); subst.
rew_map; simpl; repeat rewrite Mem_cons_eq; right; left; auto.
rewrite Mem_cons_eq in H0; destruct H0.
inversion H0; subst; repeat rewrite Mem_cons_eq; right; left; auto.
rew_map; simpl. apply Mem_permut with (l:=v::w::map fst_ G);
[permut_simpl | rewrite Mem_cons_eq; right];
apply IHG with (w:=w) (Gamma:=Gamma) (Gamma0:=Gamma0).
rew_map; simpl; auto.
rewrite Mem_cons_eq; right; auto.
Qed.

Lemma Mem_annotate_worlds_Hyb:
forall Gamma w Delta x a,
  Delta = annotate_worlds_Hyb w Gamma ->
  (Mem (x, a) Gamma <-> Mem (w, (x, a)) Delta).
induction Gamma; intros; simpl in *; subst.
repeat rewrite Mem_nil_eq; tauto.
destruct a; repeat rewrite Mem_cons_eq; split; intros;
destruct H; try inversion H; subst; simpl in *.
left; auto.
right; apply Mem_here.
destruct y; right; apply IHGamma; auto.
left; auto.
right; eapply IHGamma; eauto; apply Mem_here.
right; eapply IHGamma; eauto. rewrite H0; auto.
Qed.

Lemma Mem_preserved_term_L:
forall G w Gamma Delta,
  Delta *=* snd_ (fst_ (Hyb_to_L_ctx G (w, Gamma))) ->
  forall w0 x0 a0 Gamma0,
    Mem (w0, Gamma0) ((w, Gamma)::G) ->
    Mem (x0, a0) Gamma0 ->
    Mem  (w0, (x0, a0)) Delta.
induction G; intros; simpl in *.
rewrite Mem_cons_eq in H0; destruct H0.
inversion H0; subst;
apply Mem_permut with (l:=annotate_worlds_Hyb w Gamma);
[symmetry; rew_app in *; auto | rew_map; simpl];
eapply Mem_annotate_worlds_Hyb; auto.
rewrite Mem_nil_eq in H0; contradiction.
destruct a; simpl in *.
apply Mem_permut with (l:=annotate_worlds_Hyb w Gamma ++
                          annotate_worlds_Hyb v l ++
  flat_map
        (fun x : var * list (var * ty) =>
           annotate_worlds_Hyb (fst_ x) (snd_ x))
        G);
[symmetry; rew_app in *; auto | rew_map; simpl].
repeat rewrite Mem_cons_eq in H0; repeat rewrite Mem_app_or_eq; destruct H0.
inversion H0; subst.
left; eapply Mem_annotate_worlds_Hyb; auto.
destruct H0.
inversion H0; subst; right; left; eapply Mem_annotate_worlds_Hyb; auto.
right; right; apply IHG with (w:=w) (Gamma:=nil) (Gamma0 := Gamma0);
simpl; auto; rewrite Mem_cons_eq; right; auto.
Qed.

(* Term conversion *)
Fixpoint Hyb_to_L_term (M0: te_Hyb) :=
match M0 with
| hyp_Hyb v =>
  hyp_L v
| lam_Hyb A M =>
  lam_L A (Hyb_to_L_term M)
| appl_Hyb M N =>
  appl_L (Hyb_to_L_term M) (Hyb_to_L_term N)
| box_Hyb M =>
  box_L (Hyb_to_L_term M)
| unbox_fetch_Hyb w M =>
  unbox_L (fetch_L w (Hyb_to_L_term M))
| get_here_Hyb w M =>
  get_L w (here_L (Hyb_to_L_term M))
| letdia_get_Hyb w M N =>
  letd_L (get_L w (Hyb_to_L_term M)) (Hyb_to_L_term N)
end.

Lemma Hyb_to_L_term_subst_t:
forall M N x,
  subst_t_L (Hyb_to_L_term M) x (Hyb_to_L_term N) =
  Hyb_to_L_term (subst_t_Hyb M x N).
induction N; intros; simpl in *;
try rewrite IHN || (rewrite IHN1; rewrite IHN2); auto;
case_if; simpl; auto.
Qed.

Lemma Hyb_to_L_term_subst_w:
forall M w w',
  subst_w_L (Hyb_to_L_term M) w w' =
  Hyb_to_L_term (subst_w_Hyb w w' M).
induction M; intros; simpl in *;
try rewrite IHM || (rewrite IHM1; rewrite IHM2); auto;
case_if; simpl; auto.
Qed.

Lemma Hyb_to_L_typing:
forall G w Gamma M A Omega Delta w' M'
  (HT: G |= (w, Gamma) |- M ::: A)
  (H_Omega: Omega *=* fst_ (fst_ (Hyb_to_L_ctx G (w, Gamma))))
  (H_Delta: Delta *=* snd_ (fst_ (Hyb_to_L_ctx G (w, Gamma))))
  (H_w: w' = snd_ (Hyb_to_L_ctx G (w, Gamma)))
  (H_M: M' = Hyb_to_L_term M),
  Omega; Delta |- M' ::: A @ w.
intros;
unfold Hyb_to_L_ctx in *; rew_flat_map in *; rew_map in *;
simpl in *; subst;
generalize dependent Omega;
generalize dependent Delta;
remember (w, Gamma) as Ctx;
generalize dependent w;
generalize dependent Gamma.
induction HT;
intros; inversion HeqCtx; subst; simpl in *.
(* hyp *)
apply t_hyp_L.
  eapply ok_Hyb_to_L_ctx_ok_L; simpl; eauto.
  eapply Mem_preserved_world_L with (w:=w0) (Gamma:=Gamma0);
    simpl; eauto; eapply Mem_here.
  eapply Mem_preserved_term_L with (w:=w0) (Gamma:=Gamma0);
    simpl; eauto; eapply Mem_here.
(* lam *)
apply t_lam_L with (L:=L).
  eapply ok_Hyb_to_L_ctx_ok_L; eauto.
  intros. replace (hyp_L (fte x)) with (Hyb_to_L_term (hyp_Hyb (fte x))).
  unfold open_t_L; rewrite Hyb_to_L_term_subst_t. eapply H; eauto.
  simpl; permut_simpl; auto.
  simpl; auto.
(* appl *)
apply t_appl_L with (A:=A).
  eapply ok_Hyb_to_L_ctx_ok_L; eauto.
  eapply IHHT1; eauto.
  eapply IHHT2; eauto.
(* box *)
apply t_box_L with (L:=L).
  apply ok_Hyb_to_L_ctx_ok_L with (G:=G) (w:=w0) (Gamma:=Gamma0); auto;
    assert ((w0, Gamma0) :: G ~=~ G & (w0, Gamma0)) as H1 by PPermut_Hyb_simpl;
    rewrite H1; auto.
  eapply Mem_preserved_world_L with (w:=w0) (Gamma:=Gamma0);
    simpl; eauto; eapply Mem_here.
  intros; unfold open_w_L; rewrite Hyb_to_L_term_subst_w.
  apply H with (Gamma:=nil); auto.
  rewrite H_Delta; simpl; rew_app; rew_flat_map; simpl; permut_simpl.
  rew_map; simpl; rewrite H_Omega; permut_simpl.
(* unbox_fetch *)
apply t_unbox_L.
  eapply ok_Hyb_to_L_ctx_ok_L; eauto.
  apply t_fetch_L.
    eapply ok_Hyb_to_L_ctx_ok_L; eauto.
    eapply IHHT; eauto.
    apply Mem_permut with (l:=w0::map fst_ G);
    [ symmetry | apply Mem_here ]; auto.
apply t_unbox_L.
  eapply ok_Hyb_to_L_ctx_ok_L; eauto.
  simpl; rew_map; simpl; rewrite H_Omega; permut_simpl.
  replace ((w::nil) ++ map fst_ G) with (map fst_ ((w, Gamma)::G))
    by (rew_map; simpl; auto);
  apply PPermut_Hyb_map_fst; rewrite <- H; PPermut_Hyb_simpl.
  simpl; rewrite H_Delta; rew_flat_map; simpl; permut_simpl.
  apply PPermut_Hyb_flat_map_annotate_worlds_Hyb in H; rew_map in *;
    rewrite <- H; rew_flat_map; simpl; permut_simpl.
  apply t_fetch_L.
    eapply ok_Hyb_to_L_ctx_ok_L; eauto.
    rewrite H_Omega; symmetry; simpl; rew_map; simpl; permut_simpl.
    replace ((w::nil) ++ map fst_ G) with (map fst_ ((w, Gamma)::G))
      by (rew_map; simpl; auto);
    apply PPermut_Hyb_map_fst; rewrite <- H; PPermut_Hyb_simpl.
    simpl; rewrite H_Delta; rew_flat_map; simpl; permut_simpl.
    apply PPermut_Hyb_flat_map_annotate_worlds_Hyb in H; rew_map in *;
      rewrite <- H; rew_flat_map; simpl; permut_simpl.
    eapply IHHT; eauto.
    simpl; rewrite H_Delta; rew_flat_map; simpl; permut_simpl.
    apply PPermut_Hyb_flat_map_annotate_worlds_Hyb in H; rew_map in *;
      rewrite <- H; rew_flat_map; simpl; permut_simpl.
    rewrite H_Omega; rew_map; simpl; permut_simpl.
    replace ((w::nil) ++ map fst_ G) with (map fst_ ((w, Gamma)::G))
      by (rew_map; simpl; auto);
    apply PPermut_Hyb_map_fst; rewrite <- H; PPermut_Hyb_simpl.
    eapply Mem_preserved_world_L with (w:=w0) (Gamma:=Gamma0);
    simpl; eauto; eapply Mem_here.
(* get_here *)
apply t_get_L.
  eapply ok_Hyb_to_L_ctx_ok_L; eauto.
  apply t_here_L.
    eapply ok_Hyb_to_L_ctx_ok_L; eauto.
    eapply IHHT; eauto.
    apply Mem_permut with (l:=w0::map fst_ G);
    [ symmetry | apply Mem_here ]; auto.
apply t_get_L.
  eapply ok_Hyb_to_L_ctx_ok_L; eauto.
  simpl; rew_map; simpl; rewrite H_Omega; permut_simpl.
  replace ((w::nil) ++ map fst_ G) with (map fst_ ((w, Gamma)::G))
    by (rew_map; simpl; auto);
  apply PPermut_Hyb_map_fst; rewrite <- H; PPermut_Hyb_simpl.
  simpl; rewrite H_Delta; rew_flat_map; simpl; permut_simpl.
  apply PPermut_Hyb_flat_map_annotate_worlds_Hyb in H; rew_map in *;
    rewrite <- H; rew_flat_map; simpl; permut_simpl.
  apply t_here_L.
    eapply ok_Hyb_to_L_ctx_ok_L; eauto.
    rewrite H_Omega; symmetry; simpl; rew_map; simpl; permut_simpl.
    replace ((w::nil) ++ map fst_ G) with (map fst_ ((w, Gamma)::G))
      by (rew_map; simpl; auto);
    apply PPermut_Hyb_map_fst; rewrite <- H; PPermut_Hyb_simpl.
    simpl; rewrite H_Delta; rew_flat_map; simpl; permut_simpl.
    apply PPermut_Hyb_flat_map_annotate_worlds_Hyb in H; rew_map in *;
      rewrite <- H; rew_flat_map; simpl; permut_simpl.
    eapply IHHT; eauto.
    simpl; rewrite H_Delta; rew_flat_map; simpl; permut_simpl.
    apply PPermut_Hyb_flat_map_annotate_worlds_Hyb in H; rew_map in *;
      rewrite <- H; rew_flat_map; simpl; permut_simpl.
    rewrite H_Omega; rew_map; simpl; permut_simpl.
    replace ((w::nil) ++ map fst_ G) with (map fst_ ((w, Gamma)::G))
      by (rew_map; simpl; auto);
    apply PPermut_Hyb_map_fst; rewrite <- H; PPermut_Hyb_simpl.
    eapply Mem_preserved_world_L with (w:=w0) (Gamma:=Gamma0);
    simpl; eauto; eapply Mem_here.
(* letdia_get *)
apply t_letd_L with (A:=A) (Lt:=L_t) (Lw:=L_w).
  eapply ok_Hyb_to_L_ctx_ok_L; eauto.
  apply t_get_L.
    eapply ok_Hyb_to_L_ctx_ok_L; eauto.
    eapply IHHT; eauto.
    eapply Mem_preserved_world_L with (w:=w0) (Gamma:=Gamma0);
    simpl; eauto; eapply Mem_here.
  intros; unfold open_t_Hyb in *; unfold open_w_Hyb in *;
  unfold open_t_L in *; unfold open_w_L in *.
    rewrite Hyb_to_L_term_subst_w.
    replace (hyp_L (fte t)) with (Hyb_to_L_term (hyp_Hyb (fte t))).
    rewrite Hyb_to_L_term_subst_t.
    eapply H; eauto.
    rewrite H_Delta; rew_map; simpl; permut_simpl.
    rewrite H_Omega; rew_map; simpl; permut_simpl.
    simpl; auto.
apply t_letd_L with (A:=A) (Lt:=L_t) (Lw:=L_w).
  eapply ok_Hyb_to_L_ctx_ok_L; eauto.
  rewrite H_Omega; simpl; rew_map; simpl; permut_simpl;
  replace ((w::nil) ++ map fst_ G) with (map fst_ ((w, Gamma)::G))
    by (rew_map; simpl; auto);
  apply PPermut_Hyb_map_fst; rewrite <- H0; PPermut_Hyb_simpl.
  simpl; rewrite H_Delta; rew_flat_map; simpl; permut_simpl;
  apply PPermut_Hyb_flat_map_annotate_worlds_Hyb in H0; rew_map in *;
  rewrite <- H0; rew_flat_map; simpl; permut_simpl.
  apply t_get_L.
    eapply ok_Hyb_to_L_ctx_ok_L; eauto.
    rewrite H_Omega; simpl; rew_map; simpl; permut_simpl;
    replace ((w::nil) ++ map fst_ G) with (map fst_ ((w, Gamma)::G))
      by (rew_map; simpl; auto);
    apply PPermut_Hyb_map_fst; rewrite <- H0; PPermut_Hyb_simpl.
    simpl; rewrite H_Delta; rew_flat_map; simpl; permut_simpl;
    apply PPermut_Hyb_flat_map_annotate_worlds_Hyb in H0; rew_map in *;
    rewrite <- H0; rew_flat_map; simpl; permut_simpl.
    eapply IHHT; eauto.
    simpl; rewrite H_Delta; rew_flat_map; simpl; permut_simpl;
    apply PPermut_Hyb_flat_map_annotate_worlds_Hyb in H0; rew_map in *;
    rewrite <- H0; rew_flat_map; simpl; permut_simpl.
    rewrite H_Omega; simpl; rew_map; simpl; permut_simpl;
    replace ((w::nil) ++ map fst_ G) with (map fst_ ((w, Gamma)::G))
      by (rew_map; simpl; auto);
    apply PPermut_Hyb_map_fst; rewrite <- H0; PPermut_Hyb_simpl.
    eapply Mem_preserved_world_L with (w:=w0) (Gamma:=Gamma0);
    simpl; eauto; eapply Mem_here.
    intros; unfold open_t_Hyb in *; unfold open_w_Hyb in *;
    unfold open_t_L in *; unfold open_w_L in *.
    rewrite Hyb_to_L_term_subst_w.
    replace (hyp_L (fte t)) with (Hyb_to_L_term (hyp_Hyb (fte t))).
    rewrite Hyb_to_L_term_subst_t.
    eapply H; eauto.
    simpl; rewrite H_Delta; rew_flat_map; simpl; permut_simpl;
    apply PPermut_Hyb_flat_map_annotate_worlds_Hyb in H0; rew_map in *;
    rewrite <- H0; rew_flat_map; simpl; permut_simpl.
    rewrite H_Omega; simpl; rew_map; simpl; permut_simpl.
    replace (map fst_ G & w) with (map fst_ (G & (w, Gamma)))
      by (rew_map; simpl; auto);
    apply PPermut_Hyb_map_fst; rewrite <- H0; PPermut_Hyb_simpl.
    simpl; auto.
Qed.

Lemma Hyb_to_L_term_lc_w:
forall M n,
  lc_w_n_Hyb n M -> lc_w_n_L n (Hyb_to_L_term M).
induction M; intros; inversion H; subst; simpl in *;
try destruct v; repeat constructor; eauto.
Qed.

Lemma Hyb_to_L_term_lc_t:
forall M n,
  lc_t_n_Hyb n M -> lc_t_n_L n (Hyb_to_L_term M).
induction M; intros; inversion H; subst; simpl in *;
repeat constructor; eauto.
Qed.

Hint Resolve Hyb_to_L_term_lc_w Hyb_to_L_term_lc_t.

Lemma Hyb_to_L_value:
forall M,
  value_Hyb M -> value_L (Hyb_to_L_term M).
induction M; intros; simpl; inversion H; subst; constructor; auto.
Qed.

Lemma Hyb_to_L_steps:
forall M N w,
  lc_w_Hyb M -> lc_t_Hyb M ->
  step_Hyb (M, fwo w) (N, fwo w) ->
  steps_L (Hyb_to_L_term M) (Hyb_to_L_term N) (fwo w).
induction M; intros; inversion H1; subst;
unfold open_w_Hyb in *; unfold open_t_Hyb in *;
unfold open_w_L in *; unfold open_t_L in *;
unfold lc_w_Hyb in *; unfold lc_t_Hyb in *;
simpl;
try rewrite <- Hyb_to_L_term_subst_t;
try rewrite <- Hyb_to_L_term_subst_w.
(* appl_lam *)
constructor; constructor; unfold lc_w_L in *; unfold lc_t_L in *; auto;
unfold open_t_L; apply lc_t_subst_L; auto.
(* appl *)
apply steps_L_appl_L; unfold lc_w_L in *; unfold lc_t_L in *; eauto.
(* unbox_box *)
apply stepm_L with (M':= unbox_L (box_L (Hyb_to_L_term M0))).
repeat constructor; unfold lc_w_L in *; unfold lc_t_L in *;
inversion H; inversion H0; subst; auto;
repeat constructor; eauto.
repeat constructor; unfold lc_w_L in *; unfold lc_t_L in *;
unfold open_w_L; auto.
apply lc_w_subst_L; auto.
(* unbox_fetch *)
destruct v; inversion H; subst; try omega;
apply steps_L_unbox_L_fetch_L; unfold lc_w_L in *; unfold lc_t_L in *; auto.
(* get_here *)
destruct v; inversion H; subst; try omega;
apply steps_L_get_L_here_L; unfold lc_w_L in *; unfold lc_t_L in *; auto;
inversion H1; subst.
(* letd_here*)
clear IHM2;
destruct v; destruct ctx''; inversion H; inversion H12; subst; try omega;
apply stepm_L with
  (M':=letd_L (get_L (fwo v0) (here_L (Hyb_to_L_term M)))
              (Hyb_to_L_term M2)).
repeat constructor; auto; try (apply Hyb_to_L_value; auto);
unfold open_t_L; unfold open_w_L;
unfold open_w_L; unfold open_t_L;
[ apply lc_t_subst_L | apply lc_w_subst_L]; auto; repeat constructor; auto.
constructor; constructor; auto;
unfold lc_t_L in *; unfold lc_w_L in *; auto;
unfold open_t_L; unfold open_w_L;
[apply lc_t_subst_L | apply lc_w_subst_L | apply Hyb_to_L_value]; auto.
(* letd_get *)
destruct v; inversion H; subst; try omega;
apply steps_L_letd_L_get_L; unfold lc_w_L in *; unfold lc_t_L in *; auto.
Qed.

Close Scope labeled_is5_scope.
Close Scope hybrid_is5_scope.