Require Import oeuf.Common.
Require Import oeuf.Utopia.

Require Import oeuf.Metadata.
Require Import oeuf.Semantics.
Require Import oeuf.HighestValues.
Require Import oeuf.AllValues.
Require Import oeuf.OpaqueOps.
Require Import oeuf.ListLemmas.

Inductive expr :=
| Value (v : value)
| Arg
| UpVar (idx : nat)
| App (f : expr) (a : expr)
| MkConstr (ctor : constr_name) (args : list expr)
| MkClose (fname : nat) (free : list expr)
| Elim (ty : type_name) (cases : list expr) (target : expr)
| OpaqueOp (o : opaque_oper_name) (args : list expr)
.

Inductive is_value : expr -> Prop :=
| IsValue : forall v, is_value (Value v).

Inductive cont :=
| KAppL (e2 : expr) (l : list value) (k : cont)
| KAppR (e1 : expr) (l : list value) (k : cont)
| KConstr (ctor : constr_name) (vs : list expr) (es : list expr)
        (l : list value) (k : cont)
| KClose (fname : nat) (vs : list expr) (es : list expr)
        (l : list value) (k : cont)
| KElim (ty : type_name) (cases : list expr) (l : list value) (k : cont)
| KOpaqueOp (o : opaque_oper_name) (vs : list expr) (es : list expr)
        (l : list value) (k : cont)
| KStop
.

Inductive state :=
| Run (e : expr) (l : list value) (k : cont)
| Stop (v : value)
.

(* helper function for proceeding into a continuation *)
Definition run_cont (k : cont) : value -> state :=
    match k with
    | KAppL e2 l k => fun v => Run (App (Value v) e2) l k
    | KAppR e1 l k => fun v => Run (App e1 (Value v)) l k
    | KConstr ct vs es l k =>
            fun v => Run (MkConstr ct (vs ++ Value v :: es)) l k
    | KClose mb vs es l k =>
            fun v => Run (MkClose mb (vs ++ Value v :: es)) l k
    | KElim e cases l k =>
            fun v => Run (Elim e cases (Value v)) l k
    | KOpaqueOp o vs es l k =>
            fun v => Run (OpaqueOp o (vs ++ Value v :: es)) l k
    | KStop => fun v => Stop v
    end.

(* helper function for proceeding into an elim *)
Fixpoint unroll_elim' (case : expr)
                      (ctor : constr_name)
                      (args : list value)
                      (mk_rec : expr -> expr)
                      (idx : nat) : expr :=
    match args with
    | [] => case
    | arg :: args =>
            let case := App case (Value arg) in
            let case := if ctor_arg_is_recursive ctor idx
                then App case (mk_rec (Value arg)) else case in
            unroll_elim' case ctor args mk_rec (S idx)
    end.

Definition unroll_elim case ctor args mk_rec :=
    unroll_elim' case ctor args mk_rec 0.

(* the actual step relation *)
Inductive sstep (g : list expr) : state -> state -> Prop :=
| SValue : forall v (l : list value) (k : cont),
        sstep g (Run (Value v) l k)
                (run_cont k v)

| SArg : forall (l : list value) (k : cont) v,
        nth_error l 0 = Some v ->
        sstep g (Run (Arg) l k)
                (Run (Value v) l k)

| SUpVar : forall idx (l : list value) (k : cont) v,
        nth_error l (S idx) = Some v ->
        sstep g (Run (UpVar idx) l k)
                (Run (Value v) l k)

| SAppL : forall (e1 : expr) (e2 : expr) l k,
        ~ is_value e1 ->
        sstep g (Run (App e1 e2) l k)
                (Run e1 l (KAppL e2 l k))

| SAppR : forall (e1 : expr) (e2 : expr) l k,
        is_value e1 ->
        ~ is_value e2 ->
        sstep g (Run (App e1 e2) l k)
                (Run e2 l (KAppR e1 l k))

| SMakeCall : forall fname free arg l k body,
        nth_error g fname = Some body ->
        sstep g (Run (App (Value (Close fname free)) (Value arg)) l k)
                (Run body (arg :: free) k)

| SConstrStep : forall
            (ctor : constr_name)
            (vs : list expr)
            (e : expr)
            (es : list expr)
            l k,
        Forall is_value vs ->
        ~ is_value e ->
        sstep g (Run (MkConstr ctor (vs ++ e :: es)) l k)
                (Run e l (KConstr ctor vs es l k))

| SConstrDone : forall
            (ctor : constr_name)
            (vs : list value)
            l k,
        let es := map Value vs in
        sstep g (Run (MkConstr ctor es) l k)
                (Run (Value (Constr ctor vs)) l k)

| SCloseStep : forall
            (fname : nat)
            (vs : list expr)
            (e : expr)
            (es : list expr)
            l k,
        Forall is_value vs ->
        ~ is_value e ->
        sstep g (Run (MkClose fname (vs ++ e :: es)) l k)
                (Run e l (KClose fname vs es l k))

| SCloseDone : forall
            (fname : nat)
            (vs : list value)
            l k,
        let es := map Value vs in
        sstep g (Run (MkClose fname es) l k)
                (Run (Value (Close fname vs)) l k)

| SOpaqueOpStep : forall
            (o : opaque_oper_name)
            (vs : list expr)
            (e : expr)
            (es : list expr)
            l k,
        Forall is_value vs ->
        ~ is_value e ->
        sstep g (Run (OpaqueOp o (vs ++ e :: es)) l k)
                (Run e l (KOpaqueOp o vs es l k))

