Require Import Coq.Lists.List.
Import ListNotations.

Require Import Unique.
Require Import GenericLemmas.
Require Import GenericTactics.
Require Import Skeleton.
Require Import Names.
Require Import AST.
Require Import Typechecker.
Require Import UtilsSkeleton.
Require Import BodyTypeDefs.
Require Export ProgramDef.

(**************************************************************************************************)
(** Given the name of a function, return its body                                                 *)
(**************************************************************************************************)
Definition lookup_fun_bods (p : program) (n : Name) : option fun_bod :=
  let result := (fix lookupHelper (bs : list (Name * expr)) : option fun_bod :=
                   match bs with
                   | [] => None (*Cannot occur*)
                   | (f :: fs) =>
                     if eq_Name (fst f) n
                     then Some (snd f)
                     else lookupHelper fs
                end) (program_fun_bods p)
  in result.

(* Lemma lookupFunctionBody_In : forall (prog : program) (n : Name) (e : expr), *)
(*     lookupFunctionBody prog n = Some e <-> *)
(*     In (n, e) (program_fun_bods prog). *)
(* Proof. *)
(*   intros prog n e. split. *)
(*   -(* -> *) *)
(*     intro H_lookup. *)
(*     unfold lookupFunctionBody in H_lookup. *)
(*     induction (funbodies prog). *)
(*     *inversion H_lookup. *)
(*     *destruct (eq_Name (fst a) n) eqn:E. *)
(*      **destruct a. name_eq_tac. inversion H_lookup. subst. *)
(*        simpl. left. reflexivity. *)
(*      **simpl. right. apply IHf. assumption. *)
(*   -(* <- *) *)
(*     intro H_In. *)
(*     assert (H_wf : hasAllFunbodies (fsigs (skeleton prog)) (funbodies prog)); *)
(*       try apply hasAllFuns;  unfold hasAllFunbodies in H_wf; destruct H_wf as [H_wf1 H_wf2]. *)
(*     rewrite Forall_forall in H_wf2. specialize (H_wf2 (n, e) H_In). *)
(*     assert (H_exists : exists argts rtype, In (n, argts, rtype) (fsigs (skeleton prog))). *)
(*     +clear H_wf1. *)
(*      induction (fsigs (skeleton prog)); try (inversion H_wf2). *)
(*      simpl in H_wf2. destruct (eq_Name (fst (fst a))) eqn:E. *)
(*      *destruct a as [[a0 a1] a2]. simpl in *. *)
(*       exists a1. exists a2. left. name_eq_tac. *)
(*      *specialize (IHf H_wf2). destruct IHf. destruct H. *)
(*       exists x. exists x0. simpl. right. assumption. *)
(*     +destruct H_exists. destruct H. *)
(*      rewrite Forall_forall in H_wf1. specialize (H_wf1 (n,x,x0) H). simpl in H_wf1. *)
(*      clear H_wf2 H. *)
(*      unfold lookupFunctionBody. *)
(*      induction (funbodies prog). *)
(*      *simpl in *. contradiction. *)
(*      *destruct a. simpl in *. destruct H_In. *)
(*       **inversion H; subst. name_refl_tac. *)
(*       **destruct (eq_Name n n0) eqn:E; rewrite eq_Name_symm in E; rewrite E; try solve [apply IHf; assumption]. *)
(*         exfalso. name_eq_tac. simpl in H_wf1. inversion H_wf1. clear - H1 H. *)
(*         induction f; try contradiction. *)
(*         simpl in *. destruct a. destruct H. *)
(*         ***inversion H; subst. simpl in H1. name_refl_tac. simpl in H1. inversion H1. *)
(*         ***apply IHf; try assumption. simpl in H1. destruct (eq_Name n n0). *)
(*            inversion H1. assumption. *)
(* Qed. *)

Lemma lookup_fun_bods_is_first : forall (prog : program) (n : Name) (e : expr),
    lookup_fun_bods prog n = Some e <->
    is_first (n, e) (program_fun_bods prog) (fun x y => eq_Name (fst x) (fst y)).
Proof.
  intros prog n e.
  unfold iff. split.
  - intro Hlookup. unfold lookup_fun_bods in Hlookup.
    induction (program_fun_bods prog); try solve [inversion Hlookup].
    destruct (eq_Name (fst a) n) eqn:En.
    + destruct a. simpl in *.
      apply eq_Name_eq in En. symmetry in En. rewrite En in *. rewrite eq_Name_refl in Hlookup.
      inversion Hlookup as [El]. rewrite El in *.
      apply is_first_head.
    + apply is_first_tail.
      * simpl. rewrite eq_Name_symm. assumption.
      * destruct a; simpl in *; rewrite En in Hlookup.
        apply IHf; try assumption.
  - intro H_is_first. unfold lookup_fun_bods.
    induction (program_fun_bods prog); try solve [inversion H_is_first].
    destruct (eq_Name (fst a) n) eqn:En; destruct a as [a_n a_e]; simpl in *; rewrite En.
    + f_equal. inversion H_is_first; try reflexivity.
      subst. simpl in H2. rewrite eq_Name_symm in H2. rewrite H2 in En. discriminate En.
    + apply IHf.
      inversion H_is_first; try assumption.
      inversion H1. symmetry in H4. apply eq_Name_eq in H4. rewrite H4 in En. discriminate En.
Qed.

(* Lemma lookupFunctionSig_lookupFunctionBody : forall (prog : program)(n : Name) (sig : list TypeName * TypeName), *)
(*     lookupFunctionSig (skeleton prog) n = Some sig -> *)
(*     exists body, lookupFunctionBody prog n = Some body. *)
(* Proof. *)
(*   intros prog n sig H_lookupSig. *)
(*   assert (H_wf: hasAllFunbodies (fsigs (skeleton prog)) (funbodies prog)); *)
(*     try apply hasAllFuns; unfold hasAllFunbodies in H_wf; destruct H_wf as [H_wf1 H_wf2]. *)
(*   clear H_wf2. rewrite Forall_forall in H_wf1. specialize (H_wf1 (n, (fst sig), (snd sig))). *)
(*   destruct sig. *)
(*   rewrite <- In_funsig_lookupsig in H_lookupSig. specialize (H_wf1 H_lookupSig). *)
(*   clear - H_wf1. simpl in *. *)
(*   unfold lookupFunctionBody. induction (funbodies prog). *)
(*   -simpl in *. inversion H_wf1. *)
(*   -simpl in *. destruct (eq_Name n (fst a)) eqn:E. *)
(*    +rewrite eq_Name_symm in E. rewrite E. exists (snd a). reflexivity. *)
(*    +rewrite eq_Name_symm in E. rewrite E. apply IHf.  assumption. *)
(* Qed. *)

(* Lemma lookupFunctionBody_lookupFunctionSig : forall (prog : program) (n : Name) (e : expr), *)
(*     lookupFunctionBody prog n = Some e -> *)
(*     exists sig, lookupFunctionSig (skeleton prog) n = Some sig. *)
(* Proof. *)
(*   intros prog n e H_lookupBody. *)
(*   assert (H_wf: hasAllFunbodies (fsigs (skeleton prog)) (funbodies prog)); *)
(*     try apply hasAllFuns; unfold hasAllFunbodies in H_wf; destruct H_wf as [H_wf1 H_wf2]. *)
(*   rewrite lookupFunctionBody_In in H_lookupBody.  *)
(*   clear H_wf1. rewrite Forall_forall in H_wf2. specialize (H_wf2 (n,e) H_lookupBody). clear - H_wf2. *)
(*   unfold lookupFunctionSig. induction (fsigs (skeleton prog)). *)
(*   -simpl in *. inversion H_wf2. *)
(*   -simpl in *. destruct (eq_Name (fst (fst a)) n) eqn:E. *)
(*    +destruct a as [[a0 a1] a2]. exists (a1, a2). simpl. name_eq_tac. simpl. name_refl_tac. *)
(*    +destruct a as [[a0 a1] a2]. simpl in *. rewrite E. apply IHf. assumption. *)
(* Qed. *)

(**************************************************************************************************)
(** Given the qualified name of a generator function, return its body, i.e. a list of cases.      *)
(**************************************************************************************************)
Definition lookup_gfun_bods_x (bodies : gfun_bods) (qn : QName) : option gfun_bod_named :=
  find (fun body => eq_QName qn (fst body)) bodies.

Definition lookup_gfun_bods_g (p : program) (qn : QName) : option gfun_bod_named :=
  lookup_gfun_bods_x (program_gfun_bods_g p) qn.
Definition lookup_gfun_bods_l (p : program) (qn : QName) : option gfun_bod_named :=
  lookup_gfun_bods_x (program_gfun_bods_l p) qn.
Definition lookup_gfun_bods_scoped (p : program) (sn : ScopedName) : option gfun_bod_named :=
  match sn with
    | local qn  => lookup_gfun_bods_l p qn
    | global qn => lookup_gfun_bods_g p qn
  end.

Lemma lookup_gfun_bods_g_scoped: forall (qn : QName) (p : program),
    lookup_gfun_bods_g p qn = lookup_gfun_bods_scoped p (global qn).
auto. Qed.

Lemma lookup_gfun_bods_l_scoped: forall (qn : QName) (p : program),
    lookup_gfun_bods_l p qn = lookup_gfun_bods_scoped p (local qn).
auto. Qed.

Lemma lookup_gfun_bods_x_fst: forall (bodies : gfun_bods) (qn : QName) (body_named : gfun_bod_named),
    lookup_gfun_bods_x bodies qn = Some body_named ->
    exists body, body_named = (qn, body).
Proof.
  intros bodies qn body_named H.
  induction bodies; try solve [inversion H].
  simpl in H.
  match goal with
  | [ H: (if ?p then _ else _) = Some _ |- _ ] =>
    destruct p eqn:E
  end.
  - inversion H. apply eq_QName_eq in E. destruct a. simpl in *. subst qn. eauto.
  - IH_tac ltac:(assumption).
Qed.

Lemma lookup_gfun_bods_g_fst: forall (p : program) (qn : QName) (body_named : gfun_bod_named),
    lookup_gfun_bods_g p qn = Some body_named ->
    exists body, body_named = (qn, body).
Proof.
  intros p qn body_named H.
  unfold lookup_gfun_bods_g in H.
  apply lookup_gfun_bods_x_fst in H; assumption.
Qed.

Lemma lookup_gfun_bods_l_fst: forall (p : program) (qn : QName) (body_named : gfun_bod_named),
    lookup_gfun_bods_l p qn = Some body_named ->
    exists body, body_named = (qn, body).
Proof.
  intros p qn body_named H.
  unfold lookup_gfun_bods_l in H.
  apply lookup_gfun_bods_x_fst in H; assumption.
Qed.

Lemma lookup_gfun_bods_scoped_fst: forall (sn : ScopedName) (p : program) (body_named : gfun_bod_named),
    lookup_gfun_bods_scoped p sn = Some body_named ->
    exists body, body_named = (unscope sn, body).
Proof.
  intros sn p body_named H.
  destruct sn; unfold lookup_gfun_bods_scoped in H.
  - apply lookup_gfun_bods_l_fst in H; assumption.
  - apply lookup_gfun_bods_g_fst in H; assumption.
Qed.

(* Lemma lookupGenFunctionBody_In : forall (prog : program) (qn : QName) (cocases : list (ScopedName * expr)), *)
(*     lookup_gfun_bods_g prog qn = Some cocases <-> *)
(*     In (qn, cocases) (comatchbodies prog). *)
(* Proof. *)
(*   intros prog qn cocases. split. *)
(*   -(* -> *) *)
(*     intro H_lookup. unfold lookupGenFunctionBody in H_lookup. *)
(*     induction (comatchbodies prog). *)
(*     +inversion H_lookup. *)
(*     +destruct (eq_QName (fst a) qn) eqn:E. *)
(*      *destruct a. name_eq_tac. inversion H_lookup; subst. simpl. left. reflexivity. *)
(*      *simpl. right. apply IHc. assumption. *)
(*   -(* <- *) *)
(*     intro H_in. *)
(*     assert (H_wf : hasAllComatchfunbodies (cmfsigs (skeleton prog)) (comatchbodies prog)); *)
(*       try apply hasAllComatches;  unfold hasAllComatchfunbodies in H_wf; destruct H_wf as [H_wf1 H_wf2]. *)
(*     rewrite Forall_forall in H_wf2. specialize (H_wf2 (qn, cocases) H_in). *)
(*     assert (H_exists : exists argts, In (qn, argts) (cmfsigs (skeleton prog))). *)
(*     +clear H_wf1. *)
(*      induction (cmfsigs (skeleton prog)); try solve[inversion H_wf2]. *)
(*      simpl in H_wf2. destruct (eq_QName (fst a)) eqn:E. *)
(*      *destruct a. simpl in *. *)
(*       exists l. left. name_eq_tac. *)
(*      *specialize (IHc H_wf2). destruct IHc. *)
(*       exists x. simpl. right. assumption. *)
(*     +destruct H_exists. *)
(*      rewrite Forall_forall in H_wf1. specialize (H_wf1 (qn,x) H). simpl in H_wf1. *)
(*      clear H_wf2 H. *)
(*      unfold lookupGenFunctionBody. *)
(*      induction (comatchbodies prog). *)
(*      *simpl in *. contradiction. *)
(*      *destruct a. simpl in *. destruct H_in. *)
(*       **inversion H; subst. name_refl_tac. *)
(*       **destruct (eq_QName qn q) eqn:E; rewrite eq_QName_symm in E; rewrite E; try solve [apply IHc; assumption]. *)
(*         exfalso. name_eq_tac. simpl in H_wf1. inversion H_wf1. clear - H1 H. *)
(*         induction c; try contradiction. *)
(*         simpl in *. destruct a. destruct H. *)
(*         ***inversion H; subst. simpl in H1. name_refl_tac. simpl in H1. inversion H1. *)
(*         ***apply IHc; try assumption. simpl in H1. destruct (eq_QName qn q). *)
(*            inversion H1. assumption. *)
(* Qed. *)

