Require Import Arith.
Require Import List.
Import ListNotations.
Require Import Omega.

Require Import v1.Util.
Require Import v1.ListLemmas.
Require Import v1.EpicsTypes.
Require Import v1.EpicsRecords.
Require Import v1.Step.
Require Import v1.NeutronTactics.

Set Default Timeout 10.
Set Implicit Arguments.

Definition is_db_op op :=
    match op with
    | MSetConst _ _ => true
    | MCopy _ _ _ _ => true
    | MReadLink _ _ _ _ => true
    | MWriteLink _ _ _ _ => true
    | MCalculate _ _ => true
    | MCalculateStr _ _ _ => true
    | MHavocUpdate => true
    | MHavocWrite _ _ => true
    | _ => false
    end.

Definition is_output_op op :=
    match op with
    | MHwWrite _ _ _ => true
    | MScheduleCallback _ _ => true
    | _ => false
    end.

Definition is_special_op op :=
    match op with
    | MProcess _ => true
    | MCalcCond _ _ _ _ => true
    | MCheckPACT => true
    | MHavocProcess _ => true
    | _ => false
    end.

Definition micro_rect_g (P : micro -> Type) (Pl : list micro -> Type) :
    (forall fn val, P (MSetConst fn val)) ->
    (forall fn_src src_ty fn_dest dest_ty, P (MCopy fn_src src_ty fn_dest dest_ty)) ->
    (forall il il_ty fn f_ty, P (MReadLink il il_ty fn f_ty)) ->
    (forall fn f_ty ol ol_ty, P (MWriteLink fn f_ty ol ol_ty)) ->
    (forall fl, P (MProcess fl)) ->
    (forall expr fn_out, P (MCalculate expr fn_out)) ->
    (forall expr fn_out_dbl fn_out_str, P (MCalculateStr expr fn_out_dbl fn_out_str)) ->
    (forall fn f_ty out_ty, P (MHwWrite fn f_ty out_ty)) ->
    (forall fn_cur fn_prev oopt body,
        Pl body ->
        P (MCalcCond fn_cur fn_prev oopt body)) ->
    (forall delay code,
        Pl code ->
        P (MScheduleCallback delay code)) ->
    (P (MCheckPACT)) ->
    (P (MHavocUpdate)) ->
    (forall ol ol_ty, P (MHavocWrite ol ol_ty)) ->
    (forall fl, P (MHavocProcess fl)) ->
    (Pl []) ->
    (forall op ops,
        P op ->
        Pl ops ->
        Pl (op :: ops)) ->
    (forall op, P op).
intros. generalize op. clear op. fix 1.
simple refine (
    let fix micro_list_rect_g ops : Pl ops :=
        match ops as ops_ return Pl ops_ with
        | [] => _
        | op :: ops =>
                let Hop := micro_rect_g op in
                let Hops := micro_list_rect_g ops in
                _
        end in _
).
{ clear micro_rect_g micro_list_rect_g. assumption. }
{ clearbody Hop Hops. clear micro_rect_g micro_list_rect_g. eauto. }
clearbody micro_list_rect_g. clear micro_rect_g.

destruct op; eauto.
Defined.

Definition micro_list_rect_g (P : micro -> Type) (Pl : list micro -> Type) :
    (forall fn val, P (MSetConst fn val)) ->
    (forall fn_src src_ty fn_dest dest_ty, P (MCopy fn_src src_ty fn_dest dest_ty)) ->
    (forall il il_ty fn f_ty, P (MReadLink il il_ty fn f_ty)) ->
    (forall fn f_ty ol ol_ty, P (MWriteLink fn f_ty ol ol_ty)) ->
    (forall fl, P (MProcess fl)) ->
    (forall expr fn_out, P (MCalculate expr fn_out)) ->
    (forall expr fn_out_dbl fn_out_str, P (MCalculateStr expr fn_out_dbl fn_out_str)) ->
    (forall fn f_ty out_ty, P (MHwWrite fn f_ty out_ty)) ->
    (forall fn_cur fn_prev oopt body,
        Pl body ->
        P (MCalcCond fn_cur fn_prev oopt body)) ->
    (forall delay code,
        Pl code ->
        P (MScheduleCallback delay code)) ->
    (P (MCheckPACT)) ->
    (P (MHavocUpdate)) ->
    (forall ol ol_ty, P (MHavocWrite ol ol_ty)) ->
    (forall fl, P (MHavocProcess fl)) ->
    (Pl []) ->
    (forall op ops,
        P op ->
        Pl ops ->
        Pl (op :: ops)) ->
    (forall ops, Pl ops).
intros. generalize ops. clear ops. fix 1. intros.
simple refine (
    match ops as ops_ return Pl ops_ with
    | [] => _
    | op :: ops =>
            let Hop : P op := _ in
            let Hops : Pl ops := micro_list_rect_g ops in
            _
    end
); try clearbody Hops; clear micro_list_rect_g.
- eassumption.
- eapply micro_rect_g; eassumption.
- eauto.
Defined.

Definition micro_rec' (P : micro -> Set) (Pl : list micro -> Set) :=
    micro_rect_g P Pl.

Definition micro_ind' (P : micro -> Prop) (Pl : list micro -> Prop) :=
    micro_rect_g P Pl.

Definition micro_list_ind' (P : micro -> Prop) (Pl : list micro -> Prop) :=
    micro_list_rect_g P Pl.

Definition micro_ind'' (P : micro -> Prop) :
    (forall fn val, P (MSetConst fn val)) ->
    (forall fn_src src_ty fn_dest dest_ty, P (MCopy fn_src src_ty fn_dest dest_ty)) ->
    (forall il il_ty fn f_ty, P (MReadLink il il_ty fn f_ty)) ->
    (forall fn f_ty ol ol_ty, P (MWriteLink fn f_ty ol ol_ty)) ->
    (forall fl, P (MProcess fl)) ->
    (forall expr fn_out, P (MCalculate expr fn_out)) ->
    (forall expr fn_out_dbl fn_out_str, P (MCalculateStr expr fn_out_dbl fn_out_str)) ->
    (forall fn f_ty out_ty, P (MHwWrite fn f_ty out_ty)) ->
    (forall fn_cur fn_prev oopt body,
        Forall P body ->
        P (MCalcCond fn_cur fn_prev oopt body)) ->
    (forall delay code,
        Forall P code ->
        P (MScheduleCallback delay code)) ->
    (P (MCheckPACT)) ->
    (P (MHavocUpdate)) ->
    (forall ol ol_ty, P (MHavocWrite ol ol_ty)) ->
    (forall fl, P (MHavocProcess fl)) ->
    (forall op, P op).
intros. eapply micro_ind' with (Pl := Forall P); eauto.
Defined.

Definition umicro_rec' (P : umicro -> Type) (Pl : list umicro -> Type) :
    (forall fn val, P (USetConst fn val)) ->
    (forall fn_src fn_dest, P (UCopy fn_src fn_dest)) ->
    (forall il fn, P (UReadLink il fn)) ->
    (forall fn ol, P (UWriteLink fn ol)) ->
    (forall fns ol, P (UWriteLinkTyped fns ol)) ->
    (forall fl, P (UProcess fl)) ->
    (forall expr fn_out, P (UCalculate expr fn_out)) ->
    (forall expr fn_out_dbl fn_out_str, P (UCalculateStr expr fn_out_dbl fn_out_str)) ->
    (forall fn out_ty, P (UHwWrite fn out_ty)) ->
    (forall fn_cur fn_prev oopt body,
        Pl body ->
        P (UCalcCond fn_cur fn_prev oopt body)) ->
    (forall delay code,
        Pl code ->
        P (UScheduleCallback delay code)) ->
    (P (UCheckPACT)) ->
    (P (UHavocUpdate)) ->
    (forall ol, P (UHavocWrite ol)) ->
    (forall fl, P (UHavocProcess fl)) ->
    (Pl []) ->
    (forall op ops,
        P op ->
        Pl ops ->
        Pl (op :: ops)) ->
    (forall op, P op).
intros. generalize op. clear op. fix 1.
simple refine (
    let fix umicro_rec'_list ops : Pl ops :=
        match ops as ops_ return Pl ops_ with
        | [] => _
        | op :: ops =>
                let Hop := umicro_rec' op in
                let Hops := umicro_rec'_list ops in
                _
        end in _
).
{ clear umicro_rec' umicro_rec'_list. assumption. }
{ clearbody Hop Hops. clear umicro_rec' umicro_rec'_list. eauto. }
clearbody umicro_rec'_list. clear umicro_rec'.

destruct op; eauto.
Defined.

Inductive MicroForall (P : micro -> Prop) : micro -> Prop:=
| MfCalcCond : forall fn_cur fn_prev oopt body,
        P (MCalcCond fn_cur fn_prev oopt body) ->
        Forall (MicroForall P) body ->
        MicroForall P (MCalcCond fn_cur fn_prev oopt body)
| MfScheduleCallback : forall delay code,
        P (MScheduleCallback delay code) ->
        Forall (MicroForall P) code ->
        MicroForall P (MScheduleCallback delay code)
| MfOther : forall op,
        match op with
        | MCalcCond _ _ _ _ => False
        | MScheduleCallback _ _ => False
        | _ => True
        end ->
        P op ->
        MicroForall P op.

Lemma forall_one : forall P op,
    MicroForall P op ->
    P op.
inversion 1; auto.
Qed.

Definition type_umicro_list dbt rt :=
    let go := type_umicro dbt rt in
    let fix go_list uops : option (list micro) :=
        match uops with
        | [] => Some []
        | uop :: uops =>
                go uop >>= fun uop' =>
                go_list uops >>= fun uops' =>
                Some (uop' :: uops')
        end in go_list.

Inductive type_error_context :=
| TCtxRecord (rn : record_name)
| TCtxOpcode (uop : umicro)
.

Inductive type_error :=
| TyENoSuchRecord (rn : record_name)
| TyENoTypedField (fns : list (field_type_matcher * field_name)) (ty : field_type)
| TyEInContext (ctx : type_error_context) (e : type_error)
| TyEMultipleErrors (e1 e2 : type_error)
.

Definition type_umicro_checked (dbt : database_type) (rt : record_type) :
    umicro -> unit + type_error.
simple refine (
    let fix go (uop : umicro) : unit + type_error :=
        let fix go_list (uops : list umicro) : unit + type_error :=
            match uops with
            | [] => inl tt
            | uop :: uops =>
                match go uop, go_list uops with
                | inl tt, inl tt => inl tt
                | inr e, inl tt => inr e
                | inl tt, inr e => inr e
                | inr e1, inr e2 => inr (TyEMultipleErrors e1 e2)
                end
            end in
        let ctx := TCtxOpcode uop in
        match uop with
        | USetConst fn val => inl tt
        | UCopy fn_src fn_dest => inl tt
        | UReadLink il fn => _
        | UWriteLink fn ol => _
        | UWriteLinkTyped fns ol => _
        | UProcess fl => inl tt
        | UCalculate expr fn_out => inl tt
        | UCalculateStr expr fn_out_dbl fn_out_str => inl tt
        | UHwWrite fn out_ty => inl tt
        | UCalcCond fn_cur fn_prev oopt body => go_list body
        | UScheduleCallback delay code => go_list code
        | UCheckPACT => inl tt
        | UHavocUpdate => inl tt
        | UHavocWrite ol => _
        | UHavocProcess fl => inl tt
        end in go
); try clearbody go; try clearbody go_list.

- (* ReadLink *)
  destruct (lookup_type dbt (fl_rn il)); [ | right; exact (TyENoSuchRecord (fl_rn il)) ].
  exact (inl tt).

- (* WriteLink *)
  destruct (lookup_type dbt (fl_rn ol)); [ | right; exact (TyENoSuchRecord (fl_rn ol)) ].
  exact (inl tt).

- (* WriteLinkTyped *)
  destruct (lookup_type dbt (fl_rn ol)) as [ol_rt | ];
          [ | right; exact (TyENoSuchRecord (fl_rn ol)) ].
  set (ty := record_field_type ol_rt (fl_fn ol)).
  destruct (find_match_for_type fns ty);
        [ | right; exact (TyENoTypedField fns ty) ].
  exact (inl tt).

- (* HavocWrite *)
  destruct (lookup_type dbt (fl_rn ol)); [ | right; exact (TyENoSuchRecord (fl_rn ol)) ].
  exact (inl tt).
Defined.

Definition map_checked {A} (f : A -> unit + type_error) : list A -> unit + type_error.
simple refine (
    let go := f in
    let fix go_list (xs : list A) : unit + type_error :=
        match xs with
        | [] => inl tt
        | x :: xs =>
                match go x, go_list xs with
                | inl tt, inl tt => inl tt
                | inr e, inl tt => inr e
                | inl tt, inr e => inr e
                | inr e1, inr e2 => inr (TyEMultipleErrors e1 e2)
                end
        end in go_list
).
Defined.

