(* Distributed under the terms of the MIT license. *)
Require Import ssreflect ssrbool.
Require PeanoNat.
From MetaCoq.Template Require Import config utils Ast AstUtils Induction
     UnivSubst WfAst Reflect Typing.
From Equations Require Import Equations.

Implicit Types (cf : checker_flags).

Existing Class wf.

(** * Well-formedness of terms and types in typing derivations

  The internal representation of terms is not canonical, so we show
  that only well-formed terms and types can appear in typing derivations
  and the global context.
*)

Lemma All_local_env_wf_decl Σ :
  forall (Γ : context),
    All (wf_decl Σ) Γ -> All_local_env (wf_decl_pred Σ) Γ.
Proof.
  intros Γ X.
  induction Γ in X |- *.
  - constructor; eauto.
  - destruct a as [na [body|] ty].
    + econstructor.
      * apply IHΓ. inv X; eauto.
      * red. inv X. split.
        -- apply X0.
        -- constructor.
      * red. inv X. eauto.
    + econstructor.
      * apply IHΓ. inv X; eauto.
      * red. inv X. split.
        -- apply X0.
        -- constructor.
Qed.

Lemma on_global_decl_impl `{checker_flags} Σ P Q kn d :
  (forall Σ Γ t T, on_global_env cumul_gen P Σ.1 -> P Σ Γ t T -> Q Σ Γ t T) ->
  on_global_env cumul_gen P Σ.1 ->
  on_global_decl cumul_gen P Σ kn d -> on_global_decl cumul_gen Q Σ kn d.
Proof. intros; now eapply (on_global_decl_impl cumul_gen P). Qed.

Lemma on_global_env_impl `{checker_flags} Σ P Q :
  (forall Σ Γ t T, on_global_env cumul_gen P Σ.1 -> P Σ Γ t T -> Q Σ Γ t T) ->
  on_global_env cumul_gen P Σ -> on_global_env cumul_gen Q Σ.
Proof. intros; now eapply (on_global_env_impl cumul_gen P). Qed.

Lemma All_local_env_wf_decl_inv Σ (a : context_decl) (Γ : list context_decl)
         (X : All_local_env (wf_decl_pred Σ) (a :: Γ)) :
    on_local_decl (wf_decl_pred Σ) Γ a * All_local_env (wf_decl_pred Σ) Γ.
Proof.
  inv X; intuition; red; simpl; eauto.
Qed.

Lemma unfold_fix_wf:
  forall Σ (mfix : mfixpoint term) (idx : nat) (narg : nat) (fn : term),
    unfold_fix mfix idx = Some (narg, fn) ->
    WfAst.wf Σ (tFix mfix idx) ->
    WfAst.wf Σ fn.
Proof.
  intros Σ mfix idx narg fn Hf Hwf.
  unfold unfold_fix in Hf. inv Hwf.
  destruct nth_error eqn:eqnth; try congruence.
  pose proof (nth_error_all eqnth X) as [ _ wfd].
  injection Hf. intros <- <-.
  apply wf_subst; auto. clear wfd Hf eqnth.
  assert(forall n, WfAst.wf Σ (tFix mfix n)). constructor; auto.
  unfold fix_subst. generalize #|mfix|; intros. induction n; auto.
Qed.

Lemma unfold_cofix_wf Σ:
  forall (mfix : mfixpoint term) (idx : nat) (narg : nat) (fn : term),
    unfold_cofix mfix idx = Some (narg, fn) ->
    WfAst.wf Σ (tCoFix mfix idx) -> WfAst.wf Σ fn.
Proof.
  intros mfix idx narg fn Hf Hwf.
  unfold unfold_cofix in Hf. inv Hwf.
  destruct nth_error eqn:eqnth; try congruence.
  pose proof (nth_error_all eqnth X) as [_ wfd].
  injection Hf. intros <- <-.
  apply wf_subst; auto. clear wfd Hf eqnth.
  assert(forall n, WfAst.wf Σ (tCoFix mfix n)). constructor; auto.
  unfold cofix_subst. generalize #|mfix|; intros. induction n; auto.
Qed.

Lemma red1_isLambda Σ Γ t u :
  red1 Σ Γ t u -> isLambda t -> isLambda u.
Proof.
  induction 1 using red1_ind_all; simpl; try discriminate; auto.
Qed.