Lemma lookup_gfun_bods_x_is_first : forall (bodies : gfun_bods) (qn : QName) (body : gfun_bod_named),
    lookup_gfun_bods_x bodies qn = Some body <->
    is_first (qn, snd body) bodies (fun x y => eq_QName (fst x) (fst y)) /\ qn = fst body.
Proof.
  intros bodies qn body.
  unfold iff. split.
  - intro Hlookup. unfold lookup_gfun_bods_x in Hlookup. split.
    induction bodies; try solve [inversion Hlookup].
    + destruct (eq_QName (fst a) qn) eqn:Eqn.
      * destruct a as [a_n a_b]. simpl in *.
        apply eq_QName_eq in Eqn. symmetry in Eqn. rewrite Eqn in *.
        rewrite eq_QName_refl in Hlookup.
        inversion Hlookup as [El]. rewrite <- El in *.
        apply is_first_head.
      * apply is_first_tail.
        -- simpl. rewrite eq_QName_symm. assumption.
        -- destruct a. simpl in *. rewrite eq_QName_symm in Hlookup; rewrite Eqn in Hlookup. apply IHbodies; try assumption.
    + induction bodies; try solve [inversion Hlookup].
      simpl in Hlookup. destruct (eq_QName qn (fst a)) eqn:E.
      * inversion Hlookup as [E_b]; rewrite E_b in *. apply eq_QName_eq; assumption.
      * apply IHbodies; assumption.
  - intro H_pair. unfold lookup_gfun_bods_x. inversion_clear H_pair as [H_is_first E].
    induction bodies as [| bds_head bds_tail]; try solve [inversion H_is_first]; simpl.
    destruct (eq_QName qn (fst bds_head)) eqn:Eqn.
    + rewrite eq_QName_eq in Eqn. inversion H_is_first.
      * destruct body; simpl in *; subst; auto.
      * simpl in *. subst.
        match goal with
        | [ H: eq_QName ?x ?y = false |- _ ] =>
          rewrite Eqn in H; rewrite eq_QName_refl in H; inversion H
        end.
    + destruct bds_head as [a_qn a_dtors]; simpl in *. apply IHbds_tail.
      inversion H_is_first; try assumption.
      match goal with
      | [ H : eq_QName ?x ?y = false |- _ ] => match goal with
                                     | [ E : x = y |- _ ] => rewrite E in H; rewrite eq_QName_refl in H; inversion H
                                     end
      end.
Qed.

Lemma lookup_gfun_bods_scoped_is_first : forall (sn : ScopedName) (p : program) (body : gfun_bod_named),
    lookup_gfun_bods_scoped p sn = Some body <->
    exists qn, qn = fst body /\
          ((is_first (qn, snd body) (program_gfun_bods_g p) (fun x y => eq_QName (fst x) (fst y)) /\ (global qn = sn)) \/
          (is_first (qn, snd body) (program_gfun_bods_l p) (fun x y => eq_QName (fst x) (fst y)) /\ (local qn = sn))).