| SOpaqueOpDone : forall
            (o : opaque_oper_name)
            (vs : list value)
            (v' : value)
            l k,
        let es := map Value vs in
        opaque_oper_denote_highest o vs = Some v' ->
        sstep g (Run (OpaqueOp o es) l k)
                (Run (Value v') l k)

| SElimTarget : forall
            (ty : type_name)
            (cases : list expr)
            (target : expr)
            l k,
        ~ is_value target ->
        sstep g (Run (Elim ty cases target) l k)
                (Run target l (KElim ty cases l k))

| SEliminate : forall
            (ty : type_name)
            (cases : list expr)
            (ctor : constr_name)
            (args : list value)
            (case : expr)
            (result : expr)
            l k,
        is_ctor_for_type ty ctor ->
        constructor_arg_n ctor = length args ->
        nth_error cases (constructor_index ctor) = Some case ->
        unroll_elim case ctor args (Elim ty cases) = result ->
        sstep g (Run (Elim ty cases (Value (Constr ctor args))) l k)
                (Run result l k)
.

Definition expr_rect_mut (P : expr -> Type) (Pl : list expr -> Type)
    (HValue :   forall v, P (Value v))
    (HArg :     P Arg)
    (HUpVar :   forall idx, P (UpVar idx))
    (HApp :     forall f a, P f -> P a -> P (App f a))
    (HMkConstr : forall c args, Pl args -> P (MkConstr c args))
    (HMkClose : forall f free, Pl free -> P (MkClose f free))
    (HElim :    forall ty cases target, Pl cases -> P target -> P (Elim ty cases target))
    (HOpaqueOp : forall o args, Pl args -> P (OpaqueOp o args))
    (Hnil :     Pl [])
    (Hcons :    forall e es, P e -> Pl es -> Pl (e :: es))
    (e : expr) : P e :=
    let fix go e :=
        let fix go_list es :=
            match es as es_ return Pl es_ with
            | [] => Hnil
            | e :: es => Hcons e es (go e) (go_list es)
            end in
        match e as e_ return P e_ with
        | Value v => HValue v
        | Arg => HArg
        | UpVar idx => HUpVar idx
        | App f a => HApp f a (go f) (go a)
        | MkConstr c args => HMkConstr c args (go_list args)
        | MkClose f free => HMkClose f free (go_list free)
        | Elim ty cases target => HElim ty cases target (go_list cases) (go target)
        | OpaqueOp o args => HOpaqueOp o args (go_list args)
        end in go e.

Definition expr_rect_mut' (P : expr -> Type) (Pl : list expr -> Type)
    HValue HArg HUpVar HApp HMkConstr HMkClose HElim HOpaqueOp Hnil Hcons
    : (forall e, P e) * (forall es, Pl es) :=
    let go := expr_rect_mut P Pl
        HValue HArg HUpVar HApp HMkConstr HMkClose HElim HOpaqueOp Hnil Hcons
    in
    let fix go_list es :=
        match es as es_ return Pl es_ with
        | [] => Hnil
        | e :: es => Hcons e es (go e) (go_list es)
        end in
    (go, go_list).

(* semantics *)

Definition env := list expr.
Definition prog_type : Type := list expr * list metadata.
Definition val_level := VlHighest.
Definition valtype := value_type val_level.

Definition initial_env (prog : prog_type) : env := fst prog.

Inductive is_callstate (prog : prog_type) : valtype -> valtype -> state -> Prop :=
| IsCallstate : forall fname free av body,
        nth_error (fst prog) fname = Some body ->
        let fv := Close fname free in
        is_callstate prog fv av
            (Run body (av :: free) KStop).

Inductive final_state (prog : prog_type) : state -> valtype -> Prop :=
| FinalState : forall v,
        HighestValues.public_value (snd prog) v ->
        final_state prog (Stop v) v.

Definition semantics (prog : prog_type) : Semantics.semantics :=
  @Semantics_gen state env val_level
                 (is_callstate prog)
                 (sstep)
                 (final_state prog)
                 (initial_env prog).

Definition no_values : expr -> Prop :=
    let fix go e :=
        let fix go_list es :=
            match es with
            | [] => True
            | e :: es => go e /\ go_list es
            end in
        match e with
        | Value _ => False
        | Arg => True
        | UpVar _ => True
        | App f a => go f /\ go a
        | MkConstr _ args => go_list args
        | MkClose _ free => go_list free
        | Elim _ cases target => go_list cases /\ go target
        | OpaqueOp _ args => go_list args
        end in go.

Definition no_values_list : list expr -> Prop :=
    let go := no_values in
    let fix go_list es :=
        match es with
        | [] => True
        | e :: es => go e /\ go_list es
        end in go_list.

Ltac refold_no_values :=
    fold no_values_list in *.

Lemma no_values_list_is_Forall : forall es,
    no_values_list es <-> Forall no_values es.
induction es; simpl; split; inversion 1; constructor; firstorder eauto.
Qed.

Definition no_values_dec e : { no_values e } + { ~ no_values e }.
induction e using expr_rect_mut with
    (Pl := fun es => { no_values_list es } + { ~ no_values_list es });
simpl in *; refold_no_values;
try solve [ assumption | left; constructor | right; inversion 1 ].

- destruct IHe1; [ | right; inversion 1; intuition ].
  destruct IHe2; [ | right; inversion 1; intuition ].
  left. constructor; auto.

- destruct IHe; [ | right; inversion 1; intuition ].
  destruct IHe0; [ | right; inversion 1; intuition ].
  left. constructor; auto.

- destruct IHe; [ | right; inversion 1; intuition ].
  destruct IHe0; [ | right; inversion 1; intuition ].
  left. constructor; auto.
Defined.

Definition no_values_list_dec es : { no_values_list es } + { ~ no_values_list es }.
induction es.
- left. constructor.
- simpl; refold_no_values.  rename a into e.
  destruct (no_values_dec e); [ | right; intuition ].
  destruct IHes; [ | right; intuition ].
  left. auto.
Defined.

Definition cases_arent_values : expr -> Prop :=
    let fix go e :=
        let fix go_list es :=
            match es with
            | [] => True
            | e :: es => go e /\ go_list es
            end in
        match e with
        | Value _ => True
        | Arg => True
        | UpVar _ => True
        | App f a => go f /\ go a
        | MkConstr _ args => go_list args
        | MkClose _ free => go_list free
        | Elim _ cases target =>
                Forall (fun e => ~ is_value e) cases /\
                go_list cases /\ go target
        | OpaqueOp _ args => go_list args
        end in go.

Definition cases_arent_values_list : list expr -> Prop :=
    let go := cases_arent_values in
    let fix go_list es :=
        match es with
        | [] => True
        | e :: es => go e /\ go_list es
        end in go_list.

Ltac refold_cases_arent_values :=
    fold cases_arent_values_list in *.

Lemma cases_arent_values_list_is_Forall : forall es,
    cases_arent_values_list es <-> Forall cases_arent_values es.
induction es; simpl; split; inversion 1; constructor; firstorder eauto.
Qed.

Inductive cases_arent_values_cont : cont -> Prop :=
| CavkAppL : forall e2 l k,
        cases_arent_values e2 ->
        cases_arent_values_cont k ->
        cases_arent_values_cont (KAppL e2 l k)
| CavkAppR : forall e1 l k,
        cases_arent_values e1 ->
        cases_arent_values_cont k ->
        cases_arent_values_cont (KAppR e1 l k)
| CavkConstr : forall ctor vs es l k,
        Forall cases_arent_values vs ->
        Forall cases_arent_values es ->
        cases_arent_values_cont k ->
        cases_arent_values_cont (KConstr ctor vs es l k)
| CavkClose : forall fname vs es l k,
        Forall cases_arent_values vs ->
        Forall cases_arent_values es ->
        cases_arent_values_cont k ->
        cases_arent_values_cont (KClose fname vs es l k)
| CavkElim : forall ty cases l k,
        Forall (fun e => ~ is_value e) cases ->
        Forall cases_arent_values cases ->
        cases_arent_values_cont k ->
        cases_arent_values_cont (KElim ty cases l k)
| CavkOpaqueOp : forall op vs es l k,
        Forall cases_arent_values vs ->
        Forall cases_arent_values es ->
        cases_arent_values_cont k ->
        cases_arent_values_cont (KOpaqueOp op vs es l k)
| CavkStop : cases_arent_values_cont KStop
.

Inductive cases_arent_values_state : state -> Prop :=
| CavsRun : forall e l k,
        cases_arent_values e ->
        cases_arent_values_cont k ->
        cases_arent_values_state (Run e l k)
| CavsStop : forall v,
        cases_arent_values_state (Stop v)
.

Ltac i_ctor := intros; constructor; simpl; eauto.
Ltac i_lem H := intros; eapply H; simpl; eauto.

Lemma run_cont_cases_arent_values : forall k v,
    cases_arent_values_cont k ->
    cases_arent_values_state (run_cont k v).
induction k; intros0 Hcavk; invc Hcavk; i_ctor.
all: fold cases_arent_values_list.
all: rewrite cases_arent_values_list_is_Forall.

- i_lem Forall_app. i_ctor.
- i_lem Forall_app. i_ctor.
- eauto.
- i_lem Forall_app. i_ctor.
Qed.

Lemma unroll_elim'_cases_arent_values : forall case ctor args mk_rec idx,
    cases_arent_values case ->
    (forall e, cases_arent_values e -> cases_arent_values (mk_rec e)) ->
    cases_arent_values (unroll_elim' case ctor args mk_rec idx).
first_induction args; intros0 Hcase Hmk_rec; simpl; eauto.
- break_match.
  + i_lem IHargs. split; eauto. eapply Hmk_rec. i_ctor.
  + i_lem IHargs.
Qed.

Lemma unroll_elim_cases_arent_values : forall case ctor args mk_rec,
    cases_arent_values case ->
    (forall e, cases_arent_values e -> cases_arent_values (mk_rec e)) ->
    cases_arent_values (unroll_elim case ctor args mk_rec).
intros. i_lem unroll_elim'_cases_arent_values.
Qed.

Lemma step_cases_arent_values : forall E s s',
    Forall cases_arent_values E ->
    cases_arent_values_state s ->
    sstep E s s' ->
    cases_arent_values_state s'.
intros0 Henv Hcases Hstep; invc Hstep; invc Hcases;
simpl in *; refold_cases_arent_values.
all: repeat break_and; try solve [repeat i_ctor].
all: try rewrite cases_arent_values_list_is_Forall in *.

- i_lem run_cont_cases_arent_values.
- i_ctor. i_lem Forall_nth_error.
- on _, invc_using Forall_3part_inv. i_ctor. i_ctor.
- on _, invc_using Forall_3part_inv. i_ctor. i_ctor.
- on _, invc_using Forall_3part_inv. i_ctor. i_ctor.
- i_ctor. i_ctor.
- i_ctor. i_lem unroll_elim_cases_arent_values; refold_cases_arent_values.
  + i_lem Forall_nth_error.
  + intros; split; eauto. split; eauto.
    rewrite cases_arent_values_list_is_Forall. auto.
Qed.

Lemma no_values_not_value : forall e,
    no_values e ->
    ~ is_value e.
intros. inversion 1. subst. simpl in *. auto.
Qed.

Lemma no_values_not_value_list : forall es,
    Forall no_values es ->
    Forall (fun e => ~ is_value e) es.
induction es; intros; simpl in *; eauto.
on >Forall, invc. eauto using no_values_not_value.
Qed.

Lemma no_values_cases_arent_values : forall e,
    no_values e ->
    cases_arent_values e.
induction e using expr_rect_mut with
    (Pl := fun e =>
        Forall no_values e ->
        Forall cases_arent_values e);
simpl; intros0 Hnv; refold_no_values; refold_cases_arent_values.
all: repeat break_and.
all: try rewrite no_values_list_is_Forall in *;
     try rewrite cases_arent_values_list_is_Forall in *.
all: eauto.

- split; eauto. i_lem no_values_not_value_list.

- on >Forall, invc. i_ctor.
Qed.

Lemma no_values_cases_arent_values_list : forall es,
    Forall no_values es ->
    Forall cases_arent_values es.
induction es; intros; simpl in *; eauto.
on >Forall, invc. eauto using no_values_cases_arent_values.
Qed.


(* Sanity theorems for ett. *)

Require config.
Require Import config_tactics.

Require Import syntax.
Require Import tt.

Require ptt.
Require ptt_sanity.
Require Import ett.
Require Import ett2ptt ptt2ett.
Require Import inversion.

Section EttSanity.

Context `{configReflection : config.Reflection}.
Context `{configBinaryProdType : config.BinaryProdType}.
Context `{configProdEta : config.ProdEta}.
Context `{configUniverses : config.Universes}.
Context `{configPropType : config.PropType}.
Context `{configIdType : config.IdType}.
Context `{configIdEliminator : config.IdEliminator}.
Context `{configEmptyType : config.EmptyType}.
Context `{configUnitType : config.UnitType}.
Context `{configBoolType : config.BoolType}.
Context `{configProdType : config.ProdType}.
Context `{configSyntax : syntax.Syntax}.

Existing Instance ptt.havePrecondition.
Context {haveCtxExtendInversion : HaveCtxExtendInversion}.
Context {haveTyIdInversion : HaveTyIdInversion}.
Context {haveTyProdInversion : HaveTyProdInversion}.
Context {haveTyBinaryProdInversion : HaveTyBinaryProdInversion}.

Theorem sane_issubst sbs G D :
  issubst sbs G D -> isctx G * isctx D.
Proof.
  intro h. split
  ; now apply ptt2ett.sane_isctx,
              (ptt_sanity.sane_issubst sbs G D),
              ett2ptt.sane_issubst.
Defined.

Theorem sane_istype G A :
  istype G A -> isctx G.
Proof.
  intro h.
  now apply ptt2ett.sane_isctx,
            (ptt_sanity.sane_istype G A),
            ett2ptt.sane_istype.
Defined.

Theorem sane_isterm G u A :
  isterm G u A -> isctx G * istype G A.
Proof.
  intro h. split.
  - now apply ptt2ett.sane_isctx,
              (ptt_sanity.sane_isterm G u A),
              ett2ptt.sane_isterm.
  - now apply ptt2ett.sane_istype,
              (ptt_sanity.sane_isterm G u A),
              ett2ptt.sane_isterm.
Defined.

Theorem sane_eqctx G D :
  eqctx G D -> isctx G * isctx D.
Proof.
  intro h. split
  ; now apply ptt2ett.sane_isctx,
              (ptt_sanity.sane_eqctx G D),
              ett2ptt.sane_eqctx.
Defined.

Theorem sane_eqtype G A B :
  eqtype G A B -> isctx G * istype G A * istype G B.
Proof.
  intro h.
  (repeat split)
  ; [ apply ptt2ett.sane_isctx | apply ptt2ett.sane_istype .. ]
  ; now apply (ptt_sanity.sane_eqtype G A B),
              ett2ptt.sane_eqtype.
Defined.

Theorem sane_eqsubst sbs sbt G D :
  eqsubst sbs sbt G D -> isctx G * isctx D * issubst sbs G D * issubst sbt G D.
Proof.
  intro h.
  (repeat split)
  ; [ apply ptt2ett.sane_isctx
    | apply ptt2ett.sane_isctx
    | apply ptt2ett.sane_issubst
    | apply ptt2ett.sane_issubst
    ]
  ; now apply (ptt_sanity.sane_eqsubst sbs sbt G D),
              ett2ptt.sane_eqsubst.
Defined.

Theorem sane_eqterm G u v A :
  eqterm G u v A -> isctx G * istype G A * isterm G u A * isterm G v A.
Proof.
  intro h.
  (repeat split)
  ; [ apply ptt2ett.sane_isctx
    | apply ptt2ett.sane_istype
    | apply ptt2ett.sane_isterm ..
    ]
  ; now apply (ptt_sanity.sane_eqterm G u v A),
              ett2ptt.sane_eqterm.
Defined.

End EttSanity.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime Eprimeprime A B C Bprime : Universe, ((wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ B O /\ (wd_ A O /\ (wd_ C O /\ (wd_ O Eprimeprime /\ (wd_ E Eprimeprime /\ (wd_ B E /\ (wd_ A E /\ (wd_ Bprime O /\ (wd_ Eprime Eprimeprime /\ (wd_ Eprimeprime A /\ (wd_ Eprime A /\ (wd_ Eprime Bprime /\ (wd_ Eprime C /\ (wd_ A Bprime /\ (wd_ A C /\ (wd_ Bprime C /\ (wd_ E Bprime /\ (wd_ Eprime B /\ (wd_ B Bprime /\ (wd_ B Eprimeprime /\ (wd_ Bprime Eprimeprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O Eprime Bprime /\ (col_ O Eprimeprime Bprime /\ col_ E Eprime Eprimeprime))))))))))))))))))))))))))))) -> col_ B Bprime Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(**************************************************************************)
(*                                                                        *)
(*     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 PArray List Bool.
(* Add LoadPath ".." as SMTCoq. *)
Require Import Misc State SMT_terms.

Import Form.

Local Open Scope array_scope.
Local Open Scope int31_scope.

Set Implicit Arguments.
Unset Strict Implicit.

Definition or_of_imp args :=
  let last := PArray.length args - 1 in
  PArray.mapi (fun i l => if i == last then l else Lit.neg l) args.
Register or_of_imp as PrimInline.

Lemma length_or_of_imp : forall args,
  PArray.length (or_of_imp args) = PArray.length args.
Proof. intro; apply length_mapi. Qed.

Lemma get_or_of_imp : forall args i,
  i < (PArray.length args) - 1 -> (or_of_imp args).[i] = Lit.neg (args.[i]).
Proof.
  unfold or_of_imp; intros args i H; case_eq (0 < PArray.length args).
  intro Heq; rewrite get_mapi.
  replace (i == PArray.length args - 1) with false; auto; symmetry; rewrite eqb_false_spec; intro; subst i; unfold is_true in H; rewrite ltb_spec, (to_Z_sub_1 _ _ Heq) in H; omega.
  rewrite ltb_spec; unfold is_true in H; rewrite ltb_spec, (to_Z_sub_1 _ _ Heq) in H; omega.
  rewrite ltb_negb_geb; case_eq (PArray.length args <= 0); try discriminate; intros Heq _; assert (H1: PArray.length args = 0).
  apply to_Z_inj; rewrite leb_spec in Heq; destruct (to_Z_bounded (PArray.length args)) as [H1 _]; change [|0|] with 0%Z in *; omega.
  rewrite !get_outofbound.
  rewrite default_mapi, H1; auto.
  rewrite H1; case_eq (i < 0); auto; intro H2; eelim ltb_0; eassumption.
  rewrite length_mapi, H1; case_eq (i < 0); auto; intro H2; eelim ltb_0; eassumption.
Qed.

Lemma get_or_of_imp2 : forall args i, 0 < PArray.length args ->
  i = (PArray.length args) - 1 -> (or_of_imp args).[i] = args.[i].
Proof.
  unfold or_of_imp; intros args i Heq Hi; rewrite get_mapi; subst i.
  rewrite Int31Axioms.eqb_refl; auto.
  rewrite ltb_spec, (to_Z_sub_1 _ _ Heq); omega.
Qed.

Section CHECKER.

  Variable t_form : PArray.array form.
  Local Notation get_hash := (PArray.get t_form) (only parsing).
  Variable s : S.t.

  (*  * true             : {true}  *)

  Definition check_True := C._true.

  (* * false             : {(not false)} *)

  Definition check_False  := Lit.neg (Lit._false)::nil.

  (* * and_neg          : {(and a_1 ... a_n) (not a_1) ... (not a_n)}
     * or_pos           : {(not (or a_1 ... a_n)) a_1 ... a_n}
     * implies_pos      : {(not (implies a b)) (not a) b}
     * xor_pos1         : {(not (xor a b)) a b}
     * xor_neg1         : {(xor a b) a (not b)}
     * equiv_pos1       : {(not (iff a b)) a (not b)}
     * equiv_neg1       : {(iff a b) (not a) (not b)}
     * ite_pos1         : {(not (if_then_else a b c)) a c}
     * ite_neg1         : {(if_then_else a b c) a (not c)} *)

  Definition check_BuildDef l :=
    match get_hash (Lit.blit l) with
    | Fand args =>
      if Lit.is_pos l then l :: List.map Lit.neg (PArray.to_list args)
      else C._true
    | For args =>
      if Lit.is_pos l then C._true
      else l :: PArray.to_list args
    | Fimp args =>
      if Lit.is_pos l then C._true
      else
        let args := or_of_imp args in
        l :: PArray.to_list args
    | Fxor a b =>
      if Lit.is_pos l then l::a::Lit.neg b::nil
      else l::a::b::nil
    | Fiff a b =>
      if Lit.is_pos l then l::Lit.neg a::Lit.neg b::nil
      else l::a::Lit.neg b::nil
    | Fite a b c =>
      if Lit.is_pos l then l::a::Lit.neg c::nil
      else l::a::c::nil
    | _ => C._true
    end.

  (* * not_and           : {(not (and a_1 ... a_n))} --> {(not a_1) ... (not a_n)}
     * or                : {(or a_1 ... a_n)} --> {a_1 ... a_n}
     * implies           : {(implies a b)} --> {(not a) b}
     * xor1              : {(xor a b)} --> {a b}
     * not_xor1          : {(not (xor a b))} --> {a (not b)}
     * equiv2            : {(iff a b)} --> {a (not b)}
     * not_equiv2        : {(not (iff a b))} --> {(not a) (not b)}
     * ite1              : {(if_then_else a b c)} --> {a c}
     * not_ite1          : {(not (if_then_else a b c))} --> {a (not c)} *)

  Definition check_ImmBuildDef pos :=
    match S.get s pos with
    | l::nil =>
      match get_hash (Lit.blit l) with
      | Fand args =>
        if Lit.is_pos l then C._true
        else List.map Lit.neg (PArray.to_list args)
      | For args =>
        if Lit.is_pos l then PArray.to_list args
        else C._true
      | Fimp args =>
        if Lit.is_pos l then
          let args := or_of_imp args in
          PArray.to_list args
        else C._true
      | Fxor a b =>
        if Lit.is_pos l then a::b::nil
        else a::Lit.neg b::nil
      | Fiff a b =>
        if Lit.is_pos l then a::Lit.neg b::nil
        else Lit.neg a::Lit.neg b::nil
      | Fite a b c =>
        if Lit.is_pos l then a::c::nil
        else a::Lit.neg c::nil
      | _ => C._true
      end
    | _ => C._true
    end.

  (* * xor_pos2          : {(not (xor a b)) (not a) (not b)}
     * xor_neg2          : {(xor a b) (not a) b}
     * equiv_pos2        : {(not (iff a b)) (not a) b}
     * equiv_neg2        : {(iff a b) a b}
     * ite_pos2          : {(not (if_then_else a b c)) (not a) b}
     * ite_neg2          : {(if_then_else a b c) (not a) (not b)} *)

  Definition check_BuildDef2 l :=
    match get_hash (Lit.blit l) with
    | Fxor a b =>
      if Lit.is_pos l then l::Lit.neg a::b::nil
      else l::Lit.neg a::Lit.neg b::nil
    | Fiff a b =>
      if Lit.is_pos l then l::a::b::nil
      else l::Lit.neg a::b::nil
    | Fite a b c =>
      if Lit.is_pos l then l::Lit.neg a::Lit.neg b::nil
      else l::Lit.neg a::b::nil
    | _ => C._true
    end.

  (* * xor2              : {(xor a b)} --> {(not a) (not b)}
     * not_xor2          : {(not (xor a b))} --> {(not a) b}
     * equiv1            : {(iff a b)} --> {(not a) b}
     * not_equiv1        : {(not (iff a b))} --> {a b}
     * ite2              : {(if_then_else a b c)} --> {(not a) b}
     * not_ite2          : {(not (if_then_else a b c))} --> {(not a) (not b)}
     *)

  Definition check_ImmBuildDef2 pos :=
    match S.get s pos with
    | l::nil =>
      match get_hash (Lit.blit l) with
      | Fxor a b =>
        if Lit.is_pos l then Lit.neg a::Lit.neg b::nil
        else Lit.neg a::b::nil
      | Fiff a b =>
        if Lit.is_pos l then Lit.neg a::b::nil
        else a::b::nil
      | Fite a b c =>
        if Lit.is_pos l then Lit.neg a::b::nil
        else Lit.neg a::Lit.neg b::nil
      | _ => C._true
      end
    | _ => C._true
    end.

  (* * or_neg           : {(or a_1 ... a_n) (not a_i)}
     * and_pos          : {(not (and a_1 ... a_n)) a_i}
     * implies_neg1     : {(implies a b) a}
     * implies_neg2     : {(implies a b) (not b)} *)

  Definition check_BuildProj l i :=
    let x := Lit.blit l in
    match get_hash x with
    | For args =>
      if i < PArray.length args then Lit.lit x::Lit.neg (args.[i])::nil
      else C._true
    | Fand args =>
      if i < PArray.length args then Lit.nlit x::(args.[i])::nil
      else C._true
    | Fimp args =>
      let len := PArray.length args in
      if i < len then
        if i == len - 1 then Lit.lit x::Lit.neg (args.[i])::nil
        else Lit.lit x::(args.[i])::nil
      else C._true
    | _ => C._true
    end.

  (* * and               : {(and a_1 ... a_n)} --> {a_i}
     * not_or            : {(not (or a_1 ... a_n))} --> {(not a_i)}
     * not_implies1      : {(not (implies a b))} --> {a}
     * not_implies2      : {(not (implies a b))} --> {(not b)} *)

  Definition check_ImmBuildProj pos i :=
    match S.get s pos with
    | l::nil =>
      let x := Lit.blit l in
      match get_hash x with
      | For args =>
        if (i < PArray.length args) && negb (Lit.is_pos l) then Lit.neg (args.[i])::nil
        else C._true
      | Fand args =>
        if (i < PArray.length args) && (Lit.is_pos l) then (args.[i])::nil
        else C._true
      | Fimp args =>
        let len := PArray.length args in
        if (i < len) && negb (Lit.is_pos l) then
          if i == len - 1 then Lit.neg (args.[i])::nil
          else (args.[i])::nil
        else C._true
      | _ => C._true
      end
    | _ => C._true
    end.

  (** The correctness proofs *)

  Variable interp_atom : atom -> bool.

  Hypothesis Hch_f : check_form t_form.

  Local Notation rho := (Form.interp_state_var interp_atom t_form).

  Let Hwfrho : Valuation.wf rho.
  Proof.
    destruct (check_form_correct interp_atom _ Hch_f) as (_, H);exact H.
  Qed.

  Lemma valid_check_True : C.valid rho check_True.
  Proof.
    apply C.interp_true;trivial.
  Qed.

  Lemma valid_check_False : C.valid rho check_False.
  Proof.
    unfold check_False, C.valid;simpl.
    rewrite Lit.interp_neg.
    assert (W:= Lit.interp_false _ Hwfrho).
    destruct (Lit.interp rho Lit._false);trivial;elim W;red;trivial.
  Qed.

  Let rho_interp : forall x : int,
    rho x = interp interp_atom t_form (t_form.[ x]).
  Proof.
    destruct (check_form_correct interp_atom _ Hch_f) as ((H,H0), _).
    intros x;apply wf_interp_form;trivial.
  Qed.

  Ltac tauto_check :=
   try (rewrite !Lit.interp_neg);
   repeat
     match goal with |- context [Lit.interp rho ?x] =>
     destruct (Lit.interp rho x);trivial end.

  Lemma afold_left_and a :
    afold_left bool int true andb (Lit.interp rho) a =
    List.forallb (Lit.interp rho) (to_list a).
  Proof.
    case_eq (afold_left bool int true andb (Lit.interp rho) a); intro H; symmetry.
      assert (H1:=afold_left_andb_true_inv _ _ _ H); clear H. rewrite forallb_forall. intros i H. apply In_to_list in H. destruct H as [j [H2 H3]]. subst. apply H1. auto.
      apply afold_left_andb_false_inv in H. destruct H as [i [H H1]]. case_eq (forallb (Lit.interp rho) (to_list a)); auto. rewrite forallb_forall. intro H2. rewrite <- H1. symmetry. auto using to_list_In.
  Qed.

  Lemma afold_left_or a :
    afold_left bool int false orb (Lit.interp rho) a =
    C.interp rho (to_list a).
  Proof.
    case_eq (afold_left bool int false orb (Lit.interp rho) a); intro H; symmetry.
      apply afold_left_orb_true_inv in H. destruct H as [i [H H1]]. unfold C.interp. rewrite existsb_exists. exists (a.[i]); split; auto using to_list_In.
      assert (H1:=afold_left_orb_false_inv _ _ _ H); clear H. unfold C.interp. case_eq (existsb (Lit.interp rho) (to_list a)); auto. rewrite existsb_exists. intros [x [H H2]]. apply In_to_list in H. destruct H as [i [H H3]]. subst. rewrite <- H2. auto.
  Qed.

  Lemma afold_right_impb a :
    (afold_right bool int false implb (Lit.interp rho) a) =
    C.interp rho (to_list (or_of_imp a)).
  Proof.
    case_eq (afold_right bool int false implb (Lit.interp rho) a); intro H; symmetry.
      apply afold_right_implb_true_inv in H. destruct H as [H [[i [H1 H2]]|H1]].
        unfold C.interp. rewrite existsb_exists. exists (Lit.neg (a.[i])). split.
          apply (to_list_In2 i).
            rewrite length_or_of_imp, ltb_spec. rewrite ltb_spec, (to_Z_sub_1 _ 0) in H1; auto. omega.
            unfold or_of_imp. rewrite get_mapi.
              replace (i == PArray.length a - 1) with false; auto. symmetry. rewrite eqb_false_spec. intro H3. rewrite <- H3 in H1. apply (not_ltb_refl i). auto.
              rewrite ltb_spec. rewrite ltb_spec, (to_Z_sub_1 _ 0) in H1; auto. omega.
          rewrite Lit.interp_neg, H2; auto.
        unfold C.interp. rewrite existsb_exists. exists (a.[PArray.length a - 1]). split.
          apply (to_list_In2 (PArray.length a - 1)).
            rewrite length_or_of_imp, ltb_spec, (to_Z_sub_1 _ 0); auto. omega.
            unfold or_of_imp. rewrite get_mapi.
              rewrite Int31Axioms.eqb_refl. auto.
              rewrite ltb_spec, (to_Z_sub_1 _ 0); auto. omega.
          apply H1. rewrite ltb_spec, (to_Z_sub_1 _ 0); auto. omega.
      apply afold_right_implb_false_inv in H. destruct H as [H|[H H1]].
        unfold C.interp. case_eq (existsb (Lit.interp rho) (to_list (or_of_imp a))); auto. rewrite existsb_exists. intros [x [H1 H2]]. apply In_to_list in H1. destruct H1 as [i [H1 _]]. rewrite length_or_of_imp, <- H in H1. eelim ltb_0; eauto.
        unfold C.interp. case_eq (existsb (Lit.interp rho) (to_list (or_of_imp a))); auto. rewrite existsb_exists. intros [x [H2 H3]]. apply In_to_list in H2. destruct H2 as [i [H2 H4]]. subst. unfold or_of_imp in H3. rewrite get_mapi in H3.
          case_eq (i == PArray.length a - 1); intro H4; rewrite H4 in H3.
            rewrite eqb_spec in H4. subst. rewrite <- H3. auto.
            rewrite Lit.interp_neg in H3. rewrite eqb_false_spec in H4. rewrite H in H3; try discriminate. case_eq (PArray.length a == 0).
              rewrite eqb_spec. intro H5. rewrite length_or_of_imp, H5 in H2. eelim ltb_0; eauto.
              rewrite eqb_false_spec. intro H5. rewrite ltb_spec, to_Z_sub_1_diff; auto. assert (H6:[|i|] <> ([|PArray.length a|] - 1)%Z).
                intro H6. apply H4, to_Z_inj. rewrite to_Z_sub_1_diff; auto.
                rewrite length_or_of_imp, ltb_spec in H2. omega.
          rewrite length_or_of_imp in H2; auto.
  Qed.

  Lemma Cinterp_neg cl :
     C.interp rho (map Lit.neg cl) = negb (forallb (Lit.interp rho) cl).
  Proof.
    unfold C.interp. case_eq (forallb (Lit.interp rho) cl); simpl.
      rewrite forallb_forall. intro H. case_eq (existsb (Lit.interp rho) (map Lit.neg cl)); auto. rewrite existsb_exists. intros [l [H1 H2]]. rewrite in_map_iff in H1. destruct H1 as [x [H1 H3]]. subst l. rewrite <- H2, Lit.interp_neg, H; auto.
      rewrite existsb_exists. induction cl as [ |l cl IHcl]; simpl; try discriminate.
      rewrite andb_false_iff. intros [H|H].
        exists (Lit.neg l). intuition. rewrite Lit.interp_neg, H. auto.
        destruct (IHcl H) as [x [H1 H2]]. exists x; auto.
  Qed.

  Lemma valid_check_BuildDef : forall l, C.valid rho (check_BuildDef l).
  Proof.
   unfold check_BuildDef,C.valid;intros l.
   case_eq (t_form.[Lit.blit l]);intros;auto using C.interp_true;
   case_eq (Lit.is_pos l);intros Heq;auto using C.interp_true;simpl;
   unfold Lit.interp at 1;rewrite Heq;unfold Var.interp; rewrite rho_interp, H;simpl;
   tauto_check.
   rewrite afold_left_and, Cinterp_neg;apply orb_negb_r.
   rewrite afold_left_or, orb_comm;apply orb_negb_r.
   rewrite afold_right_impb, orb_comm;apply orb_negb_r.
  Qed.

  Lemma valid_check_BuildDef2 : forall l, C.valid rho (check_BuildDef2 l).
  Proof.
   unfold check_BuildDef2,C.valid;intros l.
   case_eq (t_form.[Lit.blit l]);intros;auto using C.interp_true;
   case_eq (Lit.is_pos l);intros Heq;auto using C.interp_true;simpl;
   unfold Lit.interp at 1;rewrite Heq;unfold Var.interp; rewrite rho_interp, H;simpl;
   tauto_check.
  Qed.

  Lemma valid_check_BuildProj : forall l i, C.valid rho (check_BuildProj l i).
  Proof.
   unfold check_BuildProj,C.valid;intros l i.
   case_eq (t_form.[Lit.blit l]);intros;auto using C.interp_true;
   case_eq (i < PArray.length a);intros Hlt;auto using C.interp_true;simpl.

   rewrite Lit.interp_nlit;unfold Var.interp;rewrite rho_interp, orb_false_r, H.
   simpl;rewrite afold_left_and.
   case_eq (forallb (Lit.interp rho) (to_list a));trivial.
   rewrite forallb_forall;intros Heq;rewrite Heq;trivial.
   apply to_list_In; auto.
   rewrite Lit.interp_lit;unfold Var.interp;rewrite rho_interp, orb_false_r, H.
   simpl;rewrite afold_left_or.

   unfold C.interp;case_eq (existsb (Lit.interp rho) (to_list a));trivial.
   rewrite <-not_true_iff_false, existsb_exists, Lit.interp_neg.
   case_eq (Lit.interp rho (a .[ i]));trivial.
   intros Heq Hex;elim Hex;exists (a.[i]);split;trivial.
   apply to_list_In; auto.
   case_eq (i == PArray.length a - 1);intros Heq;simpl;
   rewrite Lit.interp_lit;unfold Var.interp;rewrite rho_interp, H;simpl;
   rewrite afold_right_impb; case_eq (C.interp rho (to_list (or_of_imp a)));trivial;
   unfold C.interp;rewrite <-not_true_iff_false, existsb_exists;
   try rewrite Lit.interp_neg; case_eq (Lit.interp rho (a .[ i]));trivial;
   intros Heq' Hex;elim Hex.
   exists (a.[i]);split;trivial.
   assert (H1: 0 < PArray.length a) by (apply (leb_ltb_trans _ i _); auto; apply leb_0); rewrite Int31Properties.eqb_spec in Heq; rewrite <- (get_or_of_imp2 H1 Heq); apply to_list_In; rewrite length_or_of_imp; auto.
   exists (Lit.neg (a.[i]));rewrite Lit.interp_neg, Heq';split;trivial.
   assert (H1: i < PArray.length a - 1 = true) by (rewrite ltb_spec, (to_Z_sub_1 _ _ Hlt); rewrite eqb_false_spec in Heq; assert (H1: [|i|] <> ([|PArray.length a|] - 1)%Z) by (intro H1; apply Heq, to_Z_inj; rewrite (to_Z_sub_1 _ _ Hlt); auto); rewrite ltb_spec in Hlt; omega); rewrite <- (get_or_of_imp H1); apply to_list_In; rewrite length_or_of_imp; auto.
  Qed.

  Hypothesis Hs : S.valid rho s.

  Lemma valid_check_ImmBuildDef : forall cid,
     C.valid rho (check_ImmBuildDef cid).
  Proof.
   unfold check_ImmBuildDef,C.valid;intros cid.
   generalize (Hs cid);unfold C.valid.
   destruct (S.get s cid) as [ | l [ | _l _c]];auto using C.interp_true.
   simpl;unfold Lit.interp, Var.interp; rewrite !rho_interp;
   destruct (t_form.[Lit.blit l]);auto using C.interp_true;
   case_eq (Lit.is_pos l);intros Heq;auto using C.interp_true;simpl;
   tauto_check.
   rewrite afold_left_and, Cinterp_neg, orb_false_r;trivial.
   rewrite afold_left_or, orb_false_r;trivial.
   rewrite afold_right_impb, orb_false_r;trivial.
  Qed.

  Lemma valid_check_ImmBuildDef2 : forall cid, C.valid rho (check_ImmBuildDef2 cid).
  Proof.
    unfold check_ImmBuildDef2,C.valid;intros cid.
    generalize (Hs cid);unfold C.valid.
    destruct (S.get s cid) as [ | l [ | _l _c]];auto using C.interp_true.
    simpl;unfold Lit.interp, Var.interp; rewrite !rho_interp;
    destruct (t_form.[Lit.blit l]);auto using C.interp_true;
    case_eq (Lit.is_pos l);intros Heq;auto using C.interp_true;simpl;
    tauto_check.
  Qed.

  Lemma valid_check_ImmBuildProj : forall cid i, C.valid rho (check_ImmBuildProj cid i).
  Proof.
   unfold check_ImmBuildProj,C.valid;intros cid i.
   generalize (Hs cid);unfold C.valid.
   destruct (S.get s cid) as [ | l [ | _l _c]];auto using C.interp_true.
   simpl;unfold Lit.interp, Var.interp; rewrite !rho_interp;
     destruct (t_form.[Lit.blit l]);auto using C.interp_true;
       case_eq (i < PArray.length a); intros Hlt;auto using C.interp_true;
       case_eq (Lit.is_pos l);intros Heq;auto using C.interp_true;simpl;
       rewrite !orb_false_r.
   rewrite afold_left_and.
   rewrite forallb_forall;intros H;apply H;auto.
   apply to_list_In; auto.
   rewrite negb_true_iff, <-not_true_iff_false, afold_left_or.
   unfold C.interp;rewrite existsb_exists, Lit.interp_neg.
   case_eq (Lit.interp rho (a .[ i]));trivial.
   intros Heq' Hex;elim Hex;exists (a.[i]);split;trivial.
   apply to_list_In; auto.
   rewrite negb_true_iff, <-not_true_iff_false, afold_right_impb.
   case_eq (i == PArray.length a - 1);intros Heq';simpl;
     unfold C.interp;simpl;try rewrite Lit.interp_neg;rewrite orb_false_r,
   existsb_exists;case_eq (Lit.interp rho (a .[ i]));trivial;
   intros Heq2 Hex;elim Hex.
   exists (a.[i]);split;trivial.
   assert (H1: 0 < PArray.length a) by (apply (leb_ltb_trans _ i _); auto; apply leb_0); rewrite Int31Properties.eqb_spec in Heq'; rewrite <- (get_or_of_imp2 H1 Heq'); apply to_list_In; rewrite length_or_of_imp; auto.
   exists (Lit.neg (a.[i]));rewrite Lit.interp_neg, Heq2;split;trivial.
   assert (H1: i < PArray.length a - 1 = true) by (rewrite ltb_spec, (to_Z_sub_1 _ _ Hlt); rewrite eqb_false_spec in Heq'; assert (H1: [|i|] <> ([|PArray.length a|] - 1)%Z) by (intro H1; apply Heq', to_Z_inj; rewrite (to_Z_sub_1 _ _ Hlt); auto); rewrite ltb_spec in Hlt; omega); rewrite <- (get_or_of_imp H1); apply to_list_In; rewrite length_or_of_imp; auto.
  Qed.

