(* Distributed under the terms of the MIT license. *)
From MetaCoq.Template Require Import utils uGraph Reflect.
From MetaCoq.PCUIC Require Import PCUICAst PCUICSize.

Require Import ssreflect.
From Equations Require Import Equations.
Set Equations Transparent.

Lemma eqb_annot_reflect {A} na na' : reflect (@eq_binder_annot A A na na') (eqb_binder_annot na na').
Proof.
  unfold eqb_binder_annot, eq_binder_annot.
  destruct Classes.eq_dec; constructor; auto.
Qed.

Definition string_of_aname (b : binder_annot name) :=
  string_of_name b.(binder_name).

Fixpoint string_of_term (t : term) :=
  match t with
  | tRel n => "Rel(" ^ string_of_nat n ^ ")"
  | tVar n => "Var(" ^ n ^ ")"
  | tEvar ev args => "Evar(" ^ string_of_nat ev ^ "," ^ string_of_list string_of_term args ^ ")"
  | tSort s => "Sort(" ^ string_of_sort s ^ ")"
  | tProd na b t => "Prod(" ^ string_of_aname na ^ "," ^
                            string_of_term b ^ "," ^ string_of_term t ^ ")"
  | tLambda na b t => "Lambda(" ^ string_of_aname na ^ "," ^ string_of_term b
                                ^ "," ^ string_of_term t ^ ")"
  | tLetIn na b t' t => "LetIn(" ^ string_of_aname na ^ "," ^ string_of_term b
                                 ^ "," ^ string_of_term t' ^ "," ^ string_of_term t ^ ")"
  | tApp f l => "App(" ^ string_of_term f ^ "," ^ string_of_term l ^ ")"
  | tConst c u => "Const(" ^ string_of_kername c ^ "," ^ string_of_universe_instance u ^ ")"
  | tInd i u => "Ind(" ^ string_of_inductive i ^ "," ^ string_of_universe_instance u ^ ")"
  | tConstruct i n u => "Construct(" ^ string_of_inductive i ^ "," ^ string_of_nat n ^ ","
                                    ^ string_of_universe_instance u ^ ")"
  | tCase ci p t brs =>
    "Case(" ^ string_of_case_info ci ^ "," ^ string_of_term t ^ ","
            ^ string_of_predicate string_of_term p ^ "," ^ string_of_list (string_of_branch string_of_term) brs ^ ")"
  | tProj p c =>
    "Proj(" ^ string_of_inductive p.(proj_ind) ^ "," ^ string_of_nat p.(proj_npars) ^ "," ^ string_of_nat p.(proj_arg) ^ ","
            ^ string_of_term c ^ ")"
  | tFix l n => "Fix(" ^ (string_of_list (string_of_def string_of_term) l) ^ "," ^ string_of_nat n ^ ")"
  | tCoFix l n => "CoFix(" ^ (string_of_list (string_of_def string_of_term) l) ^ "," ^ string_of_nat n ^ ")"
  | tPrim i => "Int(" ^ string_of_prim string_of_term i ^ ")"
  end.

Ltac change_Sk :=
  repeat match goal with
    | |- context [S (?x + ?y)] => progress change (S (x + y)) with (S x + y)
    | |- context [#|?l| + (?x + ?y)] => progress replace (#|l| + (x + y)) with ((#|l| + x) + y) by now rewrite Nat.add_assoc
  end.

Ltac solve_all_one :=
  try lazymatch goal with
  | H: tCasePredProp _ _ _ |- _ => destruct H as [? [? ?]]
  end;
  unfold tCaseBrsProp, tFixProp in *;
  autorewrite with map;
  rtoProp;
  try (
    apply map_predicate_eq_spec ||
    apply map_predicate_k_eq_spec ||
    apply map_predicate_id_spec ||
    apply map_predicate_k_id_spec ||
    apply map_branch_k_eq_spec ||
    apply map_branch_k_id_spec ||
    apply map_def_eq_spec ||
    apply map_def_id_spec ||
    apply map_branch_eq_spec ||
    apply map_branch_id_spec ||
    (eapply All_forallb_eq_forallb; [eassumption|]) ||
    (eapply mapi_context_eqP_test_id_spec; [eassumption|eassumption|]) ||
    (eapply mapi_context_eqP_spec; [eassumption|]) ||
    (eapply mapi_context_eqP_id_spec; [eassumption|]) ||
    (eapply onctx_test; [eassumption|eassumption|]) ||
    (eapply test_context_k_eqP_id_spec; [eassumption|eassumption|]) ||
    (eapply test_context_k_eqP_eq_spec; [eassumption|]) ||
    (eapply map_context_eq_spec; [eassumption|]));
  repeat toAll; try All_map; try close_Forall;
  change_Sk; auto with all;
  intuition eauto 4 with all.

Ltac solve_all := repeat (progress solve_all_one).
#[global] Hint Extern 10 => rewrite !map_branch_map_branch : all.
#[global] Hint Extern 10 => rewrite !map_predicate_map_predicate : all.

Lemma lookup_env_nil c s : lookup_global [] c = Some s -> False.
Proof.
  induction c; simpl; auto => //.
Qed.

Lemma lookup_env_cons {kn d Σ kn' d'} : lookup_global ((kn, d) :: Σ) kn' = Some d' ->
  (kn = kn' /\ d = d') \/ (kn <> kn' /\ lookup_global Σ kn' = Some d').
Proof.
  simpl.
  epose proof (ReflectEq.eqb_spec (A:=kername) kn' kn). simpl in H.
  elim: H. intros -> [= <-]; intuition auto.
  intros diff look. intuition auto.
Qed.

Lemma lookup_env_cons_fresh {kn d Σ kn'} :
  kn <> kn' ->
  lookup_global ((kn, d) :: Σ) kn' = lookup_global Σ kn'.
Proof.
  simpl.
  epose proof (ReflectEq.eqb_spec (A:=kername) kn' kn). simpl in H.
  elim: H. intros -> => //. auto.
Qed.

Fixpoint decompose_app_rec (t : term) l :=
  match t with
  | tApp f a => decompose_app_rec f (a :: l)
  | _ => (t, l)
  end.

Definition decompose_app t := decompose_app_rec t [].

Lemma mkApps_tApp f a l : mkApps (tApp f a) l = mkApps f (a :: l).
Proof. reflexivity. Qed.

Lemma tApp_mkApps f a : tApp f a = mkApps f [a].
Proof. reflexivity. Qed.

Definition mkApps_decompose_app_rec t l :
  mkApps t l = mkApps (fst (decompose_app_rec t l)) (snd (decompose_app_rec t l)).
Proof.
  revert l; induction t; try reflexivity.
  intro l; cbn in *.
  transitivity (mkApps t1 ((t2 ::l))). reflexivity.
  now rewrite IHt1.
Qed.

Definition mkApps_decompose_app t :
  t = mkApps (fst (decompose_app t)) (snd (decompose_app t))
  := mkApps_decompose_app_rec t [].

Lemma decompose_app_rec_mkApps f l l' : decompose_app_rec (mkApps f l) l' =
                                    decompose_app_rec f (l ++ l').
Proof.
  induction l in f, l' |- *; simpl; auto; rewrite IHl ?app_nil_r; auto.
Qed.

Require Import ssrbool.

Lemma decompose_app_mkApps f l :
  ~~ isApp f -> decompose_app (mkApps f l) = (f, l).
Proof.
  intros Hf. rewrite /decompose_app decompose_app_rec_mkApps. rewrite app_nil_r.
  destruct f; simpl in *; (discriminate || reflexivity).
Qed.

Lemma mkApps_app f l l' : mkApps f (l ++ l') = mkApps (mkApps f l) l'.
Proof.
  induction l in f, l' |- *; destruct l'; simpl; rewrite ?app_nil_r; auto.
  rewrite IHl //.
Qed.

Lemma mkApps_tApp_inj fn args t u :
  ~~ isApp fn ->
  mkApps fn args = tApp t u ->
  t = mkApps fn (removelast args) /\ u = last args t.
Proof.
  intros napp eqapp.
  destruct args using rev_case => //.
  simpl in eqapp. subst fn => //.
  rewrite mkApps_app in eqapp. noconf eqapp.
  now rewrite removelast_app // last_app // /= app_nil_r.
Qed.

Lemma removelast_length {A} (args : list A) : #|removelast args| = Nat.pred #|args|.
Proof.
  induction args => //. destruct args => //.
  now rewrite (removelast_app [_]) // app_length IHargs /=.
Qed.

Lemma nth_error_removelast {A} {args : list A} {n arg} :
  nth_error (removelast args) n = Some arg ->
  nth_error args n = Some arg.
Proof.
  intros h. rewrite nth_error_removelast //.
  apply nth_error_Some_length in h.
  now rewrite removelast_length in h.
Qed.

Lemma mkApps_discr f args t :
  args <> [] ->
  mkApps f args = t ->
  ~~ isApp t -> False.
Proof.
  intros.
  destruct args using rev_case => //.
  rewrite mkApps_app in H0. destruct t => //.
Qed.

Fixpoint decompose_prod (t : term) : (list aname) * (list term) * term :=
  match t with
  | tProd n A B => let (nAs, B) := decompose_prod B in
                  let (ns, As) := nAs in
                  (n :: ns, A :: As, B)
  | _ => ([], [], t)
  end.

Fixpoint remove_arity (n : nat) (t : term) : term :=
  match n with
  | O => t
  | S n => match t with
          | tProd _ _ B => remove_arity n B
          | _ => t (* TODO *)
          end
  end.

Definition isConstruct_app t :=
  match fst (decompose_app t) with
  | tConstruct _ _ _ => true
  | _ => false
  end.

(* was mind_decl_to_entry *)
Definition mind_body_to_entry (decl : mutual_inductive_body)
  : mutual_inductive_entry.
Proof.
  refine {| mind_entry_record := None; (* not a record *)
            mind_entry_finite := Finite; (* inductive *)
            mind_entry_params := _;
            mind_entry_inds := _;
            mind_entry_universes := decl.(ind_universes);
            mind_entry_private := None |}.
  - refine (match List.hd_error decl.(ind_bodies) with
            | Some i0 => _
            | None => nil (* assert false: at least one inductive in a mutual block *)
            end).
    pose (typ := decompose_prod i0.(ind_type)).
    destruct typ as [[names types] _].
    apply (List.firstn decl.(ind_npars)) in names.
    apply (List.firstn decl.(ind_npars)) in types.
    refine (map (fun '(x, ty) => vass x ty) (combine names types)).
  - refine (List.map _ decl.(ind_bodies)).
    intros [].
    refine {| mind_entry_typename := ind_name0;
              mind_entry_arity := remove_arity decl.(ind_npars) ind_type0;
              mind_entry_template := false;
              mind_entry_consnames := _;
              mind_entry_lc := _;
            |}.
    refine (List.map (fun x => cstr_name x) ind_ctors0).
    refine (List.map (fun x => remove_arity decl.(ind_npars)
                                                (cstr_type x)) ind_ctors0).
Defined.

Fixpoint decompose_prod_assum (Γ : context) (t : term) : context * term :=
  match t with
  | tProd n A B => decompose_prod_assum (Γ ,, vass n A) B
  | tLetIn na b bty b' => decompose_prod_assum (Γ ,, vdef na b bty) b'
  | _ => (Γ, t)
  end.

Lemma decompose_prod_assum_ctx ctx t : decompose_prod_assum ctx t =
  let (ctx', t') := decompose_prod_assum [] t in
  (ctx ,,, ctx', t').
Proof.
  induction t in ctx |- *; simpl; auto.
  - simpl. rewrite IHt2.
    rewrite (IHt2 ([] ,, vass _ _)).
    destruct (decompose_prod_assum [] t2). simpl.
    unfold snoc. now rewrite app_context_assoc.
  - simpl. rewrite IHt3.
    rewrite (IHt3 ([] ,, vdef _ _ _)).
    destruct (decompose_prod_assum [] t3). simpl.
    unfold snoc. now rewrite app_context_assoc.
Qed.

Fixpoint decompose_prod_n_assum (Γ : context) n (t : term) : option (context * term) :=
  match n with
  | 0 => Some (Γ, t)
  | S n =>
    match t with
    | tProd na A B => decompose_prod_n_assum (Γ ,, vass na A) n B
    | tLetIn na b bty b' => decompose_prod_n_assum (Γ ,, vdef na b bty) n b'
    | _ => None
    end
  end.

(* TODO move *)
Lemma it_mkLambda_or_LetIn_app l l' t :
  it_mkLambda_or_LetIn (l ++ l') t = it_mkLambda_or_LetIn l' (it_mkLambda_or_LetIn l t).
Proof. induction l in l', t |- *; simpl; auto. Qed.

Lemma decompose_prod_n_assum_it_mkProd ctx ctx' ty :
  decompose_prod_n_assum ctx #|ctx'| (it_mkProd_or_LetIn ctx' ty) = Some (ctx' ++ ctx, ty).
Proof.
  revert ctx ty. induction ctx' using rev_ind; move=> // ctx ty.
  rewrite app_length /= it_mkProd_or_LetIn_app /=.
  destruct x as [na [body|] ty'] => /=;
  now rewrite !Nat.add_1_r /= IHctx' -app_assoc.
Qed.

Definition is_ind_app_head t :=
  let (f, l) := decompose_app t in
  match f with
  | tInd _ _ => true
  | _ => false
  end.

Lemma is_ind_app_head_mkApps ind u l : is_ind_app_head (mkApps (tInd ind u) l).
Proof.
  unfold is_ind_app_head.
  unfold decompose_app. rewrite decompose_app_rec_mkApps. now simpl; trivial.
Qed.

Lemma decompose_prod_assum_it_mkProd ctx ctx' ty :
  is_ind_app_head ty ->
  decompose_prod_assum ctx (it_mkProd_or_LetIn ctx' ty) = (ctx' ++ ctx, ty).
Proof.
  revert ctx ty. induction ctx' using rev_ind; move=> // ctx ty /=.
  destruct ty; unfold is_ind_app_head; simpl; try (congruence || reflexivity).
  move=> Hty. rewrite it_mkProd_or_LetIn_app /=.
  case: x => [na [body|] ty'] /=; by rewrite IHctx' // /snoc -app_assoc.
Qed.

Lemma reln_length Γ Γ' n : #|reln Γ n Γ'| = #|Γ| + context_assumptions Γ'.
Proof.
  induction Γ' in n, Γ |- *; simpl; auto.
  destruct a as [? [b|] ?]; simpl; auto.
  rewrite Nat.add_1_r. simpl. rewrite IHΓ' => /= //.
Qed.

Lemma to_extended_list_k_length Γ n : #|to_extended_list_k Γ n| = context_assumptions Γ.
Proof.
  now rewrite /to_extended_list_k reln_length.
Qed.

Lemma reln_list_lift_above l p Γ :
  Forall (fun x => exists n, x = tRel n /\ p <= n /\ n < p + length Γ) l ->
  Forall (fun x => exists n, x = tRel n /\ p <= n /\ n < p + length Γ) (reln l p Γ).
Proof.
  generalize (Nat.le_refl p).
  generalize p at 1 3 5.
  induction Γ in p, l |- *. simpl. auto.
  intros. destruct a. destruct decl_body. simpl.
  assert(p0 <= S p) by lia.
  specialize (IHΓ l (S p) p0 H1). rewrite <- Nat.add_succ_comm, Nat.add_1_r.
  simpl in *. rewrite <- Nat.add_succ_comm in H0. eauto.
  simpl in *.
  specialize (IHΓ (tRel p :: l) (S p) p0 ltac:(lia)). rewrite <- Nat.add_succ_comm, Nat.add_1_r.
  eapply IHΓ. simpl in *. rewrite <- Nat.add_succ_comm in H0. auto.
  simpl in *.
  constructor. exists p. intuition lia. auto.
Qed.

Lemma to_extended_list_k_spec Γ k :
  Forall (fun x => exists n, x = tRel n /\ k <= n /\ n < k + length Γ) (to_extended_list_k Γ k).
Proof.
  pose (reln_list_lift_above [] k Γ).
  unfold to_extended_list_k.
  forward f. constructor. apply f.
Qed.

Lemma to_extended_list_lift_above Γ :
  Forall (fun x => exists n, x = tRel n /\ n < length Γ) (to_extended_list Γ).
Proof.
  pose (reln_list_lift_above [] 0 Γ).
  unfold to_extended_list.
  forward f. constructor. eapply Forall_impl; eauto. intros.
  destruct H; eexists; intuition eauto.
Qed.

Fixpoint reln_alt p (Γ : context) :=
  match Γ with
  | [] => []
  | {| decl_body := Some _ |} :: Γ => reln_alt (p + 1) Γ
  | {| decl_body := None |} :: Γ => tRel p :: reln_alt (p + 1) Γ
  end.

Lemma reln_alt_eq l Γ k : reln l k Γ = List.rev (reln_alt k Γ) ++ l.
Proof.
  induction Γ in l, k |- *; simpl; auto.
  destruct a as [na [body|] ty]; simpl.
  now rewrite IHΓ.
  now rewrite IHΓ -app_assoc.
Qed.

Lemma to_extended_list_k_cons d Γ k :
  to_extended_list_k (d :: Γ) k =
  match d.(decl_body) with
  | None => to_extended_list_k Γ (S k) ++ [tRel k]
  | Some b => to_extended_list_k Γ (S k)
  end.
Proof.
  rewrite /to_extended_list_k reln_alt_eq. simpl.
  destruct d as [na [body|] ty]. simpl.
  now rewrite reln_alt_eq Nat.add_1_r.
  simpl. rewrite reln_alt_eq.
  now rewrite -app_assoc !app_nil_r Nat.add_1_r.
Qed.

Ltac merge_All :=
  unfold tFixProp, tCaseBrsProp in *;
  repeat toAll.

#[global]
Hint Rewrite @map_def_id @map_id : map.

(* TODO move *)
Ltac close_All :=
  match goal with
  | H : Forall _ _ |- Forall _ _ => apply (Forall_impl H); clear H; simpl
  | H : All _ _ |- All _ _ => apply (All_impl H); clear H; simpl
  | H : OnOne2 _ _ _ |- OnOne2 _ _ _ => apply (OnOne2_impl H); clear H; simpl
  | H : All2 _ _ _ |- All2 _ _ _ => apply (All2_impl H); clear H; simpl
  | H : Forall2 _ _ _ |- Forall2 _ _ _ => apply (Forall2_impl H); clear H; simpl
  | H : All _ _ |- All2 _ _ _ =>
    apply (All_All2 H); clear H; simpl
  | H : All2 _ _ _ |- All _ _ =>
    (apply (All2_All_left H) || apply (All2_All_right H)); clear H; simpl
  end.

Lemma mkApps_inj :
  forall u v l,
    mkApps u l = mkApps v l ->
    u = v.
Proof.
  intros u v l eq.
  revert u v eq.
  induction l ; intros u v eq.
  - cbn in eq. assumption.
  - cbn in eq. apply IHl in eq.
    inversion eq. reflexivity.
Qed.

Lemma isApp_mkApps :
  forall u l,
    isApp u ->
    isApp (mkApps u l).
Proof.
  intros u l h.
  induction l in u, h |- *.
  - cbn. assumption.
  - cbn. apply IHl. reflexivity.
Qed.

Lemma decompose_app_rec_notApp :
  forall t l u l',
    decompose_app_rec t l = (u, l') ->
    isApp u = false.
Proof.
  intros t l u l' e.
  induction t in l, u, l', e |- *.
  all: try (cbn in e ; inversion e ; reflexivity).
  cbn in e. eapply IHt1. eassumption.
Qed.

Lemma decompose_app_notApp :
  forall t u l,
    decompose_app t = (u, l) ->
    isApp u = false.
Proof.
  intros t u l e.
  eapply decompose_app_rec_notApp. eassumption.
Qed.

Lemma decompose_app_rec_inv {t l' f l} :
  decompose_app_rec t l' = (f, l) ->
  mkApps t l' = mkApps f l.
Proof.
  induction t in f, l', l |- *; try intros [= <- <-]; try reflexivity.
  simpl. apply/IHt1.
Qed.

Lemma decompose_app_inv {t f l} :
  decompose_app t = (f, l) -> t = mkApps f l.
Proof. by apply/decompose_app_rec_inv. Qed.

Lemma decompose_app_nonnil t f l :
  isApp t ->
  decompose_app t = (f, l) -> l <> [].
Proof.
  intros isApp.
  destruct t; simpl => //.
  intros da.
  pose proof (decompose_app_notApp _ _ _ da).
  apply decompose_app_inv in da.
  destruct l using rev_ind.
  unfold decompose_app => /=.
  destruct f => //.
  destruct l => //.
Qed.

Fixpoint nApp t :=
  match t with
  | tApp u _ => S (nApp u)
  | _ => 0
  end.

Lemma isApp_false_nApp :
  forall u,
    isApp u = false ->
    nApp u = 0.
Proof.
  intros u h.
  destruct u.
  all: try reflexivity.
  discriminate.
Qed.

Lemma nApp_mkApps :
  forall t l,
    nApp (mkApps t l) = nApp t + #|l|.
Proof.
  intros t l.
  induction l in t |- *.
  - simpl. lia.
  - simpl. rewrite IHl. cbn. lia.
Qed.

Lemma decompose_app_eq_mkApps :
  forall t u l l',
    decompose_app t = (mkApps u l', l) ->
    l' = [].
Proof.
  intros t u l l' e.
  apply decompose_app_notApp in e.
  apply isApp_false_nApp in e.
  rewrite nApp_mkApps in e.
  destruct l' ; cbn in e ; try lia.
  reflexivity.
Qed.

Lemma mkApps_nApp_inj :
  forall u u' l l',
    nApp u = nApp u' ->
    mkApps u l = mkApps u' l' ->
    u = u' /\ l = l'.
Proof.
  intros u u' l l' h e.
  induction l in u, u', l', h, e |- *.
  - cbn in e. subst.
    destruct l' ; auto.
    exfalso.
    rewrite nApp_mkApps in h. cbn in h. lia.
  - destruct l'.
    + cbn in e. subst. exfalso.
      rewrite nApp_mkApps in h. cbn in h. lia.
    + cbn in e. apply IHl in e.
      * destruct e as [e1 e2].
        inversion e1. subst. auto.
      * cbn. f_equal. auto.
Qed.

Lemma mkApps_notApp_inj :
  forall u u' l l',
    isApp u = false ->
    isApp u' = false ->
    mkApps u l = mkApps u' l' ->
    u = u' /\ l = l'.
Proof.
  intros u u' l l' h h' e.
  eapply mkApps_nApp_inj.
  - rewrite -> 2!isApp_false_nApp by assumption. reflexivity.
  - assumption.
Qed.

Definition head x := (decompose_app x).1.
Definition arguments x := (decompose_app x).2.

Lemma head_arguments x : mkApps (head x) (arguments x) = x.
Proof.
  unfold head, arguments, decompose_app.
  remember (decompose_app_rec x []).
  destruct p as [f l].
  symmetry in Heqp.
  eapply decompose_app_rec_inv in Heqp.
  now simpl in *.
Qed.

Lemma fst_decompose_app_rec t l : fst (decompose_app_rec t l) = fst (decompose_app t).
Proof.
  induction t in l |- *; simpl; auto. rewrite IHt1.
  unfold decompose_app. simpl. now rewrite (IHt1 [t2]).
Qed.

Lemma decompose_app_rec_head t l f : fst (decompose_app_rec t l) = f ->
  negb (isApp f).
Proof.
  induction t; unfold isApp; simpl; try intros [= <-]; auto.
  intros. apply IHt1. now rewrite !fst_decompose_app_rec.
Qed.

Lemma head_nApp x : negb (isApp (head x)).
Proof.
  unfold head.
  eapply decompose_app_rec_head. reflexivity.
Qed.

Lemma head_tapp t1 t2 : head (tApp t1 t2) = head t1.
Proof. rewrite /head /decompose_app /= fst_decompose_app_rec //. Qed.

Lemma mkApps_Fix_spec mfix idx args t : mkApps (tFix mfix idx) args = t ->
                                        match decompose_app t with
                                        | (tFix mfix idx, args') => args' = args
                                        | _ => False
                                        end.
Proof.
  intros H; apply (f_equal decompose_app) in H.
  rewrite decompose_app_mkApps in H. reflexivity.
  destruct t; noconf H. rewrite <- H. reflexivity.
  simpl. reflexivity.
Qed.

Lemma decompose_app_rec_tFix mfix idx args t l :
  decompose_app_rec t l = (tFix mfix idx, args) -> mkApps t l = mkApps (tFix mfix idx) args.
Proof.
  unfold decompose_app.
  revert l args.
  induction t; intros args l' H; noconf H. simpl in H.
  now specialize (IHt1 _ _ H).
  reflexivity.
Qed.

Lemma decompose_app_tFix mfix idx args t :
  decompose_app t = (tFix mfix idx, args) -> t = mkApps (tFix mfix idx) args.
Proof. apply decompose_app_rec_tFix. Qed.

Lemma mkApps_eq_head {x l} : mkApps x l = x -> l = [].
Proof.
  assert (WF : WellFounded (precompose lt PCUICSize.size))
    by apply wf_precompose, lt_wf.
  induction l. simpl. constructor.
  apply apply_noCycle_right. simpl. red. rewrite size_mkApps. simpl. lia.
Qed.

Lemma mkApps_eq_inv {x y l} : x = mkApps y l -> size y <= size x.
Proof.
  assert (WF : WellFounded (precompose lt size))
    by apply wf_precompose, lt_wf.
  induction l in x, y |- *. simpl. intros -> ; constructor.
  simpl. intros. specialize (IHl _ _ H). simpl in IHl. lia.
Qed.

Lemma mkApps_eq_left x y l : mkApps x l = mkApps y l -> x = y.
Proof.
  induction l in x, y |- *; simpl. auto.
  intros. simpl in *. specialize (IHl _ _ H). now noconf IHl.
Qed.

Lemma decompose_app_eq_right t l l' : decompose_app_rec t l = decompose_app_rec t l' -> l = l'.
Proof.
  induction t in l, l' |- *; simpl; intros [=]; auto.
  specialize (IHt1 _ _ H0). now noconf IHt1.
Qed.

Lemma mkApps_eq_right t l l' : mkApps t l = mkApps t l' -> l = l'.
Proof.
  intros. eapply (f_equal decompose_app) in H. unfold decompose_app in H.
  rewrite !decompose_app_rec_mkApps in H. apply decompose_app_eq_right in H.
  now rewrite !app_nil_r in H.
Qed.

Lemma atom_decompose_app t l : ~~ isApp t -> decompose_app_rec t l = pair t l.
Proof. destruct t; simpl; congruence. Qed.

Lemma mkApps_eq_inj {t t' l l'} :
  mkApps t l = mkApps t' l' ->
  ~~ isApp t -> ~~ isApp t' -> t = t' /\ l = l'.
Proof.
  intros Happ Ht Ht'. eapply (f_equal decompose_app) in Happ. unfold decompose_app in Happ.
  rewrite !decompose_app_rec_mkApps in Happ. rewrite !atom_decompose_app in Happ; auto.
  rewrite !app_nil_r in Happ. intuition congruence.
Qed.

Ltac solve_discr' :=
  match goal with
    H : mkApps _ _ = mkApps ?f ?l |- _ =>
    eapply mkApps_eq_inj in H as [? ?]; [|easy|easy]; subst; try intuition congruence
  | H : ?t = mkApps ?f ?l |- _ =>
    change t with (mkApps t []) in H ;
    eapply mkApps_eq_inj in H as [? ?]; [|easy|easy]; subst; try intuition congruence
  | H : mkApps ?f ?l = ?t |- _ =>
    change t with (mkApps t []) in H ;
    eapply mkApps_eq_inj in H as [? ?]; [|easy|easy]; subst; try intuition congruence
  end.

Lemma mkApps_eq_decompose_app {t t' l l'} :
  mkApps t l = mkApps t' l' ->
  decompose_app_rec t l = decompose_app_rec t' l'.
Proof.
  induction l in t, t', l' |- *; simpl.
  - intros ->. rewrite !decompose_app_rec_mkApps.
    now rewrite app_nil_r.
  - intros H. apply (IHl _ _ _ H).
Qed.

Lemma mkApps_eq_decompose {f args t} :
  mkApps f args = t ->
  ~~ isApp f ->
  fst (decompose_app t) = f.
Proof.
  intros H Happ; apply (f_equal decompose_app) in H.
  rewrite decompose_app_mkApps in H. auto. rewrite <- H. reflexivity.
Qed.

Ltac finish_discr :=
  repeat match goal with
         | [ H : ?x = ?x |- _ ] => clear H
         | [ H : mkApps _ _ = mkApps _ _ |- _ ] =>
           let H0 := fresh in let H1 := fresh in
                              specialize (mkApps_eq_inj H eq_refl eq_refl) as [H0 H1];
                              clear H;
                              try (congruence || (noconf H0; noconf H1))
         | [ H : mkApps _ _ = _ |- _ ] => apply mkApps_eq_head in H
         end.

Ltac prepare_discr :=
  repeat match goal with
         | [ H : mkApps ?f ?l = tApp ?y ?r |- _ ] => change (mkApps f l = mkApps y [r]) in H
         | [ H : tApp ?f ?l = mkApps ?y ?r |- _ ] => change (mkApps f [l] = mkApps y r) in H
         | [ H : mkApps ?x ?l = ?y |- _ ] =>
           match y with
           | mkApps _ _ => fail 1
           | _ => change (mkApps x l = mkApps y []) in H
           end
         | [ H : ?x = mkApps ?y ?l |- _ ] =>
           match x with
           | mkApps _ _ => fail 1
           | _ => change (mkApps x [] = mkApps y l) in H
           end
         end.

Inductive mkApps_spec : term -> list term -> term -> list term -> term -> Type :=
| mkApps_intro f l n :
    ~~ isApp f ->
    mkApps_spec f l (mkApps f (firstn n l)) (skipn n l) (mkApps f l).

Lemma decompose_app_rec_eq f l :
  ~~ isApp f ->
  decompose_app_rec f l = (f, l).
Proof.
  destruct f; simpl; try discriminate; congruence.
Qed.

Lemma decompose_app_rec_inv' f l hd args :
  decompose_app_rec f l = (hd, args) ->
  ∑ n, ~~ isApp hd /\ l = skipn n args /\ f = mkApps hd (firstn n args).
Proof.
  destruct (isApp f) eqn:Heq.
  revert l args hd.
  induction f; try discriminate. intros.
  simpl in H.
  destruct (isApp f1) eqn:Hf1.
  2:{ rewrite decompose_app_rec_eq in H => //. now apply negbT.
      revert Hf1.
      inv H. exists 1. simpl. intuition auto. now eapply negbT. }
  destruct (IHf1 eq_refl _ _ _ H).
  clear IHf1.
  exists (S x); intuition auto. eapply (f_equal (skipn 1)) in H2.
  rewrite [l]H2. now rewrite skipn_skipn Nat.add_1_r.
  rewrite -Nat.add_1_r firstn_add H3 -H2.
  now rewrite -[tApp _ _](mkApps_app hd _ [f2]).
  rewrite decompose_app_rec_eq; auto. now apply negbT.
  move=> [] H ->. subst f. exists 0. intuition auto.
  now apply negbT.
Qed.

Lemma mkApps_elim_rec t l l' :
  let app' := decompose_app_rec (mkApps t l) l' in
  mkApps_spec app'.1 app'.2 t (l ++ l') (mkApps t (l ++ l')).
Proof.
  destruct app' as [hd args] eqn:Heq.
  subst app'.
  rewrite decompose_app_rec_mkApps in Heq.
  have H := decompose_app_rec_inv' _ _ _ _ Heq.
  destruct H. simpl. destruct a as [isapp [Hl' Hl]].
  subst t.
  have H' := mkApps_intro hd args x. rewrite Hl'.
  rewrite -mkApps_app. now rewrite firstn_skipn.
Qed.

Lemma mkApps_elim t l  :
  let app' := decompose_app (mkApps t l) in
  mkApps_spec app'.1 app'.2 t l (mkApps t l).
Proof.
  have H := @mkApps_elim_rec t l [].
  now rewrite app_nil_r in H.
Qed.

Lemma nisApp_mkApps {t l} : ~~ isApp (mkApps t l) -> ~~ isApp t /\ l = [].
Proof.
  induction l in t |- *; simpl; auto.
  intros. destruct (IHl _ H). discriminate.
Qed.

Lemma mkApps_nisApp {t t' l} : mkApps t l = t' -> ~~ isApp t' -> t = t' /\ l = [].
Proof.
  induction l in t |- *; simpl; auto.
  intros. destruct (IHl _ H). auto. subst. simpl in H0. discriminate.
Qed.

Lemma tApp_mkApps_inj f a f' l :
  tApp f a = mkApps f' l -> l <> [] ->
  f = mkApps f' (removelast l) /\ (a = last l a).
Proof.
  induction l in f' |- *; simpl; intros H. noconf H. intros Hf. congruence.
  intros . destruct l; simpl in *. now noconf H.
  specialize (IHl _ H). forward IHl by congruence.
  apply IHl.
Qed.

Definition application_atom t :=
  match t with
  | tVar _
  | tSort _
  | tInd _ _
  | tConstruct _ _ _
  | tLambda _ _ _ => true
  | _ => false
  end.

Lemma application_atom_mkApps {t l} : application_atom (mkApps t l) -> application_atom t /\ l = [].
Proof.
  induction l in t |- *; simpl; auto.
  intros. destruct (IHl _ H). discriminate.
Qed.

Ltac solve_discr :=
  (try (progress (prepare_discr; finish_discr; cbn [mkApps] in * )));
  (try (match goal with
        | [ H : is_true (application_atom _) |- _ ] => discriminate
        | [ H : is_true (application_atom (mkApps _ _)) |- _ ] =>
          destruct (application_atom_mkApps H); subst; try discriminate
        end)).

(** Use a coercion for this common projection of the global context. *)
Definition fst_ctx : global_env_ext -> global_env := fst.
Coercion fst_ctx : global_env_ext >-> global_env.

Definition empty_ext (Σ : global_env) : global_env_ext
  := (Σ, Monomorphic_ctx).

Lemma destArity_app_aux {Γ Γ' t}
  : destArity (Γ ,,, Γ') t = option_map (fun '(ctx, s) => (Γ ,,, ctx, s))
                                        (destArity Γ' t).
Proof.
  revert Γ'.
  induction t; cbn; intro Γ'; try reflexivity.
  - rewrite <- app_context_cons. now eapply IHt2.
  - rewrite <- app_context_cons. now eapply IHt3.
Qed.

Lemma destArity_app {Γ t}
  : destArity Γ t = option_map (fun '(ctx, s) => (Γ ,,, ctx, s))
                               (destArity [] t).
Proof.
  exact (@destArity_app_aux Γ [] t).
Qed.

Lemma destArity_app_Some {Γ t ctx s}
  : destArity Γ t = Some (ctx, s)
    -> ∑ ctx', destArity [] t = Some (ctx', s) /\ ctx = Γ ,,, ctx'.
Proof.
  intros H. rewrite destArity_app in H.
  destruct (destArity [] t) as [[ctx' s']|]; cbn in *.
  exists ctx'. inversion H. now subst.
  discriminate H.
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 mkApps_nonempty f l :
  l <> [] -> mkApps f l = tApp (mkApps f (removelast l)) (last l f).
Proof.
  destruct l using rev_ind. intros; congruence.
  intros. rewrite mkApps_app. simpl. f_equal.
  rewrite removelast_app. congruence. simpl. now rewrite app_nil_r.
  rewrite last_app. congruence.
  reflexivity.
Qed.

Lemma destArity_tFix {mfix idx args} :
  destArity [] (mkApps (tFix mfix idx) args) = None.
Proof.
  induction args. reflexivity.
  rewrite mkApps_nonempty.
  intros e; discriminate e.
  reflexivity.
Qed.

Lemma destArity_tApp {t u l} :
  destArity [] (mkApps (tApp t u) l) = None.
Proof.
  induction l. reflexivity.
  rewrite mkApps_nonempty.
  intros e; discriminate e.
  reflexivity.
Qed.

Lemma destArity_tInd {t u l} :
  destArity [] (mkApps (tInd t u) l) = None.
Proof.
  induction l. reflexivity.
  rewrite mkApps_nonempty.
  intros e; discriminate e.
  reflexivity.
Qed.

Lemma destArity_mkApps_None ctx t l :
  destArity ctx t = None -> destArity ctx (mkApps t l) = None.
Proof.
  induction l in t |- *. trivial.
  intros H. cbn. apply IHl. reflexivity.
Qed.

Lemma destArity_mkApps_Ind ctx ind u l :
  destArity ctx (mkApps (tInd ind u) l) = None.
Proof.
  apply destArity_mkApps_None. reflexivity.
Qed.

(* Helper for nested recursive functions on well-typed terms *)

Section MapInP.
  Context {A B : Type}.
  Context {P : A -> Type}.
  Context (f : forall (x : A), P x -> B).

  Equations map_InP (l : list A) (H : forall x, In x l -> P x) : list B :=
  map_InP nil _ := nil;
  map_InP (cons x xs) H := cons (f x (H x (or_introl eq_refl))) (map_InP xs (fun x inx => H x _)).
End MapInP.

Lemma map_InP_spec {A B : Type} {P : A -> Type} (f : A -> B) (l : list A) (H : forall x, In x l -> P x) :
  map_InP (fun (x : A) (_ : P x) => f x) l H = List.map f l.
Proof.
  remember (fun (x : A) (_ : P x) => f x) as g.
  funelim (map_InP g l H) => //; simpl. f_equal.
  now rewrite H0.
Qed.

Lemma nth_error_map_InP {A B : Type} {P : A -> Type} (f : forall x : A, P x -> B) (l : list A) (H : forall x, In x l -> P x) n x :
  nth_error (map_InP f l H) n = Some x ->
  ∑ a, (nth_error l n = Some a) *
  ∑ p : P a, x = f a p.
Proof.
  induction l in n, H |- *. simpl. rewrite nth_error_nil => //.
  destruct n; simpl; intros [=].
  subst x.
  eexists; intuition eauto.
  eapply IHl. eapply H1.
Qed.

Lemma map_InP_length {A B : Type} {P : A -> Type} (f : forall x : A, P x -> B) (l : list A) (H : forall x, In x l -> P x) :
  #|map_InP f l H| = #|l|.
Proof.
  induction l; simpl; auto.
Qed.
#[global]
Hint Rewrite @map_InP_length : len.

(** Views *)

Definition isSort T :=
  match T with
  | tSort u => true
  | _ => false
  end.

Inductive view_sort : term -> Type :=
| view_sort_sort s : view_sort (tSort s)
| view_sort_other t : ~ isSort t -> view_sort t.

Equations view_sortc (t : term) : view_sort t :=
  view_sortc (tSort s) := view_sort_sort s;
  view_sortc t := view_sort_other t _.

Definition isProd t :=
  match t with
  | tProd na A B => true
  | _ => false
  end.

Inductive view_prod : term -> Type :=
| view_prod_prod na A b : view_prod (tProd na A b)
| view_prod_other t : ~ isProd t -> view_prod t.

Equations view_prodc (t : term) : view_prod t :=
  view_prodc (tProd na A b) := view_prod_prod na A b;
  view_prodc t := view_prod_other t _.

Definition isInd (t : term) : bool :=
  match t with
  | tInd _ _ => true
  | _ => false
  end.

Inductive view_ind : term -> Type :=
| view_ind_tInd ind u : view_ind (tInd ind u)
| view_ind_other t : negb (isInd t) -> view_ind t.

Equations view_indc (t : term) : view_ind t :=
  view_indc (tInd ind u) => view_ind_tInd ind u;
  view_indc t => view_ind_other t _.

Inductive view_prod_sort : term -> Type :=
| view_prod_sort_prod na A B : view_prod_sort (tProd na A B)
| view_prod_sort_sort u : view_prod_sort (tSort u)
| view_prod_sort_other t :
    ~isProd t ->
    ~isSort t ->
    view_prod_sort t.

Equations view_prod_sortc (t : term) : view_prod_sort t := {
  | tProd na A B => view_prod_sort_prod na A B;
  | tSort u => view_prod_sort_sort u;
  | t => view_prod_sort_other t _ _
  }.

Lemma nth_error_ass_subst_context s k Γ :
  (forall n d, nth_error Γ n = Some d -> decl_body d = None) ->
  forall n d, nth_error (subst_context s k Γ) n = Some d -> decl_body d = None.
Proof.
  induction Γ as [|[? [] ?] ?] in |- *; simpl; auto;
  intros; destruct n; simpl in *; rewrite ?subst_context_snoc in H0; simpl in H0.
  - noconf H0; simpl.
    specialize (H 0 _ eq_refl). simpl in H; discriminate.
  - specialize (H 0 _ eq_refl). simpl in H; discriminate.
  - noconf H0; simpl. auto.
  - eapply IHΓ; intros; eauto.
    now specialize (H (S n0) d0 H1).
Qed.

Lemma nth_error_smash_context Γ Δ :
  (forall n d, nth_error Δ n = Some d -> decl_body d = None) ->
  forall n d, nth_error (smash_context Δ Γ) n = Some d -> decl_body d = None.
Proof.
  induction Γ as [|[? [] ?] ?] in Δ |- *; simpl; auto.
  - intros. eapply (IHΓ (subst_context [t] 0 Δ)); tea.
    now apply nth_error_ass_subst_context.
  - intros. eapply IHΓ. 2:eauto.
    intros.
    pose proof (nth_error_Some_length H1). autorewrite with len in H2. simpl in H2.
    destruct (eq_dec n0 #|Δ|).
    * subst.
      rewrite nth_error_app_ge in H1; try lia.
      rewrite Nat.sub_diag /= in H1. noconf H1.
      reflexivity.
    * rewrite nth_error_app_lt in H1; try lia. eauto.
Qed.

Lemma context_assumptions_smash_context Δ Γ :
  context_assumptions (smash_context Δ Γ) =
  context_assumptions Δ + context_assumptions Γ.
Proof.
  induction Γ as [|[? [] ?] ?] in Δ |- *; simpl; auto;
  rewrite IHΓ.
  - now rewrite context_assumptions_fold.
  - rewrite context_assumptions_app /=. lia.
Qed.

Lemma context_assumptions_expand_lets_ctx Γ Δ :
  context_assumptions (expand_lets_ctx Γ Δ) = context_assumptions Δ.
Proof. now rewrite /expand_lets_ctx /expand_lets_k_ctx; len. Qed.
#[global]
Hint Rewrite context_assumptions_expand_lets_ctx : len.


(* File reduced by coq-bug-finder from original input, then from 2809 lines to 39 lines *)
Set Primitive Projections.
Set Implicit Arguments.
Module Export foo.
  Record prod (A B : Type) := pair { fst : A ; snd : B }.
End foo.
Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope.
Arguments idpath {A a} , [A] a.
Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y := match p with idpath => idpath end.
Axiom path_prod : forall {A B : Type} (z z' : prod A B), (fst z = fst z') -> (snd z = snd z') -> (z = z').
Notation fst := (@fst _ _).
Notation snd := (@snd _ _).
Definition ap_fst_path_prod {A B : Type} {z z' : prod A B} (p : @paths A (fst z) (fst z')) (q : snd z = snd z')
: ap fst (path_prod z z' p q) = p.
Abort.

Notation fstp x := (x.(foo.fst)).
Notation fstap x := (foo.fst x).

Definition ap_fst_path_prod' {A B : Type} {z z' : prod A B} (p : @paths A (fst z) (fst z')) (q : snd z = snd z')
: ap (fun x => fstap x) (path_prod z z' p q) = p.

Abort.

(* Toplevel input, characters 137-138:
Error:
In environment
A : Type
B : Type
z : prod A B
z' : prod A B
p : @paths A (foo.fst ?11 ?14 z) (foo.fst ?26 ?29 z')
q : @paths ?54 (foo.snd ?42 ?45 z) (foo.snd ?57 ?60 z')
The term "p" has type "@paths A (foo.fst ?11 ?14 z) (foo.fst ?26 ?29 z')"
while it is expected to have type "@paths A (foo.fst z) (foo.fst z')". *)


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import TableAux.Specs.invalidate_block.
Require Import TableAux.LowSpecs.invalidate_block.
Require Import TableAux.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       barrier_spec
       stage2_tlbi_ipa_spec
    .

  Lemma invalidate_block_spec_exists:
    forall habd habd'  labd addr
           (Hspec: invalidate_block_spec addr habd = Some habd')
            (Hrel: relate_RData habd labd),
    exists labd', invalidate_block_spec0 addr labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    intros. destruct Hrel. inv id_rdata.
    unfold invalidate_block_spec, invalidate_block_spec0 in *. repeat autounfold in *.
    repeat simpl_hyp Hspec; inv Hspec.
    eexists. split. reflexivity. constructor.
    replace (4096 / 4096) with 1 by reflexivity.
    match goal with
    | |- _ {share: _ {tlbs: ?f1}} = _ {share: _ {tlbs: ?f2}} => assert(f1 = f2)
    end.
    apply func_eq. intros. repeat destruct_if; try reflexivity; repeat destruct_con; repeat destruct_dis; bool_rel; try omega.
    rewrite H. reflexivity.
  Qed.

End Refine.


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

Local Open Scope Z_scope.

Section SpecLow.

  Definition rec_granule_measure_spec0 (rd: Pointer) (rec: Pointer) (data_size: Z64) (adt: RData) : option RData :=
    match rd, rec, data_size with
    | (_rd_base, _rd_ofst), (_rec_base, _rec_ofst), VZ64 _data_size =>
      when adt == measurement_extend_rec_header_spec (_rd_base, _rd_ofst) (_rec_base, _rec_ofst) adt;
      when adt == measurement_extend_rec_regs_spec (_rd_base, _rd_ofst) (_rec_base, _rec_ofst) adt;
      when adt == measurement_extend_rec_pstate_spec (_rd_base, _rd_ofst) (_rec_base, _rec_ofst) adt;
      when adt == measurement_extend_rec_sysregs_spec (_rd_base, _rd_ofst) (_rec_base, _rec_ofst) adt;
      Some adt
     end
    .

End SpecLow.


Require Import CSet Le.

Require Import Plus Util AllInRel Map.
Require Import Val Var Envs IL Annotation SetOperations MoreList Indexwise PairwiseDisjoint.

Set Implicit Arguments.

(** * Renamed-apart (formally) *)
(** Every subterm is annotated with two sets [D] and [D'] such that
    [D] contains all free variables of the subterm and [D'] is extactly
    the set of variables that occur in a binding position. *)

Definition defVars (Zs:params * stmt) (a:ann (set var * set var)) := of_list (fst Zs) ∪ snd (getAnn a).

Hint Unfold defVars.

Definition funConstr D Dt (Zs:params * stmt) a :=
  fst (getAnn a) [=] of_list (fst Zs) ∪ D
  /\ NoDupA eq (fst Zs)
  /\ disj (of_list (fst Zs)) D
  /\ disj (of_list (fst Zs) ∪ snd (getAnn a)) Dt.

Instance funConstr_morphism_impl
: Proper (Equal ==> (flip Subset) ==> eq ==> (ann_R (@pe _ _)) ==> impl) funConstr.
Proof.
  unfold Proper, respectful, impl; intros; subst.
  destruct H3; dcr; hnf. rewrite <- H.
  rewrite <- H1. eapply ann_R_get in H2. rewrite <- H2.
  split; eauto. split; eauto. split; eauto.
  rewrite<- H0. eauto.
Qed.

Instance funConstr_morphism_iff
: Proper (Equal ==> Equal ==> eq ==> (ann_R (@pe _ _)) ==> iff) funConstr.
Proof.
  unfold Proper, respectful, flip; split; subst; intros;
    eapply funConstr_morphism_impl; eauto; unfold flip; try symmetry; eauto;
      rewrite H0; eauto.
Qed.

Instance funConstr_morphism_iff_pointwise
  : Proper (Equal ==> Equal ==> (pointwise_relation _ (pointwise_relation _ iff)))
           funConstr.
Proof.
  unfold Proper, respectful, flip; split; subst; intros;
    eapply funConstr_morphism_impl; eauto; unfold flip; try symmetry; eauto;
      rewrite H0; eauto.
Qed.

Inductive renamedApart : stmt -> ann (set var * set var) -> Prop :=
  | renamedApartExp x e s D Ds D' an
    : x ∉ D
      -> Exp.freeVars e ⊆ D
      -> renamedApart s an
      -> D' [=] {x; Ds}
      -> pe (getAnn an) ({x; D}, Ds)
      -> renamedApart (stmtLet x e s) (ann1 (D, D') an)
  | renamedApartIf  D D' Ds Dt e s t ans ant
    : Ops.freeVars e ⊆ D
      -> disj Ds Dt
      -> Ds ∪ Dt [=] D'
      -> renamedApart s ans
      -> renamedApart t ant
      -> pe (getAnn ans) (D, Ds)
      -> pe (getAnn ant) (D, Dt)
      -> renamedApart (stmtIf e s t) (ann2 (D, D') ans ant)
  | renamedApartRet D D' e
    : Ops.freeVars e ⊆ D
      -> D' [=] ∅
      -> renamedApart (stmtReturn e) (ann0 (D, D'))
  | renamedApartGoto D D' f Y
    : list_union (List.map Ops.freeVars Y) ⊆ D
      -> D' [=] ∅
      -> renamedApart (stmtApp f Y) (ann0 (D, D'))
  | renamedApartLet D D' F t Dt ans ant
    : length F = length ans
      -> (forall n Zs a, get F n Zs -> get ans n a -> renamedApart (snd Zs) a)
      -> indexwise_R (funConstr D Dt) F ans
      -> pairwise_ne disj (zip defVars F ans)
      -> renamedApart t ant
      -> pe (getAnn ant) (D, Dt)
      -> list_union (zip defVars F ans) ∪ Dt  [=] D'
      -> renamedApart (stmtFun F t) (annF (D,D') ans ant).

(** ** Morphisms *)

Lemma renamedApart_ext s an an'
  : ann_R (@pe _ _) an an'
  -> renamedApart s an
  -> renamedApart s an'.
Proof.
  intros.
  general induction H0; simpl; invtc (ann_R (@pe var _));
  invtc (@pe var _); eauto using renamedApart.
  - econstructor; try srewrite c; try srewrite d; eauto.
    rewrite <- (ann_R_get H9). eauto.
  - econstructor; try srewrite c; try srewrite d; eauto.
    + rewrite <- (ann_R_get H10); eauto.
    + rewrite <- (ann_R_get H11); eauto.
  - econstructor; try srewrite c; try srewrite d; eauto.
  - econstructor; try srewrite c; try srewrite d; eauto.
  - assert (PIR2 Equal (zip defVars F bns) (zip defVars F ans)).
    { eapply zip_ext_PIR2; eauto; try congruence.
      intros. get_functional.
      exploit H14; eauto. unfold defVars.
      rewrite H10. reflexivity.
    }
    econstructor; eauto with len.
    + intros; inv_get; eauto.
    + instantiate (1:=Dt).
      hnf; intros. inv_get.
      exploit H14; eauto. rewrite <- H9, <- H16.
      eapply H2; eauto.
    + eapply pairwise_disj_PIR2; eauto. symmetry; eauto.
    + rewrite <- H9, <- H15; eauto.
    + rewrite <- H13, H7. eauto.
Qed.

Instance renamedApart_morphism
: Proper (eq ==> (ann_R (@pe _ _)) ==> iff) renamedApart.
Proof.
  intros x s t A; subst. intros. split; intros.
  eapply renamedApart_ext; eauto.
  eapply renamedApart_ext; try symmetry; eauto.
Qed.

(** ** Relation to freeVars and occurVars *)
Lemma renamedApart_freeVars s an
  : renamedApart s an -> freeVars s ⊆ fst (getAnn an).
Proof.
  intros. general induction H; simpl; eauto; pe_rewrite; set_simpl.
  - rewrite IHrenamedApart, H0.
    clear_all; cset_tac.
  - rewrite H, IHrenamedApart1, IHrenamedApart2. cset_tac.
  - rewrite IHrenamedApart.
    rewrite (@list_union_incl _ _ _ _ D); eauto with cset.
    intros ? ? GET. inv_get.
    rewrite H1; eauto.
    edestruct H2; eauto; dcr; eauto with cset.
Qed.

Instance indexwise_R_morphism_impl A B
: Proper ((pointwise_relation _ (pointwise_relation _ impl)) ==> eq ==> eq ==> impl) (@indexwise_R A B).
Proof.
  unfold Proper, respectful, pointwise_relation, impl, indexwise_R.
  intros; subst. eapply H. eapply H2; eauto.
Qed.

Instance indexwise_R_morphism_iff A B
: Proper ((pointwise_relation _ (pointwise_relation _ iff)) ==> eq ==> eq ==> iff) (@indexwise_R A B).
Proof.
  unfold Proper, respectful, pointwise_relation.
  split; subst; intros; eapply indexwise_R_morphism_impl; eauto;
  unfold pointwise_relation, impl; intros; firstorder.
Qed.

Lemma renamedApart_occurVars s an
  : renamedApart s an -> definedVars s [=] snd (getAnn an).
Proof.
  intros.
  general induction H; simpl; eauto;
  pe_rewrite; srewrite D'; eauto with cset.
  - set_simpl.
    eapply eq_union_lr; eauto.
    eapply list_union_eq; eauto with len.
    intros; inv_get. unfold defVarsZs.
    rewrite H1; eauto. unfold defVars. reflexivity.
Qed.

(* TODO(sigurd) find a home for this definition *)
Definition pminus (D'':set var) (s:set var * set var) :=
  match s with
    | pair s s' => (s \ D'', s')
  end.

Instance pminus_morphism
: Proper (Equal ==> (@pe _ _) ==> (@pe _ _) ) pminus.
Proof.
  unfold Proper, respectful; intros.
  inv H0; simpl; econstructor. rewrite H1, <- H. reflexivity.
  eauto.
Qed.

Instance mapAnn_pminus_morphism G'
  : Proper (ann_R (@pe _ _) ==> ann_R (@pe _ _)) (mapAnn (pminus G')).
Proof.
  unfold Proper, respectful; intros.
  general induction H; simpl; constructor; eauto with len pe.
  - intros; inv_get; eauto.
Qed.

Lemma renamedApart_minus D an an' s
  : disj (occurVars s) D
    -> renamedApart s an
    -> ann_R (@pe _ _) an' (mapAnn (pminus D) an)
    -> renamedApart s an'.
Proof.
  intros DISJ RN PE. revert an' PE.
  induction RN; indros; try rewrite PE; simpl in * |- *; set_simpl.
  - econstructor; eauto 20 with cset pe ann.
  - econstructor; eauto with cset pe ann.
  - econstructor; eauto with cset.
  - econstructor; eauto with cset.
  - econstructor; eauto with cset len.
    + intros ? ? ? GET1 GET2. inv_get. eapply H1; eauto.
      eapply disj_1_incl; eauto.
      rewrite <- get_list_union_map; eauto. cset_tac.
    + hnf; intros ? ? ? GET1 GET2; inv_get.
      edestruct H2; dcr; eauto.
      instantiate (1:=Dt).
      hnf. rewrite getAnn_mapAnn.
      destruct (getAnn x); simpl in *.
      assert (disj (of_list (fst a)) D).
      eapply disj_1_incl; eauto.
      rewrite <- get_list_union_map; eauto. cset_tac; intuition.
      split.
      * set_simpl.
        revert H6; unfold disj; clear_all; cset_tac; intuition; eauto.
      * eauto with cset.
    + eapply pairwise_disj_PIR2; eauto.
      eapply zip_ext_PIR2; eauto. rewrite map_length; eauto.
      intros ? ? ? ? ? GET1 GET2 GET3 GET4. inv_get.
      unfold defVars. rewrite getAnn_mapAnn. destruct (getAnn y); reflexivity.
    + eauto with cset pe ann.
    + rewrite list_union_eq.
      * reflexivity.
      * eauto with len.
      * intros ? ? ? GET1 GET2; inv_get.
        unfold defVars. rewrite getAnn_mapAnn.
        destruct (getAnn x0); simpl. reflexivity.
      * eauto.
Qed.

(** ** The two annotating sets are disjoint. *)

Lemma renamedApart_disj s G
: renamedApart s G
  -> disj (fst (getAnn G)) (snd (getAnn G)).
Proof.
  intros. general induction H; simpl; pe_rewrite; set_simpl.
  - eauto with cset.
  - eauto with cset.
  - eauto with cset.
  - eauto with cset.
  - eapply disj_app; split; eauto.
    + symmetry. rewrite <- list_union_disjunct.
      intros ? ? GET; inv_get.
      exploit H1; eauto.
      unfold defVars.
      edestruct H2; eauto; dcr.
      symmetry.
      eapply disj_app; split.
      symmetry; eauto.
      rewrite H8 in H7.
      eauto with cset.
Qed.

Lemma defVars_take_disj F ans n Zs a
:  pairwise_ne disj (zip defVars F ans)
   -> get F n Zs
   -> get ans n a
   -> disj (defVars Zs a) (list_union zip defVars (take n F) (take n ans)).
Proof.
  intros.
  symmetry. rewrite <- list_union_disjunct; intros; inv_get.
  eapply (H n0 n); eauto using zip_get. omega.
Qed.

Lemma defVars_drop_disj F ans n Zs a
:  pairwise_ne disj (zip defVars F ans)
   -> get F n Zs
   -> get ans n a
   -> disj (defVars Zs a) (list_union zip defVars (drop (S n) F) (drop (S n) ans)).
Proof.
  intros.
  symmetry. rewrite <- list_union_disjunct; intros; inv_get.
  eapply (H (S n + n0) n); eauto using zip_get. omega.
Qed.

Lemma defVars_disj_D F ans D Dt
      (Ddisj: disj D (list_union zip defVars F ans ∪ Dt))
: forall n  DD' Zs, get F n Zs -> get ans n DD' ->
               disj D (defVars Zs DD').
Proof.
  intros.
  eapply disj_2_incl; eauto.
  eapply incl_union_left. eapply incl_list_union; eauto using zip_get.
Qed.

Lemma disj_D_defVars F t ans D D' ant
  : renamedApart (stmtFun F t) (annF (D, D') ans ant)
    -> disj D (list_union zip defVars F ans).
Proof.
  intros.
  exploit renamedApart_disj; eauto; simpl in *.
  eapply disj_2_incl; eauto.
  invt renamedApart.
  rewrite <- H13; eauto with cset.
Qed.

Lemma disj_D_defVars_take F t ans n D D' ant
  : renamedApart (stmtFun F t) (annF (D, D') ans ant)
    -> disj D (list_union zip defVars (take n F) (take n ans)).
Proof.
  intros.
  rewrite <- take_zip, list_union_take_incl.
  eapply disj_D_defVars; eauto.
Qed.

Lemma disj_D_defVars_drop F t ans n D D' ant
  : renamedApart (stmtFun F t) (annF (D, D') ans ant)
    -> disj D (list_union zip defVars (drop n F) (drop n ans)).
Proof.
  intros.
  rewrite <- drop_zip, list_union_drop_incl.
  eapply disj_D_defVars; eauto.
Qed.

Hint Extern 5 =>
      match goal with
      | [ H : renamedApart ?s ?an, H' : pe (getAnn ?an) (?D, ?D') |- disj ?D' ?D ]
        => let H'' := fresh "tmp" in
          pose proof (renamedApart_disj H) as H''; rewrite H' in H''; simpl in H'';
            symmetry; eapply H''
      | [ H : renamedApart ?s ?an, H' : pe (getAnn ?an) (?D, ?D') |- disj ?D ?D' ]
        => let H'' := fresh "tmp" in
          pose proof (renamedApart_disj H) as H''; rewrite H' in H''; simpl in H'';
            eapply H''
      end : cset.

Lemma lv_incl_fst_ra D Dt F ans n a Zs als alv lv
  : Indexwise.indexwise_R (funConstr D Dt) F ans
    -> ( forall (n : nat) (Zs : params * stmt) (a : ann ⦃var⦄),
          get F n Zs ->
          get als n a ->
          of_list (fst Zs) ⊆ getAnn a /\ getAnn a \ of_list (fst Zs) ⊆ lv)
    -> get ans n a
    -> get F n Zs
    -> get als n alv
    -> lv ⊆ D
    -> getAnn alv ⊆ fst (getAnn a).
Proof.
  intros IDW ZlvIncl Get1 Get2 Get3 incl. edestruct IDW; eauto; dcr.
  rewrite H.
  exploit ZlvIncl; eauto; dcr. rewrite <- incl, <- H5.
  clear; cset_tac; intuition.
Qed.

Lemma disj_lv_take lv n F ans als (Zs:params*stmt) alv t D D' ant a
  : PairwiseDisjoint.pairwise_ne disj (defVars ⊜ F ans)
    -> get als n alv
    -> get F n Zs
    -> get ans n a
    -> (forall (n : nat) (Zs : params * stmt) (a : ann ⦃var⦄),
          get F n Zs ->
          get als n a ->
          of_list (fst Zs) ⊆ getAnn a /\ getAnn a \ of_list (fst Zs) ⊆ lv)
    -> lv ⊆ D
    -> renamedApart (stmtFun F t) (annF (D, D') ans ant)
    -> disj (getAnn alv) (list_union (defVars ⊜ (take n F) (take n ans))).
Proof.
  intros. exploit H3; eauto; dcr.
  assert (EQ:getAnn alv \ of_list (fst Zs) ∪ of_list (fst Zs)
                    [=] getAnn alv) by cset_tac.
  rewrite <- EQ. symmetry. rewrite disj_app. split; symmetry.
  - eapply disj_1_incl.
    eapply disj_D_defVars_take; eauto using renamedApart.
    eauto with cset.
  - eapply disj_1_incl.
    eapply defVars_take_disj; eauto. unfold defVars.
    eauto with cset.
Qed.

Lemma disj_fst_snd_ra F t D D' ans ant n Zs a
  : renamedApart (stmtFun F t) (annF (D, D') ans ant)
    -> get F n Zs
    -> get ans n a
    -> disj (fst (getAnn a) ∪ snd (getAnn a))
           (list_union (defVars ⊜ (drop (S n) F) (drop (S n) ans))).
Proof.
  intros RA Get1 Get2. invt renamedApart.
  edestruct H7; eauto; dcr. rewrite H.
  rewrite union_comm. rewrite <- union_assoc.
  symmetry; rewrite disj_app; split; symmetry.
  - eapply disj_1_incl. eapply defVars_drop_disj; eauto.
    unfold defVars. clear; cset_tac.
  - eapply disj_D_defVars_drop; eauto.
Qed.

Lemma disj_fst_snd_Dt D Dt F ans t ant a n Zs
  : Indexwise.indexwise_R (funConstr D Dt) F ans
    -> renamedApart t ant
    -> pe (getAnn ant) (D, Dt)
    -> get F n Zs
    -> get ans n a
    -> disj (fst (getAnn a) ∪ snd (getAnn a)) Dt.
Proof.
  intros IDW RA PE Get1 Get2.
  edestruct IDW; eauto; dcr. rewrite H.
  rewrite union_comm. rewrite <- union_assoc.
  symmetry; rewrite disj_app; split;
    symmetry.
  - rewrite union_comm; eauto.
  - eauto with cset.
Qed.

Lemma renamedApart_annotation s ang
: renamedApart s ang
  -> annotation s ang.
Proof.
  intros. general induction H; eauto 20 using @annotation.
Qed.

Lemma ra_incl1 X `{OrderedType X} (D Ds VD:set X) x
  : D ∪ {x; Ds} [<=] VD
    -> {x; D} ∪ Ds [<=] VD.
Proof.
  cset_tac.
Qed.

Lemma ra_incl2 X `{OrderedType X} (D Ds Dt VD:set X)
  : D ∪ (Ds ∪ Dt) [<=] VD
    -> D ∪ Ds [<=] VD.
  cset_tac.
Qed.

Lemma ra_incl3 X `{OrderedType X} (D Ds Dt VD:set X)
  : D ∪ (Ds ∪ Dt) [<=] VD
    -> D ∪ Dt [<=] VD.
  cset_tac.
Qed.

Hint Resolve ra_incl1 ra_incl2 ra_incl3 | 60 : cset.

Lemma ra_incl4 X `{OrderedType X} (D Ds VD:set X) x
  :  {x; D} ∪ Ds [<=] D ∪ {x; Ds}.
Proof.
  cset_tac.
Qed.

Lemma ra_incl5 X `{OrderedType X} (D Ds VD:set X) x
  :  {x; D} ∪ Ds [<=] D ∪ {x; Ds}.
Proof.
  cset_tac.
Qed.

Lemma ra_incl6 X `{OrderedType X} (D Ds Dt VD:set X)
  : D ∪ Ds [<=] D ∪ (Ds ∪ Dt).
  cset_tac.
Qed.

Lemma ra_incl7 X `{OrderedType X} (D Ds Dt VD:set X)
  : D ∪ Dt [<=] D ∪ (Ds ∪ Dt).
  cset_tac.
Qed.

Hint Resolve ra_incl4 ra_incl5 ra_incl6 ra_incl7 : cset.

Lemma ans_incl_D_union D Dt F ans a n
      (IFC:Indexwise.indexwise_R (funConstr D Dt) F ans)
      (GetAns:get ans n a)
      (Len:❬F❭ = ❬ans❭)
  : fst (getAnn a) ∪ snd (getAnn a) [<=] D ∪ (list_union (defVars ⊜ F ans) ∪ Dt).
Proof.
  inv_get. edestruct IFC; eauto; dcr.
  rewrite H0. rewrite <- incl_list_union; eauto using zip_get;[|reflexivity].
  unfold defVars. clear; cset_tac.
Qed.

Hint Resolve ans_incl_D_union | 0 : cset .

Lemma list_union_defVars_decomp F ans (Len:❬F❭ = ❬ans❭)
  : list_union (defVars ⊜ F ans) [=]
               list_union (of_list ⊝ fst ⊝ F) ∪ list_union (snd ⊝ getAnn ⊝ ans).
Proof.
  general induction Len; simpl; eauto.
  - cset_tac.
  - norm_lunion. rewrite IHLen.
    unfold defVars at 1.
    clear_all; cset_tac.
Qed.

Lemma funConstr_disj_Dt D Dt F ans (Len:❬F❭=❬ans❭)
  : Indexwise.indexwise_R (funConstr D Dt) F ans
    -> disj (list_union (of_list ⊝ fst ⊝ F)) Dt.
Proof.
  hnf; intros IW.
  hnf; intros x IN1 IN2.
  eapply list_union_get in IN1.
  destruct IN1; dcr; inv_get.
  edestruct IW; eauto; dcr.
  cset_tac.
Qed.

Lemma funConstr_disj_ZL_getAnn ZL (D Dt : ⦃var⦄)  (F : 〔params * stmt〕)
      (ans : 〔ann (⦃var⦄ * ⦃var⦄)〕)
  : Indexwise.indexwise_R (funConstr D Dt) F ans
    -> PairwiseDisjoint.pairwise_ne disj (defVars ⊜ F ans)
    -> disj (list_union (of_list ⊝ ZL)) (list_union (defVars ⊜ F ans) ∪ Dt)
    -> (forall (n : nat) (Zs : params * stmt) (a : ann (⦃var⦄ * ⦃var⦄)),
          get F n Zs -> get ans n a -> renamedApart (snd Zs) a)
    -> ❬F❭ = ❬ans❭
    -> disj (list_union (of_list ⊝ (fst ⊝ F ++ ZL))) (list_union (snd ⊝ getAnn ⊝ ans)).
Proof.
  intros. rewrite List.map_app, list_union_app.
  rewrite list_union_defVars_decomp in *; eauto.
  eapply disj_union_left; symmetry.
  - hnf; intros.
    eapply list_union_get in H4. destruct H4; dcr; [|cset_tac].
    eapply list_union_get in H5. destruct H5; dcr; [|cset_tac].
    decide (x0=x2).
    + subst. inv_get. edestruct H; eauto; dcr.
      exploit H2; eauto. eapply renamedApart_disj in H9.
      rewrite H8 in *. eapply H9; eauto. cset_tac.
    + inv_get. exploit H0; eauto using zip_get.
      eapply (H10 x); unfold defVars. cset_tac. cset_tac.
  - eapply disj_2_incl; eauto. cset_tac.
Qed.

Lemma funConstr_disj_Dt' ZL (D Dt : ⦃var⦄)  (F : 〔params * stmt〕)
      (ans : 〔ann (⦃var⦄ * ⦃var⦄)〕)
  : Indexwise.indexwise_R (funConstr D Dt) F ans
    -> disj (list_union (of_list ⊝ ZL)) (list_union (defVars ⊜ F ans) ∪ Dt)
    -> ❬F❭ = ❬ans❭
    -> disj Dt (list_union (of_list ⊝ (fst ⊝ F ++ ZL))).
Proof.
  intros. rewrite List.map_app, list_union_app.
  eapply disj_union_right; symmetry.
  - eauto using funConstr_disj_Dt.
  - eapply disj_2_incl; eauto.
Qed.

Lemma disj_Dt_getAnn (D Dt : ⦃var⦄) (F : 〔params * stmt〕) (ans : 〔ann (⦃var⦄ * ⦃var⦄)〕)
  : Indexwise.indexwise_R (funConstr D Dt) F ans
    -> ❬F❭ = ❬ans❭
    -> disj Dt (list_union (snd ⊝ getAnn ⊝ ans)).
Proof.
  intros. hnf; intros.
  eapply list_union_get in H2.
  destruct H2. dcr; inv_get.
  - edestruct H; eauto; dcr.
    eapply H10; eauto. cset_tac.
  - cset_tac.
Qed.

Lemma renamedApart_incl
      (s : stmt)
      (ra : ann (⦃var⦄ * ⦃var⦄))
  :
    renamedApart s ra
    -> match ra with
      | ann1 (D, D') an
        => fst (getAnn an) ∪ snd (getAnn an) ⊆ D ∪ D'
      | ann2 (D, D') ans ant
        => fst (getAnn ans) ∪ snd (getAnn ans) ⊆ D ∪ D'
          /\ fst (getAnn ant) ∪ snd (getAnn ant) ⊆ D ∪ D'
      | annF (D, D') anF ant
        => (forall (ans : ann (⦃var⦄ * ⦃var⦄)) n,
              get anF n ans
              -> fst (getAnn ans) ∪ snd (getAnn ans) ⊆ D ∪ D')
          /\ fst (getAnn ant) ∪ snd (getAnn ant) ⊆ D ∪ D'
      | _ => True
      end
.
Proof.
  intros.
  invc H; simpl; eauto; set_simpl; pe_rewrite; repeat split;
    intros; inv_get; eauto with cset.
Qed.

Lemma get_ofl_VD ZL F VD
      (Z_VD : forall (Z : params) (n : nat), get ZL n Z -> of_list Z ⊆ VD)
      D D' Dt ans
      (LEN : ❬F❭ = ❬ans❭)
      (EQ : list_union (defVars ⊜ F ans) ∪ Dt [=] D')
      (ra_VD : D ∪ D' ⊆ VD)
  : forall (Z : params) (n : nat), get (fst ⊝ F ++ ZL) n Z -> of_list Z ⊆ VD.
Proof.
  intros.
  eapply get_app_cases in H as [?|[? ?]]; inv_get; eauto.
  rewrite <- ra_VD. rewrite <- EQ.
  rewrite <- incl_list_union; eauto using zip_get; try reflexivity.
  unfold defVars. cset_tac.
Qed.


From Undecidability.L.Tactics Require Import LTactics GenEncode.
From Undecidability.L.Datatypes Require Import LNat Lists LProd LFinType LVector.
From Undecidability.L Require Import Functions.EqBool.

From Undecidability.TM.Util Require Import VectorPrelim TM_facts.

Require Import Undecidability.Shared.Libs.PSL.FiniteTypes.FinTypes.
From Undecidability.TM Require PrettyBounds.SizeBounds.

Import L_Notations.

(* ** Extraction of Turing Machine interpreter  *)

Import GenEncode.
MetaCoq Run (tmGenEncode "move_enc" move).
#[export] Hint Resolve move_enc_correct : Lrewrite.

Import TM.
Local Notation L := TM.Lmove.
Local Notation R := TM.Rmove.
Local Notation N := TM.Nmove.

Definition move_eqb (m n : move) : bool :=
  match m,n with
    N,N => true
  | L,L => true
  | R,R => true
  | _,_ => false
  end.

Lemma move_eqb_spec x y : reflect (x = y) (move_eqb x y).
Proof.
  destruct x, y;constructor. all:easy.
Qed.

#[global]
Instance eqb_move:
  eqbClass move_eqb.
Proof.
  intros ? ?. eapply move_eqb_spec.
Qed.

#[global]
Instance eqbComp_bool : eqbCompT move.
Proof.
  evar (c:nat). exists c. unfold move_eqb.
  unfold enc;cbn.
  extract.
  solverec.
  [c]:exact 3.
  all:unfold c;try lia.
Qed.

(*
Definition move_decode (s : term) : option (move) :=
  match s with
  | lam (lam (lam n)) =>
    match n with
      2 => Some TM.L
    | 1 => Some TM.R
    | 0 => Some TM.N
    | _ => None
    end
  | _ => None
  end.

Instance decode_move: decodable move.
Proof.
  exists move_decode.
  all:unfold enc at 1. all:cbn.
  -destruct x;reflexivity.
  -destruct t eqn:eq. all:cbn.
   all:repeat let eq := fresh in destruct _ eqn:eq. all:try congruence.
   all:intros ? [= <-]. all:reflexivity.
Defined. (* because instance *) *)

(* *** Encoding Tapes *)
Section reg_tapes.
  Variable sig : Type.
  Context `{reg_sig : registered sig}.

  Implicit Type (t : TM.tape sig).
  Import GenEncode.
  MetaCoq Run (tmGenEncode "tape_enc" (TM.tape sig)).
  Hint Resolve tape_enc_correct : Lrewrite.

  (*Internalize constructors **)

  Global Instance term_leftof : computableTime' (@leftof sig) (fun _ _ => (1, fun _ _ => (1,tt))).
  Proof.
    extract constructor.
    solverec.
  Qed.

  Global Instance term_rightof : computableTime' (@rightof sig) (fun _ _ => (1, fun _ _ => (1,tt))).
  Proof.
    extract constructor. solverec.
  Qed.

  Global Instance term_midtape : computableTime' (@midtape sig) (fun _ _ => (1, fun _ _ => (1,fun _ _ => (1,tt)))).
  Proof.
    extract constructor. solverec.
  Qed.

End reg_tapes.

Section fix_sig.
  Variable sig : finType.
  Context `{reg_sig : registered sig}.

  Definition mconfigAsPair {B : finType} {n} (c:mconfig sig B n):= let (x,y) := c in (x,y).

  Global Instance registered_mconfig (B : finType) `{registered B} n: registered (mconfig sig B n).
  Proof using reg_sig.
    eapply (registerAs mconfigAsPair). clear.
    register_inj.
  Defined. (* because registerAs *)

  Global Instance term_mconfigAsPair (B : finType) `{registered B} n: computableTime' (@mconfigAsPair B n) (fun _ _ => (1,tt)).
  Proof.
    apply cast_computableTime.
  Qed.

  Global Instance term_cstate (B : finType) `{registered B} n: computableTime' (@cstate sig B n) (fun _ _ => (7,tt)).
  Proof.
    apply computableTimeExt with (x:=fun x => fst (mconfigAsPair x)).
    2:{extract. solverec. }
    intros [];reflexivity.
  Qed.

  Global Instance term_ctapes (B : finType) `{registered B} n: computableTime' (@ctapes sig B n) (fun _ _ => (7,tt)).
  Proof.
    apply computableTimeExt with (x:=fun x => snd (mconfigAsPair x)).
    2:{extract. solverec. }
    intros [];reflexivity.
  Qed.

  Global Instance registered_mk_mconfig (B : finType) `{registered B} n: computableTime' (@mk_mconfig sig B n) (fun _ _ => (1,fun _ _ => (3,tt))).
  Proof.
    computable_casted_result.
    extract. solverec.
  Qed.
End fix_sig.

#[export] Hint Resolve tape_enc_correct : Lrewrite.

Import PrettyBounds.SizeBounds.

Lemma sizeOfTape_by_size {sig} `{registered sig} (t:(tape sig)) :
  sizeOfTape t <= size (enc t).
Proof.
  change (enc (X:=tape sig)) with (tape_enc (sig:=sig)). unfold tape_enc,sizeOfTape.
  change (match H with
          | @mk_registered _ enc _ _ => enc
          end) with (enc (registered:=H)). change (list_enc (X:=sig)) with (enc (X:=list sig)).
  destruct t. all:cbn [tapeToList length tape_enc size].
  all:rewrite ?app_length,?rev_length. all:cbn [length].
  all:ring_simplify. all:try rewrite !size_list_enc_r. all:try nia.
Qed.

Lemma sizeOfmTapes_by_size {sig} `{registered sig} n (t:tapes sig n) :
  sizeOfmTapes t <= size (enc t).
Proof.
  setoid_rewrite enc_vector_eq. rewrite Lists.size_list.
  erewrite <- sumn_map_le_pointwise with (f1:=fun _ => _). 2:{ intros. setoid_rewrite <- sizeOfTape_by_size. reflexivity. }
  rewrite sizeOfmTapes_max_list_map. unfold MaxList.max_list_map. rewrite max_list_sumn.
  etransitivity. 2:now apply Nat.le_add_r. rewrite vector_to_list_correct. apply sumn_map_le_pointwise. intros. nia.
Qed.