Definition type_record_uprogram_checked dbt urp : unit + type_error :=
    map_checked (type_umicro_checked dbt (ru_type urp)) (ru_code urp).

Definition check_numbered_record {A} (f : A -> unit + type_error) (nx : nat * A) :
        unit + type_error :=
    let '(n, x) := nx in
    match f x with
    | inl tt => inl tt
    | inr err => inr (TyEInContext (TCtxRecord n) err)
    end.

Definition type_database_program'_checked dbt udp :=
    map_checked (check_numbered_record (type_record_uprogram_checked dbt)) (numbered udp).

Definition type_database_program_checked udp :=
    type_database_program'_checked (map ru_type udp) udp.

Inductive results_match {A : Type} :
    (option A) ->
    (unit + type_error) ->
    Prop :=
| RmYes : forall x, results_match (Some x) (inl tt)
| RmNo : forall err, results_match None (inr err).

Lemma results_match_chain : forall A B x y
    (f : option A -> option B)
    (g : unit + type_error -> unit + type_error),
    (forall x, exists x', f (Some x) = Some x') ->
    (f None = None) ->
    (g (inl tt) = inl tt) ->
    (forall y, exists y', g (inr y) = inr y') ->
    results_match x y ->
    results_match (f x) (g y).
intros0 Hf Hf' Hg Hg' Hrm.

invc Hrm.
- destruct (Hf x0) as [? Hf_x]. rewrite Hf_x, Hg. constructor.
- destruct (Hg' err) as [? Hg'_y]. rewrite Hf', Hg'_y. constructor.
Qed.

Lemma results_match_chain' : forall A B
        (x1 : option A) (x2 : option B)
        (y1 y2 : unit + type_error),
    (forall x, x1 = Some x -> exists x', x2 = Some x') ->
    (x1 = None -> x2 = None) ->
    (y1 = inl tt -> y2 = inl tt) ->
    (forall y, y1 = inr y -> exists y', y2 = inr y') ->
    results_match x1 y1 ->
    results_match x2 y2.
intros0 Hx Hx' Hy Hy' Hrm.

invc Hrm.
- destruct (Hx x) as [? Hx_x]; auto. rewrite Hx_x, Hy; auto. constructor.
- destruct (Hy' err) as [? Hy'_y]; auto. rewrite Hx', Hy'_y; auto. constructor.
Qed.

Lemma results_match_chain_l : forall A B x y
    (f : option A -> option B),
    (forall x, exists x', f (Some x) = Some x') ->
    (f None = None) ->
    results_match x y ->
    results_match (f x) y.
intros. change y with (id y). eapply results_match_chain; eauto.
unfold id. eauto.
Qed.

Lemma results_match_chain_r : forall A (x : option A) y
    (g : unit + type_error -> unit + type_error),
    (g (inl tt) = inl tt) ->
    (forall y, exists y', g (inr y) = inr y') ->
    results_match x y ->
    results_match x (g y).
intros. change x with (id x). eapply results_match_chain; eauto.
unfold id. eauto.
Qed.

(* `remvar` ("remember as evar") - replaces a chunk of your goal with an evar,
   This may make it easier to apply some lemmas.  After solving the main goal,
   you must also prove that the evar's instantiation is compatible with the
   original value.
 *)