End CHECKER.

Unset Implicit Arguments.


(** * Autosubst wrapper for ssreflect *)
Require Export Autosubst.Autosubst_Basics.
Require Export Autosubst.Autosubst_MMap.
Require Export Autosubst.Autosubst_Classes.
Require Export Autosubst.Autosubst_Tactics.
Require Export Autosubst.Autosubst_Lemmas.
Require Export Autosubst.Autosubst_Derive.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.
From Coq Require Import ssrfun.

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

Section MMapInstances.

Variable (A B C : Type).
Variable (MMap_A_B : MMap A B).
Variable (MMap_A_C : MMap A C).
Variable (MMapLemmas_A_B : MMapLemmas A B).
Variable (MMapLemmas_A_C : MMapLemmas A C).
Variable (MMapExt_A_B : MMapExt A B).
Variable (MMapExt_A_C : MMapExt A C).

Global Instance MMap_option : MMap A (option B) := fun f => omap (mmap f).
Global Instance MMapLemmas_option : MMapLemmas A (option B). derive. Qed.
Global Instance MMapExt_option : MMapExt A (option B). derive. Defined.

Global Instance MMap_pair : MMap A (B * C). derive. Defined.
Global Instance MMapLemmas_pair : MMapLemmas A (B * C). derive. Qed.
Global Instance MMapExt_pair : MMapExt A (B * C). derive. Defined.