Lemma OnOne2_All_All {A} {P Q} {l l' : list A} :
  OnOne2 P l l' ->
  (forall x y, P x y -> Q x -> Q y) ->
  All Q l -> All Q l'.
Proof. intros Hl H. induction Hl; intros H'; inv H'; constructor; eauto. Qed.

Lemma All_mapi {A B} (P : B -> Type) (l : list A) (f : nat -> A -> B) :
  Alli (fun i x => P (f i x)) 0 l -> All P (mapi f l).
Proof.
  unfold mapi. generalize 0.
  induction 1; constructor; auto.
Qed.

Lemma Alli_id {A} (P : nat -> A -> Type) n (l : list A) :
  (forall n x, P n x) -> Alli P n l.
Proof.
  intros H. induction l in n |- *; constructor; auto.
Qed.

Lemma All_Alli {A} {P : A -> Type} {Q : nat -> A -> Type} {l n} :
  All P l ->
  (forall n x, P x -> Q n x) ->
  Alli Q n l.
Proof. intro H. revert n. induction H; constructor; eauto. Qed.

Ltac wf := intuition try (eauto with wf || congruence || solve [constructor]).
#[global]
Hint Unfold wf_decl vass vdef : wf.
#[global]
Hint Extern 10 => progress simpl : wf.
#[global]
Hint Unfold snoc : wf.
#[global]
Hint Extern 3 => apply wf_lift || apply wf_subst || apply wf_subst_instance : wf.
#[global]
Hint Extern 10 => constructor : wf.
#[global]
Hint Resolve All_skipn : wf.

Lemma on_global_decls_extends_not_fresh {cf} {univs retro} k (Σ : global_declarations) k' (Σ' : global_declarations) P :
  on_global_decls cumul_gen P univs retro ((k :: Σ) ++ [k'] ++ Σ') -> k.1 = k'.1 -> False.
Proof.
  intros H eq.
  depelim H. destruct o as [f ? ? ?].
  eapply Forall_app in f as [_ f].
  depelim f. cbn in *. subst. contradiction.
Qed.

Lemma lookup_env_extends {cf : checker_flags} (Σ : global_env) k d (Σ' : global_env) P :
  on_global_env cumul_gen P Σ' ->
  lookup_env Σ k = Some d ->
  extends_decls Σ Σ' -> lookup_env Σ' k = Some d.
Proof.
  destruct Σ as [univs Σ]; cbn in *.
  rewrite /lookup_env /on_global_env /=.
  induction Σ in univs, Σ', k, d |- *; cbn => //.
  destruct (eqb_spec k a.1) as [e|e].
  * move=> wfΣ' [=]. intros <- ext.
    destruct ext as [univeq [Σ'' eq]] => /=. cbn in *.
    subst univs. rewrite eq in wfΣ'.
    destruct Σ' as [univs' Σ']; cbn in *.
    subst Σ'. destruct wfΣ' as [cu wfΣ'].
    induction Σ''.
    + cbn. now rewrite e eq_kername_refl.
    + cbn. destruct (eqb_spec k a0.1) => //. subst.
      { apply on_global_decls_extends_not_fresh in wfΣ'; eauto. }
      subst. apply IHΣ''. now depelim wfΣ'.
  * intros HΣ' Hl [univeq [Σ'' eq]]; cbn in *. subst univs.
    rewrite eq in HΣ'. destruct HΣ'.
    eapply IHΣ; tea. split; eauto. now rewrite eq.
    red. split; eauto. reflexivity.
    exists (Σ'' ++ [a]).
    now rewrite -app_assoc.
Qed.

Lemma wf_extends {cf} {Σ : global_env} T {Σ' : global_env} P :
  on_global_env cumul_gen P Σ' -> WfAst.wf Σ T -> extends_decls Σ Σ' -> WfAst.wf Σ' T.
Proof.
  intros wfΣ'.
  induction 1 using term_wf_forall_list_ind; try solve [econstructor; eauto; solve_all].
  - intros. destruct H. destruct X0.
    eapply lookup_env_extends in H; tea.
    econstructor; repeat split; eauto; solve_all.
Qed.

Lemma wf_decl_extends {cf} {Σ : global_env} T {Σ' : global_env} P :
  on_global_env cumul_gen P Σ' -> wf_decl Σ T -> extends_decls Σ Σ' -> wf_decl Σ' T.
Proof.
  intros wf [] ext. red. destruct decl_body; split; eauto using wf_extends.
Qed.

Arguments lookup_on_global_env {H} {Pcmp P Σ c decl}.

Lemma declared_inductive_wf {cf:checker_flags} {Σ : global_env} ind
         (mdecl : mutual_inductive_body) (idecl : one_inductive_body) :
  on_global_env cumul_gen wf_decl_pred Σ ->
  declared_inductive Σ ind mdecl idecl -> WfAst.wf Σ (ind_type idecl).
Proof.
  intros.
  destruct H as [Hmdecl Hidecl]. red in Hmdecl.
  destruct (lookup_on_global_env X Hmdecl) as [Σ' [wfΣ' [ext prf]]]; eauto.
  apply onInductives in prf.
  eapply nth_error_alli in Hidecl; eauto.
  eapply onArity in Hidecl.
  destruct Hidecl.
  eapply wf_extends in w; tea.
Qed.

Lemma wf_it_mkProd_or_LetIn Σ Γ t
  : WfAst.wf Σ (it_mkProd_or_LetIn Γ t) -> All (wf_decl Σ) Γ * WfAst.wf Σ t.
Proof.
  revert t. induction Γ; [simpl; auto with wf|]. intros t XX.
  destruct a, decl_body; simpl in *.
  apply IHΓ in XX as []. depelim w; simpl in *; split; auto with wf.
  apply IHΓ in XX as []. depelim w. simpl in *.
  split; auto. constructor; auto with wf.
Qed.

Lemma declared_inductive_wf_indices {cf:checker_flags} {Σ : global_env} {ind mdecl idecl} :
  on_global_env cumul_gen wf_decl_pred Σ ->
  declared_inductive Σ ind mdecl idecl -> All (wf_decl Σ) (ind_indices idecl).
Proof.
  intros.
  destruct H as [Hmdecl Hidecl]. red in Hmdecl.
  destruct (lookup_on_global_env X Hmdecl) as [Σ' [wfΣ' [ext prf]]]; eauto.
  apply onInductives in prf.
  eapply nth_error_alli in Hidecl; eauto.
  pose proof (onArity Hidecl).
  rewrite Hidecl.(ind_arity_eq) in X0.
  destruct X0 as [s Hs]; wf.
  eapply wf_it_mkProd_or_LetIn in s as [? H].
  eapply wf_it_mkProd_or_LetIn in H as [].
  solve_all. now eapply wf_decl_extends.
Qed.

Lemma declared_inductive_wf_ctors {cf:checker_flags} {Σ} {ind} {mdecl idecl} :
  on_global_env cumul_gen wf_decl_pred Σ ->
  declared_inductive Σ ind mdecl idecl ->
  All (fun ctor => All (wf_decl Σ) ctor.(cstr_args)) (ind_ctors idecl).
Proof.
  intros.
  destruct H as [Hmdecl Hidecl]. red in Hmdecl.
  destruct (lookup_on_global_env X Hmdecl) as [Σ' [wfΣ' [ext prf]]]; eauto.
  apply onInductives in prf.
  eapply nth_error_alli in Hidecl; eauto.
  pose proof (onConstructors Hidecl). red in X0.
  solve_all. destruct X0.
  clear -X ext on_cargs.
  induction (cstr_args x) as [|[na [b|] ty] args] in on_cargs, y |- * ;
    try destruct on_cargs;
   constructor; unfold wf_decl in *; cbn in *; intuition eauto using wf_extends; simpl in *.
   destruct b0. intuition eauto using wf_extends.
   destruct a. intuition eauto using wf_extends.
   destruct y => //. destruct on_cargs. destruct w; eauto using wf_extends.
   destruct y => //. eapply IHargs; intuition eauto.
Qed.

Lemma All_local_env_wf_decls Σ ctx :
  TemplateEnvTyping.All_local_env (wf_decl_pred Σ) ctx ->
  All (wf_decl Σ) ctx.
Proof.
  induction 1; constructor; auto.
  destruct t0 as [s Hs]. split; simpl; intuition auto.
Qed.

Lemma on_global_inductive_wf_params {cf:checker_flags} {Σ : global_env_ext} {kn mdecl} :
  on_global_decl cumul_gen (fun Σ : global_env_ext => wf_decl_pred Σ) Σ kn (InductiveDecl mdecl) ->
  All (wf_decl Σ) (ind_params mdecl).
Proof.
  intros prf.
  apply onParams in prf. red in prf.
  apply All_local_env_wf_decls in prf.
  solve_all.
Qed.

Lemma destArity_spec ctx T :
  match destArity ctx T with
  | Some (ctx', s) => it_mkProd_or_LetIn ctx T = it_mkProd_or_LetIn ctx' (tSort s)
  | None => True
  end.
Proof.
  induction T in ctx |- *; simpl; try easy.
  - specialize (IHT2 (ctx,, vass na T1)). now destruct destArity.
  - specialize (IHT3 (ctx,, vdef na T1 T2)). now destruct destArity.
Qed.

Lemma destArity_it_mkProd_or_LetIn ctx ctx' t :
  destArity ctx (it_mkProd_or_LetIn ctx' t) =
  destArity (ctx ,,, ctx') t.
Proof.
  induction ctx' in ctx, t |- *; simpl; auto.
  rewrite IHctx'. destruct a as [na [b|] ty]; reflexivity.
Qed.

Lemma it_mkProd_or_LetIn_inj ctx s ctx' s' :
  it_mkProd_or_LetIn ctx (tSort s) = it_mkProd_or_LetIn ctx' (tSort s') ->
  ctx = ctx' /\ s = s'.
Proof.
  move/(f_equal (destArity [])).
  rewrite !destArity_it_mkProd_or_LetIn /=.
  now rewrite !app_context_nil_l => [= -> ->].
Qed.

(*
Lemma case_predicate_contextP ind mdecl idecl params uinst pctx :
  build_case_predicate_context ind mdecl idecl params uinst = Some pctx <~>
  case_predicate_context ind mdecl idecl params uinst pctx.
Proof.
  unfold build_case_predicate_context.
  unfold instantiate_params.
  destruct instantiate_params_subst as [[ictx p]|] eqn:ipars => /= //.
  2:{ split => //. intros H. depelim H.
      eapply instantiate_params_substP in i.
      rewrite ipars in i. discriminate. }
  move: (destArity_spec [] (subst0 ictx p)).
  destruct destArity as [[idctx inds]|] eqn:da => //.
  simpl. intros eqs.
  split.
  eapply instantiate_params_substP in ipars.
  intros [= <-]. econstructor. eauto. eauto.
  intros H. depelim H. subst sty.
  eapply instantiate_params_substP in i.
  rewrite ipars in i. noconf i. rewrite eqs in e.
  eapply it_mkProd_or_LetIn_inj in e as [<- <-].
  reflexivity.
  split => // [] [] s ty ictxt inds.
  move/instantiate_params_substP.
  rewrite ipars /= => [=] <- <- H.
  rewrite H destArity_it_mkProd_or_LetIn in da.
  noconf da.
Qed.
*)

Lemma wf_subst_context Σ s k Γ : All (wf_decl Σ) Γ -> All (WfAst.wf Σ) s -> All (wf_decl Σ) (subst_context s k Γ).
Proof.
  intros wfΓ. induction wfΓ in s |- *.
  - intros. constructor.
  - rewrite subst_context_snoc. constructor; auto.
    destruct p. destruct x as [? [] ?]; constructor; simpl in *; wf.
Qed.

Lemma wf_smash_context Σ Γ Δ : All (wf_decl Σ) Γ -> All (wf_decl Σ) Δ ->
  All (wf_decl Σ) (smash_context Δ Γ).
Proof.
  intros wfΓ; induction wfΓ in Δ |- *; intros wfΔ; simpl; auto.
  destruct x as [? [] ?]; simpl. apply IHwfΓ.
  eapply wf_subst_context; auto. constructor; auto. apply p.
  eapply IHwfΓ. apply All_app_inv; auto.
Qed.

Section WfAst.
  Context {cf:checker_flags}.
  Context {Σ : global_env}.

  Lemma wf_reln n acc Γ : All (WfAst.wf Σ) acc -> All (WfAst.wf Σ) (reln acc n Γ).
  Proof using Type.
    induction Γ in acc, n |- * => wfacc /= //.
    destruct a as [? [|] ?] => //. now eapply IHΓ.
    eapply IHΓ. constructor; auto. constructor.
  Qed.

  #[local]
  Hint Resolve wf_reln : wf.

  (* Lemma wf_instantiate_params_subst_spec params pars s ty s' ty' :
    instantiate_params_subst_spec params pars s ty s' ty' ->
    All (wf_decl Σ) params ->
    WfAst.wf Σ ty ->
    All (WfAst.wf Σ) pars ->
    All (WfAst.wf Σ) s ->
    All (WfAst.wf Σ) s' * WfAst.wf Σ ty'.
  Proof.
    intros ipars. induction ipars; intros wfparams wfty wfpars wfs => //.
    depelim wfparams. depelim wfpars. depelim wfty.
    apply IHipars; auto.
    depelim wfparams. depelim wfty. destruct H; simpl in *.
    apply IHipars; auto with wf.
  Qed. *)

  Lemma wf_map2_set_binder_name l l' :
    All (wf_decl Σ) l' ->
    All (wf_decl Σ) (map2 set_binder_name l l').
  Proof using Type.
    induction 1 in l |- *; destruct l; simpl; constructor.
    apply p. apply IHX.
  Qed.

  Definition lift_context_snoc0 n k Γ d : lift_context n k (d :: Γ) = lift_context n k Γ ,, lift_decl n (#|Γ| + k) d.
  Proof using Type. unfold lift_context. now rewrite fold_context_k_snoc0. Qed.
  Hint Rewrite lift_context_snoc0 : lift.

  Lemma lift_context_snoc n k Γ d : lift_context n k (Γ ,, d) = lift_context n k Γ ,, lift_decl n (#|Γ| + k) d.
  Proof using Type.
    unfold snoc. apply lift_context_snoc0.
  Qed.
  Hint Rewrite lift_context_snoc : lift.

  Lemma wf_lift_context n k Γ : All (wf_decl Σ) Γ -> All (wf_decl Σ) (lift_context n k Γ).
  Proof using Type.
    intros wfΓ. induction wfΓ in n, k |- *.
    - intros. constructor.
    - rewrite lift_context_snoc0. constructor; auto.
      destruct p. destruct x as [? [] ?]; constructor; simpl in *; wf.
  Qed.

  Lemma wf_subst_instance_context u Γ :
    All (wf_decl Σ) Γ ->
    All (wf_decl Σ) (subst_instance u Γ).
  Proof using Type.
    induction 1; constructor; auto.
    destruct x as [na [b|] ty]; simpl in *.
    destruct p. now split; apply wf_subst_instance.
    destruct p. now split; auto; apply wf_subst_instance.
  Qed.

  Lemma wf_extended_subst Γ n :
    All (wf_decl Σ) Γ ->
    All (WfAst.wf Σ) (extended_subst Γ n).
  Proof using Type.
    induction 1 in n |- *.
    - simpl; constructor.
    - destruct x as [na [b|] ty]; simpl; constructor; auto.
      2:constructor.
      eapply wf_subst; auto.
      eapply wf_lift. apply p.
  Qed.

  Lemma wf_case_predicate_context ind mdecl idecl p :
    declared_inductive Σ ind mdecl idecl ->
    All (wf_decl Σ) mdecl.(ind_params) ->
    All (wf_decl Σ) (ind_indices idecl) ->
    All (WfAst.wf Σ) p.(pparams) ->
    All (wf_decl Σ) (case_predicate_context ind mdecl idecl p).
  Proof using Type.
    intros decl wfparams wfindty wfpars.
    unfold case_predicate_context. destruct p.
    apply wf_map2_set_binder_name.
    unfold pre_case_predicate_context_gen. cbn [Ast.pparams Ast.puinst].
    unfold inst_case_context.
    eapply wf_subst_context => //.
    2:now eapply All_rev.
    apply wf_subst_instance_context.
    rewrite /ind_predicate_context.
    constructor.
    simpl; split; auto. simpl. auto. simpl.
    eapply wf_mkApps. now econstructor.
    apply wf_reln. constructor.
    eapply wf_subst_context.
    now apply wf_lift_context.
    now apply wf_extended_subst.
  Qed.

  Lemma Forall_decls_on_global_wf :
    Forall_decls_typing
      (fun (Σ : global_env_ext) (_ : context) (t T : term) =>
      WfAst.wf Σ t * WfAst.wf Σ T) Σ ->
    on_global_env cumul_gen wf_decl_pred Σ.
  Proof using Type.
    apply on_global_env_impl => Σ' Γ t []; simpl; unfold wf_decl_pred;
    intros; auto. destruct X0 as [s []]; intuition auto.
  Qed.

  (* Hint Resolve on_global_wf_Forall_decls : wf. *)
  Lemma wf_inds mind u mdecl :
    All (WfAst.wf Σ) (inds mind u mdecl.(ind_bodies)).
  Proof using Type.
    unfold inds. induction #|ind_bodies mdecl|; constructor; auto.
    now constructor.
  Qed.

  Hint Resolve wf_inds : wf.

  Lemma on_inductive_wf_params {Σ' : global_env_ext} {kn mdecl} :
      forall (oib : on_inductive cumul_gen wf_decl_pred Σ'  kn mdecl),
      All (wf_decl Σ') (ind_params mdecl).
  Proof using Type.
    intros oib. apply onParams in oib.
    red in oib.
    induction (ind_params mdecl) as [|[? [] ?] ?]; simpl in oib; inv oib; constructor;
      try red in X0; try red in X1; try red; simpl; intuition auto.
  Qed.

  Lemma declared_inductive_wf_params {ind mdecl idecl} :
    on_global_env cumul_gen wf_decl_pred Σ ->
    declared_inductive Σ ind mdecl idecl -> All (wf_decl Σ) (ind_params mdecl).
  Proof using Type.
    intros.
    destruct H as [Hmdecl Hidecl]. red in Hmdecl.
    destruct (lookup_on_global_env X Hmdecl) as [Σ' [wfΣ' [ext prf]]]; eauto.
    eapply on_global_inductive_wf_params in prf.
    solve_all. eapply wf_decl_extends; tea.
  Qed.

  Lemma declared_constructor_wf
    (ind : inductive) (i : nat) (u : list Level.t)
          (mdecl : mutual_inductive_body) (idecl : one_inductive_body) (cdecl : constructor_body) :
      on_global_env cumul_gen wf_decl_pred Σ ->
      declared_constructor Σ (ind, i) mdecl idecl cdecl ->
      WfAst.wf Σ (cstr_type cdecl).
  Proof using Type.
    intros X isdecl.
    destruct isdecl as [[Hmdecl Hidecl] Hcdecl]. red in Hmdecl.
    destruct (lookup_on_global_env X Hmdecl) as [Σ' [wfΣ' [ext prf]]]; eauto. red in prf.
    apply onInductives in prf.
    eapply nth_error_alli in Hidecl; eauto. simpl in *.
    pose proof (onConstructors Hidecl) as h. unfold on_constructors in h.
    eapply All2_nth_error_Some in Hcdecl. 2: eassumption.
    destruct Hcdecl as [cs [Hnth [? ? [? ?]]]].
    eapply wf_extends; eauto.
  Qed.

  Lemma wf_case_branch_context_gen {ind mdecl idecl cdecl p br} :
    on_global_env cumul_gen wf_decl_pred Σ ->
    declared_constructor Σ ind mdecl idecl cdecl ->
    All (WfAst.wf Σ) (pparams p) ->
    All (fun ctor => All (wf_decl Σ) (cstr_args ctor)) (ind_ctors idecl) ->
    All (wf_decl Σ) (case_branch_context (fst ind) mdecl cdecl p br).
  Proof using Type.
    intros ong decli wfpars.
    intros Hforall.
    destruct decli as [decli hcstr].
    eapply nth_error_all in Hforall; tea. cbn in Hforall.
    unfold case_branch_context, case_branch_context_gen.
    eapply wf_map2_set_binder_name.
    apply wf_subst_context; auto.
    apply wf_subst_instance_context.
    rewrite /cstr_branch_context.
    unfold expand_lets_ctx, expand_lets_k_ctx.
    eapply wf_subst_context.
    eapply wf_lift_context.
    eapply wf_subst_context => //.
    eapply wf_inds.
    apply wf_extended_subst.
    eapply declared_inductive_wf_params in decli => //.
    now eapply All_rev.
  Qed.

  Lemma wf_case_branches_context ind mdecl idecl p brs :
    on_global_env cumul_gen wf_decl_pred Σ ->
    declared_inductive Σ ind mdecl idecl ->
    All (WfAst.wf Σ) (pparams p) ->
    All (fun ctor => All (wf_decl Σ) (cstr_args ctor)) (ind_ctors idecl) ->
    All (fun ctx => All (wf_decl Σ) ctx) (case_branches_contexts ind mdecl idecl p brs).
  Proof using Type.
    intros ong decli wfpars.
    unfold case_branches_contexts.
    intros Hforall.
    induction Hforall in brs |- *; destruct brs; cbn; constructor; auto.
    unfold case_branch_context_gen.
    eapply wf_map2_set_binder_name.
    apply wf_subst_context; auto.
    apply wf_subst_instance_context.
    2:now eapply All_rev.
    rewrite /cstr_branch_context.
    unfold expand_lets_ctx, expand_lets_k_ctx.
    eapply wf_subst_context.
    eapply wf_lift_context.
    eapply wf_subst_context => //.
    eapply wf_inds.
    apply wf_extended_subst.
    now eapply declared_inductive_wf_params in decli.
  Qed.

End WfAst.

Record wf_inductive_body Σ idecl := {
  wf_ind_type : WfAst.wf Σ (ind_type idecl);
  wf_ind_indices : All (WfAst.wf_decl Σ) (ind_indices idecl);
  wf_ind_ctors : All (fun cdecl => WfAst.wf Σ (cstr_type cdecl)) (ind_ctors idecl);
  wf_ind_ctor_args : All (fun cs => All (wf_decl Σ) (cstr_args cs)) idecl.(ind_ctors);
  wf_ind_ctors_indices : All (fun cdecl => All (WfAst.wf Σ) (cstr_indices cdecl)) (ind_ctors idecl);
  wf_ind_projs : All (fun pdecl => WfAst.wf Σ pdecl.(proj_type)) (ind_projs idecl)
}.

Section WfLookup.
  Context {cf:checker_flags}.
  Context {Σ : global_env_ext}.

  Lemma wf_projs ind npars p : All (WfAst.wf Σ) (projs ind npars p).
  Proof using Type.
    unfold projs. induction p; constructor; wf.
  Qed.

  Lemma on_global_inductive_wf_bodies {kn mdecl} :
    on_global_decl cumul_gen wf_decl_pred Σ kn (InductiveDecl mdecl) ->
    All (wf_inductive_body Σ) mdecl.(ind_bodies).
  Proof using Type.
    cbn. intros oni.
    have wfpars : All (wf_decl Σ) (ind_params mdecl).
    { now eapply on_inductive_wf_params in oni. }
    eapply onInductives in oni.
    solve_all.
    induction oni; constructor; auto.
    clear oni IHoni.
    destruct p.

    have wfargs : All (fun cs => All (wf_decl Σ) (cstr_args cs)) hd.(ind_ctors).
    { unfold on_constructors in onConstructors.
      clear -onConstructors.
      induction onConstructors; constructor; auto.
      destruct r.
      clear -on_cargs.
      revert on_cargs. revert y. generalize (cstr_args x).
      induction c as [|[? [] ?] ?]; simpl;
        destruct y; intuition auto;
        constructor;
        try red; simpl; try red in a0, b0; intuition eauto.
        now red in b. }
    split => //.
    - now destruct onArity.
    - rewrite ind_arity_eq in onArity .
      destruct onArity as [ona _].
      eapply wf_it_mkProd_or_LetIn in ona as [_ ona].
      now eapply wf_it_mkProd_or_LetIn in ona as [].
    - unfold on_constructors in onConstructors.
      clear -onConstructors.
      induction onConstructors; constructor; auto.
      destruct r.
      eapply on_ctype.
    - unfold on_constructors in onConstructors.
      clear -onConstructors.
      induction onConstructors; constructor; auto.
      destruct r.
      rewrite cstr_eq in on_ctype.
      destruct on_ctype as [wf _].
      eapply wf_it_mkProd_or_LetIn in wf as [_ wf].
      eapply wf_it_mkProd_or_LetIn in wf as [_ wf].
      rewrite /cstr_concl in wf.
      eapply wf_mkApps_inv in wf.
      now apply All_app in wf as [].
    - rename onProjections into on_projs.
      destruct (ind_projs hd) eqn:eqprojs. constructor.
      destruct (ind_ctors hd) as [|? [|]] eqn:Heq; try contradiction.
      destruct on_projs. rewrite eqprojs in on_projs.
      solve_all. eapply Alli_All; tea.
      intros. red in H.
      destruct (nth_error (smash_context _ _) _) eqn:Heq'; try contradiction.
      simpl in Heq. inv wfargs. clear X0.
      destruct H as [onna ->].
      eapply wf_subst.
      eapply wf_inds. eapply wf_subst.
      eapply wf_projs.
      eapply wf_lift.
      eapply All_app_inv in wfpars; [|eapply X].
      eapply (wf_smash_context _ _ []) in wfpars.
      2:constructor.
      eapply nth_error_all in Heq'; eauto.
      apply Heq'.
  Qed.

End WfLookup.

Lemma OnOne2All_All2_All2 (A B C : Type) (P : B -> A -> A -> Type) (Q : C -> A -> Type)
	(i : list B) (j : list C) (R : B -> Type) (l l' : list A) :
  OnOne2All P i l l' ->
  All2 Q j l ->
  All R i ->
  (forall x y a b, R x -> P x a b -> Q y a -> Q y b) ->
  All2 Q j l'.
Proof.
  induction 1 in j |- *; intros.
  depelim X. depelim X0. constructor; eauto.
  depelim X0. depelim X1.
  constructor; auto.
Qed.

Section WfRed.
  Context {cf:checker_flags}.
  Context {Σ : global_env}.

  Lemma wf_red1 Γ M N :
    on_global_env cumul_gen wf_decl_pred Σ ->
    All (wf_decl Σ) Γ ->
    WfAst.wf Σ M ->
    red1 Σ Γ M N ->
    WfAst.wf Σ N.
  Proof using Type.
    intros wfΣ wfΓ wfM H.
    induction H using red1_ind_all in wfM, wfΓ |- *.
    all: inv wfM.
    all: try solve[ constructor; intuition auto with wf ].
    all:auto.

    - inv X. inv X0.
      eauto with wf.
    - auto with wf.
    - apply wf_lift.
      unfold option_map in H. destruct nth_error eqn:Heq; try discriminate.
      eapply nth_error_all in wfΓ; eauto. unfold wf_decl in *.
      apply some_inj in H; rewrite H in wfΓ; apply wfΓ.
    - unfold iota_red.
      eapply wf_mkApps_inv in X2.
      apply wf_subst. eapply All_rev. now eapply All_skipn.
      rewrite /expand_lets /expand_lets_k.
      apply wf_subst. apply wf_extended_subst. rewrite /bctx.
      eapply (wf_case_branch_context_gen (ind := (ci_ind ci, c))); tea.
      eapply declared_inductive_wf_ctors; tea. apply H0.
      eapply wf_lift. solve_all.
      now eapply All2_nth_error_Some_r in X3 as [cb [? []]]; tea.
    - eapply unfold_fix_wf in H; eauto. eapply wf_mkApps; auto.
    - econstructor; eauto. apply wf_mkApps_napp in X2 as [Hcof Hargs]; auto.
      eapply unfold_cofix_wf in H; eauto.
      apply wf_mkApps; intuition auto.
    - constructor; auto. apply wf_mkApps_napp in X as [Hcof Hargs]; auto.
      eapply unfold_cofix_wf in H; eauto.
      apply wf_mkApps; intuition auto.
    - apply wf_subst_instance.
      unfold declared_constant in H.
      eapply lookup_on_global_env in H as [Σ' [onΣ' [ext prf]]]; eauto.
      destruct decl; simpl in *.
      subst cst_body0; simpl in *; unfold on_constant_decl in prf; cbn in prf.
      unfold wf_decl_pred in prf. intuition eauto using wf_extends.
    - apply wf_mkApps_inv in X.
      eapply nth_error_all in X; eauto.
    - simpl in *. econstructor; eauto. cbn.
      now rewrite -(OnOne2_length X).
      cbn. clear H1. induction X; constructor; inv X1; intuition auto.
    - econstructor; eauto; simpl in *.
      apply IHred1; eauto.
      apply All_app_inv => //.
      apply wf_case_predicate_context; auto.
      eapply declared_inductive_wf_params in isdecl; eauto.
      eapply declared_inductive_wf_indices; eauto; wf.
    - econstructor; eauto.
    - econstructor; eauto.
      assert (wf := wf_case_branches_context _ _ _ _ brs wfΣ isdecl X1).
      forward wf.
      eapply declared_inductive_wf_ctors; eauto; wf.
      solve_all.
      eapply OnOne2All_All2_All2; tea. cbn. intuition auto.
      now rewrite b0 in a1.
      apply b2 => //.
      apply All_app_inv => //.
    - now eapply wf_mkApps.
    - constructor; auto. induction X; auto; congruence.
      clear H X0 H0. induction X; inv X1; constructor; intuition auto; try congruence.
    - constructor.
      induction X; inv X0; constructor; intuition auto.
    - constructor; auto.
      induction X; inv X0; constructor; intuition auto; congruence.
    - constructor; auto. solve_all.
      pose proof X0 as H'. revert X0.
      apply (OnOne2_All_All X). clear X.
      intros [na bo ty ra] [nb bb tb rb] [[r ih] e] [? ?].
      simpl in *.
      inversion e. subst. clear e.
      intuition eauto.
      eapply ih. 2: assumption.
      solve_all.
      apply All_app_inv. 2: assumption.
      unfold fix_context. apply All_rev. eapply All_mapi.
      eapply All_Alli. 1: exact H'.
      cbn. unfold wf_decl. simpl.
      intros ? [? ? ? ?] ?. simpl in *.
      intuition eauto with wf.
    - constructor; auto.
      induction X; inv X0; constructor; intuition auto; congruence.
    - constructor; auto. solve_all.
      pose proof X0 as H'. revert X0.
      apply (OnOne2_All_All X). clear X.
      intros [na bo ty ra] [nb bb tb rb] [[r ih] e] [? ?].
      simpl in *.
      inversion e. subst. clear e.
      intuition eauto.
      eapply ih. 2: assumption.
      solve_all. apply All_app_inv. 2: assumption.
      unfold fix_context. apply All_rev. eapply All_mapi.
      eapply All_Alli. 1: exact H'.
      cbn. unfold wf_decl. simpl.
      intros ? [? ? ? ?] ?. simpl in *.
      intuition eauto with wf.
  Qed.

  Lemma wf_lift_wf n k t : WfAst.wf Σ (lift n k t) -> WfAst.wf Σ t.
  Proof using Type.
    induction t in n, k |- * using term_forall_list_rect; simpl in *;
      intros Hwf; inv Hwf; try constructor; eauto;
        repeat (unfold snd, on_snd in *; simpl in *; solve_all).

    - destruct t; try reflexivity. discriminate.
    - destruct l; simpl in *; congruence.
    - eapply All2_map_right_inv in X5. econstructor; eauto; solve_all.
      now rewrite map_length in H1.
  Qed.

  Lemma declared_projection_wf (p : projection)
          (mdecl : mutual_inductive_body) (idecl : one_inductive_body) cdecl pdecl :
      declared_projection Σ p mdecl idecl cdecl pdecl ->
      on_global_env cumul_gen wf_decl_pred Σ ->
      WfAst.wf Σ pdecl.(proj_type).
  Proof using Type.
    intros isdecl X.
    destruct isdecl as [[[Hmdecl Hidecl] Hcdecl] Hpdecl].
    destruct (lookup_on_global_env X Hmdecl) as [Σ' [wfΣ' [ext prf]]]; eauto.
    assert (wfpars := on_inductive_wf_params prf).
    eapply on_global_inductive_wf_bodies in prf => //.
    eapply nth_error_all in Hidecl; eauto. intuition auto.
    destruct Hidecl.
    eapply nth_error_all in wf_ind_projs0; eauto. intuition auto.
    eauto using wf_extends.
  Qed.

  Lemma declared_constant_wf cst decl :
    on_global_env cumul_gen wf_decl_pred Σ ->
    declared_constant Σ cst decl ->
    WfAst.wf Σ decl.(cst_type) *
    on_some_or_none (WfAst.wf Σ) decl.(cst_body).
  Proof using Type.
    intros wΣ h.
    unfold declared_constant in h.
    destruct (lookup_on_global_env wΣ h) as [Σ' [wΣ' [ext h']]].
    simpl in h'.
    destruct decl as [ty [bo|]]. all: cbn in *.
    - destruct h'. intuition eauto using wf_extends.
    - destruct h'. intuition eauto using wf_extends.
  Qed.

  Lemma wf_it_mkProd_or_LetIn_inv (Σ' : global_env_ext) Γ (wfΓ : wf_local Σ' Γ)
    : All_local_env_over typing
    (fun (Σ : global_env_ext) (Γ : context) (_ : wf_local Σ Γ)
      (t T : term) (_ : Σ;;; Γ |- t : T) => WfAst.wf Σ t * WfAst.wf Σ T) Σ'
          Γ wfΓ
  -> forall t, WfAst.wf Σ' t -> WfAst.wf Σ' (it_mkProd_or_LetIn Γ t).
  Proof using Type.
    induction 1; simpl.
    - trivial.
    - intros t0 Ht0. apply IHX. constructor. apply Hs. assumption.
    - intros t0 Ht0. apply IHX. constructor. apply Hc. apply Hc. assumption.
  Qed.

  Lemma wf_Lambda_or_LetIn {d t} :
    wf_decl Σ d ->
    WfAst.wf Σ t ->
    WfAst.wf Σ (mkLambda_or_LetIn d t).
  Proof using Type.
    destruct d as [? [|] ?]; simpl; wf;
    unfold wf_decl, mkLambda_or_LetIn in *; simpl in *.
    constructor; intuition auto.
    constructor; intuition auto.
  Qed.

  Lemma wf_it_mkLambda_or_LetIn {Γ t} :
    All (wf_decl Σ) Γ ->
    WfAst.wf Σ t ->
    WfAst.wf Σ (it_mkLambda_or_LetIn Γ t).
  Proof using Type.
    intros wfΓ wft; induction wfΓ in t, wft |- *; simpl.
    - trivial.
    - apply IHwfΓ. now apply wf_Lambda_or_LetIn.
  Qed.

End WfRed.

#[global]
Hint Resolve wf_extends : wf.

Lemma All2i_All2 {A B} {P : nat -> A -> B -> Type} {Q : A -> B -> Type} n l l' :
  All2i P n l l' ->
  (forall i x y, P i x y -> Q x y) ->
  All2 Q l l'.
Proof.
  induction 1; constructor; eauto.
Qed.

Lemma cstr_branch_context_length ind mdecl cdecl :
  #|cstr_branch_context ind mdecl cdecl| = #|cdecl.(cstr_args)|.
Proof. rewrite /cstr_branch_context. now len. Qed.

Global Hint Rewrite cstr_branch_context_length : len.

(* Lemma case_branch_context_gen_length ind mdecl p puinst pctx :
  #|case_branch_context_gen ind mdecl p puinst pctx | = #|pctx|. *)

Section TypingWf.
  Context {cf}.

  Ltac specialize_goal :=
    repeat match goal with
    | H : ?P -> _, H' : ?P |- _ => specialize (H H')
    end.

  Lemma typing_wf_gen :
    env_prop
      (fun Σ Γ t T => WfAst.wf Σ t * WfAst.wf Σ T)
      (fun Σ Γ wfΓ => All (wf_decl Σ) Γ).
  Proof using Type.
    apply typing_ind_env; intros; auto with wf;
      specialize_goal;
      try solve [split; try constructor; intuition auto with wf].

    - eapply All_local_env_wf_decls.
      induction X; constructor; auto; red; intuition auto.
    - split; wf. apply wf_lift.
      apply (nth_error_all H X).
    - split. constructor; auto. wf.
      clear -X1.
      induction X1; constructor; now auto.
      destruct X0 as [_ X0].
      clear X H H0.
      induction X1; auto. apply IHX1.
      apply wf_subst. now destruct p0. destruct p. now inv w.
    - split. wf. apply wf_subst_instance. wf.
      destruct (lookup_on_global_env X H) as [Σ' [wfΣ' [ext prf]]]; eauto.
      red in prf. destruct decl; destruct cst_body0; red in prf; simpl in *; wf.
      destruct prf as [s []]. wf.

    - split. wf. apply wf_subst_instance.
      eapply declared_inductive_wf; eauto.
      now eapply Forall_decls_on_global_wf.

    - split. wf. unfold type_of_constructor.
      apply wf_subst; auto with wf.
      apply wf_inds.
      apply wf_subst_instance.
      eapply declared_constructor_wf; eauto.
      now eapply Forall_decls_on_global_wf.

    - destruct X3 as [wfret wps].
      destruct X6 as [wfc wfapps].
      eapply wf_mkApps_inv in wfapps.
      eapply All_app in wfapps as [wfp wfindices].
      assert (All (wf_decl Σ) predctx).
      { now apply All_app in X4 as [? ?]. }
      split; [econstructor; simpl; eauto; solve_all|].
      eapply All2i_All2; tea; repeat intuition auto.
      apply wf_mkApps. subst ptm. wf. apply wf_it_mkLambda_or_LetIn; auto.
      apply All_app_inv; auto.
    - split. wf. apply wf_subst. solve_all. constructor. wf.
      apply wf_mkApps_inv in b. apply All_rev. solve_all.
      eapply declared_projection_wf in isdecl; eauto.
      now eapply wf_subst_instance.
      now eapply Forall_decls_on_global_wf.

    - subst types.
      clear H.
      split.
      + constructor.
        solve_all; destruct a, b.
        all: intuition.
      + eapply All_nth_error in X0; eauto.
        destruct X0 as [s ?]; intuition.

    - subst types.
      split.
      + constructor.
        solve_all; destruct a, b.
        all: intuition.
      + eapply All_nth_error in X0; eauto. destruct X0 as [s ?]; intuition.
  Qed.

  Lemma typing_all_wf_decl Σ (wfΣ : wf Σ.1) Γ (wfΓ : wf_local Σ Γ) :
    All (wf_decl Σ.1) Γ.
  Proof using Type.
    eapply (env_prop_wf_local typing_wf_gen); eauto.
  Qed.
  Hint Resolve typing_all_wf_decl : wf.

  Lemma typing_wf_sigma Σ (wfΣ : wf Σ) :
    on_global_env cumul_gen wf_decl_pred Σ.
  Proof using Type.
    intros.
    pose proof (env_prop_sigma typing_wf_gen _ wfΣ). red in X.
    do 2 red in wfΣ.
    eapply on_global_env_impl; eauto; simpl; intros.
    destruct T. red. apply X1. red. destruct X1 as [x [a wfs]]. split; auto.
  Qed.

  Lemma typing_wf Σ (wfΣ : wf Σ.1) Γ t T :
    Σ ;;; Γ |- t : T -> WfAst.wf Σ.1 t * WfAst.wf Σ.1 T.
  Proof using Type.
    intros. eapply typing_wf_gen in X; intuition eauto with wf.
  Qed.

  Lemma declared_minductive_wf {Σ : global_env} {mind mdecl} {wfΣ : wf Σ} :
    declared_minductive Σ mind mdecl ->
    All (wf_decl Σ) (ind_params mdecl) *
    All (@wf_inductive_body Σ) (ind_bodies mdecl).
  Proof using Type.
    intros declm.
    pose proof (typing_wf_gen (Env.empty_ext Σ) wfΣ _ localenv_nil _ _ (type_Prop _)) as [X _].
    eapply Forall_decls_on_global_wf in X.
    destruct (lookup_on_global_env X declm) as [? [? [ext ?]]]; eauto.
    split. eapply on_global_inductive_wf_params in o0. solve_all. eauto using wf_decl_extends.
    eapply on_global_inductive_wf_bodies in o0. solve_all.
    destruct X0; split; solve_all; eauto using wf_extends, wf_decl_extends.
  Qed.

  Lemma declared_inductive_wf_case_predicate_context
     {Σ : global_env} {wfΣ : wf Σ} {ind mdecl idecl p} :
    declared_inductive Σ ind mdecl idecl ->
    All (WfAst.wf Σ) p.(pparams) ->
    All (wf_decl Σ) (case_predicate_context ind mdecl idecl p).
  Proof using Type.
    intros decli.
    destruct (declared_minductive_wf (proj1 decli)) as [wfp wfb].
    intros wfpars.
    eapply wf_case_predicate_context => //.
    destruct decli as [declm hi].
    eapply nth_error_all in wfb; tea. apply wfb.
  Qed.

  Lemma declared_constructor_wf_case_branch_context
    {Σ} {wfΣ : wf Σ} {ind mdecl idecl cdecl p br} :
    declared_constructor Σ ind mdecl idecl cdecl ->
    All (WfAst.wf Σ) (pparams p) ->
    All (wf_decl Σ) (case_branch_context (fst ind) mdecl cdecl p br).
  Proof using Type.
    intros.
    eapply wf_case_branch_context_gen; tea => //.
    now apply typing_wf_sigma.
    destruct (declared_minductive_wf (proj1 (proj1 H))).
    destruct H as [[hm hnth] hnth'].
    eapply nth_error_all in a0; tea.
    now eapply wf_ind_ctor_args.
  Qed.

  Lemma mkApp_ex_wf Σ t u : WfAst.wf Σ (mkApp t u) ->
    exists f args, mkApp t u = tApp f args /\ ~~ isApp f.
  Proof using Type.
    induction t; simpl; try solve [eexists _, _; split; reflexivity].
    intros wf.
    eapply wf_inv in wf as [[[appt _] wft] wfargs].
    eapply All_app in wfargs as [wfargs wfu]. depelim wfu.
    forward IHt. eapply wf_mkApp; intuition auto.
    destruct IHt as [f [ar [eqf isap]]].
    eexists _, _; split; auto. rewrite appt //.
  Qed.

  Lemma decompose_app_mkApp f u :
    (decompose_app (mkApp f u)).2 <> [].
  Proof using Type.
    induction f; simpl; auto; try congruence.
    destruct args; simpl; congruence.
  Qed.

  Lemma mkApps_tApp' f u f' u' :
    ~~ isApp f' ->
    mkApp f u = tApp f' u' -> mkApps f [u] = mkApps f' u'.
  Proof using Type.
    intros.
    rewrite -(mkApp_mkApps f u []).
    simpl. rewrite H0.
    rewrite -(mkApps_tApp f') // ?H //.
    destruct u' => //.
    eapply (f_equal decompose_app) in H0.
    simpl in H0. pose proof (decompose_app_mkApp f u).
    rewrite H0 /= in H1. congruence.
  Qed.

  Lemma eq_decompose_app Σ x y :
    WfAst.wf Σ x -> WfAst.wf Σ y ->
    decompose_app x = decompose_app y -> x = y.
  Proof using Type.
    intros wfx; revert y.
    induction wfx using term_wf_forall_list_ind; intros [] wfy;
    eapply wf_inv in wfy; simpl in wfy; simpl;
    intros [= ?]; try intuition congruence.
  Qed.

  Lemma mkApp_ex t u : ∑ f args, mkApp t u = tApp f args.
  Proof using Type.
    induction t; simpl; try solve [eexists _, _; reflexivity].
  Qed.

  Lemma strip_casts_decompose_app Σ t :
    WfAst.wf Σ t ->
    forall f l, decompose_app t = (f, l) ->
    strip_casts t = mkApps (strip_casts f) (map strip_casts l).
  Proof using Type.
    intros wf.
    induction wf using term_wf_forall_list_ind; simpl; intros; auto; noconf H;
    try noconf H0;
      rewrite ?map_map_compose  ?compose_on_snd ?compose_map_def ?map_length;
        f_equal; solve_all; eauto.
    - now noconf H1.
    - now noconf H1.
    - now noconf H2.
  Qed.

  Lemma mkApps_tApp f args :
    ~~ isApp f ->
    ~~ is_empty args ->
    tApp f args = mkApps f args.
  Proof using Type.
    intros.
    destruct args, f; try discriminate; auto.
  Qed.

  Lemma strip_casts_mkApps_napp_wf Σ f u :
    ~~ isApp f -> WfAst.wf Σ f -> All (WfAst.wf Σ) u ->
    strip_casts (mkApps f u) = mkApps (strip_casts f) (map strip_casts u).
  Proof using Type.
    intros nisapp wf wf'.
    destruct u.
    simpl. auto.
    rewrite -(mkApps_tApp f (t :: u)) //.
  Qed.

  Lemma mkApp_mkApps f u : mkApp f u = mkApps f [u].
  Proof using Type. reflexivity. Qed.

  Lemma decompose_app_inv Σ f l hd args :
    WfAst.wf Σ f ->
    decompose_app (mkApps f l) = (hd, args) ->
    ∑ n, ~~ isApp hd /\ l = skipn n args /\ f = mkApps hd (firstn n args).
  Proof using Type.
    destruct (isApp f) eqn:Heq.
    revert l args hd.
    induction f; try discriminate. intros.
    simpl in X.
    move/wf_inv: X => /= [[[isAppf Hargs] wff] wfargs].
    rewrite mkApps_tApp ?isAppf in H => //. destruct args => //.
    rewrite -mkApps_app in H.
    rewrite decompose_app_mkApps ?isAppf in H; auto. noconf H.
    exists #|args|; split; auto. now rewrite isAppf.
    rewrite skipn_all_app.
    rewrite firstn_app. rewrite firstn_all2. lia.
    rewrite Nat.sub_diag firstn_O app_nil_r. split; auto.
    rewrite mkApps_tApp ?isAppf //. now destruct args.

    intros wff fl.
    rewrite decompose_app_mkApps in fl; auto. now apply negbT.
    inversion fl. subst; exists 0.
    split; auto. now eapply negbT.
  Qed.

  Lemma eq_tip_skipn {A} (x : A) n l : [x] = skipn n l ->
    exists l', l = l' ++ [x] /\ n = #|l'|.
  Proof using Type.
    induction l in n |- *. rewrite skipn_nil //.
    destruct n. simpl. destruct l => //.
    intros eq. noconf eq. exists []; split; auto.
    rewrite skipn_S. intros Hx.
    destruct (IHl _ Hx) as [l' [-> ->]].
    exists (a :: l'); split; reflexivity.
  Qed.

  Lemma strip_casts_mkApp_wf Σ f u :
    WfAst.wf Σ f -> WfAst.wf Σ u ->
    strip_casts (mkApp f u) = mkApp (strip_casts f) (strip_casts u).
  Proof using Type.
    intros wf wf'.
    assert (wfa : WfAst.wf Σ (mkApp f u)). now apply wf_mkApp.
    destruct (mkApp_ex_wf Σ f u wfa) as [f' [args [eq isapp]]].
    eapply (f_equal decompose_app) in eq. simpl in eq.
    epose proof (strip_casts_decompose_app Σ _ wfa _ _ eq).
    rewrite H.
    rewrite mkApp_mkApps in eq.
    destruct (decompose_app_inv Σ _ _ _ _ wf eq) as [n [ng [stripeq stripf]]].
    apply eq_tip_skipn in stripeq. destruct stripeq as [l' [eqargs eqn]].
    subst n args. rewrite firstn_app_left // in stripf. subst f.
    eapply wf_mkApps_napp in wf as [wff' wfl] => //.
    rewrite (strip_casts_mkApps_napp_wf Σ) //.
    now rewrite mkApp_mkApps -mkApps_app map_app.
  Qed.

  Lemma strip_casts_mkApps_wf Σ f u :
    WfAst.wf Σ f -> All (WfAst.wf Σ) u ->
    strip_casts (mkApps f u) = mkApps (strip_casts f) (map strip_casts u).
  Proof using Type.
    intros wf wf'. induction wf' in f, wf |- *.
    simpl. auto.
    rewrite -mkApps_mkApp IHwf'.
    apply wf_mkApp; auto with wf.
    rewrite (strip_casts_mkApp_wf Σ) //.
    now rewrite mkApps_mkApp.
  Qed.
End TypingWf.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.
Require Import Coq.Strings.String.

Require Import Blech.Bishop.
Require Import Blech.Type.Some.
Require Import Blech.Functor.
Require Import Blech.Category.
Require Import Blech.Category.Funct.
Require Import Blech.Category.Prod.
Require Import Blech.Category.Bsh.
Require Import Blech.Category.Op.
Require Import Blech.Category.El.
Require Import Blech.Groupoid.
Require Import Blech.Groupoid.Core.

Import BishopNotations.
Import SomeNotations.
Import CategoryNotations.
Import GroupoidNotations.
Import CoreNotations.
Import OpNotations.
Import FunctorNotations.

Open Scope category_scope.
Open Scope bishop_scope.

Import IfNotations.

Definition Decidable (T: Type) := ∀ (x y: T), {x = y} + {x ≠ y}.
Existing Class Decidable.

Definition eq_dec {T: Type} `{D:Decidable T} := D.

Definition ns (A: Type): nat → Type :=
  fix loop n :=
    match n with
    | O => True
    | S n' => prod A (loop n')
    end.

#[universes(cumulative)]
Inductive sort {V} :=
| true | false

| prod (_ _: sort)
| Forall (_: V → sort)
| span {E} (_: E → sort)
.
Arguments sort: clear implicits.

Inductive prop {V}: sort V → Type :=
| prop_true: prop true
| prop_false: prop false
| prop_prod {A B}: prop A → prop B → prop (prod A B)
.

Fixpoint pnf {V} (n: nat) (S: sort V): Type :=
  match n with
  | O => prop S
  | S n' =>
    if S is Forall P
    then
      forall x, pnf n' (P x)
    else
      False
  end.

Definition app {V n} {S: sort V} (p:pnf n S): ns V n → sort V.
Proof.
  generalize dependent p.
  generalize dependent S.
  induction n.
  - cbn in *.
    intros.
    apply S.
  - cbn in *.
    destruct S.
    all: try contradiction.
    intro p.
    intro HT.
    destruct HT as [H T].
    apply (IHn (s H) (p _) T).
Defined.

Fixpoint eqb {V} `{Decidable V} (x y: @sort V _): bool :=
  match (x, y) with
  | (true, true) => Datatypes.true
  | (false, false) => Datatypes.true
  | (prod A B, prod A' B') => eqb A A' && eqb B B'
  | (Forsome F, Forsome F') => λ x, eqb (F x) (F x)
  | _ => Datatypes.false
  end.
Instance sort_Decidable V `(Decidable V): Decidable (@sort V _) :=
  λ x y :=
Proof.
  unfold Decidable in *.
  intros x y.
  induction x, y.
  all: try (left; reflexivity).
  all: try (right; discriminate).

}.

Definition eq {V: Decidable} (x y: V): sort V := if eq_dec x y then true else false.

Definition η {V: Decidable} (x: V): sort V := Forsome (eq x).

Definition foo {V: Decidable}: sort V := Forall (λ p, prod p p).

Definition st (λ x, η x).

  Inductive term {Var Val: sort → Type}: sort → Type :=
| bang: term pt
| true: term bool | false: term bool

| tuple {A B}: term A → term B → term (prod A B)
| fst {A B}: term (prod A B) → term A
| snd {A B}: term (prod A B) → term B

| app {A B}: term (exp A B) → term A → term B

| var {A}: Var A → term A
| lam {A B}: Var A → (Val A → term B) → term (exp A B)
.

Inductive xs: sort → Type :=
| x: xs pt .
Check lam x (λ x', var x).

Inductive form {V}: nat → Type :=
| η (_: V): form 0
| d {p} (_: form p): form (p + 1)
| wedge {p q} (_: form p) (_: form q): form (p + q)
.
Arguments form: clear implicits.
Infix "∧" := wedge.

Record subset A := sup {
  s: Type ;
  π: s → A ;
}.

Arguments sup {A s}.
Arguments s {A}.
Arguments π {A}.

Notation "'lim' x .. y , P" := (sup (λ x, .. (sup (λ y,  P)) .. )) (at level 200, x binder, y binder).

(* FIXME add complicated setoid relations *)
.
Notation "!" := bang.

Notation "·" := point.
Infix "×" := prod (at level 30, right associativity).

Open Scope nat_scope.

Definition bangRule: subset (form term 1) :=
  lim (x: unit), η ! ∧ d (η ·).

Definition tupleRule: form (subset term) 1 :=
  η (lim (x: unit), !) ∧ d (η (lim (x: unit), ·)).

Definition tupleRule := lim '(e0, e1, A, B), tuple e0 e1 ∈ prod A B.

Definition appRule := λ e0 e1, app e0 e1 ∈ (
                                     η (λ Γ, Γ e0) ∧ η (λ Γ, Γ e1)
                                   ).
#[local]
Obligation Tactic := Reflect.category_simpl.

Reserved Notation "f ◃ g" (at level 30, no associativity).
Reserved Notation "f ▹ g" (at level 30, no associativity).
Reserved Notation "f ▵ g" (at level 30, no associativity).
Reserved Notation "i ~ j" (at level 30, no associativity).

#[universes(cumulative)]
Class Cylinder := {
  Obj: Type ;
  Mor: string → Obj → Obj → Bishop ;

  id [s] A: Mor s A A ;
  compose [s] [A B C]: Mor s B C -> Mor s A B -> Mor s A C
  where "f ∘ g" := (compose f g) ;

  compose_assoc [s A B C D] (f: Mor s C D) (g: Mor s B C) (h: Mor s A B):
    (f ∘ (g ∘ h)) == ((f ∘ g) ∘ h );
  compose_id_left [s A B] (f: Mor s A B): (id B ∘ f) == f ;
  compose_id_right [s A B] (f: Mor s A B): (f ∘ id A) == f ;

  compose_compat [s A B C]: Proper (equiv ==> equiv ==> equiv) (@compose s A B C) ;

  left_commute [A B C] [i j]: Mor i B C -> Mor j A B -> Mor j B C
  where "f ◃ g" := (left_commute f g) ;

  right_commute [A B C] [i j]: Mor i B C -> Mor j A B -> Mor i A B
  where "f ▹ g" := (right_commute f g) ;

  left_right_commute [A B C] [i j]: Mor i B C -> Mor j A B -> (Mor j B C * Mor i A B) :=
   λ f g, (f ◃ g, f ▹ g) ;

     (* FIXME figure out the rest of the laws *)
  left_id [s t A B] (f: Mor t A B): (@id s B ◃ f) == @id t B ;
  right_id [s t A B] (f: Mor s A B): (f ▹ @id t A) == @id s A ;

  left_Proper [s t A B C]: Proper (equiv ==> equiv ==> equiv) (@left_commute s t A B C) ;
  right_Proper [s t A B C]: Proper (equiv ==> equiv ==> equiv) (@right_commute s t A B C) ;

  diag (i j: string): Obj
  where "i ~ j" := (diag i j);

  refl {i A}: Mor i A (i ~ i) ;
  sym {i j}: Mor i (i ~ j) (j ~ i) ;
  trans {i j k A}:
    Mor j A (i ~ j) → Mor j A (j ~ k) → Mor j A (i ~ k) ;
}.

Arguments Obj: clear implicits.
Arguments Mor: clear implicits.

Coercion Obj: Cylinder >-> Sortclass.
Coercion Mor: Cylinder >-> Funclass.

Existing Instance compose_compat.
Existing Instance left_Proper.
Existing Instance right_Proper.

Module Import CylinderNotations.
  Bind Scope category_scope with Cylinder.
  Bind Scope object_scope with Obj.
  Bind Scope morphism_scope with Mor.

  Notation "f ∘ g" := (compose f g) : morphism_scope.
  Notation "f ◃ g" := (left_commute f g) : morphism_scope.
  Notation "f ▹ g" := (right_commute f g) : morphism_scope.
  Notation "f ▵ g" := (left_right_commute f g) : morphism_scope.

  Notation "i ~ j" := (diag i j) : object_scope.

  Notation "A → B" := (Mor _ A B) (only parsing) : bishop_scope.
  Notation "A ~> B" := (Mor _ A B) (only parsing) : bishop_scope.
End CylinderNotations.

Check trans (id _) _.

#[universes(cumulative)]
Class Closed := {
  C: Category ;

  pt: C ;
  prod: Functor (C * C) C ;
  exp: Functor (C ᵒᵖ * C) C ;

  (* FIXME laws *)
  bang x: C x pt ;
  fanout {x y z}: C z x → C z y → C z (prod (x, y)) ;
  π1 {x y}: C (prod (x, y)) x ;
  π2 {x y}: C (prod (x, y)) y ;
}.
Coercion C: Closed >-> Category.
Existing Instance C.

Notation "⊤" := pt.
Notation "A × B" := (prod (A, B)) (at level 30, right associativity).
Notation "[ A , B ]" := (exp (A, B)).

Notation "!" := bang.

#[universes(cumulative)]
Class Cylinder := {
  H (s: string): Closed ;

  diag (x y: string): Bsh ;

  alpha {i j}: Functor (H i) (H j) ;

  (* Seems absurdly wrong *)
  assoc i j: H i b c → H j a b ;
}.
Coercion H: Cylinder >-> Funclass.
Existing Instance H.

Infix "∝" := assoc (at level 30, no associativity).
Infix "~" := diag (at level 30, no associativity).

Section open.
  Context `{C:Cylinder}.

  Check ("x" ∝ "y") (⊤, ⊤).
  Check map ("x" ∝ "y") (id _,  _).
  (! ⊤).
#[universes(cumulative)]
Record Var (C: Category) := {
  pt: C ;
  prod: Functor (C * C) C ;
  exp: Functor (C ᵒᵖ * C) C ;

  (* FIXME laws *)

  bang x: C x pt ;
  push {x y}: C pt x → C y (prod (x, y)) ;

  (* Doesn't seem quite right *)
  π1 {x y}: C (prod (x, y)) x ;
  π2 {x y}: C (prod (x, y)) y ;

  pass {x y}: C pt x → C (exp (x, y)) y ;

  curr {x y z}:
    C (prod (x, y)) z → C y (exp (x, z)) ;
  ev {x y}: C (prod (x, exp (x, y))) y ;
}.

Arguments pt {C}.
Arguments prod {C}.
Arguments exp {C}.

Arguments bang {C}.
Arguments push {C} v {x y}.
Arguments π1 {C} v {x y}.
Arguments π2 {C} v {x y}.

Arguments curr {C} v {x y z}.
Arguments ev {C} v {x y}.

#[universes(cumulative)]
Class Variadic := {
  C: Category;
  (* FIXME require finite ? *)
  α: Type;

  var: α → Var C ;

  diag: α → α → C ;

  assoc {i j} {A B C}:
    prod (var i) (A, prod (var j) (B, C)) ~> prod (var j) (prod (var i) (A, B), C) ;

  (* Just for playing with *)
  Z: C ;
  z i: nat → C (pt (var i)) Z ;
}.

Coercion C: Variadic >-> Category.
Existing Instance C.

Coercion var: α >-> Var.

Notation "⊤" := pt.
Notation "A [ i ]× B" := (prod i (A, B)) (at level 30, right associativity).
Notation "A ~[ i ]> B" := (exp i (A, B)) (at level 90, right associativity).
Notation "!" := bang.

Section open.
  Context `{V:Variadic}.

  Definition foo (i j: α) A: A ~> Z [i]× Z [j]× A :=
    push i (z i 4) ∘ push j (z j 5).

  Definition ident (i j: α) A B: A ~> (B ~[i]> B) :=
    curr i (π1 i).

  Check λ (i: α), curr i (π1 i).


(** MetaLan.v *)
From Babel Require Import TerminalDogma
                          ExtraDogma.Extensionality
                          EpsilonDescription
                          SetFacility
                          POrderFacility.

From Babel Require Import Ranko
                            ExtensionalityCharacter
                            ClassicalCharacter.

From Babel Require Import MetaLanguage.Notations
                            MetaType.

From Coq Require Import Relations Classical.

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

(****************************************)
(*                                      *)
(*       AxSem                          *)
(*       (Axiomatic Semantics)          *)
(*                                      *)
(****************************************)

Module AxSem.

Section ClassDef.

Record mixin_of (mT : dMT) (syn : Type) : Type := Mixin {
    ax_sys : mT -> syn -> mT -> Prop;
}.

Notation class_of := mixin_of (only parsing).

Record type (mT : dMT) := Pack {
    syn : Type;
    class : class_of mT syn;
}.

End ClassDef.

Module Exports.

#[reversible]
Coercion syn : type >-> Sortclass.
Coercion class : type >-> mixin_of.

Notation axSem := type.
Notation AxSem s m:= (@Pack _ s m).

Notation " ⊢ { P } s { Q } " := (ax_sys _ P s Q) (only printing)
    : MetaLan_scope.
Notation " ⊢ { P } s { Q } " := (ax_sys (class _) P s Q)
    : MetaLan_scope.
Notation " ⊢ < ax > { P } s { Q } " := (ax_sys (class ax) P s Q)
    : MetaLan_scope.

End Exports.

End AxSem.
Export AxSem.Exports.

(****************************************)
(*                                      *)
(*       DeSem                          *)
(*       (Backward Transformer)         *)
(*                                      *)
(****************************************)
Module DeSem.
Section ClassDef.

Record mixin_of (mT : Type) (syn : Type) : Type := Mixin {
    de_fun : syn -> mT -> mT;
}.

Notation class_of := mixin_of (only parsing).

Record type (mT : Type) : Type := Pack {
    syn : Type;
    class : class_of mT syn;
}.

End ClassDef.

Module Exports.

#[reversible]
Coercion syn : type >-> Sortclass.
Coercion class : type >-> mixin_of.

Notation deSem := type.
Notation DeSem s m := (@Pack _ s m).

Notation " ⟦ s ⟧ < de > " := (de_fun de s) : MetaLan_scope.

End Exports.
End DeSem.

Export DeSem.Exports.

(****************************************)
(*                                      *)
(*       DeSemM                         *)
(*       (Backward Transformer)         *)
(*       (monotonic)                    *)
(****************************************)

Module DeSemM.
Section ClassDef.

Record mixin_of (mT : poset) (syn : Type)
        (b : DeSem.mixin_of mT syn) : Type := Mixin {
    mono_mixin : forall s,
        MonotonicFun.mixin_of (DeSem.de_fun b s);
}.

Record class_of (mT : poset) (syn : Type) := Class {
    base_de : DeSem.mixin_of mT syn;
    mixin : mixin_of base_de;
}.

Record type (mT : poset) : Type := Pack {
    syn : Type;
    class : class_of mT syn;
}.

Local Coercion class : type >-> class_of.

Definition de_monot (mT : poset) (cT : type mT) (s : syn cT)
    : MonotonicFun.mixin_of (DeSem.de_fun (base_de cT) s) :=
        mono_mixin (mixin cT) s.

Definition to_deSem (mT : poset) (cT : type mT) : deSem mT :=
    DeSem (syn cT) (base_de cT).

End ClassDef.

Module Exports.

#[reversible]
Coercion syn : type >-> Sortclass.
Coercion class : type >-> class_of.
Coercion mixin : class_of >-> mixin_of.
Coercion base_de : class_of >-> DeSem.mixin_of.

Coercion to_deSem : type >-> deSem.

Notation deSemM := type.
Notation DeSemM s m := (@Pack _ s (Class m)).

End Exports.

End DeSemM.
Export DeSemM.Exports.

(****************************************)
(*                                      *)
(*       DeSemC                         *)
(*       (Backward Transformer)         *)
(*       (Continuous)                   *)
(****************************************)

Module DeSemC.
Section ClassDef.

Record mixin_of (mT : cpo) (syn : Type)
        (b : DeSemM.class_of mT syn) : Type := Mixin {
    conti_mixin : forall s,
        ContinuousFun.mixin_of (DeSemM.mono_mixin b s);
}.

Record class_of (mT : cpo) (syn : Type) := Class {
    base_deM : DeSemM.class_of mT syn;
    mixin : mixin_of base_deM;
}.

Record type (mT : cpo) : Type := Pack {
    syn : Type;
    class : class_of mT syn;
}.

Local Coercion class : type >-> class_of.

Definition de_conti (mT : cpo) (cT : type mT) (s : syn cT)
    : ContinuousFun.mixin_of (DeSemM.mono_mixin (base_deM cT) s) :=
        conti_mixin (mixin cT) s.

Definition to_deSemM (mT : cpo) (cT : type mT) : deSemM mT :=
    DeSemM (syn cT) (base_deM cT).

End ClassDef.

Module Exports.

#[reversible]
Coercion syn : type >-> Sortclass.
Coercion class : type >-> class_of.
Coercion mixin : class_of >-> mixin_of.
Coercion base_deM : class_of >-> DeSemM.class_of.

Coercion to_deSemM : type >-> deSemM.

Notation deSemC := type.
Notation DeSemC s m := (@Pack _ s (Class m)).

End Exports.

End DeSemC.
Export DeSemC.Exports.

(****************************************)
(*                                      *)
(*       VeriModS                       *)
(*       (Verification Module)          *)
(*                                      *)
(****************************************)

(* only soundness is required *)
Module VeriModS.
Section ClassDef.

Definition axiom (mT : cpoDMT) (syn : Type)
    (ax_m : AxSem.mixin_of mT syn) (de_m : DeSem.mixin_of mT syn)
    (base_de := DeSem syn de_m) (base_ax := AxSem syn ax_m):=

        forall (s : syn) (P Q : [cpo of mT]),
        ⊢ <base_ax> { P } s { Q } -> P ⊑ ⟦ s ⟧ <base_de> Q.

Record mixin_of (mT : cpoDMT) (syn : Type)
    (ax_m : AxSem.mixin_of mT syn) (de_m : DeSem.mixin_of mT syn) : Type
        := Mixin {
    soundness : axiom ax_m de_m;
}.

Record class_of (mT : cpoDMT) (syn : Type) : Type := Class {
    base_ax : AxSem.mixin_of mT syn;
    base_de : DeSem.mixin_of mT syn;
    mixin : mixin_of base_ax base_de;
}.

Record type (mT : cpoDMT) := Pack {
    syn : Type;
    class : class_of mT syn;
}.

Local Coercion syn : type >-> Sortclass.
Local Coercion class : type >-> class_of.

Definition to_axSem (mT : cpoDMT) (cT : type mT) :=
    AxSem (syn cT) (base_ax cT).

Definition to_deSem (mT : cpoDMT) (cT : type mT) :=
    DeSem (syn cT) (base_de cT).

Definition soundness_of (mT : cpoDMT) (cT : type mT) :=
    soundness (mixin cT).

End ClassDef.

Module Exports.

#[reversible]
Coercion syn : type >-> Sortclass.
Coercion class : type >-> class_of.
Coercion mixin : class_of >-> mixin_of.

Coercion to_axSem : type >-> axSem.
Coercion to_deSem : type >-> deSem.

Notation veriModS := type.
Notation VeriModS s m := (@Pack _ s (Class m)).

Arguments soundness_of [_] _.
Notation soundness_of := soundness_of.

End Exports.

End VeriModS.
Export VeriModS.Exports.

(****************************************)
(*                                      *)
(*       VeriModC                       *)
(*       (Verification Module)          *)
(*                                      *)
(****************************************)

(* complete *)
Module VeriModC.
Section ClassDef.

Definition axiom (mT : cpoDMT) (syn : Type)
    (ax_m : AxSem.mixin_of mT syn) (de_m : DeSem.mixin_of mT syn)
    (base_ax := AxSem syn ax_m) (base_de := DeSem syn de_m) :=
        forall (s : syn) (P Q : [cpo of mT]),
        P ⊑ ⟦ s ⟧ <base_de> Q -> ⊢ <base_ax> { P } s { Q }.

Record mixin_of (mT : cpoDMT) (syn : Type)
    (ax_m : AxSem.mixin_of mT syn) (de_m : DeSem.mixin_of mT syn)
        : Type := Mixin {
    completeness : axiom ax_m de_m;
}.

Record class_of (mT : cpoDMT) (syn : Type) : Type := Class {
    base_ax : AxSem.mixin_of mT syn;
    base_de : DeSem.mixin_of mT syn;
    mixin : mixin_of base_ax base_de;
}.

Record type (mT : cpoDMT) := Pack {
    syn : Type;
    class : class_of mT syn;
}.

Local Coercion syn : type >-> Sortclass.
Local Coercion class : type >-> class_of.

Definition to_axSem (mT : cpoDMT) (cT : type mT) :=
    AxSem (syn cT) (base_ax cT).

Definition to_deSem (mT : cpoDMT) (cT : type mT) :=
    DeSem (syn cT) (base_de cT).

Definition completeness_of (mT : cpoDMT) (cT : type mT) :=
    completeness (mixin cT).

End ClassDef.

Module Exports.

#[reversible]
Coercion syn : type >-> Sortclass.
Coercion class : type >-> class_of.
Coercion mixin : class_of >-> mixin_of.

Coercion to_axSem : type >-> axSem.
Coercion to_deSem : type >-> deSem.

Notation veriModC := type.
Notation VeriModC s m := (@Pack _ s (Class m)).

Arguments completeness_of [_] _.
Notation completeness_of := completeness_of.

End Exports.

End VeriModC.
Export VeriModC.Exports.

(****************************************)
(*                                      *)
(*       VeriModSC                      *)
(*       (Verification Module)          *)
(*                                      *)
(****************************************)

(* sound and complete *)
Module VeriModSC.
Section ClassDef.

Definition axiom (mT : cpoDMT) (syn : Type)
    (ax_m : AxSem.mixin_of mT syn) (de_m : DeSem.mixin_of mT syn)
    (base_ax := AxSem syn ax_m) (base_de := DeSem syn de_m) :=
        forall (s : syn) (P Q : [cpo of mT]),
        P ⊑ ⟦ s ⟧ <base_de> Q <-> ⊢ <base_ax> { P } s { Q }.

Lemma to_soundness (mT : cpoDMT) (syn : Type)
    (ax_m : AxSem.mixin_of mT syn) (de_m : DeSem.mixin_of mT syn)
    (base_ax := AxSem syn ax_m) (base_de := DeSem syn de_m):

    axiom base_ax base_de -> VeriModS.axiom base_ax base_de.
Proof. rewrite /axiom /VeriModS.axiom => H s P Q.
    by rewrite H.
Qed.

Lemma to_completeness (mT : cpoDMT) (syn : Type)
    (ax_m : AxSem.mixin_of mT syn) (de_m : DeSem.mixin_of mT syn)
    (base_ax := AxSem syn ax_m) (base_de := DeSem syn de_m):

    axiom base_ax base_de -> VeriModC.axiom base_ax base_de.
Proof. rewrite /axiom /VeriModC.axiom => H s P Q.
    by rewrite H.
Qed.

Record mixin_of (mT : cpoDMT) (syn : Type)
    (ax_m : AxSem.mixin_of mT syn) (de_m : DeSem.mixin_of mT syn)
    (veriS_m : VeriModS.mixin_of ax_m de_m)
    (veriC_m : VeriModC.mixin_of ax_m de_m)
        : Type := Mixin {
}.

Lemma combine (mT : cpoDMT) (syn : Type)
    (ax_m : AxSem.mixin_of mT syn) (de_m : DeSem.mixin_of mT syn)
    (veriS_m : VeriModS.mixin_of ax_m de_m)
    (veriC_m : VeriModC.mixin_of ax_m de_m) :

    axiom ax_m de_m.

Proof. rewrite /axiom => s P Q. split.
    destruct veriC_m as [H_C]. by apply H_C.
    destruct veriS_m as [H_S]. by apply H_S.
Qed.

Record class_of (mT : cpoDMT) (syn : Type) : Type := Class {
    base_ax : AxSem.mixin_of mT syn;
    base_de : DeSem.mixin_of mT syn;
    equiv : axiom base_ax base_de;
}.

Record type (mT : cpoDMT) := Pack {
    syn : Type;
    class : class_of mT syn;
}.

Local Coercion syn : type >-> Sortclass.
Local Coercion class : type >-> class_of.

Definition pack (mT : cpoDMT) (syn : Type)
    (ax_m : AxSem.mixin_of mT syn) (de_m : DeSem.mixin_of mT syn)
    (veriS_m : VeriModS.mixin_of ax_m de_m)
    (veriC_m : VeriModC.mixin_of ax_m de_m)
    (m : mixin_of veriS_m veriC_m) : type mT :=
        Pack (Class (combine veriS_m veriC_m)).

Definition to_veriModS (mT : cpoDMT) (cT : type mT) :=
    VeriModS (syn cT) (VeriModS.Mixin (to_soundness (equiv cT))).

Definition to_veriModC (mT : cpoDMT) (cT : type mT) :=
    VeriModC (syn cT) (VeriModC.Mixin (to_completeness (equiv cT))).

End ClassDef.

Module Exports.

#[reversible]
Coercion syn : type >-> Sortclass.
Coercion class : type >-> class_of.

Coercion to_veriModS : type >-> veriModS.
Coercion to_veriModC : type >-> veriModC.

Notation veriModSC := type.
Notation VeriModSC s m := (@pack _ s _ _ _ _ m).

End Exports.

End VeriModSC.
Export VeriModSC.Exports.

(****************************************)
(*                                      *)
(*       FlowCtrl                       *)
(*       (flow contrl)                  *)
(*                                      *)
(****************************************)

Module FlowCtrl.

Record join (mT : cpo) := {

    join_op : mT -> mT -> mT;
    join_monot1 : forall x, MonotonicFun.mixin_of (join_op x);
    join_monot0 : forall y, MonotonicFun.mixin_of (join_op ^~ y);
    join_conti0 : forall x, ContinuousFun.mixin_of (join_monot0 x);
    join_conti1 : forall x, ContinuousFun.mixin_of (join_monot1 x);
    (*
    join_conti :
        forall (g f : [mT ↦ mT]) (ch : chain mT),
        join_op (⊔ᶜᵖᵒ (f [<] ch)) (⊔ᶜᵖᵒ (g [<] ch)) =
        ⊔ᶜᵖᵒ ((fun x => join_op (f x) (g x)) [<] ch);
    *)
}.

Record split (mT : cpo) (Hj : join mT) := {
    M0 : [ mT ↦ mT ];
    M1 : [ mT ↦ mT ];
    split_join_consistency :
        forall x, join_op Hj (M0 x) (M1 x) = x;
}.

Module Exports.

Notation " x ⊕[ Hj ] y " := (join_op Hj x y) : MetaLan_scope.

End Exports.

End FlowCtrl.

Export FlowCtrl.Exports.

Lemma flow_join_comp_chain_mixin (mT : cpo) (Hj : FlowCtrl.join mT)
        (f g : [mT ↦ mT]) (ch : chain mT):
        Chain.mixin_of ((fun x => (f x) ⊕[Hj] (g x)) [<] ch).
Proof.
    rewrite /Chain.mixin_of.
    porder_level.
    case (Chain.class ch _ a _ a0) => Hle.
    - left.
        transitivity (ContinuousFun.obj f x0 ⊕[ Hj] ContinuousFun.obj g x1).
        apply FlowCtrl.join_monot1. by apply MonotonicFun.class.
        apply FlowCtrl.join_monot0. by apply MonotonicFun.class.
    - right.
        transitivity (ContinuousFun.obj f x0 ⊕[ Hj] ContinuousFun.obj g x1).
        apply FlowCtrl.join_monot0. by apply MonotonicFun.class.
        apply FlowCtrl.join_monot1. by apply MonotonicFun.class.
Qed.

Lemma flow_join_conti (mT : cpo) (Hj : FlowCtrl.join mT) (f g : [mT ↦ mT]) :

    forall (x : chain mT), (⊔ᶜᵖᵒ (f [<] x)) ⊕[Hj] (⊔ᶜᵖᵒ (g [<] x))
        = ⊔ᶜᵖᵒ (Chain ((fun x => (f x) ⊕[Hj] (g x)) [<] x)
             (@flow_join_comp_chain_mixin _ Hj _ _ x)).

Proof. move => ch. (* symmetry. apply cpo_join_eqP. *)

(*
    have Hconti0 := (FlowCtrl.join_conti0 Hj).
    rewrite /ContinuousFun.mixin_of in Hconti0. simpl in Hconti0.
    rewrite {}Hconti0.
    apply cpo_join_eqP.

    have Hconti1 := (FlowCtrl.join_conti1 Hj).
    rewrite /ContinuousFun.mixin_of in Hconti1. simpl in Hconti1.
    rewrite {}Hconti1.

    porder_level.

    apply /lubP. split.

    porder_level.

    transitivity (
        ContinuousFun.obj f x ⊕[ Hj]
        CPO.join_of (CPO.class mT) (monotonic_mapR_chain g ch)
    ).

    + apply FlowCtrl.join_monot0.
        apply CPO.join_prop. porder_level.
    + apply FlowCtrl.join_monot1.
        apply CPO.join_prop. porder_level.

    move => U H.

    have Hconti0 := (FlowCtrl.join_conti0 Hj).
    rewrite /ContinuousFun.mixin_of in Hconti0. simpl in Hconti0.
    rewrite {}Hconti0.
    apply CPO.join_prop.
    porder_level.

    have Hconti1 := (FlowCtrl.join_conti1 Hj).
    rewrite /ContinuousFun.mixin_of in Hconti1. simpl in Hconti1.
    rewrite {}Hconti1.
    apply CPO.join_prop.
    porder_level.
    apply H. porder_level.
*)
Admitted.


From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.

From PromisingLib Require Import Event.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Thread.
Require Import Configuration.
Require Import Behavior.

Set Implicit Arguments.

Section Simulation.
  Definition SIM := forall (c1_src c1_tgt: Configuration.t), Prop.

  Definition _sim (sim: SIM) (c1_src c1_tgt:Configuration.t): Prop :=
    forall (WF_SRC: Configuration.wf c1_src)
      (WF_TGT: Configuration.wf c1_tgt),
      <<TERMINAL:
        forall (TERMINAL_TGT: Threads.is_terminal (Configuration.threads c1_tgt)),
        exists c2_src,
          <<STEPS_SRC: rtc Configuration.tau_step c1_src c2_src>> /\
          <<TERMINAL_SRC: Threads.is_terminal (Configuration.threads c2_src)>>>> /\
      <<STEP:
        forall e tid c2_tgt
          (STEP_TGT: Configuration.step e tid c1_tgt c2_tgt),
        exists c2_src,
          <<STEP_SRC: Configuration.opt_step e tid c1_src c2_src>> /\
          <<SIM: sim c2_src c2_tgt>>>>
  .

  Lemma _sim_mon: monotone2 _sim.
  Proof.
    ii. exploit IN; eauto. i. des.
    econs; eauto. ii.
    exploit STEP; eauto. i. des. eauto.
  Qed.
  Hint Resolve _sim_mon: paco.

  Definition sim: SIM := paco2 _sim bot2.
End Simulation.
#[export] Hint Resolve _sim_mon: paco.

Lemma sim_adequacy
      c_src c_tgt
      (WF_SRC: Configuration.wf c_src)
      (WF_TGT: Configuration.wf c_tgt)
      (SIM: sim c_src c_tgt):
  behaviors Configuration.step c_tgt <2= behaviors Configuration.step c_src.
Proof.
  i. revert c_src WF_SRC WF_TGT SIM.
  induction PR; i.
  - punfold SIM0. exploit SIM0; eauto. i. des.
    hexploit TERMINAL0; eauto. i. des.
    eapply rtc_tau_step_behavior; eauto.
    econs 1. eauto.
  - punfold SIM0. exploit SIM0; eauto. i. des.
    exploit STEP0; eauto. i. des.
    exploit Configuration.step_future; try exact STEP; eauto. i. des.
    exploit Configuration.opt_step_future; try exact STEP_SRC; eauto. i. des.
    inv SIM1; ss. inv STEP_SRC.
    econs 2; eauto.
  - punfold SIM0. exploit SIM0; eauto. i. des.
    exploit STEP0; eauto. i. des.
    exploit Configuration.step_future; try exact STEP; eauto. i. des.
    exploit Configuration.opt_step_future; try exact STEP_SRC; eauto. i. des.
    inv SIM1; ss. inv STEP_SRC.
    econs 3; eauto.
  - punfold SIM0. exploit SIM0; eauto. i. des.
    exploit STEP0; eauto. i. des.
    exploit Configuration.step_future; try exact STEP; eauto. i. des.
    exploit Configuration.opt_step_future; try exact STEP_SRC; eauto. i. des.
    inv SIM1; ss. inv STEP_SRC; eauto.
    econs 4; eauto.
  - econs 5.
Qed.


From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Basic.
From PromisingLib Require Import Language.

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import Progress.

Set Implicit Arguments.

Lemma read_read_tview
      loc ts released ord
      tview0
      (WF0: TView.wf tview0)
      (WF_REL: View.opt_wf released):
  TView.le
    (TView.read_tview (TView.read_tview tview0 loc ts released ord) loc ts released ord)
    (TView.read_tview tview0 loc ts released ord).
Proof.
  econs; aggrtac;
    (try by apply WF0);
    repeat condtac; aggrtac.
Qed.

Lemma write_read_tview
      loc ts ord1 ord2
      tview0 sc0
      (ORD: Ordering.le Ordering.seqcst ord2 -> Ordering.le Ordering.seqcst ord1)
      (WF0: TView.wf tview0):
  TView.le
    (TView.read_tview (TView.write_tview tview0 sc0 loc ts ord1) loc ts
                        (Some ((TView.rel (TView.write_tview tview0 sc0 loc ts ord1)) loc))
                        ord2)
    (TView.write_tview tview0 sc0 loc ts ord1).
Proof.
  econs; repeat (try condtac; aggrtac; try apply WF0).
Qed.

Lemma write_write_tview
      loc ts1 ts2 ord
      (TS: Time.lt ts1 ts2)
      tview0 sc0
      (WF0: TView.wf tview0):
  TView.le
    (TView.write_tview (TView.write_tview tview0 sc0 loc ts1 ord)
                         sc0
                         loc ts2 ord)
    (TView.write_tview tview0 sc0 loc ts2 ord).
Proof.
  econs; repeat (try condtac; aggrtac).
  all: try by apply WF0.
Qed.

Lemma read_fence_read_fence_tview
      ord
      tview0
      (WF0: TView.wf tview0):
  TView.le
    (TView.read_fence_tview (TView.read_fence_tview tview0 ord) ord)
    (TView.read_fence_tview tview0 ord).
Proof.
  econs; aggrtac;
    (try by apply WF0).
  repeat condtac; viewtac.
Qed.

Lemma write_fence_write_fence_sc
      ord
      tview0 sc0
      (WF0: TView.wf tview0):
  TimeMap.le
    (TView.write_fence_sc (TView.write_fence_tview tview0 sc0 ord) (TView.write_fence_sc tview0 sc0 ord) ord)
    (TView.write_fence_sc tview0 sc0 ord).
Proof.
  unfold TView.write_fence_tview, TView.write_fence_sc.
  repeat (condtac; aggrtac).
Qed.

Lemma write_fence_write_fence_tview
      ord
      tview0 sc0
      (WF0: TView.wf tview0):
  TView.le
    (TView.write_fence_tview (TView.write_fence_tview tview0 sc0 ord) (TView.write_fence_sc tview0 sc0 ord) ord)
    (TView.write_fence_tview tview0 sc0 ord).
Proof.
  econs; aggrtac;
    (try by apply WF0);
    (repeat condtac; aggrtac);
    rewrite <- ? View.join_r; viewtac.
  - apply write_fence_write_fence_sc; auto.
  - apply write_fence_write_fence_sc; auto.
  - apply write_fence_write_fence_sc; auto.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** A persistent union-find data structure. *)

Require Import Wf.
Require Recdef.
Require Setoid.
Require Coq.Program.Wf.
Require Import Coqlib.

Open Scope nat_scope.
Set Implicit Arguments.

Module Type MAP.
  Variable elt: Type.
  Variable elt_eq: forall (x y: elt), {x=y} + {x<>y}.
  Variable t: Type -> Type.
  Variable empty: forall (A: Type), t A.
  Variable get: forall (A: Type), elt -> t A -> option A.
  Variable set: forall (A: Type), elt -> A -> t A -> t A.
  Hypothesis gempty: forall (A: Type) (x: elt), get x (empty A) = None.
  Hypothesis gsspec: forall (A: Type) (x y: elt) (v: A) (m: t A),
    get x (set y v m) = if elt_eq x y then Some v else get x m.
End MAP.

Unset Implicit Arguments.

Module Type UNIONFIND.
  Variable elt: Type.
  Variable elt_eq: forall (x y: elt), {x=y} + {x<>y}.
  Variable t: Type.

  Variable repr: t -> elt -> elt.
  Hypothesis repr_canonical: forall uf a, repr uf (repr uf a) = repr uf a.

  Definition sameclass (uf: t) (a b: elt) : Prop := repr uf a = repr uf b.
  Hypothesis sameclass_refl:
    forall uf a, sameclass uf a a.
  Hypothesis sameclass_sym:
    forall uf a b, sameclass uf a b -> sameclass uf b a.
  Hypothesis sameclass_trans:
    forall uf a b c,
    sameclass uf a b -> sameclass uf b c -> sameclass uf a c.
  Hypothesis sameclass_repr:
    forall uf a, sameclass uf a (repr uf a).

  Variable empty: t.
  Hypothesis repr_empty:
    forall a, repr empty a = a.
  Hypothesis sameclass_empty:
    forall a b, sameclass empty a b -> a = b.

  Variable find: t -> elt -> elt * t.
  Hypothesis find_repr:
    forall uf a, fst (find uf a) = repr uf a.
  Hypothesis find_unchanged:
    forall uf a x, repr (snd (find uf a)) x = repr uf x.
  Hypothesis sameclass_find_1:
    forall uf a x y, sameclass (snd (find uf a)) x y <-> sameclass uf x y.
  Hypothesis sameclass_find_2:
    forall uf a, sameclass uf a (fst (find uf a)).
  Hypothesis sameclass_find_3:
    forall uf a, sameclass (snd (find uf a)) a (fst (find uf a)).

  Variable union: t -> elt -> elt -> t.
  Hypothesis repr_union_1:
    forall uf a b x, repr uf x <> repr uf a -> repr (union uf a b) x = repr uf x.
  Hypothesis repr_union_2:
    forall uf a b x, repr uf x = repr uf a -> repr (union uf a b) x = repr uf b.
  Hypothesis repr_union_3:
    forall uf a b, repr (union uf a b) b = repr uf b.
  Hypothesis sameclass_union_1:
    forall uf a b, sameclass (union uf a b) a b.
  Hypothesis sameclass_union_2:
    forall uf a b x y, sameclass uf x y -> sameclass (union uf a b) x y.
  Hypothesis sameclass_union_3:
    forall uf a b x y,
    sameclass (union uf a b) x y ->
       sameclass uf x y
    \/ sameclass uf x a /\ sameclass uf y b
    \/ sameclass uf x b /\ sameclass uf y a.

  Variable merge: t -> elt -> elt -> t.
  Hypothesis repr_merge:
    forall uf a b x, repr (merge uf a b) x = repr (union uf a b) x.
  Hypothesis sameclass_merge:
    forall uf a b x y, sameclass (merge uf a b) x y <-> sameclass (union uf a b) x y.

  Variable path_ord: t -> elt -> elt -> Prop.
  Hypothesis path_ord_wellfounded:
    forall uf, well_founded (path_ord uf).
  Hypothesis path_ord_canonical:
    forall uf x y, repr uf x = x -> ~path_ord uf y x.
  Hypothesis path_ord_merge_1:
    forall uf a b x y,
    path_ord uf x y -> path_ord (merge uf a b) x y.
  Hypothesis path_ord_merge_2:
    forall uf a b,
    repr uf a <> repr uf b -> path_ord (merge uf a b) b (repr uf a).

  Variable pathlen: t -> elt -> nat.
  Hypothesis pathlen_zero:
    forall uf a, repr uf a = a <-> pathlen uf a = O.
  Hypothesis pathlen_merge:
    forall uf a b x,
    pathlen (merge uf a b) x =
      if elt_eq (repr uf a) (repr uf b) then
        pathlen uf x
      else if elt_eq (repr uf x) (repr uf a) then
        pathlen uf x + pathlen uf b + 1
      else
        pathlen uf x.
  Hypothesis pathlen_gt_merge:
    forall uf a b x y,
    repr uf x = repr uf y ->
    pathlen uf x > pathlen uf y ->
    pathlen (merge uf a b) x > pathlen (merge uf a b) y.

End UNIONFIND.

Module UF (M: MAP) : UNIONFIND with Definition elt := M.elt.

Definition elt := M.elt.
Definition elt_eq := M.elt_eq.

(* A set of equivalence classes over elt is represented by a map m.
   M.get a m = Some a' means that a is in the same class as a'.
   M.get a m = None means that a is the canonical representative
     for its equivalence class. *)

(* The ordering over elt induced by such a map.
   repr_order m a a' iff M.get a' m = Some a.
   This ordering must be well founded. *)

Definition order (m: M.t elt) (a a': elt) : Prop :=
  M.get a' m = Some a.

Record unionfind : Type := mk { m: M.t elt; mwf: well_founded (order m) }.

Definition t := unionfind.

(* The canonical representative of an element *)

Section REPR.

Variable uf: t.

Function repr (a: elt) {wf (order uf.(m)) a} : elt :=
  match M.get a uf.(m) with
  | Some a' => repr a'
  | None => a
  end.
Proof.
  intros. auto.
  apply mwf.
Qed.

Lemma repr_none:
  forall a,
  M.get a uf.(m) = None ->
  repr a = a.
Proof.
  intros.
  functional induction (repr a). congruence. auto.
Qed.

Lemma repr_some:
  forall a a',
  M.get a uf.(m) = Some a' ->
  repr a = repr a'.
Proof.
  intros.
  functional induction (repr a). congruence. congruence.
Qed.

Lemma repr_res_none:
  forall (a: elt), M.get (repr a) uf.(m) = None.
Proof.
  intros. functional induction (repr a). auto. auto.
Qed.

Lemma repr_canonical:
  forall (a: elt), repr (repr a) = repr a.
Proof.
  intros. apply repr_none. apply repr_res_none.
Qed.

Lemma repr_some_diff:
  forall a a', M.get a uf.(m) = Some a' -> a <> repr a'.
Proof.
  intros; red; intros.
  assert (repr a = a). rewrite (repr_some a a'); auto.
  assert (M.get a uf.(m) = None). rewrite <- H1. apply repr_res_none.
  congruence.
Qed.

End REPR.

Definition sameclass (uf: t) (a b: elt) : Prop :=
  repr uf a = repr uf b.

Lemma sameclass_refl:
  forall uf a, sameclass uf a a.
Proof.
  intros. red. auto.
Qed.

Lemma sameclass_sym:
  forall uf a b, sameclass uf a b -> sameclass uf b a.
Proof.
  intros. red. symmetry. exact H.
Qed.

Lemma sameclass_trans:
  forall uf a b c,
  sameclass uf a b -> sameclass uf b c -> sameclass uf a c.
Proof.
  intros. red. transitivity (repr uf b). exact H. exact H0.
Qed.

Lemma sameclass_repr:
  forall uf a, sameclass uf a (repr uf a).
Proof.
  intros. red. symmetry. rewrite repr_canonical. auto.
Qed.

(* The empty unionfind structure (each element in its own class) *)

Lemma wf_empty:
  well_founded (order (M.empty elt)).
Proof.
  red. intros. apply Acc_intro. intros b RO. red in RO.
  rewrite M.gempty in RO. discriminate.
Qed.

Definition empty : t := mk (M.empty elt) wf_empty.

Lemma repr_empty:
  forall a, repr empty a = a.
Proof.
  intros. apply repr_none. simpl. apply M.gempty.
Qed.

Lemma sameclass_empty:
  forall a b, sameclass empty a b -> a = b.
Proof.
  intros. red in H. repeat rewrite repr_empty in H. auto.
Qed.

(* Merging two equivalence classes *)

Section IDENTIFY.

Variable uf: t.
Variables a b: elt.
Hypothesis a_canon: M.get a uf.(m) = None.
Hypothesis not_same_class: repr uf b <> a.

Lemma identify_order:
  forall x y,
  order (M.set a b uf.(m)) y x <->
  order uf.(m) y x \/ (x = a /\ y = b).
Proof.
  intros until y. unfold order. rewrite M.gsspec.
  destruct (M.elt_eq x a). intuition congruence. intuition congruence.
Qed.

Remark identify_Acc_b:
  forall x,
  Acc (order uf.(m)) x -> repr uf x <> a -> Acc (order (M.set a b uf.(m))) x.
Proof.
  induction 1; intros. constructor; intros.
  rewrite identify_order in H2. destruct H2 as [A | [A B]].
  apply H0; auto. rewrite <- (repr_some uf _ _ A). auto.
  subst. elim H1. apply repr_none. auto.
Qed.

Remark identify_Acc:
  forall x,
  Acc (order uf.(m)) x -> Acc (order (M.set a b uf.(m))) x.
Proof.
  induction 1. constructor; intros.
  rewrite identify_order in H1. destruct H1 as [A | [A B]].
  auto.
  subst. apply identify_Acc_b; auto. apply uf.(mwf).
Qed.

Lemma identify_wf:
  well_founded (order (M.set a b uf.(m))).
Proof.
  red; intros. apply identify_Acc. apply uf.(mwf).
Qed.

Definition identify := mk (M.set a b uf.(m)) identify_wf.

Lemma repr_identify_1:
  forall x, repr uf x <> a -> repr identify x = repr uf x.
Proof.
  intros. functional induction (repr uf x).

  rewrite <- IHe; auto. apply repr_some. simpl. rewrite M.gsspec.
  destruct (M.elt_eq a0 a). congruence. auto.

  apply repr_none. simpl. rewrite M.gsspec. rewrite dec_eq_false; auto.
Qed.

Lemma repr_identify_2:
  forall x, repr uf x = a -> repr identify x = repr uf b.
Proof.
  intros. functional induction (repr uf x).

  rewrite <- IHe; auto. apply repr_some. simpl. rewrite M.gsspec.
  rewrite dec_eq_false; auto. congruence.

  transitivity (repr identify b). apply repr_some. simpl.
  rewrite M.gsspec. apply dec_eq_true.
  apply repr_identify_1. auto.
Qed.

End IDENTIFY.

(* Union *)

Remark union_not_same_class:
  forall uf a b, repr uf a <> repr uf b -> repr uf (repr uf b) <> repr uf a.
Proof.
  intros. rewrite repr_canonical. auto.
Qed.

Definition union (uf: t) (a b: elt) : t :=
  let a' := repr uf a in
  let b' := repr uf b in
  match M.elt_eq a' b' with
  | left EQ => uf
  | right NEQ => identify uf a' b' (repr_res_none uf a) (union_not_same_class uf a b NEQ)
  end.

Lemma repr_union_1:
  forall uf a b x, repr uf x <> repr uf a -> repr (union uf a b) x = repr uf x.
Proof.
  intros. unfold union. destruct (M.elt_eq (repr uf a) (repr uf b)).
  auto.
  apply repr_identify_1. auto.
Qed.

Lemma repr_union_2:
  forall uf a b x, repr uf x = repr uf a -> repr (union uf a b) x = repr uf b.
Proof.
  intros. unfold union. destruct (M.elt_eq (repr uf a) (repr uf b)).
  congruence.
  rewrite <- (repr_canonical uf b). apply repr_identify_2. auto.
Qed.

Lemma repr_union_3:
  forall uf a b, repr (union uf a b) b = repr uf b.
Proof.
  intros. unfold union. destruct (M.elt_eq (repr uf a) (repr uf b)).
  auto. apply repr_identify_1. auto.
Qed.

Lemma sameclass_union_1:
  forall uf a b, sameclass (union uf a b) a b.
Proof.
  intros; red. rewrite repr_union_2; auto. rewrite repr_union_3. auto.
Qed.

Lemma sameclass_union_2:
  forall uf a b x y, sameclass uf x y -> sameclass (union uf a b) x y.
Proof.
  unfold sameclass; intros.
  destruct (M.elt_eq (repr uf x) (repr uf a));
  destruct (M.elt_eq (repr uf y) (repr uf a)).
  repeat rewrite repr_union_2; auto.
  congruence. congruence.
  repeat rewrite repr_union_1; auto.
Qed.

Lemma sameclass_union_3:
  forall uf a b x y,
  sameclass (union uf a b) x y ->
     sameclass uf x y
  \/ sameclass uf x a /\ sameclass uf y b
  \/ sameclass uf x b /\ sameclass uf y a.
Proof.
  intros until y. unfold sameclass.
  destruct (M.elt_eq (repr uf x) (repr uf a));
  destruct (M.elt_eq (repr uf y) (repr uf a)).
  intro. left. congruence.
  rewrite repr_union_2; auto. rewrite repr_union_1; auto.
  rewrite repr_union_1; auto. rewrite repr_union_2; auto.
  repeat rewrite repr_union_1; auto.
Qed.

(* Merge *)

Definition merge (uf: t) (a b: elt) : t :=
  let a' := repr uf a in
  let b' := repr uf b in
  match M.elt_eq a' b' with
  | left EQ => uf
  | right NEQ => identify uf a' b (repr_res_none uf a) (sym_not_equal NEQ)
  end.

Lemma repr_merge:
  forall uf a b x, repr (merge uf a b) x = repr (union uf a b) x.
Proof.
  intros. unfold merge, union. destruct (M.elt_eq (repr uf a) (repr uf b)).
  auto.
  destruct (M.elt_eq (repr uf x) (repr uf a)).
  repeat rewrite repr_identify_2; auto. rewrite repr_canonical; auto.
  repeat rewrite repr_identify_1; auto.
Qed.

Lemma sameclass_merge:
  forall uf a b x y, sameclass (merge uf a b) x y <-> sameclass (union uf a b) x y.
Proof.
  unfold sameclass; intros. repeat rewrite repr_merge. tauto.
Qed.

(* Path order and merge *)

Definition path_ord (uf: t) : elt -> elt -> Prop := order uf.(m).

Lemma path_ord_wellfounded:
  forall uf, well_founded (path_ord uf).
Proof.
  intros. apply mwf.
Qed.

Lemma path_ord_canonical:
  forall uf x y, repr uf x = x -> ~path_ord uf y x.
Proof.
  intros; red; intros. hnf in H0.
  assert (M.get x (m uf) = None). rewrite <- H. apply repr_res_none.
  congruence.
Qed.

Lemma path_ord_merge_1:
  forall uf a b x y,
  path_ord uf x y -> path_ord (merge uf a b) x y.
Proof.
  intros. unfold merge.
  destruct (M.elt_eq (repr uf a) (repr uf b)).
  auto.
  red. simpl. red. rewrite M.gsspec. rewrite dec_eq_false. apply H.
  red; intros. hnf in H. generalize (repr_res_none uf a). congruence.
Qed.

Lemma path_ord_merge_2:
  forall uf a b,
  repr uf a <> repr uf b -> path_ord (merge uf a b) b (repr uf a).
Proof.
  intros. unfold merge.
  destruct (M.elt_eq (repr uf a) (repr uf b)).
  congruence.
  red. simpl. red. rewrite M.gsspec. rewrite dec_eq_true; auto.
Qed.

(* Path length and merge *)

Section PATHLEN.

Variable uf: t.

Function pathlen (a: elt) {wf (order uf.(m)) a} : nat :=
  match M.get a uf.(m) with
  | Some a' => S (pathlen a')
  | None => O
  end.
Proof.
  intros. auto.
  apply mwf.
Qed.

Lemma pathlen_none:
  forall a,
  M.get a uf.(m) = None ->
  pathlen a = 0.
Proof.
  intros.
  functional induction (pathlen a). congruence. auto.
Qed.

Lemma pathlen_some:
  forall a a',
  M.get a uf.(m) = Some a' ->
  pathlen a = S (pathlen a').
Proof.
  intros.
  functional induction (pathlen a). congruence. congruence.
Qed.

Lemma pathlen_zero:
  forall a, repr uf a = a <-> pathlen a = O.
Proof.
  intros; split; intros.
  apply pathlen_none. rewrite <- H. apply repr_res_none.
  functional induction (pathlen a).
  congruence.
  apply repr_none. auto.
Qed.

End PATHLEN.

(* Path length and merge *)

Lemma pathlen_merge:
  forall uf a b x,
  pathlen (merge uf a b) x =
    if M.elt_eq (repr uf a) (repr uf b) then
      pathlen uf x
    else if M.elt_eq (repr uf x) (repr uf a) then
      pathlen uf x + pathlen uf b + 1
    else
      pathlen uf x.
Proof.
  intros. unfold merge.
  destruct (M.elt_eq (repr uf a) (repr uf b)).
  auto.
  functional induction (pathlen (identify uf (repr uf a) b (repr_res_none uf a) (sym_not_equal n)) x).
  simpl in e. rewrite M.gsspec in e.
  destruct (M.elt_eq a0 (repr uf a)).
  inversion e; subst a'; clear e.
  replace (repr uf a0) with (repr uf a). rewrite dec_eq_true.
  rewrite IHn0. rewrite dec_eq_false; auto.
  rewrite (pathlen_none uf a0). omega. subst a0. apply repr_res_none.
  subst a0. rewrite repr_canonical; auto.
  rewrite (pathlen_some uf a0 a'); auto.
  rewrite IHn0.
  replace (repr uf a0) with (repr uf a').
  destruct (M.elt_eq (repr uf a') (repr uf a)); omega.
  symmetry. apply repr_some; auto.

  simpl in e. rewrite M.gsspec in e. destruct (M.elt_eq a0 (repr uf a)).
  congruence. rewrite (repr_none uf a0); auto.
  rewrite dec_eq_false; auto. symmetry. apply pathlen_none; auto.
Qed.

Lemma pathlen_gt_merge:
  forall uf a b x y,
  repr uf x = repr uf y ->
  pathlen uf x > pathlen uf y ->
  pathlen (merge uf a b) x > pathlen (merge uf a b) y.
Proof.
  intros. repeat rewrite pathlen_merge.
  destruct (M.elt_eq (repr uf a) (repr uf b)). auto.
  rewrite H. destruct (M.elt_eq (repr uf y) (repr uf a)).
  omega. auto.
Qed.

(* Path compression *)

Section COMPRESS.

Variable uf: t.
Variable a b: elt.
Hypothesis a_diff_b: a <> b.
Hypothesis a_repr_b: repr uf a = b.

Lemma compress_order:
  forall x y,
  order (M.set a b uf.(m)) y x ->
  order uf.(m) y x \/ (x = a /\ y = b).
Proof.
  intros until y. unfold order. rewrite M.gsspec.
  destruct (M.elt_eq x a).
  intuition congruence.
  auto.
Qed.

Remark compress_Acc:
  forall x,
  Acc (order uf.(m)) x -> Acc (order (M.set a b uf.(m))) x.
Proof.
  induction 1. constructor; intros.
  destruct (compress_order _ _ H1) as [A | [A B]].
  auto.
  subst x y. constructor; intros.
  destruct (compress_order _ _ H2) as [A | [A B]].
  red in A. generalize (repr_res_none uf a). congruence.
  congruence.
Qed.

Lemma compress_wf:
  well_founded (order (M.set a b uf.(m))).
Proof.
  red; intros. apply compress_Acc. apply uf.(mwf).
Qed.

Definition compress := mk (M.set a b uf.(m)) compress_wf.

Lemma repr_compress:
  forall x, repr compress x = repr uf x.
Proof.
  intros. functional induction (repr compress x).
  simpl in e. rewrite M.gsspec in e. destruct (M.elt_eq a0 a).
  subst a0. injection e; intros. subst a'. rewrite IHe. rewrite <- a_repr_b.
  apply repr_canonical.
  rewrite IHe. symmetry. apply repr_some; auto.
  simpl in e. rewrite M.gsspec in e. destruct (M.elt_eq a0 a).
  congruence. symmetry. apply repr_none. auto.
Qed.

End COMPRESS.

(* Find with path compression *)

Section FIND.

Variable uf: t.

Program Fixpoint find_x (a: elt) {wf (order uf.(m)) a} :
    { r: elt * t | fst r = repr uf a /\ forall x, repr (snd r) x = repr uf x } :=
  match M.get a uf.(m) with
  | Some a' =>
      match find_x a' with
      | pair b uf' => (b, compress uf' a b _ _)
      end
  | None => (a, uf)
  end.
Next Obligation.
  red. auto.
Qed.
Next Obligation.
  (* a <> b*)
  destruct (find_x a')
  as [[b' uf''] [A B]]. simpl in *. inv Heq_anonymous0.
  apply repr_some_diff. auto.
Qed.
Next Obligation.
  destruct (find_x a') as [[b' uf''] [A B]]. simpl in *. inv Heq_anonymous0.
  rewrite B. apply repr_some. auto.
Qed.
Next Obligation.
  split.
  destruct (find_x a')
  as [[b' uf''] [A B]]. simpl in *. inv Heq_anonymous0.
  symmetry. apply repr_some. auto.
  intros. rewrite repr_compress.
  destruct (find_x a')
  as [[b' uf''] [A B]]. simpl in *. inv Heq_anonymous0. auto.
Qed.
Next Obligation.
  split; auto. symmetry. apply repr_none. auto.
Qed.
Next Obligation.
  apply mwf.
Defined.

Definition find (a: elt) : elt * t := proj1_sig (find_x a).

Lemma find_repr:
  forall a, fst (find a) = repr uf a.
Proof.
  unfold find; intros. destruct (find_x a) as [[b uf'] [A B]]. simpl. auto.
Qed.

Lemma find_unchanged:
  forall a x, repr (snd (find a)) x = repr uf x.
Proof.
  unfold find; intros. destruct (find_x a) as [[b uf'] [A B]]. simpl. auto.
Qed.

Lemma sameclass_find_1:
  forall a x y, sameclass (snd (find a)) x y <-> sameclass uf x y.
Proof.
  unfold sameclass; intros. repeat rewrite find_unchanged. tauto.
Qed.

Lemma sameclass_find_2:
  forall a, sameclass uf a (fst (find a)).
Proof.
  intros. rewrite find_repr. apply sameclass_repr.
Qed.

Lemma sameclass_find_3:
  forall a, sameclass (snd (find a)) a (fst (find a)).
Proof.
  intros. rewrite sameclass_find_1. apply sameclass_find_2.
Qed.

End FIND.

End UF.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal49.

From lfind Require Import LFind.
Require Import Arith.
Require Import Extraction.
Extract Inductive nat => nat [ "(O)" "S" ].
Extract Inductive list => list [ "Nil" "Cons" ].
Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal49_mem_cons_96_eqb_elim/goal49_lfind_orig.ml"  adtind.goal49.eqb Coq.Bool.Bool.Is_true.
Success.


From Undecidability Require Import TM.Util.Prelim.
From Undecidability Require Import TM.Code.Code.
From Undecidability Require Import LM_heap_def.

(* * Alphabets *)

Inductive ACom : Type := retAT | lamAT | appAT.

Coercion ACom2Com (a : ACom) : Tok :=
  match a with
  | retAT => retT
  | lamAT => lamT
  | appAT => appT
  end.

#[global]
Instance ACom_eq_dec : eq_dec ACom.
Proof. intros x y; hnf. decide equality. Defined. (* because instance *)

#[global]
Instance ACom_finType : finTypeC (EqType ACom).
Proof. split with (enum := [retAT; lamAT; appAT]). intros [ | | ]; cbn; reflexivity. Defined. (* because instance *)

#[global]
Instance ACom_inhab : inhabitedC ACom := ltac:(repeat constructor).

#[global]
Instance Encode_ACom : codable ACom ACom := Encode_Finite (FinType(EqType ACom)).

Coercion Com_to_sum (t : Tok) : (nat + ACom) :=
  match t with
  | varT x => inl x
  | appT => inr appAT
  | lamT => inr lamAT
  | retT => inr retAT
  end.

Definition sigCom := sigSum sigNat ACom.
Definition sigCom_fin := FinType (EqType sigCom).

#[global]
Instance Encode_Com : codable sigCom Tok :=
  {|
    encode x := encode (Com_to_sum x)
  |}.

Definition Encode_Com_size (t : Tok) : nat :=
  size (Com_to_sum t).

Lemma Encode_Com_hasSize (t : Tok) :
  size t = Encode_Com_size t.
Proof. reflexivity. Qed.

Definition sigHAdd := sigNat.
Definition sigHAdd_fin := FinType(EqType sigHAdd).

Definition sigPro := sigList sigCom.
#[global]
Instance Encode_Prog : codable sigPro Pro := _.
Definition sigPro_fin := FinType(EqType sigPro).

Definition sigHClos := sigPair sigHAdd sigPro.
Definition sigHClos_fin := FinType(EqType sigHClos).
#[global]
Instance Encode_HClos : codable sigHClos HClos := _.

Definition sigHEntr' := sigPair sigHClos sigHAdd.
#[global]
Instance Encode_HEntr' : codable (sigHEntr') (HClos*HAdd) := _.
Definition sigHEntr'_fin := FinType(EqType sigHEntr').

Definition sigHEntr := sigOption sigHEntr'.
#[global]
Instance Encode_HEntr : codable (sigHEntr) HEntr := _.
Definition sigHEntr_fin := FinType(EqType sigHEntr).

Definition sigHeap := sigList sigHEntr.
#[global]
Instance Encode_Heap : codable (sigHeap) Heap := _.
Definition sigHeap_fin := FinType(EqType sigHeap).