Tactic Notation "remvar" uconstr(u) "as" ident(x) :=
    let x' := fresh x "'" in
    let Heq := fresh "Heq" x in
    remember u as x' eqn:Heq in |- *;
    let T := type of x' in
    evar (x : T);
    let H := fresh "H" in
    assert (H : x' = x); cycle 1;
    unfold x in *; clear x;
    [ rewrite H in Heq |- *; clear H
    | rewrite Heq; clear Heq; clear x' ].

Ltac lift xx :=
    let T := type of xx in
    let switch old new_f :=
        let new_f' := eval cbv beta in new_f in
        (change old with (new_f' xx)) in

    match goal with
    | [ |- context [?f (?fx xx) ?b ?c ?d ?e] ] =>
            switch (f (fx xx) b c d e) (fun x : T => f (fx x) b c d e)
    | [ |- context [?f ?a (?fx xx) ?c ?d ?e] ] =>
            switch (f a (fx xx) c d e) (fun x : T => f a (fx x) c d e)
    | [ |- context [?f ?a ?b (?fx xx) ?d ?e] ] =>
            switch (f a b (fx xx) d e) (fun x : T => f a b (fx x) d e)
    | [ |- context [?f ?a ?b ?c (?fx xx) ?e] ] =>
            switch (f a b c (fx xx) e) (fun x : T => f a b c (fx x) e)
    | [ |- context [?f ?a ?b ?c ?d (?fx xx)] ] =>
            switch (f a b c d (fx xx)) (fun x : T => f a b c d (fx x))

    | [ |- context [?f (?fx xx) ?b ?c ?d] ] =>
            switch (f (fx xx) b c d) (fun x : T => f (fx x) b c d)
    | [ |- context [?f ?a (?fx xx) ?c ?d] ] =>
            switch (f a (fx xx) c d) (fun x : T => f a (fx x) c d)
    | [ |- context [?f ?a ?b (?fx xx) ?d] ] =>
            switch (f a b (fx xx) d) (fun x : T => f a b (fx x) d)
    | [ |- context [?f ?a ?b ?c (?fx xx)] ] =>
            switch (f a b c (fx xx)) (fun x : T => f a b c (fx x))

    | [ |- context [?f (?fx xx) ?b ?c] ] =>
            switch (f (fx xx) b c) (fun x : T => f (fx x) b c)
    | [ |- context [?f ?a (?fx xx) ?c] ] =>
            switch (f a (fx xx) c) (fun x : T => f a (fx x) c)
    | [ |- context [?f ?a ?b (?fx xx)] ] =>
            switch (f a b (fx xx)) (fun x : T => f a b (fx x))

    | [ |- context [?f (?fx xx) ?b] ] =>
            switch (f (fx xx) b) (fun x : T => f (fx x) b)
    | [ |- context [?f ?a (?fx xx)] ] =>
            switch (f a (fx xx)) (fun x : T => f a (fx x))

    | [ |- context [?f (?fx xx)] ] =>
            switch (f (fx xx)) (fun x : T => f (fx x))

    | [ |- context [xx] ] =>
            switch (xx) (fun x : T => x)
    end.

Lemma type_umicro_checked_correct : forall dbt rt uop,
    results_match (type_umicro dbt rt uop) (type_umicro_checked dbt rt uop).
intros dbt rt.
induction uop using umicro_rec' with
    (Pl := fun uops =>
        results_match
            (type_umicro_list dbt rt uops)
            (map_checked (type_umicro_checked dbt rt) uops));
simpl;
fold (type_umicro_list dbt rt);
fold (map_checked (type_umicro_checked dbt rt));
try solve [constructor; discriminate 1 || eauto].

- destruct (lookup_type _ _); simpl;
  constructor; discriminate 1 || eauto.

- destruct (lookup_type _ _); simpl;
  constructor; discriminate 1 || eauto.

- destruct (lookup_type _ _); simpl;
  [ destruct (find_match_for_type _ _); simpl | ];
  constructor; discriminate 1 || eauto.

- do 2 lift (type_umicro_list dbt rt body).
  eapply results_match_chain_l with (3 := IHuop); simpl; eauto.

- do 2 lift (type_umicro_list dbt rt code).
  eapply results_match_chain_l with (3 := IHuop); simpl; eauto.

- destruct (lookup_type _ _); simpl;
  constructor; discriminate 1 || eauto.

- unfold bind_option.
  invc IHuop; invc IHuop0; simpl; constructor.

Qed.

Lemma map_checked_correct : forall A B (f : A -> option B) f' xs,
    (forall x, results_match (f x) (f' x)) ->
    results_match (map_opt f xs) (map_checked f' xs).
induction xs; intros0 Hrm.
- constructor; simpl; intros; discriminate || eauto.
- specialize (IHxs Hrm). rename a into x. specialize (Hrm x).
  simpl. unfold bind_option.
  invc Hrm; invc IHxs; simpl; constructor.
Qed.

Lemma type_record_uprogram_checked_correct : forall dbt urp,
    results_match (type_record_uprogram dbt urp)
                  (type_record_uprogram_checked dbt urp).
intros. unfold type_record_uprogram, type_record_uprogram_checked.
do 2 lift (map_opt (type_umicro dbt (ru_type urp)) (ru_code urp)).
eapply results_match_chain_l; simpl; eauto.
eapply map_checked_correct. eapply type_umicro_checked_correct.
Qed.

(*
Lemma chain_map_checked_numbered' : forall A B (f : A -> option B) f' xs n,
    results_match (map_opt f xs) (map_checked f' xs) ->
    results_match (map_opt f xs) (map_checked (check_numbered_record f') (numbered' n xs)).
induction xs; intros0 Hrm.
- constructor; simpl; intros; discriminate || eauto.
- simpl in *; unfold bind_option in *.
  destruct (f a), (map_opt f xs),
    (f' a), (map_checked f' xs) eqn:?, (map_checked _ (numbered' _ xs)) eqn:?;
    (repeat on unit, fun H => destruct H); try econstructor; invc Hrm.
  + specialize (IHxs (S n) ltac:(constructor)). rewrite Heqs0 in IHxs. invc IHxs.
  + specialize (IHxs (S n) ltac:(constructor)). rewrite Heqs0 in IHxs. invc IHxs.
  + specialize (IHxs (S n) ltac:(constructor)). rewrite Heqs0 in IHxs. invc IHxs.
  +
    try destruct u; try destruct u0; try try discriminate.
  destruct (f a), (f' a); try destruct u.
  Focus 2.
  eapply

  + destruct (f a), (map_opt f xs), (f' a), (map_checked f' xs);
      try destruct u; try destruct u0; try discriminate.
    specialize (IHxs (S n) ltac:(constructor)). invc IHxs.
    econstructor.

  + destruct (f a), (map_opt f xs), (f' a), (map_checked f' xs);
      try destruct u; try destruct u0; try discriminate.
    all: try (specialize (IHxs (S n) ltac:(constructor)); invc IHxs; constructor).
    econstructor.

simpl in *. unfold bind_option in *.
destruct (f a) eqn:?, (f' a) eqn:?; try destruct u.
destruct (map_opt f xs), (map_checked _ _); try destruct u.
  *)

Lemma map_checked_numbered'_inl : forall A (f : A -> _) xs n,
    map_checked f xs = inl tt ->
    map_checked (check_numbered_record f) (numbered' n xs) = inl tt.
induction xs; intros0 Hmap; simpl in *.  { auto. }
destruct (f a), (map_checked f xs) eqn:?;
(repeat on unit, fun H => destruct H); try discriminate.
rewrite IHxs; eauto.
Qed.

Lemma map_checked_numbered_inl : forall A (f : A -> _) xs,
    map_checked f xs = inl tt ->
    map_checked (check_numbered_record f) (numbered xs) = inl tt.
unfold numbered. intros. eapply map_checked_numbered'_inl; eauto.
Qed.

Lemma map_checked_numbered'_inr : forall A (f : A -> _) xs n err,
    map_checked f xs = inr err ->
    exists err',
        map_checked (check_numbered_record f) (numbered' n xs) = inr err'.
induction xs; intros0 Hmap; simpl in *.  { discriminate. }
destruct (f a), (map_checked f xs) eqn:?;
(repeat on unit, fun H => destruct H); try discriminate.
- destruct (IHxs (S n) ?? ***) as (? & Heq). rewrite Heq. eauto.
- break_match; try destruct u; eauto.
- break_match; try destruct u; eauto.
Qed.

Lemma map_checked_numbered_inr : forall A (f : A -> _) xs err,
    map_checked f xs = inr err ->
    exists err',
        map_checked (check_numbered_record f) (numbered xs) = inr err'.
unfold numbered. intros. eapply map_checked_numbered'_inr; eauto.
Qed.

Lemma type_database_program'_checked_correct : forall dbt udp,
    results_match (type_database_program' dbt udp)
                  (type_database_program'_checked dbt udp).
intros. unfold type_database_program', type_database_program'_checked.
assert (HH : results_match
        (map_opt (type_record_uprogram dbt) udp)
        (map_checked (type_record_uprogram_checked dbt) udp)).
  { eapply map_checked_correct. eapply type_record_uprogram_checked_correct. }

eapply results_match_chain' with (5 := HH); eauto.
- eapply map_checked_numbered_inl.
- eapply map_checked_numbered_inr.
Qed.

Lemma type_database_program_checked_correct : forall udp,
    results_match (type_database_program udp)
                  (type_database_program_checked udp).
intros. unfold type_database_program, type_database_program_checked.
eapply type_database_program'_checked_correct.
Qed.

Definition unwrap_matched_results {A} x y :
    @results_match A x y ->
    A + type_error.
intro Hrm.
refine (
    match x as x_, y as y_ return x = x_ -> y = y_ -> _ with
    | Some val, inl tt => fun _ _ => inl val
    | None, inr err => fun _ _ => inr err
    | _, _ => fun Heq1 Heq2 => _
    end eq_refl eq_refl
); hide; exfalso; subst; invc Hrm.
Defined.
Implicit Arguments unwrap_matched_results [A].

Lemma unwrap_matched_results_inl : forall A x y pf val,
    @unwrap_matched_results A x y pf = inl val ->
    x = Some val.
intros0 Hunwrap.
unfold unwrap_matched_results in Hunwrap.
destruct x, y; (repeat on unit, fun u => destruct u); try solve [discriminate | invc pf].
congruence.
Qed.

Definition type_database_program_with_check udp :=
    unwrap_matched_results
        (type_database_program udp)
        (type_database_program_checked udp)
        ltac:(eauto using type_database_program_checked_correct).

Lemma type_database_program_with_check_inl_eq udp dbp :
    type_database_program_with_check udp = inl dbp ->
    type_database_program udp = Some dbp.
unfold type_database_program_with_check. eapply unwrap_matched_results_inl.
Qed.


(**
 Verified SAR-BP: A verified C implementation of SAR backprojection
 with a certified absolute error bound.

 Version 1.0 (2015-12-04)

 Copyright (C) 2015 Reservoir Labs Inc.
 All rights reserved.

 This file is free software. You can redistribute it and/or modify it
 under the terms of the GNU General Public License as published by the
 Free Software Foundation, either version 3 of the License (GNU GPL
 v3), or (at your option) any later version.  A verbatim copy of the
 GNU GPL v3 is included in gpl-3.0.txt.

 This file is distributed in the hope that it will be useful, but
 WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See LICENSE for
 more details about the use and redistribution of this file and the
 whole Verified SAR-BP library.

 This work is sponsored in part by DARPA MTO as part of the Power
 Efficiency Revolution for Embedded Computing Technologies (PERFECT)
 program (issued by DARPA/CMO under Contract No: HR0011-12-C-0123). The
 views and conclusions contained in this work are those of the authors
 and should not be interpreted as representing the official policies,
 either expressly or implied, of the DARPA or the
 U.S. Government. Distribution Statement "A" (Approved for Public
 Release, Distribution Unlimited.)

 If you are using or modifying Verified SAR-BP in your work, please
 consider citing the following paper:

 Tahina Ramananandro, Paul Mountcastle, Benoit Meister and Richard
 Lethin.
 A Unified Coq Framework for Verifying C Programs with Floating-Point
 Computations.
 In CPP (5th ACM/SIGPLAN conference on Certified Programs and Proofs)
 2016.

 Verified SAR-BP derives from prior work listed in ACKS along with
 their copyright and licensing information.

 Verified SAR-BP requires third-party libraries listed in ACKS along
 with their copyright information.
*)
(**
Author: Tahina Ramananandro <ramananandro@reservoir.com>

Bounds for small images. Those bounds have been extracted from the
DARPA PERFECT suite ( http://hpc.pnl.gov/PERFECT/ )
*)

Require Import ZArith RAux.
Require Flocq.Core.Fcore_Raux.
Definition abs_data_border: R := (16231879/4294967296)%R .
Definition abs_data_min: R := (6115167/4503599627370496)%R .
Definition abs_data_max: R := (4194091/4194304)%R .
Definition abs_data_dist: R := (2873621/16777216)%R .

Definition platpos_x_min: R := (7227795/1024)%R .
Definition platpos_x_max: R := (14481547/2048)%R.

Definition platpos_y_min: R := (0)%R .
Definition platpos_y_max: R := (13866841/32768)%R.

Definition platpos_z_min: R := (14481547/2048)%R .
Definition platpos_z_max: R := (14481547/2048)%R.

Definition dxdy := Eval compute in (4503599627370496 * / Fcore_Raux.Z2R (2 ^ 54))%R.
Definition dR := Eval compute in (4503599627370496 * / Fcore_Raux.Z2R (2 ^ 57))%R.
Definition N_PULSES := (512)%nat .
Definition N_RANGE := (512)%Z .
Definition N_RANGE_UPSAMPLED := (4096)%Z .
Definition BP_NPIX_Y := (512)%nat .
Definition BP_NPIX_X := (512)%nat .
Definition ku := Eval compute in (7368997658362958 * / Fcore_Raux.Z2R (2 ^ 45))%R.
(*
Definition z0 := Eval compute in (0 * / R_of_Z (2 ^ 1074))%R.
*)
Definition z0_low := 0%R.
Definition z0_high := 0%R.
Definition R0 := Eval compute in (5462373766791168 * / Fcore_Raux.Z2R (2 ^ 39))%R.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableWalk.Spec.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition data_destroy_spec0 (g_rd: Pointer) (map_addr: Z64) (adt: RData) : option (RData * Z64) :=
    match g_rd, map_addr with
    | (_g_rd_base, _g_rd_ofst), VZ64 _map_addr =>
      rely is_int (4 - 1);
      rely is_int64 _map_addr;
      rely is_int64 (4 - 1);
      when adt == table_walk_lock_unlock_spec (_g_rd_base, _g_rd_ofst) (VZ64 _map_addr) (VZ64 (4 - 1)) adt;
      when'' _g_llt_base, _g_llt_ofst == get_wi_g_llt_spec  adt;
      rely is_int _g_llt_ofst;
      when' _index == get_wi_index_spec  adt;
      rely is_int64 _index;
      when _t'7 == is_null_spec (_g_llt_base, _g_llt_ofst) adt;
      rely is_int _t'7;
      if (_t'7 =? 1) then
        let _ret := 1 in
        Some (adt, (VZ64 _ret))
      else
        when'' _ll_table_base, _ll_table_ofst, adt == granule_map_spec (_g_llt_base, _g_llt_ofst) 5 adt;
        rely is_int _ll_table_ofst;
        when' _pte_val == pgte_read_spec (_ll_table_base, _ll_table_ofst) (VZ64 _index) adt;
        rely is_int64 _pte_val;
        rely is_int64 (Z.land _pte_val 504403158265495552);
        rely is_int64 ((Z.land _pte_val 504403158265495552) / 72057594037927936);
        let _ipa_state := ((Z.land _pte_val 504403158265495552) / 72057594037927936) in
        if (negb (_ipa_state =? 1)) then
          let _ret := 1 in
          when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
          when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
          Some (adt, (VZ64 _ret))
        else
          rely is_int64 (Z.land _pte_val 281474976706560);
          let _data_addr := (Z.land _pte_val 281474976706560) in
          rely is_int64 _data_addr;
          when'' _g_data_base, _g_data_ofst, adt == find_lock_granule_spec (VZ64 _data_addr) (VZ64 4) adt;
          rely is_int _g_data_ofst;
          when _t'6 == is_null_spec (_g_data_base, _g_data_ofst) adt;
          rely is_int _t'6;
          if (_t'6 =? 1) then
            let _ret := 1 in
            when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
            when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
            Some (adt, (VZ64 _ret))
          else
            rely is_int64 (3 * 72057594037927936);
            let _pte_val := (3 * 72057594037927936) in
            when adt == pgte_write_spec (_ll_table_base, _ll_table_ofst) (VZ64 _index) (VZ64 _pte_val) adt;
            when adt == granule_put_spec (_g_llt_base, _g_llt_ofst) adt;
            when adt == granule_memzero_spec (_g_data_base, _g_data_ofst) 1 adt;
            when adt == granule_set_state_spec (_g_data_base, _g_data_ofst) 1 adt;
            when adt == granule_unlock_spec (_g_data_base, _g_data_ofst) adt;
            let _ret := 0 in
            when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
            when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
            Some (adt, (VZ64 _ret))
     end
    .

End SpecLow.


Require Import Target.
Require Import Shape.
Require Import Compiler.

(* _____________________________________
                  SYNTAX
   _____________________________________ *)

Inductive origin : Type :=
  | ContextOrigin : origin
  | ProgramOrigin : origin.

Inductive external_action : Type :=
  | ExtCall : component_id -> procedure_id -> registers ->
    external_action
  | ExtRet : registers -> external_action
  | End : external_action.

Notation "✓" := (End).

Inductive internal_action : Type :=
  | IntTau : internal_action
  | IntCall : component_id -> procedure_id -> internal_action
  | IntRet : internal_action.

Inductive action : Type :=
  | Ext : external_action -> origin -> action
  | Int : internal_action -> origin -> action.

Definition trace : Type := list action.

(* _____________________________________
                  STATES
   _____________________________________ *)

Definition sigma :=
  list (component_id * nat).

Definition A_sigma :=
  list (component_id).

Inductive alt_list (A B : Type) : Type :=
  | alt_init : A -> alt_list A B
  | alt_cons : A -> alt_list B A -> alt_list A B.

Definition A_SIGMA : Type :=
  alt_list A_sigma sigma.

Definition P_SIGMA : Type :=
  alt_list sigma A_sigma.

Definition program_state : Type :=
  (component_id *
   P_SIGMA *
   global_memory *
   registers *
   address).

Definition context_state : Type :=
  (component_id *
   A_SIGMA *
   global_memory).

Inductive state_partial_view : Type :=
  | ProgramControl : program_state -> state_partial_view
  | ContextControl : context_state -> state_partial_view
  | EXITED.

(* ------- Definitions : Extra notations ------- *)

Definition Top {A B : Type} (E:alt_list A B) : A :=
  match E with
  | alt_init _ _ h => h
  | alt_cons _ _ h t => h
  end.

Definition SetTop {A B : Type} (E:alt_list A B) (new:A)
  : alt_list A B :=
  match E with
  | alt_init _ _ h => alt_init A B new
  | alt_cons _ _ h t => alt_cons A B new t
  end.

(* _____________________________________
                REDUCTIONS
   _____________________________________ *)

Inductive reduction (Is:partial_program_interfaces) (E:entry_points) :
  state_partial_view -> state_partial_view -> action -> Prop :=
  (* T_CallRetTau+ *)
  | T_CallRetTauPlus :
    forall C C' d d' mem mem' reg reg' pc pc' o o' PE PE',
    let action := fun cfg =>
      match cfg with
      | (C,d,mem,reg,pc) =>
        match decode (fetch_mem C mem pc) with
        | Some (Target.Call C0 P0) => Int (IntCall C0 P0) ProgramOrigin
        | Some Return => Int IntRet ProgramOrigin
        | _ => Int IntTau ProgramOrigin
        end
      end
    in
    (Top PE = o) -> (PE' = SetTop PE o') ->
    step Is E (C,d,mem,reg,pc) (C',d',mem',reg',pc') ->
    reduction Is E
      (ProgramControl (C,PE,mem,reg,pc))
      (ProgramControl (C',PE',mem',reg',pc'))
      (action (C,d,mem,reg,pc))
  (* T_TauMinus- *)
  | T_TauMinus : forall C AE mem,
    reduction Is E
      (ContextControl (C, AE, mem))
      (ContextControl (C, AE, mem))
      (Int IntTau ContextOrigin)
  (* T_Call- *)
  | T_CallMinus : forall C C' P' AE AE' Ao mem,
    (component_defined C (option interface) Is = true) ->
    (match (nth C Is None) with
    | Some i => In (C', P') (get_import i)
    | None => False
    end)
    \/ (C' = C) ->
    ~(In (Some C') (dom_entry_points E)) -> (Top AE = Ao) ->
    (AE' = SetTop AE (C::Ao)) ->
    reduction Is E
      (ContextControl (C, AE, mem))
      (ContextControl (C', AE',mem))
      (Int (IntCall C' P') ContextOrigin)
  (* T_Ret- *)
  | T_RetMinus : forall C C' AE AE' o mem,
    (C'::o = Top AE) -> (AE' = SetTop AE o) ->
    reduction Is E
      (ContextControl (C, AE, mem))
      (ContextControl (C', AE', mem))
      (Int IntRet ContextOrigin)
  (* T_Call? *)
  | T_CallCtx : forall C C' P' AE AE' Ao reg mem,
    (component_defined C (option interface) Is = true) ->
    (match (nth C Is None) with
    | Some i => In (C',P') (get_import i)
    | None => False
    end)
    ->
    (In (Some C') (dom_entry_points E)) -> (Top AE = Ao) ->
    (AE' = SetTop AE (C::Ao)) ->
    reduction Is E
    (ContextControl (C,AE,mem))
    (ProgramControl (C',(alt_cons sigma A_sigma [] AE'),
      mem,reg,fetch_entry_points C' P' E))
        (Ext (ExtCall C' P' reg) ContextOrigin)
  (* T_Ret? *)
  | T_RetCtx : forall C C' pc o PE PE' reg mem,
    (Top PE = (C',pc)::o) -> (PE' = SetTop PE o) ->
    reduction Is E
    (ContextControl (C, (alt_cons A_sigma sigma [] PE), mem))
    (ProgramControl (C',PE',mem,reg,pc))
      (Ext (ExtRet reg) ContextOrigin)
  (* T_Call! *)
  | T_CallPrg : forall C C' P' o PE PE' mem reg pc i,
    (fetch_mem C mem pc = i) -> (decode i = Some (Target.Call C' P')) ->
    (component_defined C (option interface) Is = true) ->
    (match (nth C Is None) with
    | Some i => (In (C',P') (get_import i))
    | None => False
    end)
    ->
    ~(In (Some C') (dom_entry_points E)) -> (Top PE = o) ->
    (PE' = SetTop PE ((C,pc+1)::o)) ->
    reduction Is E
    (ProgramControl (C,PE,mem,reg,pc))
    (ContextControl (C',(alt_cons A_sigma sigma [] PE'),mem))
      (Ext (ExtCall C' P' reg) ProgramOrigin)
  (* T_Ret! *)
  | T_RetPrg : forall C C' Ao AE AE' i pc mem reg,
    (fetch_mem C mem pc = i) -> (decode i = Some Return) ->
    (Top AE = C'::Ao) -> (AE' = SetTop AE Ao) ->
    reduction Is E
    (ProgramControl (C,(alt_cons sigma A_sigma [] AE),mem,reg,pc))
    (ContextControl (C',AE',mem))
      (Ext (ExtRet reg) ProgramOrigin)
  (* T_Exit? *)
  | T_ExitCtx : forall C AE mem,
    reduction Is E
    (ContextControl (C,AE,mem)) EXITED (Ext End ContextOrigin)
  (* T_Exit! *)
  | T_ExitPrg : forall theta C PE mem reg pc,
    (forall alpha, (alpha <> (Ext End ProgramOrigin) ->
      reduction Is E (ProgramControl(C,PE,mem,reg,pc)) theta alpha)) ->
    reduction Is E
    (ProgramControl (C,PE,mem,reg,pc)) EXITED (Ext End ProgramOrigin).

(* _____________________________________
          INITIAL TRACE STATES
   _____________________________________ *)

Definition initial_trace_state (P:Target.program) :
  state_partial_view :=
  match P with
  | (Is, mem, E) =>
    let CS_PRG := (alt_init sigma A_sigma []) in
    let CS_CTX := (alt_init A_sigma sigma []) in
    let f x :=
      match x with
      | Some x' => main_cid =? x'
      | None => false
      end
    in
    if existsb f (dom_entry_points E) then
      ProgramControl (main_cid, CS_PRG, mem, g_regs,
        fetch_entry_points main_cid 0 E)
    else
      ContextControl (main_cid, CS_CTX, mem)
  end.

(* _____________________________________
            TRACE DUALIZATION
   _____________________________________ *)

Definition dual_trace (T:trace) :=
  let f :=
    (fun alpha =>
     match alpha with
     | Int ia ProgramOrigin => Int ia ContextOrigin
     | Int ia ContextOrigin => Int ia ProgramOrigin
     | Ext ea ProgramOrigin => Ext ea ContextOrigin
     | Ext ea ContextOrigin => Ext ea ProgramOrigin
     end) in
  map f T.

(* _____________________________________
            ACTION COMPOSITION
   _____________________________________ *)

Inductive reduction_multi (Is:partial_program_interfaces) (E:entry_points) :
  state_partial_view -> state_partial_view -> trace -> Prop :=
  (* T_Refl *)
  | T_Refl : forall o o',
    reduction_multi Is E o o' []
  (* T_Internal *)
  | T_Internal : forall o o' Ia origin,
    reduction Is E o o' (Int Ia origin) ->
    reduction_multi Is E o o' []
  (* T_Cross *)
  | T_Cross : forall o o' Ea origin,
    reduction Is E o o' (Ext Ea origin) ->
    reduction_multi Is E o o' [Ext Ea origin]
  (* T_Trans *)
  | T_Trans : forall o o' o'' t u,
    reduction_multi Is E o o' [t] ->
    reduction_multi Is E o' o'' [u] ->
    reduction_multi Is E o o'' ([t]++[u]).

(* _____________________________________
       INFERENCE RULES FOR CONTEXT
   _____________________________________ *)

Inductive reduction_duality (Is:partial_program_interfaces) (E:entry_points) :
  state_partial_view -> state_partial_view -> trace -> Prop :=
  | T_Dual : forall o o' t,
    reduction_multi Is E o o' (dual_trace t) ->
    reduction_duality Is E o o' t.

(* _____________________________________
              TRACE SETS
   _____________________________________ *)

(* Defined as a binary relation *)

Definition in_Traces_p (t:trace) (p:Target.program) (s:shape) :
  Prop :=
  match p with
  | (_, mem_p, E_p) =>
    match s with
    | (Is, _) => exists O,
    reduction_multi (normalize_Is Is) E_p (initial_trace_state p) O t
    end
  end.

Definition in_Traces_a (t:trace) (a:Target.program) (s:shape) :
  Prop :=
  match a with
  | (_, mem_a, E_a) =>
    match s with
    | (Is, _) => exists O,
    reduction_multi (normalize_Is Is) E_a (initial_trace_state a) O t
    end
  end.

(* _____________________________________
       TRACES WITH INTERNAL ACTIONS
   _____________________________________ *)

Fixpoint erase (t:trace) : trace :=
  match t with
  | [] => []
  | (Int _ _)::t => erase t
  | (Ext Ea origin)::t =>
    (Ext Ea origin) :: (erase t)
  end.

(* _____________________________________
         TRACE CANONICALIZATION
   _____________________________________ *)

Definition zeta_gamma (Ea:external_action) : external_action :=
  match Ea with
  | ExtCall C P reg => ExtCall C P (clear_regs reg)
  | ExtRet reg => ExtRet (clear_regs reg)
  | End => End
  end.

Definition zetaC_Ea (a:action) : action :=
  match a with
  | Ext gamma ContextOrigin => Ext (zeta_gamma gamma) ContextOrigin
  | _ => a
  end.

Fixpoint zetaC_t (t:trace) : trace :=
  match t with
  | [] => []
  | (Ext g ContextOrigin)::t' =>
    (zetaC_Ea (Ext g ContextOrigin))::(zetaC_t t')
  | h::t' => h :: (zetaC_t t')
  end.

Fixpoint zetaC_T (T:trace) : trace :=
  match T with
  | [] => []
  | (Ext g ContextOrigin)::T' => (zetaC_Ea (Ext g ContextOrigin))::(zetaC_T T')
  | (Int g ContextOrigin)::T' => (Int g ContextOrigin)::(zetaC_T T')
  | H::T' => H :: (zetaC_T T')
  end.

Definition zetaP_Ea (a:action) : action :=
  match a with
  | Ext gamma ProgramOrigin => Ext (zeta_gamma gamma) ProgramOrigin
  | _ => a
  end.

Fixpoint zetaP_t (t:trace) : trace :=
  match t with
  | [] => []
  | (Ext g ProgramOrigin)::t' =>
    (zetaP_Ea (Ext g ProgramOrigin))::(zetaP_t t')
  | h::t' => h :: (zetaP_t t')
  end.

Fixpoint zetaP_T (T:trace) : trace :=
  match T with
  | [] => []
  | (Ext g ProgramOrigin)::T' =>
    (zetaP_Ea (Ext g ProgramOrigin))::(zetaP_T T')
  | (Int g ProgramOrigin)::T' =>
    (Int g ProgramOrigin)::(zetaP_T T')
  | _ => T
  end.

(* _____________________________________
            WELL-FORMEDNESS
   _____________________________________ *)

Inductive wellformed_o (E:entry_points) : sigma -> Prop :=
  | WF_Nil_o :
    wellformed_o E []
  | WF_Cons_o : forall o o' C pc,
    (o = (C,pc)::o') -> (In (Some C) (dom_entry_points E)) ->
    (wellformed_o E o') -> (wellformed_o E o).

Inductive wellformed_Ao (E:entry_points) : A_sigma -> Prop :=
  | WF_Nil_Ao :
    wellformed_Ao E []
  | WF_Cons_Ao : forall C Ao Ao',
    (Ao = C::Ao') -> ~(In (Some C) (dom_entry_points E)) ->
    (wellformed_Ao E Ao') -> (wellformed_Ao E Ao).

Inductive wellformed_PE (E:entry_points) : P_SIGMA -> Prop :=
  | WF_Init_PE : forall o PE,
    PE = alt_init sigma A_sigma o -> wellformed_PE E PE
  | WF_Cons_PE : forall PE AE h t o,
    PE = alt_cons sigma A_sigma o AE ->
    Top AE = h::t ->
    wellformed_o E o -> wellformed_AE E AE ->
    wellformed_PE E PE
with wellformed_AE (E:entry_points) : A_SIGMA -> Prop :=
  | WF_Init_AE : forall AE Ao,
    AE = alt_init A_sigma sigma Ao -> wellformed_AE E AE
  | WF_Cons_AE : forall AE Ao h t PE,
    AE = alt_cons A_sigma sigma Ao PE ->
    Top PE = h::t ->
    wellformed_Ao E Ao -> wellformed_PE E PE ->
    wellformed_AE E AE.

Inductive wellformed_P0 (E:entry_points) :
  program_state -> Prop :=
  | WF_P0 : forall P0 PE C mem reg pc,
    In (Some C) (dom_entry_points E) ->
    (dom_global_memory mem = dom_entry_points E) ->
    wellformed_PE E PE -> P0 = (C, PE, mem, reg, pc) ->
    wellformed_P0 E P0.

Inductive wellformed_A0 (E:entry_points) :
  context_state -> Prop :=
  | WF_A0 : forall A0 AE C mem,
    ~(In (Some C) (dom_entry_points E)) ->
    (dom_global_memory mem = dom_entry_points E) ->
    wellformed_AE E AE -> A0 = (C, AE, mem) ->
    wellformed_A0 E A0.

(* _____________________________________
              STATE MERGING
   _____________________________________ *)

Inductive mergeable_Ao_o : A_sigma -> sigma -> Prop :=
  | M_Ao_o_Nil :
    mergeable_Ao_o [] []
  | M_Ao_o_Cons : forall C Ao o i,
    (mergeable_Ao_o Ao o) ->
    mergeable_Ao_o (C::Ao) ((C,i)::o).

Inductive mergeable_PE_AE : P_SIGMA -> A_SIGMA -> Prop :=
  | M_AEPE_Init : forall Ao o,
    mergeable_Ao_o Ao o -> mergeable_PE_AE
      (alt_init sigma A_sigma o) (alt_init A_sigma sigma Ao)
  | M_AEPE_Cons : forall Ao o AE PE,
    mergeable_Ao_o Ao o -> mergeable_PE_AE PE AE -> mergeable_PE_AE
    (alt_cons sigma A_sigma o AE) (alt_cons A_sigma sigma Ao PE).

Fixpoint combine_alt {A B C: Type} (f: A -> B -> list C)
  (e1: alt_list A B) (e2: alt_list B A) :=
  match e1, e2 with
  | alt_init _ _ h1, alt_init _ _ h2 => f h1 h2
  | alt_cons _ _ h1 t1, alt_cons _ _ h2 t2 =>
    f h1 h2 ++ @combine_alt B A C (fun b a => f a b) t1 t2
  | _, _ => []
  end.

(* Assuming they are mergeable *)
Definition merge (e1: P_SIGMA) (e2: A_SIGMA): sigma :=
  combine_alt (fun (s:sigma) (a_s:A_sigma) => s) e1 e2.

Definition option_pair_dismatch
  (p:option component_id * option component_id) : bool :=
  match p with
  | (Some _, None) => true
  | (None, Some _) => true
  | _ => false
  end.

Definition comps_are_complements
  (cs1 cs2 : list (option component_id)) : bool :=
  fold_right andb true (map option_pair_dismatch (combine cs1 cs2)).

Inductive mergeable_P0_A0 :
  program_state -> context_state -> Prop :=
  | M_P0_A0 : forall PE AE C mem_p mem_a pc reg,
    mergeable_PE_AE PE AE ->
    (comps_are_complements
      (dom_global_memory mem_p)
      (dom_global_memory mem_a)) = true ->
    mergeable_P0_A0 (C,PE,mem_p,reg,pc) (C,AE,mem_a).

Definition merge_P0A0 (P0:program_state) (A0:context_state) :
  program_state :=
  match P0, A0 with
  | (C, PE, mem_p, reg, pc), (_, AE, mem_a) =>
    (C, alt_init sigma A_sigma (merge PE AE),
     mem_p ++ mem_a, reg, pc)
  end.

(* _____________________________________
                PROPERTIES
   _____________________________________ *)

Lemma trace_extensibility :
  forall t s g,
  forall p, (LL_PROGRAM_SHAPE p ∈• s) ->
  forall a, (LL_CONTEXT_SHAPE a ∈∘ s) ->
    ((in_Traces_p t p s) /\
    (in_Traces_a (t++[Ext g ContextOrigin]) a s)
    -> (in_Traces_p (t++[Ext g ContextOrigin]) p s))
      /\
    ((in_Traces_a t a s) /\
    (in_Traces_p (t++[Ext g ProgramOrigin]) p s)
    -> (in_Traces_a (t++[Ext g ProgramOrigin]) a s)).
Proof.
Admitted.

Lemma trace_decomposition :
  forall s,
  forall p, (LL_PROGRAM_SHAPE p ∈• s) ->
  forall a, (LL_CONTEXT_SHAPE a ∈∘ s) ->
    cprogram_terminates (LL_context_application a p)
      ->
    (exists t, exists t' o, t = t'++[Ext End o] /\
    ((in_Traces_p t p s) /\ (in_Traces_a t a s))).
Proof.
Admitted.

Lemma trace_composition :
  forall t s,
  forall p, (LL_PROGRAM_SHAPE p ∈• s) ->
  forall a, (LL_CONTEXT_SHAPE a ∈∘ s) ->
    ((in_Traces_p t p s) /\ (in_Traces_a t a s)) ->
    (forall Ea o,
      ~((in_Traces_p (t++[Ext Ea o]) p s) /\
      (in_Traces_a (t++[Ext Ea o]) a s))) ->
    (cprogram_terminates (LL_context_application a p)
      <->
     exists t' o, t = t'++[Ext End o]).
Proof.
Admitted.


From Pony Require Import Language LocalMap.

Require Import Coq.FSets.FMapInterface.
Require Import Coq.Structures.Equalities.

Module Context (Map : WSfun).

Export Syntax.

Module LocalMap := LocalMap Map.
Export LocalMap.

Definition context : Type := (LocalMap.t aliasedType ponyType).

Definition sendableCtxt (gamma : context) : context :=
  LocalMap.fold_var
    (fun var varType sendableMap =>
      match varType with
      | aType _ b =>
          if isSendable b
            then LocalMap.addVar var varType sendableMap
            else sendableMap
      end)
    gamma
    (LocalMap.empty aliasedType ponyType).

End Context.

Module Typing (Map : WSfun).

Module Program := Program Map.
Export Program.

Module Context := Context Map.
Import Context.

Import Context.LocalMap.

(* Partial function - not defined for @tag@ *)
Definition viewAdapt
  (objCap : capability)
  (fieldCap : baseCapability)
  : option capability :=
  match objCap with
  | base iso =>
      match fieldCap with
      | iso => Some (base iso)
      | trn => Some (base iso)
      | ref => Some (base iso)
      | val => Some (base val)
      | box => Some (base tag)
      | tag => Some (base tag)
      end
  | base trn =>
      match fieldCap with
      | iso => Some (base iso)
      | trn => Some (base trn)
      | ref => Some (base trn)
      | val => Some (base val)
      | box => Some (base box)
      | tag => Some (base tag)
      end
  | base ref =>
      match fieldCap with
      | iso => Some (base iso)
      | trn => Some (base trn)
      | ref => Some (base ref)
      | val => Some (base val)
      | box => Some (base box)
      | tag => Some (base tag)
      end
  | base val =>
      match fieldCap with
      | iso => Some (base val)
      | trn => Some (base val)
      | ref => Some (base val)
      | val => Some (base val)
      | box => Some (base val)
      | tag => Some (base val)
      end
  | base box =>
      match fieldCap with
      | iso => Some (base tag)
      | trn => Some (base box)
      | ref => Some (base box)
      | val => Some (base val)
      | box => Some (base box)
      | tag => Some (base tag)
      end
  | base tag => None
  | isohat =>
      match fieldCap with
      | iso => Some isohat
      | trn => Some isohat
      | ref => Some isohat
      | val => Some (base val)
      | box => Some (base val)
      | tag => Some (base tag)
      end
  | trnhat =>
      match fieldCap with
      | iso => Some isohat
      | trn => Some trnhat
      | ref => Some trnhat
      | val => Some (base val)
      | box => Some (base val)
      | tag => Some (base tag)
      end
  end.

(* Partial function - not defined for @val@, @box@, @tag@ *)
Definition writeAdapt
  (objCap : capability)
  (fieldCap : baseCapability)
  : option capability :=
  match objCap with
  | base iso =>
      match fieldCap with
      | iso => Some isohat
      | trn => Some (base val)
      | ref => Some (base tag)
      | val => Some (base val)
      | box => Some (base tag)
      | tag => Some (base tag)
      end
  | base trn =>
      match fieldCap with
      | iso => Some isohat
      | trn => Some (base val)
      | ref => Some (base box)
      | val => Some (base val)
      | box => Some (base box)
      | tag => Some (base tag)
      end
  | base ref =>
      match fieldCap with
      | iso => Some isohat
      | trn => Some trnhat
      | ref => Some (base ref)
      | val => Some (base val)
      | box => Some (base box)
      | tag => Some (base tag)
      end
  | base val => None
  | base box => None
  | base tag => None
  | isohat =>
      match fieldCap with
      | iso => Some isohat
      | trn => Some isohat
      | ref => Some isohat
      | val => Some (base val)
      | box => Some (base val)
      | tag => Some (base tag)
      end
  | trnhat =>
      match fieldCap with
      | iso => Some isohat
      | trn => Some trnhat
      | ref => Some trnhat
      | val => Some (base val)
      | box => Some (base box)
      | tag => Some (base tag)
      end
  end.

Inductive safeToWrite : capability -> baseCapability -> Prop :=
  (* Write to an @iso@ *)
  | safeToWrite_iso_iso : safeToWrite (base iso) iso
  | safeToWrite_iso_val : safeToWrite (base iso) val
  | safeToWrite_iso_tag : safeToWrite (base iso) tag
  (* Write to a @trn@ *)
  | safeToWrite_trn_iso : safeToWrite (base trn) iso
  | safeToWrite_trn_trn : safeToWrite (base trn) trn
  | safeToWrite_trn_val : safeToWrite (base trn) val
  | safeToWrite_trn_tag : safeToWrite (base trn) tag
  (* Write to a @ref@ *)
  | safeToWrite_ref (b : baseCapability) : safeToWrite (base ref) b
  (* Write to an @iso^@ *)
  | safeToWrite_isohat (b : baseCapability) : safeToWrite isohat b
  (* Write to a @trn^@ *)
  | safeToWrite_trnhat (b : baseCapability) : safeToWrite trnhat b.

Example safeToWrite_implies_writeAdapt_defined : forall k b, safeToWrite k b -> exists k', writeAdapt k b = Some k'.
Proof.
  intros k b stw_k_b.
  induction stw_k_b; try (compute; eauto).
  (* Solve the three "general" cases, which take any value of b *)
  induction b; try (compute; eauto).
  induction b; try (compute; eauto).
  induction b; try (compute; eauto).
  Qed.

Reserved Notation "g |- x : T ==> g'" (at level 9, x at level 50, T at level 50).

Inductive typing { P : program } : context -> cw_encoding -> ponyType -> context -> Prop :=
  (* Path rules *)
  | path_var (gamma : context) (x : var) (aT : aliasedType)
  : VarMapsTo x aT gamma
      -> gamma |- (ePath (use x)) : asPonyType aT ==> gamma
  | path_temp (gamma : context) (t : temp) (T : ponyType)
  : TempMapsTo t T gamma
      -> gamma |- (ePath (useTemp t)) : T ==> (removeTemp t gamma)
  | path_consume (gamma : context) (x : var) (aT : aliasedType)
  : VarMapsTo x aT gamma
      -> gamma |- (ePath (consume x)) : hat aT ==> (removeVar x gamma)
  | path_field (gamma gamma' : context) (p : path) (s s' : typeId) (k k'' : capability) (k' : baseCapability) (f : fieldId)
  : gamma |- (ePath p) : (type s k) ==> gamma'
      -> @fieldLookup P s f (aType s' k')
      -> viewAdapt k k' = Some k''
      -> gamma |- (eFieldOfPath (p, f)) : (type s' k'') ==> gamma'
  (* The alias rule *)
  | expr_alias (gamma gamma': context) (x : cw_encoding) (s : typeId) (k : capability) (b : baseCapability)
  : gamma |- x : (type s k) ==> gamma'
    -> (alias k <; base b)
    -> gamma |- (eAlias x) : (type s (base b)) ==> gamma'
  | expr_vardecl (gamma : context) (x : var) (aT : aliasedType)
  : ~ VarIn x gamma
      -> gamma |- (eExpr (varDecl x)) : asPonyType aT ==> (addVar x aT gamma)
  | expr_localassign (gamma gamma' : context) (x : var) (r : rhs) (aT : aliasedType)
  : gamma |- (eAlias (eRhs r)) : asPonyType aT ==> gamma
    -> VarMapsTo x aT gamma'
    -> gamma |- (eExpr (assign x (aliasOf r))) : hat aT ==> gamma'
  | expr_tempassign (gamma gamma' : context) (t : temp) (pf : fieldOfPath) (T : ponyType)
  : gamma |- (eFieldOfPath pf) : T ==> gamma'
    -> gamma |- (eExpr (tempAssign t pf)) : T ==> (LocalMap.addTemp t T gamma')
  | expr_fieldassign (gamma gamma' gamma'' : context) (p p' : path) (f : fieldId) (s s' : typeId) (k k' : capability) (b b' : baseCapability)
  : gamma |- (eAlias (ePath p')) : (type s' (base b)) ==> gamma'
      -> gamma' |- (ePath p) : (type s k) ==> gamma''
      -> @fieldLookup P s f (aType s' b')
      -> safeToWrite k b
      -> (base b) <; (base b')
      -> writeAdapt k b' = Some k'
      -> gamma |- (eRhs (fieldAssign (p, f) (aliasOf p'))) : type s' k' ==> gamma''
  | expr_funcall (gamma gamma' gamma'' : context) (p : path) (args : list (@aliased path)) (s : typeId) (b : baseCapability)
      (mId : methodId) (mArgs : arrayVarMap aliasedType) (returnType : ponyType) (body : expressionSeq)
  : @methodLookup P s mId (mDef b mArgs returnType body)
    -> typing_list gamma (eAPaths args) (argValues mArgs) gamma'
    -> gamma' |- (eAlias (ePath p)) : (type s (base b)) ==> gamma''
    -> gamma |- (eRhs (methodCall (aliasOf p) mId args)) : returnType ==> gamma''
  | expr_becall (gamma gamma' gamma'' : context) (p : path) (args : list (@aliased path)) (s : typeId)
      (bId : behaviourId) (bArgs : arrayVarMap aliasedType) (body : expressionSeq)
  : @behaviourLookup P s bId (bDef bArgs body)
    -> typing_list gamma (eAPaths args) (argValues bArgs) gamma'
    -> gamma' |- (eAlias (ePath p)) : (type s (base tag)) ==> gamma''
    -> gamma |- (eRhs (behaviourCall (aliasOf p) bId args)) : (type s (base tag)) ==> gamma''
  | expr_classcon (gamma gamma' : context) (args : list (@aliased path)) (c : classId)
      (kId : constructorId) (cnArgs : arrayVarMap aliasedType) (body : expressionSeq)
  : @constructorLookup P (inl c) kId (cnDef cnArgs body)
    -> typing_list gamma (eAPaths args) (argValues cnArgs) gamma'
    -> gamma |- (eRhs (constructorCall (inl c) kId args)) : (type (inl c) (base ref)) ==> gamma'
  | expr_actorcon (gamma gamma' : context) (args : list (@aliased path)) (a : actorId)
      (kId : constructorId) (cnArgs : arrayVarMap aliasedType) (body : expressionSeq)
  : @constructorLookup P (inr a) kId (cnDef cnArgs body)
    -> typing_list gamma (eAPaths args) (argValues cnArgs) gamma'
    -> gamma |- (eRhs (constructorCall (inr a) kId args)) : (type (inr a) (base tag)) ==> gamma'
where "G |- x : T ==> G'" := (typing G x T G')
with
typing_list { P : program } : context -> list cw_encoding -> list ponyType -> context -> Prop :=
  | typing_list_nil (gamma : context)
  : typing_list gamma nil nil gamma
  | typing_list_cons (gamma gamma' gamma'' : context) (x : cw_encoding) (t : ponyType) (lx : list cw_encoding) (lt : list ponyType)
  : gamma |- x : t ==> gamma'
    -> typing_list gamma' lx lt gamma''
    -> typing_list gamma (x :: lx) (t :: lt) gamma''.

Lemma typing_paths_func_on_type_and_outcome :
  forall P : program,
  forall gamma gamma' gamma'' : context,
  forall p : path,
  forall T T' : ponyType,
  @typing P gamma (ePath p) T gamma'
  -> @typing P gamma (ePath p) T' gamma''
  -> T = T' /\ gamma' = gamma''.
  intros P gamma gamma' gamma'' p T T' p_type_T_gamma' p_type_T'_gamma''.

  destruct p as [ x | x | t ].
  { inversion p_type_T_gamma' as [ _gamma0 _x0 aT p_mapsto_aT | | | | | | | | | | | | ].
    inversion p_type_T'_gamma'' as [ _gamma1 _x1 aT' p_mapsto_aT' | | | | | | | | | | | | ].
    assert (gamma' = gamma'') as ctxts_same by (transitivity gamma; auto).

    split.
    { enough (aT = aT') as aTs_equal.
      rewrite <- aTs_equal.
      reflexivity.

      apply VarMapsTo_func with (m:=gamma') (var:=x).
      assumption.
      rewrite ctxts_same; assumption.
    }
    { assumption.
    }
  }
  { inversion p_type_T_gamma' as [ | | _gamma0 _x0 aT p_mapsto_aT | | | | | | | | | | ].
    inversion p_type_T'_gamma'' as [ | | _gamma1 _x1 aT' p_mapsto_aT' | | | | | | | | | | ].

    assert (gamma' = gamma'') as ctxts_same by (transitivity (removeVar x gamma); auto).

    split.
    { enough (aT = aT') as aTs_equal.
      rewrite <- aTs_equal.
      reflexivity.

      apply VarMapsTo_func with (m:=gamma) (var:=x); assumption.
    }
    { reflexivity.
    }
  }
  { inversion p_type_T_gamma' as [ | _gamma0 _t0 _T0 t_mapsto_T | | | | | | | | | | | ].
    inversion p_type_T'_gamma'' as [ | _gamma1 _t1 _T'0 t_mapsto_T' | | | | | | | | | | | ].

    split.
    { apply TempMapsTo_func with (m:=gamma) (temp:=t); assumption.
    }
    { reflexivity.
    }
  }
  Qed.

Lemma typing_func_on_type_and_outcome :
  forall P : program,
  forall gamma gamma' gamma'' : context,
  forall x : cw_encoding,
  forall T T' : ponyType,
  @typing P gamma x T gamma'
  -> @typing P gamma x T' gamma''
  -> T = T' /\ gamma' = gamma''.
Proof.
  intros P gamma gamma' gamma'' x T T' x_type_T_gamma' x_type_T'_gamma''.
  induction x as [ p | fp | x' IHx' | [] | [] ].
  (* Case for paths is shown as a lemma *)
  { apply typing_paths_func_on_type_and_outcome with (P:=P) (p:=p) (gamma:=gamma); assumption.
  }
  { inversion x_type_T_gamma' as [ | | | _gamma0 _gamma'0 p1 S1 S1' k1 k1' b1 f1 p1_typed_s1_k1 lookup_s1_f1_is_s1'_k1' viewadapt_k1_b1_k1' | | | | | | | | | ].
    inversion x_type_T'_gamma'' as [ | | | _gamma1 _gamma'1 p2 S2 S2' k2 k2' b2 f2 p2_typed_s2_k2 lookup_s2_f2_is_s2'_k2' viewadapt_k2_b2_k2' | | | | | | | | | ].

    assert (p1 = p2 /\ f1 = f2) as [ paths_same fields_same ].
    { assert ((p1, f1) = (p2, f2)) as fps_same by (transitivity fp; auto).
      now inversion fps_same.
    }

    assert (type S1 k1 = type S2 k2 /\ gamma' = gamma'') as [ paths_typed_same ctxts_same ].
    { apply typing_paths_func_on_type_and_outcome with (P:=P) (p:=p1) (gamma:=gamma).
      assumption.
      rewrite paths_same.
      assumption.
    }

    split.
    { assert (S1' = S2' /\ b1 = b2) as [ f_type_ids_same bs_same ].
      { assert (aType S1' b1 = aType S2' b2) as aTypes_same.
        { apply fieldLookup_func with (P:=P) (s:=S1) (f:=f1).
          assumption.
          rewrite fields_same.
          assert (S1 = S2) as type_ids_same by (inversion paths_typed_same; auto).
          rewrite type_ids_same.
          assumption.
        }

        now inversion aTypes_same.
      }

      enough (k1' = k2') as vAs_same.
      rewrite f_type_ids_same.
      rewrite vAs_same.
      reflexivity.

      assert (Some k1' = Some k2') as somes_eq.
      { transitivity (viewAdapt k1 b1).
        auto.
        rewrite bs_same.
        assert (k1 = k2) as ks_eq by (inversion paths_typed_same; auto).
        rewrite ks_eq.
        auto.
      }

      inversion somes_eq.
      reflexivity.
    }
    { assumption.
    }
  }
  { admit. (* TODO *)
  }
  { admit. (* TODO *)
  }
  { admit. (* TODO *)
  }
  { admit. (* TODO *)
  }
  { admit. (* TODO *)
  }
  { admit. (* TODO *)
  }
  { admit. (* TODO *)
  }
  { admit. (* TODO *)
  }
  { admit. (* TODO *)
  }
  Admitted. (* TODO: prove this helper lemma (v. obvious) *)

End Typing.

Require Import Coq.MSets.MSetInterface.

Module WFExpressions (Map : WSfun) (SetM : WSetsOn).

Module Typing := Typing Map.
Export Typing.

Import Typing.Context.

Module TempSet := SetM DecidableTemp.
Definition tempSet := TempSet.t.

Definition consumePath (p : path) : tempSet :=
  match p with
  | useTemp t => TempSet.singleton t
  | _         => TempSet.empty
  end.

Definition consumeRhs (r : rhs) : tempSet :=
  match r with
  | rhsPath p => consumePath p
  | fieldAssign (p, _) (aliasOf p') => TempSet.union (consumePath p) (consumePath p')
  | methodCall (aliasOf rcvr) _ args =>
      fold_left
        (fun consumed ap =>
          match ap with
          | aliasOf p => TempSet.union consumed (consumePath p)
          end
        )
        args
        (consumePath rcvr)
  | behaviourCall (aliasOf rcvr) _ args =>
      fold_left
        (fun consumed ap =>
          match ap with
          | aliasOf p => TempSet.union consumed (consumePath p)
          end
        )
        args
        (consumePath rcvr)
  | constructorCall _ _ args =>
      fold_left
        (fun consumed ap =>
          match ap with
          | aliasOf p => TempSet.union consumed (consumePath p)
          end
        )
        args
        TempSet.empty
  end.

Definition consumeExpr (e : expression) : tempSet :=
  match e with
  | varDecl _ => TempSet.empty
  | assign _ (aliasOf r) => consumeRhs r
  | tempAssign _ (p, _) => consumePath p
  end.

Inductive well_formed_expr { P : program } : context -> expressionSeq -> ponyType -> Prop :=
  | wf_return (gamma gamma' : context) (p : path) (t : ponyType)
  : @typing P gamma (ePath p) t gamma'
    -> well_formed_expr gamma (final p) t
  | wf_vardecl (gamma gamma' : context) (x : var) (E : expressionSeq) (t t' : ponyType)
  : @typing P gamma (eExpr (varDecl x)) t' gamma'
    -> well_formed_expr gamma' E t
    -> well_formed_expr gamma (seq (varDecl x) E) t
  | wf_localassign (gamma gamma' : context) (x : var) (arhs : @aliased rhs) (E : expressionSeq) (t t' : ponyType)
  : @typing P gamma (eExpr (assign x arhs)) t' gamma'
    -> well_formed_expr gamma' E t
    -> well_formed_expr gamma (seq (assign x arhs) E) t
  | wf_tempassign_final (gamma gamma' : context) (t : temp) (pf : fieldOfPath) (p : path) (T T' : ponyType)
  : @typing P gamma (eExpr (tempAssign t pf)) T' gamma'
    -> well_formed_expr gamma' (final p) T
    -> well_formed_expr gamma (seq (tempAssign t pf) (final p)) T
  | wf_tempassign (gamma gamma' : context) (t : temp) (pf : fieldOfPath) (e : expression) (E : expressionSeq) (T T' : ponyType)
  : @typing P gamma (eExpr (tempAssign t pf)) T' gamma'
    -> TempSet.In t (consumeExpr e)
    -> well_formed_expr gamma' (seq e E) T
    -> well_formed_expr gamma (seq (tempAssign t pf) (seq e E)) T.

(* For some method arguments, produce the corresponding typing context *)
Definition argsToContext (args : arrayVarMap aliasedType) : context :=
  ArrayVarMap.fold
    (fun key val ctxt => LocalMap.addVar key val ctxt)
    args
    (LocalMap.empty aliasedType ponyType).

Definition well_formed_constructor_def { P : program }
  (thisType : aliasedType) (kD : constructorDef) : Prop
  := forall args body, kD = cnDef args body
        -> exists (t : ponyType),
            @well_formed_expr P
              (LocalMap.addVar this thisType (argsToContext args))
              body
              t.

Definition well_formed_method_def { P : program }
  (thisTypeId : typeId) (mD : methodDef) : Prop
  := forall rcvrCap args returnType body, mD = mDef rcvrCap args returnType body
        -> @well_formed_expr P
            (LocalMap.addVar this (aType thisTypeId rcvrCap) (argsToContext args))
            body
            returnType.

Definition well_formed_behaviour_def { P : program }
  (thisTypeId : actorId) (bD : behaviourDef) : Prop
  := forall args body, bD = bDef args body
        -> exists (t : ponyType),
            @well_formed_expr P
              (LocalMap.addVar this (aType (inr thisTypeId) iso) (argsToContext args))
              body
              t.

Definition well_formed_class { P : program } (c : classId) : Prop :=
  (forall k kD, @constructorLookup P (inl c) k kD -> @well_formed_constructor_def P (aType (inl c) ref) kD)
  /\
  (forall m mD, @methodLookup P (inl c) m mD -> @well_formed_method_def P (inl c) mD).

Definition well_formed_actor { P : program } (a : actorId) : Prop :=
  (forall k kD, @constructorLookup P (inr a) k kD -> @well_formed_constructor_def P (aType (inr a) iso) kD)
  /\
  (forall m mD, @methodLookup P (inr a) m mD -> @well_formed_method_def P (inr a) mD)
  /\
  (forall b bD, @behaviourLookup P (inr a) b bD -> @well_formed_behaviour_def P a bD).

Definition well_formed_program (P : program) : Prop :=
  (forall a : actorId, @well_formed_actor P a)
  /\ (forall c : classId, @well_formed_class P c).

End WFExpressions.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export Coq.Logic.ConstructiveEpsilon.
Require Export stronger_continuity_defs.
Require Export stronger_continuity_defs0.
Require Export per_props_atom.
Require Export terms5.
Require Export per_props_nat2.

Lemma equality_mkc_union_tnat_unit {o} :
  forall lib (a b : @CTerm o),
    equality lib a b (mkc_union mkc_tnat mkc_unit)
    <=>
    ({k : nat
      , ccequivc lib a (mkc_inl (mkc_nat k))
      # ccequivc lib b (mkc_inl (mkc_nat k))}
     {+}
     (ccequivc lib a (mkc_inr mkc_axiom)
      # ccequivc lib b (mkc_inr mkc_axiom))).
Proof.
  introv.
  rw @equality_mkc_union.
  split; intro k; exrepnd; repndors; exrepnd; spcast; dands; eauto 3 with slow.

  - allrw @equality_in_tnat.
    allunfold @equality_of_nat; exrepnd; spcast.
    left.
    exists k; dands; spcast.
    + eapply cequivc_trans;[apply computes_to_valc_implies_cequivc; exact k2|].
      apply cequivc_mkc_inl_if.
      apply computes_to_valc_implies_cequivc; auto.
    + eapply cequivc_trans;[apply computes_to_valc_implies_cequivc; exact k4|].
      apply cequivc_mkc_inl_if.
      apply computes_to_valc_implies_cequivc; auto.

  - allrw @equality_in_unit; repnd; spcast.
    right; dands; spcast.
    + eapply cequivc_trans;[apply computes_to_valc_implies_cequivc; exact k2|].
      apply cequivc_mkc_inr_if.
      apply computes_to_valc_implies_cequivc; auto.
    + eapply cequivc_trans;[apply computes_to_valc_implies_cequivc; exact k4|].
      apply cequivc_mkc_inr_if.
      apply computes_to_valc_implies_cequivc; auto.

  - left.
    apply cequivc_sym in k2; apply cequivc_mkc_inl_implies in k2.
    apply cequivc_sym in k1; apply cequivc_mkc_inl_implies in k1.
    exrepnd.
    exists b1 b0; dands; spcast; auto.
    eapply equality_respects_cequivc_left;[exact k4|].
    eapply equality_respects_cequivc_right;[exact k3|].
    apply equality_in_tnat.
    unfold equality_of_nat.
    exists k0; dands; spcast; auto;
    apply computes_to_valc_refl; eauto 3 with slow.

  - right.
    apply cequivc_sym in k0; apply cequivc_mkc_inr_implies in k0.
    apply cequivc_sym in k; apply cequivc_mkc_inr_implies in k.
    exrepnd.
    exists b1 b0; dands; spcast; auto.
    eapply equality_respects_cequivc_left;[exact k3|].
    eapply equality_respects_cequivc_right;[exact k1|].
    apply equality_in_unit.
    dands; spcast;
    apply computes_to_valc_refl; eauto 3 with slow.
Qed.

Lemma equality_in_mkc_texc {o} :
  forall lib (a b N E : @CTerm o),
    equality lib a b (mkc_texc N E)
    <=> {n1 : CTerm
         , {n2 : CTerm
         , {e1 : CTerm
         , {e2 : CTerm
         , a ===e>(lib,n1) e1
         # b ===e>(lib,n2) e2
         # equality lib n1 n2 N
         # equality lib e1 e2 E }}}}.
Proof.
  introv.
  split; introv k; exrepnd; spcast.

  - unfold equality in k; exrepnd.
    inversion k1; subst; try not_univ.
    clear k1.
    match goal with
      | [ H : per_texc _ _ _ _ _ |- _ ] => rename H into p
    end.
    allunfold @per_texc; exrepnd; spcast; computes_to_value_isvalue.
    apply p1 in k0.
    unfold per_texc_eq in k0; exrepnd; spcast.
    exists n1 n2 e1 e2; dands; spcast; auto.

    + eapply eq_equality1; eauto.

    + eapply eq_equality1; eauto.

  - allunfold @equality; exrepnd.
    rename eq0 into eqn.
    rename eq into eqe.
    exists (per_texc_eq lib eqn eqe).
    dands; auto.

    + apply CL_texc.
      unfold per_texc.
      exists eqn eqe N N E E.
      dands; spcast; auto;
      try (apply computes_to_valc_refl; apply iscvalue_mkc_texc).

    + unfold per_texc_eq.
      exists n1 n2 e1 e2; dands; spcast; auto.
Qed.

Lemma tequality_mkc_texc {o} :
  forall lib (N1 E1 N2 E2 : @CTerm o),
    tequality lib (mkc_texc N1 E1) (mkc_texc N2 E2)
    <=> (tequality lib N1 N2 # tequality lib E1 E2).
Proof.
  introv; split; intro teq; repnd.

  - unfold tequality in teq; exrepnd.
    inversion teq0; try not_univ; allunfold @per_texc; exrepnd.
    computes_to_value_isvalue; sp; try (complete (spcast; sp)).
    + exists eqn; sp.
    + exists eqe; sp.

  - unfold tequality in teq0; exrepnd.
    rename eq into eqn.
    unfold tequality in teq; exrepnd.
    rename eq into eqe.
    exists (per_texc_eq lib eqn eqe); apply CL_texc; unfold per_texc.
    exists eqn eqe N1 N2 E1 E2; sp; spcast;
    try (apply computes_to_valc_refl; apply iscvalue_mkc_texc).
Qed.

Lemma disjoint_nat_exc {o} :
  forall lib (a b : @CTerm o),
    disjoint_types lib mkc_tnat (mkc_texc a b).
Proof.
  introv mem; repnd.

  allrw @equality_in_tnat.
  allunfold @equality_of_nat; exrepnd; spcast; GC.

  allrw @equality_in_mkc_texc; exrepnd; spcast.
  eapply computes_to_valc_and_excc_false in mem0; eauto.
Qed.

Lemma tequality_mkc_singleton_uatom {o} :
  forall lib (n1 n2 : @get_patom_set o),
    tequality lib (mkc_singleton_uatom n1) (mkc_singleton_uatom n2)
    <=> n1 = n2.
Proof.
  introv.
  unfold mkc_singleton_uatom.
  rw @tequality_set; split; introv k; repnd; subst; tcsp.

  - clear k0.
    pose proof (k (mkc_utoken n1) (mkc_utoken n1)) as h; clear k.
    autodimp h hyp.
    { apply equality_in_uatom_iff.
      exists n1; dands; spcast;
      try (apply computes_to_valc_refl; apply iscvalue_mkc_utoken). }
    allrw @mkcv_cequiv_substc.
    allrw @mkc_var_substc.
    allrw @mkcv_utoken_substc.
    allrw @tequality_mkc_cequiv.
    destruct h as [h h2]; clear h2.
    autodimp h hyp; spcast; eauto 3 with slow.
    allrw @cequivc_mkc_utoken; auto.

  - dands;[apply tequality_uatom|].
    introv e.
    apply equality_in_uatom_iff in e; exrepnd; spcast.
    allrw @mkcv_cequiv_substc.
    allrw @mkc_var_substc.
    allrw @mkcv_utoken_substc.
    allrw @tequality_mkc_cequiv.
    allapply @computes_to_valc_implies_cequivc.
    split; intro k; spcast.
    + eapply cequivc_trans in k;[|apply cequivc_sym;exact e1].
      allrw @cequivc_mkc_utoken; subst; auto.
    + eapply cequivc_trans in k;[|apply cequivc_sym;exact e0].
      allrw @cequivc_mkc_utoken; subst; auto.
Qed.

Lemma tequality_mkc_ntexc {o} :
  forall lib n1 n2 (E1 E2 : @CTerm o),
    tequality lib (mkc_ntexc n1 E1) (mkc_ntexc n2 E2)
    <=> (n1 = n2 # tequality lib E1 E2).
Proof.
  introv.
  unfold mkc_ntexc.
  rw @tequality_mkc_texc.
  rw @tequality_mkc_singleton_uatom; auto.
Qed.

Lemma type_mkc_ntexc {o} :
  forall lib n (E : @CTerm o),
    type lib (mkc_ntexc n E) <=> (type lib E).
Proof.
  introv.
  rw @tequality_mkc_ntexc; split; sp.
Qed.

Lemma inhabited_type_mkc_cequiv {o} :
  forall lib (t1 t2 : @CTerm o),
    inhabited_type lib (mkc_cequiv t1 t2) <=> ccequivc lib t1 t2.
Proof.
  introv.
  unfold inhabited_type; split; introv k; exrepnd.

  - allunfold @member; allunfold @equality; allunfold @nuprl; exrepnd.
    inversion k0; subst; try not_univ.

    allunfold @per_cequiv; sp.
    uncast; computes_to_value_isvalue.
    discover; sp.

  - exists (@mkc_axiom o).
    apply member_cequiv_iff; auto.
Qed.

Lemma equality_in_mkc_singleton_uatom {o} :
  forall lib a b (n : @get_patom_set o),
    equality lib a b (mkc_singleton_uatom n)
    <=> (a ===>(lib) (mkc_utoken n) # b ===>(lib) (mkc_utoken n)).
Proof.
  introv.
  unfold mkc_singleton_uatom.
  rw @equality_in_set.
  allrw @mkcv_cequiv_substc.
  allrw @mkc_var_substc.
  allrw @mkcv_utoken_substc.
  allrw @inhabited_type_mkc_cequiv.
  allrw @equality_in_uatom_iff.
  split; intro k; exrepnd; spcast; dands; tcsp.

  - eapply close_type_sys_per_ffatom.cequivc_utoken in k;[|exact k1].
    apply computes_to_valc_isvalue_eq in k; try (eqconstr k); eauto 3 with slow.
    dands; spcast; auto.

  - eapply close_type_sys_per_ffatom.cequivc_utoken in k;[|exact k1].
    apply computes_to_valc_isvalue_eq in k; try (eqconstr k); eauto 3 with slow.
    dands; spcast; auto.

  - introv e.
    allrw @mkcv_cequiv_substc.
    allrw @mkc_var_substc.
    allrw @mkcv_utoken_substc.
    allrw @equality_in_uatom_iff; exrepnd; spcast.
    apply tequality_mkc_cequiv.
    allapply @computes_to_valc_implies_cequivc.
    split; intro h; spcast.
    + eapply cequivc_trans in h;[|apply cequivc_sym;exact e1].
      allrw @cequivc_mkc_utoken; subst; auto.
    + eapply cequivc_trans in h;[|apply cequivc_sym;exact e0].
      allrw @cequivc_mkc_utoken; subst; auto.

  - exists n; dands; spcast; auto.

  - spcast.
    allapply @computes_to_valc_implies_cequivc; auto.
Qed.

Lemma equality_in_mkc_ntexc {o} :
  forall lib n (a b E : @CTerm o),
    equality lib a b (mkc_ntexc n E)
    <=> {n1 : CTerm
         , {n2 : CTerm
         , {e1 : CTerm
         , {e2 : CTerm
         , n1 ===>(lib) (mkc_utoken n)
         # n2 ===>(lib) (mkc_utoken n)
         # a ===e>(lib,n1) e1
         # b ===e>(lib,n2) e2
         # equality lib e1 e2 E }}}}.
Proof.
  introv.
  rw @equality_in_mkc_texc; split; intro k; exrepnd; spcast.

  - allrw @equality_in_mkc_singleton_uatom; repnd; spcast.
    exists n1 n2 e1 e2; dands; spcast; auto.

  - exists n1 n2 e1 e2; dands; spcast; auto.
    allrw @equality_in_mkc_singleton_uatom; dands; spcast; auto.
Qed.

Lemma equality_in_natE {o} :
  forall lib n (a b : @CTerm o),
    equality lib a b (natE n)
    <=> (equality_of_nat lib a b
         {+} (ccequivc lib a (spexcc n) # ccequivc lib b (spexcc n))).
Proof.
  introv.
  unfold natE, with_nexc_c.

  pose proof (equality_in_disjoint_bunion lib a b mkc_tnat (mkc_ntexc n mkc_unit)) as h.
  autodimp h hyp.
  { unfold mkc_ntexc; apply disjoint_nat_exc. }
  rw h; clear h.
  rw @type_mkc_ntexc.

  split; intro k; repnd; dands; eauto 3 with slow; repndors; tcsp;
  allrw @equality_in_tnat;
  allrw @equality_in_mkc_ntexc;
  exrepnd; spcast; tcsp;
  allrw @equality_in_unit;
  repnd; spcast.

  - allapply @computes_to_excc_implies_cequivc.
    allapply @computes_to_valc_implies_cequivc.
    right; dands; spcast.
    + eapply cequivc_trans;[exact k5|].
      unfold spexc.
      apply cequivc_mkc_exception; auto.
    + eapply cequivc_trans;[exact k6|].
      unfold spexc.
      apply cequivc_mkc_exception; auto.

  - left; allrw @equality_in_tnat; auto.

  - right; allrw @equality_in_mkc_ntexc.
    allunfold @spexc.
    apply cequivc_sym in k0; apply cequivc_sym in k.
    apply cequivc_exception_implies in k0.
    apply cequivc_exception_implies in k.
    exrepnd.
    allapply @cequivc_axiom_implies.
    allapply @cequivc_utoken_implies.
    exists x0 x c0 c; dands; spcast; auto.
    allrw @equality_in_unit; dands; spcast; auto.
Qed.

Lemma dec_reduces_ksteps_excc {o} :
  forall lib k (t v : @CTerm o),
    (forall x, decidable (x = get_cterm v))
    -> decidable (reduces_ksteps_excc lib t v k).
Proof.
  introv d.
  destruct_cterms; allsimpl.
  pose proof (dec_reduces_in_atmost_k_steps_exc lib k x0 x d) as h.
  destruct h as [h|h];[left|right].
  - spcast; tcsp.
  - intro r; spcast; tcsp.
Qed.

Lemma reduces_ksteps_excc_spexcc_decompose {o} :
  forall lib (k : nat) a (t : @CTerm o),
    reduces_ksteps_excc lib t (spexcc a) k
    -> {k1 : nat
        & {k2 : nat
        & {k3 : nat
        & {a' : CTerm
        & {e' : CTerm
        & k1 + k2 + k3 <= k
        # reduces_in_atmost_k_stepsc lib t (mkc_exception a' e') k1
        # reduces_in_atmost_k_stepsc lib a' (mkc_utoken a) k2
        # reduces_in_atmost_k_stepsc lib e' mkc_axiom k3 }}}}}.
Proof.
  introv r.
  pose proof (dec_reduces_in_atmost_k_steps_excc lib k t (spexcc a)) as h; allsimpl.
  try (fold (spexc a) in h).
  autodimp h hyp; eauto 3 with slow.
  destruct h as [d|d].
  - apply reduces_in_atmost_k_steps_excc_decompose in d; eauto 2 with slow.
  - provefalse; spcast; sp.
Qed.

Lemma reduces_ksteps_excc_impossible1 {o} :
  forall lib k1 k2 (t : @CTerm o) a n,
    reduces_ksteps_excc lib t (spexcc a) k1
    -> reduces_ksteps_excc lib t (mkc_nat n) k2
    -> False.
Proof.
  introv r1 r2; spcast.
  eapply reduces_in_atmost_k_steps_excc_impossible1 in r1; eauto.
Qed.

Lemma dec_reduces_ksteps_excc_nat {o} :
  forall lib k (t : @CTerm o),
    decidable {n : nat & reduces_ksteps_excc lib t (mkc_nat n) k}.
Proof.
  introv; destruct_cterms; allsimpl.
  pose proof (dec_reduces_in_atmost_k_steps_exc_nat lib k x) as h.
  destruct h as [h|h];[left|right].
  - exrepnd; exists n; spcast; tcsp.
  - intro r; exrepnd; destruct h; exists n; spcast; tcsp.
Qed.

Lemma equality_in_natE_implies {o} :
  forall lib (t u : @CTerm o) a,
    equality lib t u (natE a)
    -> equality_of_nat_tt lib t u
       [+] (cequivc lib t (spexcc a) # cequivc lib u (spexcc a)).
Proof.
  introv equ.

  assert {k : nat
          , {m : nat
          , (reduces_ksteps_excc lib t (mkc_nat m) k
             # reduces_ksteps_excc lib u (mkc_nat m) k)
            {+} (reduces_ksteps_excc lib t (spexcc a) k
                  # reduces_ksteps_excc lib u (spexcc a) k)}} as j.
  { apply equality_in_natE in equ.
    repndors.

    - unfold equality_of_nat in equ; exrepnd; spcast.
      allrw @computes_to_valc_iff_reduces_in_atmost_k_stepsc; exrepnd.
      exists (Peano.max k0 k1) k.
      left; dands; spcast.

      + apply (reduces_in_atmost_k_stepsc_le _ _ _ _ (Peano.max k0 k1)) in equ4; eauto 3 with slow;
        try (apply Nat.le_max_l; auto).
        apply reduces_in_atmost_k_steps_excc_can in equ4; tcsp.

      + apply (reduces_in_atmost_k_stepsc_le _ _ _ _ (Peano.max k0 k1)) in equ2; eauto 3 with slow;
        try (apply Nat.le_max_r; auto).
        apply reduces_in_atmost_k_steps_excc_can in equ2; tcsp.

    - repnd; spcast.
      apply cequivc_spexcc in equ0.
      apply cequivc_spexcc in equ.
      exrepnd.
      allrw @computes_to_valc_iff_reduces_in_atmost_k_stepsc; exrepnd.
      allrw @computes_to_excc_iff_reduces_in_atmost_k_stepsc; exrepnd.

      exists (Peano.max (k3 + k + k0) (k4 + k1 + k2)) 0.
      right; dands; spcast.

      + apply (reduces_in_atmost_k_steps_excc_le_exc _ (k3 + k + k0));
        eauto 3 with slow; tcsp;
        try (apply Nat.le_max_l; auto).
        pose proof (reduces_in_atmost_k_steps_excc_exception
                      lib k k0 n0 e0 (mkc_utoken a) mkc_axiom) as h.
        repeat (autodimp h hyp); tcsp; exrepnd.
        pose proof (reduces_in_atmost_k_steps_excc_trans2
                      lib k3 i
                      t
                      (mkc_exception n0 e0)
                      (mkc_exception (mkc_utoken a) mkc_axiom)) as q.
        repeat (autodimp q hyp); exrepnd.
        apply (reduces_in_atmost_k_steps_excc_le_exc _ i0); tcsp; try omega.

      + apply (reduces_in_atmost_k_steps_excc_le_exc _ (k4 + k1 + k2));
        eauto 3 with slow; tcsp;
        try (apply Nat.le_max_r; auto).
        pose proof (reduces_in_atmost_k_steps_excc_exception
                      lib k1 k2 n e (mkc_utoken a) mkc_axiom) as h.
        repeat (autodimp h hyp); tcsp; exrepnd.
        pose proof (reduces_in_atmost_k_steps_excc_trans2
                      lib k4 i
                      u
                      (mkc_exception n e)
                      (mkc_exception (mkc_utoken a) mkc_axiom)) as q.
        repeat (autodimp q hyp); exrepnd.
        apply (reduces_in_atmost_k_steps_excc_le_exc _ i0); tcsp; try omega.
  }

  apply (constructive_indefinite_ground_description nat (fun x => x) (fun x => x))
    in j; auto.

  { exrepnd.
    apply (constructive_indefinite_ground_description nat (fun x => x) (fun x => x))
      in j0; auto.

    - exrepnd.
      pose proof (dec_reduces_ksteps_excc lib x t (mkc_nat x0)) as h.
      autodimp h hyp; simpl; eauto 3 with slow.
      pose proof (dec_reduces_ksteps_excc lib x t (spexcc a)) as q.
      autodimp q hyp; simpl; try (fold (spexc a)); eauto 3 with slow.
      pose proof (dec_reduces_ksteps_excc lib x u (mkc_nat x0)) as j.
      autodimp j hyp; simpl; eauto 3 with slow.
      pose proof (dec_reduces_ksteps_excc lib x u (spexcc a)) as l.
      autodimp l hyp; simpl; try (fold (spexc a)); eauto 3 with slow.

      destruct h as [h|h];
      destruct q as [q|q];
      destruct j as [j|j];
      destruct l as [l|l];
      try (complete (eapply reduces_ksteps_excc_impossible1 in h;[|exact q]; tcsp));
      try (complete (eapply reduces_ksteps_excc_impossible1 in j;[|exact l]; eauto; tcsp));
      try (complete (provefalse; repndors; repnd; tcsp)).

      { left; exists x0; dands; split; simpl; eauto 3 with slow; exists x; spcast;
        apply reduces_in_atmost_k_steps_excc_can_implies in h;
        apply reduces_in_atmost_k_steps_excc_can_implies in j;
        allunfold @reduces_in_atmost_k_stepsc; allsimpl;
        allrw @get_cterm_apply; tcsp. }

      { right.
        apply reduces_ksteps_excc_spexcc_decompose in q.
        apply reduces_ksteps_excc_spexcc_decompose in l.
        exrepnd.
        allunfold @reduces_in_atmost_k_stepsc; allsimpl.
        allrw @get_cterm_apply; allsimpl.
        allrw @get_cterm_mkc_exception; allsimpl.
        dands;
          apply cequiv_spexc_if;
          try (apply isprog_apply);
          try (apply isprog_mk_nat);
          eauto 3 with slow.
        - exists (get_cterm a'0) (get_cterm e'0); dands; eauto 3 with slow.
          unfold computes_to_exception; exists k0; auto.
        - exists (get_cterm a') (get_cterm e'); dands; eauto 3 with slow.
          unfold computes_to_exception; exists k1; auto. }

    - clear j0.
      introv.

      pose proof (dec_reduces_ksteps_excc lib x t (mkc_nat x0)) as h.
      autodimp h hyp; simpl; eauto 3 with slow.
      pose proof (dec_reduces_ksteps_excc lib x t (spexcc a)) as q.
      autodimp q hyp; simpl; try (fold (spexc a)); eauto 3 with slow.
      pose proof (dec_reduces_ksteps_excc lib x u (mkc_nat x0)) as j.
      autodimp j hyp; simpl; eauto 3 with slow.
      pose proof (dec_reduces_ksteps_excc lib x u (spexcc a)) as l.
      autodimp l hyp; simpl; try (fold (spexc a)); eauto 3 with slow.

      destruct h as [h|h];
        destruct q as [q|q];
        destruct j as [j|j];
        destruct l as [l|l];
        tcsp;
        try (complete (right; intro xx; repndors; repnd; tcsp)).
  }

  { clear j; introv.

    pose proof (dec_reduces_ksteps_excc_nat lib x t) as h.
    pose proof (dec_reduces_ksteps_excc lib x t (spexcc a)) as q.
    autodimp q hyp; simpl; try (fold (spexc a)); eauto 3 with slow.
    pose proof (dec_reduces_ksteps_excc_nat lib x u) as j.
    pose proof (dec_reduces_ksteps_excc lib x u (spexcc a)) as l.
    autodimp l hyp; simpl; try (fold (spexc a)); eauto 3 with slow.

    destruct h as [h|h];
      destruct q as [q|q];
      destruct j as [j|j];
      destruct l as [l|l];
      exrepnd;
      try (destruct (deq_nat n0 n) as [d|d]); subst;
      tcsp;
      try (complete (eapply reduces_ksteps_excc_impossible1 in h0; eauto; tcsp));
      try (complete (eapply reduces_ksteps_excc_impossible1 in j0; eauto; tcsp));
      try (complete (provefalse; repndors; repnd; tcsp));
      try (complete (right; intro xx; exrepnd; repndors; repnd; tcsp;
                     try (complete (destruct h; eexists; eauto));
                     try (complete (destruct j; eexists; eauto))));
      try (complete (left; exists n; left; tcsp));
      try (complete (left; exists 0; right; tcsp)).

    right; intro xx; exrepnd; repndors; repnd; tcsp; spcast.
    allunfold @reduces_in_atmost_k_steps_excc; allsimpl.
    allunfold @reduces_in_atmost_k_steps_exc.
    rw xx1 in h0.
    rw xx0 in j0.
    inversion h0.
    inversion j0.
    allapply Znat.Nat2Z.inj; subst; tcsp.
  }
Qed.

Lemma tequality_with_nexc_c {o} :
  forall lib a1 a2 (T1 T2 E1 E2 : @CTerm o),
    tequality lib (with_nexc_c a1 T1 E1) (with_nexc_c a2 T2 E2)
    <=> (a1 = a2 # tequality lib T1 T2 # tequality lib E1 E2).
Proof.
  introv.
  unfold with_nexc_c.
  rw @tequality_bunion.
  rw @tequality_mkc_texc.
  rw @tequality_mkc_singleton_uatom.
  split; sp.
Qed.

Lemma tequality_natE {o} :
  forall lib (a1 a2 : @get_patom_set o),
    tequality lib (natE a1) (natE a2) <=> a1 = a2.
Proof.
  introv.
  unfold natE.
  rw @tequality_with_nexc_c.
  allrw @fold_type.
  split; intro k; repnd; dands; eauto with slow.
Qed.

Lemma type_natE {o} :
  forall lib (a : @get_patom_set o),
    type lib (natE a).
Proof.
  introv.
  rw @tequality_natE; auto.
Qed.
Hint Resolve type_natE : slow.

Lemma disjoint_nat_unit {o}:
  forall (lib : @library o),
    disjoint_types lib mkc_tnat mkc_unit.
Proof.
  introv mem; repnd.
  allrw @equality_in_tnat.
  allrw @equality_in_unit.
  allunfold @equality_of_nat; exrepnd; spcast; GC.
  computes_to_eqval.
Qed.
Hint Resolve disjoint_nat_unit : slow.

Lemma member_bunion_nat_unit_implies_cis_spcan_not_atom {o} :
  forall lib (t : @CTerm o) a,
    member lib t (mkc_bunion mkc_tnat mkc_unit)
    -> cis_spcan_not_atom lib t a.
Proof.
  introv mem.
  apply @equality_in_disjoint_bunion in mem; eauto 3 with slow.
  repnd.
  clear mem0 mem1.
  repndors.
  - apply equality_in_tnat in mem.
    unfold equality_of_nat in mem; exrepnd; spcast.
    exists (@mkc_nat o k); dands; spcast; simpl; tcsp.
  - apply equality_in_unit in mem; repnd; spcast.
    exists (@mkc_axiom o); dands; spcast; simpl; tcsp.
Qed.