(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Why can't I induct on K and keep d connected?

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.
Require Import Coq.Program.Equality.

Require Export FormalSyntax.
Require Export VarLemmas.
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export DynamicSemanticsTypeSubstitution.
Require Export StaticSemanticsKindingAndContextWellFormedness.
Require Export StaticSemantics.
Require Export TypeSafety.
Require Export ContextExtensionRelation.

Require Export CpdtTactics.
Require Export Case.
Require Export TacticNotations.

Require Export AlphaConversion.
Require Export GetLemmasRelation.

Inductive K' : Delta -> Tau -> Kappa -> Prop :=
 | K'_int   : forall (d : Delta),
                  K' d cint B

 | K'_B     : forall (d : Delta) (alpha : TVar),
               getD d alpha = Some B ->
               K' d (tv_t alpha) B

(*
 | K_star_A  : forall (d : Delta) (alpha : TVar),
                 getD d alpha = Some A ->
                 K'  d (ptype (tv_t alpha)) B.

 | K_B_A     : forall (d : Delta) (tau : Tau),
                  K'  d tau B ->
                  K'  d tau A
*)
 | K'_cross   : forall (d : Delta) (t0 t1 : Tau),
                    K' d t0 A ->
                    K' d t1 A ->
                    K' d (cross t0 t1) A.
(*
 | K_arrow   : forall (d : Delta) (t0 t1 : Tau),
                    K' d t0 A ->
                    K' d t1 A ->
                    K' d (arrow t0 t1) A

 | K_ptype    :  forall (d : Delta) (tau : Tau),
                    K' d tau A ->
                    K' d (ptype tau) B

 | K_utype  : forall (d : Delta) (alpha : TVar) (k : Kappa) (tau : Tau),
                   WFD ([(alpha, k)] ++ d) ->
                   getD d alpha = None ->
                   K' ([(alpha, k)] ++ d) tau A ->
                   K' d (utype alpha k tau) A

 | K_etype  : forall (d : Delta) (alpha : TVar) (k : Kappa) (tau : Tau) (p : Phi),
                   WFD ([(alpha, k)] ++ d) ->
                   getD d alpha = None ->
                   K' ([(alpha, k)] ++ d) tau A ->
                   K' d (etype p alpha k tau) A.
*)

Inductive AK' : Delta -> Tau -> Kappa -> Prop :=

 | AK'_AK_K  : forall (d : Delta) (tau : Tau) (k : Kappa),
                   K'  d tau k ->
                   AK' d tau k

 | AK'_A     : forall (d : Delta) (alpha : TVar),
                getD d alpha = Some A ->
                AK' d (tv_t alpha) A.

(* What's the smallest K_ind that will show me this bug? *)

Lemma minimally_broken_induction:
  forall (alpha : TVar) (k : Kappa) (d : Delta) (tau : Tau),
    K' ([(alpha,k)] ++ d) tau k ->
    K' d tau k.
Proof.
  intros alpha k d tau K'der.
  induction K'der.
  Case "K d cint B".
   (* Good. *)
   admit.
  Case "K d (tv_t alpha) B".
   admit. (* disconnected. *)
   admit.
Qed.

Print K'_ind.

Definition K'_ind_saved :=
fun (P : Delta -> Tau -> Kappa -> Prop) (f : forall d : Delta, P d cint B)
  (f0 : forall (d : Delta) (alpha : TVar),
        getD d alpha = Some B -> P d (tv_t alpha) B)
  (f1 : forall (d : Delta) (t0 t1 : Tau),
        K' d t0 A -> P d t0 A -> K' d t1 A -> P d t1 A -> P d (cross t0 t1) A) =>
fix F (d : Delta) (t : Tau) (k : Kappa) (k0 : K' d t k) {struct k0} :
  P d t k :=
  match k0 in (K' d0 t0 k1) return (P d0 t0 k1) with
  | K'_int d0 => f d0
  | K'_B d0 alpha e => f0 d0 alpha e
  | K'_cross d0 t0 t1 k1 k2 => f1 d0 t0 t1 k1 (F d0 t0 A k1) k2 (F d0 t1 A k2)
  end.

Check K_B.

Definition K'_ind_2 :=
fun (P  : TVar -> Kappa -> Delta -> Tau -> Kappa -> Prop)
    (f  : forall (alpha : TVar) (k : Kappa) (d : Delta), P alpha k d cint B)
    (f0 : forall (alpha : TVar) (k : Kappa) (d : Delta) (alpha0 : TVar),
            getD d alpha0 = Some B ->
            P alpha k d (tv_t alpha0) B)
    (f1 : forall (alpha : TVar) (k : Kappa) (d : Delta) (t0 t1 : Tau),
        K' d t0 A -> P alpha k d t0 A -> K' d t1 A -> P alpha k d t1 A ->
         P alpha k d (cross t0 t1) A) =>
fix F (alpha : TVar) (k1 : Kappa) (d : Delta) (t : Tau) (k2 : Kappa) (k0 : K' d t k2)
    { struct k0} :
  P alpha k1 d t k2 :=
match k0 in (K' d0 t0 k2) return (P alpha k1 d0 t0 k2) with
| K'_int x => f alpha k1 x
| K'_B d' a' getd => f0 alpha k1 d' a' getd
| K'_cross d0 t0 t1 k1' k2' =>
   f1 alpha k1 d0 t0 t1 k1' (F alpha k1 d0 t0 A k1') k2' (F alpha k1 d0 t1 A k2')
end.

Check K'_ind_2.

Lemma minimally_broken_induction_with_handmade_induction:
  forall (alpha : TVar) (k1 : Kappa) (d : Delta) (tau : Tau) (k2: Kappa),
    K' ([(alpha,k1)] ++ d) tau k2 ->
    K' d tau k2.
Proof.
  intros alpha k1 d tau k2 K'der.
  apply (K'_ind_2
           (fun (alpha : TVar) (k1 : Kappa) (d : Delta) (tau : Tau) (k2: Kappa) =>
              K' ([(alpha,k1)] ++ d) tau k2 ->
              K' d tau k2))
        with (alpha := alpha) (k1:= k1).
  Case "K d cint B".
   (* Good. *)
   admit.
  Case "K d (tv_t alpha) B".
   intros.
   admit.
  Case "K d (cross t0 t1) A".
   intros.
   (* ?   H : K' d0 t0 A and H1 : K' d0 t1 A *)
   admit.
  Case "K' d tau k2".
   admit.
  Case "base".
   assumption.
Qed.

(* I'm absolutely not sure I'm building this right until I apply it in the
right inductive form.  But its building interesting cases.
*)

Lemma A_6_Substitution_1_my_induction:
  forall (d : Delta) (tau : Tau) (k1 : Kappa),
      AK' d tau k1 ->
      forall (alpha : TVar) (k2 : Kappa) (tau' : Tau),
        K' ([(alpha,k1)] ++ d) tau' k2 ->
        K' d (subst_Tau tau' tau alpha) k2.
Proof.
  intros d tau k1 AKder alpha k2 tau' Kder.
  apply (K'_ind_2
           (fun (alpha : TVar) (k1 : Kappa) (d : Delta) (tau' : Tau) (k2: Kappa) =>
              K' ([(alpha,k1)] ++ d) tau' k2 ->
              K' d (subst_Tau tau' tau alpha) k2))
        with (k1:= k1).
  Case "K d cint B".
   intros.
   simpl.
   constructor.
  Case "K d (tv_t alpha) B".
   intros.
   admit.
  Case "K d (cross t0 t1) A".
   intros.
   simpl.
   inversion H3.
   apply H0 in H7.
   apply H2 in H8.
   constructor; try assumption.
  Case "K' d tau k2".
   (* Unprovable! Darn. *)

   admit.
  Case "assumption".
   assumption.
Qed.

Lemma A_6_Substitution_1_dep_destruction:
  forall (d : Delta),
      forall (alpha : TVar) (k1 : Kappa) (k2 : Kappa) (tau' : Tau),
        K' ([(alpha,k1)] ++ d) tau' k2 ->
        forall (tau : Tau),
          AK' d tau k1 ->
          K' d (subst_Tau tau' tau alpha) k2.
Proof.
  intros d alpha k1 k2 tau' Kder.
  dependent induction Kder.
  Case "K d cint B".
   intros.
   simpl.
   constructor.
  Case "K d (tv_t alpha) B".
   intros.
   admit.
  Case "K d (cross t0 t1) A".
   intros.
   simpl.
   constructor; try assumption.

Qed.

Lemma A_6_Substitution_1_full_extends:
  forall (d : Delta),
      forall (alpha : TVar) (k1 : Kappa) (k2 : Kappa) (tau' : Tau),
        K' ([(alpha,k1)] ++ d) tau' k2 ->
        forall (tau : Tau),
          AK' d tau k1 ->
          K' d (subst_Tau tau' tau alpha) k2.
Proof.


Require Import Metalib.Metatheory.
Require Import Metalib.LibTactics.
Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Import Strings.String.
Require Import Psatz.

Require Import Language.
Require Import Tactical.
Require Import Subtyping.Subtyping.
Require Import Subtyping.Splitable.
Require Import Subtyping.Toplike.
Require Import Appsub.

Require Import Value.
Require Import Disjoint.
Require Import PrincipalTyping.
Require Import Consistent.
Require Import Typing.
Require Import Casting.
Require Import LocallyNameless.
Require Import Application.

(** * Definition *)

Inductive step : term -> term -> Prop :=
| St_Lit : forall n,
    step (Lit n) (Ann (Lit n) Int)
| St_Lam : forall e A B,
    step (Lam A e B) (Ann (Lam A e B) (Arr A B))
| St_Spl : forall p A A1 A2,
    pvalue p ->
    splitable A A1 A2 ->
    step (Ann p A) (Mrg (Ann p A1) (Ann p A2))
| St_App : forall v vl e,
    value v -> value vl ->
    papp v vl e ->
    step (App v vl) e
| St_Val : forall v v' A,
    value v ->
    casting v A v' ->
    step (Ann v A) v'
| St_Ann : forall e e' A,
    not (pvalue e) ->
    step e e' ->
    step (Ann e A) (Ann e' A)
| St_App_L : forall e1 e1' e2,
    lc e2 ->
    step e1 e1' ->
    step (App e1 e2) (App e1' e2)
| St_App_R : forall v e2 e2',
    value v ->
    step e2 e2' ->
    step (App v e2) (App v e2')
| St_Mrg : forall e1 e1' e2 e2',
    step e1 e1' ->
    step e2 e2' ->
    step (Mrg e1 e2) (Mrg e1' e2')
| St_Mrg_L : forall e1 v e1',
    value v ->
    step e1 e1' ->
    step (Mrg e1 v) (Mrg e1' v)
| St_Mrg_R : forall v e2 e2',
    value v ->
    step e2 e2' ->
    step (Mrg v e2) (Mrg v e2').

Hint Constructors step : core.

Notation "e ⟾ e'" := (step e e') (at level 68).

(** * Value *)

Lemma value_no_step :
  forall v,
    value v -> forall e, ~ step v e.
Proof.
  introv Val.
  induction v; intros; eauto.
  - intros St.
    dependent destruction Val. dependent destruction St; eauto.
    + eapply IHv1; eauto.
    + eapply IHv1; eauto.
    + eapply IHv2; eauto.
  - dependent destruction Val.
    destruct H.
    + intros St. dependent destruction St; eauto.
    + intros St. dependent destruction St; eauto.
Qed.

Lemma step_lc :
  forall e e',
    lc e -> step e e' -> lc e'.
Proof.
  introv Lc St. gen e'.
  induction Lc; intros;
    try solve [dependent destruction St; eauto 3].
  - dependent destruction St. eapply Lc_Ann. eapply Lc_Lam; eauto.
  - dependent destruction St; try solve [econstructor; eauto].
    pose proof (papp_lc e1 e2 e). eauto 3.
  - dependent destruction St; econstructor; eauto.
  - dependent destruction St.
    + econstructor; eapply Lc_Ann; eapply lc_pvalue; eauto.
    + eapply casting_lc; eauto.
    + econstructor. eauto.
Qed.

Lemma step_uvalue :
  forall u u',
    uvalue u -> step u u' -> uvalue u'.
Proof.
  introv Uv St. gen u'.
  induction Uv; intros.
  - dependent destruction St; eauto.
    eapply Uv_Ann. eapply step_lc; eauto.
  - dependent destruction St; eauto.
Qed.

Hint Resolve step_uvalue : core.

(** * Determinism *)

Section determinism.

Ltac solver1 := try solve [match goal with
                           | [Val: value ?v, St: step ?v _ |- _] =>
                               (pose proof (value_no_step _ Val _ St); contradiction)
                           end].

Theorem determinism:
  forall e e1 e2 A,
    typing nil e Inf A ->
    step e e1 -> step e e2 -> e1 = e2.
Proof.
  introv Typ St1 St2. gen e2 A.
  dependent induction St1; intros.
  - dependent destruction St2; eauto.
  - dependent destruction St2; eauto.
  - dependent destruction St2; eauto.
    subst_splitable. reflexivity.
  - dependent destruction St2; solver1.
    pose proof (papp_determinism v vl e). eauto.
  - dependent destruction St2; eauto; solver1.
    dependent destruction Typ.
    dependent destruction Typ.
    eapply casting_determinism; eauto.
  - dependent destruction St2; eauto; solver1.
    f_equal. dependent destruction Typ.
    dependent destruction Typ; eauto.
  - dependent destruction St2; solver1.
    f_equal. dependent destruction Typ; eauto.
  - dependent destruction St2; solver1.
    f_equal. dependent destruction Typ; eauto.
  - dependent destruction St2; solver1.
    dependent destruction Typ;
      f_equal; eauto.
  - dependent destruction St2; solver1.
    dependent destruction Typ;
      f_equal; eauto.
  - dependent destruction St2; solver1.
    dependent destruction Typ;
      f_equal; eauto.
Qed.

End determinism.

(** * Consistent *)

Inductive step_or_value : term -> term -> Prop :=
| Sv_V : forall v, value v -> step_or_value v v
| Sv_S : forall e1 e2, step e1 e2 -> step_or_value e1 e2.

Hint Constructors step_or_value : core.

Lemma size_term_lg_z :
  forall e, size_term e > 0.
Proof.
  introv.
  dependent induction e; try solve [eauto | simpl; lia].
Qed.

Hint Resolve size_term_lg_z : core.

Lemma size_term_lg_z_any1 :
  forall e1 e2,
    size_term e1 < (size_term e2 + size_term e1).
Proof.
  introv.
  assert (size_term e2 > 0). eapply size_term_lg_z.
  lia.
Qed.

Lemma size_term_lg_z_any2 :
  forall e1 e2,
    size_term e1 < (size_term e1 + size_term e2).
Proof.
  introv.
  assert (size_term e2 > 0). eapply size_term_lg_z.
  lia.
Qed.

Hint Resolve size_term_lg_z_any1 : core.
Hint Resolve size_term_lg_z_any2 : core.

Section step_consistent.

Ltac solver1 := match goal with
                | [St: step (Ann (Lam _ _ _) _) _ |- _] => (dependent destruction St; eauto)
                end.

Ltac solver2 := match goal with
                | [St: step (Ann _ _) _ |- _] => (dependent destruction St; eauto)
                end.

Ltac solver3 := match goal with
                | [Val: value ?v, St: step ?v _ |- _] =>
                    (pose proof (value_no_step _ Val _ St); contradiction)
                end.

Ltac solver4 IHC IH :=
  eapply IHC; eauto; intros; match goal with
                             | St: step ?e ?e' |- _ => eapply (IH e e'); eauto; simpl; lia
                             end.

Lemma step_consistent :
  forall e1 e2 e1' e2' A B,
    uvalue e1 -> uvalue e2 ->
    typing nil e1 Inf A -> typing nil e2 Inf B ->
    consistent e1 e2 ->
    step_or_value e1 e1' -> step_or_value e2 e2' ->
    (forall e e' A, size_term e < (size_term e1 + size_term e2) ->
        typing nil e Inf A -> step e e' -> (exists C, typing nil e' Inf C /\ isosub C A)) ->
    consistent e1' e2'.
Proof.
  introv Uv1 Uv2 Typ1 Typ2 Con Sv1 Sv2 IH. gen A B e1' e2'.
  dependent induction Con; intros; eauto.
  - Case "Lam Lam".
    dependent destruction Sv1; dependent destruction Sv2; eauto; try solve [solver1].
    dependent destruction Typ1. dependent destruction Typ2.
    solver1. solver1. eapply Con_Mrg_L; eauto.
  - Case "Anno Anno".
    dependent destruction Sv1; dependent destruction Sv2; eauto; try solve [solver2].
    dependent destruction Typ1. dependent destruction Typ2.
    solver2.
    * solver2. eapply Con_Mrg_L; eauto.
    * solver2; try solve [solver3].
      dependent destruction Typ1.
      pose proof (casting_preservation e v' B0 A) as Cp1.
      dependent destruction Typ2.
      pose proof (casting_preservation e v'0 B A0) as Cp2.
      destruct Cp1; destruct Cp2; eauto. destruct_conjs.
      eapply casting_consistent; eauto.
    * solver2; try solve [solver3].
      dependent destruction Typ1. dependent destruction Typ2.
      assert (e' = e'0). eapply determinism; eauto. subst. econstructor; eauto.
      eapply step_lc; eauto.
  - Case "Disjoint".
    dependent destruction Sv1; dependent destruction Sv2; eauto.
    + pose proof (step_uvalue _ _ Uv2 H3).
      eapply IH in H3; eauto; try lia.
      destruct H3 as [x Typ]; destruct Typ as [Typ Isub].
      eapply typing_to_ptype in Typ; eauto.
      eapply typing_to_ptype in Typ2; eauto. subst_ptype.
      eapply Con_Dj; eauto. eapply disjoint_iso_l; eauto.
    + pose proof (step_uvalue _ _ Uv1 H2).
      eapply IH in H2; eauto; try lia.
      destruct H2 as [x Typ]; destruct Typ as [Typ Isub].
      eapply typing_to_ptype in Typ; eauto.
      eapply typing_to_ptype in Typ1; eauto. subst_ptype.
      eapply Con_Dj; eauto. eapply disjoint_iso_l; eauto.
    + pose proof (step_uvalue _ _ Uv1 H2).
      pose proof (step_uvalue _ _ Uv2 H3).
      eapply IH in H2; eauto; try lia.
      eapply IH in H3; eauto; try lia.
      destruct_conjs.
      eapply typing_to_ptype in Typ1; eauto.
      eapply typing_to_ptype in Typ2; eauto. repeat subst_ptype.
      eapply Con_Dj; eauto. eapply disjoint_iso_l; eauto.
  - Case "Merge L".
    dependent destruction Sv1; eauto 3.
    + dependent destruction Typ1;
        eapply Con_Mrg_L; try solve [solver4 IHCon1 IH | solver4 IHCon2 IH].
    + dependent destruction Typ1;
        match goal with
        | St: step (Mrg _ _) _ |- _ => dependent destruction St
        end; eapply Con_Mrg_L; try solve [solver4 IHCon1 IH | solver4 IHCon2 IH].
  - Case "Merge R".
    dependent destruction Sv2; eauto 3.
    + dependent destruction Typ2;
        eapply Con_Mrg_R; try solve [solver4 IHCon1 IH | solver4 IHCon2 IH].
    + dependent destruction Typ2;
        match goal with
        | St: step (Mrg _ _) _ |- _ => dependent destruction St
        end; eapply Con_Mrg_R; try solve [solver4 IHCon1 IH | solver4 IHCon2 IH].
Qed.

End step_consistent.

(** * Preservation *)

Ltac ind_term_size s :=
  assert (SizeInd: exists i, s < i) by eauto;
  destruct SizeInd as [i SizeInd];
  repeat match goal with | [ h : term |- _ ] => (gen h) end;
  induction i as [|i IH]; [
      intros; match goal with | [ H : _ < 0 |- _ ] => (dependent destruction H) end
    | intros ].

Theorem preservation :
  forall e e' A,
    typing nil e Inf A ->
    step e e' ->
    (exists B, typing nil e' Inf B /\ isosub B A).
Proof.
  introv Typ St. gen e' A.
  ind_term_size (size_term e).
  dependent destruction Typ; simpl in SizeInd.
  - Case "Lit".
    dependent destruction St; eauto.
    exists Int; eauto.
  - Case "Var".
    dependent destruction St.
  - Case "Lam".
    dependent destruction St; eauto.
    exists (Arr A B). split; eauto.
  - Case "Ann".
    dependent destruction St.
    + SCase "Split".
      dependent destruction Typ.
      exists (And A1 A2). split; eauto.
      pose proof (sub_inv_splitable_r A B A1 A2) as Sub. destruct Sub; eauto.
      eapply Ty_Mrg_Uv; eauto.
    + SCase "Value".
      dependent destruction Typ.
      eapply casting_preservation; eauto.
    + SCase "Ann".
      dependent destruction Typ.
      eapply IH in St; eauto; try lia.
      destruct St as [C Typ']. destruct Typ' as [Typ'1 Typ'2].
      pose proof (isosub_to_sub1 _ _ Typ'2).
      exists B. split; eauto. eapply Ty_Ann; eauto; try solve [eapply sub_transitivity; eauto].
      eapply Ty_Sub; eauto. eapply sub_transitivity; eauto.
  - Case "App".
    dependent destruction St.
    + pose proof (papp_preservation e1 e2 e) as P.
      eapply P; eauto.
    + eapply IH in St; eauto; try lia. destruct_conjs.
      eapply appsub_iso in H0; eauto. destruct_conjs.
      eexists; eauto.
    + eapply IH in St; eauto; try lia. destruct_conjs.
      eapply appsub_iso in H0; eauto. destruct_conjs.
      eexists; eauto.
  - Case "Merge".
    dependent destruction St.
    + eapply IH in St1; eauto; try lia.
      eapply IH in St2; eauto; try lia. destruct_conjs.
      eapply disjoint_iso_l in H; eauto.
    + eapply IH in St; eauto; try lia. destruct_conjs.
      eapply disjoint_iso_l in H0; eauto.
    + eapply IH in St; eauto; try lia. destruct_conjs.
      eapply disjoint_iso_l in H0; eauto.
  - Case "Merge U".
    dependent destruction St.
    + (* TODO: Automation *)
      assert (exists C, (typing nil e1' Inf C) /\ (isosub C A)) by (eapply IH; eauto; lia).
      assert (exists C, (typing nil e2' Inf C) /\ (isosub C B)) by (eapply IH; eauto; lia).
      destruct_conjs. exists (And H3 H4).
      pose proof (step_uvalue _ _ H0 St1).
      pose proof (step_uvalue _ _ H1 St2).
      split; eauto. eapply Ty_Mrg_Uv; eauto.
      pose proof (Sv_S _ _ St1) as Sov1.
      pose proof (Sv_S _ _ St2) as Sov2.
      pose proof (step_consistent u1 u2 e1' e2' A B H0 H1 Typ1 Typ2 H2 Sov1 Sov2) as Sc.
      eapply Sc. intros. eapply IH; eauto. lia.
    + assert (exists C, (typing nil e1' Inf C) /\ (isosub C A)) by (eapply IH; eauto; lia).
      destruct_conjs. exists (And H4 B).
      pose proof (step_uvalue _ _ H1 St).
      split; eauto. eapply Ty_Mrg_Uv; eauto.
      pose proof (Sv_S _ _ St) as Sov1.
      pose proof (Sv_V _ H) as Sov2.
      pose proof (step_consistent u1 u2 e1' u2 A B H1 H2 Typ1 Typ2 H3 Sov1 Sov2) as Sc.
      eapply Sc; eauto. intros. eapply IH; eauto. lia.
    + assert (exists C, (typing nil e2' Inf C) /\ (isosub C B)) by (eapply IH; eauto; lia).
      destruct_conjs. exists (And A H4).
      pose proof (step_uvalue _ _ H2 St).
      split; eauto. eapply Ty_Mrg_Uv; eauto.
      pose proof (Sv_V _ H) as Sov1.
      pose proof (Sv_S _ _ St) as Sov2.
      pose proof (step_consistent u1 u2 u1 e2' A B H1 H2 Typ1 Typ2 H3 Sov1 Sov2) as Sc.
      eapply Sc; eauto. intros. eapply IH; eauto. lia.
      Unshelve. eauto.
Qed.

(** * Progress *)

Theorem progress :
  forall e A dir,
    typing nil e dir A ->
    value e \/ exists e', step e e'.
Proof.
  introv Typ.
  dependent induction Typ; eauto 3.
  - Case "Anno".
    destruct IHTyp as [Val | St] ; eauto.
    + right. eapply casting_progress in Typ; eauto. destruct Typ.
      exists x. eapply St_Val; eauto.
    + destruct (pvalue_decidable e) as [Pv | nPv];
        destruct (splitable_or_ordinary A) as [Spl | Ord]; eauto.
      * destruct Pv; right; destruct_conjs; eexists; eauto.
      * destruct St. right. eexists; eauto.
      * destruct St. right. eexists; eauto.
  - Case "App".
    right. destruct IHTyp1; destruct IHTyp2; eauto 3; try solve [destruct_conjs; eauto].
    pose proof (papp_progress e1 e2 A B C) as P. destruct P; eauto.
  - Case "Merge".
    destruct IHTyp1; destruct IHTyp2; eauto 3; try solve [destruct_conjs; eauto].
  - Case "Merge V".
    destruct IHTyp1; destruct IHTyp2; eauto 3; try solve [destruct_conjs; eauto].
Qed.


(**************************************************************************)
(*                                                                        *)
(*     SMTCoq                                                             *)
(*     Copyright (C) 2011 - 2014                                          *)
(*                                                                        *)
(*     Michaël Armand                                                     *)
(*     Benjamin Grégoire                                                  *)
(*     Chantal Keller                                                     *)
(*                                                                        *)
(*     INRIA - École Polytechnique - MSR                                  *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

Require Import List.
Require Import Bool.
Require Import Int31.
Require Import PArray.

(* Require Import AxiomesInt. *)

Local Open Scope int31_scope.
Local Open Scope array_scope.

Coercion is_true (x: bool) := x = true.

Set Vm Optimize.

Notation var := int (only parsing).

(* Variables interpretation *)
Module Valuation.
(* TODO : Should be var -> Prop *)
  Definition t := var -> bool.
  Definition wf (rho : t) : Prop := rho 0 /\ ~ rho 1.

End Valuation.

Module Var.

  Definition _true : var := 0. (* true *)
  Register _true as PrimInline.

  Definition _false : var := 1. (* false *)

  Definition interp (rho:Valuation.t) (x:var) : bool := rho x.

  Lemma interp_true : forall rho, Valuation.wf rho -> interp rho _true.
  Proof. intros rho [H _];exact H. Qed.

  Lemma interp_false : forall rho, Valuation.wf rho -> ~ interp rho _false.
  Proof. intros rho [_ H];exact H. Qed.

End Var.

Notation _lit := int (only parsing).

Module Lit.

  Definition is_pos (l:_lit) := is_even l.
  Register is_pos as PrimInline.

  Definition blit (l:_lit) : var := l >> 1.
  Register blit as PrimInline.

  Definition lit (x:var) : _lit := x << 1.
  Register lit as PrimInline.

  Definition neg (l:_lit) : _lit := l lxor 1.
  Register neg as PrimInline.

  Definition nlit (x:var) : _lit := neg (lit x).
  Register nlit as PrimInline.

  Definition _true : _lit := Eval compute in lit Var._true.
  Register _true as PrimInline.

  Lemma lit_true : _true = lit Var._true.
  Proof. reflexivity. Qed.

  Definition _false : _lit := Eval compute in lit Var._false.
  Register _false as PrimInline.

  Lemma lit_false : _false = lit Var._false.
  Proof. reflexivity. Qed.

  Definition eqb (l l' : _lit) := l == l'.
  Register eqb as PrimInline.

  Lemma eqb_spec : forall l l', eqb l l' = true <-> l = l'.
  Proof eqb_spec.

  Lemma neg_involutive : forall l,  neg (neg l) = l.
  Proof.
    unfold neg;intros; rewrite <- lxor_assoc;change (1 lxor 1) with 0;rewrite lxor_0_r;trivial.
  Qed.

  Lemma blit_neg : forall l, blit (neg l) = blit l.
  Proof.
    unfold blit, neg;intros l.
    rewrite lxor_lsr, lxor_0_r;trivial.
  Qed.

  Lemma lit_blit: forall l,
    is_pos l = true -> lit (blit l) = l.
  Proof.
    unfold is_pos, lit, blit;intros.
    rewrite (bit_xor_split l) at 2.
    rewrite is_even_bit, negb_true_iff in H;rewrite H.
    symmetry;apply lxor_0_r.
  Qed.

  Lemma lit_blit_neg: forall l,
    is_pos l = false -> lit (blit l) = neg l.
  Proof.
    unfold is_pos, lit, blit;intros.
    rewrite (bit_xor_split l) at 2.
    rewrite is_even_bit, negb_false_iff in H;rewrite H.
    rewrite <- (neg_involutive ((l >> 1) << 1)) at 1;trivial.
  Qed.

  Lemma nlit_blit: forall l,
    is_pos l = false -> nlit (blit l) = l.
  Proof.
    unfold nlit;intros;rewrite lit_blit_neg;auto using neg_involutive.
  Qed.

  Lemma nlit_blit_neg: forall l,
    is_pos l = true -> nlit (blit l) = neg l.
  Proof.
    unfold nlit;intros;rewrite lit_blit;auto using neg_involutive.
  Qed.

  Lemma is_pos_lit : forall l,
    is_pos (lit l) = true.
  Proof.
    unfold is_pos, lit;apply is_even_lsl_1.
  Qed.

  Lemma is_pos_neg : forall l,
    is_pos (neg l) = negb (is_pos l).
  Proof.
    unfold neg, is_pos;intros l.
    rewrite is_even_xor, xorb_false_r;trivial.
  Qed.

  Lemma is_pos_nlit : forall l,
    is_pos (nlit l) = false.
  Proof.
    unfold nlit;intros l;rewrite is_pos_neg, is_pos_lit;trivial.
  Qed.

  Lemma is_pos_true : is_pos _true.
  Proof. reflexivity. Qed.

  Lemma is_pos_false : is_pos _false.
  Proof. reflexivity. Qed.

  Lemma blit_pos :forall a b,
    Lit.blit a = Lit.blit b -> Lit.is_pos a = Lit.is_pos b ->
    a = b.
  Proof lsr_is_even_eq.

  Lemma blit_lit : forall l, blit (lit (blit l)) = blit l.
  Proof.
    intros l;case_eq (is_pos l);intros.
    rewrite lit_blit;trivial.
    rewrite lit_blit_neg, blit_neg;trivial.
  Qed.

  Lemma blit_nlit : forall l, blit (nlit (blit l)) = blit l.
  Proof.
    intros l;case_eq (is_pos l);intros.
    rewrite nlit_blit_neg, blit_neg;trivial.
    rewrite nlit_blit;trivial.
  Qed.

  Lemma blit_true : blit _true = Var._true.
  Proof. reflexivity. Qed.

  Lemma blit_false : blit _false = Var._false.
  Proof. reflexivity. Qed.

                        (* Interpretation of a literal *)
  Definition interp rho (l:_lit) :=
    if is_pos l then Var.interp rho (blit l)
      else negb (Var.interp rho (blit l)).

  Lemma interp_true : forall rho, Valuation.wf rho -> interp rho _true.
  Proof.
    intros rho Hwf;unfold interp;rewrite is_pos_true, blit_true.
    apply Var.interp_true;trivial.
  Qed.

  Lemma interp_false : forall rho, Valuation.wf rho -> ~interp rho _false.
  Proof.
    intros rho Hwf;unfold interp;rewrite is_pos_false, blit_false.
    apply Var.interp_false;trivial.
  Qed.

  Lemma interp_neg : forall rho l, interp rho (neg l) = negb (interp rho l).
  Proof.
    intros rho l;unfold interp;rewrite is_pos_neg, blit_neg.
    destruct (is_pos l);simpl;auto using negb_involutive.
  Qed.

  Lemma interp_lit : forall rho l, interp rho (lit (blit l)) = Var.interp rho (blit l).
  Proof.
    intros;unfold interp;rewrite is_pos_lit, blit_lit;trivial.
  Qed.

  Lemma interp_nlit : forall rho l, interp rho (nlit (blit l)) = negb (Var.interp rho (blit l)).
  Proof.
    unfold nlit;intros rho l;rewrite interp_neg, interp_lit;trivial.
  Qed.

  Lemma interp_eq_compat : forall rho1 rho2 l,
    rho1 (blit l) = rho2 (blit l) ->
    interp rho1 l = interp rho2 l.
  Proof.
    unfold interp, Var.interp;intros rho1 rho2 l Heq;rewrite Heq;trivial.
  Qed.

  Lemma lxor_neg : forall l1 l2, (l1 lxor l2 == 1) = true -> l1 = Lit.neg l2.
  Proof.
    unfold Lit.neg; intros l1 l2;rewrite eqb_spec;intros Heq;rewrite <- Heq.
    rewrite lxor_comm, <- lxor_assoc, lxor_nilpotent, lxor_0_r;trivial.
  Qed.

End Lit.

Lemma compare_spec' : forall x y,
    match x ?= y with
    | Lt => x < y
    | Eq => x = y
    | Gt => y < x
    end.
Proof.
  intros x y;rewrite compare_def_spec;unfold compare_def.
  case_eq (x < y);intros;[reflexivity | ].
  case_eq (x == y);intros.
  rewrite <- eqb_spec;trivial.
  rewrite <- not_true_iff_false in H, H0.
  unfold is_true in *;rewrite ltb_spec in H |- *;rewrite eqb_spec in H0.
  assert ([|x|] <> [|y|]) by (intros Heq;apply H0, to_Z_inj;trivial);omega.
Qed.

Module C.

  Definition t := list _lit.

  Definition interp (rho:Valuation.t) (l:t) :=
    List.existsb (Lit.interp rho) l.

  Definition valid rho c :=
    interp rho c = true.

  Definition _true : t := Lit._true :: nil.

  Definition is_false (c:t) :=
    match c with
      | nil => true
      | _ => false
    end.

  Section OR.

    Variable or : t -> t -> t.
    Variable l1 : _lit.
    Variable c1 : t.

    Fixpoint or_aux (c2:t) :=
      match c2 with
      | nil => l1 :: c1
      | l2::c2' =>
        match l1 ?= l2 with
        | Eq => l1 :: or c1 c2'
        | Lt => l1 :: or c1 c2
        | Gt => l2 :: or_aux c2'
        end
      end.

    Variable rho : Valuation.t.
    Hypothesis or_correct : forall c2,
        interp rho (or c1 c2) = interp rho c1 || interp rho c2.

    Lemma or_aux_correct : forall c2,
      interp rho (or_aux c2) = interp rho (l1::c1) || interp rho c2.
    Proof.
      induction c2;simpl.
      rewrite orb_false_r;trivial.
      generalize (compare_spec' l1 a);destruct (l1 ?= a);intros H;simpl.
      rewrite H;destruct (Lit.interp rho a);trivial.
      rewrite !orb_false_l, or_correct;trivial.
      rewrite or_correct;simpl;rewrite orb_assoc;trivial.
      rewrite IHc2;simpl.
      destruct (Lit.interp rho a);simpl;trivial.
      rewrite orb_true_r;trivial.
    Qed.

  End OR.

  Fixpoint or (c1 c2:t) {struct c1} : t :=
    match c1, c2 with
    | nil, _ => c2
    | _, nil => c1
    | l1::c1, l2::c2' =>
      match compare l1 l2 with
      | Eq => l1 :: or c1 c2'
      | Lt => l1 :: or c1 c2
      | Gt => l2 :: or_aux or l1 c1 c2'
      end
    end.

  Lemma or_correct : forall rho c1 c2,
    interp rho (or c1 c2) = interp rho c1 || interp rho c2.
  Proof.
    induction c1;simpl;trivial.
    destruct c2;simpl.
    rewrite orb_false_r;trivial.
    generalize (compare_spec' a i);destruct (a ?= i);intros H;simpl.
    rewrite H, IHc1;simpl;destruct (Lit.interp rho i);simpl;trivial.
    rewrite IHc1, orb_assoc;trivial.
    rewrite or_aux_correct;simpl;trivial.
    destruct (Lit.interp rho i);trivial.
    simpl;rewrite !orb_true_r;trivial.
  Qed.

  Section RESOLVE.

    Variable resolve : t -> t -> t.
    Variable l1 : _lit.
    Variable c1 : t.

    Fixpoint resolve_aux (c2:t) : t :=
      match c2 with
      | nil => _true
      | l2::c2' =>
        match compare l1 l2 with
        | Eq => l1 :: resolve c1 c2'
        | Lt => if l1 lxor l2 == 1 then or c1 c2' else l1 :: resolve c1 c2
        | Gt =>
          if l1 lxor l2 == 1 then or c1 c2' else l2 :: resolve_aux c2'
        end
      end.

    Lemma resolve_aux_correct : forall rho,
      (forall c2, interp rho c1 -> interp rho c2 -> interp rho (resolve c1 c2)) ->
      interp rho (l1 :: c1) ->
      forall c2, interp rho c2 ->
      interp rho (resolve_aux c2).
    Proof.
      intros rho resolve_correct Hc1;simpl in Hc1.
      induction c2;simpl;try discriminate.
      generalize (compare_spec' l1 a);destruct (l1 ?= a);intros;subst;simpl.
      simpl in Hc1;destruct (Lit.interp rho a);simpl in *;auto.
      generalize (Lit.lxor_neg l1 a);destruct (l1 lxor a == 1);intros.
      rewrite or_correct.
      rewrite H1, Lit.interp_neg in Hc1;trivial;destruct (Lit.interp rho a).
      simpl in Hc1;rewrite Hc1;trivial.
      simpl in H0;rewrite H0, orb_true_r;trivial.
      simpl;destruct (Lit.interp rho l1);simpl;auto.
      generalize (Lit.lxor_neg l1 a);destruct (l1 lxor a == 1);intros.
      rewrite or_correct.
      rewrite H1, Lit.interp_neg in Hc1;trivial;destruct (Lit.interp rho a).
      simpl in Hc1;rewrite Hc1;trivial.
      simpl in H0;rewrite H0, orb_true_r;trivial.
      simpl;destruct (Lit.interp rho a);simpl;auto.
    Qed.

  End RESOLVE.

  Fixpoint resolve (c1 c2:t) {struct c1} : t :=
    match c1, c2 with
    | nil, _ => _true
    | _, nil => _true
    | l1::c1, l2::c2' =>
      match compare l1 l2 with
      | Eq => l1 :: resolve c1 c2'
      | Lt => if l1 lxor l2 == 1 then or c1 c2' else l1 :: resolve c1 c2
      | Gt =>
        if l1 lxor l2 == 1 then or c1 c2' else l2 :: resolve_aux resolve l1 c1 c2'
      end
    end.

  Lemma resolve_correct : forall rho c1 c2,
    interp rho c1 -> interp rho c2 ->
    interp rho (resolve c1 c2).
  Proof.
    induction c1;simpl;try discriminate.
    destruct c2;simpl;try discriminate.
    intros Hc1 Hc2.
    generalize (compare_spec' a i);destruct (a ?= i);intros;subst;simpl.
    destruct (Lit.interp rho i);simpl in *;auto.
    generalize (Lit.lxor_neg a i);destruct (a lxor i == 1);intros.
    rewrite or_correct.
    rewrite H0, Lit.interp_neg in Hc1;trivial;destruct (Lit.interp rho i).
    simpl in Hc1;rewrite Hc1;trivial.
    simpl in Hc2;rewrite Hc2, orb_true_r;trivial.
    simpl;destruct (Lit.interp rho a);simpl;auto.
    generalize (Lit.lxor_neg a i);destruct (a lxor i == 1);intros.
    rewrite or_correct.
    rewrite H0, Lit.interp_neg in Hc1;trivial;destruct (Lit.interp rho i).
    simpl in Hc1;rewrite Hc1;trivial.
    simpl in Hc2;rewrite Hc2, orb_true_r;trivial.
    simpl;destruct (Lit.interp rho i);simpl;auto using resolve_aux_correct.
  Qed.

  Lemma interp_true : forall rho, Valuation.wf rho -> interp rho _true = true.
  Proof.
    unfold _true, interp;intros rho Hwf;simpl.
    rewrite Lit.interp_true;trivial.
  Qed.

  Lemma is_false_correct :
    forall c, is_false c = true ->
      forall rho, ~valid rho c.
  Proof.
    unfold valid, interp;destruct c;simpl; auto;discriminate.
  Qed.

End C.

Notation clause_id := int (only parsing).

Notation resolution := (array clause_id) (only parsing).

Module S.

  Definition t := array C.t.

  Definition get (s:t) (cid:clause_id) := s.[cid].
  Register get as PrimInline.

  (* Do not use this function outside this module *)
  (* expect if you are sure that [c = sort_uniq c] *)
  Definition internal_set (s:t) (cid:clause_id) (c:C.t) : t := s.[cid <- c].
  Register internal_set as PrimInline.

  Definition make (nclauses : int) : t :=
    PArray.make nclauses C._true.

  Definition valid rho s :=
    forall id, C.valid rho (get s id).

  (* Specification of make *)

  Lemma valid_make : forall rho nclauses,
    Valuation.wf rho ->
    valid rho (make nclauses).
  Proof.
    unfold valid, make, get;intros.
    rewrite PArray.get_make; apply C.interp_true;trivial.
  Qed.

  (* Specification of get *)

  Lemma valid_get : forall rho s, valid rho s ->
    forall id, C.valid rho (get s id).
  Proof. auto. Qed.

  (* Specification of internal_set *)

  Lemma valid_internal_set :
    forall rho s, valid rho s ->
      forall c, C.valid rho c ->
        forall id, valid rho (set s id c).
  Proof.
    unfold valid, get, set;simpl;intros.
    destruct (Int31Properties.reflect_eqb id id0);subst.
    case_eq (id0 < length s);intros.
    rewrite PArray.get_set_same;trivial.
    rewrite PArray.get_outofbound.
    rewrite PArray.default_set.
    rewrite <- (PArray.get_outofbound _ _ (length s)); trivial.
    rewrite <- not_true_iff_false, ltb_spec;auto with zarith.
    rewrite PArray.length_set;trivial.
    rewrite get_set_other;trivial.
  Qed.

  (* Building clause *)
  (* Same as set but without precondition *)

  (* TODO: It can be a good idea to change the insertion sort algorithm *)

  Fixpoint insert l1 c :=
   match c with
   | nil => l1:: nil
   | l2 :: c' =>
     match l1 ?= l2 with
     | Lt => if l1 lxor l2 == 1 then C._true else l1 :: c
     | Eq => c
     | Gt => if l1 lxor l2 == 1 then C._true else l2 :: insert l1 c'
     end
   end.

  Fixpoint sort_uniq c :=
    match c with
    | nil => nil
    | l1 :: c => insert l1 (sort_uniq c)
    end.

  Lemma insert_correct : forall rho (Hwf:Valuation.wf rho) l1 c,
    C.interp rho (insert l1 c) = C.interp rho (l1 :: c).
  Proof.
    intros rho Hwf l1;induction c;simpl;trivial.
    generalize (compare_spec' l1 a);destruct (l1 ?= a);intros;subst;simpl.
    destruct (Lit.interp rho a);simpl in *;auto.
    generalize (Lit.lxor_neg l1 a);destruct (l1 lxor a == 1);intros;trivial.
    rewrite C.interp_true;trivial.
    rewrite H0, Lit.interp_neg;trivial;destruct (Lit.interp rho a);trivial.
    generalize (Lit.lxor_neg l1 a);destruct (l1 lxor a == 1);intros.
    rewrite C.interp_true;trivial.
    rewrite H0, Lit.interp_neg;trivial;destruct (Lit.interp rho a);trivial.
    simpl;rewrite orb_assoc,(orb_comm (Lit.interp rho l1)),<-orb_assoc,IHc;trivial.
  Qed.

  Lemma sort_uniq_correct : forall rho (Hwf:Valuation.wf rho) c,
    C.interp rho (sort_uniq c) = C.interp rho c.
  Proof.
    intros rho Hwf;induction c;simpl;trivial.
    rewrite insert_correct;trivial;simpl;rewrite IHc;trivial.
  Qed.

  Definition set_clause (s:t) pos (c:C.t) : t :=
    set s pos (sort_uniq c).

  Lemma valid_set_clause :
    forall rho s, Valuation.wf rho -> valid rho s -> forall pos c,
      C.valid rho c -> valid rho (set_clause s pos c).
  Proof.
    unfold valid, get, set_clause. intros rho s Hrho Hs pos c Hc id.
    destruct (Int31Properties.reflect_eqb pos id);subst.
    case_eq (id < length s); intro H.
    unfold get;rewrite PArray.get_set_same; trivial.
    unfold C.valid;rewrite sort_uniq_correct;trivial.
    generalize (Hs id);rewrite !PArray.get_outofbound, PArray.default_set;trivial.
    rewrite length_set;trivial.
    rewrite get_set_other;trivial.
  Qed.

  (* Resolution *)

  Definition set_resolve (s:t) pos (r:resolution) : t :=
    let len := PArray.length r in
    if len == 0 then s
    else
      let c := foldi (fun i c => C.resolve (get s (r.[i])) c) 1 (len - 1)
         (get s (r.[0])) in
      internal_set s pos c.

  Lemma valid_set_resolve :
    forall rho s, Valuation.wf rho -> valid rho s ->
      forall pos r, valid rho (set_resolve s pos r).
  Proof.
    unfold set_resolve; intros rho s Hrho Hv pos r.
    destruct (Int31Properties.reflect_eqb (length r) 0);[trivial | ].
    apply valid_internal_set;trivial.
    apply foldi_ind;auto.
    intros i c _ _ Hc;apply C.resolve_correct;auto;apply Hv.
  Qed.

End S.


Require Import Coq.ZArith.ZArith.
Require Import compcert.lib.Maps.
Require Import compcert.common.AST.
Require Import liblayers.lib.Decision.
Require Import liblayers.lib.OptionMonad.
Require Import liblayers.compcertx.ErrorMonad.
Require Import liblayers.logic.PTrees.
Require Import liblayers.logic.PTreeLayers.
Require Import liblayers.logic.PTreeModules.
Require Export liblayers.logic.Semantics.
Require Import liblayers.logic.GlobalVars.

Local Existing Instance ptree_module_ops.
Local Existing Instance ptree_layer_ops.
Local Existing Instance ptree_module_prf.
Local Existing Instance ptree_layer_prf.
Local Transparent ptree_module ptree_module_ops.
Local Transparent ptree_layer ptree_layer_ops.
Local Opaque PTree.combine.

Local Hint Extern 1 (Sim _ (ptree_layer _ _)) =>
  eapply ptree_layer_sim_op : typeclass_instances.

(** * Preliminaries *)

(** We want to be able to use [PTree]-based layers to build up more
  complex kinds of layers, then use the code in this file to build a
  semantics operator with all the required properties for these more
  complex layers. To make this possible, we write our definitions in
  the context of an arbitrary kind of layers, and we make the
  connection with PTree layers explicit thanks to the following
  class. *)

Class PTreeSemanticsOps {layerdata simrel primsem V} layer
    `{layer_ops: LayerOps layerdata ident primsem V layer}
    `{primsem_sim_op: Sim layerdata simrel primsem}
    `{layer_sim_op: Sim layerdata simrel layer} :=
  {
    ptree_semof_inj D:
      ptree_layer primsem V D -> layer D
  }.

Class PTreeSemantics {layerdata simrel primsem V} layer
    `{ptree_semof_ops: PTreeSemanticsOps layerdata simrel primsem V layer}
    `{cat_ops: !CategoryOps layerdata simrel} :=
  {
    ptree_semof_primitives :>
      Primitives primsem;
    ptree_semof_layers :>
      Layers ident primsem V layer;
    ptree_semof_inj_sim :>
      Monotonic ptree_semof_inj (forallr R, sim R ++> sim R);
    get_ptree_semof_inj_primitive i D L:
      get_layer_primitive i (ptree_semof_inj D L) =
      get_layer_primitive i L;
    get_ptree_semof_inj_globalvar i D L:
      get_layer_globalvar i (ptree_semof_inj D L) =
      get_layer_globalvar i L;
    ptree_semof_inj_variable i D (τ: V):
      sim id (i ↦ τ) (ptree_semof_inj D (i ↦ τ));
    ptree_semof_inj_empty D:
      sim id (ptree_semof_inj D ∅) ∅;
    ptree_semof_wf D (L: layer D) (L': ptree_layer primsem V D):
      layer_wf L ->
      layer_wf (ptree_semof_inj D L' ⊕ L)
  }.

Global Instance ptree_semof_inj_sim_params:
  Params (@ptree_semof_inj) 2.

(** The trivial instance below can be used to obtain a semantics on
  [ptree_layer] itself. *)

Section PTREE_TRIVIAL_SEMANTICS.
  Local Instance ptree_semantics_trivial_ops {layerdata simrel primsem V}
      {gvar_ops: GlobalVarsOps V}
      `{PrimitiveOps layerdata primsem}
      `{primsem_sim_op: Sim layerdata simrel primsem}:
    PTreeSemanticsOps (ptree_layer primsem V) :=
    {
      ptree_semof_inj D L := L
    }.

  Local Instance ptree_semantics_trivial_prf {layerdata simrel primsem V}
      {gvar_ops: GlobalVarsOps V}
      `{Primitives layerdata simrel primsem}:
    PTreeSemantics (ptree_layer primsem V).
  Proof.
    split; try typeclasses eauto; simpl.
    - solve_monotonic.
    - reflexivity.
    - reflexivity.
    - reflexivity.
    - reflexivity.
    - tauto.
  Qed.
End PTREE_TRIVIAL_SEMANTICS.

Hint Extern 1 (PTreeSemanticsOps (ptree_layer _ _)) =>
  eapply ptree_semantics_trivial_ops : typeclass_instances.

Hint Extern 1 (PTreeSemantics (ptree_layer _ _)) =>
  eapply ptree_semantics_trivial_prf : typeclass_instances.

(** * Semantics of [ptree_module]s *)

Section PTREE_SEMANTICS.
  Context `{Hps: PTreeSemantics}.
  Context {F} `{Fops: !FunctionSemanticsOps _ F _ _ (ptree_module _ _) layer}.

  Definition ptree_semantics_mapdef D (M: ptree_module F V) L:
    ptree_layer _ _ D :=
      (PTree.map (fun i => Monad.bind (semof_fundef D (M, L) i)) (fst M),
       snd M).

  Definition ptree_semof_module D (M: ptree_module F V) L :=
    ptree_semof_inj D (ptree_semantics_mapdef D M L).

  Lemma ptree_get_semof_module_primitive {D} i M L:
    get_layer_primitive i (ptree_semof_module D M L) =
    semof_function D (M, L) i (get_module_function i M).
  Proof.
    simpl.
    unfold ptree_semof_module.
    rewrite get_ptree_semof_inj_primitive.
    simpl.
    unfold ptree_layer_primitive, ptree_semantics_mapdef; simpl.
    unfold semof_function, ptree_module_function; simpl.
    rewrite PTree.gmap.
    destruct ((fst M) ! i) as [[|]|]; reflexivity.
  Qed.

  Lemma ptree_get_semof_module_globalvar {D} i M L:
    get_layer_globalvar i (ptree_semof_module D M L) =
    get_module_variable i M.
  Proof.
    unfold ptree_semof_module.
    rewrite get_ptree_semof_inj_globalvar.
    reflexivity.
  Qed.

  Local Instance ptree_semof:
      SemanticsOps ident F primsem V (ptree_module F V) layer :=
    {
      lang_semof :=
        {|
          semof D ML :=
            let '(M, L) := ML in ptree_semof_module D M L ⊕ L
        |}
    }.

  (* We prove accessor lemmas separately, outside of the Semantics proof,
     so that they can be used to prove FunctionSemantics. *)

  Lemma ptree_get_semof_globalvar
        (D : layerdata) (i : ident) (M : ptree_module F V) (L : layer D):
    get_layer_globalvar i (〚 M 〛 L) =
    get_module_variable i M ⊕ get_layer_globalvar i L.
  Proof.
    simpl (semof _ _).
    get_layer_normalize.
    rewrite ptree_get_semof_module_globalvar.
    reflexivity.
  Qed.

  Lemma ptree_get_semof_primitive
        (D : layerdata) (i : ident) (M : ptree_module F V) (L : layer D):
    get_layer_primitive i (〚 M 〛 L) =
    semof_function D (M, L) i (get_module_function i M)
    ⊕ get_layer_primitive i L.
  Proof.
    simpl (semof _ _).
    get_layer_normalize.
    rewrite ptree_get_semof_module_primitive.
    reflexivity.
  Qed.

  Context `{HFops: !FunctionSemantics _ F _ _ (ptree_module _ _) layer}.

  Global Instance ptree_semantics_mapdef_rel:
    Monotonic
      ptree_semantics_mapdef
      (forallr R, rel_curry (module_layer_sim _ _ R ++> sim R)).
  Proof.
    unfold ptree_semantics_mapdef.
    intros D1 D2 R [M1 L1] [M2 L2] HML.
    inversion HML as [HM HL HL2 Hdisj]; subst.
    simpl.
    solve_monotonic.
  Qed.

  Global Instance ptree_semof_module_rel:
    Monotonic
      ptree_semof_module
      (forallr R, rel_curry (module_layer_sim _ _ R ++> sim R)).
  Proof.
    unfold ptree_semof_module.
    repeat rstep.
    destruct x, y.
    simpl.
    solve_monotonic.
  Qed.

  Global Instance ptree_semof_rel:
    Monotonic
      semof
      (forallr R, module_layer_sim _ _ R ++> sim R).
  Proof.
    simpl.
    repeat rstep.
    simpl (semof _ _) in *.
    apply hlub_intro; eauto.
    htransitivity (ptree_semof_inj v (ptree_semantics_mapdef v M2 L2)).
    - unfold ptree_semof_module.
      solve_monotonic.
      constructor; eauto.
    - apply left_upper_bound.
  Qed.

  Lemma ptree_semof_module_variable D i τ L:
    sim id (i ↦ τ) (ptree_semof_module D (i ↦ τ) L).
  Proof.
    unfold ptree_semof_module.
    htransitivity (ptree_semof_inj D (i ↦ τ)).
    - apply ptree_semof_inj_variable.
    - monotonicity.
      split.
      + intros j.
        simpl.
        rewrite PTree.gempty.
        constructor.
      + intros j.
        simpl.
        destruct (decide (j = i)) as [Hij | Hij].
        * subst.
          rewrite !PTree.gss; simpl.
          reflexivity.
        * rewrite !PTree.gso by assumption.
          reflexivity.
  Qed.

  Lemma ptree_semof_module_empty D L:
    sim id (ptree_semof_module D ∅ L) ∅.
  Proof.
    unfold ptree_semof_module.
    htransitivity (ptree_semof_inj D ∅).
    - reflexivity.
    - apply ptree_semof_inj_empty.
  Qed.

  Global Instance ptree_semof_prf:
    Semantics ident F primsem V (ptree_module F V) layer.
  Proof.
    split; try typeclasses eauto; simpl (semof _ _).
    - apply ptree_get_semof_globalvar.
    - apply ptree_get_semof_primitive.
    - intros D i M L.
      ehtransitivity.
      + eapply ptree_semof_module_variable.
      + apply left_upper_bound.
    - intros D M L.
      rewrite commutativity.
      apply left_upper_bound. (** XXX: should be able to use right_upper_bound *)
    - intros D L.
      apply hlub_intro.
      + etransitivity.
        * apply ptree_semof_module_empty.
        * apply lower_bound.
      + reflexivity.
    - intros D M L.
      apply ptree_semof_wf.
  Qed.
End PTREE_SEMANTICS.