Proof.
  intros sn p body.
  destruct sn as [qn | qn]; simpl;
  match goal with
  | [  |- ?lookup _ _ = _ _ <-> _ ] => unfold lookup
  end;
  let solve_tac :=
      split; intros;
        [> exists qn; apply lookup_gfun_bods_x_is_first in H; inversion H; split; auto
           |
           inversion H as [qn' H1]; inversion H1; inversion H2;
           match goal with
           | [ H: _ /\ _ = _ |- _ ] =>
             let E := fresh "E" in let H1 := fresh H in inversion H as [H1 E]; clear H; rename H1 into H; inversion E
           end; subst;
           apply lookup_gfun_bods_x_is_first; auto ]
  in [> solve_tac | solve_tac].
Qed.

Ltac is_first_tac :=
  match goal with
  | [ |- ?lookup ?p ?qn = Some ?body <-> is_first (?qn, snd ?body) ?bods _ /\ ?qn = fst ?body ] =>
    split; intros;
       [> let H0 := fresh
          in match lookup with
          | lookup_gfun_bods_g =>
            assert (H0: lookup_gfun_bods_scoped p (global qn) = Some body)
          | lookup_gfun_bods_l =>
            assert (H0: lookup_gfun_bods_scoped p (local qn) = Some body)
          end;
        [> unfold lookup_gfun_bods_scoped; assumption |];
        apply lookup_gfun_bods_scoped_is_first in H0; inversion H0;
        match goal with
        | [ H1: _ /\ _ |- _ ] => inversion H1
        end;
        match goal with
        | [ H3: _ \/ _ |- _ ] => inversion H3
        end;
        match goal with
        | [ H4: _ /\ ?scope _ = ?scope' _ |- _ ] =>
          inversion H4;
          match goal with
          | [ E: scope _ = scope' _ |- _ ] =>
            inversion E; subst; split; try assumption; try reflexivity
          end
        end
       | let H0 := fresh
         in match lookup with
         | lookup_gfun_bods_g =>
           assert (H0: lookup_gfun_bods_scoped p (global qn) = Some body)
         | lookup_gfun_bods_l =>
           assert (H0: lookup_gfun_bods_scoped p (local qn) = Some body)
         end;
         [> apply lookup_gfun_bods_scoped_is_first;
          exists qn; split;
          [> inversion H; assumption
          | match lookup with
            | lookup_gfun_bods_g => left
            | lookup_gfun_bods_l => right
            end;
            inversion H; split; try assumption; try reflexivity
          ]
         |];
         simpl in H0; assumption
       ]
  end.

Lemma lookup_gfun_bods_is_first_g: forall (qn: QName) (p : program) (body : gfun_bod_named),
    lookup_gfun_bods_g p qn = Some body <->
    (is_first (qn, snd body) (program_gfun_bods_g p) (fun x y => eq_QName (fst x) (fst y))) /\ qn = fst body.
Proof.
  intros qn p body; is_first_tac.
Qed.

Lemma lookup_gfun_bods_is_first_l: forall (qn: QName) (p : program) (body : gfun_bod_named),
    lookup_gfun_bods_l p qn = Some body <->
    (is_first (qn, snd body) (program_gfun_bods_l p) (fun x y => eq_QName (fst x) (fst y))) /\ qn = fst body.
Proof.
  intros qn p body; is_first_tac.
Qed.

Lemma in_gfun_bods_lookup_gfun_x : forall (qn : QName) (bodies : gfun_bods),
    (exists body, In (qn, body) bodies) ->
    exists body, lookup_gfun_bods_x bodies qn = Some body.
Proof.
  intros qn bodies H; inversion H; unfold lookup_gfun_bods_x; in_filter_tac; eauto.
Qed.

Lemma in_gfun_bods_lookup_gfun_g : forall (qn : QName) (p : program),
    (exists body, In (qn, body) (program_gfun_bods_g p)) ->
    exists body, lookup_gfun_bods_g p qn = Some body.
Proof.
  intros qn p H; unfold lookup_gfun_bods_g; apply in_gfun_bods_lookup_gfun_x; assumption.
Qed.

Lemma in_gfun_bods_lookup_gfun_l : forall (qn : QName) (p : program),
    (exists body, In (qn, body) (program_gfun_bods_l p)) ->
    exists body, lookup_gfun_bods_l p qn = Some body.
Proof.
  intros qn p H; unfold lookup_gfun_bods_l; apply in_gfun_bods_lookup_gfun_x; assumption.
Qed.

Ltac lookup_gfun_bods_scoped_in_gfun_bods_tac :=
  let H := fresh in
  let H1 := fresh in
  let H2 := fresh in
  let v := fresh "v" in
  match goal with
  | [ Hl: ?lookup ?p ?sn = Some (?qn, ?body) |- In (?qn, ?body) ?l ] =>
    apply lookup_gfun_bods_scoped_is_first in Hl;
      inversion_clear Hl as [v H];
        inversion_clear H as [Hl H1];
          inversion_clear H1 as [H|H];
          inversion_clear H as [H1 H2]; induction l; inversion H2; subst; simpl in *;
            inversion H1; subst;
              [> left; auto | right; IH_tac]
  end.

Lemma lookup_gfun_bods_scoped_in_gfun_bods_l : forall (qn : QName) (p : program) (body : gfun_bod),
    lookup_gfun_bods_scoped p (local qn) = Some (qn, body) ->
    In (qn, body) (program_gfun_bods_l p).
Proof.
  intros qn p body H; lookup_gfun_bods_scoped_in_gfun_bods_tac.
Qed.

Lemma lookup_gfun_bods_scoped_in_gfun_bods_g : forall (qn : QName) (p : program) (body : gfun_bod),
    lookup_gfun_bods_scoped p (global qn) = Some (qn, body) ->
    In (qn, body) (program_gfun_bods_g p).
Proof.
  intros qn p body H; lookup_gfun_bods_scoped_in_gfun_bods_tac.
Qed.

(* Lemma lookupGenFunctionSig_lookupGenFunctionBody : forall (prog : program) (qn : QName) (sig : list TypeName), *)
(*     lookupGenFunctionSig (skeleton prog) qn = Some sig -> *)
(*     exists cocases, lookupGenFunctionBody prog qn = Some cocases. *)
(* Proof. *)
(*   intros prog qn sig H_lookupSig. *)
(*   assert (H_wf : hasAllComatchfunbodies (cmfsigs (skeleton prog)) (comatchbodies prog)); *)
(*     try apply hasAllComatches;  unfold hasAllComatchfunbodies in H_wf; destruct H_wf as [H_wf1 H_wf2]. *)
(*   clear H_wf2. rewrite Forall_forall in H_wf1. *)
(*   rewrite <- In_comatchfunsig_lookupsig in H_lookupSig. *)
(*   specialize (H_wf1 (qn, sig) H_lookupSig). clear - H_wf1. simpl in *. *)
(*   unfold lookupGenFunctionBody. induction (comatchbodies prog). *)
(*   -simpl in H_wf1. inversion H_wf1. *)
(*   -simpl in *. destruct (eq_QName qn (fst a)) eqn:E; rewrite eq_QName_symm in E; rewrite E. *)
(*    +simpl in *. name_eq_tac. exists (snd a). reflexivity. *)
(*    +apply IHc. assumption. *)
(* Qed. *)

(* Lemma lookupGenFunctionBody_lookupGenFunctionSig : forall (prog : program) (qn : QName) (cocases : list (ScopedName * expr)), *)
(*   lookupGenFunctionBody prog qn = Some cocases -> *)
(*   exists sig, lookupGenFunctionSig (skeleton prog) qn = Some sig. *)
(* Proof. *)
(*   intros prog qn cocases H_lookupBody. *)
(*   assert (H_wf : hasAllComatchfunbodies (cmfsigs (skeleton prog)) (comatchbodies prog)); *)
(*     try apply hasAllComatches;  unfold hasAllComatchfunbodies in H_wf; destruct H_wf as [H_wf1 H_wf2]. *)
(*   clear H_wf1. rewrite Forall_forall in H_wf2. *)
(*   rewrite lookupGenFunctionBody_In in H_lookupBody. *)
(*   specialize (H_wf2 (qn, cocases) H_lookupBody). clear - H_wf2. simpl in *. *)
(*   unfold lookupGenFunctionSig. unfold option_map. induction (cmfsigs (skeleton prog)). *)
(*   -simpl in H_wf2. inversion H_wf2. *)
(*   -simpl in *. destruct (eq_QName (fst a) qn) eqn:E. *)
(*    +destruct a. name_eq_tac. simpl. name_refl_tac. exists l. reflexivity. *)
(*    +destruct a. simpl in *. rewrite E. apply IHc. assumption. *)
(* Qed. *)

(**************************************************************************************************)
(** Given the qualified name of a consumer function, return its body, i.e. a list of cocases.     *)
(**************************************************************************************************)
Definition lookup_cfun_bods_x (bodies : cfun_bods) (qn : QName) : option cfun_bod_named :=
  find (fun body => eq_QName qn (fst body)) bodies.
Definition lookup_cfun_bods_g (p : program) (qn : QName) : option cfun_bod_named :=
  lookup_cfun_bods_x (program_cfun_bods_g p) qn.
Definition lookup_cfun_bods_l (p : program) (qn : QName) : option cfun_bod_named :=
  lookup_cfun_bods_x (program_cfun_bods_l p) qn.
Definition lookup_cfun_bods_scoped (p : program) (sn : ScopedName) : option cfun_bod_named :=
  match sn with
    | local qn  => lookup_cfun_bods_l p qn
    | global qn => lookup_cfun_bods_g p qn
  end.

Lemma lookup_cfun_bods_g_scoped: forall (qn : QName) (p : program),
    lookup_cfun_bods_g p qn = lookup_cfun_bods_scoped p (global qn).
auto. Qed.

Lemma lookup_cfun_bods_l_scoped: forall (qn : QName) (p : program),
    lookup_cfun_bods_l p qn = lookup_cfun_bods_scoped p (local qn).
auto. Qed.

Lemma lookup_cfun_bods_x_fst: forall (bodies : cfun_bods) (qn : QName) (body_named : cfun_bod_named),
    lookup_cfun_bods_x bodies qn = Some body_named ->
    exists body, body_named = (qn, body).
Proof.
  intros bodies qn body_named H.
  induction bodies; try solve [inversion H].
  simpl in H.
  match goal with
  | [ H: (if ?p then _ else _) = Some _ |- _ ] =>
    destruct p eqn:E
  end.
  - inversion H. apply eq_QName_eq in E. destruct a. simpl in *. subst qn. eauto.
  - IH_tac ltac:(assumption).
Qed.

Lemma lookup_cfun_bods_g_fst: forall (p : program) (qn : QName) (body_named : cfun_bod_named),
    lookup_cfun_bods_g p qn = Some body_named ->
    exists body, body_named = (qn, body).
Proof.
  intros p qn body_named H.
  unfold lookup_cfun_bods_g in H.
  apply lookup_cfun_bods_x_fst in H; assumption.
Qed.

Lemma lookup_cfun_bods_l_fst: forall (p : program) (qn : QName) (body_named : cfun_bod_named),
    lookup_cfun_bods_l p qn = Some body_named ->
    exists body, body_named = (qn, body).
Proof.
  intros p qn body_named H.
  unfold lookup_cfun_bods_l in H.
  apply lookup_cfun_bods_x_fst in H; assumption.
Qed.

Lemma lookup_cfun_bods_scoped_fst: forall (sn : ScopedName) (p : program) (body_named : cfun_bod_named),
    lookup_cfun_bods_scoped p sn = Some body_named ->
    exists body, body_named = (unscope sn, body).
Proof.
  intros sn p body_named H.
  destruct sn; unfold lookup_cfun_bods_scoped in H.
  - apply lookup_cfun_bods_l_fst in H; assumption.
  - apply lookup_cfun_bods_g_fst in H; assumption.
Qed.

(* Lemma lookupConsFunctionBody_In : forall (prog : program) (qn : QName) (ctors : list (ScopedName * expr)), *)
(*     lookupConsFunctionBody prog qn = Some ctors <-> *)
(*     In (qn, ctors) (matchbodies prog). *)
(* Proof. *)
(*   intros prog n e. split. *)
(*   -(* -> *) *)
(*     intro H_lookup. *)
(*     unfold lookupConsFunctionBody in H_lookup. *)
(*     induction (matchbodies prog). *)
(*     *inversion H_lookup. *)
(*     *destruct (eq_QName (fst a) n) eqn:E. *)
(*      **destruct a. simpl in E. apply eq_QName_eq in E. inversion H_lookup. subst. *)
(*        simpl. left. reflexivity. *)
(*      **simpl. right. apply IHm. assumption. *)
(*   -(* <- *) *)
(*     intro H_in. *)
(*      assert (H_wf : hasAllMatchfunbodies (mfsigs (skeleton prog)) (matchbodies prog)); *)
(*       try apply hasAllMatches;  unfold hasAllMatchfunbodies in H_wf; destruct H_wf as [H_wf1 H_wf2]. *)
(*      rewrite Forall_forall in H_wf2. specialize (H_wf2 (n, e) H_in). *)
(*      assert (H_exists : exists argts rtype, In (n, argts, rtype) (mfsigs (skeleton prog))). *)
(*     +clear H_wf1. *)
(*      induction (mfsigs (skeleton prog)); try (inversion H_wf2). *)
(*      simpl in H_wf2. destruct (eq_QName (fst (fst a)) n) eqn:E. *)
(*      *destruct a as [[a0 a1] a2]. simpl in *. *)
(*       exists a1. exists a2. left. name_eq_tac. *)
(*      *specialize (IHm H_wf2). destruct IHm. destruct H. *)
(*       exists x. exists x0. simpl. right. assumption. *)
(*     +destruct H_exists. destruct H. *)
(*      rewrite Forall_forall in H_wf1. specialize (H_wf1 (n,x,x0) H). simpl in H_wf1. *)
(*      clear H_wf2 H. *)
(*      unfold lookupConsFunctionBody. *)
(*      induction (matchbodies prog). *)
(*      *simpl in *. contradiction. *)
(*      *destruct a. simpl in *. destruct H_in. *)
(*       **inversion H; subst. name_refl_tac. *)
(*       **destruct (eq_QName n q) eqn:E; rewrite eq_QName_symm in E; rewrite E; try solve [apply IHm; assumption]. *)
(*         exfalso. name_eq_tac. simpl in H_wf1. inversion H_wf1. clear - H1 H. *)
(*         induction m; try contradiction. *)
(*         simpl in *. destruct a. destruct H. *)
(*         ***inversion H; subst. simpl in H1. name_refl_tac. simpl in H1. inversion H1. *)
(*         ***apply IHm; try assumption. simpl in H1. destruct (eq_QName n q). *)
(*            inversion H1. assumption. *)
(* Qed. *)

(* Lemma lookupConsFunctionSig_lookupConsFunctionBody : forall (prog : program) (qn : QName) (sig : list TypeName * TypeName), *)
(*     lookupConsFunctionSig (skeleton prog) qn = Some sig -> *)
(*     exists cases, lookupConsFunctionBody prog qn = Some cases. *)
(* Proof. *)
(*   intros prog qn sig H_lookupSig. *)
(*   assert (H_wf : hasAllMatchfunbodies (mfsigs (skeleton prog)) (matchbodies prog)); *)
(*     try apply hasAllMatches;  unfold hasAllMatchfunbodies in H_wf; destruct H_wf as [H_wf1 H_wf2]. *)
(*   clear H_wf2. rewrite Forall_forall in H_wf1. destruct sig. *)
(*   rewrite <- In_matchfunsig_lookupsig in H_lookupSig. *)
(*   specialize (H_wf1 (qn, l, t) H_lookupSig). clear - H_wf1. simpl in *. *)
(*   unfold lookupConsFunctionBody. induction (matchbodies prog). *)
(*   -simpl in H_wf1. inversion H_wf1. *)
(*   -simpl in *. destruct (eq_QName qn (fst a)) eqn:E; rewrite eq_QName_symm in E; rewrite E. *)
(*    +exists (snd a). reflexivity. *)
(*    +apply IHm. assumption. *)
(* Qed. *)

(* Lemma lookupConsFunctionBody_lookupConsFunctionSig : forall (prog : program) (qn : QName) (cases : list (ScopedName * expr)), *)
(*     lookupConsFunctionBody prog qn = Some cases -> *)
(*     exists sig, lookupConsFunctionSig (skeleton prog) qn = Some sig. *)
(* Proof. *)
(*   intros prog qn cases H_lookupBody. *)
(*   assert (H_wf : hasAllMatchfunbodies (mfsigs (skeleton prog)) (matchbodies prog)); *)
(*     try apply hasAllMatches;  unfold hasAllMatchfunbodies in H_wf; destruct H_wf as [H_wf1 H_wf2]. *)
(*   clear H_wf1. rewrite Forall_forall in H_wf2. *)
(*   rewrite lookupConsFunctionBody_In in H_lookupBody. *)
(*   specialize (H_wf2 (qn, cases) H_lookupBody). clear - H_wf2. simpl in *. *)
(*   unfold lookupConsFunctionSig. unfold option_map. induction (mfsigs (skeleton prog)). *)
(*   -simpl in H_wf2. inversion H_wf2. *)
(*   -simpl in *. destruct (eq_QName (fst (fst a)) qn) eqn:E. *)
(*    +name_eq_tac.  destruct a as [[a0 a1] a2]. simpl. name_refl_tac. exists (a1, a2). reflexivity. *)
(*    +destruct a as [[a0 a1] a2]. simpl in *. rewrite E. apply IHm. assumption. *)
(* Qed. *)

Lemma lookup_cfun_bods_x_is_first : forall (bodies : cfun_bods) (qn : QName) (body : cfun_bod_named),
    lookup_cfun_bods_x bodies qn = Some body <->
    is_first (qn, snd body) bodies (fun x y => eq_QName (fst x) (fst y)) /\ qn = fst body.
Proof.
  intros bodies qn body.
  unfold iff. split.
  - intro Hlookup. unfold lookup_cfun_bods_x in Hlookup. split.
    induction bodies; try solve [inversion Hlookup].
    + destruct (eq_QName (fst a) qn) eqn:Eqn.
      * destruct a as [a_n a_b]. simpl in *.
        apply eq_QName_eq in Eqn. symmetry in Eqn. rewrite Eqn in *.
        rewrite eq_QName_refl in Hlookup.
        inversion Hlookup as [El]. rewrite <- El in *.
        apply is_first_head.
      * apply is_first_tail.
        -- simpl. rewrite eq_QName_symm. assumption.
        -- destruct a. simpl in *. rewrite eq_QName_symm in Hlookup; rewrite Eqn in Hlookup. apply IHbodies; try assumption.
    + induction bodies; try solve [inversion Hlookup].
      simpl in Hlookup. destruct (eq_QName qn (fst a)) eqn:E.
      * inversion Hlookup as [E_b]; rewrite E_b in *. apply eq_QName_eq; assumption.
      * apply IHbodies; assumption.
  - intro H_pair. unfold lookup_cfun_bods_x. inversion_clear H_pair as [H_is_first E].
    induction bodies as [| bds_head bds_tail]; try solve [inversion H_is_first]; simpl.
    destruct (eq_QName qn (fst bds_head)) eqn:Eqn.
    + rewrite eq_QName_eq in Eqn. inversion H_is_first.
      * destruct body; simpl in *; subst; auto.
      * simpl in *. subst.
        match goal with
        | [ H: eq_QName ?x ?y = false |- _ ] =>
          rewrite Eqn in H; rewrite eq_QName_refl in H; inversion H
        end.
    + destruct bds_head as [a_qn a_dtors]; simpl in *. apply IHbds_tail.
      inversion H_is_first; try assumption.
      match goal with
      | [ H : eq_QName ?x ?y = false |- _ ] => match goal with
                                     | [ E : x = y |- _ ] => rewrite E in H; rewrite eq_QName_refl in H; inversion H
                                     end
      end.
Qed.

Lemma lookup_cfun_bods_scoped_is_first : forall (sn : ScopedName) (p : program) (body : cfun_bod_named),
    lookup_cfun_bods_scoped p sn = Some body <->
    exists qn, qn = fst body /\
          ((is_first (qn, snd body) (program_cfun_bods_g p) (fun x y => eq_QName (fst x) (fst y)) /\ (global qn = sn)) \/
          (is_first (qn, snd body) (program_cfun_bods_l p) (fun x y => eq_QName (fst x) (fst y)) /\ (local qn = sn))).
Proof.
  intros sn p body.
  destruct sn as [qn | qn]; simpl;
  match goal with
  | [  |- ?lookup _ _ = _ _ <-> _ ] => unfold lookup
  end;
  let solve_tac :=
      split; intros;
        [> exists qn; apply lookup_cfun_bods_x_is_first in H; inversion H; split; auto
           |
           inversion H as [qn' H1]; inversion H1; inversion H2;
           match goal with
           | [ H: _ /\ _ = _ |- _ ] =>
             let E := fresh "E" in let H1 := fresh H in inversion H as [H1 E]; clear H; rename H1 into H; inversion E
           end; subst;
           apply lookup_cfun_bods_x_is_first; auto ]
  in [> solve_tac | solve_tac].
Qed.

Lemma in_cfun_bods_lookup_cfun_x : forall (qn : QName) (bodies : cfun_bods),
    (exists body, In (qn, body) bodies) ->
    exists body, lookup_cfun_bods_x bodies qn = Some body.
Proof.
  intros qn bodies H; inversion H; unfold lookup_cfun_bods_x; in_filter_tac; eauto.
Qed.

Lemma in_cfun_bods_lookup_cfun_g : forall (qn : QName) (p : program),
    (exists body, In (qn, body) (program_cfun_bods_g p)) ->
    exists body, lookup_cfun_bods_g p qn = Some body.
Proof.
  intros qn p H; unfold lookup_cfun_bods_g; apply in_cfun_bods_lookup_cfun_x; assumption.
Qed.

Lemma in_cfun_bods_lookup_cfun_l : forall (qn : QName) (p : program),
    (exists body, In (qn, body) (program_cfun_bods_l p)) ->
    exists body, lookup_cfun_bods_l p qn = Some body.
Proof.
  intros qn p H; unfold lookup_cfun_bods_l; apply in_cfun_bods_lookup_cfun_x; assumption.
Qed.

Ltac lookup_cfun_bods_scoped_in_cfun_bods_tac :=
  let H := fresh in
  let H1 := fresh in
  let H2 := fresh in
  let v := fresh "v" in
  match goal with
  | [ Hl: ?lookup ?p ?sn = Some (?qn, ?body) |- In (?qn, ?body) ?l ] =>
    apply lookup_cfun_bods_scoped_is_first in Hl;
      inversion_clear Hl as [v H];
        inversion_clear H as [Hl H1];
          inversion_clear H1 as [H|H];
          inversion_clear H as [H1 H2]; induction l; inversion H2; subst; simpl in *;
            inversion H1; subst;
              [> left; auto | right; IH_tac]
  end.

Lemma lookup_cfun_bods_scoped_in_cfun_bods_l : forall (qn : QName) (p : program) (body : cfun_bod),
    lookup_cfun_bods_scoped p (local qn) = Some (qn, body) ->
    In (qn, body) (program_cfun_bods_l p).
Proof.
  intros qn p body H; lookup_cfun_bods_scoped_in_cfun_bods_tac.
Qed.

Lemma lookup_cfun_bods_scoped_in_cfun_bods_g : forall (qn : QName) (p : program) (body : cfun_bod),
    lookup_cfun_bods_scoped p (global qn) = Some (qn, body) ->
    In (qn, body) (program_cfun_bods_g p).
Proof.
  intros qn p body H; lookup_cfun_bods_scoped_in_cfun_bods_tac.
Qed.

Definition lookup_case (cs : list (ScopedName * expr))(sn : ScopedName) : option ( ScopedName * expr) :=
  find (fun case => eq_ScopedName sn (fst case)) cs.

Definition lookup_cocase (ccs : list (ScopedName * expr)) (sn : ScopedName) : option (ScopedName * expr) :=
  find (fun cocase => eq_ScopedName sn (fst cocase)) ccs.

Lemma lookup_case_In : forall (cs : list (ScopedName * expr))(sn : ScopedName)(ctor : ScopedName * expr),
    lookup_case cs sn = Some ctor ->
    In ctor cs /\ sn = (fst ctor).
Proof.
  intros cs sn ctor H. unfold lookup_case in H. induction cs.
  - inversion H.
  - simpl in H. destruct (eq_ScopedName sn (fst a)) eqn:E.
    + split.
      * simpl. left. inversion H. reflexivity.
      * inversion H; subst. apply eq_ScopedName_eq in E. assumption.
    + split.
      * simpl. right. apply IHcs. assumption.
      * apply IHcs. assumption.
Qed.

Lemma lookup_cocase_In : forall (ccs : list (ScopedName * expr)) (sn : ScopedName) (dtor : ScopedName * expr),
    lookup_cocase ccs sn = Some dtor ->
    In dtor ccs /\ sn = (fst dtor).
Proof.
  intros ccs sn dtor H. unfold lookup_cocase. induction ccs.
  - inversion H.
  - simpl in H. destruct (eq_ScopedName sn (fst a)) eqn:E.
    + split.
      * simpl. left. inversion H. reflexivity.
      * inversion H; subst. apply eq_ScopedName_eq in E. assumption.
    + split.
      * simpl. right. apply IHccs. assumption.
      * apply IHccs. assumption.
Qed.

Lemma lookup_case_is_first : forall (sn : ScopedName) (body : expr) (cases : list (ScopedName * expr)),
    lookup_case cases sn = Some (sn, body) <->
    is_first (sn, body) cases (fun x y => eq_ScopedName (fst x) (fst y)).
Proof.
  intros sn body cases.
  unfold iff. split.
  -intro Hl.
   induction cases.
   +simpl in Hl. discriminate Hl.
   +simpl in Hl. destruct (eq_ScopedName sn (fst a)) eqn:Esn.
    *inversion Hl. apply is_first_head.
    *apply is_first_tail.
     --apply lookup_case_In in Hl. apply proj2 in Hl. rewrite Hl in Esn. assumption.
     --apply IHcases. assumption.
  -intro Hfirst.
   induction cases; try solve [inversion Hfirst].
   destruct a as [sn_a body_a]. simpl.
   destruct (eq_ScopedName sn sn_a) eqn:Esn.
   +inversion Hfirst; try reflexivity.
    simpl in H2. rewrite H2 in Esn. discriminate Esn.
   +apply IHcases.
    inversion Hfirst; try assumption. subst. rewrite eq_ScopedName_refl in Esn. discriminate Esn.
Qed.

Lemma lookup_cocase_is_first : forall (sn : ScopedName)(body : expr) (cocases : list (ScopedName * expr)),
    lookup_cocase cocases sn = Some (sn, body) <->
    is_first (sn, body) cocases (fun x y => eq_ScopedName (fst x) (fst y)).
Proof.
  intros sn body cocases.
  unfold iff. split.
  -intro Hl.
   induction cocases.
   +simpl in Hl. discriminate Hl.
   +simpl in Hl. destruct (eq_ScopedName sn (fst a)) eqn:Esn.
    *inversion Hl. apply is_first_head.
    *apply is_first_tail.
     --apply lookup_case_In in Hl. apply proj2 in Hl. rewrite Hl in Esn. assumption.
     --apply IHcocases. assumption.
  -intro Hfirst.
   induction cocases; try solve [inversion Hfirst].
   destruct a as [sn_a  body_a]. simpl.
   destruct (eq_ScopedName sn sn_a) eqn:Esn.
   +inversion Hfirst; try reflexivity.
    simpl in H2. rewrite H2 in Esn. discriminate Esn.
   +apply IHcocases.
    inversion Hfirst; try assumption. subst. rewrite eq_ScopedName_refl in Esn. discriminate Esn.
Qed.

Lemma in_cocases_lookup_cocase : forall (sn : ScopedName) (ccs : list (ScopedName * expr)),
    (exists e, In (sn, e) ccs) ->
    exists cocase, lookup_cocase ccs sn = Some cocase.
Proof.
  intros sn ccs H. inversion H. unfold lookup_cocase. in_filter_tac; eauto.
Qed.

Lemma in_cases_lookup_case : forall (sn : ScopedName) (ccs : list (ScopedName * expr)),
    (exists e, In (sn, e) ccs) ->
    exists case, lookup_case ccs sn = Some case.
Proof.
  intros sn ccs H. inversion H. unfold lookup_case. in_filter_tac; eauto.
Qed.

Lemma lookup_comatch_cocase_succeeds : forall (p : program) (sn : ScopedName) (qn : QName) (ccs : list (ScopedName * expr)),
    (exists ctx bs dtor_args tn, (program_skeleton p / ctx |- (E_DestrCall sn (E_CoMatch qn bs ccs) dtor_args) : tn)) ->
    exists cocase, lookup_cocase ccs sn = Some cocase.
Proof.
  intros p sn qn ccs H.
  inversion_clear H as [ctx [bs [dtor_args [tn H']]]].
  inversion_clear H'.
  unfold lookup_cocase.
  inversion H0; subst. clear H0.
  apply in_dtors_lookup_dtors' in H. inversion_clear H as [dtors [H_lookup H_in]]; simpl in H_lookup.
  rewrite H5 in H10.
  rewrite H10 in H_lookup. inversion H_lookup. subst dtors; clear H_lookup H10.
  gen_induction dtorlist ccs.
  - inversion H12; subst.
    symmetry in H2; apply map_eq_nil in H2; subst dtorlist.
    inversion H_in.
  - simpl. match_destruct_tac; eauto.
    destruct dtorlist; try solve [inversion H12].
    inversion_clear H_in.
    + inversion_clear H12. subst p0; simpl in *.
      inversion H11; subst. destruct a. subst s.
      simpl in E_match. name_refl_contradiction_tac.
    + apply IHccs with (dtorlist := dtorlist); auto; try Forall_tail_tac.
      inversion H12; auto.
Qed.

Lemma lookup_gfun_cocase_succeeds : forall (p : program) (sn_gfun sn_dtor : ScopedName) (ccs : gfun_bod_named),
    lookup_gfun_bods_scoped p sn_gfun = Some ccs ->
    (exists ctx gfun_args dtor_args tn, (program_skeleton p / ctx |- (E_DestrCall sn_dtor (E_GenFunCall sn_gfun gfun_args) dtor_args) : tn)) ->
    exists cocase, lookup_cocase (snd ccs) sn_dtor = Some cocase.
Proof.
  intros p sn_gfun sn_dtor ccs H_lookup H_t';
  let rec destruct_tc := inversion_clear H_t' as [ctx [gfun_args [dtor_args [tn H_t]]]];
                           inversion H_t; subst; clear H_t
  with
    pose_lookup_dtor := match goal with
                        | [ H: In _ (skeleton_dtors _) |- _ ] =>
                          let H' := fresh H_lookup_dtors in pose proof H as H';
                                                              apply in_dtors_lookup_dtors' in H'
                        end
  with
    in_dtors_to_in_cdts := match goal with
                           | [ H: In _ (skeleton_dtors _) |- _ ] => apply In_dtors_in_cdts in H
                           end
  with

    housekeeping_scoped := match goal with
                       | [ H : ?lookup_X ?p ?qn = Some ?ccs |- _ ] =>
                         unfold lookup_X in H;
                         let H_tc := fresh "H_tc"
                         in match lookup_X with
                            | lookup_gfun_bods_g => pose proof (program_gfun_bods_typecheck_g p) as H_tc
                            | lookup_gfun_bods_l => pose proof (program_gfun_bods_typecheck_l p) as H_tc
                            end;
                            match type of H with
                            | ?l ?bods qn = Some ccs =>
                                unfold l in H;
                                match type of H with
                                | find _ ?bods = Some ccs =>
                                    match type of H_tc with
                                    | ?tc (program_skeleton p) bods =>
                                    unfold tc in H_tc
                                    end
                                end
                            end
                       end
   with
     invert_tc_gfun := match goal with
                       | [ H: program_skeleton p / _ |- (E_GenFunCall _ _) : _ |- _ ] =>
                         inversion H; subst;
                           clear H
                       end
   with
     induction_on_gfun_bods :=
                           match goal with
                           | [ H: context [program_gfun_bods_l p] |- _ ] =>
                             induction (program_gfun_bods_l p) as [|bod bods]
                           | [ H: context [program_gfun_bods_g p] |- _ ] =>
                             induction (program_gfun_bods_g p) as [|bod bods]
                           end;
                             try solve [inversion H_lookup]
   with
     destruct_eq_QName_in_lookup :=
         match goal with
         | [ H: find _ _ = Some _ |- _ ] =>
                 simpl in H;
                 match goal with
                 | [ H1: context [eq_QName ?l ?r] |- _ ] =>
                         match H1 with
                         | H => let E := fresh "E" in destruct (eq_QName l r) eqn:E
                         end
                 end
         end
   with
      subst_qn_fst_bod := name_eq_rewrite_tac; simpl in E; subst qn
   with
      destr_subst_ccs :=
                destruct ccs as [ccs_n ccs_b]; simpl in *; inversion H_lookup; subst; simpl in *
   with
      invert_tc_bodies :=
                match goal with
                | [ Ht: Forall ?P ((_, _) :: ?bods) |- _ ] => inversion Ht
                end
   with
      invert_tc_fst :=
                match goal with
                | [ H1: exists q args, _ /\ _ |- _ ] =>
                        simpl in H1; inversion H1 as [qn' [args H_ccs]]; inversion H_ccs as [H_ccs_sig H_ccs_tc]; subst x l; clear H_ccs
                end
   with
      assert_E :=
                match goal with
                | [ H: In _ (skeleton_gfun_sigs_l _) |- _ ] =>
                        apply In_gfun_sig_lookup_gfun_sig_l in H; rewrite H in H_ccs_sig; inversion H_ccs_sig; auto
                | [ H: In _ (skeleton_gfun_sigs_g _) |- _ ] =>
                        apply In_gfun_sig_lookup_gfun_sig_g in H; rewrite H in H_ccs_sig; inversion H_ccs_sig; auto
                end
   with
      assert_H_in_dtorlist :=
                    match goal with
                    | [ H: exists x, lookup_dtors _ _ = Some x /\ _ |- _ ] =>
                            let Dtors := fresh dtors in
                            let H' := fresh H in
                            inversion H as [Dtors H'];
                            let H_lookup := fresh H_lookup_dtors in
                            let H_in := fresh H_in_dtors in
                            inversion H' as [H_lookup H_in]; clear H';
                            match goal with
                            | [ H_l: lookup_dtors _ ?name = Some ?dtors' |- _ ] =>
                                    match H_l with
                                    | H_lookup => fail 1
                                    | _ =>
                                            match type of H_lookup with
                                            | lookup_dtors _ ?name' = _ =>
                                                    subst_in name name' H_l;
                                                    rewrite H_l in H_lookup; inversion H_lookup
                                            end
                                    end
                            end
                    end; assumption
   with
      dtorlist_induction to_gen := generalize dependent to_gen; induction dtorlist as [|dtor dtors_rest];
                      intros; try solve [inversion H_in_dtorlist]
   with
     clear_unnecessary :=
                      match goal with
                         | [ H: Forall _ (combine _ ?dtorlist) |- _ ] =>
                           match goal with
                           | [ H1: _ /// _ |||- _ ::: _ |- _ ] =>
                             match goal with
                             | [ H2: In _ dtorlist |- _ ] =>
                               clear - H H1 H2
                             end
                           end
                         end
   with
     destruct_ccs_b := destruct ccs_b as [| ccs ccss];
                         try solve [match goal with
                                    | [ H: (_ /// _ |||- _ ::: _) |- _ ] => inversion H end]
   with
     invert_list_typing :=
                        match goal with
                        | [ H: Forall _ (combine (_ :: _) (_ :: _)) |- _ ] => inversion H; subst
                        end
   with
     destruct_tuples := destruct ccs as [ccs_sn ccs_e];
                          destruct dtor as [[dtor_sn dtor_ts] dtor_t]; subst
   with
     destruct_In_dtorlist :=
                          match goal with
                          | [ H: In _ (_ :: _) |- _ ] => inversion H
                          end
   with
     in_dtorlist_eq_case :=
                            match goal with
                            | [ E: ?x = ?y |- _ ] => inversion E
                            end; eexists; left; eauto; idtac (* for some reason idtac is necessary here *)
   with
     specialize_IH := match goal with
                      | [ H: context c [forall ccs, ?b] |- _ ] =>
                        match b with
                        | context [In _ _] =>
                          match goal with
                          | [ _: _ /// _ |||- map _ (_ :: ?ccss) ::: _ |- _ ] =>
                            specialize H with (ccs_b := ccss)
                          end
                        end
                      end

   with
     solve_branch := invert_tc_gfun; induction_on_gfun_bods; destruct_eq_QName_in_lookup;
            [> subst_qn_fst_bod; destr_subst_ccs; invert_tc_bodies; invert_tc_fst;
                assert (E : (ccs_n, argts) = (qn', args)); [> assert_E | ];
                destruct E; inversion H_ccs_tc; subst;
                assert (H_in_dtorlist : In (sn_dtor, dargs, tn) dtorlist); [> assert_H_in_dtorlist | ];
                clear_unnecessary;
                let to_generalize := match goal with
                                     | [ gen: gfun_bod |- _ ] => gen
                                     end in
                dtorlist_induction to_generalize; destruct_ccs_b;
                invert_list_typing; destruct_tuples;
                destruct_In_dtorlist;
                    [> in_dtorlist_eq_case
                    | specialize_IH;
                      match goal with
                      | [ H: _ /// _ |||- _ ::: _ |- _ ] =>
                        apply In_right_over_exists; IH_tac ltac:(inversion H; subst; assumption)
                    end]
            | IH_tac ltac:(try Forall_tail_tac) ]
   in destruct_tc; pose_lookup_dtor; in_dtors_to_in_cdts;
      apply in_cocases_lookup_cocase;
      destruct sn_gfun as [qn | qn]; simpl in H_lookup; housekeeping_scoped;
        [> solve_branch | solve_branch ].
Qed.

Lemma lookup_cfun_case_succeeds : forall (p : program) (sn_cfun sn_ctor : ScopedName) (ccs : cfun_bod_named),
    lookup_cfun_bods_scoped p sn_cfun = Some ccs ->
    (exists ctx cfun_args ctor_args tn, (program_skeleton p / ctx |- (E_ConsFunCall sn_cfun (E_Constr sn_ctor ctor_args) cfun_args) : tn)) ->
    exists case, lookup_case (snd ccs) sn_ctor = Some case.
Proof.
  intros p sn_cfun sn_ctor ccs H_lookup H_t';
  let rec destruct_tc := inversion_clear H_t' as [ctx [cfun_args [ctor_args [tn H_t]]]];
                           inversion H_t; subst; clear H_t
   with
     invert_tc_constr := match goal with
                       | [ H: program_skeleton p / _ |- (E_Constr _ _) : _ |- _ ] =>
                         inversion H; subst;
                           clear H
                       end
  with
    pose_lookup_ctor := match goal with
                        | [ H: In _ (skeleton_ctors _) |- _ ] =>
                          let H' := fresh H_lookup_ctors in pose proof H as H';
                                                              apply in_ctors_lookup_ctors' in H'
                        end
  with
    in_ctors_to_in_dts := match goal with
                           | [ H: In _ (skeleton_ctors _) |- _ ] => apply In_ctors_in_dts in H
                           end
  with

    housekeeping_scoped := match goal with
                       | [ H : ?lookup_X ?p ?qn = Some ?ccs |- _ ] =>
                         unfold lookup_X in H;
                         let H_tc := fresh "H_tc"
                         in match lookup_X with
                            | lookup_cfun_bods_g => pose proof (program_cfun_bods_typecheck_g p) as H_tc
                            | lookup_cfun_bods_l => pose proof (program_cfun_bods_typecheck_l p) as H_tc
                            end;
                            match type of H with
                            | ?l ?bods qn = Some ccs =>
                                unfold l in H;
                                match type of H with
                                | find _ ?bods = Some ccs =>
                                    match type of H_tc with
                                    | ?tc (program_skeleton p) bods =>
                                    unfold tc in H_tc
                                    end
                                end
                            end
                       end
   with
     induction_on_cfun_bods :=
                           match goal with
                           | [ H: context [program_cfun_bods_l p] |- _ ] =>
                             induction (program_cfun_bods_l p) as [|bod bods]
                           | [ H: context [program_cfun_bods_g p] |- _ ] =>
                             induction (program_cfun_bods_g p) as [|bod bods]
                           end;
                             try solve [inversion H_lookup]
   with
     destruct_eq_QName_in_lookup :=
         match goal with
         | [ H: find _ _ = Some _ |- _ ] =>
                 simpl in H;
                 match goal with
                 | [ H1: context [eq_QName ?l ?r] |- _ ] =>
                         match H1 with
                         | H => let E := fresh "E" in destruct (eq_QName l r) eqn:E
                         end
                 end
         end
   with
      subst_qn_fst_bod := name_eq_rewrite_tac; simpl in E; subst qn
   with
      destr_subst_ccs :=
                destruct ccs as [ccs_n ccs_b]; simpl in *; inversion H_lookup; subst; simpl in *
   with
      invert_tc_bodies :=
                match goal with
                | [ Ht: Forall ?P ((_, _) :: ?bods) |- _ ] => inversion Ht
                end
   with
      invert_tc_fst :=
                match goal with
                | [ H1: exists q args t, _ /\ _ |- _ ] =>
                        simpl in H1; inversion H1 as [qn' [args [t H_ccs]]]; inversion H_ccs as [H_ccs_sig H_ccs_tc]; subst x l; clear H_ccs
                end
   with
      assert_E :=
                match goal with
                | [ H: In _ (skeleton_cfun_sigs_l _) |- _ ] =>
                        apply In_cfun_sig_lookup_cfun_sig_l in H; rewrite H in H_ccs_sig; inversion H_ccs_sig; auto
                | [ H: In _ (skeleton_cfun_sigs_g _) |- _ ] =>
                        apply In_cfun_sig_lookup_cfun_sig_g in H; rewrite H in H_ccs_sig; inversion H_ccs_sig; auto
                end
   with
      assert_H_in_ctorlist :=
                    match goal with
                    | [ H: exists x, lookup_ctors _ _ = Some x /\ _ |- _ ] =>
                            let Ctors := fresh ctors in
                            let H' := fresh H in
                            inversion H as [Ctors H'];
                            let H_lookup := fresh H_lookup_ctors in
                            let H_in := fresh H_in_ctors in
                            inversion H' as [H_lookup H_in]; clear H';
                            match goal with
                            | [ H_l: lookup_ctors _ ?name = Some ?ctors' |- _ ] =>
                                    match H_l with
                                    | H_lookup => fail 1
                                    | _ =>
                                            match type of H_lookup with
                                            | lookup_ctors _ ?name' = _ =>
                                                    subst_in name name' H_l;
                                                    rewrite H_l in H_lookup; inversion H_lookup
                                            end
                                    end
                            end
                    end; assumption
   with
      ctorlist_induction to_gen := generalize dependent to_gen; induction ctorlist as [|ctor ctors_rest];
                      intros; try solve [inversion H_in_ctorlist]
   with
     clear_unnecessary :=
                      match goal with
                         | [ H: Forall _ (combine _ ?ctorlist) |- _ ] =>
                           match goal with
                           | [ H1: _ /// _ |||- _ ::: _ |- _ ] =>
                             match goal with
                             | [ H2: In _ ctorlist |- _ ] =>
                               clear - H H1 H2
                             end
                           end
                         end
   with
     destruct_ccs_b := destruct ccs_b as [| ccs ccss];
                         try solve [match goal with
                                    | [ H: (_ /// _ |||- _ ::: _) |- _ ] => inversion H end]
   with
     invert_list_typing :=
                        match goal with
                        | [ H: Forall _ (combine (_ :: _) (_ :: _)) |- _ ] => inversion H; subst
                        end
   with
     destruct_tuples := destruct ccs as [ccs_sn ccs_e];
                          destruct ctor as [ctor_sn ctor_ts]; subst
   with
     destruct_In_ctorlist :=
                          match goal with
                          | [ H: In _ (_ :: _) |- _ ] => inversion H
                          end
   with
     in_ctorlist_eq_case :=
                            match goal with
                            | [ E: ?x = ?y |- _ ] => inversion E
                            end; eexists; left; eauto; idtac (* for some reason idtac is necessary here *)
   with
     specialize_IH := match goal with
                      | [ H: context c [forall ccs, ?b] |- _ ] =>
                        match b with
                        | context [In _ _] =>
                          match goal with
                          | [ _: _ /// _ |||- map _ (_ :: ?ccss) ::: _ |- _ ] =>
                            specialize H with (ccs_b := ccss)
                          end
                        end
                      end

   with
     solve_branch := invert_tc_constr; pose_lookup_ctor; in_ctors_to_in_dts;
            induction_on_cfun_bods; destruct_eq_QName_in_lookup;
            [> subst_qn_fst_bod; destr_subst_ccs; invert_tc_bodies; invert_tc_fst;
                assert (E : (ccs_n, argts) = (qn', args)); [> assert_E | ];
                destruct E; inversion H_ccs_tc; subst ;
                assert (H_in_ctorlist : In (sn_ctor, cargs) ctorlist) ; [> assert_H_in_ctorlist | ];
                clear_unnecessary;
                let to_generalize := match goal with
                                     | [ gen: cfun_bod |- _ ] => gen
                                     end in
                ctorlist_induction to_generalize; destruct_ccs_b;
                invert_list_typing; destruct_tuples;
                destruct_In_ctorlist;
                    [> in_ctorlist_eq_case
                    | specialize_IH;
                      match goal with
                      | [ H: _ /// _ |||- _ ::: _ |- _ ] =>
                        apply In_right_over_exists; IH_tac ltac:(inversion H; subst; assumption)
                    end]
            | IH_tac ltac:(try Forall_tail_tac) ]
   in destruct_tc;
      apply in_cases_lookup_case; simpl in H_lookup; housekeeping_scoped;
        [> solve_branch | solve_branch ].
Qed.

Opaque lookup_case lookup_cocase.

Lemma cfun_bods_unique_l : forall (p : program),
    unique (map fst (program_cfun_bods_l p)).
Proof.
  intros p;
  pose proof (program_has_all_cfun_bods_l p) as H;
  unfold has_all_cfun_bods in H;
  pose proof (skeleton_cfun_sigs_names_unique_l (program_skeleton p)) as H_unique;
  unfold cfun_sigs_names_unique in H_unique;
  rewrite <- H; assumption.
Qed.

Lemma cfun_bods_unique_g : forall (p : program),
    unique (map fst (program_cfun_bods_g p)).
Proof.
  intro p;
  pose proof (program_has_all_cfun_bods_g p) as H;
  unfold has_all_cfun_bods in H;
  pose proof (skeleton_cfun_sigs_names_unique_g (program_skeleton p)) as H_unique;
  unfold cfun_sigs_names_unique in H_unique;
  rewrite <- H; assumption.
Qed.

Lemma gfun_bods_unique_l : forall (p : program),
    unique (map fst (program_gfun_bods_l p)).
Proof.
  intro p;
  pose proof (program_has_all_gfun_bods_l p) as H;
  unfold has_all_gfun_bods in H;
  pose proof (skeleton_gfun_sigs_names_unique_l (program_skeleton p)) as H_unique;
  unfold gfun_sigs_names_unique in H_unique;
  rewrite <- H; assumption.
Qed.

Lemma gfun_bods_unique_g : forall (p : program),
    unique (map fst (program_gfun_bods_g p)).
Proof.
  intro p;
  pose proof (program_has_all_gfun_bods_g p) as H;
  unfold has_all_gfun_bods in H;
  pose proof (skeleton_gfun_sigs_names_unique_g (program_skeleton p)) as H_unique;
  unfold gfun_sigs_names_unique in H_unique;
  rewrite <- H; assumption.
Qed.

Lemma fun_bods_unique : forall (p : program),
    unique (map fst (program_fun_bods p)).
Proof.
  intro p;
  pose proof (program_has_all_fun_bods p) as H;
  unfold has_all_fun_bods in H;
  pose proof (skeleton_fun_sigs_names_unique (program_skeleton p)) as H_unique;
  unfold fun_sigs_names_unique in H_unique;
  rewrite <- H; assumption.
Qed.

Global Opaque lookup_cfun_bods_g lookup_cfun_bods_l lookup_cfun_bods_x lookup_cfun_bods_scoped.
Global Opaque lookup_gfun_bods_g lookup_gfun_bods_l lookup_gfun_bods_x lookup_gfun_bods_scoped.

Lemma gfun_cocase_order_g: forall (p : program) (gfun: gfun_bod_named),
    In gfun (program_gfun_bods_g p) ->
    map (fun x => fst x) (snd gfun)
    = filter (fun t => eq_TypeName (fst (unscope t)) (fst (fst gfun))) (map (fun x => fst (fst x)) (skeleton_dtors (program_skeleton p))).
Proof.
  intros p gfun H_in.
  pose proof (program_gfun_bods_typecheck_g p) as H_t.
  unfold gfun_bods_g_typecheck in H_t; rewrite Forall_forall in H_t.
  specialize (H_t gfun H_in). inversion H_t as [qn [args [H_lookup H_t']]].
  inversion H_t'; subst. apply lookup_dtors_name_order in H6.
  unfold gfun_bod in *. rewrite <- H6.
  clear - H7  H8. destruct gfun; simpl in *.
  gen_induction dtorlist g; destruct dtorlist; inversion H8; subst; auto.
  simpl in *. inversion H7; subst; auto.
  repeat match goal with
         | [  |- context [fst (fst ?x)] ] => destruct x; simpl in *
         | [  |- context [fst ?x] ] => destruct x; simpl in *
         end; f_equal; auto.
Qed.

Lemma gfun_cocase_order_l: forall (p : program) (gfun: gfun_bod_named),
    In gfun (program_gfun_bods_l p) ->
    map (fun x => fst x) (snd gfun)
    = filter (fun t => eq_TypeName (fst (unscope t)) (fst (fst gfun))) (map (fun x => fst (fst x)) (skeleton_dtors (program_skeleton p))).
Proof.
  intros p gfun H_in.
  pose proof (program_gfun_bods_typecheck_l p) as H_t.
  unfold gfun_bods_l_typecheck in H_t; rewrite Forall_forall in H_t.
  specialize (H_t gfun H_in). inversion H_t as [qn [args [H_lookup H_t']]].
  inversion H_t'; subst. apply lookup_dtors_name_order in H6.
  unfold gfun_bod in *. rewrite <- H6.
  clear - H7  H8. destruct gfun; simpl in *.
  gen_induction dtorlist g; destruct dtorlist; inversion H8; subst; auto.
  simpl in *. inversion H7; subst; auto.
  repeat match goal with
         | [  |- context [fst (fst ?x)] ] => destruct x; simpl in *
         | [  |- context [fst ?x] ] => destruct x; simpl in *
         end; f_equal; auto.
Qed.

Lemma comatch_names_unique_global_sublist: forall fs cfs_g cfs_l gfs_g gfs_l,
    comatch_names_unique fs (cfs_g ++ cfs_l) (gfs_g ++ gfs_l) ->
    comatch_names_unique fs cfs_g gfs_g.
Proof.
  intros.
  unfold comatch_names_unique in *.
  repeat (repeat rewrite map_app in *; repeat rewrite concat_app in * ).
  repeat rewrite <- app_assoc in H.
  unique_sublist_tac.
Qed.

Lemma match_names_unique_global_sublist: forall fs cfs_g cfs_l gfs_g gfs_l,
    match_names_unique fs (cfs_g ++ cfs_l) (gfs_g ++ gfs_l) ->
    match_names_unique fs cfs_g gfs_g.
Proof.
  intros.
  unfold match_names_unique in *.
  repeat (repeat rewrite map_app in *; repeat rewrite concat_app in * ).
  repeat rewrite <- app_assoc in H.
  unique_sublist_tac.
Qed.


(** 4. Compiler *)
Require Import closed_lterm krivine List lterm substitute_list.

Fixpoint comp (t: lterm) : krivine_code :=
  match t with
    | Var n => Access n Nop
    | Lambda t0 => Grab (comp t0)
    | Apply t0 u => Push (comp u) (comp t0)
  end
.

Definition comp_state (t: lterm) : krivine_env :=
  krivine_state (comp t) KEnv_nil KEnv_nil
.

(** 5. Proof of the compiler *)
(** tau is the reverse translation of the compiler *)
Fixpoint tau_code (c: krivine_code) : option lterm :=
  match c with
    | Nop => None
    | Access n c0 => Some (Var n)
    | Grab c0 => option_map Lambda (tau_code c0)
    | Push c1 c0 =>
      match tau_code c0 with
        | Some t0 => option_map (Apply t0) (tau_code c1)
        | None => None
      end
  end
.

(** 5.2. *)
Theorem compile_term_tau_ident:
  forall t: lterm, tau_code (comp t) = Some t.
Proof.
  induction t; simpl; trivial.
  rewrite IHt; trivial.
  rewrite IHt1; rewrite IHt2; trivial.
Save.

(** Reverse translate a Krivine environment *)
Fixpoint tau_env (e: krivine_env) : list lterm :=
  match e with
    | KEnv_nil => nil
    | KEnv c0 e0 e' =>
      match tau_code c0 with
        | Some t => (subst_list t 0 (tau_env e0)) :: (tau_env e')
        | None => nil
      end
  end
.

(** Reverse translate a Krivine state,
    using a Recursive routine which works with an accumulator
 *)
Fixpoint list_lterm_to_apply (a: option lterm) (l: list lterm) : option lterm :=
  match l, a with
    | nil, _ => a
    | t :: l0, None => list_lterm_to_apply (Some t) l0
    | u :: l0, Some t => list_lterm_to_apply (Some (Apply t u)) l0
  end
.
Definition tau_state (st: krivine_env) : option lterm :=
  list_lterm_to_apply None (tau_env st)
.

(** list_lterm_to_apply often returns Some ... *)
Theorem list_lterm_to_apply_is_some:
  forall (l: list lterm) (t: lterm),
  exists u: lterm, list_lterm_to_apply (Some t) l = Some u.
Proof.
  induction l; intro t; simpl; trivial.
  exists t; trivial.
Save.

Theorem compile_term_tau_state_ident:
  forall t: lterm, tau_state (comp_state t) = Some t.
Proof.
  intro t; unfold comp_state; unfold tau_state; simpl.
  rewrite compile_term_tau_ident; simpl.
  rewrite substitute_list_empty; trivial.
Save.

(** To define correct state, define C[n] predicate ("fr_below" in code) on a code *)
Definition closed_code (n: nat) (c: krivine_code): Prop :=
   exists t: lterm, tau_code c = Some t /\ closed_n n t
.

(** Here are some theorems using closed_code *)
Theorem not_closed_Nop:
  forall n: nat, ~ closed_code n Nop.
Proof.
  intros n H.
  inversion H.
  elim H0; simpl.
  intro H1; inversion H1.
Save.

Theorem closed_Access:
  forall (n m: nat) (c: krivine_code),
  closed_code n (Access m c) -> m < n.
Proof.
  intros n m c H.
  inversion H.
  elim H0; simpl.
  intro H1; inversion H1.
  trivial.
Save.

Theorem closed_Access_iff:
  forall (n m: nat) (c: krivine_code),
  m < n -> closed_code n (Access m c).
Proof.
  intros n m c H.
  unfold closed_code; simpl.
  exists (Var m).
  split; trivial.
Save.

Theorem closed_Grab_S:
  forall (n: nat) (c: krivine_code),
  closed_code n (Grab c) -> closed_code (S n) c.
Proof.
  intros n c.

  (* We need to introduce (tau_code c) as a (option lterm) *)
  cut (exists ot: option lterm, tau_code c = ot).
    Focus 2. exists (tau_code c); trivial.
  intro Hot; destruct Hot as [ot Hot].

  (* Clear any reference to (tau_code c) *)
  unfold closed_code; simpl; rewrite Hot.
  clear Hot c.

  intro H; destruct H as [t H]. destruct H.

  (* Prove that ot is (Some a) *)
  induction ot; inversion H.
  exists a; split; trivial.
  generalize H0.
  rewrite <- H2; trivial.
Save.

(** Intermediate lemma for Push *)
Lemma closed_Push_internal:
  forall (n: nat) (c0 c: krivine_code), closed_code n (Push c0 c) ->
  exists (t t0: lterm),
  tau_code c = Some t /\ tau_code c0 = Some t0 /\ closed_n n (Apply t t0).
Proof.
  intros n c0 c.
  unfold closed_code; simpl.

  (* Introduce (tau_code c) : (option lterm) *)
  cut (exists ot: option lterm, tau_code c = ot).
    Focus 2. exists (tau_code c); trivial.
  intro Hot; destruct Hot as [ot Hot].
  rewrite Hot. clear Hot c.

  (* Introduce (tau_code c0) : (option lterm) *)
  cut (exists ot: option lterm, tau_code c0 = ot).
    Focus 2. exists (tau_code c0); trivial.
  intro Hot; destruct Hot as [ot0 Hot].
  rewrite Hot. clear Hot c0.

  intro Ht; destruct Ht as [t Ht]. destruct Ht as [Ht Ht_closed].
  induction ot; inversion Ht as [Hinv]. clear Hinv.
  induction ot0; inversion Ht as [Hinv].
  exists a; exists a0; split; trivial; split; trivial.
  generalize Ht_closed. rewrite <- Hinv; trivial.
Save.

Theorem closed_Push1:
  forall (n: nat) (c0 c: krivine_code),
  closed_code n (Push c0 c) -> closed_code n c0.
Proof.
  intros n c0 c H.
  unfold closed_code; simpl.
  elim (closed_Push_internal n c0 c H).
  intros x H0.
  destruct H0 as [t0 H0]. destruct H0; destruct H1.
  generalize H2; clear H2; simpl; intro H2.
  destruct H2.
  exists t0; split; trivial.
Save.

Theorem closed_Push2:
  forall (n: nat) (c0 c: krivine_code),
  closed_code n (Push c0 c) -> closed_code n c.
Proof.
  intros n c0 c H.
  unfold closed_code; simpl.
  elim (closed_Push_internal n c0 c H).
  intros x H0.
  destruct H0 as [t0 H0]. destruct H0; destruct H1.
  generalize H2; clear H2; simpl; intro H2.
  destruct H2.
  exists x; split; trivial.
Save.


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

(*************************************************)
(*              Additive Conjunction             *)
(*************************************************)

Record LWithVal{E:LEnv} (A B:LType) := {
  lwithval_fst : ltype A;
  lwithval_snd : ltype B;
  lwithval_weight_eqn : lweight lwithval_fst = lweight lwithval_snd
}.
Arguments LWithVal [E] A%LL B%LL.
Arguments lwithval_fst [E] [A] [B] _.
Arguments lwithval_snd [E] [A] [B] _.
Arguments lwithval_weight_eqn [E] [A] [B] _.

Definition LWith{E:LEnv} (A B:LType) : LType := {|
  ltype := LWithVal A B;
  lweight x := lweight (lwithval_fst x)
|}.
Definition LTop{E:LEnv} : LType := {|
  ltype := LWeight;
  lweight x := x
|}.
Notation "A && B" := (LWith A%LL B%LL) : LL_scope.
Definition LIff{E:LEnv} (A B:LType) : LType :=
  ((A -o B) && (B -o A))%LL.
Notation "A o-o B" := (LIff A%LL B%LL) : LL_scope.

Definition LWithConstructor{E:LEnv} (A B:LType) {W:LWeight} :
  LGoal A W -> LGoal B W -> LGoal (A && B) W.
Proof.
  intros H0 H1.
  refine {|
    lgoal_proof := {|
      lwithval_fst := lgoal_proof H0;
      lwithval_snd := lgoal_proof H1;
      lwithval_weight_eqn :=
        eq_trans (eq_sym (lweight_eqn _)) (lweight_eqn _)
    |} : ltype (A && B);
    lgoal_weight_eqn := lgoal_weight_eqn H0
  |}.
Defined.

Definition LTopConstructor{E:LEnv} {W:LWeight} :
  LGoal LTop W.
Proof.
  refine {| lgoal_proof := W : ltype LTop |}.
Defined.

Definition LWithDestructorL{E:LEnv} {A B C:LType} {W:LWeight}
  (H0 : LGoal (A -o C) W) : LGoal (A && B -o C) W.
Proof.
  refine {|
    lgoal_proof := {|
      lfun_val := fun(x : ltype (A && B)) =>
        lfun_val (lgoal_proof H0) (lwithval_fst x);
      lfun_weight := W
    |} : ltype (A && B -o C)
  |}.
Grab Existential Variables.
  intros x; simpl.
  refine (lweight_eqn _).
Defined.
Definition LWithDestructorR{E:LEnv} {A B C:LType} {W:LWeight}
  (H1 : LGoal (B -o C) W) : LGoal (A && B -o C) W.
Proof.
  refine {|
    lgoal_proof := {|
      lfun_val := fun(x : ltype (A && B)) =>
        lfun_val (lgoal_proof H1) (lwithval_snd x);
      lfun_weight := W
    |} : ltype (A && B -o C)
  |}.
Grab Existential Variables.
  intros x; simpl.
  rewrite lwithval_weight_eqn.
  refine (lweight_eqn _).
Defined.

Definition LWithFst{E:LEnv} {A B:LType} : ltype (A && B -o A).
Proof.
  refine {|
    lfun_val := fun(p:ltype (A && B)) => lwithval_fst p;
    lfun_weight := 0%LWeight
  |}.
  intros x; refine (lweight_eqn _).
Defined.
Definition LWithSnd{E:LEnv} {A B:LType} : ltype (A && B -o B).
Proof.
  refine {|
    lfun_val := fun(p:ltype (A && B)) => lwithval_snd p;
    lfun_weight := 0%LWeight
  |}.
  intros x; rewrite <-lwithval_weight_eqn; refine (lweight_eqn _).
Defined.

Instance lgoal_autoapply_with_fst{E:LEnv} {T:Type} {A B C:LType}
  {n:nat} {l:list (nat * LWeight)} {W:LWeight}
  {f:ltype (A && B)}
  {Impls:list Type}
  {H: LHintedApp n l Impls (LGoal C (W + lweight (LWithFst f))%LWeight)}
  : LHintedApp n l Impls (LGoal C (W + lweight f)%LWeight).
Proof.
  exists.
  destruct H as [H].
  revert H; apply implication_list_map; intros H.
  refine {|
    lgoal_proof := lgoal_proof H
  |}.
Defined.
Instance lgoal_autoapply_with_snd{E:LEnv} {T:Type} {A B C:LType}
  {n:nat} {l:list (nat * LWeight)} {W:LWeight}
  {f:ltype (A && B)}
  {Impls:list Type}
  {H: LHintedApp n l Impls (LGoal C (W + lweight (LWithSnd f))%LWeight)}
  : LHintedApp n l Impls (LGoal C (W + lweight f)%LWeight).
Proof.
  exists.
  destruct H as [H].
  revert H; apply implication_list_map; intros H.
  refine {|
    lgoal_proof := lgoal_proof H
  |}.
Defined.

Local Ltac splitll_base ::=
  apply LWithConstructor ||
  apply LTopConstructor ||
  fail "Constructor not found".
Local Ltac destructll_left_base ::=
  apply LWithDestructorL ||
  fail "Destructor not found".
Local Ltac destructll_right_base ::=
  apply LWithDestructorR ||
  fail "Destructor not found".

Local Open Scope LL_goal_scope.
Example LWithComm{E:LEnv} (A B:LType) :
  (ILL |- A && B -o B && A).
Proof.
  introsll x.
  splitll.
  - destructll x as [_ z].
    applyll z.
  - destructll x as [y _].
    applyll y.
Defined.
Local Close Scope LL_goal_scope.


(** * Groupoid, the precategory of strict groupoid categories *)
Require Import Functor.Core Category.Strict.
Require Import Cat.Core.
Require Import GroupoidCategory.Core.
Require Import Functor.Paths.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope functor_scope.

Section groupoid_cat.
  Context `{Funext}.

  Let P : PreCategory -> Type
    := fun C => IsGroupoid C /\ IsStrictCategory C.
  Let HF : forall C D, P C -> P D -> IsHSet (Functor C D)
    := fun C D HC HD => @trunc_functor _ C D _ (snd HD) _.

  (** There is a full precategory of [cat] which is the strict groupoid precategories *)

  Definition groupoid_cat : PreCategory
    := @sub_pre_cat _ P HF.
End groupoid_cat.


Require Setoid.

Goal forall (P : Prop) (T : Type) (m m' : T) (T0 T1 : Type) (P2 : forall _ :
Prop, Prop)
            (P0 : Set) (x0 : P0) (P1 : forall (_ : P0) (_ : T), Prop)
            (P3 : forall (_ : forall (_ : P0) (_ : T0) (_ : Prop), Prop) (_ :
T) (_ : Prop), Prop)
            (o : forall _ : P0, option T1)
            (_ : P3
                   (fun (k : P0) (_ : T0) (_ : Prop) =>
                      match o k return Prop with
                      | Some _ => True
                      | None => False
                      end) m' P) (_ : P2 (P1 x0 m))
            (_ : forall (f : forall (_ : P0) (_ : T0) (_ : Prop), Prop) (m1 m2
: T)
                        (k : P0) (e : T0) (_ : P2 (P1 k m1)), iff (P3 f m2 P)
(f k e (P3 f m1 P))), False.
Proof.
  intros ???????????? H0 H H1.
  rewrite H1 in H0; eauto with nocore.
  { lazymatch goal with
    | H : match ?X with _ => _ end |- _
      => first [ lazymatch goal with
                 | [ H' : context[X] |- _ ] => idtac H
                 end
               | fail 1 "could not find" X ]
    end.


From Undecidability.FOL Require Import Syntax.Facts Syntax.Asimpl Deduction.FragmentNDFacts Syntax.Theories.
From Undecidability.Synthetic Require Import Definitions DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
From Undecidability Require Import Shared.ListAutomation Shared.Dec.
From Undecidability Require Import Shared.Libs.PSL.Vectors.Vectors Shared.Libs.PSL.Vectors.VectorForall.
Import ListAutomationNotations.

Section GenCons.
  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Context {HdF : eq_dec syms} {HdP : eq_dec preds}.

  Context {ff : falsity_flag}.
  Variable GBot : form.
  Hypothesis GBot_closed : closed GBot.

  Notation "⊥'" := GBot.
  Notation "A ⊢G phi" := (@prv Σ_funcs Σ_preds ff class A phi) (at level 30).
  Notation "T ⊢TG phi" := (@tprv Σ_funcs Σ_preds ff class T phi) (at level 30).

  Definition econsistent T T' := T' ⊢TG ⊥' -> T ⊢TG ⊥'.

  (* **** Union *)

  Section Union.
    Variable f : nat -> theory.
    Hypothesis econsistent_f : forall n, econsistent (f n) (f (S n)).
    Hypothesis f_le : forall m n, m <= n -> f m ⊑ f n.

    Definition union (f : nat -> theory) := fun t => exists n, f n t.

    Lemma union_f phi :
      union f ⊢TG phi -> exists n, f n ⊢TG phi.
    Proof.
      intros (A & HA1 & HA2). enough (exists n, A ⊏ f n) as [n H] by now exists n, A.
      clear HA2; induction A.
      - exists 0; eauto with contains_theory.
      - destruct IHA as [n Hn]; destruct (HA1 a) as [m Hm]; eauto with contains_theory.
        exists (max n m); intros ? []; subst.
        + eapply f_le; [apply PeanoNat.Nat.le_max_r | eauto with contains_theory].
        + eapply f_le; [apply PeanoNat.Nat.le_max_l | eauto with contains_theory].
    Qed.

    Lemma union_sub n :
      f n ⊑ union f.
    Proof.
      intros ? ?; exists n; eauto with contains_theory.
    Qed.

    Lemma union_econsistent :
      econsistent (f 0) (union f).
    Proof.
      intros [n H] % union_f. induction n; unfold econsistent in *; eauto.
    Qed.

    Lemma union_closed :
      (forall n, closed_T (f n)) -> closed_T (union f).
    Proof.
      intros f_closed phi [m H]. now eapply f_closed with (n := m) (phi := phi).
    Qed.
  End Union.

  (* **** Explosion *)

  Section Explosion.
    Variable T : theory.
    Hypothesis Hclosed : closed_T T.

    Variable e : nat -> form.
    Hypothesis He : forall phi, exists n, e n = phi.

    Definition exp_axiom phi := ⊥' → close All phi.

    Lemma exp_axiom_closed phi : closed (exp_axiom phi).
    Proof.
      unfold closed, exp_axiom. econstructor. 1:easy.
      apply close_closed.
    Qed.

    Lemma exp_axiom_lift phi A :
      exp_axiom phi el A -> exp_axiom phi el (map (subst_form ↑) A).
    Proof.
      intros H. apply in_map_iff. exists (exp_axiom phi). split. 2: assumption.
      unshelve erewrite <- subst_id. 1: intros x; exact ($x). eapply bounded_subst.
      1: apply exp_axiom_closed. lia. now cbv.
    Qed.

    Fixpoint exp n :=
      match n with
      | 0 => T
      | S n => exp n ⋄ exp_axiom (e n)
      end.
    Definition Exp := union exp.

    Lemma Exp_sub :
      T ⊑ Exp.
    Proof.
      apply union_sub with (n := 0) (f := exp).
    Qed.

    Lemma Exp_econsistent :
      econsistent T Exp.
    Proof.
      apply union_econsistent.
      - cbn. intros n (B & HB & Hprv) % prv_T_impl. use_theory B.
        eapply IE. 1: eapply Pc. apply Hprv.
      - induction 1; intros ?; firstorder.
    Qed.

    Lemma Exp_closed :
      closed_T Exp.
    Proof.
      apply union_closed. induction n; intuition.
      cbn. apply closed_T_extend. 1:easy. apply exp_axiom_closed.
    Qed.

    Definition exploding T := forall phi, (⊥' → close All phi) ∈ T.

    Lemma Exp_exploding :
      exploding Exp.
    Proof.
      intros phi. destruct (He phi) as [n Hn]. exists (S n). right; now subst.
    Qed.

    Lemma exploding_inherit T1 T2 :
      exploding T1 -> T1 ⊑ T2 -> exploding T2.
    Proof.
      firstorder.
    Qed.

  End Explosion.

  (* **** Proving with explosion axioms *)

  Notation "¬' phi" := (phi → GBot) (at level 20).
  Notation "∃' phi" := (¬' ∀ ¬' phi) (at level 56, right associativity).

  Lemma GExp A phi :
    (exp_axiom phi) el A -> A ⊢G ⊥' -> A ⊢G phi.
  Proof.
    intros Hel Hbot. apply close_extract. exact (IE (Ctx Hel) Hbot).
  Qed.

  Lemma GDN A phi :
    (exp_axiom phi) el A -> A ⊢G ¬' (¬' phi) -> A ⊢G phi.
  Proof.
    intros Hx H.
    eapply IE.
    2: eapply (Pc A phi GBot).
    eapply II.
    eapply IE. 1: eapply Ctx; now left.
    eapply II. apply GExp. 1: now do 2 right.
    eapply IE. 2: eapply Ctx; now left.
    eapply Weak. 1: apply H.
    intros a Ha; now do 2 right.
  Qed.

  Lemma GExE A phi psi :
    exp_axiom psi el A -> A ⊢G (∃' phi) -> (phi :: map (subst_form ↑) A) ⊢G psi[↑] -> A ⊢G psi.
  Proof.
    intros Hx Hex Hinst.
    apply GDN; [easy | apply II].
    eapply IE. 1: eapply Weak; [eapply Hex |eauto].
    eapply AllI. eapply II.
    cbn. rewrite (@subst_closed _ _ _ _ ⊥'). 2: easy.
    eapply IE. 1: apply Ctx; right; now left.
    eapply Weak. 1: apply Hinst.
    intros a [->|H2]; eauto.
  Qed.

  Lemma GExI A t phi :
    A ⊢G phi [t..] -> A ⊢G ∃' phi.
  Proof.
    intros Hc. apply II.
    erewrite <- (@subst_closed _ _ _ _ ⊥' (t..)). 2:easy.
    eapply IE. 2: eapply Weak. 2: apply Hc. 2: intros a Ha; eauto.
    change ((phi[t..] → ⊥'[t..])) with ((phi → ⊥')[t..]).
    eapply AllE. apply Ctx. left.
    now rewrite subst_closed.
  Qed.

  Lemma GXM A phi psi :
    exp_axiom psi el A -> (phi :: A) ⊢G psi -> (¬' phi :: A) ⊢G psi -> A ⊢G psi.
  Proof.
    intros Hx Ht Hf. apply GDN; try easy.
    apply II. eapply IE with (¬' phi); [apply II|].
    - eapply IE. 1: apply Ctx; right; now left. eapply Weak. 1: apply Hf. intros a [->|Ha]; eauto.
    - eapply II. eapply IE. 1: apply Ctx; right; now left. eapply Weak. 1: apply Ht. intros a [->|Ha]; eauto.
  Qed.

  Definition DPexp1 phi := exp_axiom (∃' (phi → (∀ phi)[↑])).
  Definition DPexp2 phi := exp_axiom (phi [($O) .: (S >> (S >> var))]).
  Definition DPexp3 phi := exp_axiom phi.

  Lemma GDP A phi :
    DPexp1 phi el A -> DPexp2 phi el A -> DPexp3 phi el A -> A ⊢G ∃' (phi → (∀ phi)[↑]).
  Proof.
    intros ? H1 H2. do 2 apply exp_axiom_lift in H1. do 1 apply exp_axiom_lift in H2.
    apply (@GXM _ (∃' (¬' phi))); [intuition| |].
    - eapply GExE; [intuition|apply Ctx;now left|]; cbn.
      erewrite !(subst_closed _ GBot_closed).
      apply (@GExI _ ($0)). cbn. apply II. apply AllI. asimpl. apply GExp.
      eapply incl_map. 2: exact H1. intros a Ha; eauto. cbn.
      asimpl. rewrite (subst_closed _ GBot_closed).
      eapply IE; apply Ctx. 2: now left. 1: right; now left.
    - apply (@GExI _ ($0)). cbn. apply II. apply AllI. cbn.
      asimpl. rewrite ! (subst_closed _ GBot_closed).
      eapply GDN. 1: now do 2 right.
      eapply II.
      eapply IE. 1: apply Ctx; right; right; now left.
      apply (@GExI _ ($0)). cbn. rewrite ! (subst_closed _ GBot_closed).
      asimpl. apply Ctx. now left.
  Qed.

  (* **** Henkin *)

  Section Henkin.
    Variable T : theory.
    Hypothesis Hclosed : closed_T T.
    Hypothesis Hexp : exploding T.

    Variable e : nat -> form.
    Hypothesis He : forall phi, exists n, e n = phi.
    Hypothesis Hbounded : forall n, bounded n (e n).

    Definition henkin_axiom phi := (phi → ((∀ phi)[↑])).

    Lemma henkin_axiom_bounded n phi :
      bounded n (∀ phi) -> bounded (S n) (¬' (henkin_axiom phi)).
    Proof.
      intros H%bounded_S_quant.
      unfold henkin_axiom. constructor. 2: eapply bounded_up; [apply GBot_closed|lia].
      econstructor. 2: cbn; econstructor. 1:easy.
      eapply subst_bounded_max. 2: apply H.
      intros i Hi. unfold up, funcomp, scons. cbn.
      destruct i; econstructor; lia.
    Qed.

    Fixpoint henkin n :=
      match n with
      | O => T
      | S n => henkin n ⋄ subst_form (($ n)..) (henkin_axiom (e n))
      end.

    Lemma henkin_bounded n :
      forall phi, phi ∈ (henkin n) -> bounded n phi.
    Proof.
      induction n as [|n IH]; cbn.
      - intros. now apply Hclosed.
      - intros phi [H1|H1]. 1: eapply bounded_up; intuition.
        subst. econstructor.
        + eapply subst_bounded_max. 2: apply Hbounded.
          intros i Hi. destruct i; econstructor; lia.
        + econstructor. rewrite subst_comp. eapply subst_bounded_max. 2:apply Hbounded.
          intros i Hi. destruct i; econstructor; lia.
    Qed.

    Lemma henkin_le m n :
      m <= n -> henkin m ⊑ henkin n.
    Proof.
      induction 1; firstorder.
    Qed.

    Definition Henkin := union henkin.

    Lemma Henkin_consistent :
      econsistent T Henkin.
    Proof.
      refine (union_econsistent _ henkin_le). intros n.
      cbn; intros (A & HA1 & HA2) % prv_T_impl.
      rewrite <- (@subst_id _ _ _ _ ⊥' var) in HA2.
      rewrite (@bounded_subst _ _ _ _ _ _ _ ($n..) GBot_closed) in HA2.
      apply <- (@nameless_equiv_all' _ _ ff class A (¬' (henkin_axiom (e n))) n) in HA2. 5:easy. 4:lia.
      - use_theory (exp_axiom GBot :: DPexp1 (e n) :: DPexp2 (e n) :: DPexp3 (e n) :: A).
        { intros ? [<- | [<- | [ <- | [<- |]]]]. 5: intuition.
          all: apply henkin_le with (m := 0); [lia | apply Hexp]. }
        eapply IE.
        2: apply (@GDP (exp_axiom GBot :: DPexp1 (e n) :: DPexp2 (e n) :: DPexp3 (e n) :: A) (e n)); eauto.
        apply II.
        eapply GExE. 1: eauto. 1: apply Ctx; eauto.
        cbn.
        rewrite ! (subst_closed _ GBot_closed).
        rewrite ! (subst_closed _ (close_closed _ _)).
        eapply IE. 2: eapply Weak; [apply HA2|]. 2: intros a Ha; now do 6 right.
        apply II. eapply IE. 1: apply Ctx; now left. apply Ctx. right. now left.
      - apply henkin_axiom_bounded. constructor. eapply bounded_up; [apply Hbounded | lia].
      - intros ? H' % HA1. eapply henkin_bounded. apply H'.
    Qed.

    Definition is_Henkin T := forall T' phi, T ⊑ T' -> (forall t, T' ⊢TG phi[t..]) -> T' ⊢TG ∀ phi.

    Lemma Henkin_is_Henkin :
      is_Henkin Henkin.
    Proof.
      intros T' phi HT' Hall. destruct (He phi) as [n Hn]. destruct (Hall ($n)) as (A & HA1 & HA2).
      use_theory (subst_form (($n)..) (henkin_axiom phi) :: A).
      - intros ? [<- |]; [| intuition]; subst. apply HT'. exists (S n). now right.
      - eapply IE; [|eapply Weak; [apply HA2|intros a Ha; eauto]]; apply II.
        cbn. asimpl.
        eapply IE. 1: apply Ctx; eauto. apply Ctx; eauto.
    Qed.

    Lemma is_Henkin_inherit T1 T2 :
      is_Henkin T1 -> T1 ⊑ T2 -> is_Henkin T2.
    Proof.
      intros H1 H2 TT phi HTT. apply H1. intros psi Hpsi. apply HTT. apply H2. easy.
    Qed.

    Lemma Henkin_T :
      T ⊑ Henkin.
    Proof.
      apply union_sub with (f := henkin) (n := 0).
    Qed.
  End Henkin.

  (* **** Omega *)

  Section Omega.
    Variable e : nat -> form.
    Hypothesis He : forall phi, exists n, e n = phi.

    Variable T : theory.
    Hypothesis Hexp : exploding T.
    Hypothesis Hhenkin : is_Henkin T.

    Definition maximal T := forall f, econsistent T (T ⋄ f) -> f ∈ T.

    Definition econsistent_join T phi := fun psi => T psi \/ (econsistent T (T ⋄ phi) /\ psi = phi).
    Infix "∘" := econsistent_join (at level 20).

    Lemma econsistent_join_sub T' phi :
      (T' ∘ phi) ⊑ (T' ⋄ phi).
    Proof.
      intros psi [Htt1|[Htt2 ->]].
      - now left.
      - now right.
    Qed.

    Lemma consistent_join_step T' phi psi :
      T' ∘ psi ⊢TG phi -> T' ⊢TG phi \/ econsistent T' (T' ⋄ psi).
    Proof.
      intros (A & HA1 & HA2).
      enough (A ⊏ T' \/ econsistent T' (T' ⋄ psi)) as [] by ((left; exists A; intuition) + now right).
      clear HA2; induction A.
      - firstorder.
      - destruct (HA1 a), IHA; intuition. all: eauto with contains_theory.
    Qed.

    Fixpoint omega n : theory :=
      match n with
      | 0 => T
      | S n => omega n ∘ e n
      end.

    Lemma omega_le n m :
      n <= m -> omega n ⊑ omega m.
    Proof.
      induction 1; firstorder.
    Qed.

    Definition Omega : theory := union omega.

    Lemma econsistent_Omega :
      econsistent T Omega.
    Proof.
      refine (union_econsistent _ omega_le). intros n H. destruct (consistent_join_step H).
      all: firstorder.
    Qed.

    Lemma econsistency_inheritance T1 T2 T1' T2' :
      econsistent T1 T1' -> T1 ⊑ T2 -> T2' ⊑ T1' -> econsistent T2 T2'.
    Proof.
      intros H1 HT HT' (A & AT2' & Hprv).
      assert (T1' ⊢TG ⊥') as HT1'.
      - use_theory A. 1: intros psi Hin; apply HT', AT2', Hin. easy.
      - destruct (H1 HT1') as (B & BT1' & HBprv).
        use_theory B. intros psi Hin; apply HT, BT1', Hin. easy.
    Qed.

    Lemma econsistency_trans T1 T2 T3 :
      econsistent T1 T2 -> econsistent T2 T3 -> econsistent T1 T3.
    Proof.
      intros H1 H2 H. apply H1. apply H2. easy.
    Qed.

    Lemma maximal_Omega :
      maximal Omega.
    Proof.
      intros phi H. destruct (He phi) as [n Hn].
      apply (union_sub (n := S n)); cbn; rewrite -> Hn. right; split; [| reflexivity].
      eapply econsistency_inheritance.
      + exact (econsistency_trans econsistent_Omega H).
      + apply omega_le with (n := 0). lia.
      + firstorder.
    Qed.

    Lemma econsistent_prv T' T'' phi :
      econsistent T' T'' -> T'' ⊢TG phi -> econsistent T' (T'' ⋄ phi).
    Proof.
      intros HT Hphi Hbot. now apply HT, (prv_T_remove Hphi).
    Qed.

    Lemma maximal_prv T' phi :
      maximal T' -> T' ⊢TG phi -> phi ∈ T'.
    Proof.
      intros Hin Hprv. now apply Hin, econsistent_prv.
    Qed.

    Lemma Omega_prv phi :
      Omega ⊢TG phi -> phi ∈ Omega.
    Proof.
      intros Hprv. now apply (maximal_prv maximal_Omega).
    Qed.

    Lemma Omega_T :
      T ⊑ Omega.
    Proof.
      change T with (omega 0). apply (union_sub (n := 0)).
    Qed.

    Lemma Omega_impl phi psi :
      phi → psi ∈ Omega <-> (phi ∈ Omega -> psi ∈ Omega).
    Proof.
      split.
      - intros Himp Hphi. apply Omega_prv.
        use_theory [phi → psi; phi].
        1: intros a [<-|[<-|[]]]; easy.
        eapply IE. 1: apply Ctx; eauto. apply Ctx; eauto.
      - intros H. apply maximal_Omega. intros (A & HA1 & HA2) % prv_T_impl.
        apply (prv_T_remove (phi := psi)).
        + apply elem_prv, H, Omega_prv.
          use_theory (exp_axiom phi :: exp_axiom psi :: A).
          * intros ? [<- | [ <- | H'']]; [apply Omega_T, Hexp | apply Omega_T, Hexp | now apply HA1].
          * eapply GDN; try eauto. apply II.
            eapply IE; [|eapply Weak; [apply HA2|intros a Ha; eauto]]; apply II.
            eapply IE; [eapply Ctx; now left|].
            apply II. apply GExp; eauto. eapply IE; [|apply Ctx; now left]. apply Ctx; eauto.
        + use_theory (psi :: A). 1:intros a [->|Hin]; [right|left]; intuition.
          eapply IE; [|eapply Weak; [apply HA2|intros a Ha; eauto]]; apply II.
          eapply IE; [apply Ctx; eauto|]. apply II. apply Ctx; eauto.
    Qed.

    Lemma Omega_all phi :
      ∀ phi ∈ Omega <-> (forall t, phi[t..] ∈ Omega).
    Proof.
      split; intros Hprv.
      - intros t. apply Omega_prv. use_theory [∀ phi]. 1: intros psi [<-|[]]; eauto.
        apply AllE. now apply Ctx.
      - apply Omega_prv, (Hhenkin Omega_T). eauto using elem_prv.
    Qed.
  End Omega.
End GenCons.

(* **** Conclusion *)

Section Composition.
  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Context {HdF : eq_dec syms} {HdP : eq_dec preds}.

  Structure ConstructionInputs : Type :=
    {
      variant : falsity_flag ;

      NBot : form ;
      NBot_closed : closed NBot ;

      In_T : theory ;
      In_T_closed : closed_T In_T ;

      enum : nat -> form ;
      enum_enum : forall phi, exists n, enum n = phi ;
      enum_bounded : forall n, bounded n (enum n)
    }.

  Structure ConstructionOutputs (In : ConstructionInputs) :=
    {
      Out_T : theory ;
      Out_T_econsistent : @econsistent _ _  (variant In) (NBot In) (@In_T In) Out_T ;
      Out_T_sub : @In_T In ⊑ Out_T ;

      Out_T_prv : forall phi, @tprv _ _ (variant In) class Out_T phi -> phi ∈ Out_T ;
      Out_T_all : forall phi, ∀ phi ∈ Out_T <-> (forall t, phi[t..] ∈ Out_T) ;
      Out_T_impl : forall phi psi, phi → psi ∈ Out_T <-> (phi ∈ Out_T -> psi ∈ Out_T)
    }.

  Lemma construct_construction (In : ConstructionInputs) :
    ConstructionOutputs In.
  Proof.
    destruct In as [ff NBot NBot_closed T T_closed e e_enum e_bounded].
    eexists (Omega NBot e (Henkin (Exp NBot T e) e)); cbn.
    + eapply econsistency_trans. { eapply econsistency_trans. eapply Exp_econsistent.
      eapply Henkin_consistent; intuition. 1: eapply Exp_closed; intuition. eapply Exp_exploding. intros n; easy. } eapply econsistent_Omega.
    + transitivity (Henkin (Exp NBot T e) e). 1: transitivity (Exp NBot T e).
      1: apply Exp_sub. 1: apply Henkin_T. apply Omega_T.
    + eapply Omega_prv. easy.
    + eapply Omega_all; try easy. eapply Henkin_is_Henkin. easy.
    + eapply Omega_impl; try easy. eapply exploding_inherit.
      - eapply Exp_exploding. easy.
      - eapply Henkin_T.
  Qed.
End Composition.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef3.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition smc_data_destroy_spec0 (rd_addr: Z64) (map_addr: Z64) (adt: RData) : option (RData * Z64) :=
    match rd_addr, map_addr with
    | VZ64 _rd_addr, VZ64 _map_addr =>
      rely is_int64 _rd_addr;
      when'' _g_rd_base, _g_rd_ofst, adt == find_lock_granule_spec (VZ64 _rd_addr) (VZ64 2) adt;
      rely is_int _g_rd_ofst;
      when _t'3 == is_null_spec (_g_rd_base, _g_rd_ofst) adt;
      rely is_int _t'3;
      if (_t'3 =? 1) then
        let _ret := 1 in
        Some (adt, (VZ64 _ret))
      else
        rely is_int64 _map_addr;
        when' _ret, adt == data_destroy3_spec (_g_rd_base, _g_rd_ofst) (VZ64 _map_addr) adt;
        rely is_int64 _ret;
        when adt == granule_unlock_spec (_g_rd_base, _g_rd_ofst) adt;
        Some (adt, (VZ64 _ret))
     end
    .

End SpecLow.