(*
 * 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 String.
Require Import List.
Require Import Sumbool.
Require Import Arith.
Require Import Bool.
Require Import Morphisms.
Require Import Basics.
Require Import BrandRelation.
Require Import Utils.
Require Import Types.
Require Import ForeignData.
Require Import DataModel.
Require Import ForeignDataTyping.

Section TData.
  (** Data is:
     - unit - used for undefined results.
     - nat - an integer
     - float - a floating point number (IEEE 754 double precision)
     - bool - true or false
     - string - a character string
     - coll - a bag
     - rec - a record
     - left - left sum value
     - right - right sum value
     - foreign - foreign data
   *)

  Context {fdata:foreign_data}.
  Context {ftype:foreign_type}.
  Context {fdtyping:foreign_data_typing}.
  Context {m:brand_model}.

  Definition Rrec (r1 r2:(string*data)) :=
    ODT_lt_dec (fst r1) (fst r2).

  Inductive data_type : data -> rtype -> Prop :=
  | dttop d : data_normalized brand_relation_brands d -> data_type d Top
  | dtunit : data_type dunit Unit
  | dtnat n : data_type (dnat n) Nat
  | dtfloat n : data_type (dfloat n) Float
  | dtbool b : data_type (dbool b) Bool
  | dtstring s : data_type (dstring s) String
  | dtcoll dl r : Forall (fun d => data_type d r) dl ->
                  data_type (dcoll dl) (Coll r)
  | dtrec k dl rl rl_sub pf
          (pf':is_list_sorted ODT_lt_dec (domain rl) = true) :
      sublist rl_sub rl ->
      (k = Closed -> rl_sub = rl) ->
      Forall2
        (fun d r => (fst d) = (fst r) /\ data_type (snd d) (snd r))
        dl rl ->
      data_type (drec dl) (Rec k rl_sub pf)
  | dtleft {d τl} τr : data_type d τl -> data_type (dleft d) (Either τl τr)
  | dtright {d} τl {τr} : data_type d τr -> data_type (dright d) (Either τl τr)
  | dtbrand b b' d :
      (* Ensure that only normalized brands are well typed *)
      is_canon_brands brand_relation_brands b ->
      data_normalized brand_relation_brands d ->
      Forall (fun bb =>
                forall τ,
                  lookup string_dec brand_context_types bb = Some τ ->
                  data_type d τ
                ) b ->
      b ≤ b' ->
      data_type (dbrand b d) (Brand b')
  | dtforeign {fd fτ} :
      foreign_data_typing_has_type fd fτ ->
      data_type (dforeign fd) (Foreign fτ)
  .

  Notation "d ▹ r" := (data_type d r) (at level 70). (* \triangleright *)

  Section opt.
    (* synonym for option type *)

    Lemma dtsome {d τ} :
      data_type d τ ->
      data_type (dsome d) (Option τ).
    Proof.
      intros; eapply dtleft; trivial.
    Qed.

    Lemma dtnone τ :
      data_type dnone (Option τ).
    Proof.
      intros; eapply dtright; econstructor.
    Qed.

    Lemma dtsome_inv {d τ} :
      data_type (dsome d) (Option τ) ->
      data_type d τ.
    Proof.
      inversion 1; rtype_equalizer. subst.
      trivial.
    Qed.

  End opt.

  Lemma dtrec_closed_inv {dl rl pf} :
    data_type (drec dl) (Rec Closed rl pf) ->
    Forall2
      (fun d r => (fst d) = (fst r) /\ data_type (snd d) (snd r))
      dl rl.
  Proof.
    inversion 1; intuition; subst; rtype_equalizer; subst; trivial.
  Qed.

  Lemma dtrec_full k {dl rl} pf:
       Forall2
         (fun d r => (fst d) = (fst r) /\ data_type (snd d) (snd r))
         dl rl ->
       data_type (drec dl) (Rec k rl pf).
  Proof.
    intros. apply (dtrec _ _ rl rl); intuition.
  Qed.

  Lemma dtrec_open {dl : list (string*data)} {rl rl_sub : list (string*rtype)}
        pf (pf':is_list_sorted ODT_lt_dec (domain rl) = true) :
       sublist rl_sub rl ->
       Forall2
         (fun d r => (fst d) = (fst r) /\ data_type (snd d) (snd r))
         dl rl ->
       data_type (drec dl) (Rec Open rl_sub pf).
  Proof.
    intros; apply (dtrec _ _  rl rl_sub); intuition; try discriminate.
  Qed.

  Lemma dtrec_open_pf {dl : list (string*data)} {rl rl_sub : list (string*rtype)}
        (pf':is_list_sorted ODT_lt_dec (domain rl) = true) :
    forall (sub:sublist rl_sub rl),
       Forall2
         (fun d r => (fst d) = (fst r) /\ data_type (snd d) (snd r))
         dl rl ->
       data_type (drec dl) (Rec Open rl_sub (is_list_sorted_sublist pf' (sublist_domain sub))).
  Proof.
    intros; apply (dtrec _ _  rl rl_sub); intuition; try discriminate.
  Qed.

  Lemma dtrec_closed_is_open k dl rl pf :
    data_type (drec dl) (Rec Closed rl pf) ->
    data_type (drec dl) (Rec k rl pf).
  Proof.
    intros dt. apply dtrec_closed_inv in dt; apply dtrec_full; trivial.
  Qed.

  Lemma dtbrand_inv b b' d :
    data_type (dbrand b d) (Brand b') ->
      is_canon_brands brand_relation_brands b /\
      data_normalized brand_relation_brands d /\
      Forall (fun bb =>
                forall τ,
                  lookup string_dec brand_context_types bb = Some τ ->
                  data_type d τ
                ) b /\
      b ≤ b'.
  Proof.
    inversion 1; subst.
    apply canon_equiv in H2.
    rewrite H2 in H6.
    intuition.
  Qed.

  Lemma dtbrand_refl {b d}:
    is_canon_brands brand_relation_brands b ->
    data_normalized brand_relation_brands d ->
    Forall (fun bb =>
                forall τ,
                  lookup string_dec brand_context_types bb = Some τ ->
                  data_type d τ
           ) b   ->
    data_type (dbrand b d) (Brand b).
  Proof.
    intros; eapply dtbrand; try eassumption; intuition.
  Qed.

  Lemma  data_type_ext d τ₀ pf1 pf2:
    d ▹ (exist _ τ₀ pf1) <-> d ▹ (exist _ τ₀ pf2).
  Proof.
    rewrite (wf_rtype₀_ext pf1 pf2). intuition.
  Qed.

  Lemma  data_type_fequal d τ₁ τ₂:
    (proj1_sig τ₁) = (proj1_sig τ₂) ->
    (d ▹ τ₁ <-> d ▹ τ₂).
  Proof.
    destruct τ₁; destruct τ₂; simpl; intros; subst.
    apply data_type_ext.
  Qed.

  Lemma data_type_not_bottom {d} : d ▹ ⊥ -> False.
  Proof.
    induction d; inversion 1.
  Qed.

Section inv.

  Lemma data_type_dunit_inv {τ}:
    isTop τ = false ->
    dunit ▹ τ -> τ = Unit.
  Proof.
    induction τ using rtype_rect;
    try solve [intros HH HH0; assert False; [inversion HH0|intuition]];
    eauto; simpl; try discriminate.
  Qed.

  Lemma data_type_dnat_inv {n τ}:
    isTop τ = false ->
    dnat n ▹ τ -> τ = Nat.
  Proof.
    induction τ using rtype_rect;
    try solve [intros ? HH; assert False; [inversion HH|intuition]];
    eauto; simpl; try discriminate.
  Qed.

  Lemma data_type_dfloat_inv {n τ}:
    isTop τ = false ->
    dfloat n ▹ τ -> τ = Float.
  Proof.
    induction τ using rtype_rect;
    try solve [intros ? HH; assert False; [inversion HH|intuition]];
    eauto; simpl; try discriminate.
  Qed.

  Lemma data_type_dbool_inv {b τ}:
    isTop τ = false ->
    dbool b ▹ τ -> τ = Bool.
  Proof.
    induction τ using rtype_rect;
    try solve [intros ? HH; assert False; [inversion HH|intuition]];
    eauto; simpl; try discriminate.
  Qed.

  Lemma data_type_dstring_inv {s τ}:
    isTop τ = false ->
    dstring s ▹ τ -> τ = String.
  Proof.
    induction τ using rtype_rect;
    try solve [intros ? HH; assert False; [inversion HH|intuition]];
    eauto; simpl; try discriminate.
  Qed.

  Lemma data_type_dcoll_inv {d τ}:
    isTop τ = false ->
    dcoll d ▹ τ ->
    {τ' | τ = Coll τ'}.
  Proof.
    induction τ using rtype_rect;
    try solve [intros ? HH; assert False; [inversion HH|intuition]];
    eauto; simpl; try discriminate.
  Qed.

  Lemma data_type_drec_inv {sdl τ}:
    isTop τ = false ->
    drec sdl ▹ τ ->
    {k : record_kind & {τ' | exists pf, τ = Rec k τ' pf}}.
  Proof.
    induction τ using rtype_rect;
    try solve [intros ? HH; assert False; [inversion HH|intuition]];
    eauto; simpl; try discriminate.
  Qed.

  Lemma data_type_dleft_inv {d τ} :
    isTop τ = false ->
    dleft d ▹ τ ->
    {τl : rtype & {τr | τ = Either τl τr}}.
  Proof.
    induction τ using rtype_rect;
    try solve [intros ? HH; assert False; [inversion HH|intuition]];
    eauto; simpl; try discriminate.
  Qed.

    Lemma data_type_dright_inv {d τ} :
    isTop τ = false ->
    dright d ▹ τ ->
    {τl : rtype & {τr | τ = Either τl τr}}.
  Proof.
    induction τ using rtype_rect;
    try solve [intros ? HH; assert False; [inversion HH|intuition]];
    eauto; simpl; try discriminate.
  Qed.

  Lemma data_type_dsome_inv {d τ} :
    isTop τ = false ->
    dsome d ▹ τ ->
    {τl : rtype & {τr | τ = Either τl τr}}.
  Proof.
    apply data_type_dleft_inv.
  Qed.

    Lemma data_type_dnone_inv {τ} :
    isTop τ = false ->
    dnone ▹ τ ->
    {τl : rtype & {τr | τ = Either τl τr}}.
  Proof.
    apply data_type_dright_inv.
  Qed.

  Lemma data_type_Unit_inv {d}:
    d ▹ Unit ->
    d = dunit.
  Proof.
    induction d;
    try solve [intros HH; assert False; [inversion HH|intuition]];
    eauto; simpl; try discriminate.
  Qed.

  Lemma data_type_Nat_inv {d}:
    d ▹ Nat ->
    {n | d = dnat n}.
  Proof.
    induction d;
    try solve [intros HH; assert False; [inversion HH|intuition]];
    eauto; simpl; try discriminate.
  Qed.

  Lemma data_type_Float_inv {d}:
    d ▹ Float ->
    {n | d = dfloat n}.
  Proof.
    induction d;
    try solve [intros HH; assert False; [inversion HH|intuition]];
    eauto; simpl; try discriminate.
  Qed.

  Lemma data_type_Bool_inv {d}:
    d ▹ Bool ->
    {b | d = dbool b}.
  Proof.
    induction d;
    try solve [intros HH; assert False; [inversion HH|intuition]];
    eauto; simpl; try discriminate.
  Qed.

  Lemma data_type_String_inv {d}:
    d ▹ String ->
    {s | d = dstring s}.
  Proof.
    induction d;
    try solve [intros HH; assert False; [inversion HH|intuition]];
    eauto; simpl; try discriminate.
  Qed.

  Lemma data_type_Col_inv {d τ}:
    d ▹ Coll τ ->
    {dl | d = dcoll dl}.
  Proof.
    revert τ.
    induction d; intros τ;
    try solve [intros HH; assert False; [inversion HH|intuition]];
    eauto; simpl; try discriminate.
  Qed.

  Lemma Col_inv {d τ}:
    dcoll d ▹ Coll τ ->
    Forall (fun c => c ▹ τ) d.
  Proof.
    inversion 1; rtype_equalizer.
    subst.
    trivial.
  Qed.

  Lemma data_type_Rec_inv {d k τ pf} :
    d ▹ Rec k τ pf ->
    {dl | d = drec dl}.
  Proof.
    revert τ pf.
    induction d; intros τ pf;
    try solve [intros HH; assert False; [inversion HH|intuition]];
    eauto; simpl; try discriminate.
  Qed.

    Lemma data_type_Arrow_inv {d τin τout}:
    d ▹ Arrow τin τout ->
    False.
    Proof.
      inversion 1.
    Qed.

    Lemma data_type_Foreign_inv {d ft}:
    d ▹ Foreign ft ->
    {fd | d = dforeign fd}.
    Proof.
      revert ft.
      induction d; intros ft;
        try solve [intros HH; assert False; [inversion HH|intuition]];
        eauto; simpl; try discriminate.
    Qed.

  Lemma data_type_Either_inv {d τl τr}:
    d ▹ Either τl τr ->
    {dl | d = dleft dl /\ dl ▹ τl} + {dr | d = dright dr /\ dr ▹ τr}.
  Proof.
    revert τl τr.
    induction d; intros τ pf;
    try solve [intros HH; assert False; [inversion HH|intuition]].
    - left. econstructor. inversion H; rtype_equalizer. subst; intuition.
    - right. econstructor. inversion H; rtype_equalizer. subst; intuition.
  Qed.

    Lemma data_type_Option_inv {d τ}:
    d ▹ Option τ ->
    {ds | d = dsome ds /\ ds ▹ τ} + {d = dnone}.
    Proof.
      intros inn. apply data_type_Either_inv in inn.
      unfold dsome, dnone.
      destruct inn as [[?[??]]|[?[??]]]; subst; eauto.
      eapply data_type_Unit_inv in H0.
      subst; eauto.
    Qed.

    Lemma data_type_Brand_inv {d br} :
    d ▹ Brand br ->
    {bs:brands & {d' | d = dbrand bs d'}}.
  Proof.
    revert br.
    induction d; intros br;
    try solve [intros H; assert False; [inversion H|intuition]];
    eauto; simpl; try discriminate.
    - intros. assert False; [inversion H0|intuition].
    - intros. assert False; [inversion H0|intuition].
  Qed.

End inv.

(** Inversion tactic for typed data *)
    Ltac data_type_inverter :=
  match goal with
    | [H: dunit ▹ ?τ,  H1: isTop ?τ = false |- _ ] =>
      match τ with
        | Unit => fail 1
        | _ => generalize (data_type_dunit_inv H1 H); intros ?; try subst
      end
    | [H: dnat _ ▹ ?τ,  H1: isTop ?τ = false  |- _ ] =>
      match τ with
        | Nat => fail 1
        | _ => generalize (data_type_dnat_inv H1 H); intros ?; try subst
      end
    | [H: dfloat _ ▹ ?τ,  H1: isTop ?τ = false  |- _ ] =>
      match τ with
        | Float => fail 1
        | _ => generalize (data_type_dfloat_inv H1 H); intros ?; try subst
      end
    | [H: dbool _ ▹ ?τ,  H1: isTop ?τ = false  |- _ ] =>
      match τ with
        | Bool => fail 1
        | _ => generalize (data_type_dbool_inv H1 H); intros ?; try subst
      end
    | [H: dstring _ ▹ ?τ,  H1: isTop ?τ = false  |- _ ] =>
      match τ with
        | String => fail 1
        | _ => generalize (data_type_dstring_inv H1 H); intros ?; try subst
      end
    | [H: dcoll _ ▹ ?τ,  H1: isTop ?τ = false  |- _ ] =>
      match τ with
        | Coll _ => fail 1
        | _ => destruct (data_type_dcoll_inv H1 H); try subst
      end
    | [H: drec _ ▹ ?τ,  H1: isTop ?τ = false  |- _ ] =>
      match τ with
        | Rec _ _ => fail 1
        | _ => destruct (data_type_drec_inv H1 H) as [?[?[??]]]; try subst
      end
  end.

Lemma data_type_Rec_sublist {r k l l' pf} pf' :
      drec r ▹ Rec k l pf ->
      sublist l' l ->
      drec r ▹ Rec Open l' pf'.
Proof.
  inversion 1; subst; intros.
  inversion H2; clear H2; simpl in *; rtype_equalizer; subst.
  econstructor.
  - eassumption.
  - rewrite H0; eassumption.
  - intros; discriminate.
  - trivial.
Qed.

Lemma sorted_forall_same_domain {dl τ}:
    Forall2 (fun (d : string * data) (r : string * rtype) =>
          fst d = fst r /\ data_type (snd d) (snd r)) dl τ ->
    (domain dl) = (domain τ).
Proof.
  intros.
  assert (Forall2 (fun (d : string * data) (r : string * rtype) =>
                     fst d = fst r) dl τ)
    by (eapply Forall2_incl; try apply H; intuition).
  apply Forall2_map in H0.
  apply Forall2_eq in H0.
  assumption.
Qed.

Lemma data_type_Rec_domain {r k l pf} :
      drec r ▹ Rec k l pf ->
      sublist (domain l) (domain r).
Proof.
  revert l pf. induction r; inversion 1; rtype_equalizer; subst;
               inversion H5; subst; clear H5.
  - apply sublist_nil_r in H3; subst; simpl; qauto.
  - simpl. intuition.
    rewrite H0.
    apply sublist_domain in H3.
    rewrite H3.
    simpl.
    apply sublist_cons.
    apply (IHr _ (is_list_sorted_cons_inv _ pf')).
    apply dtrec_full; trivial.
Qed.

Lemma data_type_Rec_closed_domain {r l pf} :
      drec r ▹ Rec Closed l pf ->
      domain r = domain l.
Proof.
  intros.
  symmetry.
  apply sublist_length_eq.
  - apply (data_type_Rec_domain H).
  - apply dtrec_closed_inv in H.
    repeat rewrite domain_length.
    symmetry.
    eapply Forall2_length; eauto.
Qed.

Lemma data_type_Recs_domain {r k l pf l' pf'} :
  drec r ▹ Rec k l pf ->
  drec r ▹ Rec Closed l' pf' ->
  sublist (domain l) (domain l').
Proof.
  intros t1 t2.
  rewrite (data_type_Rec_domain t1).
  rewrite (data_type_Rec_closed_domain t2).
  reflexivity.
Qed.

Lemma data_type_Recs_closed_domain {r l l' pf pf'} :
  drec r ▹ Rec Closed l pf ->
  drec r ▹ Rec Closed l' pf' ->
  domain l = domain l'.
Proof.
  intros t1 t2.
  rewrite <- (data_type_Rec_closed_domain t1).
  rewrite <- (data_type_Rec_closed_domain t2).
  trivial.
Qed.

Lemma dtrec_edot_parts a k τ pf s x y:
  drec a ▹ Rec k τ pf ->
  edot a s = Some x ->
  edot τ s = Some y ->
  x ▹ y.
Proof.
  unfold edot.
  intros dt ina inτ.
  invcs dt; rtype_equalizer.
  subst.
  apply is_list_sorted_NoDup_strlt in pf'.
  apply (assoc_lookupr_nodup_sublist pf' H2 (R_dec:=ODT_eqdec)) in inτ.
  clear H3 H2.
  induction H4; simpl in *; try discriminate.
  destruct x0; destruct y0; destruct H; simpl in *; subst.
  invcs pf'.
  destruct (string_eqdec s s1); unfold Equivalence.equiv in *; subst.
  - apply sorted_forall_same_domain in H4.
    assert (nd2:~ In s1 (domain l)) by (rewrite H4; trivial).
    apply (assoc_lookupr_nin_none) with (dec:=string_eqdec) in H2.
    rewrite H2 in inτ.
    invcs inτ.
    apply (assoc_lookupr_nin_none) with (dec:=string_eqdec) in nd2.
    unfold Equivalence.equiv, RelationClasses.complement, not in *.
    simpl in *.
    rewrite nd2 in ina.
    invcs ina.
    trivial.
  - match_case_in inτ
    ; [intros ? eqq1 | intros eqq1]; rewrite eqq1 in inτ
    ; try discriminate.
    invcs inτ.
    match_case_in ina
    ; [intros ? eqq2 | intros eqq2]; rewrite eqq2 in ina
    ; try discriminate.
    invcs ina.
    intuition.
Qed.

Lemma coll_type_cons a c x:
  dcoll (a :: c) ▹ Coll x ->
  a ▹ x /\ dcoll c ▹ Coll x.
Proof.
  intros.
  inversion H.
  assert (r = x) by (apply rtype_fequal; assumption).
  rewrite Forall_forall in H2; simpl in H2.
  rewrite H3 in *; clear H3 H1.
  split.
  apply (H2 a); left; reflexivity.
  apply dtcoll; rewrite Forall_forall; intros.
  apply (H2 x0); right; assumption.
Qed.

Lemma dcoll_coll_in_inv {d τ a} :
  In a d -> dcoll d ▹ Coll τ -> a ▹ τ.
Proof.
  induction d; [simpl; intuition| ]; intros.
  apply coll_type_cons in H0.
  simpl in *; intuition; subst; intuition.
Qed.

Lemma rec_type_closed_cons {x y l l' pf} pf':
  drec (x :: l) ▹ Rec Closed (y :: l') pf ->
  (snd x) ▹ (snd y) /\ drec l ▹ Rec Closed l' pf'.
Proof.
  intros H.
  apply dtrec_closed_inv in H.
  inversion H; subst; intuition.
  apply dtrec_full; auto.
Qed.

Lemma rec_type_cons {k x y l l' pf} pf':
  drec (x :: l) ▹ Rec k (y :: l') pf ->
  ((fst x) = (fst y) /\ (snd x) ▹ (snd y) /\ drec l ▹ Rec k l' pf')
  \/ ((fst x) <> (fst y) /\ drec l ▹ Rec k (y::l') pf).
Proof.
  intros H.
  inversion H; clear H; subst.
  inversion H5; clear H5; subst.
  destruct rl_sub; simpl in *; try discriminate.
  inversion H2; clear H2.
  rtype_equalizer; subst.
  intuition.
  destruct p; destruct x; destruct y; destruct y0; simpl in *; subst.
  inversion H3; subst.
  - left; intuition.
    econstructor; try apply H7; trivial.
    eapply is_list_sorted_cons_inv; eassumption.
    intros kc; specialize (H4 kc); inversion H4.
    trivial.
  - assert (neq:s2 = s1 -> False).
    + intro; subst.
       generalize pf'0.
       generalize (sublist_In H1 (s1, r0)); clear; simpl; intuition.
       apply (@is_list_sorted_cons string) in pf'0.
       apply (@is_list_sorted_cons string) in pf'0.
       apply is_list_sorted_NoDup in pf'0
       ; [ | eapply StringOrder.lt_strorder].
       inversion pf'0; subst.
       apply in_dom in H.
       tauto.
    + right; split; trivial.
       econstructor; try apply H1; auto.
       apply (is_list_sorted_cons_inv _ pf'0).
       intros kc; specialize (H4 kc).
       inversion H4; subst.
       elim neq; trivial.
Qed.

  Lemma sorted_forall_sorted (dl:list (string*data)) (τ:list (string*rtype)):
    is_list_sorted ODT_lt_dec (domain τ) = true ->
    Forall2 (fun (d : string * data) (r : string * rtype) =>
          fst d = fst r /\ data_type (snd d) (snd r)) dl τ ->
    is_list_sorted ODT_lt_dec (domain dl) = true.
  Proof.
    intros.
    assert (domain dl = domain τ).
    apply sorted_forall_same_domain; assumption.
    rewrite H1; assumption.
  Qed.

  Lemma insert_and_foralls_mean_same_sort l1 l2 τ₁ τ₂ x y:
    is_list_sorted ODT_lt_dec (domain (rec_sort (τ₁ ++ τ₂))) = true ->
    Forall2
      (fun (d : string * data) (r : string * rtype) =>
         fst d = fst r /\ data_type (snd d) (snd r))
      (rec_sort (l1 ++ l2)) (rec_sort (τ₁ ++ τ₂)) ->
    (fst x = fst y) ->
    is_list_sorted
      ODT_lt_dec
      (domain
         (insertion_sort_insert rec_field_lt_dec y (rec_sort (τ₁ ++ τ₂)))) = true ->
    is_list_sorted
      ODT_lt_dec
      (domain
         (insertion_sort_insert rec_field_lt_dec x (rec_sort (l1 ++ l2)))) = true.
  Proof.
    intros.
    assert (domain (rec_sort (l1 ++ l2)) = domain (rec_sort (τ₁ ++ τ₂))).
    apply sorted_forall_same_domain; assumption.
    assert (domain (insertion_sort_insert rec_field_lt_dec x (rec_sort (l1 ++ l2))) =
            domain (insertion_sort_insert rec_field_lt_dec y (rec_sort (τ₁ ++ τ₂)))).
    generalize (same_domain_insert (rec_sort (l1++l2)) (rec_sort (τ₁++τ₂)) x y); intros.
    simpl.
    unfold rec_cons_sort in *. rewrite H4; try assumption; try reflexivity.
    rewrite H4; assumption.
  Qed.

  Lemma sorted_cons_skip {A} (l:list (string*A)) (x x0:string*A) :
    is_list_sorted
      ODT_lt_dec
      (domain (rec_cons_sort x (x0 :: l))) = true
    -> is_list_sorted
         ODT_lt_dec
         (domain (rec_cons_sort x l)) = true.
  Proof.
    intros; simpl in *.
    revert H; elim (rec_field_lt_dec x x0); intros.
    assert (is_list_sorted ODT_lt_dec (domain (x :: l)) = true).
    apply (@rec_sorted_skip_second string ODT_string _ l x x0); assumption.
    assert ((rec_cons_sort x l) = x::l).
    apply rec_cons_sorted_id; assumption.
    rewrite H1; assumption.
    revert H; elim (rec_field_lt_dec x0 x); intros.
    apply (@rec_sorted_skip_first string ODT_string _ (rec_cons_sort x l) x0); assumption.
    assert (fst x = fst x0).
    apply lt_contr1; assumption.
    simpl in H.
    rewrite <- H0 in H.
    assert ((rec_cons_sort x l) = x::l).
    apply rec_cons_sorted_id; assumption.
    rewrite H1; assumption.
  Qed.

  Lemma Forall2_cons_sorted l1 l2 x y :
    Forall2
      (fun (d : string * data) (r : string * rtype) =>
         fst d = fst r /\ data_type (snd d) (snd r))
      l1 l2 ->
    is_list_sorted ODT_lt_dec
                   (domain
                      (insertion_sort_insert rec_field_lt_dec x l1)) =
    true ->
    is_list_sorted ODT_lt_dec
                   (domain
                      (insertion_sort_insert rec_field_lt_dec y l2)) =
    true -> fst x = fst y -> data_type (snd x) (snd y) ->
    Forall2
      (fun (d : string * data) (r : string * rtype) =>
         fst d = fst r /\ data_type (snd d) (snd r))
      (insertion_sort_insert rec_field_lt_dec x l1)
      (insertion_sort_insert rec_field_lt_dec y l2).
  Proof.
    intros.
    induction H.
    - apply Forall2_cons.
      split; assumption; apply Forall2_nil.
      apply Forall2_nil.
    - assert (is_list_sorted
                ODT_lt_dec
                (domain (insertion_sort_insert rec_field_lt_dec x l)) = true)
       by (apply (sorted_cons_skip l x x0); assumption).
      assert (is_list_sorted
                ODT_lt_dec
                (domain (insertion_sort_insert rec_field_lt_dec y l')) = true)
        by (apply (sorted_cons_skip l' y y0); assumption).
      specialize (IHForall2 H5 H6).
      simpl in *.
      revert H0 H1.
      elim (rec_field_lt_dec x x0); elim (rec_field_lt_dec y y0); intros.
      + apply Forall2_cons. split; assumption.
        apply Forall2_cons; assumption.
      + revert H1.
        elim (rec_field_lt_dec y0 y); intros.
        apply Forall2_cons.
        elim H; intros; clear H.
        congruence.
        elim H; intros; clear H.
        congruence.
        assert ((fst y) = (fst y0)).
        apply lt_contr1; assumption.
        assert ((fst x) = (fst x0)).
        elim H; intros; clear H.
        rewrite <- H7 in H8.
        rewrite <- H2 in H8.
        rewrite H8; reflexivity.
        congruence.
      + revert H0.
        elim (rec_field_lt_dec x0 x); intros.
        apply Forall2_cons.
        elim H; intros; clear H.
        congruence.
        elim H; intros; clear H.
        congruence.
        assert ((fst x) = (fst x0)).
        apply lt_contr1; assumption.
        assert ((fst y) = (fst y0)).
        elim H; intros; clear H.
        rewrite <- H8.
        rewrite <- H2.
        assumption.
        congruence.
      + revert H0 H1.
        elim (rec_field_lt_dec x0 x); elim (rec_field_lt_dec y0 y); intros.
        apply Forall2_cons; assumption.
        assert ((fst y) = (fst y0)).
        apply lt_contr1; assumption.
        assert ((fst x) = (fst x0)).
        elim H; intros; clear H.
        rewrite <- H7 in H8.
        rewrite <- H2 in H8.
        rewrite H8; reflexivity.
        congruence.
        assert ((fst x) = (fst x0)).
        apply lt_contr1; assumption.
        assert ((fst y) = (fst y0)).
        elim H; intros; clear H.
        rewrite <- H8.
        rewrite <- H2.
        assumption.
        congruence.
        apply Forall2_cons; assumption.
  Qed.

  Lemma dtrec_rec_concat_sort {x xt pfx y yt pfy} pxyt :
    drec x ▹ Rec Closed xt pfx ->
    drec y ▹ Rec Closed yt pfy ->
    drec (rec_concat_sort x y) ▹ Rec Closed (rec_concat_sort xt yt) pxyt.
  Proof.
    intros typ1 typ2.
    apply dtrec_closed_inv in typ1.
    apply dtrec_closed_inv in typ2.
    apply dtrec_full.
    unfold rec_concat_sort.
    apply rec_sort_Forall2.
    - repeat rewrite domain_app.
      rewrite (sorted_forall_same_domain typ1).
      rewrite (sorted_forall_same_domain typ2).
      trivial.
    - apply Forall2_app; trivial.
  Qed.

  Lemma dttop' d : data_normalized brand_relation_brands d -> d ▹ ⊤.
  Proof.
    apply dttop.
  Qed.

  Hint Resolve dttop dttop' : qcert.

  Lemma Forall_map {A B} P (f:A->B) l :
    Forall P (map f l) <-> Forall (fun x => P (f x)) l.
  Proof.
    induction l; simpl; intuition.
    - inversion H1; subst; auto.
    - inversion H1; subst; auto.
  Qed.

  (** Well typed data must be normalized *)
  Lemma data_type_normalized d τ :
    d ▹ τ -> data_normalized brand_relation_brands d.
  Proof.
    Hint Constructors data_normalized : qcert.
    revert τ.
    induction d using dataInd2; intros; try assumption; simpl in *;
    auto 2 with qcert.
    - constructor. inversion H0; subst.
      + inversion H1; trivial.
      + revert H2; apply Forall_impl_in.
        eauto.
    - inversion H0; subst; trivial.
      constructor; trivial.
      + apply Forall_forall. intros.
        destruct x; simpl.
        specialize (H _ _ H1).
        revert H H1 H4. clear.
        revert rl.
        induction r; inversion 3; subst; simpl in *;
        intuition; subst; simpl in *; subst; eauto.
      + apply sorted_forall_same_domain in H4.
        rewrite H4.
        trivial.
    - inversion H; subst; trivial; qeauto.
    - inversion H; subst; trivial; qeauto.
    - inversion H; subst; trivial; constructor; qeauto.
    - invcs H.
      + eauto.
      + constructor.
        eapply foreign_data_typing_normalized; qeauto.
  Qed.

  (** Lemma showing that normalization preserves typing *)
  Lemma normalize_preserves_type d τ :
    d ▹ τ -> normalize_data brand_relation_brands d ▹ τ.
  Proof.
    intros.
    rewrite normalize_normalized_eq; trivial.
    eapply data_type_normalized; eauto.
  Qed.

  Lemma dttop_weaken {d τ} : data_type d τ -> data_type d ⊤.
  Proof.
    intros H; apply data_type_normalized in H.
    auto 2 with qcert.
  Qed.

End TData.

(* expands well-typed data with a specific type *)
Notation "d ▹ r" := (data_type d r) (at level 70). (* \vdash, \triangleright *)

Ltac dtype_inverter
  := repeat progress
            match goal with
            | [H:?d ▹ Unit |- _ ] =>
              apply data_type_Unit_inv in H; try subst d
            | [H:?d ▹ Nat |- _ ] =>
              apply data_type_Nat_inv in H; destruct H; try subst d
            | [H:?d ▹ Float |- _ ] =>
              apply data_type_Float_inv in H; destruct H; try subst d
            | [H:?d ▹ Bool |- _ ] =>
              apply data_type_Bool_inv in H;  destruct H; try subst d
            | [H:?d ▹ String |- _ ] =>
              apply data_type_String_inv in H;  destruct H; try subst d
            | [H:?d ▹ (Coll ?τ) |- _ ] =>
              match d with
              | dcoll ?d => fail 1
              | _ =>
                let XX := fresh in
                destruct (data_type_Col_inv H) as [XX ?];
                  (discriminate || (subst d; rename XX into d))
              end
            | [H:?d ▹ Arrow _ _ |- _ ] =>
              apply data_type_Arrow_inv in H; tauto
            | [H:?d ▹ (Foreign ?τ) |- _ ] =>
              match d with
              | dforeign _ => fail 1
              | _ =>
                let XX := fresh in
                destruct (data_type_Foreign_inv H) as [XX ?];
                  (discriminate || (subst d; rename XX into d))
              end
            | [H:?d ▹ (Brand _) |- _ ] =>
              match d with
              | dbrand _ _ => fail 1
              | _ =>
                let XX := fresh in
                destruct (data_type_Brand_inv H) as [? [XX ?]];
                  (discriminate || (subst d; rename XX into d))
              end
            | [H:?d ▹ (Rec ?k ?τ ?pf) |- _ ] =>
              match d with
              | drec _ => fail 1
              | _ =>
                let XX := fresh in
                destruct (data_type_Rec_inv H) as [XX ?];
                  (discriminate || (subst d; rename XX into d))
              end
            |   [H:?d ▹ Bool |- _ ] =>
                let XX := fresh in
                destruct (data_type_Bool_inv H) as [XX ?]; try subst d; clear H;
                rename XX into d
            | [H:proj1_sig _ =
                 Rec₀ Closed
                   (map
                      (fun x : string * {τ₀ : rtype₀ | wf_rtype₀ τ₀ = true} =>
                         (fst x, proj1_sig (snd x))) _) |- _ ]
              => apply Rec₀_eq_proj1_Rec in H; destruct H as [??]
            end; simpl.

  Ltac dtype_inverter_with_either
    := repeat progress
              try dtype_inverter;
      try match goal with
            | [H:?d ▹ (Either _ _) |- _ ] =>
              match d with
                | dleft ?d => fail 1
                | dright ?d => fail 1
                | _ =>
                let XX := fresh in
                destruct (data_type_Either_inv H) as [[XX [??]]|[XX [??]]];
                  (discriminate || (subst d; rename XX into d))
              end
          end.

(* adds type information about the data when it can be inferred *)
Ltac dtype_enrich :=
  match goal with
    | [H: In ?a ?l, H2: (dcoll ?l) ▹ (Coll ?τ) |- _ ] =>
      extend (dcoll_coll_in_inv H H2)
  end.

Global Hint Immediate dttop dttop' : qcert.
Global Hint Resolve dttop_weaken : qcert.

Section subtype.

  Lemma subtype_Rec_sublist_strengthen
        {fdata:foreign_data}
        {ftype:foreign_type}
        {fdtyping:foreign_data_typing}
        {m:brand_model} {dl rl srl k1 pf srl0 pf0 k2} :
  forall (f2:Forall2
         (fun (d : string * data) (r : string * rtype) =>
            fst d = fst r /\ data_type (snd d) (snd r)) dl rl)
         (subl:sublist srl rl)
         (subt:Rec k1 srl pf <: Rec k2 srl0 pf0)
         (pf3:is_list_sorted ODT_lt_dec (domain rl) = true)
         (ft:Forallt
        (fun ab : string * rtype =>
         forall (d : data) (τ₂ : rtype),
         snd ab <: τ₂ -> data_type d (snd ab) -> data_type d τ₂) srl),
  exists l2,
    Forall2
         (fun (d : string * data) (r : string * rtype) =>
            fst d = fst r /\ data_type (snd d) (snd r)) dl l2
    /\
    sublist srl0 l2.
Proof.
  revert dl srl k1 pf srl0 pf0 k2.
  induction rl; intros dl srl k1 pf srl0 pf0 k2 f2 subl subt pf3; inversion f2; clear f2; subst; intros.
  -  apply sublist_nil_r in subl; subst. exists nil.
     apply subtype_Rec_sublist in subt.
     apply sublist_nil_r in subt.
     unfold domain in subt; apply map_eq_nil in subt. subst.
     intuition.
  - destruct x; destruct a. unfold fst, snd in H2; destruct H2; subst.
    destruct (sublist_cons_inv subl pf3).
    + destruct H as [?[??]]. subst.
      inversion ft; subst; clear ft.
       case_eq (lookup string_dec srl0 s0); intros.
      * (* clear subl. revert x H1 pf subt. *)
         destruct srl0; intros; simpl in H; try discriminate.
         destruct p. destruct (string_dec s0 s).
          inversion H; clear H; subst.
          destruct (Rec_subtype_cons_inv subt) as [? [??]].
          specialize (IHrl _ _ k1 _ _ _ _ H3 H1 H (
                             is_list_sorted_cons_inv ODT_lt_dec pf3) H5).
          destruct (IHrl) as [? [??]].
          exists ((s,r0)::x2); intuition;[ | apply sublist_cons; auto].
          constructor; intuition.
          simpl.
          inversion subt; rtype_equalizer; subst; trivial.
          destruct rl2; inversion H11; rtype_equalizer; clear H11.
          destruct rl1; inversion H8; rtype_equalizer; clear H8.
          destruct p; destruct p0; unfold fst in H11; subst.
          simpl.
          simpl in H0.
          specialize (H10 s0 r1). simpl in H10.
          destruct (string_dec s0 s0); [| congruence].
          destruct H10 as [? [??]]; trivial.
          invcs H7.
          eauto.

          generalize (subtype_Rec_sublist subt); intros subl'.
          repeat rewrite domain_cons in subl'; unfold fst in subl'.
          inversion subl'; subst; [congruence | ].
          apply lookup_in in H.
          apply in_dom in H.
          generalize (sublist_In H7 s0); simpl; intuition.
          generalize (is_list_sorted_NoDup _ _ pf).
          inversion 1; congruence.
      * apply Rec_subtype_cons_inv1 in subt; trivial.
          destruct subt as [pf' subt].
          specialize (IHrl _ _ k1 pf' _ pf0 _ H3 H1 subt (
                             is_list_sorted_cons_inv ODT_lt_dec pf3) H5).
          destruct IHrl as [? [? ?]].
          exists ((s0,r)::x0).
          intuition.
          apply sublist_skip; auto 1.
    + simpl in H; destruct H.
      specialize (IHrl _ _ k1 pf _ pf0 _ H3 H1 subt (
                             is_list_sorted_cons_inv ODT_lt_dec pf3) ft).
          destruct IHrl as [? [? ?]].
          exists ((s0,r)::x).
          intuition.
          apply sublist_skip; auto 1.
Qed.

Global Instance data_type_subtype_prop
       {fdata:foreign_data}
       {ftype:foreign_type}
       {fdtyping:foreign_data_typing}
       {m:brand_model} : Proper (eq ==> subtype ==> impl) (data_type).
  Proof.
    unfold Proper, respectful, impl, flip.
    intros ? d ? τ₁ τ₂ sub ; subst.
    Hint Resolve data_type_ext : qcert.
    Hint Resolve data_type_not_bottom : qcert.
    Hint Resolve dtrec_closed_is_open : qcert.
    Hint Constructors data_normalized : qcert.

    revert d τ₂ sub.
      induction τ₁ using rtype_rect;
        induction τ₂ using rtype_rect; simpl;
        try autorewrite with rtype_join;
        try solve[inversion 1; subst; intros;
                  try solve [intros; dtype_inverter; eauto 2 with qcert
                            | eelim data_type_not_bottom; qeauto
                            | unfold Top, Bottom, Unit, Nat, Float, Bool, String, Coll, Rec in *;
                              eauto 2 with qcert; try r_ext]].
    - clear IHτ₂. intros.
      inversion H; rtype_equalizer.
      subst.
      inversion sub; rtype_equalizer.
      + subst; trivial.
      + subst. constructor.
        revert H2; apply Forall_impl; auto.
    - clear H0.
      intros.
      inversion H0; rtype_equalizer; subst.
      destruct (subtype_Rec_sublist_strengthen H6 H3 sub) as [?[??]]; trivial.
      eapply dtrec; try exact H1; trivial.
      rewrite <- (sorted_forall_same_domain H1).
      rewrite (sorted_forall_same_domain H6).
      trivial.
      intros; subst.
      generalize (subtype_Rec_closed2_closed1 sub); intros; subst.
      intuition; subst.
      generalize (subtype_Rec_closed_domain sub); intros eqd.
      rewrite <- (sorted_forall_same_domain H6) in eqd.
      rewrite (sorted_forall_same_domain H1) in eqd.
      apply sublist_length_eq; trivial.
      rewrite <- (domain_length srl0), <- (domain_length x).
      congruence.
    - intros e sub. apply subtype_Either_inv in e.
      destruct e as [e1 e2].
      inversion sub; subst; rtype_equalizer.
      + subst. econstructor; intuition.
      + subst. econstructor; intuition.
    - inversion 1; trivial; subst.
      + apply canon_equiv in H1.
        rewrite H1; trivial.
      + apply canon_equiv in H; apply canon_equiv in H0.
        rewrite H, H0 in H1.
        inversion 1; subst.
        apply canon_equiv in H3. rewrite H3 in H8.
        econstructor; trivial.
        etransitivity; eauto.
    - intros sub dt.
      invcs sub; trivial.
      invcs dt.
      constructor.
      eapply foreign_data_typing_subtype; eauto.
  Qed.

  Global Instance data_type_subtype_prop'
         {fdata:foreign_data}
         {ftype:foreign_type}
         {fdtyping:foreign_data_typing}
         {m:brand_model} d : Proper (subtype ==> impl) (data_type d).
  Proof.
    apply data_type_subtype_prop; trivial.
  Qed.

  Lemma join_preserves_data_type
        {fdata:foreign_data}
        {ftype:foreign_type}
        {fdtyping:foreign_data_typing}
        {m:brand_model} {d τ}:
    d ▹ τ -> forall τ₀, d ▹ (τ ⊔ τ₀).
  Proof.
    intros.
    rewrite (join_leq_l τ τ₀) in H; trivial.
  Qed.

  (* Just so we can refer to it in the paper *)
  Theorem subtyping_preserves_data_type
          {fdata:foreign_data}
          {ftype:foreign_type}
          {fdtyping:foreign_data_typing}
          {m:brand_model} {d τ₁ τ₂}:
    d ▹ τ₁ -> τ₁ ≤ τ₂ -> d ▹ τ₂.
  Proof.
    intros.
    rewrite <- H0.
    trivial.
  Qed.

  Lemma map_rtype_meet_cons2_nin
        {ftype:foreign_type}
        {br:brand_relation} s x l1 l2 :
    ~ In s (domain l1) ->
    map_rtype_meet l1 ((s, x) :: l2)
    = map_rtype_meet l1 l2.
  Proof.
    induction l1; simpl; trivial.
    destruct a; simpl.
    intuition.
    rewrite H.
    destruct (string_dec s0 s); intuition.
  Qed.

  Lemma lookup_diff_cons2_nin {A B C} dec s x (l1:list (A*B)) (l2:list (A*C)) :
    ~ In s (domain l1) ->
  lookup_diff dec l1 ((s, x) :: l2)
  = lookup_diff dec l1 l2.
  Proof.
    induction l1; simpl; trivial.
    intuition.
    rewrite H. destruct (dec (fst a) s); intuition.
  Qed.

  Lemma lookup_diff_sublist {A B C} (dec:forall a a':A, {a=a'} + {a<>a'})
        (l1:list (A*B)) (l2:list (A*C)):
    sublist (lookup_diff dec l1 l2) l1.
  Proof.
    induction l1; simpl; trivial.
    - intuition.
    - match_destr.
      + apply sublist_skip; trivial.
      + apply sublist_cons; trivial.
  Qed.

  Theorem meet_preserves_data_type
          {fdata:foreign_data}
          {ftype:foreign_type}
          {fdtyping:foreign_data_typing}
          {m:brand_model} {d τ₁ τ₂}:
    d ▹ τ₁ -> d ▹ τ₂ -> d ▹ (τ₁ ⊓ τ₂).
  Proof.
    Hint Resolve data_type_ext : qcert.
    Hint Resolve data_type_not_bottom : qcert.
    Hint Resolve dtrec_closed_is_open : qcert.
    Hint Constructors data_normalized : qcert.

    revert d τ₂.
      induction τ₁ using rtype_rect;
        induction τ₂ using rtype_rect; simpl;
        try autorewrite with rtype_meet;
        try solve[inversion 1; subst; intros;
                  try solve [intros; dtype_inverter_with_either; try discriminate; eauto 2 with qcert
                            | eelim data_type_not_bottom; qeauto
                            | unfold Top, Bottom, Unit, Nat, Float, Bool, String, Coll, Rec in *;
                              eauto 2 with qcert; try r_ext]].
    - intros; dtype_inverter.
      inversion H; clear H; subst.
      inversion H0; clear H0; subst.
      rtype_equalizer. subst.
      constructor.
      rewrite Forall_forall in *.
      intros ? inn.
      apply IHτ₁; intuition.
    - intros; dtype_inverter.
      invcs H1; rtype_equalizer.
      invcs H2; rtype_equalizer.
      subst.
      match_destr.
      + { clear H0.
          assert (F2:Forall2 (fun (d : string * data) (r : string * rtype) =>
                             fst d = fst r /\ snd d ▹ snd r) d
                          (rec_concat_sort
                             (map_rtype_meet srl srl0)
                             (lookup_diff string_dec rl0 srl))).
          {
            clear H7 H10 r k k0.
            revert rl rl0 srl srl0 pf pf' pf0 pf'0 H H6 H9 H8 H11.
            induction d; simpl; intros;
              invcs H8; invcs H11; simpl.
            - apply sublist_nil_r in H6; subst.
              simpl. constructor.
            - destruct H3; destruct H2; destruct a; destruct y; destruct y0.
              simpl in H, H0, H1, H2 |- *. repeat subst.
              apply sublist_cons_inv_simple in H6;
                [| apply NoDup_domain_NoDup;
                 eapply is_list_sorted_NoDup; [ eapply StringOrder.lt_strorder | ];
                 eauto].
              apply sublist_cons_inv_simple in H9;
                [| apply NoDup_domain_NoDup;
                 eapply is_list_sorted_NoDup; [ eapply StringOrder.lt_strorder | ];
                 eauto].
              destruct H6 as [[srl' [eqq subl']]|[nin subl']].
              + subst. simpl.
                invcs H.
                destruct (string_dec s1 s1); [ | congruence].
                destruct H9 as [[srl0' [eqq0 subl0']]|[nin0 subl'0]].
                * subst. simpl.
                  destruct (string_dec s1 s1); [ | congruence].
                  unfold rec_concat_sort.
                  simpl.
                  { rewrite insertion_sort_insert_forall_lt.
                    - constructor; simpl.
                      + split; eauto.
                      + rewrite map_rtype_meet_cons2_nin;
                        [rewrite lookup_diff_cons2_nin | ].
                        *  apply (IHd l' l'0); trivial;
                           try solve[eapply is_list_sorted_cons_inv; eauto].
                        * apply is_list_sorted_NoDup in pf'0;
                          [ | eapply StringOrder.lt_strorder ].
                          inversion pf'0; subst; trivial.
                        * apply is_list_sorted_NoDup in pf;
                          [ | eapply StringOrder.lt_strorder ].
                          inversion pf; subst; trivial.
                    - apply Forall_sorted.
                      apply Forall_rec_field_lt.
                      simpl.
                      rewrite domain_app.
                      rewrite map_rtype_meet_domain.
                      apply Forall_app.
                      + apply sorted_StronglySorted in pf;
                        [ | eapply StrictOrder_Transitive ].
                        simpl in pf. inversion pf; subst.
                        trivial.
                      + eapply Forall_sublist.
                        * eapply sublist_domain.
                          eapply lookup_diff_sublist.
                      * apply sorted_StronglySorted in pf'0;
                        [ | eapply StrictOrder_Transitive ].
                        simpl in pf'0. inversion pf'0; subst.
                        trivial.
                  }
                * assert (nind: ~ In s1 (domain srl0)).
                  { apply is_list_sorted_NoDup in pf'0;
                    [ | eapply StringOrder.lt_strorder ].
                    inversion pf'0; subst; trivial.
                    intros inn; apply H2. eapply sublist_In; try eapply inn.
                    eapply sublist_domain; trivial.
                  }
                  apply (lookup_nin_none string_dec) in nind.
                  rewrite nind.
                  unfold rec_concat_sort. simpl.
                  {rewrite insertion_sort_insert_forall_lt.
                    - constructor; simpl.
                      + split; eauto.
                      + rewrite lookup_diff_cons2_nin.
                        *  apply (IHd l' l'0); trivial;
                           try solve[eapply is_list_sorted_cons_inv; eauto].
                        * apply is_list_sorted_NoDup in pf'0;
                          [ | eapply StringOrder.lt_strorder ].
                          inversion pf'0; subst; trivial.
                    - apply Forall_sorted.
                      apply Forall_rec_field_lt.
                      simpl.
                      rewrite domain_app.
                      rewrite map_rtype_meet_domain.
                      apply Forall_app.
                      + apply sorted_StronglySorted in pf;
                        [ | eapply StrictOrder_Transitive ].
                        simpl in pf. inversion pf; subst.
                        trivial.
                      + eapply Forall_sublist.
                        * eapply sublist_domain.
                          eapply lookup_diff_sublist.
                      * apply sorted_StronglySorted in pf'0;
                        [ | eapply StrictOrder_Transitive ].
                        simpl in pf'0. inversion pf'0; subst.
                        trivial.
                  }
              + assert (nind: ~ In s1 (domain srl)).
                  { apply is_list_sorted_NoDup in pf';
                    [ | eapply StringOrder.lt_strorder ].
                    inversion pf'; subst; trivial.
                    intros inn; apply H5. eapply sublist_In; try eapply inn.
                    eapply sublist_domain; trivial.
                  }
                  apply (lookup_nin_none string_dec) in nind.
                  rewrite nind.
                  unfold rec_concat_sort.
                  unfold rec_sort.
                  rewrite <- insertion_sort_insert_middle.
                * {rewrite insertion_sort_insert_forall_lt.
                   - constructor; simpl.
                      + split; eauto.
                      + destruct H9 as [[srl0' [eqq0 subl0']]|[nin0 subl0']].
                        * subst.
                          { rewrite map_rtype_meet_cons2_nin.
                            - apply (IHd l' ); trivial;
                              try solve[eapply is_list_sorted_cons_inv; eauto].
                            - apply lookup_none_nin in nind; trivial.
                          }
                        * apply (IHd l' ); trivial;
                          try solve[eapply is_list_sorted_cons_inv; eauto].
                   - change (Forall (rec_field_lt (s1, r0))
                                     (rec_sort
                                        (map_rtype_meet srl srl0 ++
                                                        lookup_diff string_dec l'0 srl))).
                      apply Forall_sorted.
                      apply Forall_rec_field_lt.
                      simpl.
                      rewrite domain_app.
                      rewrite map_rtype_meet_domain.
                      apply Forall_app.
                      + apply sorted_StronglySorted in pf';
                        [ | eapply StrictOrder_Transitive ].
                        simpl in pf'. inversion pf'; subst.
                        eapply Forall_sublist; eauto.
                        apply sublist_domain; trivial.
                      + eapply Forall_sublist.
                        * eapply sublist_domain.
                          eapply lookup_diff_sublist.
                      * apply sorted_StronglySorted in pf'0;
                        [ | eapply StrictOrder_Transitive ].
                        simpl in pf'0. inversion pf'0; subst.
                        trivial.
                  }
                * rewrite map_rtype_meet_domain.
                  apply lookup_none_nin in nind.
                  trivial.
          }
          econstructor; try eapply F2.
          - eapply rec_concat_sort_sorted; reflexivity.
          - unfold rec_concat_sort.
            apply Sorted_incl_sublist; try apply insertion_sort_Sorted.
            intros ? inn.
            rewrite <- rec_sort_perm in inn |- *.
            + rewrite in_app_iff in inn |- *.
              destruct inn as [inn|inn]; [tauto | ].
              right.
              apply lookup_diff_inv in inn.
              destruct inn as [inn ninn].
              destruct x.
              apply (lookup_in string_dec).
              simpl in *.
              rewrite lookup_diff_none2.
              * apply in_lookup_nodup.
                { eapply is_list_sorted_NoDup ;
                  [ eapply StringOrder.lt_strorder | ]; eauto. }
                eapply sublist_In; eauto.
              * apply lookup_nin_none; trivial.
            + apply NoDup_map_rtype_meet_lookup_diff.
              * eapply is_list_sorted_NoDup;
                [ eapply StringOrder.lt_strorder | ].
                apply sublist_domain in H6.
                eapply is_list_sorted_sublist; try eapply H6; eauto.
              * eapply is_list_sorted_NoDup;
                [ eapply StringOrder.lt_strorder | ].
                apply sublist_domain in H9.
                eapply is_list_sorted_sublist; try eapply H9; eauto.
            + rewrite domain_app, map_rtype_meet_domain.
              apply NoDup_app; eauto 2 with qcert.
              * symmetry; apply lookup_diff_disjoint.
              * apply NoDup_lookup_diff; qeauto.
          - intros.
            destruct k; destruct k0; simpl in H0.
            + discriminate.
            + rewrite H10 by trivial; reflexivity.
            + rewrite H7 by trivial.
              repeat rewrite lookup_diff_domain_bounded.
              * reflexivity.
              * rewrite <- (sorted_forall_same_domain H8).
                rewrite <- (sorted_forall_same_domain H11).
                reflexivity.
              * rewrite <- (sorted_forall_same_domain H8).
                rewrite  (sorted_forall_same_domain H11).
                rewrite H9; reflexivity.
            + rewrite H10 by trivial; reflexivity.
        }
      + elim n; clear n.
        assert (domeq:domain rl = domain rl0).
        {
          rewrite <- (sorted_forall_same_domain H8).
          rewrite (sorted_forall_same_domain H11).
          trivial.
        }
        destruct k; destruct k0; simpl; trivial.
        * rewrite H10 in * by trivial.
          rewrite <- domeq.
          apply sublist_domain; trivial.
        *  rewrite H7 in * by trivial.
           rewrite domeq.
           apply sublist_domain; trivial.
        * rewrite H7, H10 by trivial.
          congruence.
    - intros; dtype_inverter_with_either.
      + inversion H; rtype_equalizer. subst.
        econstructor. apply IHτ₁1; trivial.
      + inversion H; rtype_equalizer. subst.
        econstructor. apply IHτ₁2; trivial.
    - intros; dtype_inverter.
      inversion H; clear H; subst.
      inversion H0; clear H0; subst.
      constructor; trivial.
      apply canon_equiv in H3.
      apply canon_equiv in H2.
      rewrite H3 in H7.
      rewrite H2 in H11.
      apply (meet_most (olattice:=brands_olattice)); trivial.
    - intros dt1 dt2.
      invcs dt1.
      invcs dt2.
      constructor.
      apply foreign_data_typing_meet; trivial.
  Qed.

  Theorem meet_data_type_iff
          {fdata:foreign_data}
          {ftype:foreign_type}
          {fdtyping:foreign_data_typing}
          {m:brand_model} d τ₁ τ₂:
    d ▹ (τ₁ ⊓ τ₂) <-> (d ▹ τ₁ /\ d ▹ τ₂).
  Proof.
    split; intros HH.
    - split.
      + rewrite meet_leq_l in HH; trivial.
      + rewrite meet_leq_r in HH; trivial.
    - apply meet_preserves_data_type; tauto.
  Qed.

  Lemma brands_type_Forall
        {fdata:foreign_data}
        {ftype:foreign_type}
        {fdtyping:foreign_data_typing}
        {m:brand_model} d b :
    d ▹ (brands_type b)
     <->
     (data_normalized brand_relation_brands d /\
    Forall (fun bb =>
              forall τ,
                lookup string_dec brand_context_types bb = Some τ ->
                d ▹ τ
           ) b).
  Proof.
    Hint Resolve data_type_normalized : qcert.
    rewrite brands_type_alt.
    induction b; simpl; [ intuition; qeauto | ].
    destruct IHb as [IHb1 IHb2].
    case_eq ( lookup string_dec brand_context_types a); intros; simpl.
    - generalize (meet_data_type_iff d r (fold_right rtype_meet ⊤ (brands_type_list b))); simpl; intros eqq.
      rewrite eqq; clear eqq.
      { split; intros [dt dtf].
        - split; [qeauto | ].
          constructor.
          + rewrite H. intro; inversion 1; subst; trivial.
          + apply IHb1; trivial.
        - inversion dtf; clear dtf; subst.
          specialize (H2 _ H). split; trivial.
          apply IHb2; split; trivial.
      }
    - { split; [intros dt | intros [dt dtf]].
        - split; [ qeauto | ].
          constructor.
          + rewrite H; intros; discriminate.
          + apply IHb1; trivial.
        - inversion dtf; clear dtf; subst.
          apply IHb2; split; trivial.
      }
  Qed.

  Lemma dtbrand'
        {fdata:foreign_data}
        {ftype:foreign_type}
        {fdtyping:foreign_data_typing}
        {m:brand_model} b b' d:
      is_canon_brands brand_relation_brands b ->
      d ▹ (brands_type b) ->
      b ≤ b' ->
      data_type (dbrand b d) (Brand b').
  Proof.
    intros.
    apply brands_type_Forall in H0.
    apply dtbrand; intuition.
  Qed.

  Lemma dtbrand'_inv
        {fdata:foreign_data}
        {ftype:foreign_type}
        {fdtyping:foreign_data_typing}
        {m:brand_model} b b' d:
    data_type (dbrand b d) (Brand b') ->
    is_canon_brands brand_relation_brands b /\
    d ▹ (brands_type b) /\
    b ≤ b'.
  Proof.
    intros dt.
    apply dtbrand_inv in dt.
    intuition.
    apply brands_type_Forall; intuition.
  Qed.

(*
  Global Instance data_type_sub_model_prop : Proper (sub_model ==> eq ==> eq ==> impl) (data_type).
  Proof.
    unfold Proper, respectful, flip, impl; intros; subst.
    revert x y H y1 H2.
    Hint Resolve data_type_normalized.
    Hint Constructors data_type.
    induction y0; simpl; inversion 2; subst; eauto 2.
    - constructor. revert H3. apply Forall_impl_in. intros.
      generalize (Forallt_In H _ H1 _ _ H0). eauto.
    -  inversion H2; rtype_equalizer; subst.
       econstructor; eauto. revert H10.
       apply Forall2_incl; intros. intuition.
       generalize (Forallt_In H _ H1 _ _ H0); intros.
       eauto.
    - specialize (IHy0 _ _ H _ H3).
      case_eq (lookup string_dec (brand_context_types y) b); intros.
      + apply lookup_in in H0.
         generalize (Rec_subtype_In H H5 H0); intros.
         rewrite H1 in IHy0. eauto.
      + apply lookup_none_nin in H0.
         eauto.
    - apply dtbrand_unknown; trivial.
      intro inn.
      generalize (SRec_closed_in_domain H _ inn).
      congruence.
  Qed.
*)
End subtype.

Global Hint Resolve data_type_normalized : qcert.


Require Export Program.Basics. Open Scope program_scope.
From Paco Require Import paco.
From Paco Require Import paconotation_internal paco_internal pacotac_internal.
From Paco Require Export paconotation.
From Fairness Require Import pind_internal.
Set Implicit Arguments.

Section PIND12.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable T6 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4), Type.
Variable T7 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5), Type.
Variable T8 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6), Type.
Variable T9 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6) (x8: @T8 x0 x1 x2 x3 x4 x5 x6 x7), Type.
Variable T10 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6) (x8: @T8 x0 x1 x2 x3 x4 x5 x6 x7) (x9: @T9 x0 x1 x2 x3 x4 x5 x6 x7 x8), Type.
Variable T11 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6) (x8: @T8 x0 x1 x2 x3 x4 x5 x6 x7) (x9: @T9 x0 x1 x2 x3 x4 x5 x6 x7 x8) (x10: @T10 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9), Type.

(** ** Predicates of Arity 12
*)

Definition pind12(gf : rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11)(r: rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11) : rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 :=
  @curry12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 (pind (fun R0 => @uncurry12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 (gf (@curry12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 R0))) (@uncurry12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 r)).

Definition upind12(gf : rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11)(r: rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11) := pind12 gf r /12\ r.
Arguments pind12 : clear implicits.
Arguments upind12 : clear implicits.
#[local] Hint Unfold upind12 : core.

Lemma monotone12_inter (gf gf': rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11)
      (MON1: monotone12 gf)
      (MON2: monotone12 gf'):
  monotone12 (gf /13\ gf').
Proof.
  red; intros. destruct IN. split; eauto.
Qed.

Lemma _pind12_mon_gen (gf gf': rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11) r r'
    (LEgf: gf <13= gf')
    (LEr: r <12= r'):
  pind12 gf r <12== pind12 gf' r'.
Proof.
  apply curry_map12. red; intros. eapply pind_mon_gen. apply PR.
  - intros. apply LEgf, PR0.
  - intros. apply LEr, PR0.
Qed.

Lemma pind12_mon_gen (gf gf': rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11) r r' x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11
    (REL: pind12 gf r x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)
    (LEgf: gf <13= gf')
    (LEr: r <12= r'):
  pind12 gf' r' x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11.
Proof.
  eapply _pind12_mon_gen; [apply LEgf | apply LEr | apply REL].
Qed.

Lemma pind12_mon_bot (gf gf': rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11) r' x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11
    (REL: pind12 gf bot12 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)
    (LEgf: gf <13= gf'):
  pind12 gf' r' x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11.
Proof.
  eapply pind12_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Definition top12 { T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11} (x0: T0) (x1: T1 x0) (x2: T2 x0 x1) (x3: T3 x0 x1 x2) (x4: T4 x0 x1 x2 x3) (x5: T5 x0 x1 x2 x3 x4) (x6: T6 x0 x1 x2 x3 x4 x5) (x7: T7 x0 x1 x2 x3 x4 x5 x6) (x8: T8 x0 x1 x2 x3 x4 x5 x6 x7) (x9: T9 x0 x1 x2 x3 x4 x5 x6 x7 x8) (x10: T10 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9) (x11: T11 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) := True.

Lemma pind12_mon_top (gf gf': rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11) r x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11
    (REL: pind12 gf r x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)
    (LEgf: gf <13= gf'):
  pind12 gf' top12 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11.
Proof.
  eapply pind12_mon_gen; eauto. red. auto.
Qed.

Lemma upind12_mon_gen (gf gf': rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11) r r' x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11
    (REL: upind12 gf r x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)
    (LEgf: gf <13= gf')
    (LEr: r <12= r'):
  upind12 gf' r' x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11.
Proof.
  destruct REL. split; eauto.
  eapply pind12_mon_gen; [apply H | apply LEgf | apply LEr].
Qed.

Lemma upind12_mon_bot (gf gf': rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11) r' x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11
    (REL: upind12 gf bot12 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)
    (LEgf: gf <13= gf'):
  upind12 gf' r' x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11.
Proof.
  eapply upind12_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Lemma upind12mon_top (gf gf': rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11) r x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11
    (REL: upind12 gf r x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)
    (LEgf: gf <13= gf'):
  upind12 gf' top12 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11.
Proof.
  eapply upind12_mon_gen; eauto. red. auto.
Qed.

Section Arg12.

Variable gf : rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11.
Arguments gf : clear implicits.

Theorem _pind12_mon: _monotone12 (pind12 gf).
Proof.
  red; intros. eapply curry_map12, _pind_mon; apply uncurry_map12; assumption.
Qed.

Theorem _pind12_acc: forall
  l r (OBG: forall rr (DEC: rr <12== r) (IH: rr <12== l), pind12 gf rr <12== l),
  pind12 gf r <12== l.
Proof.
  intros. apply curry_adjoint2_12.
  eapply _pind_acc. intros.
  apply curry_adjoint2_12 in DEC. apply curry_adjoint2_12 in IH.
  apply curry_adjoint1_12.
  eapply le12_trans. 2: eapply (OBG _ DEC IH).
  apply curry_map12.
  apply _pind_mon; try apply le1_refl; apply curry_bij2_12.
Qed.

Theorem _pind12_mult_strong: forall r,
  pind12 gf r <12== pind12 gf (upind12 gf r).
Proof.
  intros. apply curry_map12.
  eapply le1_trans; [eapply _pind_mult_strong |].
  apply _pind_mon; intros [] H. apply H.
Qed.

Theorem _pind12_fold: forall r,
  gf (upind12 gf r) <12== pind12 gf r.
Proof.
  intros. apply uncurry_adjoint1_12.
  eapply le1_trans; [| apply _pind_fold]. apply le1_refl.
Qed.

Theorem _pind12_unfold: forall (MON: _monotone12 gf) r,
  pind12 gf r <12== gf (upind12 gf r).
Proof.
  intros. apply curry_adjoint2_12.
  eapply _pind_unfold; apply monotone12_map; assumption.
Qed.

Theorem pind12_acc: forall
  l r (OBG: forall rr (DEC: rr <12= r) (IH: rr <12= l), pind12 gf rr <12= l),
  pind12 gf r <12= l.
Proof.
  apply _pind12_acc.
Qed.

Theorem pind12_mon: monotone12 (pind12 gf).
Proof.
  apply monotone12_eq.
  apply _pind12_mon.
Qed.

Theorem upind12_mon: monotone12 (upind12 gf).
Proof.
  red; intros.
  destruct IN. split; eauto.
  eapply pind12_mon. apply H. apply LE.
Qed.

Theorem pind12_mult_strong: forall r,
  pind12 gf r <12= pind12 gf (upind12 gf r).
Proof.
  apply _pind12_mult_strong.
Qed.

Corollary pind12_mult: forall r,
  pind12 gf r <12= pind12 gf (pind12 gf r).
Proof. intros; eapply pind12_mult_strong in PR. eapply pind12_mon; eauto. intros. destruct PR0. eauto. Qed.

Theorem pind12_fold: forall r,
  gf (upind12 gf r) <12= pind12 gf r.
Proof.
  apply _pind12_fold.
Qed.

Theorem pind12_unfold: forall (MON: monotone12 gf) r,
  pind12 gf r <12= gf (upind12 gf r).
Proof.
  intro. eapply _pind12_unfold; apply monotone12_eq; assumption.
Qed.

End Arg12.

Arguments pind12_acc : clear implicits.
Arguments pind12_mon : clear implicits.
Arguments upind12_mon : clear implicits.
Arguments pind12_mult_strong : clear implicits.
Arguments pind12_mult : clear implicits.
Arguments pind12_fold : clear implicits.
Arguments pind12_unfold : clear implicits.

End PIND12.

Global Opaque pind12.

#[export] Hint Unfold upind12 : core.
#[export] Hint Resolve pind12_fold : core.
#[export] Hint Unfold monotone12 : core.


Set Implicit Arguments.

Require Import Platform.Cito.GLabel Platform.Cito.GLabelMap Platform.Cito.GLabelMapFacts Platform.Cito.ConvertLabel Platform.Cito.GoodModule Platform.Cito.GoodFunction Platform.Cito.NameDecoration Platform.Cito.Label2Word.
Export GLabel GLabelMap GLabelMapFacts ConvertLabel GoodModule GoodFunction Cito.NameDecoration Label2Word.
Import GLabelMap.

Section TopSection.

  Variable ADTValue : Type.

  Variable modules : list GoodModule.

  Require Import Platform.Cito.Semantics.
  Require Import Platform.Cito.AxSpec.

  Variable imports : GLabelMap.t (AxiomaticSpec ADTValue).

  Notation FName := SyntaxFunc.Name.
  Notation MName := GoodModule.Name.

  Definition label_in (lbl : glabel) :=
    (exists m f,
       List.In m modules /\
       List.In f (Functions m) /\
       lbl = (MName m, FName f)) \/
    In lbl imports.

  Notation Internal := (@Internal ADTValue).

  Definition label_mapsto lbl spec :=
    (exists ispec m f,
       spec = Internal ispec /\
       List.In m modules /\
       List.In f (Functions m) /\
       ispec = f /\
       lbl = (MName m, FName f)) \/
    (exists fspec,
       spec = Foreign fspec /\
       find lbl imports = Some fspec).

  Definition stn_good_to_use (stn : settings) :=
    forall lbl : glabel,
      label_in lbl ->
      Labels stn lbl <> None.

  Notation Callee := (@Callee ADTValue).

  Definition fs_good_to_use (fs : settings -> W -> option Callee) (stn : settings) :=
    forall p spec,
      fs stn p = Some spec <->
      exists lbl : glabel,
        Labels stn lbl = Some p /\
        label_mapsto lbl spec.

  Definition glabel2w (stn : settings) (lbl : glabel) : option W := Labels stn lbl.

  Definition env_good_to_use stn fs :=
    stn_good_to_use stn /\
    stn_injective label_in (glabel2w stn) /\
    fs_good_to_use fs stn.

  Definition func_export_IFS m (f : GoodFunction) := ((MName m, FName f), f : InternalFuncSpec).

  Definition module_exports_IFS m :=
    List.map (func_export_IFS m) (Functions m).

  Require Import Platform.Cito.ListFacts1.

  Definition exports_IFS :=
    to_map
      (app_all
         (List.map module_exports_IFS modules)).

  Section fs.

    Variable stn : settings.

    Definition is_export := find_by_word (glabel2w stn) (elements exports_IFS).

    Definition is_import := find_by_word (glabel2w stn) (elements imports).

    Definition fs (p : W) : option Callee :=
      match is_export p with
        | Some spec => Some (Internal spec)
        | None =>
          match is_import p with
            | Some spec => Some (Foreign spec)
            | None => None
          end
      end.

  End fs.

End TopSection.

Definition name_marker (id : glabel) : PropX W (settings * state) := (Ex s, [| s = id |])%PropX.

Require Import Platform.Cito.ADT.

Module Make (Import E : ADT).

  Require Import Platform.Cito.Semantics.
  Module Import SemanticsMake := Make E.
  Export Semantics SemanticsMake.

  Require Import Platform.Cito.RepInv.

  Module Make (Import M : RepInv E).

    Require Import Platform.Cito.CompileFuncSpec.
    Module Import CompileFuncSpecMake := Make E M.
    Import InvMake2.
    Export CompileFuncSpec CompileFuncSpecMake InvMake2.

    Section TopSection.

      Variable modules : list GoodModule.

      Variable imps : t ForeignFuncSpec.

      Notation fs := (fs modules imps).

      (* the exported Bedrock spec format *)
      Definition func_spec (id : glabel) f : assert := (st ~> name_marker id /\ [| env_good_to_use modules imps (fst st) fs |] ---> spec_without_funcs_ok f fs st)%PropX.

      (* the imported Bedrock spec format *)
      Definition foreign_func_spec id spec : assert :=
        st ~> name_marker id /\ ExX, foreign_spec _ spec st.

      (* the imported Bedrock specs *)
      Definition imports := mapi (foreign_func_spec) imps.

      Notation FName := SyntaxFunc.Name.
      Notation MName := GoodModule.Name.

      Definition func_export module (f : GoodFunction) :=
        let lbl := (MName module, FName f) in
        (lbl, func_spec lbl f).

      Definition module_exports m :=
        of_list
          (List.map
             (func_export m)
             (Functions m)).

      (* the exported Bedrock specs (barring the exports from internal implementation, which shouldn't be used) *)
      Definition exports := update_all (List.map module_exports modules).

      Definition impl_label mod_name f_name : glabel := (impl_module_name mod_name, f_name).

      Definition func_impl_export m (f : GoodFunction) := (impl_label (MName m) (FName f), spec f).

      Definition module_impl_exports m :=
        of_list
          (List.map
             (func_impl_export m)
             (Functions m)).

      Definition impl_exports := update_all (List.map module_impl_exports modules).

      (* the imported Bedrock specs (including the exports from internal implementation, which shouldn't be used) *)
      Definition all_exports := update exports impl_exports.

    End TopSection.

  End Make.

End Make.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** RTL function inlining *)

Require Import Coqlib.
Require Import Wfsimpl.
Require Import Errors.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Op.
Require Import Registers.
Require Import RTL.

Ltac xomega := unfold Plt, Ple in *; zify; omega.

(** ** Environment of inlinable functions *)

(** We maintain a mapping from function names to their definitions.
  In this mapping, we only include functions that are eligible for
  inlining, as determined by the external heuristic
  [should_inline]. *)

Definition funenv : Type := PTree.t function.

Definition size_fenv (fenv: funenv) := PTree_Properties.cardinal fenv.

Parameter should_inline: ident -> function -> bool.

Definition add_fundef (fenv: funenv) (idf: ident * fundef) : funenv :=
  match idf with
  | (id, External ef) =>
      PTree.remove id fenv
  | (id, Internal f) =>
      if should_inline id f
      then PTree.set id f fenv
      else PTree.remove id fenv
  end.

Definition remove_vardef (fenv: funenv) (idv: ident * globvar unit) : funenv :=
  PTree.remove (fst idv) fenv.

Definition funenv_program (p: program) : funenv :=
  List.fold_left remove_vardef p.(prog_vars)
    (List.fold_left add_fundef p.(prog_funct) (PTree.empty function)).

(** Resources used by a function. *)

(** Maximum PC (node number) in the CFG of a function.  All nodes of
  the CFG of [f] are between 1 and [max_pc_function f] (inclusive). *)

Definition max_pc_function (f: function) :=
  PTree.fold (fun m pc i => Pmax m pc) f.(fn_code) 1%positive.

(** Maximum pseudo-register defined in a function.  All results of
  an instruction of [f], as well as all parameters of [f], are between
  1 and [max_def_function] (inclusive). *)

Definition max_def_instr (i: instruction) :=
  match i with
  | Iop op args res s => res
  | Iload chunk addr args dst s => dst
  | Icall sg ros args res s => res
  | Ibuiltin ef args res s => res
  | _ => 1%positive
  end.

Definition max_def_function (f: function) :=
  Pmax
    (PTree.fold (fun m pc i => Pmax m (max_def_instr i)) f.(fn_code) 1%positive)
    (List.fold_left (fun m r => Pmax m r) f.(fn_params) 1%positive).

(** State monad *)

(** To construct incrementally the CFG of a function after inlining,
  we use a state monad similar to that used in module [RTLgen].
  It records the current state of the CFG, plus counters to generate
  fresh pseudo-registers and fresh CFG nodes.  It also records the
  stack size needed for the inlined function. *)

Record state : Type := mkstate {
  st_nextreg: positive;                 (**r last used pseudo-register *)
  st_nextnode: positive;                (**r last used CFG node *)
  st_code: code;                        (**r current CFG  *)
  st_stksize: Z                         (**r current stack size *)
}.

(** Monotone evolution of the state. *)

Inductive sincr (s1 s2: state) : Prop :=
  Sincr (NEXTREG: Ple s1.(st_nextreg) s2.(st_nextreg))
        (NEXTNODE: Ple s1.(st_nextnode) s2.(st_nextnode))
        (STKSIZE: s1.(st_stksize) <= s2.(st_stksize)).

Remark sincr_refl: forall s, sincr s s.
Proof.
  intros; constructor; xomega.
Qed.

Lemma sincr_trans: forall s1 s2 s3, sincr s1 s2 -> sincr s2 s3 -> sincr s1 s3.
Proof.
  intros. inv H; inv H0. constructor; xomega.
Qed.

(** Dependently-typed state monad, ensuring that the final state is
  greater or equal (in the sense of predicate [sincr] above) than
  the initial state. *)

Inductive res {A: Type} {s: state}: Type := R (x: A) (s': state) (I: sincr s s').

Definition mon (A: Type) : Type := forall (s: state), @res A s.

(** Operations on this monad. *)

Definition ret {A: Type} (x: A): mon A :=
  fun s => R x s (sincr_refl s).

Definition bind {A B: Type} (x: mon A) (f: A -> mon B): mon B :=
  fun s1 => match x s1 with R vx s2 I1 =>
              match f vx s2 with R vy s3 I2 =>
                R vy s3 (sincr_trans s1 s2 s3 I1 I2)
              end
            end.

Notation "'do' X <- A ; B" := (bind A (fun X => B))
   (at level 200, X ident, A at level 100, B at level 200).

Definition initstate :=
  mkstate 1%positive 1%positive (PTree.empty instruction) 0.

Program Definition set_instr (pc: node) (i: instruction): mon unit :=
  fun s =>
    R tt
      (mkstate s.(st_nextreg) s.(st_nextnode) (PTree.set pc i s.(st_code)) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition add_instr (i: instruction): mon node :=
  fun s =>
    let pc := Psucc s.(st_nextnode) in
    R pc
      (mkstate s.(st_nextreg) pc (PTree.set pc i s.(st_code)) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition reserve_nodes (numnodes: positive): mon positive :=
  fun s =>
    R s.(st_nextnode)
      (mkstate s.(st_nextreg) (Pplus s.(st_nextnode) numnodes) s.(st_code) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition reserve_regs (numregs: positive): mon positive :=
  fun s =>
    R s.(st_nextreg)
      (mkstate (Pplus s.(st_nextreg) numregs) s.(st_nextnode) s.(st_code) s.(st_stksize))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Program Definition request_stack (sz: Z): mon unit :=
  fun s =>
    R tt
      (mkstate s.(st_nextreg) s.(st_nextnode) s.(st_code) (Zmax s.(st_stksize) sz))
      _.
Next Obligation.
  intros; constructor; simpl; xomega.
Qed.

Fixpoint mlist_iter2 {A B: Type} (f: A -> B -> mon unit) (l: list (A*B)): mon unit :=
  match l with
  | nil => ret tt
  | (x,y) :: l' => do z <- f x y; mlist_iter2 f l'
  end.

(** ** Inlining contexts *)

(** A context describes how to insert the CFG for a source function into
  the CFG for the function after inlining:
- a source instruction at PC [n] is relocated to PC [n + ctx.(dpc)];
- all pseudo-registers of this instruction are shifted by [ctx.(dreg)];
- all stack references are shifted by [ctx.(dstk)];
- "return" instructions are transformed into "return" or "move" instructions
  as governed by [ctx.(retinfo)].
*)

Record context: Type := mkcontext {
  dpc: positive;                        (**r offset for PCs *)
  dreg: positive;                       (**r offset for pseudo-regs *)
  dstk: Z;                              (**r offset for stack references *)
  mreg: positive;                       (**r max pseudo-reg number *)
  mstk: Z;                              (**r original stack block size *)
  retinfo: option(node * reg)           (**r where to branch on return *)
                                        (**r and deposit return value *)
}.

(** The following functions "shift" (relocate) PCs, registers, operations, etc. *)

Definition spc (ctx: context) (pc: node) := Pplus pc ctx.(dpc).

Definition sreg (ctx: context) (r: reg) := Pplus r ctx.(dreg).

Definition sregs (ctx: context) (rl: list reg) := List.map (sreg ctx) rl.

Definition sros (ctx: context) (ros: reg + ident) := sum_left_map (sreg ctx) ros.

Definition sop (ctx: context) (op: operation) :=
  shift_stack_operation (Int.repr ctx.(dstk)) op.

Definition saddr (ctx: context) (addr: addressing) :=
  shift_stack_addressing (Int.repr ctx.(dstk)) addr.

(** The initial context, used to copy the CFG of a toplevel function. *)

Definition initcontext (dpc dreg nreg: positive) (sz: Z) :=
  {| dpc := dpc;
     dreg := dreg;
     dstk := 0;
     mreg := nreg;
     mstk := Zmax sz 0;
     retinfo := None |}.

(** The context used to inline a call to another function. *)

Definition min_alignment (sz: Z) :=
  if zle sz 1 then 1
  else if zle sz 2 then 2
  else if zle sz 4 then 4 else 8.

Definition callcontext (ctx: context)
                      (dpc dreg nreg: positive) (sz: Z)
                      (retpc: node) (retreg: reg) :=
  {| dpc := dpc;
     dreg := dreg;
     dstk := align (ctx.(dstk) + ctx.(mstk)) (min_alignment sz);
     mreg := nreg;
     mstk := Zmax sz 0;
     retinfo := Some (spc ctx retpc, sreg ctx retreg) |}.

(** The context used to inline a tail call to another function. *)

Definition tailcontext (ctx: context) (dpc dreg nreg: positive) (sz: Z) :=
  {| dpc := dpc;
     dreg := dreg;
     dstk := align ctx.(dstk) (min_alignment sz);
     mreg := nreg;
     mstk := Zmax sz 0;
     retinfo := ctx.(retinfo) |}.

(** ** Recursive expansion and copying of a CFG *)

(** Insert "move" instructions to copy the arguments of an inlined
    function into its parameters. *)

Fixpoint add_moves (srcs dsts: list reg) (succ: node): mon node :=
  match srcs, dsts with
  | s1 :: sl, d1 :: dl =>
      do n <- add_instr (Iop Omove (s1 :: nil) d1 succ);
      add_moves sl dl n
  | _, _ =>
      ret succ
  end.

(** To prevent infinite inlining of a recursive function, when we
  inline the body of a function [f], this function is removed from the
  environment of inlinable functions and therefore becomes ineligible
  for inlining.  This decreases the size (number of entries) of the
  environment and guarantees termination.  Inlining is, therefore,
  presented as a well-founded recursion over the size of the environment. *)

Section EXPAND_CFG.

Variable fenv: funenv.

(** The [rec] parameter is the recursor: [rec fenv' P ctx f] copies
  the body of function [f], with inline expansion within, as governed
  by context [ctx].  It can only be called for function environments
  [fenv'] strictly smaller than the current environment [fenv]. *)

Variable rec: forall fenv', (size_fenv fenv' < size_fenv fenv)%nat -> context -> function -> mon unit.

(** Given a register-or-symbol [ros], can we inline the corresponding call? *)

Inductive inline_decision (ros: reg + ident) : Type :=
  | Cannot_inline
  | Can_inline (id: ident) (f: function) (P: ros = inr reg id) (Q: fenv!id = Some f).

Program Definition can_inline (ros: reg + ident): inline_decision ros :=
  match ros with
  | inl r => Cannot_inline _
  | inr id => match fenv!id with Some f => Can_inline _ id f _ _ | None => Cannot_inline _ end
  end.

(** Inlining of a call to function [f].  An appropriate context is
  created, then the CFG of [f] is recursively copied, then moves
  are inserted to copy the arguments of the call to the parameters of [f]. *)

Definition inline_function (ctx: context) (id: ident) (f: function)
                           (P: PTree.get id fenv = Some f)
                           (args: list reg)
                           (retpc: node) (retreg: reg) : mon node :=
  let npc := max_pc_function f in
  let nreg := max_def_function f in
  do dpc <- reserve_nodes npc;
  do dreg <- reserve_regs nreg;
  let ctx' := callcontext ctx dpc dreg nreg f.(fn_stacksize) retpc retreg in
  do x <- rec (PTree.remove id fenv) (PTree_Properties.cardinal_remove P) ctx' f;
  add_moves (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)).

(** Inlining of a tail call to function [f].  Similar to [inline_function],
  but the new context is different. *)

Definition inline_tail_function (ctx: context) (id: ident) (f: function)
                               (P: PTree.get id fenv = Some f)
                               (args: list reg): mon node :=
  let npc := max_pc_function f in
  let nreg := max_def_function f in
  do dpc <- reserve_nodes npc;
  do dreg <- reserve_regs nreg;
  let ctx' := tailcontext ctx dpc dreg nreg f.(fn_stacksize) in
  do x <- rec (PTree.remove id fenv) (PTree_Properties.cardinal_remove P) ctx' f;
  add_moves (sregs ctx args) (sregs ctx' f.(fn_params)) (spc ctx' f.(fn_entrypoint)).

(** The instruction generated for a [Ireturn] instruction found in an
  inlined function body. *)

Definition inline_return (ctx: context) (or: option reg) (retinfo: node * reg) :=
  match retinfo, or with
  | (retpc, retreg), Some r => Iop Omove (sreg ctx r :: nil) retreg retpc
  | (retpc, retreg), None   => Inop retpc
  end.

(** Expansion and copying of an instruction.  For most instructions,
  its registers and successor PC are shifted as per the context [ctx],
  then the instruction is inserted in the final CFG at its final position
  [spc ctx pc].

  [Icall] instructions are either replaced by a "goto" to the expansion
  of the called function, or shifted as described above.

  [Itailcall] instructions are similar, with one additional case.  If
  the [Itailcall] occurs in the body of an inlined function, and
  cannot be inlined itself, it must be turned into an [Icall]
  instruction that branches to the return point of the inlined
  function.

  Finally, [Ireturn] instructions within an inlined function are
  turned into a "move" or "goto" that stores the result, if any,
  into the destination register, then branches back to the successor
  of the inlined call. *)

Definition expand_instr (ctx: context) (pc: node) (i: instruction): mon unit :=
  match i with
  | Inop s =>
      set_instr (spc ctx pc) (Inop (spc ctx s))
  | Iop op args res s =>
      set_instr (spc ctx pc)
                (Iop (sop ctx op) (sregs ctx args) (sreg ctx res) (spc ctx s))
  | Iload chunk addr args dst s =>
      set_instr (spc ctx pc)
                (Iload chunk (saddr ctx addr) (sregs ctx args) (sreg ctx dst) (spc ctx s))
  | Istore chunk addr args src s =>
      set_instr (spc ctx pc)
                (Istore chunk (saddr ctx addr) (sregs ctx args) (sreg ctx src) (spc ctx s))
  | Icall sg ros args res s =>
      match can_inline ros with
      | Cannot_inline =>
          set_instr (spc ctx pc)
                    (Icall sg (sros ctx ros) (sregs ctx args) (sreg ctx res) (spc ctx s))
      | Can_inline id f P Q =>
          do n <- inline_function ctx id f Q args s res;
          set_instr (spc ctx pc) (Inop n)
      end
  | Itailcall sg ros args =>
      match can_inline ros with
      | Cannot_inline =>
          match ctx.(retinfo) with
          | None =>
              set_instr (spc ctx pc)
                        (Itailcall sg (sros ctx ros) (sregs ctx args))
          | Some(rpc, rreg) =>
              set_instr (spc ctx pc)
                        (Icall sg (sros ctx ros) (sregs ctx args) rreg rpc)
          end
      | Can_inline id f P Q =>
          do n <- inline_tail_function ctx id f Q args;
          set_instr (spc ctx pc) (Inop n)
      end
  | Ibuiltin ef args res s =>
      set_instr (spc ctx pc)
                (Ibuiltin ef (sregs ctx args) (sreg ctx res) (spc ctx s))
  | Icond cond args s1 s2 =>
      set_instr (spc ctx pc)
                (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2))
  | Ijumptable r tbl =>
      set_instr (spc ctx pc)
                (Ijumptable (sreg ctx r) (List.map (spc ctx) tbl))
  | Ireturn or =>
      match ctx.(retinfo) with
      | None =>
          set_instr (spc ctx pc) (Ireturn (option_map (sreg ctx) or))
      | Some rinfo =>
          set_instr (spc ctx pc) (inline_return ctx or rinfo)
      end
  end.

(** The expansion of a function [f] iteratively expands all its
  instructions, after recording how much stack it needs. *)

Definition expand_cfg_rec (ctx: context) (f: function): mon unit :=
  do x <- request_stack (ctx.(dstk) + ctx.(mstk));
  mlist_iter2 (expand_instr ctx) (PTree.elements f.(fn_code)).

End EXPAND_CFG.

(** Here we "tie the knot" of the recursion, taking the fixpoint
  of [expand_cfg_rec]. *)

Definition expand_cfg := Fixm size_fenv expand_cfg_rec.

(** Start of the recursion: copy and inline function [f] in the
  initial context. *)

Definition expand_function (fenv: funenv) (f: function): mon context :=
  let npc := max_pc_function f in
  let nreg := max_def_function f in
  do dpc <- reserve_nodes npc;
  do dreg <- reserve_regs nreg;
  let ctx := initcontext dpc dreg nreg f.(fn_stacksize) in
  do x <- expand_cfg fenv ctx f;
  ret ctx.

(** ** Inlining in functions and whole programs. *)

Local Open Scope string_scope.

(** Inlining can increase the size of the function's stack block.  We must
  make sure that the new size does not exceed [Int.max_unsigned], otherwise
  address computations within the stack would overflow and produce incorrect
  results. *)

Definition transf_function (fenv: funenv) (f: function) : Errors.res function :=
  let '(R ctx s _) := expand_function fenv f initstate in
  if zle s.(st_stksize) Int.max_unsigned then
    OK (mkfunction f.(fn_sig)
                   (sregs ctx f.(fn_params))
                   s.(st_stksize)
                   s.(st_code)
                   (spc ctx f.(fn_entrypoint)))
  else
    Error(msg "Inlining: stack too big").

Definition transf_fundef (fenv: funenv) (fd: fundef) : Errors.res fundef :=
  AST.transf_partial_fundef (transf_function fenv) fd.

Definition transf_program (p: program): Errors.res program :=
  let fenv := funenv_program p in
  AST.transform_partial_program (transf_fundef fenv) p.