Global Instance mmap_seq : MMap A (seq B) := fun f => map (mmap f).
Global Instance mmapLemmas_seq : MMapLemmas A (seq B). derive. Qed.
Global Instance mmapExt_seq : MMapExt A (seq B). derive. Defined.

Global Instance MMap_fun : MMap A (B -> C) := fun f g x => mmap f (g x).

Global Instance MMapLemmas_fun : MMapLemmas A (B -> C).
Proof.
  constructor; intros; f_ext; intros; [apply mmap_id|apply mmap_comp].
Qed.

Global Instance MMapExt_fun : MMapExt A (B -> C).
Proof.
  hnf. intros f g H h. f_ext. intro x. apply mmap_ext. exact H.
Defined.

End MMapInstances.


(* Author: Masaki Hara, 2014 *)
(* Linear Logic Toy for Coq *)
Require Import LWeight LType_base LGoal.

(*************************************************)
(*       Conjunctive Exponential Modality        *)
(*************************************************)

Record LOfcourseVal{E:LEnv} (A:LType) := {
  lofcourseval : ltype A;
  lofcourseval_nil : lweight lofcourseval = 0%LWeight
}.
Arguments LOfcourseVal [E] A%LL.
Arguments Build_LOfcourseVal [E] [A] _ _.
Arguments lofcourseval [E] [A] _.
Arguments lofcourseval_nil [E] [A] _.

Definition LOfcourse{E:LEnv} (A:LType) : LType := {|
  ltype := LOfcourseVal A;
  lweight x := lweight (lofcourseval x)
|}.
Notation "! A" := (LOfcourse A%LL) : LL_scope.

Class LOfcAutoPromotion{E:LEnv} (W:LWeight) := {
  lofc_autopromotion_eqn : W = 0%LWeight
}.
Instance LOfcAutoPromotionZero{E:LEnv} : LOfcAutoPromotion 0%LWeight.
Proof.
  exists; reflexivity.
Defined.
Instance LOfcAutoPromotionPlus{E:LEnv} {W0 W1:LWeight}
    {H0:LOfcAutoPromotion W0} {H1:LOfcAutoPromotion W1}
    : LOfcAutoPromotion (W0 + W1)%LWeight.
Proof.
  exists.
  rewrite (@lofc_autopromotion_eqn _ _ H0).
  rewrite (@lofc_autopromotion_eqn _ _ H1).
  apply LWeightZeroL.
Defined.
Instance LOfcAutoPromotionOfc{E:LEnv} (A:LType)
  (v:ltype (!A)) : LOfcAutoPromotion v.
Proof.
  exists; apply lofcourseval_nil.
Defined.

(* Promotion *)
Definition LOfcConstructor{E:LEnv} {A:LType} {W:LWeight}
    {H:LOfcAutoPromotion W} : LGoal A W -> LGoal (!A) W.
Proof.
  intros H0.
  refine {|
    lgoal_proof := {|
      lofcourseval := H0
    |} : ltype (!A);
    lgoal_weight_eqn := {| lweight_eqn := _ |}
  |}.
  simpl.
  apply lgoal_weight_eqn.
Grab Existential Variables.
  rewrite <-(lweight_eqn (lgoal_weight_eqn H0)).
  apply (@lofc_autopromotion_eqn _ _ H).
Defined.

(* Dereliction *)
Definition LOfcDestructor{E:LEnv} {A B:LType} {W:LWeight}
    : LGoal (A -o B) W -> LGoal (!A -o B) W.
Proof.
  intros H0.
  refine {|
    lgoal_proof := {|
      lfun_val := fun(oa:ltype (!A)) => (lgoal_proof H0) (lofcourseval oa);
      lfun_weight := W
    |} : ltype (!A -o B)
  |}.
Grab Existential Variables.
  intros x; simpl; refine (lweight_eqn _).
Defined.

(* Contraction *)
Definition LOfcClone{E:LEnv} {A B:LType} {W:LWeight}
    : LGoal (!A -o !A -o B) W -> LGoal (!A -o B) W.
Proof.
  intros H0.
  refine {|
    lgoal_proof := {|
      lfun_val := fun(oa:ltype (!A)) => (lgoal_proof H0) oa oa;
      lfun_weight := W
    |} : ltype (!A -o B)
  |}.
Grab Existential Variables.
  intros x; simpl.
  rewrite <-lfun_weight_eqn.
  change (W + x = (lgoal_proof H0 x) + lofcourseval x)%LWeight.
  rewrite lofcourseval_nil.
  refine (lweight_eqn _).
Defined.

(* Weakening *)
Definition LOfcClear{E:LEnv} {A B:LType} {W:LWeight}
    : LGoal B W -> LGoal (!A -o B) W.
Proof.
  intros H0.
  refine {|
    lgoal_proof := {|
      lfun_val := fun(oa:ltype (!A)) => lgoal_proof H0;
      lfun_weight := W
    |} : ltype (!A -o B)
  |}.
Grab Existential Variables.
  intros x; simpl.
  rewrite lofcourseval_nil.
  refine (lweight_eqn _).
Defined.

Local Ltac splitll_base ::=
  apply LOfcConstructor ||
  fail "Constructor not found".
Local Ltac destructll_base ::=
  apply LOfcDestructor ||
  fail "Destructor not found".
Local Ltac clonell_base ::=
  apply LOfcClone ||
  fail "Destructor not found".
Local Ltac clearll_base ::=
  apply LOfcClear ||
  fail "Destructor not found".

Local Open Scope LL_goal_scope.

Example LOfcDig1{E:LEnv} (A:LType) :
  (ILL |- (!!A) -o !A).
Proof.
  introsll x.
  destructll x as [x].
  applyll x.
Defined.
Example LOfcDig2{E:LEnv} (A:LType) :
  (ILL |- !A -o !!A).
Proof.
  introsll x.
  splitll.
  applyll x.
Defined.
Local Close Scope LL_goal_scope.


(** printing ⊢k #⊢k# *)
(** printing ⊢s #⊢s# *)
(** printing ⊢! #⊢# *)
(** printing k⊣ #⊣# *)
(** printing |- #⊢# *)
(** printing ↗! #↗# *)
(** printing ↘! #↘# *)
(** printing ⦂ #:# *)
(** printing <⦂ #<:# *)
(** printing [<=] #⊆# *)
(** printing `union` #∪# *)
(** printing \u #∪# *)
(** printing `notin` #∉# *)
(** printing `in` #∈# *)
(** printing ⊆<⦂ #⊆<:# *)

Set Implicit Arguments.
Require Import Definitions.

(** * Miscellaneous Definitions

    This file defines well-formedness of contexts, and some structural measures. The
 definitions resembles those in D<:, so we do not repeat here.
  *)

Inductive wf_env : env -> Prop :=
| wf_nil : wf_env nil
| wf_cons : forall {x T G}, x \notin fv T \u fv G ->
                       fv T [<=] dom G ->
                       wf_env G ->
                       lc T ->
                       wf_env (x ~ T ++ G).
Hint Constructors wf_env.

Lemma wf_decons : forall x T G, wf_env (x ~ T ++ G) -> x \notin fv T.
Proof. routine. Qed.

Lemma wf_deapp : forall G1 G2, wf_env (G1 ++ G2) -> wf_env G2.
Proof. induction on env; routine. Qed.

Lemma wf_uniq : forall G, wf_env G -> uniq G.
Proof. induction on env; routine. Qed.

Lemma wf_var_in : forall G1 G2 v,
    wf_env (G1 ++ G2) ->
    v `in` dom G2 ->
         v `notin` dom G1.
Proof.
  induction G1; intros.
  - routine.
  - tidy_up. repeat rewrite dom_app in *.
    destruct_notin.
    rewrite AtomSetProperties.add_union_singleton.
    intro Contra.
    apply AtomSetImpl.union_1 in Contra.
    destruct Contra.
    + apply AtomSetImpl.singleton_1 in H1. subst.
      intuition.
    + eapply IHG1; eassumption.
Qed.

Lemma wf_fv_is_dom : forall G,
    wf_env G ->
    fv G [=] dom G.
Proof.
  induction on wf_env; set solve.
  autorewrite with meta_ext.
  rewrite IHwf_env.
  simpl. fsetdec.
Qed.

Fixpoint typ_struct_measure (T : typ) :=
  match T with
  | typ_top => 1
  | typ_var x => 2
  | typ_fun T U => S $ typ_struct_measure T + typ_struct_measure U
  | typ_all T U => S $ typ_struct_measure T + typ_struct_measure U
  end.

Local Ltac simplify :=
  intros; cbn in *; try lia.

Local Ltac finish :=
  repeat match goal with
         | H : context[forall _, _ = _] |- _ =>
           rewrite H; clear H
         end;
  reflexivity.

Lemma open_typ_same_measure : forall T k u,
    typ_struct_measure $ open_rec_typ k u T = typ_struct_measure T.
Proof.
  induction T; simplify; finish.
Qed.

Lemma typ_struct_measure_ge_1 : forall T,
    typ_struct_measure T >= 1.
Proof. destruct T; routine. Qed.

Definition total (ns : list nat) : nat :=
  fold_right plus 0 ns.

Lemma total_app : forall ns1 ns2,
    total (ns1 ++ ns2) = total ns1 + total ns2.
Proof.
  unfold total.
  induction on list; simpl in *; intros; trivial.
  rewrite IHlist. lia.
Qed.

Definition env_measure (G : env) : nat :=
  total (List.map (fun (tup : var * typ) =>
        let (x, T) := tup in typ_struct_measure T) G).

Lemma env_measure_cons : forall x T G,
    env_measure ((x, T) :: G) = typ_struct_measure T + env_measure G.
Proof. routine. Qed.

Lemma env_measure_app : forall G1 G2,
    env_measure (G2 ++ G1) = env_measure G2 + env_measure G1.
Proof.
  induction G2; simpl; trivial.
  destruct a. rewrite! env_measure_cons.
  rewrite IHG2. lia.
Qed.

Arguments env_measure G : simpl never.
Create HintDb measures discriminated.
Hint Rewrite -> env_measure_cons env_measure_app total_app : measures.
Hint Rewrite -> open_typ_same_measure : measures.

Section Predicates.

  Definition is_top (T : typ) :=
    match T with
    | typ_top => True
    | _ => False
    end.

  Definition is_top_dec (T : typ) : {is_top T} + {~is_top T}.
  Proof. destruct T; simpl; auto. Defined.

  Definition is_var (T : typ) :=
    match T with
    | typ_var _ => True
    | _ => False
    end.

  Definition is_var_dec (T : typ) : {A | T = typ_var A } + {~is_var T}.
  Proof. destruct T; simpl; eauto. Defined.

  Definition is_fun (T : typ) :=
    match T with
    | typ_fun _ _ => True
    | _ => False
    end.

  Definition is_fun_dec (T : typ) : {S & { U | T = typ_fun S U } } + {~is_fun T}.
  Proof. destruct T; simpl; eauto. Defined.

  Definition is_all (T : typ) :=
    match T with
    | typ_all _ _ => True
    | _ => False
    end.

  Definition is_all_dec (T : typ) : {S & { U | T = typ_all S U } } + {~is_all T}.
  Proof. destruct T; simpl; eauto. Defined.

End Predicates.


(* *********************************************************************)
(*                                                                     *)
(*              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.     *)
(*                                                                     *)
(* *********************************************************************)

(** Correctness proof for the [RRE] pass. *)

Require Import Axioms.
Require Import Coqlib.
Require Import AST.
Require Import Values.
Require Import Globalenvs.
Require Import Events.
Require Import Smallstep.
Require Import Op.
Require Import Locations.
Require Import Conventions.
Require Import Linear.
Require Import RRE.

(** * Operations over equations *)

Lemma find_reg_containing_sound:
  forall s r eqs, find_reg_containing s eqs = Some r -> In (mkeq r s) eqs.
Proof.
  induction eqs; simpl; intros.
  congruence.
  destruct (slot_eq (e_slot a) s). inv H. left; destruct a; auto. right; eauto.
Qed.

Definition equations_hold (ls: locset) (eqs: equations) : Prop :=
  forall e, In e eqs -> ls (S (e_slot e)) = ls (R (e_reg e)).

Lemma nil_hold:
  forall ls, equations_hold ls nil.
Proof.
  red; intros; contradiction.
Qed.

Lemma In_kill_loc:
  forall e l eqs,
  In e (kill_loc l eqs) ->
  In e eqs /\ Loc.diff (S (e_slot e)) l /\ Loc.diff (R (e_reg e)) l.
Proof.
  induction eqs; simpl kill_loc; simpl In; intros.
  tauto.
  destruct (Loc.diff_dec (S (e_slot a)) l).
  destruct (Loc.diff_dec (R (e_reg a)) l).
  simpl in H.  intuition congruence.
  simpl in H.  intuition.
  simpl in H.  intuition.
Qed.

Lemma kill_loc_hold:
  forall ls eqs l v,
  equations_hold ls eqs ->
  equations_hold (Locmap.set l v ls) (kill_loc l eqs).
Proof.
  intros; red; intros.
  exploit In_kill_loc; eauto. intros [A [B C]].
  repeat rewrite Locmap.gso; auto; apply Loc.diff_sym; auto.
Qed.

Lemma In_kill_locs:
  forall e ll eqs,
  In e (kill_locs ll eqs) ->
  In e eqs /\ Loc.notin (S (e_slot e)) ll /\ Loc.notin (R (e_reg e)) ll.
Proof.
Opaque Loc.diff.
  induction ll; simpl; intros.
  tauto.
  exploit IHll; eauto. intros [A [B C]]. exploit In_kill_loc; eauto. intros [D [E F]].
  tauto.
Qed.

Lemma kill_locs_hold:
  forall ll ls eqs,
  equations_hold ls eqs ->
  equations_hold (Locmap.undef ll ls) (kill_locs ll eqs).
Proof.
  intros; red; intros. exploit In_kill_locs; eauto. intros [A [B C]].
  repeat rewrite Locmap.guo; auto.
Qed.

Lemma kill_temps_hold:
  forall ls eqs,
  equations_hold ls eqs ->
  equations_hold (LTL.undef_temps ls) (kill_temps eqs).
Proof.
  exact (kill_locs_hold temporaries).
Qed.

Lemma kill_at_move_hold:
  forall ls eqs,
  equations_hold ls eqs ->
  equations_hold (undef_setstack ls) (kill_at_move eqs).
Proof.
  exact (kill_locs_hold destroyed_at_move).
Qed.

Lemma kill_at_op_hold:
  forall op ls eqs,
  equations_hold ls eqs ->
  equations_hold (undef_op op ls) (kill_op op eqs).
Proof.
  intros op.
  destruct op; exact kill_temps_hold || exact kill_at_move_hold.
Qed.

Lemma eqs_getstack_hold:
  forall rs r s eqs,
  equations_hold rs eqs ->
  equations_hold (Locmap.set (R r) (rs (S s)) rs)
                 (mkeq r s :: kill_loc (R r) eqs).
Proof.
Transparent Loc.diff.
  intros; red; intros. simpl in H0; destruct H0.
  subst e. simpl. rewrite Locmap.gss; rewrite Locmap.gso; auto. red; auto.
  exploit In_kill_loc; eauto. intros [D [E F]].
  repeat rewrite Locmap.gso. auto.
  apply Loc.diff_sym; auto. apply Loc.diff_sym; auto.
Qed.

Lemma eqs_movestack_hold:
  forall rs r s eqs,
  equations_hold rs eqs ->
  equations_hold (Locmap.set (R r) (rs (S s)) (undef_setstack rs))
                 (kill_at_move (mkeq r s :: kill_loc (R r) eqs)).
Proof.
  unfold undef_setstack, kill_at_move; intros; red; intros.
  exploit In_kill_locs; eauto. intros [A [B C]].
  simpl in A; destruct A.
  subst e. rewrite Locmap.gss. rewrite Locmap.gso. apply Locmap.guo. auto.
  simpl; auto.
  exploit In_kill_loc; eauto. intros [D [E F]].
  repeat rewrite Locmap.gso. repeat rewrite Locmap.guo; auto.
  apply Loc.diff_sym; auto. apply Loc.diff_sym; auto.
Qed.

Lemma eqs_setstack_hold:
  forall rs r s eqs,
  equations_hold rs eqs ->
  equations_hold (Locmap.set (S s) (rs (R r)) (undef_setstack rs))
                 (kill_at_move (mkeq r s :: kill_loc (S s) eqs)).
Proof.
  unfold undef_setstack, kill_at_move; intros; red; intros.
  exploit In_kill_locs; eauto. intros [A [B C]].
  simpl in A; destruct A.
  subst e. rewrite Locmap.gss. rewrite Locmap.gso. rewrite Locmap.guo. auto.
  auto. simpl. destruct s; auto.
  exploit In_kill_loc; eauto. intros [D [E F]].
  repeat rewrite Locmap.gso. repeat rewrite Locmap.guo; auto.
  apply Loc.diff_sym; auto. apply Loc.diff_sym; auto.
Qed.

Lemma locmap_set_reg_same:
  forall rs r,
  Locmap.set (R r) (rs (R r)) rs = rs.
Proof.
  intros. apply extensionality; intros.
  destruct (Loc.eq x (R r)).
  subst x. apply Locmap.gss.
  apply Locmap.gso. apply Loc.diff_reg_right; auto.
Qed.

(** * Agreement between values of locations *)

(** Values of locations may differ between the original and transformed
  program: after a [Lgetstack] is optimized to a [Lop Omove],
  the values of [destroyed_at_move] temporaries differ.  This
  can only happen in parts of the code where the [safe_move_insertion]
  function returns [true].  *)

Definition agree (sm: bool) (rs rs': locset) : Prop :=
  forall l, sm = false \/ Loc.notin l destroyed_at_move -> rs' l = rs l.

Lemma agree_false:
  forall rs rs',
  agree false rs rs' <-> rs' = rs.
Proof.
  intros; split; intros.
  apply extensionality; intros. auto.
  subst rs'. red; auto.
Qed.

Lemma agree_slot:
  forall sm rs rs' s,
  agree sm rs rs' -> rs' (S s) = rs (S s).
Proof.
Transparent Loc.diff.
  intros. apply H. right. simpl; destruct s; tauto.
Qed.

Lemma agree_reg:
  forall sm rs rs' r,
  agree sm rs rs' ->
  sm = false \/ ~In r destroyed_at_move_regs -> rs' (R r) = rs (R r).
Proof.
  intros. apply H. destruct H0; auto. right.
  simpl in H0; simpl; intuition congruence.
Qed.

Lemma agree_regs:
  forall sm rs rs' rl,
  agree sm rs rs' ->
  sm = false \/ list_disjoint rl destroyed_at_move_regs -> reglist rs' rl = reglist rs rl.
Proof.
  induction rl; intros; simpl.
  auto.
  decEq. apply agree_reg with sm. auto.
    destruct H0. auto. right. eapply list_disjoint_notin; eauto with coqlib.
  apply IHrl; auto. destruct H0; auto. right. eapply list_disjoint_cons_left; eauto.
Qed.

Lemma agree_set:
  forall sm rs rs' l v,
  agree sm rs rs' ->
  agree sm (Locmap.set l v rs) (Locmap.set l v rs').
Proof.
  intros; red; intros.
  unfold Locmap.set.
  destruct (Loc.eq l l0). auto.
  destruct (Loc.overlap l l0). auto.
  apply H; auto.
Qed.

Lemma agree_undef_move_1:
  forall sm rs rs',
  agree sm rs rs' ->
  agree true rs (undef_setstack rs').
Proof.
  intros. unfold undef_setstack. red; intros.
  destruct H0. congruence. rewrite Locmap.guo; auto.
Qed.

Remark locmap_undef_equal:
  forall x ll rs rs',
  (forall l, Loc.notin l ll -> rs' l = rs l) ->
  Locmap.undef ll rs' x = Locmap.undef ll rs x.
Proof.
  induction ll; intros; simpl.
  apply H. simpl. auto.
  apply IHll. intros. unfold Locmap.set.
  destruct (Loc.eq a l). auto. destruct (Loc.overlap a l) eqn:?. auto.
  apply H. simpl. split; auto. apply Loc.diff_sym. apply Loc.non_overlap_diff; auto.
Qed.

Lemma agree_undef_move_2:
  forall sm rs rs',
  agree sm rs rs' ->
  agree false (undef_setstack rs) (undef_setstack rs').
Proof.
  intros. rewrite agree_false.
  apply extensionality; intros. unfold undef_setstack. apply locmap_undef_equal. auto.
Qed.

Lemma agree_undef_temps:
  forall sm rs rs',
  agree sm rs rs' ->
  agree false (LTL.undef_temps rs) (LTL.undef_temps rs').
Proof.
  intros. rewrite agree_false.
  apply extensionality; intros. unfold LTL.undef_temps. apply locmap_undef_equal.
  intros. apply H. right. simpl in H0; simpl; tauto.
Qed.

Lemma agree_undef_op:
  forall op sm rs rs',
  agree sm rs rs' ->
  agree false (undef_op op rs) (undef_op op rs').
Proof.
  intros op.
  destruct op; exact agree_undef_temps || exact agree_undef_move_2.
Qed.

Lemma transl_find_label:
  forall lbl c eqs,
  find_label lbl (transf_code eqs c) =
  option_map (transf_code nil) (find_label lbl c).
Proof.
  induction c; simpl; intros.
  auto.
  destruct a; simpl; auto.
  destruct (is_incoming s); simpl; auto.
  destruct (contains_equation s m eqs); auto.
  destruct (find_reg_containing s eqs); simpl; auto.
  destruct (safe_move_insertion c); simpl; auto.
  destruct (peq lbl l); simpl; auto.
Qed.

(** * Semantic preservation *)

Section PRESERVATION.

Variable prog: program.
Let tprog := transf_program prog.

Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.

Lemma functions_translated:
  forall v f,
  Genv.find_funct ge v = Some f ->
  Genv.find_funct tge v = Some (transf_fundef f).
Proof (@Genv.find_funct_transf _ _ _ transf_fundef prog).

Lemma function_ptr_translated:
  forall v f,
  Genv.find_funct_ptr ge v = Some f ->
  Genv.find_funct_ptr tge v = Some (transf_fundef f).
Proof (@Genv.find_funct_ptr_transf _ _ _ transf_fundef prog).

Lemma symbols_preserved:
  forall id,
  Genv.find_symbol tge id = Genv.find_symbol ge id.
Proof (@Genv.find_symbol_transf _ _ _ transf_fundef prog).

Lemma varinfo_preserved:
  forall b, Genv.find_var_info tge b = Genv.find_var_info ge b.
Proof (@Genv.find_var_info_transf _ _ _ transf_fundef prog).

Lemma sig_preserved:
  forall f, funsig (transf_fundef f) = funsig f.
Proof.
  destruct f; reflexivity.
Qed.

Lemma find_function_translated:
  forall ros rs fd,
  find_function ge ros rs = Some fd ->
  find_function tge ros rs = Some (transf_fundef fd).
Proof.
  intros. destruct ros; simpl in *.
  apply functions_translated; auto.
  rewrite symbols_preserved. destruct (Genv.find_symbol ge i).
  apply function_ptr_translated; auto.
  congruence.
Qed.

Inductive match_frames: stackframe -> stackframe -> Prop :=
  | match_frames_intro:
      forall f sp rs c,
      match_frames (Stackframe f sp rs c)
                   (Stackframe (transf_function f) sp rs (transf_code nil c)).

Inductive match_states: state -> state -> Prop :=
  | match_states_regular:
      forall sm stk f sp c rs m stk' rs' eqs
        (STK: list_forall2 match_frames stk stk')
        (EQH: equations_hold rs' eqs)
        (AG: agree sm rs rs')
        (SAFE: sm = false \/ safe_move_insertion c = true),
      match_states (State stk f sp c rs m)
                   (State stk' (transf_function f) sp (transf_code eqs c) rs' m)
  | match_states_call:
      forall stk f rs m stk'
        (STK: list_forall2 match_frames stk stk'),
      match_states (Callstate stk f rs m)
                   (Callstate stk' (transf_fundef f) rs m)
  | match_states_return:
      forall stk rs m stk'
        (STK: list_forall2 match_frames stk stk'),
      match_states (Returnstate stk rs m)
                   (Returnstate stk' rs m).

Definition measure (S: state) : nat :=
  match S with
  | State s f sp c rs m => List.length c
  | _ => 0%nat
  end.

Remark match_parent_locset:
  forall stk stk',
  list_forall2 match_frames stk stk' ->
  return_regs (parent_locset stk') = return_regs (parent_locset stk).
Proof.
  intros. inv H; auto. inv H0; auto.
Qed.

Theorem transf_step_correct:
  forall S1 t S2, step ge S1 t S2 ->
  forall S1' (MS: match_states S1 S1'),
  (exists S2', step tge S1' t S2' /\ match_states S2 S2')
  \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat.
Proof.
Opaque destroyed_at_move_regs.
  induction 1; intros; inv MS; simpl.
(** getstack *)
  simpl in SAFE.
  assert (SAFE': sm = false \/ ~In r destroyed_at_move_regs /\ safe_move_insertion b = true).
    destruct (in_dec mreg_eq r destroyed_at_move_regs); simpl in SAFE; intuition congruence.
  destruct (is_incoming sl) eqn:?.
  (* incoming, stays as getstack *)
  assert (UGS: forall rs, undef_getstack sl rs = Locmap.set (R IT1) Vundef rs).
    destruct sl; simpl in Heqb0; discriminate || auto.
  left; econstructor; split. constructor.
  repeat rewrite UGS.
  apply match_states_regular with sm. auto.
  apply kill_loc_hold. apply kill_loc_hold; auto.
  rewrite (agree_slot _ _ _ sl AG). apply agree_set. apply agree_set. auto.
  tauto.
  (* not incoming *)
  assert (UGS: forall rs, undef_getstack sl rs = rs).
    destruct sl; simpl in Heqb0; discriminate || auto.
  unfold contains_equation.
  destruct (in_dec eq_equation (mkeq r sl) eqs); simpl.
  (* eliminated *)
  right.  split. omega. split. auto. rewrite UGS.
  exploit EQH; eauto. simpl. intro EQ.
  assert (EQ1: rs' (S sl) = rs (S sl)) by (eapply agree_slot; eauto).
  assert (EQ2: rs' (R r) = rs (R r)) by (eapply agree_reg; eauto; tauto).
  rewrite <- EQ1; rewrite EQ; rewrite EQ2. rewrite locmap_set_reg_same.
  apply match_states_regular with sm; auto; tauto.
  (* found an equation *)
  destruct (find_reg_containing sl eqs) as [r'|] eqn:?.
  exploit EQH. eapply find_reg_containing_sound; eauto.
  simpl; intro EQ.
  (* turned into a move *)
  destruct (safe_move_insertion b) eqn:?.
  left; econstructor; split. constructor. simpl; eauto.
  rewrite UGS. rewrite <- EQ.
  apply match_states_regular with true; auto.
  apply eqs_movestack_hold; auto.
  rewrite (agree_slot _ _ _ sl AG). apply agree_set. eapply agree_undef_move_1; eauto.
  (* left as a getstack *)
  left; econstructor; split. constructor.
  repeat rewrite UGS.
  apply match_states_regular with sm. auto.
  apply eqs_getstack_hold; auto.
  rewrite (agree_slot _ _ _ sl AG). apply agree_set. auto.
  intuition congruence.
  (* no equation, left as a getstack *)
  left; econstructor; split. constructor.
  repeat rewrite UGS.
  apply match_states_regular with sm. auto.
  apply eqs_getstack_hold; auto.
  rewrite (agree_slot _ _ _ sl AG). apply agree_set. auto.
  tauto.

(* setstack *)
  left; econstructor; split. constructor.
  apply match_states_regular with false; auto.
  apply eqs_setstack_hold; auto.
  rewrite (agree_reg _ _ _ r AG). apply agree_set. eapply agree_undef_move_2; eauto.
  simpl in SAFE. destruct (in_dec mreg_eq r destroyed_at_move_regs); simpl in SAFE; intuition congruence.

(* op *)
  left; econstructor; split. constructor.
  instantiate (1 := v). rewrite <- H.
  rewrite (agree_regs _ _ _ args AG).
  apply eval_operation_preserved. exact symbols_preserved.
  simpl in SAFE. destruct (list_disjoint_dec mreg_eq args destroyed_at_move_regs); simpl in SAFE; intuition congruence.
  apply match_states_regular with false; auto.
  apply kill_loc_hold; apply kill_at_op_hold; auto.
  apply agree_set. eapply agree_undef_op; eauto.

(* load *)
  left; econstructor; split.
  econstructor.  instantiate (1 := a).  rewrite <- H.
  rewrite (agree_regs _ _ _ args AG).
  apply eval_addressing_preserved.  exact symbols_preserved.
  simpl in SAFE. destruct (list_disjoint_dec mreg_eq args destroyed_at_move_regs); simpl in SAFE; intuition congruence.
  eauto.
  apply match_states_regular with false; auto.
  apply kill_loc_hold; apply kill_temps_hold; auto.
  apply agree_set. eapply agree_undef_temps; eauto.

(* store *)
Opaque list_disjoint_dec.
  simpl in SAFE.
  assert (sm = false \/ ~In src destroyed_at_move_regs /\ list_disjoint args destroyed_at_move_regs).
    destruct SAFE. auto. right.
    destruct (list_disjoint_dec mreg_eq (src :: args) destroyed_at_move_regs); try discriminate.
    split. eapply list_disjoint_notin; eauto with coqlib. eapply list_disjoint_cons_left; eauto.
  left; econstructor; split.
  econstructor.  instantiate (1 := a).  rewrite <- H.
  rewrite (agree_regs _ _ _ args AG).
  apply eval_addressing_preserved.  exact symbols_preserved.
  tauto.
  rewrite (agree_reg _ _ _ src AG).
  eauto.
  tauto.
  apply match_states_regular with false; auto.
  apply kill_temps_hold; auto.
  eapply agree_undef_temps; eauto.

(* call *)
  simpl in SAFE. assert (sm = false) by intuition congruence.
  subst sm. rewrite agree_false in AG. subst rs'.
  left; econstructor; split.
  constructor. eapply find_function_translated; eauto.
  symmetry; apply sig_preserved.
  constructor. constructor; auto. constructor.

(* tailcall *)
  simpl in SAFE. assert (sm = false) by intuition congruence.
  subst sm. rewrite agree_false in AG. subst rs'.
  left; econstructor; split.
  constructor. eapply find_function_translated; eauto.
  symmetry; apply sig_preserved. eauto.
  reflexivity.
  rewrite (match_parent_locset _ _ STK). constructor; auto.

(* builtin *)
  left; econstructor; split.
  constructor.
  rewrite (agree_regs _ _ _ args AG).
  eapply external_call_symbols_preserved; eauto.
  exact symbols_preserved. exact varinfo_preserved.
  simpl in SAFE. destruct (list_disjoint_dec mreg_eq args destroyed_at_move_regs); simpl in SAFE; intuition congruence.
  apply match_states_regular with false; auto.
  apply kill_loc_hold; apply kill_temps_hold; auto.
  apply agree_set. eapply agree_undef_temps; eauto.

(* annot *)
  simpl in SAFE. assert (sm = false) by intuition congruence.
  subst sm. rewrite agree_false in AG. subst rs'.
  left; econstructor; split.
  econstructor. eapply external_call_symbols_preserved; eauto.
  exact symbols_preserved. exact varinfo_preserved.
  apply match_states_regular with false; auto.
  rewrite agree_false; auto.

(* label *)
  left; econstructor; split. constructor.
  apply match_states_regular with false; auto.
  apply nil_hold.
  simpl in SAFE. destruct SAFE. subst sm. auto. congruence.

(* goto *)
  generalize (transl_find_label lbl (fn_code f) nil).  rewrite H. simpl. intros.
  left; econstructor; split. constructor; eauto.
  apply match_states_regular with false; auto.
  apply nil_hold.
  simpl in SAFE. destruct SAFE. subst sm. auto. congruence.

(* cond true *)
  generalize (transl_find_label lbl (fn_code f) nil).  rewrite H0. simpl. intros.
  left; econstructor; split.
  apply exec_Lcond_true; auto.
  rewrite (agree_regs _ _ _ args AG). auto.
  simpl in SAFE. destruct (list_disjoint_dec mreg_eq args destroyed_at_move_regs); simpl in SAFE; intuition congruence.
  eauto.
  apply match_states_regular with false; auto.
  apply nil_hold.
  eapply agree_undef_temps; eauto.

(* cond false *)
  left; econstructor; split. apply exec_Lcond_false; auto.
  rewrite (agree_regs _ _ _ args AG). auto.
  simpl in SAFE. destruct (list_disjoint_dec mreg_eq args destroyed_at_move_regs); simpl in SAFE; intuition congruence.
  apply match_states_regular with false; auto.
  apply kill_temps_hold; auto.
  eapply agree_undef_temps; eauto.

(* jumptable *)
  generalize (transl_find_label lbl (fn_code f) nil).  rewrite H1. simpl. intros.
  left; econstructor; split. econstructor; eauto.
  rewrite (agree_reg _ _ _ arg AG). auto.
  simpl in SAFE. destruct (in_dec mreg_eq arg destroyed_at_move_regs); simpl in SAFE; intuition congruence.
  apply match_states_regular with false; auto.
  apply nil_hold.
  eapply agree_undef_temps; eauto.

(* return *)
  simpl in SAFE. destruct SAFE; try discriminate. subst sm. rewrite agree_false in AG. subst rs'.
  left; econstructor; split.
  constructor. simpl. eauto.
  reflexivity.
  rewrite (match_parent_locset _ _ STK).
  constructor; auto.

(* internal *)
  left; econstructor; split.
  constructor. simpl; eauto.
  reflexivity.
  simpl. apply match_states_regular with false; auto. apply nil_hold. rewrite agree_false; auto.

(* external *)
  left; econstructor; split.
  econstructor. eapply external_call_symbols_preserved; eauto.
  exact symbols_preserved. exact varinfo_preserved.
  auto. eauto.
  constructor; auto.

(* return *)
  inv STK. inv H1. left; econstructor; split. constructor.
  apply match_states_regular with false; auto.
  apply nil_hold.
  rewrite agree_false; auto.
Qed.

Lemma transf_initial_states:
  forall st1, initial_state prog st1 ->
  exists st2, initial_state tprog st2 /\ match_states st1 st2.
Proof.
  intros. inversion H.
  econstructor; split.
  econstructor.
  apply Genv.init_mem_transf; eauto.
  rewrite symbols_preserved. eauto.
  apply function_ptr_translated; eauto.
  rewrite sig_preserved. auto.
  econstructor; eauto. constructor.
Qed.

Lemma transf_final_states:
  forall st1 st2 r,
  match_states st1 st2 -> final_state st1 r -> final_state st2 r.
Proof.
  intros. inv H0. inv H. inv STK. econstructor. auto.
Qed.

Theorem transf_program_correct:
  forward_simulation (Linear.semantics prog) (Linear.semantics tprog).
Proof.
  eapply forward_simulation_opt.
  eexact symbols_preserved.
  eexact transf_initial_states.
  eexact transf_final_states.
  eexact transf_step_correct.
Qed.

End PRESERVATION.


Require Import VST.msl.log_normalize.
Require Import VST.msl.ghost.
Require Import VST.msl.ghost_seplog.
Require Export VST.veric.base.
Require Import VST.veric.rmaps.
Require Import VST.veric.compcert_rmaps.
Require Import VST.veric.res_predicates.

Import RML. Import R.
Local Open Scope pred.

Notation ghost_approx m := (ghost_fmap (approx (level m)) (approx (level m))).

(* Ownership construction based on "Iris from the ground up", Jung et al. *)
Program Definition ghost_is g: pred rmap :=
  fun m => ghost_of m = ghost_approx m g.
Next Obligation.
  intros ???? Hg.
  rewrite (age1_ghost_of _ _ H), Hg.
  pose proof (age_level _ _ H).
  rewrite ghost_fmap_fmap, approx_oo_approx', approx'_oo_approx by lia; eauto.
Qed.

Definition Own g: pred rmap := allp noat && ghost_is g.

Lemma Own_op: forall a b c, join a b c -> Own c = Own a * Own b.
Proof.
  intros; apply pred_ext.
  - intros w (Hno & Hg).
    destruct (make_rmap (resource_at w) (ghost_approx w a) (level w))
      as (wa & Hla & Hra & Hga).
    { extensionality; apply resource_at_approx. }
    { rewrite ghost_fmap_fmap, approx_oo_approx; auto. }
    destruct (make_rmap (resource_at w) (ghost_approx w b) (level w))
      as (wb & Hlb & Hrb & Hgb).
    { extensionality; apply resource_at_approx. }
    { rewrite ghost_fmap_fmap, approx_oo_approx; auto. }
    exists wa, wb; split.
    + apply resource_at_join2; auto.
      * intro; rewrite Hra, Hrb.
        apply identity_unit', Hno.
      * rewrite Hg, Hga, Hgb.
        apply ghost_fmap_join; auto.
    + simpl; rewrite Hla, Hlb, Hra, Hrb, Hga, Hgb; simpl; eauto 6.
  - intros w (w1 & w2 & J & (Hnoa & Hga) & (Hnob & Hgb)).
    split.
    + intro l; apply (resource_at_join _ _ _ l) in J.
      simpl in *; rewrite <- (Hnoa _ _ _ J); auto.
    + destruct (join_level _ _ _ J) as [Hl1 Hl2].
      apply ghost_of_join in J.
      rewrite Hga, Hgb in J.
      eapply join_eq; eauto.
      rewrite Hl1, Hl2; apply ghost_fmap_join; auto.
Qed.

Fixpoint make_join (a c : ghost) : ghost :=
  match a, c with
  | nil, _ => c
  | _, nil => nil
  | None :: a', x :: c' => x :: make_join a' c'
  | _ :: a', None :: c' => None :: make_join a' c'
  | Some (ga, pa) :: a', Some (gc, _) :: c' => Some (gc, pa) :: make_join a' c'
  end.

Lemma make_join_nil : forall a, make_join a nil = nil.
Proof.
  destruct a; auto.
  destruct o as [[]|]; auto.
Qed.

Lemma make_join_nil_cons : forall o a c, make_join (o :: a) (None :: c) = None :: make_join a c.
Proof.
  destruct o as [[]|]; auto.
Qed.

Lemma ghost_joins_approx: forall n a c,
  joins (ghost_fmap (approx n) (approx n) a) (ghost_fmap (approx n) (approx n) c) ->
  let c' := make_join a c in
  joins (ghost_fmap (approx (S n)) (approx (S n)) a) (ghost_fmap (approx (S n)) (approx (S n)) c') /\
    forall b, joins b (ghost_fmap (approx (S n)) (approx (S n)) c') ->
      joins (ghost_fmap (approx n) (approx n) b) (ghost_fmap (approx n) (approx n) c).
Proof.
  intros ???; revert a; induction c; intros; subst c'; simpl.
  - rewrite make_join_nil; split.
    + eexists; constructor.
    + eexists; constructor.
  - destruct H; inv H.
    + destruct a0; inv H1.
      split.
      { eexists; constructor. }
      intros ? []; eexists.
      apply ghost_fmap_join with (f := approx n)(g := approx n) in H.
      rewrite ghost_fmap_fmap, approx_oo_approx', approx'_oo_approx in H by auto; eauto.
    + destruct a0; inv H0.
      destruct (IHc a0) as (H & Hc'); eauto.
      inv H3.
      * destruct o; inv H1.
        split.
        { destruct H; eexists; constructor; eauto; constructor. }
        intros ? [? J]; inv J; [eexists; constructor|].
        destruct (Hc' m1); eauto.
        eexists; constructor; eauto.
        instantiate (1 := option_map (fun '(a, b) => (a, preds_fmap (approx n) (approx n) b)) a3).
        inv H3.
        -- destruct a as [[]|]; [simpl | constructor].
           rewrite preds_fmap_fmap, approx_oo_approx', approx'_oo_approx by auto; constructor; auto.
        -- destruct a; inv H4; constructor.
        -- destruct a as [[]|]; inv H1; constructor.
           destruct a2, a5; inv H4; constructor; auto; simpl in *.
           inv H2.
           rewrite preds_fmap_fmap, approx_oo_approx', approx'_oo_approx by auto; constructor; auto.
      * destruct a; inv H2.
        rewrite make_join_nil_cons.
        split.
        { destruct H; eexists; constructor; eauto; constructor. }
        intros ? [? J]; inv J; [eexists; constructor|].
        destruct (Hc' m1); eauto.
        eexists; constructor; eauto; constructor.
      * destruct o as [[]|], a as [[]|]; inv H0; inv H1.
        split.
        { destruct H.
          destruct a4; inv H2; simpl in *.
          inv H1.
          eexists (Some (_, _) :: _); constructor; eauto; constructor.
          constructor; simpl; eauto; constructor; eauto. }
        intros ? [? J]; inv J; [eexists; constructor|].
        destruct (Hc' m1); eauto.
        eexists; constructor; eauto.
        instantiate (1 := option_map (fun '(a, b) => (a, preds_fmap (approx n) (approx n) b)) a3).
        inv H4.
        -- destruct a4; inv H2; simpl in *.
           inv H3.
           rewrite <- H2, preds_fmap_fmap, approx_oo_approx', approx'_oo_approx by auto; constructor.
        -- constructor.
           destruct a2, a4, a6; inv H2; inv H6; constructor; auto; simpl in *.
           inv H3; inv H4.
           rewrite <- H6, preds_fmap_fmap, approx_oo_approx', approx'_oo_approx by auto; constructor; auto.
Qed.

Program Definition bupd (P: pred rmap): pred rmap :=
  fun m => forall c, joins (ghost_of m) (ghost_approx m c) ->
    exists b, joins b (ghost_approx m c) /\
    exists m', level m' = level m /\ resource_at m' = resource_at m /\ ghost_of m' = b /\ P m'.
Next Obligation.
Proof.
  repeat intro.
  rewrite (age1_ghost_of _ _ H) in H1.
  rewrite <- ghost_of_approx in H0.
  destruct (ghost_joins_approx _ _ _ H1) as (J0 & Hc0).
  rewrite <- (age_level _ _ H) in *.
  specialize (H0 _ J0); destruct H0 as (b & J & Hrb).
  pose proof (age_level _ _ H).
  exists (ghost_approx a' b); split; auto.
  destruct Hrb as (m' & Hl' & Hr' & Hg' & HP).
  destruct (levelS_age m' (level a')) as (m'' & Hage' & Hl'').
  { congruence. }
  exists m''; repeat split; auto.
  + extensionality l.
    erewrite (age1_resource_at _ _ H l) by (symmetry; apply resource_at_approx).
    erewrite (age1_resource_at _ _ Hage' l) by (symmetry; apply resource_at_approx).
    congruence.
  + rewrite (age1_ghost_of _ _ Hage').
    rewrite Hg', <- Hl''; auto.
  + eapply (proj2_sig P); eauto.
Qed.

Lemma bupd_intro: forall P, P |-- bupd P.
Proof.
  repeat intro; eauto 7.
Qed.

Lemma bupd_mono: forall P Q, P |-- Q -> bupd P |-- bupd Q.
Proof.
  repeat intro.
  simpl in *.
  destruct (H0 _ H1) as (b & ? & m' & ? & ? & ? & ?).
  exists b; split; auto.
  exists m'; repeat split; auto.
Qed.

Lemma bupd_frame_r: forall P Q, bupd P * Q |-- bupd (P * Q).
Proof.
  repeat intro.
  destruct H as (w1 & w2 & J & HP & HQ).
  destruct (join_level _ _ _ J) as [Hl1 Hl2].
  pose proof (ghost_of_join _ _ _ J) as Jg.
  destruct H0 as [? J'].
  destruct (join_assoc Jg J') as (c' & J1 & J2).
  erewrite <- (ghost_same_level_gen (level a) (ghost_of w2) c c') in J2, J1
    by (rewrite <- Hl2 at 1 2; rewrite ghost_of_approx; auto).
  destruct (HP c') as (? & [? J1'] & w1' & ? & Hr' & ? & HP'); subst.
  { rewrite Hl1; eauto. }
  rewrite Hl1 in J1'; destruct (join_assoc (join_comm J1) (join_comm J1')) as (w' & ? & ?).
  exists w'; split; [eexists; apply join_comm; eauto|].
  destruct (make_rmap (resource_at a) w' (level a)) as (m' & ? & Hr'' & ?); subst.
  { extensionality l; apply resource_at_approx. }
  { eapply ghost_same_level_gen.
    rewrite <- (ghost_of_approx w2), <- (ghost_of_approx w1'), H, Hl1, Hl2 in H0.
    apply join_comm; eauto. }
  exists m'; repeat split; auto.
  exists w1', w2; repeat split; auto.
  apply resource_at_join2; auto; try lia.
  intro; rewrite Hr', Hr''.
  apply resource_at_join; auto.
Qed.

Lemma bupd_frame_l: forall P Q, P * bupd Q |-- bupd (P * Q).
Proof.
  intros; rewrite sepcon_comm, (sepcon_comm P Q); apply bupd_frame_r.
Qed.

Lemma bupd_trans: forall P, bupd (bupd P) |-- bupd P.
Proof.
  repeat intro.
  destruct (H _ H0) as (b & J & a' & Hl & Hr & ? & Ha'); subst.
  rewrite <- Hl in J; destruct (Ha' _ J) as (b' & ? & Hm').
  rewrite <- Hl, <- Hr; eauto.
Qed.

Lemma bupd_prop : forall P, bupd (!! P) = !! P.
Proof.
  intros ?; apply pred_ext.
  - intros ??; simpl in *.
    destruct (H (core (ghost_of a))) as (? & ? & ? & ? & ? & ? & ?); auto.
    eexists.
    rewrite ghost_core; simpl; erewrite <- ghost_core.
    apply join_comm, core_unit.
  - intros ??.
    do 2 eexists; eauto.
Qed.

Lemma subp_bupd: forall (G : pred nat) (P P' : pred rmap), G |-- P >=> P' ->
    G |-- (bupd P >=> bupd P')%pred.
Proof.
  repeat intro.
  specialize (H3 _ H4) as (? & ? & ? & ? & ? & ? & HP).
  do 2 eexists; eauto; do 2 eexists; eauto; repeat (split; auto).
  pose proof (necR_level _ _ H2).
  apply (H _ H0 x0 ltac:(lia) _ (necR_refl _)); auto.
Qed.

Lemma eqp_bupd: forall (G : pred nat) (P P' : pred rmap), G |-- P <=> P' ->
    G |-- (bupd P <=> bupd P').
Proof.
  intros.
  rewrite fash_and in *.
  apply andp_right; apply subp_bupd; eapply derives_trans; try apply H;
    [apply andp_left1 | apply andp_left2]; apply derives_refl.
Qed.

Definition ghost_fp_update_ND a B :=
  forall n c, joins (ghost_fmap (approx n) (approx n) a) c ->
    exists b, B b /\ joins (ghost_fmap (approx n) (approx n) b) c.

Lemma Own_update_ND: forall a B, ghost_fp_update_ND a B ->
  Own a |-- bupd (EX b : _, !!(B b) && Own b).
Proof.
  repeat intro.
  destruct H0 as (Hno & Hg).
  rewrite Hg in H1.
  destruct H1 as [? J].
  destruct (H (level a0) (ghost_approx a0 c)) as (g' & ? & J').
  { eexists; eauto. }
  exists (ghost_fmap (approx (level a0)) (approx (level a0)) g'); split; auto.
  destruct (make_rmap (resource_at a0)
    (ghost_fmap (approx (level a0)) (approx (level a0)) g') (level a0))
    as (m' & Hl & Hr & Hg').
  { extensionality; apply resource_at_approx. }
  { rewrite ghost_fmap_fmap, approx_oo_approx; auto. }
  exists m'; repeat split; auto.
  exists g'; repeat split; auto.
  - simpl in *; intro; rewrite Hr; auto.
  - simpl; rewrite Hg', Hl; simpl; eauto.
Qed.

Definition ghost_fp_update (a b : ghost) :=
  forall n c, joins (ghost_fmap (approx n) (approx n) a) c ->
               joins (ghost_fmap (approx n) (approx n) b) c.

Instance ghost_fp_update_preorder: RelationClasses.PreOrder ghost_fp_update.
Proof.
  split; repeat intro; auto.
Qed.

Lemma ghost_fp_update_approx: forall a b n, ghost_fp_update a b ->
  ghost_fp_update (ghost_fmap (approx n) (approx n) a) (ghost_fmap (approx n) (approx n) b).
Proof.
  intros; intros m c J.
  rewrite ghost_fmap_fmap in *.
  replace (approx m oo approx n) with (approx (min m n)) in *.
  replace (approx n oo approx m) with (approx (min m n)) in *.
  auto.
  { destruct (Min.min_spec m n) as [[? ->] | [? ->]];
      [rewrite approx'_oo_approx | rewrite approx_oo_approx']; auto; lia. }
  { destruct (Min.min_spec m n) as [[? ->] | [? ->]];
      [rewrite approx_oo_approx' | rewrite approx'_oo_approx]; auto; lia. }
Qed.

Lemma Own_update: forall a b, ghost_fp_update a b ->
  Own a |-- bupd (Own b).
Proof.
  intros; eapply derives_trans.
  - eapply (Own_update_ND _ (eq _)).
    repeat intro.
    eexists; split; [constructor|].
    apply H; eauto.
  - apply bupd_mono.
    repeat (apply exp_left; intro).
    apply prop_andp_left; intro X; inv X; auto.
Qed.

Lemma Own_unit: emp |-- EX a : _, !!(identity a) && Own a.
Proof.
  intros w ?; simpl in *.
  exists (ghost_of w); split; [|split].
  - apply ghost_of_identity; auto.
  - intro; apply resource_at_identity; auto.
  - rewrite ghost_of_approx; auto.
Qed.

Lemma Own_dealloc: forall a, Own a |-- bupd emp.
Proof.
  intros ? w [] ??.
  exists (core ((ghost_approx w) c)); split; [eexists; apply core_unit|].
  destruct (make_rmap (resource_at w) (core (ghost_approx w c)) (level w)) as (w' & ? & Hr & Hg).
  { extensionality; apply resource_at_approx. }
  { rewrite ghost_core; auto. }
  exists w'; repeat split; auto.
  apply all_resource_at_identity.
  - rewrite Hr; auto.
  - rewrite Hg; apply core_identity.
Qed.

Definition singleton {A} k (x : A) : list (option A) := repeat None k ++ Some x :: nil.

Definition gname := nat.

Definition own {RA: Ghost} (n: gname) (a: G) (pp: preds) :=
  EX v : _, Own (singleton n (existT _ RA (exist _ a v), pp)).

Definition list_set {A} (m : list (option A)) k v : list (option A) :=
  firstn k m ++ repeat None (k - length m) ++ Some v :: skipn (S k) m.

Lemma singleton_join_gen: forall k a c (m: ghost)
  (Hjoin: join (Some a) (nth k m None) (Some c)),
  join (singleton k a) m (list_set m k c).
Proof.
  induction k; intros.
  - destruct m; simpl in *; subst; inv Hjoin; constructor; constructor; auto.
  - destruct m; simpl in *.
    + inv Hjoin; constructor.
    + constructor; [constructor | apply IHk; auto].
Qed.

Lemma map_repeat : forall {A B} (f : A -> B) x n, map f (repeat x n) = repeat (f x) n.
Proof.
  induction n; auto; simpl.
  rewrite IHn; auto.
Qed.

Lemma ghost_fmap_singleton: forall f g k v, ghost_fmap f g (singleton k v) =
  singleton k (match v with (a, b) => (a, preds_fmap f g b) end).
Proof.
  intros; unfold ghost_fmap, singleton.
  rewrite map_app, map_repeat; auto.
Qed.

Lemma ghost_fmap_singleton_inv : forall f g a k v,
  ghost_fmap f g a = singleton k v ->
  exists v', a = singleton k v' /\ v = let (a, b) := v' in (a, preds_fmap f g b).
Proof.
  unfold singleton; induction a; simpl; intros.
  - destruct k; discriminate.
  - destruct a as [[]|]; simpl in *.
    + destruct k; inv H.
      destruct a0; inv H2.
      simpl; eauto.
    + destruct k; inv H.
      edestruct IHa as (? & ? & ?); eauto; subst.
      simpl; eauto.
Qed.

Lemma ghost_alloc: forall {RA: Ghost} a pp, ghost.valid a ->
  emp |-- bupd (EX g: gname, own g a pp).
Proof.
  intros.
  eapply derives_trans; [apply Own_unit|].
  apply exp_left; intro g0.
  apply prop_andp_left; intro Hg0.
  eapply derives_trans.
  - apply Own_update_ND with (B := fun b => exists g, b = singleton g (existT _ RA (exist _ _ H), pp)).
    intros ? c [? J]; exists (singleton (length c) (existT _ RA (exist _ _ H), pp)).
    split; eauto.
    rewrite (identity_core Hg0), ghost_core in J; inv J; [|eexists; constructor].
    rewrite ghost_fmap_singleton; eexists; apply singleton_join_gen.
    rewrite nth_overflow by auto; constructor.
  - apply bupd_mono, exp_left; intro g'.
    apply prop_andp_left; intros [g]; subst.
    apply exp_right with g.
    eapply exp_right; eauto.
Qed.

Lemma singleton_join: forall a b c k,
  join (singleton k a) (singleton k b) (singleton k c) <-> join a b c.
Proof.
  unfold singleton; induction k; simpl.
  - split.
    + inversion 1; subst.
      inv H3; auto.
    + intro; do 2 constructor; auto.
  - rewrite <- IHk.
    split; [inversion 1 | repeat constructor]; auto.
Qed.

Lemma singleton_join_inv: forall k a b c,
  join (singleton k a) (singleton k b) c -> exists c', join a b c' /\ c = singleton k c'.
Proof.
  unfold singleton; induction k; inversion 1; subst.
  - assert (m3 = nil) by (inv H6; auto).
    inv H5; eauto.
  - assert (a3 = None) by (inv H5; auto); subst.
    edestruct IHk as (? & ? & ?); eauto; subst; eauto.
Qed.

Lemma ghost_valid_2: forall {RA: Ghost} g a1 a2 pp,
  own g a1 pp * own g a2 pp |-- !!ghost.valid_2 a1 a2.
Proof.
  intros.
  intros w (? & ? & J%ghost_of_join & (? & ? & Hg1) & (? & ? & Hg2)).
  rewrite Hg1, Hg2, !ghost_fmap_singleton in J.
  apply singleton_join_inv in J as ([] & J & ?).
  inv J; simpl in *.
  inv H2; repeat inj_pair_tac.
  eexists; eauto.
Qed.

Lemma ghost_op: forall {RA: Ghost} g (a1 a2 a3: G) pp, join a1 a2 a3 ->
  own g a3 pp = own g a1 pp * own g a2 pp.
Proof.
  intros; apply pred_ext.
  - apply exp_left; intro.
    erewrite Own_op; [apply sepcon_derives; eapply exp_right; eauto|].
    apply singleton_join; constructor; constructor; auto.
  - eapply derives_trans; [apply andp_right, derives_refl; apply ghost_valid_2|].
    apply prop_andp_left; intros (? & J & ?).
    eapply join_eq in H; eauto; subst.
    unfold own; rewrite exp_sepcon1; apply exp_left; intro.
    rewrite exp_sepcon2; apply exp_left; intro.
    erewrite <- Own_op; [eapply exp_right; eauto|].
    apply singleton_join; constructor; constructor; auto.
  Unshelve.
  eapply join_valid; eauto.
  eapply join_valid; eauto.
  auto.
Qed.

Lemma ghost_valid: forall {RA: Ghost} g a pp,
  own g a pp |-- !!ghost.valid a.
Proof.
  intros.
  rewrite <- (normalize.andp_TT (!!_)).
  erewrite ghost_op by apply core_unit.
  eapply derives_trans; [apply andp_right, derives_refl; apply ghost_valid_2|].
  apply prop_andp_left; intros (? & J & ?); apply prop_andp_right; auto.
  apply core_identity in J; subst; auto.
Qed.

Lemma singleton_join_inv_gen: forall k a (b c: ghost),
  join (singleton k a) b c ->
  join (Some a) (nth k b None) (nth k c None) /\
    exists c', nth k c None = Some c' /\ c = list_set b k c'.
Proof.
  unfold singleton; induction k; inversion 1; subst; auto.
  - split; simpl; eauto; constructor.
  - split; auto.
    unfold list_set; simpl.
    rewrite <- (ghost_core m2) in H5.
    apply (core_identity m2) in H5; subst.
    inv H2; eauto.
  - rewrite app_nth2; rewrite repeat_length; auto.
    rewrite minus_diag; split; [constructor | simpl; eauto].
  - assert (a2 = a3) by (inv H2; auto).
    destruct (IHk _ _ _ H5) as (? & ? & ? & ?); subst; eauto.
Qed.

Lemma ghost_update_ND: forall {RA: Ghost} g (a: G) B pp,
  fp_update_ND a B -> own g a pp |-- bupd (EX b : _, !!(B b) && own g b pp).
Proof.
  intros.
  apply exp_left; intro Hva.
  eapply derives_trans.
  - apply Own_update_ND with
      (B := fun b => exists b' Hvb, B b' /\ b = singleton g (existT _ RA (exist _ b' Hvb), pp)).
    intros ?? [? J].
    rewrite ghost_fmap_singleton in J.
    destruct (singleton_join_inv_gen _ _ _ _ J) as [Jg _].
    inv Jg.
    + destruct (H (core a)) as (b & ? & Hv).
      { eexists; split; [apply join_comm, core_unit | auto]. }
      assert (ghost.valid b) as Hvb.
      { destruct Hv as (? & ? & ?); eapply join_valid; eauto. }
      exists (singleton g (existT _ RA (exist _ _ Hvb), pp)); split; eauto.
      rewrite ghost_fmap_singleton.
      eexists; apply singleton_join_gen.
      rewrite <- H2; constructor.
    + destruct a2, a3; inv H3; simpl in *.
      inv H0; inj_pair_tac.
      destruct (H b0) as (b & ? & Hv).
      { eexists; eauto. }
      destruct Hv as (? & ? & ?).
      assert (ghost.valid b) as Hvb by (eapply join_valid; eauto).
      exists (singleton g (existT _ RA (exist _ _ Hvb), pp)); split; eauto.
      rewrite ghost_fmap_singleton.
      eexists; apply singleton_join_gen.
      instantiate (1 := (_, _)).
      rewrite <- H1; constructor; constructor; [constructor|]; eauto.
  - apply bupd_mono, exp_left; intro.
    apply prop_andp_left; intros (b & ? & ? & ?); subst.
    apply exp_right with b, prop_andp_right; auto.
    eapply exp_right; auto.
  Unshelve.
  auto.
Qed.

Lemma ghost_update: forall {RA: Ghost} g (a b: G) pp,
  fp_update a b -> own g a pp |-- bupd (own g b pp).
Proof.
  intros; eapply derives_trans.
  - apply (ghost_update_ND g a (eq b)).
    intros ? J; destruct (H _ J).
    do 2 eexists; [constructor | eauto].
  - apply bupd_mono.
    apply exp_left; intro; apply prop_andp_left; intro X; inv X; auto.
Qed.

Lemma ghost_dealloc: forall {RA: Ghost} g a pp,
  own g a pp |-- bupd emp.
Proof.
  intros; unfold own.
  apply exp_left; intro; apply Own_dealloc.
Qed.

Lemma list_set_same : forall {A} n l (a : A), nth n l None = Some a ->
  list_set l n a = l.
Proof.
  unfold list_set; induction n; destruct l; simpl; try discriminate; intros; subst; auto.
  f_equal; eauto.
Qed.

(* The addition of ghost state means that there are rmaps that have only
   cores for ghost state, but are not cores themselves (since they have ghost
   state at all). An rmap of this sort is not emp, but is its own unit. *)

Definition cored: pred rmap := ALL P : pred rmap, ALL Q : pred rmap,
  P && Q --> P * Q.

Program Definition is_w w: pred rmap := fun w' => necR w w'.
Next Obligation.
Proof.
  repeat intro.
  eapply necR_trans; eauto.
  constructor; auto.
Qed.

Lemma cored_unit: forall w, cored w = join w w w.
Proof.
  intro; apply prop_ext; split; unfold cored; intro.
  - edestruct (H (is_w w) (is_w w)) as (? & ? & J & Hw1 & Hw2).
    { apply necR_refl. }
    { split; apply necR_refl. }
    simpl in *.
    destruct (join_level _ _ _ J).
    eapply necR_linear' in Hw1; try apply necR_refl; auto.
    eapply necR_linear' in Hw2; try apply necR_refl; auto.
    subst; auto.
  - intros P Q ?? [HP HQ].
    exists a', a'; repeat split; auto.
    eapply nec_join in H as (? & ? & ? & Hw1 & Hw2); eauto.
    destruct (join_level _ _ _ H).
    eapply necR_linear' in Hw1; try apply H0; [|lia].
    eapply necR_linear' in Hw2; try apply H0; [|lia].
    subst; auto.
Qed.

Lemma cored_dup: forall P, P && cored |-- (P && cored) * (P && cored).
Proof.
  intros.
  rewrite <- (andp_dup cored) at 1.
  rewrite <- andp_assoc.
  intros; unfold cored at 2.
  eapply modus_ponens.
  + apply andp_left1, derives_refl.
  + eapply andp_left2, allp_left, allp_left.
    rewrite andp_dup; apply derives_refl.
Qed.

Lemma cored_core: forall w, cored (core w).
Proof.
  intro; rewrite cored_unit.
  apply identity_unit', core_identity.
Qed.

Lemma cored_duplicable: cored = cored * cored.
Proof.
  apply pred_ext.
  - rewrite <- andp_dup at 1.
    eapply derives_trans; [apply cored_dup|].
    apply sepcon_derives; apply andp_left1; auto.
  - intros ? (? & ? & J & J1 & J2).
    rewrite cored_unit in *.
    destruct (join_assoc J1 J) as (? & J' & J1').
    eapply join_eq in J'; [|apply J]; subst.
    destruct (join_assoc J2 (join_comm J)) as (? & J' & J2').
    eapply join_eq in J'; [|apply join_comm, J]; subst.
    destruct (join_assoc (join_comm J1') (join_comm J2')) as (? & J' & ?).
    eapply join_eq in J'; [|apply J]; subst; auto.
Qed.

Lemma cored_emp: cored |-- bupd emp.
Proof.
  intro; rewrite cored_unit; intros J ??.
  exists nil; split; [eexists; constructor|].
  destruct (make_rmap (resource_at a) nil (level a)) as (m' & ? & Hr & Hg); auto.
  { intros; extensionality; apply resource_at_approx. }
  exists m'; repeat split; auto.
  apply all_resource_at_identity.
  - intro; rewrite Hr.
    apply (resource_at_join _ _ _ l) in J.
    inv J.
    + apply join_self, identity_share_bot in RJ; subst.
      apply NO_identity.
    + apply join_self, identity_share_bot in RJ; subst.
      contradiction shares.bot_unreadable.
    + apply PURE_identity.
  - rewrite Hg, <- (ghost_core nil); apply core_identity.
Qed.

Lemma emp_cored : emp |-- cored.
Proof.
  repeat intro; simpl in *.
  destruct H1.
  eapply nec_identity, identity_unit' in H; eauto.
Qed.

Lemma join_singleton_inv: forall k a b RA c v pp,
  join a b (singleton k (existT _ RA (exist _ (core c) v), pp)) ->
  a = singleton k (existT _ RA (exist _ (core c) v), pp) \/ b = singleton k (existT _ RA (exist _ (core c) v), pp).
Proof.
  induction k; unfold singleton; intros; simpl in *.
  - inv H; auto.
    assert (m1 = nil /\ m2 = nil) as [] by (inv H5; auto); subst.
    inv H4; auto.
    destruct a0, a3; inv H2; simpl in *.
    inv H0; inv H.
    inj_pair_tac.
    pose proof (core_unit a0) as J.
    erewrite join_core, core_idem in J by eauto.
    unfold unit_for in J.
    eapply join_positivity in J; eauto; subst.
    left; repeat f_equal; apply proof_irr.
  - inv H; auto.
    edestruct IHk as [|]; eauto; [left | right]; f_equal; auto; inv H4; auto.
Qed.

Lemma own_cored: forall {RA: Ghost} g a pp, join a a a -> own g a pp |-- cored.
Proof.
  intros; intros ? (? & ? & Hg).
  rewrite cored_unit; simpl in *.
  apply resource_at_join2; auto.
  - intro; apply identity_unit'.
    eapply necR_resource_at_identity; eauto.
  - rewrite Hg, ghost_fmap_singleton.
    apply singleton_join; repeat constructor; auto.
Qed.

Require Import VST.veric.tycontext.
Require Import VST.veric.Clight_seplog.

Lemma own_super_non_expansive: forall {RA: Ghost} n g a pp,
  approx n (own g a pp) = approx n (own g a (preds_fmap (approx n) (approx n) pp)).
Proof.
  intros; unfold own.
  rewrite !approx_exp; f_equal; extensionality v.
  unfold Own.
  rewrite !approx_andp; f_equal.
  apply pred_ext; intros ? [? Hg]; split; auto; simpl in *.
  - rewrite <- ghost_of_approx, Hg.
    rewrite !ghost_fmap_singleton, !preds_fmap_fmap.
    rewrite approx_oo_approx, approx_oo_approx', approx'_oo_approx by lia; auto.
  - rewrite ghost_fmap_singleton in *.
    rewrite preds_fmap_fmap in Hg.
    rewrite approx_oo_approx', approx'_oo_approx in Hg by lia; auto.
Qed.