Require Import FunctionalExtensionality.
Require Export SpecializedCategory Functor FunctorCategory Hom FunctorAttributes.
Require Import Common ProductCategory SetCategory.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Local Open Scope category_scope.

Local Ltac apply_commutes_by_transitivity_and_solve_with tac :=
  repeat (apply functional_extensionality_dep; intro);
    match goal with
      | [ a : _, f : _ |- _ ] => let H := fresh in
        assert (H := fg_equal (Commutes a _ _ f)); simpl in H;
          let fin_tac := (solve [ etransitivity; try apply H; clear H; tac ]) in
            fin_tac || symmetry in H; fin_tac
    end.

Section Yoneda.
  Context `(C : @SpecializedCategory objC).
  Let COp := OppositeCategory C.

  Section Yoneda.
    Let Yoneda_NT s d (f : COp.(Morphism) s d) : SpecializedNaturalTransformation (CovariantHomFunctor C s) (CovariantHomFunctor C d).
      refine (Build_SpecializedNaturalTransformation
                (CovariantHomFunctor C s)
                (CovariantHomFunctor C d)
                (fun c : C => (fun m : C.(Morphism) _ _ => Compose m f))
                _
             );
      abstract (intros; simpl; apply functional_extensionality_dep; intros; auto with morphism).
    Defined.

    Definition Yoneda : SpecializedFunctor COp (TypeCat ^ C).
      match goal with
        | [ |- SpecializedFunctor ?C0 ?D0 ] =>
          refine (Build_SpecializedFunctor C0 D0
            (fun c : COp => CovariantHomFunctor C c : TypeCat ^ C)
            (fun s d (f : COp.(Morphism) s d) => Yoneda_NT s d f)
            _
            _
          )
      end;
      abstract (simpl; nt_eq; auto with morphism).
    Defined.
  End Yoneda.

  Section CoYoneda.
    Let CoYoneda_NT s d (f : C.(Morphism) s d) : SpecializedNaturalTransformation (ContravariantHomFunctor C s) (ContravariantHomFunctor C d).
      refine (Build_SpecializedNaturalTransformation
                (ContravariantHomFunctor C s)
                (ContravariantHomFunctor C d)
                (fun c : C => (fun m : COp.(Morphism) _ _ => Compose m f))
                _
             );
      abstract (intros; simpl; apply functional_extensionality_dep; intros; auto with morphism).
    Defined.

    Definition CoYoneda : SpecializedFunctor C (TypeCat ^ COp).
      match goal with
        | [ |- SpecializedFunctor ?C0 ?D0 ] =>
          refine (Build_SpecializedFunctor C0 D0
            (fun c : C => ContravariantHomFunctor C c : TypeCat ^ COp)
            (fun s d (f : C.(Morphism) s d) => CoYoneda_NT s d f)
            _
            _
          )
      end;
      abstract (simpl; nt_eq; auto with morphism).
    Defined.
  End CoYoneda.
End Yoneda.

Section YonedaLemma.
  Context `(C : @SpecializedCategory objC).
  Let COp := OppositeCategory C : SpecializedCategory _.

  (* Note: If we use [Yoneda _ c] instead, we get Universe Inconsistencies.  Hmm... *)
  Definition YonedaLemmaMorphism (c : C) (X : TypeCat ^ C) : Morphism TypeCat (Morphism (TypeCat ^ C) (Yoneda C c) X) (X c).
    simpl; intro a.
    exact (a c (Identity _)).
  Defined.

  Definition YonedaLemmaMorphismInverse (c : C) (X : TypeCat ^ C) : Morphism TypeCat (X c) (Morphism (TypeCat ^ C) (Yoneda C c) X).
    simpl; intro Xc.
    hnf.
    match goal with
      | [ |- SpecializedNaturalTransformation ?F ?G ] =>
        refine (Build_SpecializedNaturalTransformation F G
          (fun c' : C => (fun f : Morphism _ c c' => X.(MorphismOf) f Xc))
          _
        )
    end;
    abstract (
      intros; simpl; apply functional_extensionality_dep; intros; eauto;
        pose (FCompositionOf X);
          simpl in *;
            fg_equal;
            t_with t'
    ).
  Defined.

  Lemma YonedaLemma (c : C) (X : TypeCat ^ C) : IsIsomorphism (@YonedaLemmaMorphism c X).
    exists (@YonedaLemmaMorphismInverse c X).
    unfold YonedaLemmaMorphismInverse, YonedaLemmaMorphism.
    pose (FIdentityOf X).
    pose (FCompositionOf X).
    split; simpl; nt_eq;
    simpl in *; autorewrite with functor; simpl; trivial;
    apply_commutes_by_transitivity_and_solve_with ltac:(rewrite_hyp; autorewrite with morphism; trivial).
  Qed.
End YonedaLemma.

Section CoYonedaLemma.
  Context `(C : @SpecializedCategory objC).
  Let COp := OppositeCategory C.

  Definition CoYonedaLemmaMorphism (c : C) (X : TypeCat ^ COp)
  : Morphism TypeCat (Morphism (TypeCat ^ COp) (CoYoneda C c) X) (X c).
    simpl; intro a.
    exact (a c (Identity _)).
  Defined.

  Definition CoYonedaLemmaMorphismInverse (c : C) (X : TypeCat ^ COp)
  : Morphism TypeCat (X c) (Morphism (TypeCat ^ COp) (CoYoneda C c) X).
    simpl; intro Xc.
    hnf.
    match goal with
      | [ |- SpecializedNaturalTransformation ?F ?G ] =>
        refine (Build_SpecializedNaturalTransformation F G
          (fun c' : COp => (fun f : COp.(Morphism) c c' => X.(MorphismOf) f Xc))
          _
        )
    end;
    abstract (
      intros; simpl; apply functional_extensionality_dep; intros; eauto;
        pose (FCompositionOf X);
          simpl in *;
            fg_equal;
            t_with t'
    ).
  Defined.

  Lemma CoYonedaLemma (c : C) (X : TypeCat ^ COp) : IsIsomorphism (@CoYonedaLemmaMorphism c X).
    exists (@CoYonedaLemmaMorphismInverse c X).
    split; simpl; nt_eq; clear;
    [ | pose (FIdentityOf X); fg_equal; trivial ];
    pose (FCompositionOf X);
    unfold CoYonedaLemmaMorphism, CoYonedaLemmaMorphismInverse;
    simpl;
    apply_commutes_by_transitivity_and_solve_with ltac:(rewrite_hyp; autorewrite with morphism; trivial).
  Qed.
End CoYonedaLemma.

Section FullyFaithful.
  Context `(C : @SpecializedCategory objC).

  Definition YonedaEmbedding : FunctorFullyFaithful (Yoneda C).
    unfold FunctorFullyFaithful.
    intros c c'.
    destruct (@YonedaLemma _ C c (CovariantHomFunctor C c')) as [ m i ].
    exists (YonedaLemmaMorphism (X := CovariantHomFunctor C c')).
    t_with t'; nt_eq; autorewrite with morphism; trivial.
    apply_commutes_by_transitivity_and_solve_with ltac:(rewrite_hyp; autorewrite with morphism; trivial).
  Qed.

  Definition CoYonedaEmbedding : FunctorFullyFaithful (CoYoneda C).
    unfold FunctorFullyFaithful.
    intros c c'.
    destruct (@CoYonedaLemma _ C c (ContravariantHomFunctor C c')) as [ m i ].
    exists (CoYonedaLemmaMorphism (X := ContravariantHomFunctor C c')).
    t_with t'; nt_eq; autorewrite with morphism; trivial.
    unfold CoYonedaLemmaMorphism, CoYonedaLemmaMorphismInverse;
      simpl;
      apply_commutes_by_transitivity_and_solve_with ltac:(rewrite_hyp; autorewrite with morphism; trivial).
  Qed.
End FullyFaithful.


Require Import List.

Require Import Utils.
Require Import Substitutions.

Require Import Le Lt.
Require Import Plus Minus.
Require Import Compare_dec.

Module Type TYPES.

Declare Module Import TermBump : TERMBUMP.

Parameter type : Type.

Parameter tyDf : type.
Parameter tyBump : forall (n l:nat) (T:type),type.
Parameter tySubst : forall (l:nat) (b:term) (T:type),type.

Axiom tyBump_Bump : forall n1 n2 T l1 l2,(l1 <= l2)->
(tyBump n2 (n1 + l2) (tyBump n1 l1 T) = tyBump n1 l1 (tyBump n2 l2 T)).

Axiom tyBumpDiv : forall a b n T,(n <= b)->forall l,tyBump a (l + n) (tyBump b l T) = tyBump (a + b) l T.

Axiom tySubst_Bump : forall n b T l1 l2,(l1 <= l2)->
(tySubst (n + l2) b (tyBump n l1 T) = tyBump n l1 (tySubst l2 b T)).

Axiom tySubstDiv : forall n b T l1 l2,(l1 <= l2 <= l1 + n)->(tySubst l2 b (tyBump (S n) l1 T) = tyBump n l1 T).

End TYPES.

Module VarOKBump (Import Types : TYPES).

Import VarBump.
Import TermBump.

Fixpoint ctxBump n G := match G with
	nil => nil |
	T :: G => tyBump n (length G) T :: ctxBump n G
end.

Fixpoint ctxSubst b G := match G with
	nil => nil |
	T :: G => tySubst (length G) b T :: ctxSubst b G
end.

Lemma ctxBump_length n G : length (ctxBump n G) = length G.
	induction G;simpl.

	reflexivity.

	rewrite IHG.
	reflexivity.
Qed.

Lemma ctxBump_nth i n : forall G,(i < length G)->(nth i (ctxBump n G) tyDf = tyBump n (length G - S i) (nth i G tyDf)).
	induction i;intro;(destruct G as [| T];intro;[destruct lt_n_O with (1 := H) |]);simpl.

	rewrite <- minus_n_O.
	reflexivity.

	apply IHi.
	apply lt_S_n with (1 := H).
Qed.

Lemma ctxSubst_length b G : length (ctxSubst b G) = length G.
	induction G;simpl.

	reflexivity.

	rewrite IHG.
	reflexivity.
Qed.

Lemma ctxSubst_nth i b : forall G,(i < length G)->(nth i (ctxSubst b G) tyDf = tySubst (length G - S i) b (nth i G tyDf)).
	induction i;intro;(destruct G as [| T];intro;[destruct lt_n_O with (1 := H) |]);simpl.

	rewrite <- minus_n_O.
	reflexivity.

	apply IHi.
	apply lt_S_n with (1 := H).
Qed.

Inductive VarOK G i : type->Set := mkVarOK : (i < length G)->VarOK G i (tyBump (S i) O (nth i G tyDf)).

Lemma varOKBump GL X GR i T : VarOK (GR ++ GL) i T->
VarOK (ctxBump (length X) GR ++ X ++ GL) (varBump (length X) (length GR) i) (tyBump (length X) (length GR) T).
	intro.
	destruct H.
	destruct (le_lt_dec (length GR) i).

	rewrite varBumpHi with (1 := le_not_lt _ _ l0).
	assert (let i' := length X + i in
	tyBump (length X) (length GR) (tyBump (S i) O (nth i (GR ++ GL) tyDf)) =
	tyBump (S i') O (nth i' (ctxBump (length X) GR ++ X ++ GL) tyDf)).
		simpl.
		rewrite app_nth2 with (1 := l0).
		rewrite app_nth2;rewrite ctxBump_length;[| apply le_trans with (1 := l0);apply le_plus_r].
		rewrite <- le_plus_minus_assoc with (1 := l0).
		rewrite app_nth2 with (1 := le_plus_l _ _).
		rewrite minus_plus.
		change (length GR) at 1 with (O + length GR).
		rewrite tyBumpDiv with (1 := le_S _ _ l0).
		rewrite plus_n_Sm.
		reflexivity.
	simpl in H.
	rewrite H.
	apply mkVarOK.
	rewrite app_length.
	rewrite ctxBump_length.
	rewrite app_length.
	rewrite plus_assoc.
	rewrite <- (plus_comm (length X)).
	rewrite <- plus_assoc.
	apply plus_lt_compat_l.
	rewrite <- app_length.
	exact l.

	rewrite varBumpLo with (1 := l0).
	assert (tyBump (length X) (length GR) (tyBump (S i) O (nth i (GR ++ GL) tyDf)) =
	tyBump (S i) O (nth i (ctxBump (length X) GR ++ X ++ GL) tyDf)).
		rewrite app_nth1 with (1 := l0).
		rewrite app_nth1;[| rewrite ctxBump_length;exact l0].
		rewrite ctxBump_nth with (1 := l0).
		rewrite <- tyBump_Bump with (1 := le_O_n _).
		rewrite <- le_plus_minus with (1 := l0).
		reflexivity.
	rewrite H.
	apply mkVarOK.
	rewrite app_length.
	rewrite ctxBump_length.
	apply le_plus_trans with (1 := l0).
Qed.

End VarOKBump.

Module Type TYPINGBUMP.

Declare Module Import Types : TYPES.
Import TermBump.

Module VarSubst := VarSubst TermBump.
Module Import VarOKBump := VarOKBump Types.

Parameter TermOK : forall (G:list type) (t:term) (T:type),Type.
Parameter TypeOK : forall (G:list type) (T:type),Type.

Axiom tmOKVar : forall G i T,VarOK G i T->TermOK G (tmVar i) T.

Axiom tmOKBump : forall GL X GR t T,TermOK (GR ++ GL) t T->
TermOK (ctxBump (length X) GR ++ X ++ GL) (tmBump (length X) (length GR) t) (tyBump (length X) (length GR) T).

End TYPINGBUMP.

Module VarOKSubst (Import TypingBump : TYPINGBUMP).

Import Types VarSubst VarOKBump.
Import TermBump.

Inductive CtxOK : list type->Type :=
	ctxOKNil : CtxOK nil |
	ctxOKCons G T : CtxOK G->TypeOK G T->CtxOK (T :: G).

Lemma ctxProjOK i : forall G,CtxOK G->(i < length G)->TypeOK (skipn (S i) G) (nth i G tyDf).
	induction i;intros;(destruct X;[destruct lt_n_O with (1 := H) |]).

	exact t.

	exact (IHi _ X (le_S_n _ _ H)).
Qed.

Lemma varOKSubst GL b B GR i T : TermOK GL b B->VarOK (GR ++ B :: GL) i T->
TermOK (ctxSubst b GR ++ GL) (varSubst (length GR) b i) (tySubst (length GR) b T).
	intros Hb Hi.
	destruct Hi.
	destruct (lt_eq_lt_dec i (length GR));[clear l;destruct s |].

	rewrite varSubstLt with (1 := l).
	assert (tySubst (length GR) b (tyBump (S i) O (nth i (GR ++ B :: GL) tyDf)) =
	tyBump (S i) O (nth i (ctxSubst b GR ++ GL) tyDf)).
		rewrite app_nth1 with (1 := l).
		rewrite app_nth1;[| rewrite ctxSubst_length;exact l].
		rewrite ctxSubst_nth with (1 := l).
		rewrite <- tySubst_Bump with (1 := le_O_n _).
		rewrite <- le_plus_minus with (1 := l).
		reflexivity.
	rewrite H.
	apply tmOKVar.
	apply mkVarOK.
	rewrite app_length.
	rewrite ctxSubst_length.
	apply le_plus_trans with (1 := l).

	rewrite varSubstEq with (1 := e).
	subst i.
	rewrite app_nth2 with (1 := le_n _).
	rewrite minus_diag.
	simpl.
	rewrite tySubstDiv with (1 := conj (le_O_n _) (le_n (length GR))).
	change (ctxSubst b GR ++ GL) with (ctxBump (length GR) nil ++ ctxSubst b GR ++ GL).
	rewrite <- (ctxSubst_length b GR).
	apply tmOKBump with (1 := Hb).

	rewrite varSubstGt with (1 := l0).
	revert l.
	destruct i.
		destruct lt_n_O with (1 := l0).
	rewrite app_length.
	simpl.
	rewrite <- plus_n_Sm.
	intro.
	rewrite app_nth2 with (1 := lt_le_weak _ _ l0).
	assert (Hlo := le_S_n _ _ l0).
	assert (Hhi := lt_S_n _ _ l).
	clear l0 l.
	rewrite <- minus_Sn_m with (1 := Hlo).
	simpl.
	rewrite tySubstDiv with (1 := conj (le_O_n _) (le_S _ _ Hlo)).
	assert (nth (i - length GR) GL tyDf =
	nth i (ctxSubst b GR ++ GL) tyDf).
		rewrite app_nth2;rewrite ctxSubst_length;[| exact Hlo].
		reflexivity.
	rewrite H.
	apply tmOKVar.
	apply mkVarOK.
	rewrite app_length.
	rewrite ctxSubst_length.
	exact Hhi.
Qed.

End VarOKSubst.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(* Certified Haskell Prelude.
 * Author: Matthieu Sozeau
 * Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud
 *              91405 Orsay, France *)

Require Import Coq.Program.Program.

Set Implicit Arguments.
Unset Strict Implicit.

Require Import Coq.Classes.SetoidTactics.

Goal not True == not (not False) -> ((not True -> True)) \/ True.
  intros.
  clrewrite H.
  clrewrite <- H.
  right ; auto.
Defined.

Definition reduced_thm := Eval compute in Unnamed_thm.

(* Print reduced_thm. *)

Lemma foo [ Setoid a R ] : True. (* forall x y, R x y -> x -> y. *)
Proof.
  intros.
  Print respect2.
  pose setoid_morphism.
  pose (respect2 (b0:=b)).
  simpl in b0.
  unfold binary_respectful in b0.
  pose (arrow_morphism R).
  pose (respect2 (b0:=b1)).
  unfold binary_respectful in b2.

  pose (eq_morphism (A:=a)).
  pose (respect2 (b0:=b3)).
  unfold binary_respectful in b4.
  exact I.
Qed.

Goal forall A B C (H : A <-> B) (H' : B <-> C), A /\ B <-> B /\ C.
  intros.
  Set Printing All.
  Print iff_morphism.
  clrewrite H.
  clrewrite H'.
  reflexivity.
Defined.

Goal forall A B C (H : A <-> B) (H' : B <-> C), A /\ B <-> B /\ C.
  intros.
  rewrite H.
  rewrite H'.
  reflexivity.
Defined.

Require Import Setoid_tac.
Require Import Setoid_Prop.

(* Print Unnamed_thm0. *)
(* Print Unnamed_thm1. *)


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2011-2018 Sylvie Boldo
#<br />#
Copyright (C) 2011-2018 Guillaume Melquiond

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

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

Require Import ZArith Zquot.
Require Import Zaux.

(** Number of bits (radix 2) of a positive integer.

It serves as an upper bound on the number of digits to ensure termination.
*)

Fixpoint digits2_Pnat (n : positive) : nat :=
  match n with
  | xH => O
  | xO p => S (digits2_Pnat p)
  | xI p => S (digits2_Pnat p)
  end.

Theorem digits2_Pnat_correct :
  forall n,
  let d := digits2_Pnat n in
  (Zpower_nat 2 d <= Zpos n < Zpower_nat 2 (S d))%Z.
Proof.
intros n d. unfold d. clear.
assert (Hp: forall m, (Zpower_nat 2 (S m) = 2 * Zpower_nat 2 m)%Z) by easy.
induction n ; simpl digits2_Pnat.
rewrite Zpos_xI, 2!Hp.
omega.
rewrite (Zpos_xO n), 2!Hp.
omega.
now split.
Qed.

Section Fcore_digits.

Variable beta : radix.

Definition Zdigit n k := Z.rem (Z.quot n (Zpower beta k)) beta.

Theorem Zdigit_lt :
  forall n k,
  (k < 0)%Z ->
  Zdigit n k = Z0.
Proof.
intros n [|k|k] Hk ; try easy.
now case n.
Qed.

Theorem Zdigit_0 :
  forall k, Zdigit 0 k = Z0.
Proof.
intros k.
unfold Zdigit.
rewrite Zquot_0_l.
apply Zrem_0_l.
Qed.

Theorem Zdigit_opp :
  forall n k,
  Zdigit (-n) k = Z.opp (Zdigit n k).
Proof.
intros n k.
unfold Zdigit.
rewrite Zquot_opp_l.
apply Zrem_opp_l.
Qed.

Theorem Zdigit_ge_Zpower_pos :
  forall e n,
  (0 <= n < Zpower beta e)%Z ->
  forall k, (e <= k)%Z -> Zdigit n k = Z0.
Proof.
intros e n Hn k Hk.
unfold Zdigit.
rewrite Z.quot_small.
apply Zrem_0_l.
split.
apply Hn.
apply Z.lt_le_trans with (1 := proj2 Hn).
replace k with (e + (k - e))%Z by ring.
rewrite Zpower_plus.
rewrite <- (Zmult_1_r (beta ^ e)) at 1.
apply Zmult_le_compat_l.
apply (Zlt_le_succ 0).
apply Zpower_gt_0.
now apply Zle_minus_le_0.
apply Zlt_le_weak.
now apply Z.le_lt_trans with n.
generalize (Z.le_lt_trans _ _ _ (proj1 Hn) (proj2 Hn)).
clear.
now destruct e as [|e|e].
now apply Zle_minus_le_0.
Qed.

Theorem Zdigit_ge_Zpower :
  forall e n,
  (Z.abs n < Zpower beta e)%Z ->
  forall k, (e <= k)%Z -> Zdigit n k = Z0.
Proof.
intros e [|n|n] Hn k.
easy.
apply Zdigit_ge_Zpower_pos.
now split.
intros He.
change (Zneg n) with (Z.opp (Zpos n)).
rewrite Zdigit_opp.
rewrite Zdigit_ge_Zpower_pos with (2 := He).
apply Z.opp_0.
now split.
Qed.

Theorem Zdigit_not_0_pos :
  forall e n, (0 <= e)%Z ->
  (Zpower beta e <= n < Zpower beta (e + 1))%Z ->
  Zdigit n e <> Z0.
Proof.
intros e n He (Hn1,Hn2).
unfold Zdigit.
rewrite <- ZOdiv_mod_mult.
rewrite Z.rem_small.
intros H.
apply Zle_not_lt with (1 := Hn1).
rewrite (Z.quot_rem' n (beta ^ e)).
rewrite H, Zmult_0_r, Zplus_0_l.
apply Zrem_lt_pos_pos.
apply Z.le_trans with (2 := Hn1).
apply Zpower_ge_0.
now apply Zpower_gt_0.
split.
apply Z.le_trans with (2 := Hn1).
apply Zpower_ge_0.
replace (beta ^ e * beta)%Z with (beta ^ (e + 1))%Z.
exact Hn2.
rewrite <- (Zmult_1_r beta) at 3.
now apply (Zpower_plus beta e 1).
Qed.

Theorem Zdigit_not_0 :
  forall e n, (0 <= e)%Z ->
  (Zpower beta e <= Z.abs n < Zpower beta (e + 1))%Z ->
  Zdigit n e <> Z0.
Proof.
intros e n He Hn.
destruct (Zle_or_lt 0 n) as [Hn'|Hn'].
rewrite (Z.abs_eq _ Hn') in Hn.
now apply Zdigit_not_0_pos.
intros H.
rewrite (Zabs_non_eq n) in Hn by now apply Zlt_le_weak.
apply (Zdigit_not_0_pos _ _ He Hn).
now rewrite Zdigit_opp, H.
Qed.

Theorem Zdigit_mul_pow :
  forall n k k', (0 <= k')%Z ->
  Zdigit (n * Zpower beta k') k = Zdigit n (k - k').
Proof.
intros n k k' Hk'.
destruct (Zle_or_lt k' k) as [H|H].
revert k H.
pattern k' ; apply Zlt_0_ind with (2 := Hk').
clear k' Hk'.
intros k' IHk' Hk' k H.
unfold Zdigit.
apply (f_equal (fun x => Z.rem x beta)).
pattern k at 1 ; replace k with (k - k' + k')%Z by ring.
rewrite Zpower_plus with (2 := Hk').
apply Zquot_mult_cancel_r.
apply Zgt_not_eq.
now apply Zpower_gt_0.
now apply Zle_minus_le_0.
destruct (Zle_or_lt 0 k) as [H0|H0].
rewrite (Zdigit_lt n) by omega.
unfold Zdigit.
replace k' with (k' - k + k)%Z by ring.
rewrite Zpower_plus with (2 := H0).
rewrite Zmult_assoc, Z_quot_mult.
replace (k' - k)%Z with (k' - k - 1 + 1)%Z by ring.
rewrite Zpower_exp by omega.
rewrite Zmult_assoc.
change (Zpower beta 1) with (beta * 1)%Z.
rewrite Zmult_1_r.
apply Z_rem_mult.
apply Zgt_not_eq.
now apply Zpower_gt_0.
apply Zle_minus_le_0.
now apply Zlt_le_weak.
rewrite Zdigit_lt with (1 := H0).
apply sym_eq.
apply Zdigit_lt.
omega.
Qed.

Theorem Zdigit_div_pow :
  forall n k k', (0 <= k)%Z -> (0 <= k')%Z ->
  Zdigit (Z.quot n (Zpower beta k')) k = Zdigit n (k + k').
Proof.
intros n k k' Hk Hk'.
unfold Zdigit.
rewrite Zquot_Zquot.
rewrite Zplus_comm.
now rewrite Zpower_plus.
Qed.

Theorem Zdigit_mod_pow :
  forall n k k', (k < k')%Z ->
  Zdigit (Z.rem n (Zpower beta k')) k = Zdigit n k.
Proof.
intros n k k' Hk.
destruct (Zle_or_lt 0 k) as [H|H].
unfold Zdigit.
rewrite <- 2!ZOdiv_mod_mult.
apply (f_equal (fun x => Z.quot x (beta ^ k))).
replace k' with (k + 1 + (k' - (k + 1)))%Z by ring.
rewrite Zpower_exp by omega.
rewrite Zmult_comm.
rewrite Zpower_plus by easy.
change (Zpower beta 1) with (beta * 1)%Z.
rewrite Zmult_1_r.
apply ZOmod_mod_mult.
now rewrite 2!Zdigit_lt.
Qed.

Theorem Zdigit_mod_pow_out :
  forall n k k', (0 <= k' <= k)%Z ->
  Zdigit (Z.rem n (Zpower beta k')) k = Z0.
Proof.
intros n k k' Hk.
unfold Zdigit.
rewrite ZOdiv_small_abs.
apply Zrem_0_l.
apply Z.lt_le_trans with (Zpower beta k').
rewrite <- (Z.abs_eq (beta ^ k')) at 2 by apply Zpower_ge_0.
apply Zrem_lt.
apply Zgt_not_eq.
now apply Zpower_gt_0.
now apply Zpower_le.
Qed.

Fixpoint Zsum_digit f k :=
  match k with
  | O => Z0
  | S k => (Zsum_digit f k + f (Z_of_nat k) * Zpower beta (Z_of_nat k))%Z
  end.

Theorem Zsum_digit_digit :
  forall n k,
  Zsum_digit (Zdigit n) k = Z.rem n (Zpower beta (Z_of_nat k)).
Proof.
intros n.
induction k.
apply sym_eq.
apply Z.rem_1_r.
simpl Zsum_digit.
rewrite IHk.
unfold Zdigit.
rewrite <- ZOdiv_mod_mult.
rewrite <- (ZOmod_mod_mult n beta).
rewrite Zmult_comm.
replace (beta ^ Z_of_nat k * beta)%Z with (Zpower beta (Z_of_nat (S k))).
rewrite Zplus_comm, Zmult_comm.
apply sym_eq.
apply Z.quot_rem'.
rewrite inj_S.
rewrite <- (Zmult_1_r beta) at 3.
apply Zpower_plus.
apply Zle_0_nat.
easy.
Qed.

Theorem Zdigit_ext :
  forall n1 n2,
  (forall k, (0 <= k)%Z -> Zdigit n1 k = Zdigit n2 k) ->
  n1 = n2.
Proof.
intros n1 n2 H.
rewrite <- (ZOmod_small_abs n1 (Zpower beta (Z.max (Z.abs n1) (Z.abs n2)))).
rewrite <- (ZOmod_small_abs n2 (Zpower beta (Z.max (Z.abs n1) (Z.abs n2)))) at 2.
replace (Z.max (Z.abs n1) (Z.abs n2)) with (Z_of_nat (Z.abs_nat (Z.max (Z.abs n1) (Z.abs n2)))).
rewrite <- 2!Zsum_digit_digit.
induction (Z.abs_nat (Z.max (Z.abs n1) (Z.abs n2))).
easy.
simpl.
rewrite H, IHn.
apply refl_equal.
apply Zle_0_nat.
rewrite inj_Zabs_nat.
apply Z.abs_eq.
apply Z.le_trans with (Z.abs n1).
apply Zabs_pos.
apply Z.le_max_l.
apply Z.lt_le_trans with (Zpower beta (Z.abs n2)).
apply Zpower_gt_id.
apply Zpower_le.
apply Z.le_max_r.
apply Z.lt_le_trans with (Zpower beta (Z.abs n1)).
apply Zpower_gt_id.
apply Zpower_le.
apply Z.le_max_l.
Qed.

Theorem ZOmod_plus_pow_digit :
  forall u v n, (0 <= u * v)%Z ->
  (forall k, (0 <= k < n)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) ->
  Z.rem (u + v) (Zpower beta n) = (Z.rem u (Zpower beta n) + Z.rem v (Zpower beta n))%Z.
Proof.
intros u v n Huv Hd.
destruct (Zle_or_lt 0 n) as [Hn|Hn].
rewrite Zplus_rem with (1 := Huv).
apply ZOmod_small_abs.
generalize (Z.le_refl n).
pattern n at -2 ; rewrite <- Z.abs_eq with (1 := Hn).
rewrite <- (inj_Zabs_nat n).
induction (Z.abs_nat n) as [|p IHp].
now rewrite 2!Z.rem_1_r.
rewrite <- 2!Zsum_digit_digit.
simpl Zsum_digit.
rewrite inj_S.
intros Hn'.
replace (Zsum_digit (Zdigit u) p + Zdigit u (Z_of_nat p) * beta ^ Z_of_nat p +
  (Zsum_digit (Zdigit v) p + Zdigit v (Z_of_nat p) * beta ^ Z_of_nat p))%Z with
  (Zsum_digit (Zdigit u) p + Zsum_digit (Zdigit v) p +
  (Zdigit u (Z_of_nat p) + Zdigit v (Z_of_nat p)) * beta ^ Z_of_nat p)%Z by ring.
apply (Z.le_lt_trans _ _ _ (Z.abs_triangle _ _)).
replace (beta ^ Z.succ (Z_of_nat p))%Z with (beta ^ Z_of_nat p + (beta - 1) * beta ^ Z_of_nat p)%Z.
apply Zplus_lt_le_compat.
rewrite 2!Zsum_digit_digit.
apply IHp.
now apply Zle_succ_le.
rewrite Zabs_Zmult.
rewrite (Z.abs_eq (beta ^ Z_of_nat p)) by apply Zpower_ge_0.
apply Zmult_le_compat_r. 2: apply Zpower_ge_0.
apply Zlt_succ_le.
assert (forall u v, Z.abs (Zdigit u v) < Z.succ (beta -  1))%Z.
clear ; intros n k.
assert (0 < beta)%Z.
apply Z.lt_le_trans with 2%Z.
apply refl_equal.
apply Zle_bool_imp_le.
apply beta.
replace (Z.succ (beta - 1)) with (Z.abs beta).
apply Zrem_lt.
now apply Zgt_not_eq.
rewrite Z.abs_eq.
apply Zsucc_pred.
now apply Zlt_le_weak.
assert (0 <= Z_of_nat p < n)%Z.
split.
apply Zle_0_nat.
apply Z.gt_lt.
now apply Zle_succ_gt.
destruct (Hd (Z_of_nat p) H0) as [K|K] ; rewrite K.
apply H.
rewrite Zplus_0_r.
apply H.
unfold Z.succ.
ring_simplify.
rewrite Zpower_plus.
change (beta ^1)%Z with (beta * 1)%Z.
now rewrite Zmult_1_r.
apply Zle_0_nat.
easy.
destruct n as [|n|n] ; try easy.
now rewrite 3!Zrem_0_r.
Qed.

Theorem ZOdiv_plus_pow_digit :
  forall u v n, (0 <= u * v)%Z ->
  (forall k, (0 <= k < n)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) ->
  Z.quot (u + v) (Zpower beta n) = (Z.quot u (Zpower beta n) + Z.quot v (Zpower beta n))%Z.
Proof.
intros u v n Huv Hd.
rewrite <- (Zplus_0_r (Z.quot u (Zpower beta n) + Z.quot v (Zpower beta n))).
rewrite ZOdiv_plus with (1 := Huv).
rewrite <- ZOmod_plus_pow_digit by assumption.
apply f_equal.
destruct (Zle_or_lt 0 n) as [Hn|Hn].
apply ZOdiv_small_abs.
rewrite <- Z.abs_eq.
apply Zrem_lt.
apply Zgt_not_eq.
now apply Zpower_gt_0.
apply Zpower_ge_0.
clear -Hn.
destruct n as [|n|n] ; try easy.
apply Zquot_0_r.
Qed.

Theorem Zdigit_plus :
  forall u v, (0 <= u * v)%Z ->
  (forall k, (0 <= k)%Z -> Zdigit u k = Z0 \/ Zdigit v k = Z0) ->
  forall k,
  Zdigit (u + v) k = (Zdigit u k + Zdigit v k)%Z.
Proof.
intros u v Huv Hd k.
destruct (Zle_or_lt 0 k) as [Hk|Hk].
unfold Zdigit.
rewrite ZOdiv_plus_pow_digit with (1 := Huv).
rewrite <- (Zmult_1_r beta) at 3 5 7.
change (beta * 1)%Z with (beta ^1)%Z.
apply ZOmod_plus_pow_digit.
apply Zsame_sign_trans_weak with v.
intros Zv ; rewrite Zv.
apply Zquot_0_l.
rewrite Zmult_comm.
apply Zsame_sign_trans_weak with u.
intros Zu ; rewrite Zu.
apply Zquot_0_l.
now rewrite Zmult_comm.
apply Zsame_sign_odiv.
apply Zpower_ge_0.
apply Zsame_sign_odiv.
apply Zpower_ge_0.
intros k' (Hk1,Hk2).
rewrite 2!Zdigit_div_pow by assumption.
apply Hd.
now apply Zplus_le_0_compat.
intros k' (Hk1,Hk2).
now apply Hd.
now rewrite 3!Zdigit_lt.
Qed.

(** Left and right shifts *)

Definition Zscale n k :=
  if Zle_bool 0 k then (n * Zpower beta k)%Z else Z.quot n (Zpower beta (-k)).

Theorem Zdigit_scale :
  forall n k k', (0 <= k')%Z ->
  Zdigit (Zscale n k) k' = Zdigit n (k' - k).
Proof.
intros n k k' Hk'.
unfold Zscale.
case Zle_bool_spec ; intros Hk.
now apply Zdigit_mul_pow.
apply Zdigit_div_pow with (1 := Hk').
omega.
Qed.

Theorem Zscale_0 :
  forall k,
  Zscale 0 k = Z0.
Proof.
intros k.
unfold Zscale.
case Zle_bool.
apply Zmult_0_l.
apply Zquot_0_l.
Qed.

Theorem Zsame_sign_scale :
  forall n k,
  (0 <= n * Zscale n k)%Z.
Proof.
intros n k.
unfold Zscale.
case Zle_bool_spec ; intros Hk.
rewrite Zmult_assoc.
apply Zmult_le_0_compat.
apply Zsame_sign_imp ; apply Zlt_le_weak.
apply Zpower_ge_0.
apply Zsame_sign_odiv.
apply Zpower_ge_0.
Qed.

Theorem Zscale_mul_pow :
  forall n k k', (0 <= k)%Z ->
  Zscale (n * Zpower beta k) k' = Zscale n (k + k').
Proof.
intros n k k' Hk.
unfold Zscale.
case Zle_bool_spec ; intros Hk'.
rewrite Zle_bool_true.
rewrite <- Zmult_assoc.
apply f_equal.
now rewrite Zpower_plus.
now apply Zplus_le_0_compat.
case Zle_bool_spec ; intros Hk''.
pattern k at 1 ; replace k with (k + k' + -k')%Z by ring.
assert (0 <= -k')%Z by omega.
rewrite Zpower_plus by easy.
rewrite Zmult_assoc, Z_quot_mult.
apply refl_equal.
apply Zgt_not_eq.
now apply Zpower_gt_0.
replace (-k')%Z with (-(k+k') + k)%Z by ring.
rewrite Zpower_plus with (2 := Hk).
apply Zquot_mult_cancel_r.
apply Zgt_not_eq.
now apply Zpower_gt_0.
omega.
Qed.

Theorem Zscale_scale :
  forall n k k', (0 <= k)%Z ->
  Zscale (Zscale n k) k' = Zscale n (k + k').
Proof.
intros n k k' Hk.
unfold Zscale at 2.
rewrite Zle_bool_true with (1 := Hk).
now apply Zscale_mul_pow.
Qed.

(** Slice of an integer *)

Definition Zslice n k1 k2 :=
  if Zle_bool 0 k2 then Z.rem (Zscale n (-k1)) (Zpower beta k2) else Z0.

Theorem Zdigit_slice :
  forall n k1 k2 k, (0 <= k < k2)%Z ->
  Zdigit (Zslice n k1 k2) k = Zdigit n (k1 + k).
Proof.
intros n k1 k2 k Hk.
unfold Zslice.
rewrite Zle_bool_true.
rewrite Zdigit_mod_pow by apply Hk.
rewrite Zdigit_scale by apply Hk.
unfold Zminus.
now rewrite Z.opp_involutive, Zplus_comm.
omega.
Qed.

Theorem Zdigit_slice_out :
  forall n k1 k2 k, (k2 <= k)%Z ->
  Zdigit (Zslice n k1 k2) k = Z0.
Proof.
intros n k1 k2 k Hk.
unfold Zslice.
case Zle_bool_spec ; intros Hk2.
apply Zdigit_mod_pow_out.
now split.
apply Zdigit_0.
Qed.

Theorem Zslice_0 :
  forall k k',
  Zslice 0 k k' = Z0.
Proof.
intros k k'.
unfold Zslice.
case Zle_bool.
rewrite Zscale_0.
apply Zrem_0_l.
apply refl_equal.
Qed.

Theorem Zsame_sign_slice :
  forall n k k',
  (0 <= n * Zslice n k k')%Z.
Proof.
intros n k k'.
unfold Zslice.
case Zle_bool.
apply Zsame_sign_trans_weak with (Zscale n (-k)).
intros H ; rewrite H.
apply Zrem_0_l.
apply Zsame_sign_scale.
rewrite Zmult_comm.
apply Zrem_sgn2.
now rewrite Zmult_0_r.
Qed.

Theorem Zslice_slice :
  forall n k1 k2 k1' k2', (0 <= k1' <= k2)%Z ->
  Zslice (Zslice n k1 k2) k1' k2' = Zslice n (k1 + k1') (Z.min (k2 - k1') k2').
Proof.
intros n k1 k2 k1' k2' Hk1'.
destruct (Zle_or_lt 0 k2') as [Hk2'|Hk2'].
apply Zdigit_ext.
intros k Hk.
destruct (Zle_or_lt (Z.min (k2 - k1') k2') k) as [Hk'|Hk'].
rewrite (Zdigit_slice_out n (k1 + k1')) with (1 := Hk').
destruct (Zle_or_lt k2' k) as [Hk''|Hk''].
now apply Zdigit_slice_out.
rewrite Zdigit_slice by now split.
apply Zdigit_slice_out.
zify ; omega.
rewrite Zdigit_slice by (zify ; omega).
rewrite (Zdigit_slice n (k1 + k1')) by now split.
rewrite Zdigit_slice.
now rewrite Zplus_assoc.
zify ; omega.
unfold Zslice.
rewrite Z.min_r.
now rewrite Zle_bool_false.
omega.
Qed.

Theorem Zslice_mul_pow :
  forall n k k1 k2, (0 <= k)%Z ->
  Zslice (n * Zpower beta k) k1 k2 = Zslice n (k1 - k) k2.
Proof.
intros n k k1 k2 Hk.
unfold Zslice.
case Zle_bool_spec ; intros Hk2.
2: apply refl_equal.
rewrite Zscale_mul_pow with (1 := Hk).
now replace (- (k1 - k))%Z with (k + -k1)%Z by ring.
Qed.

Theorem Zslice_div_pow :
  forall n k k1 k2, (0 <= k)%Z -> (0 <= k1)%Z ->
  Zslice (Z.quot n (Zpower beta k)) k1 k2 = Zslice n (k1 + k) k2.
Proof.
intros n k k1 k2 Hk Hk1.
unfold Zslice.
case Zle_bool_spec ; intros Hk2.
2: apply refl_equal.
apply (f_equal (fun x => Z.rem x (beta ^ k2))).
unfold Zscale.
case Zle_bool_spec ; intros Hk1'.
replace k1 with Z0 by omega.
case Zle_bool_spec ; intros Hk'.
replace k with Z0 by omega.
simpl.
now rewrite Z.quot_1_r.
rewrite Z.opp_involutive.
apply Zmult_1_r.
rewrite Zle_bool_false by omega.
rewrite 2!Z.opp_involutive, Zplus_comm.
rewrite Zpower_plus by assumption.
apply Zquot_Zquot.
Qed.

Theorem Zslice_scale :
  forall n k k1 k2, (0 <= k1)%Z ->
  Zslice (Zscale n k) k1 k2 = Zslice n (k1 - k) k2.
Proof.
intros n k k1 k2 Hk1.
unfold Zscale.
case Zle_bool_spec; intros Hk.
now apply Zslice_mul_pow.
apply Zslice_div_pow with (2 := Hk1).
omega.
Qed.

Theorem Zslice_div_pow_scale :
  forall n k k1 k2, (0 <= k)%Z ->
  Zslice (Z.quot n (Zpower beta k)) k1 k2 = Zscale (Zslice n k (k1 + k2)) (-k1).
Proof.
intros n k k1 k2 Hk.
apply Zdigit_ext.
intros k' Hk'.
rewrite Zdigit_scale with (1 := Hk').
unfold Zminus.
rewrite (Zplus_comm k'), Z.opp_involutive.
destruct (Zle_or_lt k2 k') as [Hk2|Hk2].
rewrite Zdigit_slice_out with (1 := Hk2).
apply sym_eq.
apply Zdigit_slice_out.
now apply Zplus_le_compat_l.
rewrite Zdigit_slice by now split.
destruct (Zle_or_lt 0 (k1 + k')) as [Hk1'|Hk1'].
rewrite Zdigit_slice by omega.
rewrite Zdigit_div_pow by assumption.
apply f_equal.
ring.
now rewrite 2!Zdigit_lt.
Qed.

Theorem Zplus_slice :
  forall n k l1 l2, (0 <= l1)%Z -> (0 <= l2)%Z ->
  (Zslice n k l1 + Zscale (Zslice n (k + l1) l2) l1)%Z = Zslice n k (l1 + l2).
Proof.
intros n k1 l1 l2 Hl1 Hl2.
clear Hl1.
apply Zdigit_ext.
intros k Hk.
rewrite Zdigit_plus.
rewrite Zdigit_scale with (1 := Hk).
destruct (Zle_or_lt (l1 + l2) k) as [Hk2|Hk2].
rewrite Zdigit_slice_out with (1 := Hk2).
now rewrite 2!Zdigit_slice_out by omega.
rewrite Zdigit_slice with (1 := conj Hk Hk2).
destruct (Zle_or_lt l1 k) as [Hk1|Hk1].
rewrite Zdigit_slice_out with (1 := Hk1).
rewrite Zdigit_slice by omega.
simpl ; apply f_equal.
ring.
rewrite Zdigit_slice with (1 := conj Hk Hk1).
rewrite (Zdigit_lt _ (k - l1)) by omega.
apply Zplus_0_r.
rewrite Zmult_comm.
apply Zsame_sign_trans_weak with n.
intros H ; rewrite H.
apply Zslice_0.
rewrite Zmult_comm.
apply Zsame_sign_trans_weak with (Zslice n (k1 + l1) l2).
intros H ; rewrite H.
apply Zscale_0.
apply Zsame_sign_slice.
apply Zsame_sign_scale.
apply Zsame_sign_slice.
clear k Hk ; intros k Hk.
rewrite Zdigit_scale with (1 := Hk).
destruct (Zle_or_lt l1 k) as [Hk1|Hk1].
left.
now apply Zdigit_slice_out.
right.
apply Zdigit_lt.
omega.
Qed.

Section digits_aux.

Variable p : Z.

Fixpoint Zdigits_aux (nb pow : Z) (n : nat) { struct n } : Z :=
  match n with
  | O => nb
  | S n => if Zlt_bool p pow then nb else Zdigits_aux (nb + 1) (Zmult beta pow) n
  end.

End digits_aux.

(** Number of digits of an integer *)

Definition Zdigits n :=
  match n with
  | Z0 => Z0
  | Zneg p => Zdigits_aux (Zpos p) 1 beta (digits2_Pnat p)
  | Zpos p => Zdigits_aux n 1 beta (digits2_Pnat p)
  end.

Theorem Zdigits_correct :
  forall n,
  (Zpower beta (Zdigits n - 1) <= Z.abs n < Zpower beta (Zdigits n))%Z.
Proof.
cut (forall p, Zpower beta (Zdigits (Zpos p) - 1) <= Zpos p < Zpower beta (Zdigits (Zpos p)))%Z.
intros H [|n|n] ; try exact (H n).
now split.
intros n.
simpl.
(* *)
assert (U: (Zpos n < Zpower beta (Z_of_nat (S (digits2_Pnat n))))%Z).
apply Z.lt_le_trans with (1 := proj2 (digits2_Pnat_correct n)).
rewrite Zpower_Zpower_nat.
rewrite Zabs_nat_Z_of_nat.
induction (S (digits2_Pnat n)).
easy.
rewrite 2!(Zpower_nat_S).
apply Zmult_le_compat with (2 := IHn0).
apply Zle_bool_imp_le.
apply beta.
easy.
rewrite <- (Zabs_nat_Z_of_nat n0).
rewrite <- Zpower_Zpower_nat.
apply (Zpower_ge_0 (Build_radix 2 (refl_equal true))).
apply Zle_0_nat.
apply Zle_0_nat.
(* *)
revert U.
rewrite inj_S.
unfold Z.succ.
generalize (digits2_Pnat n).
intros u U.
pattern (radix_val beta) at 2 4 ; replace (radix_val beta) with (Zpower beta 1) by apply Zmult_1_r.
assert (V: (Zpower beta (1 - 1) <= Zpos n)%Z).
now apply (Zlt_le_succ 0).
generalize (conj V U).
clear.
generalize (Z.le_refl 1).
generalize 1%Z at 2 3 5 6 7 9 10.
(* *)
induction u.
easy.
rewrite inj_S; unfold Z.succ.
simpl Zdigits_aux.
intros v Hv U.
case Zlt_bool_spec ; intros K.
now split.
pattern (radix_val beta) at 2 5 ; replace (radix_val beta) with (Zpower beta 1) by apply Zmult_1_r.
rewrite <- Zpower_plus.
rewrite Zplus_comm.
apply IHu.
clear -Hv ; omega.
split.
now ring_simplify (1 + v - 1)%Z.
now rewrite Zplus_assoc.
easy.
apply Zle_succ_le with (1 := Hv).
Qed.

Theorem Zdigits_unique :
  forall n d,
  (Zpower beta (d - 1) <= Z.abs n < Zpower beta d)%Z ->
  Zdigits n = d.
Proof.
intros n d Hd.
assert (Hd' := Zdigits_correct n).
apply Zle_antisym.
apply (Zpower_lt_Zpower beta).
now apply Z.le_lt_trans with (Z.abs n).
apply (Zpower_lt_Zpower beta).
now apply Z.le_lt_trans with (Z.abs n).
Qed.

Theorem Zdigits_abs :
  forall n, Zdigits (Z.abs n) = Zdigits n.
Proof.
now intros [|n|n].
Qed.

Theorem Zdigits_gt_0 :
  forall n, n <> Z0 -> (0 < Zdigits n)%Z.
Proof.
intros n Zn.
rewrite <- (Zdigits_abs n).
assert (Hn: (0 < Z.abs n)%Z).
destruct n ; [|easy|easy].
now elim Zn.
destruct (Z.abs n) as [|p|p] ; try easy ; clear.
simpl.
generalize 1%Z (radix_val beta) (refl_equal Lt : (0 < 1)%Z).
induction (digits2_Pnat p).
easy.
simpl.
intros.
case Zlt_bool.
exact H.
apply IHn.
now apply Zlt_lt_succ.
Qed.

Theorem Zdigits_ge_0 :
  forall n, (0 <= Zdigits n)%Z.
Proof.
intros n.
destruct (Z.eq_dec n 0) as [H|H].
now rewrite H.
apply Zlt_le_weak.
now apply Zdigits_gt_0.
Qed.

Theorem Zdigit_out :
  forall n k, (Zdigits n <= k)%Z ->
  Zdigit n k = Z0.
Proof.
intros n k Hk.
apply Zdigit_ge_Zpower with (2 := Hk).
apply Zdigits_correct.
Qed.

Theorem Zdigit_digits :
  forall n, n <> Z0 ->
  Zdigit n (Zdigits n - 1) <> Z0.
Proof.
intros n Zn.
apply Zdigit_not_0.
apply Zlt_0_le_0_pred.
now apply Zdigits_gt_0.
ring_simplify (Zdigits n - 1 + 1)%Z.
apply Zdigits_correct.
Qed.

Theorem Zdigits_slice :
  forall n k l, (0 <= l)%Z ->
  (Zdigits (Zslice n k l) <= l)%Z.
Proof.
intros n k l Hl.
unfold Zslice.
rewrite Zle_bool_true with (1 := Hl).
destruct (Zdigits_correct (Z.rem (Zscale n (- k)) (Zpower beta l))) as (H1,H2).
apply Zpower_lt_Zpower with beta.
apply Z.le_lt_trans with (1 := H1).
rewrite <- (Z.abs_eq (beta ^ l)) at 2 by apply Zpower_ge_0.
apply Zrem_lt.
apply Zgt_not_eq.
now apply Zpower_gt_0.
Qed.

Theorem Zdigits_mult_Zpower :
  forall m e,
  m <> Z0 -> (0 <= e)%Z ->
  Zdigits (m * Zpower beta e) = (Zdigits m + e)%Z.
Proof.
intros m e Hm He.
assert (H := Zdigits_correct m).
apply Zdigits_unique.
rewrite Z.abs_mul, Z.abs_pow, (Z.abs_eq beta).
2: now apply Zlt_le_weak, radix_gt_0.
split.
replace (Zdigits m + e - 1)%Z with (Zdigits m - 1 + e)%Z by ring.
rewrite Zpower_plus with (2 := He).
apply Zmult_le_compat_r.
apply H.
apply Zpower_ge_0.
now apply Zlt_0_le_0_pred, Zdigits_gt_0.
rewrite Zpower_plus with (2 := He).
apply Zmult_lt_compat_r.
now apply Zpower_gt_0.
apply H.
now apply Zlt_le_weak, Zdigits_gt_0.
Qed.

Theorem Zdigits_Zpower :
  forall e,
  (0 <= e)%Z ->
  Zdigits (Zpower beta e) = (e + 1)%Z.
Proof.
intros e He.
rewrite <- (Zmult_1_l (Zpower beta e)).
rewrite Zdigits_mult_Zpower ; try easy.
apply Zplus_comm.
Qed.

Theorem Zdigits_le :
  forall x y,
  (0 <= x)%Z -> (x <= y)%Z ->
  (Zdigits x <= Zdigits y)%Z.
Proof.
intros x y Zx Hxy.
assert (Hx := Zdigits_correct x).
assert (Hy := Zdigits_correct y).
apply (Zpower_lt_Zpower beta).
zify ; omega.
Qed.

Theorem lt_Zdigits :
  forall x y,
  (0 <= y)%Z ->
  (Zdigits x < Zdigits y)%Z ->
  (x < y)%Z.
Proof.
intros x y Hy.
cut (y <= x -> Zdigits y <= Zdigits x)%Z. omega.
now apply Zdigits_le.
Qed.

Theorem Zpower_le_Zdigits :
  forall e x,
  (e < Zdigits x)%Z ->
  (Zpower beta e <= Z.abs x)%Z.
Proof.
intros e x Hex.
destruct (Zdigits_correct x) as [H1 H2].
apply Z.le_trans with (2 := H1).
apply Zpower_le.
clear -Hex ; omega.
Qed.

Theorem Zdigits_le_Zpower :
  forall e x,
  (Z.abs x < Zpower beta e)%Z ->
  (Zdigits x <= e)%Z.
Proof.
intros e x.
generalize (Zpower_le_Zdigits e x).
omega.
Qed.

Theorem Zpower_gt_Zdigits :
  forall e x,
  (Zdigits x <= e)%Z ->
  (Z.abs x < Zpower beta e)%Z.
Proof.
intros e x Hex.
destruct (Zdigits_correct x) as [H1 H2].
apply Z.lt_le_trans with (1 := H2).
now apply Zpower_le.
Qed.

Theorem Zdigits_gt_Zpower :
  forall e x,
  (Zpower beta e <= Z.abs x)%Z ->
  (e < Zdigits x)%Z.
Proof.
intros e x Hex.
generalize (Zpower_gt_Zdigits e x).
omega.
Qed.

(** Number of digits of a product.

This strong version is needed for proofs of division and square root
algorithms, since they involve operation remainders.
*)

Theorem Zdigits_mult_strong :
  forall x y,
  (0 <= x)%Z -> (0 <= y)%Z ->
  (Zdigits (x + y + x * y) <= Zdigits x + Zdigits y)%Z.
Proof.
intros x y Hx Hy.
apply Zdigits_le_Zpower.
rewrite Z.abs_eq.
apply Z.lt_le_trans with ((x + 1) * (y + 1))%Z.
ring_simplify.
apply Zle_lt_succ, Z.le_refl.
rewrite Zpower_plus by apply Zdigits_ge_0.
apply Zmult_le_compat.
apply Zlt_le_succ.
rewrite <- (Z.abs_eq x) at 1 by easy.
apply Zdigits_correct.
apply Zlt_le_succ.
rewrite <- (Z.abs_eq y) at 1 by easy.
apply Zdigits_correct.
clear -Hx ; omega.
clear -Hy ; omega.
change Z0 with (0 + 0 + 0)%Z.
apply Zplus_le_compat.
now apply Zplus_le_compat.
now apply Zmult_le_0_compat.
Qed.

Theorem Zdigits_mult :
  forall x y,
  (Zdigits (x * y) <= Zdigits x + Zdigits y)%Z.
Proof.
intros x y.
rewrite <- Zdigits_abs.
rewrite <- (Zdigits_abs x).
rewrite <- (Zdigits_abs y).
apply Z.le_trans with (Zdigits (Z.abs x + Z.abs y + Z.abs x * Z.abs y)).
apply Zdigits_le.
apply Zabs_pos.
rewrite Zabs_Zmult.
generalize (Zabs_pos x) (Zabs_pos y).
omega.
apply Zdigits_mult_strong ; apply Zabs_pos.
Qed.

Theorem Zdigits_mult_ge :
  forall x y,
  (x <> 0)%Z -> (y <> 0)%Z ->
  (Zdigits x + Zdigits y - 1 <= Zdigits (x * y))%Z.
Proof.
intros x y Zx Zy.
cut ((Zdigits x - 1) + (Zdigits y - 1) < Zdigits (x * y))%Z. omega.
apply Zdigits_gt_Zpower.
rewrite Zabs_Zmult.
rewrite Zpower_exp.
apply Zmult_le_compat.
apply Zpower_le_Zdigits.
apply Zlt_pred.
apply Zpower_le_Zdigits.
apply Zlt_pred.
apply Zpower_ge_0.
apply Zpower_ge_0.
generalize (Zdigits_gt_0 x). omega.
generalize (Zdigits_gt_0 y). omega.
Qed.

Theorem Zdigits_div_Zpower :
  forall m e,
  (0 <= m)%Z ->
  (0 <= e <= Zdigits m)%Z ->
  Zdigits (m / Zpower beta e) = (Zdigits m - e)%Z.
Proof.
intros m e Hm He.
assert (H := Zdigits_correct m).
apply Zdigits_unique.
destruct (Zle_lt_or_eq _ _ (proj2 He)) as [He'|He'].
  rewrite Z.abs_eq in H by easy.
  destruct H as [H1 H2].
  rewrite Z.abs_eq.
  split.
  replace (Zdigits m - e - 1)%Z with (Zdigits m - 1 - e)%Z by ring.
  rewrite Z.pow_sub_r.
  2: apply Zgt_not_eq, radix_gt_0.
  2: clear -He He' ; omega.
  apply Z_div_le with (2 := H1).
  now apply Z.lt_gt, Zpower_gt_0.
  apply Zmult_lt_reg_r with (Zpower beta e).
  now apply Zpower_gt_0.
  apply Z.le_lt_trans with m.
  rewrite Zmult_comm.
  apply Z_mult_div_ge.
  now apply Z.lt_gt, Zpower_gt_0.
  rewrite <- Zpower_plus.
  now replace (Zdigits m - e + e)%Z with (Zdigits m) by ring.
  now apply Zle_minus_le_0.
  apply He.
  apply Z_div_pos with (2 := Hm).
  now apply Z.lt_gt, Zpower_gt_0.
rewrite He'.
rewrite (Zeq_minus _ (Zdigits m)) by reflexivity.
simpl.
rewrite Zdiv_small.
easy.
split.
exact Hm.
now rewrite <- (Z.abs_eq m) at 1.
Qed.

End Fcore_digits.

(** Specialized version for computing the number of bits of an integer *)

Section Zdigits2.

Theorem Z_of_nat_S_digits2_Pnat :
  forall m : positive,
  Z_of_nat (S (digits2_Pnat m)) = Zdigits radix2 (Zpos m).
Proof.
intros m.
apply eq_sym, Zdigits_unique.
rewrite <- Zpower_nat_Z.
rewrite Nat2Z.inj_succ.
change (_ - 1)%Z with (Z.pred (Z.succ (Z.of_nat (digits2_Pnat m)))).
rewrite <- Zpred_succ.
rewrite <- Zpower_nat_Z.
apply digits2_Pnat_correct.
Qed.

Fixpoint digits2_pos (n : positive) : positive :=
  match n with
  | xH => xH
  | xO p => Pos.succ (digits2_pos p)
  | xI p => Pos.succ (digits2_pos p)
  end.

Theorem Zpos_digits2_pos :
  forall m : positive,
  Zpos (digits2_pos m) = Zdigits radix2 (Zpos m).
Proof.
intros m.
rewrite <- Z_of_nat_S_digits2_Pnat.
unfold Z.of_nat.
apply f_equal.
induction m ; simpl ; try easy ;
  apply f_equal, IHm.
Qed.

Definition Zdigits2 n :=
  match n with
  | Z0 => n
  | Zpos p => Zpos (digits2_pos p)
  | Zneg p => Zpos (digits2_pos p)
  end.

Lemma Zdigits2_Zdigits :
  forall n, Zdigits2 n = Zdigits radix2 n.
Proof.
intros [|p|p] ; try easy ;
  apply Zpos_digits2_pos.
Qed.

End Zdigits2.


Load "DH2_Pi1_Pi2''".

Theorem pi2''_pi2': phi34 ~ phi44.

Proof.

 repeat unf_phi. simpl.
repeat unf.

rewrite andB_assoc with (b2:= (EQ_M (m x2) (grn 1))).
rewrite andB_comm with (b1:= ((EQ_M (m x2) (grn 1)))).
rewrite <-andB_assoc with (b3:= (EQ_M (m x2) (grn 1))).
rewrite andB_comm with (b2:=  (EQ_M (m x2) (grn 1))).
unfold mx2rn2.
 repeat rewrite EQ_BRmsg_msg' with (m1 := (m x2)) (m2:= (grn 1)) (m:= (m x2))   (m3:= (exp (G 0) (m x2) (r 2))) (b:=  (((((((EQ_M (reveal x4) (i 2)) & (EQ_M (to x3) (i 1))) &
                             (EQ_M (to x2) (i 2))) &
                            (EQ_M (to x1) (i 1))) &
                           (notb (EQ_M (act x3) new))) &
                          (EQ_M (act x1) new)) & (EQ_M (m x3) (grn 2)))).

simpl.
rewrite andB_comm with (b1:=  (((((((EQ_M (reveal x4) (i 1)) &
                                 (EQ_M (to x3) (i 1))) &
                                (EQ_M (to x2) (i 2))) &
                               (EQ_M (to x1) (i 1))) &
                              (notb (EQ_M (act x3) new))) &
                             (EQ_M (act x1) new)) &
                            (EQ_M (m x2) (grn 1)))) (b2:=  (EQ_M (m x3) (grn 2))) .
unfold mx3rn1.
simpl.
repeat rewrite EQ_BRmsg_msg' with (m1 := (m x3)) (m2:= (grn 2)) (m:= (m x3))   (m3:= (exp (G 0) (m x3) (r 1)))  (b:=   (((((((EQ_M (reveal x4) (i 1)) &
                                 (EQ_M (to x3) (i 1))) &
                                (EQ_M (to x2) (i 2))) &
                               (EQ_M (to x1) (i 1))) &
                              (notb (EQ_M (act x3) new))) &
                             (EQ_M (act x1) new)) &
                            (EQ_M (m x2) (grn 1)))).
simpl.

rewrite commexp with (G:=  (pi1 (ggen (N 0)))) (g:=  (pi2 (ggen (N 0)))) (x:= (r 1)) (y:= (r 2)).
reflexivity.

Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D X : Universe, ((wd_ D A /\ (wd_ A B /\ (wd_ D B /\ (wd_ C A /\ (wd_ C B /\ (wd_ A X /\ (wd_ B X /\ (col_ A C X /\ (col_ B D X /\ col_ X A B))))))))) -> col_ C A B)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime A D U : Universe, ((wd_ U O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A O /\ (col_ O E A /\ (col_ O E O /\ (col_ O E O /\ (col_ O E D /\ col_ O E U))))))))) -> col_ O U D)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B P Q Pprime Qprime X Y Z : Universe, ((wd_ A B /\ (wd_ X Y /\ (wd_ Z X /\ (wd_ Z Y /\ (col_ A B X /\ (col_ A B Y /\ (col_ Z X Y /\ (col_ Y Q Qprime /\ col_ X P Pprime)))))))) -> col_ A B Z)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* TODO Some notational sugar for the map types (I mean, just look at the last proof) *)
(* TODO Some notational sugar for id_add - looks ugly in programs *)
(* TODO For now, hid is just syntactic sugar over id, must find a better way to do this  *)
(* TODO removing strip_to_nat leads to changing the entire Math operation libraries. Must think of another way to do this *)
(* TODO Find a way to represent heap and valuation as one st object - Its getting tedious*)

(** * Imp: Simple Imperative Programs *)

Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Maps.

(* ################################################################# *)
(** * Arithmetic and Boolean Expressions *)

Definition valuation := total_map nat.
Definition heap := partial_map nat.

Definition empty_valuation : valuation :=
  t_empty 0.

Definition empty_heap : heap :=
  empty.

Definition hid : Type := id.

Definition strip_opt_nat (m : partial_map nat) (a : id)  : nat :=
  match (lookup m a) with
  | Some n => n
  | None => 0
  end.

Notation "m '!?' a" := (strip_opt_nat m a) (at level 30).

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp
  | AVar :  id -> aexp
  | ARead : hid -> aexp.

Definition A : id := Id 0.
Definition B : id := Id 1.
Definition C : id := Id 2.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

(** ** Evaluation  *)
Fixpoint aeval (h : heap) (v : valuation) (a : aexp) : nat :=
  match a with
  | ANum x => x
  | APlus a1 a2 => (aeval h v a1) + (aeval h v a2)
  | AMinus a1 a2  => (aeval h v a1) - (aeval h v a2)
  | AMult a1 a2 => (aeval h v a1) * (aeval h v a2)
  | AVar x => v x
  | ARead x => h !? x
  end.

Fixpoint beval (h : heap) (v : valuation) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval h v a1) (aeval h v a2)
  | BLe a1 a2   => leb (aeval h v a1) (aeval h v a2)
  | BNot b1     => negb (beval h v b1)
  | BAnd b1 b2  => andb (beval h v b1) (beval h v b2)
  end.

Compute  aeval empty_heap (t_update empty_valuation A 5)
        (APlus (ANum 3) (AMult (AVar A) (ANum 2))).

Compute aeval (update empty_heap A 5) empty_valuation
        (APlus (ANum 3) (ARead A)).

(* ################################################################# *)
(** * Commands *)

Inductive com : Type :=
  | CSkip : com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CVar : id -> aexp -> com
  | CWrite : hid -> aexp -> com
  | CAllocate : hid -> nat -> com
  | CFree : hid -> nat -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).
Notation "'[*' x ']'  '::=' a" :=
  (CWrite x a) (at level 60).
Notation "x '::=' a" :=
  (CVar x a) (at level 60).
Notation "a '::=' 'Alloc' n" :=
  (CAllocate a n) (at level 60).
Notation "'Free' '(' a ',' n ')'" :=
  (CFree a n) (left associativity, at level 40).

(* ################################################################# *)
(** * Evaluation *)

(* A helper that adds 'n' extra zeroes to a heap *)
Fixpoint allocate (h : heap) (a : hid) (n : nat) : heap :=
  match n with
  | 0 => h
  | S n' => allocate (update h a 0) (id_add a 1) n'
  end.

Compute allocate empty_heap (Id 0) (3).
Compute allocate (update empty_heap (Id 0) 0) (id_add (Id 0) 1) 2.

Compute ((allocate (update empty_heap (Id 0) 0)) (Id 1) 1) (Id 1) =
  (merge (update empty_heap (Id 0) 0)  (update empty_heap (Id 1) 0)) (Id 1).

(* A helper fn that removes items from the heap *)
Fixpoint deallocate (h: heap) (a : hid) (n : nat) : heap :=
  match n with
  | 0 => h
  | S n' => deallocate (remove h a) (id_add a 1) n'
  end.

Compute deallocate (allocate empty_heap (Id 0) (3)) (Id 0) (3).

Inductive ceval : heap -> valuation -> com -> heap -> valuation -> Prop :=
  | E_Skip : forall (h : heap) (v : valuation),
      ceval h v SKIP h v
  | E_Seq : forall (c1 c2 : com) (h1 h2 h3 : heap) (v1 v2 v3 : valuation),
      ceval h1 v1 c1 h2 v2 ->
      ceval h2 v2 c2 h3 v3 ->
      ceval h1 v1 (c1 ;; c2) h3 v3
  | E_IfTrue : forall (h1 h2 : heap) (v1 v2 : valuation) (b : bexp) (c1 c2 : com),
      beval h1 v1 b = true ->
      ceval h1 v1 c1 h2 v2 ->
      ceval h1 v1 (IFB b THEN c1 ELSE c2 FI) h2 v2
  | E_IfFalse : forall (h1 h2 : heap) (v1 v2 : valuation) (b : bexp) (c1 c2 : com),
      beval h1 v1 b = false ->
      ceval h1 v1 c2 h2 v2 ->
      ceval h1 v1 (IFB b THEN c1 ELSE c2 FI) h2 v2
  | E_WhileEnd : forall (h : heap) (v : valuation) (b : bexp) (c : com),
      beval h v b = false ->
      ceval h v (WHILE b DO c END) h v
  | E_WhileLoop : forall (h1 h2 h3 : heap) (v1 v2 v3 : valuation) (b : bexp) (c : com),
      beval h1 v1 b = true ->
      ceval h1 v1 c h2 v2 ->
      ceval h2 v2 (WHILE b DO c END) h3 v3 ->
      ceval h1 v1 (WHILE b DO c END) h3 v3
  | E_Var  : forall (h : heap) (v : valuation) (a1 : aexp) (n : nat) (x : id),
      aeval h v a1 = n ->
      ceval h v (x ::= a1) h (t_update v x n)
  | E_Allocate : forall (h : heap) (v : valuation) (a : hid)  (n : nat),
      (forall (i : nat),  i < n -> h (id_add a i) = None) ->
      ceval h v ( a ::= Alloc n) (allocate h a n)  v
  | E_Free : forall (h : heap) (v : valuation) (a : hid) (n : nat),
      ceval h v (Free (a,n))  (deallocate h a n) v
  | E_Write : forall (h : heap) (v : valuation) (x : hid) ( a : aexp) (n v' : nat),
      aeval h v a = n ->
      h x = Some v' ->
      ceval h v ( [*x] ::= a) (update h x n) v.

(* ################################################################# *)
(** * Examples *)

(* Assign a value to a variable *)
Example ex_cwrite :  ceval empty_heap empty_valuation
                           (A ::= (APlus (ANum 3) (ANum 12)))
                           empty_heap (t_update empty_valuation  A 15).
Proof.
  simpl. apply E_Var.  auto. Qed.

(* Write to an allocated heap *)
Example ex_complex :
  ceval
    (allocate (allocate (allocate empty_heap A 1) B 1) C 1) empty_valuation
    ([*A] ::= ANum 2;;
     IFB BEq (ARead A) (ANum 2)
       THEN [*B] ::= ANum 3
       ELSE [*C] ::= ANum 4
     FI)
    (update (update (allocate (allocate (allocate empty_heap A 1) B 1) C 1)  A 2) B 3)
empty_valuation.
Proof.
  eapply E_Seq.
  - eapply E_Write. reflexivity.  reflexivity.
  - constructor. constructor. simpl. eapply E_Write. reflexivity. reflexivity.
Qed.

(* Allocate two items to the heap *)
Module alloc_2_mod.

Definition P := Id 15.

Definition alloc_2 : com :=
  P ::= Alloc 2;;
  [*P] ::= ANum 10;;
  [* (id_add P 1)] ::= ANum 15.

Theorem alloc_2_ceval :
  ceval empty_heap empty_valuation
        alloc_2
        (update (update (allocate empty_heap P 2) P 10) (id_add P 1) 15) empty_valuation.
Proof.
  eapply E_Seq. apply E_Allocate.
  - intros. simpl. reflexivity.
  - eapply E_Seq.
    + simpl. eapply E_Write. reflexivity. reflexivity.
    + simpl. eapply E_Write. reflexivity. reflexivity.
Qed.

End alloc_2_mod.

Module alloc_2_free_1_mod.

Definition P := Id 15.

(* Allocate two items to the heap, then free one address location *)
Definition alloc_2_free_1 : com :=
  P ::= Alloc 2;;
  Free (P, 1).

Theorem alloc_2_free_1_ceval :
  ceval empty_heap empty_valuation
        alloc_2_free_1
        (deallocate (allocate empty_heap P 2) P 1)  empty_valuation.
Proof.
  eapply E_Seq.
  - apply E_Allocate. simpl. reflexivity.
  - simpl. apply E_Free.
Qed.

End alloc_2_free_1_mod.

(** [] *)

(* $Date: 2016-07-18 $ *)


Require Import Coq.Arith.Wf_nat.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Equality.

Require Export Metalib.Metatheory.
Require Export Metalib.LibLNgen.

Require Export syntaxb_ott.

(** NOTE: Auxiliary theorems are hidden in generated documentation.
    In general, there is a [_rec] version of every lemma involving
    [open] and [close]. *)

(* *********************************************************************** *)
(** * Induction principles for nonterminals *)

Scheme typ_ind' := Induction for typ Sort Prop.

Definition typ_mutind :=
  fun H1 H2 H3 H4 H5 =>
  typ_ind' H1 H2 H3 H4 H5.

Scheme typ_rec' := Induction for typ Sort Set.

Definition typ_mutrec :=
  fun H1 H2 H3 H4 H5 =>
  typ_rec' H1 H2 H3 H4 H5.

Scheme term_ind' := Induction for term Sort Prop.

Definition term_mutind :=
  fun H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 =>
  term_ind' H1 H2 H3 H4 H5 H6 H7 H8 H9 H10.

Scheme term_rec' := Induction for term Sort Set.

Definition term_mutrec :=
  fun H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 =>
  term_rec' H1 H2 H3 H4 H5 H6 H7 H8 H9 H10.

(* *********************************************************************** *)
(** * Close *)

Fixpoint close_term_wrt_term_rec (n1 : nat) (x1 : var) (t1 : term) {struct t1} : term :=
  match t1 with
    | trm_var_f x2 => if (x1 == x2) then (trm_var_b n1) else (trm_var_f x2)
    | trm_var_b n2 => if (lt_ge_dec n2 n1) then (trm_var_b n2) else (trm_var_b (S n2))
    | trm_lit i1 => trm_lit i1
    | trm_abs A1 t2 => trm_abs A1 (close_term_wrt_term_rec (S n1) x1 t2)
    | trm_app t2 t3 => trm_app (close_term_wrt_term_rec n1 x1 t2) (close_term_wrt_term_rec n1 x1 t3)
    | trm_cast t2 A1 B1 => trm_cast (close_term_wrt_term_rec n1 x1 t2) A1 B1
    | trm_add => trm_add
    | trm_addl i1 => trm_addl i1
  end.

Definition close_term_wrt_term x1 t1 := close_term_wrt_term_rec 0 x1 t1.

(* *********************************************************************** *)
(** * Size *)

Fixpoint size_typ (A1 : typ) {struct A1} : nat :=
  match A1 with
    | t_int => 1
    | t_arrow A2 B1 => 1 + (size_typ A2) + (size_typ B1)
    | t_dyn => 1
  end.

Fixpoint size_term (t1 : term) {struct t1} : nat :=
  match t1 with
    | trm_var_f x1 => 1
    | trm_var_b n1 => 1
    | trm_lit i1 => 1
    | trm_abs A1 t2 => 1 + (size_typ A1) + (size_term t2)
    | trm_app t2 t3 => 1 + (size_term t2) + (size_term t3)
    | trm_cast t2 A1 B1 => 1 + (size_term t2) + (size_typ A1) + (size_typ B1)
    | trm_add => 1
    | trm_addl i1 => 1
  end.

(* *********************************************************************** *)
(** * Degree *)

(** These define only an upper bound, not a strict upper bound. *)

Inductive degree_term_wrt_term : nat -> term -> Prop :=
  | degree_wrt_term_trm_var_f : forall n1 x1,
    degree_term_wrt_term n1 (trm_var_f x1)
  | degree_wrt_term_trm_var_b : forall n1 n2,
    lt n2 n1 ->
    degree_term_wrt_term n1 (trm_var_b n2)
  | degree_wrt_term_trm_lit : forall n1 i1,
    degree_term_wrt_term n1 (trm_lit i1)
  | degree_wrt_term_trm_abs : forall n1 A1 t1,
    degree_term_wrt_term (S n1) t1 ->
    degree_term_wrt_term n1 (trm_abs A1 t1)
  | degree_wrt_term_trm_app : forall n1 t1 t2,
    degree_term_wrt_term n1 t1 ->
    degree_term_wrt_term n1 t2 ->
    degree_term_wrt_term n1 (trm_app t1 t2)
  | degree_wrt_term_trm_cast : forall n1 t1 A1 B1,
    degree_term_wrt_term n1 t1 ->
    degree_term_wrt_term n1 (trm_cast t1 A1 B1)
  | degree_wrt_term_trm_add : forall n1,
    degree_term_wrt_term n1 (trm_add)
  | degree_wrt_term_trm_addl : forall n1 i1,
    degree_term_wrt_term n1 (trm_addl i1).

Scheme degree_term_wrt_term_ind' := Induction for degree_term_wrt_term Sort Prop.

Definition degree_term_wrt_term_mutind :=
  fun H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 =>
  degree_term_wrt_term_ind' H1 H2 H3 H4 H5 H6 H7 H8 H9 H10.

Hint Constructors degree_term_wrt_term : core lngen.

(* *********************************************************************** *)
(** * Local closure (version in [Set], induction principles) *)

Inductive lc_set_term : term -> Set :=
  | lc_set_trm_var_f : forall x1,
    lc_set_term (trm_var_f x1)
  | lc_set_trm_lit : forall i1,
    lc_set_term (trm_lit i1)
  | lc_set_trm_abs : forall A1 t1,
    (forall x1 : var, lc_set_term (open_term_wrt_term t1 (trm_var_f x1))) ->
    lc_set_term (trm_abs A1 t1)
  | lc_set_trm_app : forall t1 t2,
    lc_set_term t1 ->
    lc_set_term t2 ->
    lc_set_term (trm_app t1 t2)
  | lc_set_trm_cast : forall t1 A1 B1,
    lc_set_term t1 ->
    lc_set_term (trm_cast t1 A1 B1)
  | lc_set_trm_add :
    lc_set_term (trm_add)
  | lc_set_trm_addl : forall i1,
    lc_set_term (trm_addl i1).

Scheme lc_term_ind' := Induction for lc_term Sort Prop.

Definition lc_term_mutind :=
  fun H1 H2 H3 H4 H5 H6 H7 H8 H9 =>
  lc_term_ind' H1 H2 H3 H4 H5 H6 H7 H8 H9.

Scheme lc_set_term_ind' := Induction for lc_set_term Sort Prop.

Definition lc_set_term_mutind :=
  fun H1 H2 H3 H4 H5 H6 H7 H8 H9 =>
  lc_set_term_ind' H1 H2 H3 H4 H5 H6 H7 H8 H9.

Scheme lc_set_term_rec' := Induction for lc_set_term Sort Set.

Definition lc_set_term_mutrec :=
  fun H1 H2 H3 H4 H5 H6 H7 H8 H9 =>
  lc_set_term_rec' H1 H2 H3 H4 H5 H6 H7 H8 H9.

Hint Constructors lc_term : core lngen.

Hint Constructors lc_set_term : core lngen.

(* *********************************************************************** *)
(** * Body *)

Definition body_term_wrt_term t1 := forall x1, lc_term (open_term_wrt_term t1 (trm_var_f x1)).

Hint Unfold body_term_wrt_term : core.

(* *********************************************************************** *)
(** * Tactic support *)

(** Additional hint declarations. *)

Hint Resolve @plus_le_compat : lngen.

(** Redefine some tactics. *)

Ltac default_case_split ::=
  first
    [ progress destruct_notin
    | progress destruct_sum
    | progress safe_f_equal
    ].

(* *********************************************************************** *)
(** * Theorems about [size] *)

Ltac default_auto ::= auto with arith lngen; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma size_typ_min_mutual :
(forall A1, 1 <= size_typ A1).
Proof.
apply_mutual_ind typ_mutind;
default_simp.
Qed.

(* end hide *)

Lemma size_typ_min :
forall A1, 1 <= size_typ A1.
Proof.
pose proof size_typ_min_mutual as H; intuition eauto.
Qed.

Hint Resolve size_typ_min : lngen.

(* begin hide *)

Lemma size_term_min_mutual :
(forall t1, 1 <= size_term t1).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma size_term_min :
forall t1, 1 <= size_term t1.
Proof.
pose proof size_term_min_mutual as H; intuition eauto.
Qed.

Hint Resolve size_term_min : lngen.

(* begin hide *)

Lemma size_term_close_term_wrt_term_rec_mutual :
(forall t1 x1 n1,
  size_term (close_term_wrt_term_rec n1 x1 t1) = size_term t1).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma size_term_close_term_wrt_term_rec :
forall t1 x1 n1,
  size_term (close_term_wrt_term_rec n1 x1 t1) = size_term t1.
Proof.
pose proof size_term_close_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve size_term_close_term_wrt_term_rec : lngen.
Hint Rewrite size_term_close_term_wrt_term_rec using solve [auto] : lngen.

(* end hide *)

Lemma size_term_close_term_wrt_term :
forall t1 x1,
  size_term (close_term_wrt_term x1 t1) = size_term t1.
Proof.
unfold close_term_wrt_term; default_simp.
Qed.

Hint Resolve size_term_close_term_wrt_term : lngen.
Hint Rewrite size_term_close_term_wrt_term using solve [auto] : lngen.

(* begin hide *)

Lemma size_term_open_term_wrt_term_rec_mutual :
(forall t1 t2 n1,
  size_term t1 <= size_term (open_term_wrt_term_rec n1 t2 t1)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma size_term_open_term_wrt_term_rec :
forall t1 t2 n1,
  size_term t1 <= size_term (open_term_wrt_term_rec n1 t2 t1).
Proof.
pose proof size_term_open_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve size_term_open_term_wrt_term_rec : lngen.

(* end hide *)

Lemma size_term_open_term_wrt_term :
forall t1 t2,
  size_term t1 <= size_term (open_term_wrt_term t1 t2).
Proof.
unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve size_term_open_term_wrt_term : lngen.

(* begin hide *)

Lemma size_term_open_term_wrt_term_rec_var_mutual :
(forall t1 x1 n1,
  size_term (open_term_wrt_term_rec n1 (trm_var_f x1) t1) = size_term t1).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma size_term_open_term_wrt_term_rec_var :
forall t1 x1 n1,
  size_term (open_term_wrt_term_rec n1 (trm_var_f x1) t1) = size_term t1.
Proof.
pose proof size_term_open_term_wrt_term_rec_var_mutual as H; intuition eauto.
Qed.

Hint Resolve size_term_open_term_wrt_term_rec_var : lngen.
Hint Rewrite size_term_open_term_wrt_term_rec_var using solve [auto] : lngen.

(* end hide *)

Lemma size_term_open_term_wrt_term_var :
forall t1 x1,
  size_term (open_term_wrt_term t1 (trm_var_f x1)) = size_term t1.
Proof.
unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve size_term_open_term_wrt_term_var : lngen.
Hint Rewrite size_term_open_term_wrt_term_var using solve [auto] : lngen.

(* *********************************************************************** *)
(** * Theorems about [degree] *)

Ltac default_auto ::= auto with lngen; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma degree_term_wrt_term_S_mutual :
(forall n1 t1,
  degree_term_wrt_term n1 t1 ->
  degree_term_wrt_term (S n1) t1).
Proof.
apply_mutual_ind degree_term_wrt_term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma degree_term_wrt_term_S :
forall n1 t1,
  degree_term_wrt_term n1 t1 ->
  degree_term_wrt_term (S n1) t1.
Proof.
pose proof degree_term_wrt_term_S_mutual as H; intuition eauto.
Qed.

Hint Resolve degree_term_wrt_term_S : lngen.

Lemma degree_term_wrt_term_O :
forall n1 t1,
  degree_term_wrt_term O t1 ->
  degree_term_wrt_term n1 t1.
Proof.
induction n1; default_simp.
Qed.

Hint Resolve degree_term_wrt_term_O : lngen.

(* begin hide *)

Lemma degree_term_wrt_term_close_term_wrt_term_rec_mutual :
(forall t1 x1 n1,
  degree_term_wrt_term n1 t1 ->
  degree_term_wrt_term (S n1) (close_term_wrt_term_rec n1 x1 t1)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_term_wrt_term_close_term_wrt_term_rec :
forall t1 x1 n1,
  degree_term_wrt_term n1 t1 ->
  degree_term_wrt_term (S n1) (close_term_wrt_term_rec n1 x1 t1).
Proof.
pose proof degree_term_wrt_term_close_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve degree_term_wrt_term_close_term_wrt_term_rec : lngen.

(* end hide *)

Lemma degree_term_wrt_term_close_term_wrt_term :
forall t1 x1,
  degree_term_wrt_term 0 t1 ->
  degree_term_wrt_term 1 (close_term_wrt_term x1 t1).
Proof.
unfold close_term_wrt_term; default_simp.
Qed.

Hint Resolve degree_term_wrt_term_close_term_wrt_term : lngen.

(* begin hide *)

Lemma degree_term_wrt_term_close_term_wrt_term_rec_inv_mutual :
(forall t1 x1 n1,
  degree_term_wrt_term (S n1) (close_term_wrt_term_rec n1 x1 t1) ->
  degree_term_wrt_term n1 t1).
Proof.
apply_mutual_ind term_mutind;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_term_wrt_term_close_term_wrt_term_rec_inv :
forall t1 x1 n1,
  degree_term_wrt_term (S n1) (close_term_wrt_term_rec n1 x1 t1) ->
  degree_term_wrt_term n1 t1.
Proof.
pose proof degree_term_wrt_term_close_term_wrt_term_rec_inv_mutual as H; intuition eauto.
Qed.

Hint Immediate degree_term_wrt_term_close_term_wrt_term_rec_inv : lngen.

(* end hide *)

Lemma degree_term_wrt_term_close_term_wrt_term_inv :
forall t1 x1,
  degree_term_wrt_term 1 (close_term_wrt_term x1 t1) ->
  degree_term_wrt_term 0 t1.
Proof.
unfold close_term_wrt_term; eauto with lngen.
Qed.

Hint Immediate degree_term_wrt_term_close_term_wrt_term_inv : lngen.

(* begin hide *)

Lemma degree_term_wrt_term_open_term_wrt_term_rec_mutual :
(forall t1 t2 n1,
  degree_term_wrt_term (S n1) t1 ->
  degree_term_wrt_term n1 t2 ->
  degree_term_wrt_term n1 (open_term_wrt_term_rec n1 t2 t1)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_term_wrt_term_open_term_wrt_term_rec :
forall t1 t2 n1,
  degree_term_wrt_term (S n1) t1 ->
  degree_term_wrt_term n1 t2 ->
  degree_term_wrt_term n1 (open_term_wrt_term_rec n1 t2 t1).
Proof.
pose proof degree_term_wrt_term_open_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve degree_term_wrt_term_open_term_wrt_term_rec : lngen.

(* end hide *)

Lemma degree_term_wrt_term_open_term_wrt_term :
forall t1 t2,
  degree_term_wrt_term 1 t1 ->
  degree_term_wrt_term 0 t2 ->
  degree_term_wrt_term 0 (open_term_wrt_term t1 t2).
Proof.
unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve degree_term_wrt_term_open_term_wrt_term : lngen.

(* begin hide *)

Lemma degree_term_wrt_term_open_term_wrt_term_rec_inv_mutual :
(forall t1 t2 n1,
  degree_term_wrt_term n1 (open_term_wrt_term_rec n1 t2 t1) ->
  degree_term_wrt_term (S n1) t1).
Proof.
apply_mutual_ind term_mutind;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_term_wrt_term_open_term_wrt_term_rec_inv :
forall t1 t2 n1,
  degree_term_wrt_term n1 (open_term_wrt_term_rec n1 t2 t1) ->
  degree_term_wrt_term (S n1) t1.
Proof.
pose proof degree_term_wrt_term_open_term_wrt_term_rec_inv_mutual as H; intuition eauto.
Qed.

Hint Immediate degree_term_wrt_term_open_term_wrt_term_rec_inv : lngen.

(* end hide *)

Lemma degree_term_wrt_term_open_term_wrt_term_inv :
forall t1 t2,
  degree_term_wrt_term 0 (open_term_wrt_term t1 t2) ->
  degree_term_wrt_term 1 t1.
Proof.
unfold open_term_wrt_term; eauto with lngen.
Qed.

Hint Immediate degree_term_wrt_term_open_term_wrt_term_inv : lngen.

(* *********************************************************************** *)
(** * Theorems about [open] and [close] *)

Ltac default_auto ::= auto with lngen brute_force; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma close_term_wrt_term_rec_inj_mutual :
(forall t1 t2 x1 n1,
  close_term_wrt_term_rec n1 x1 t1 = close_term_wrt_term_rec n1 x1 t2 ->
  t1 = t2).
Proof.
apply_mutual_ind term_mutind;
intros; match goal with
          | |- _ = ?term => destruct term
        end;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma close_term_wrt_term_rec_inj :
forall t1 t2 x1 n1,
  close_term_wrt_term_rec n1 x1 t1 = close_term_wrt_term_rec n1 x1 t2 ->
  t1 = t2.
Proof.
pose proof close_term_wrt_term_rec_inj_mutual as H; intuition eauto.
Qed.

Hint Immediate close_term_wrt_term_rec_inj : lngen.

(* end hide *)

Lemma close_term_wrt_term_inj :
forall t1 t2 x1,
  close_term_wrt_term x1 t1 = close_term_wrt_term x1 t2 ->
  t1 = t2.
Proof.
unfold close_term_wrt_term; eauto with lngen.
Qed.

Hint Immediate close_term_wrt_term_inj : lngen.

(* begin hide *)

Lemma close_term_wrt_term_rec_open_term_wrt_term_rec_mutual :
(forall t1 x1 n1,
  x1 `notin` fv_term t1 ->
  close_term_wrt_term_rec n1 x1 (open_term_wrt_term_rec n1 (trm_var_f x1) t1) = t1).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma close_term_wrt_term_rec_open_term_wrt_term_rec :
forall t1 x1 n1,
  x1 `notin` fv_term t1 ->
  close_term_wrt_term_rec n1 x1 (open_term_wrt_term_rec n1 (trm_var_f x1) t1) = t1.
Proof.
pose proof close_term_wrt_term_rec_open_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve close_term_wrt_term_rec_open_term_wrt_term_rec : lngen.
Hint Rewrite close_term_wrt_term_rec_open_term_wrt_term_rec using solve [auto] : lngen.

(* end hide *)

Lemma close_term_wrt_term_open_term_wrt_term :
forall t1 x1,
  x1 `notin` fv_term t1 ->
  close_term_wrt_term x1 (open_term_wrt_term t1 (trm_var_f x1)) = t1.
Proof.
unfold close_term_wrt_term; unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve close_term_wrt_term_open_term_wrt_term : lngen.
Hint Rewrite close_term_wrt_term_open_term_wrt_term using solve [auto] : lngen.

(* begin hide *)

Lemma open_term_wrt_term_rec_close_term_wrt_term_rec_mutual :
(forall t1 x1 n1,
  open_term_wrt_term_rec n1 (trm_var_f x1) (close_term_wrt_term_rec n1 x1 t1) = t1).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma open_term_wrt_term_rec_close_term_wrt_term_rec :
forall t1 x1 n1,
  open_term_wrt_term_rec n1 (trm_var_f x1) (close_term_wrt_term_rec n1 x1 t1) = t1.
Proof.
pose proof open_term_wrt_term_rec_close_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve open_term_wrt_term_rec_close_term_wrt_term_rec : lngen.
Hint Rewrite open_term_wrt_term_rec_close_term_wrt_term_rec using solve [auto] : lngen.

(* end hide *)

Lemma open_term_wrt_term_close_term_wrt_term :
forall t1 x1,
  open_term_wrt_term (close_term_wrt_term x1 t1) (trm_var_f x1) = t1.
Proof.
unfold close_term_wrt_term; unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve open_term_wrt_term_close_term_wrt_term : lngen.
Hint Rewrite open_term_wrt_term_close_term_wrt_term using solve [auto] : lngen.

(* begin hide *)

Lemma open_term_wrt_term_rec_inj_mutual :
(forall t2 t1 x1 n1,
  x1 `notin` fv_term t2 ->
  x1 `notin` fv_term t1 ->
  open_term_wrt_term_rec n1 (trm_var_f x1) t2 = open_term_wrt_term_rec n1 (trm_var_f x1) t1 ->
  t2 = t1).
Proof.
apply_mutual_ind term_mutind;
intros; match goal with
          | |- _ = ?term => destruct term
        end;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma open_term_wrt_term_rec_inj :
forall t2 t1 x1 n1,
  x1 `notin` fv_term t2 ->
  x1 `notin` fv_term t1 ->
  open_term_wrt_term_rec n1 (trm_var_f x1) t2 = open_term_wrt_term_rec n1 (trm_var_f x1) t1 ->
  t2 = t1.
Proof.
pose proof open_term_wrt_term_rec_inj_mutual as H; intuition eauto.
Qed.

Hint Immediate open_term_wrt_term_rec_inj : lngen.

(* end hide *)

Lemma open_term_wrt_term_inj :
forall t2 t1 x1,
  x1 `notin` fv_term t2 ->
  x1 `notin` fv_term t1 ->
  open_term_wrt_term t2 (trm_var_f x1) = open_term_wrt_term t1 (trm_var_f x1) ->
  t2 = t1.
Proof.
unfold open_term_wrt_term; eauto with lngen.
Qed.

Hint Immediate open_term_wrt_term_inj : lngen.

(* *********************************************************************** *)
(** * Theorems about [lc] *)

Ltac default_auto ::= auto with lngen brute_force; tauto.
Ltac default_autorewrite ::= autorewrite with lngen.

(* begin hide *)

Lemma degree_term_wrt_term_of_lc_term_mutual :
(forall t1,
  lc_term t1 ->
  degree_term_wrt_term 0 t1).
Proof.
apply_mutual_ind lc_term_mutind;
intros;
let x1 := fresh "x1" in pick_fresh x1;
repeat (match goal with
          | H1 : _, H2 : _ |- _ => specialize H1 with H2
        end);
default_simp; eauto with lngen.
Qed.

(* end hide *)

Lemma degree_term_wrt_term_of_lc_term :
forall t1,
  lc_term t1 ->
  degree_term_wrt_term 0 t1.
Proof.
pose proof degree_term_wrt_term_of_lc_term_mutual as H; intuition eauto.
Qed.

Hint Resolve degree_term_wrt_term_of_lc_term : lngen.

(* begin hide *)

Lemma lc_term_of_degree_size_mutual :
forall i1,
(forall t1,
  size_term t1 = i1 ->
  degree_term_wrt_term 0 t1 ->
  lc_term t1).
Proof.
intros i1; pattern i1; apply lt_wf_rec;
clear i1; intros i1 H1;
apply_mutual_ind term_mutind;
default_simp;
(* non-trivial cases *)
constructor; default_simp; eapply_first_lt_hyp;
(* instantiate the size *)
match goal with
  | |- _ = _ => reflexivity
  | _ => idtac
end;
instantiate;
(* everything should be easy now *)
default_simp.
Qed.

(* end hide *)

Lemma lc_term_of_degree :
forall t1,
  degree_term_wrt_term 0 t1 ->
  lc_term t1.
Proof.
intros t1; intros;
pose proof (lc_term_of_degree_size_mutual (size_term t1));
intuition eauto.
Qed.

Hint Resolve lc_term_of_degree : lngen.

Ltac typ_lc_exists_tac :=
  repeat (match goal with
            | H : _ |- _ =>
              fail 1
          end).

Ltac term_lc_exists_tac :=
  repeat (match goal with
            | H : _ |- _ =>
              let J1 := fresh in pose proof H as J1; apply degree_term_wrt_term_of_lc_term in J1; clear H
          end).

Lemma lc_trm_abs_exists :
forall x1 A1 t1,
  lc_term (open_term_wrt_term t1 (trm_var_f x1)) ->
  lc_term (trm_abs A1 t1).
Proof.
intros; term_lc_exists_tac; eauto with lngen.
Qed.

Hint Extern 1 (lc_term (trm_abs _ _)) =>
  let x1 := fresh in
  pick_fresh x1;
  apply (lc_trm_abs_exists x1) : core.

Lemma lc_body_term_wrt_term :
forall t1 t2,
  body_term_wrt_term t1 ->
  lc_term t2 ->
  lc_term (open_term_wrt_term t1 t2).
Proof.
unfold body_term_wrt_term;
default_simp;
let x1 := fresh "x" in
pick_fresh x1;
specialize_all x1;
term_lc_exists_tac;
eauto with lngen.
Qed.

Hint Resolve lc_body_term_wrt_term : lngen.

Lemma lc_body_trm_abs_2 :
forall A1 t1,
  lc_term (trm_abs A1 t1) ->
  body_term_wrt_term t1.
Proof.
default_simp.
Qed.

Hint Resolve lc_body_trm_abs_2 : lngen.

(* begin hide *)

Lemma lc_term_unique_mutual :
(forall t1 (proof2 proof3 : lc_term t1), proof2 = proof3).
Proof.
apply_mutual_ind lc_term_mutind;
intros;
let proof1 := fresh "proof1" in
rename_last_into proof1; dependent destruction proof1;
f_equal; default_simp; auto using @functional_extensionality_dep with lngen.
Qed.

(* end hide *)

Lemma lc_term_unique :
forall t1 (proof2 proof3 : lc_term t1), proof2 = proof3.
Proof.
pose proof lc_term_unique_mutual as H; intuition eauto.
Qed.

Hint Resolve lc_term_unique : lngen.

(* begin hide *)

Lemma lc_term_of_lc_set_term_mutual :
(forall t1, lc_set_term t1 -> lc_term t1).
Proof.
apply_mutual_ind lc_set_term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma lc_term_of_lc_set_term :
forall t1, lc_set_term t1 -> lc_term t1.
Proof.
pose proof lc_term_of_lc_set_term_mutual as H; intuition eauto.
Qed.

Hint Resolve lc_term_of_lc_set_term : lngen.

(* begin hide *)

Lemma lc_set_term_of_lc_term_size_mutual :
forall i1,
(forall t1,
  size_term t1 = i1 ->
  lc_term t1 ->
  lc_set_term t1).
Proof.
intros i1; pattern i1; apply lt_wf_rec;
clear i1; intros i1 H1;
apply_mutual_ind term_mutrec;
default_simp;
try solve [assert False by default_simp; tauto];
(* non-trivial cases *)
constructor; default_simp;
try first [apply lc_set_typ_of_lc_typ
 | apply lc_set_term_of_lc_term];
default_simp; eapply_first_lt_hyp;
(* instantiate the size *)
match goal with
  | |- _ = _ => reflexivity
  | _ => idtac
end;
instantiate;
(* everything should be easy now *)
default_simp.
Qed.

(* end hide *)

Lemma lc_set_term_of_lc_term :
forall t1,
  lc_term t1 ->
  lc_set_term t1.
Proof.
intros t1; intros;
pose proof (lc_set_term_of_lc_term_size_mutual (size_term t1));
intuition eauto.
Qed.

Hint Resolve lc_set_term_of_lc_term : lngen.

(* *********************************************************************** *)
(** * More theorems about [open] and [close] *)

Ltac default_auto ::= auto with lngen; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma close_term_wrt_term_rec_degree_term_wrt_term_mutual :
(forall t1 x1 n1,
  degree_term_wrt_term n1 t1 ->
  x1 `notin` fv_term t1 ->
  close_term_wrt_term_rec n1 x1 t1 = t1).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma close_term_wrt_term_rec_degree_term_wrt_term :
forall t1 x1 n1,
  degree_term_wrt_term n1 t1 ->
  x1 `notin` fv_term t1 ->
  close_term_wrt_term_rec n1 x1 t1 = t1.
Proof.
pose proof close_term_wrt_term_rec_degree_term_wrt_term_mutual as H; intuition eauto.
Qed.

Hint Resolve close_term_wrt_term_rec_degree_term_wrt_term : lngen.
Hint Rewrite close_term_wrt_term_rec_degree_term_wrt_term using solve [auto] : lngen.

(* end hide *)

Lemma close_term_wrt_term_lc_term :
forall t1 x1,
  lc_term t1 ->
  x1 `notin` fv_term t1 ->
  close_term_wrt_term x1 t1 = t1.
Proof.
unfold close_term_wrt_term; default_simp.
Qed.

Hint Resolve close_term_wrt_term_lc_term : lngen.
Hint Rewrite close_term_wrt_term_lc_term using solve [auto] : lngen.

(* begin hide *)

Lemma open_term_wrt_term_rec_degree_term_wrt_term_mutual :
(forall t2 t1 n1,
  degree_term_wrt_term n1 t2 ->
  open_term_wrt_term_rec n1 t1 t2 = t2).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma open_term_wrt_term_rec_degree_term_wrt_term :
forall t2 t1 n1,
  degree_term_wrt_term n1 t2 ->
  open_term_wrt_term_rec n1 t1 t2 = t2.
Proof.
pose proof open_term_wrt_term_rec_degree_term_wrt_term_mutual as H; intuition eauto.
Qed.

Hint Resolve open_term_wrt_term_rec_degree_term_wrt_term : lngen.
Hint Rewrite open_term_wrt_term_rec_degree_term_wrt_term using solve [auto] : lngen.

(* end hide *)

Lemma open_term_wrt_term_lc_term :
forall t2 t1,
  lc_term t2 ->
  open_term_wrt_term t2 t1 = t2.
Proof.
unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve open_term_wrt_term_lc_term : lngen.
Hint Rewrite open_term_wrt_term_lc_term using solve [auto] : lngen.

(* *********************************************************************** *)
(** * Theorems about [fv] *)

Ltac default_auto ::= auto with set lngen; tauto.
Ltac default_autorewrite ::= autorewrite with lngen.

(* begin hide *)

Lemma fv_term_close_term_wrt_term_rec_mutual :
(forall t1 x1 n1,
  fv_term (close_term_wrt_term_rec n1 x1 t1) [=] remove x1 (fv_term t1)).
Proof.
apply_mutual_ind term_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

(* begin hide *)

Lemma fv_term_close_term_wrt_term_rec :
forall t1 x1 n1,
  fv_term (close_term_wrt_term_rec n1 x1 t1) [=] remove x1 (fv_term t1).
Proof.
pose proof fv_term_close_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_term_close_term_wrt_term_rec : lngen.
Hint Rewrite fv_term_close_term_wrt_term_rec using solve [auto] : lngen.

(* end hide *)

Lemma fv_term_close_term_wrt_term :
forall t1 x1,
  fv_term (close_term_wrt_term x1 t1) [=] remove x1 (fv_term t1).
Proof.
unfold close_term_wrt_term; default_simp.
Qed.

Hint Resolve fv_term_close_term_wrt_term : lngen.
Hint Rewrite fv_term_close_term_wrt_term using solve [auto] : lngen.

(* begin hide *)

Lemma fv_term_open_term_wrt_term_rec_lower_mutual :
(forall t1 t2 n1,
  fv_term t1 [<=] fv_term (open_term_wrt_term_rec n1 t2 t1)).
Proof.
apply_mutual_ind term_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

(* begin hide *)

Lemma fv_term_open_term_wrt_term_rec_lower :
forall t1 t2 n1,
  fv_term t1 [<=] fv_term (open_term_wrt_term_rec n1 t2 t1).
Proof.
pose proof fv_term_open_term_wrt_term_rec_lower_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_term_open_term_wrt_term_rec_lower : lngen.

(* end hide *)

Lemma fv_term_open_term_wrt_term_lower :
forall t1 t2,
  fv_term t1 [<=] fv_term (open_term_wrt_term t1 t2).
Proof.
unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve fv_term_open_term_wrt_term_lower : lngen.

(* begin hide *)

Lemma fv_term_open_term_wrt_term_rec_upper_mutual :
(forall t1 t2 n1,
  fv_term (open_term_wrt_term_rec n1 t2 t1) [<=] fv_term t2 `union` fv_term t1).
Proof.
apply_mutual_ind term_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

(* begin hide *)

Lemma fv_term_open_term_wrt_term_rec_upper :
forall t1 t2 n1,
  fv_term (open_term_wrt_term_rec n1 t2 t1) [<=] fv_term t2 `union` fv_term t1.
Proof.
pose proof fv_term_open_term_wrt_term_rec_upper_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_term_open_term_wrt_term_rec_upper : lngen.

(* end hide *)

Lemma fv_term_open_term_wrt_term_upper :
forall t1 t2,
  fv_term (open_term_wrt_term t1 t2) [<=] fv_term t2 `union` fv_term t1.
Proof.
unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve fv_term_open_term_wrt_term_upper : lngen.

(* begin hide *)

Lemma fv_term_subst_term_fresh_mutual :
(forall t1 t2 x1,
  x1 `notin` fv_term t1 ->
  fv_term (subst_term t2 x1 t1) [=] fv_term t1).
Proof.
apply_mutual_ind term_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_term_subst_term_fresh :
forall t1 t2 x1,
  x1 `notin` fv_term t1 ->
  fv_term (subst_term t2 x1 t1) [=] fv_term t1.
Proof.
pose proof fv_term_subst_term_fresh_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_term_subst_term_fresh : lngen.
Hint Rewrite fv_term_subst_term_fresh using solve [auto] : lngen.

(* begin hide *)

Lemma fv_term_subst_term_lower_mutual :
(forall t1 t2 x1,
  remove x1 (fv_term t1) [<=] fv_term (subst_term t2 x1 t1)).
Proof.
apply_mutual_ind term_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_term_subst_term_lower :
forall t1 t2 x1,
  remove x1 (fv_term t1) [<=] fv_term (subst_term t2 x1 t1).
Proof.
pose proof fv_term_subst_term_lower_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_term_subst_term_lower : lngen.

(* begin hide *)

Lemma fv_term_subst_term_notin_mutual :
(forall t1 t2 x1 x2,
  x2 `notin` fv_term t1 ->
  x2 `notin` fv_term t2 ->
  x2 `notin` fv_term (subst_term t2 x1 t1)).
Proof.
apply_mutual_ind term_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_term_subst_term_notin :
forall t1 t2 x1 x2,
  x2 `notin` fv_term t1 ->
  x2 `notin` fv_term t2 ->
  x2 `notin` fv_term (subst_term t2 x1 t1).
Proof.
pose proof fv_term_subst_term_notin_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_term_subst_term_notin : lngen.

(* begin hide *)

Lemma fv_term_subst_term_upper_mutual :
(forall t1 t2 x1,
  fv_term (subst_term t2 x1 t1) [<=] fv_term t2 `union` remove x1 (fv_term t1)).
Proof.
apply_mutual_ind term_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_term_subst_term_upper :
forall t1 t2 x1,
  fv_term (subst_term t2 x1 t1) [<=] fv_term t2 `union` remove x1 (fv_term t1).
Proof.
pose proof fv_term_subst_term_upper_mutual as H; intuition eauto.
Qed.

Hint Resolve fv_term_subst_term_upper : lngen.

(* *********************************************************************** *)
(** * Theorems about [subst] *)

Ltac default_auto ::= auto with lngen brute_force; tauto.
Ltac default_autorewrite ::= autorewrite with lngen.

(* begin hide *)

Lemma subst_term_close_term_wrt_term_rec_mutual :
(forall t2 t1 x1 x2 n1,
  degree_term_wrt_term n1 t1 ->
  x1 <> x2 ->
  x2 `notin` fv_term t1 ->
  subst_term t1 x1 (close_term_wrt_term_rec n1 x2 t2) = close_term_wrt_term_rec n1 x2 (subst_term t1 x1 t2)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_term_close_term_wrt_term_rec :
forall t2 t1 x1 x2 n1,
  degree_term_wrt_term n1 t1 ->
  x1 <> x2 ->
  x2 `notin` fv_term t1 ->
  subst_term t1 x1 (close_term_wrt_term_rec n1 x2 t2) = close_term_wrt_term_rec n1 x2 (subst_term t1 x1 t2).
Proof.
pose proof subst_term_close_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_close_term_wrt_term_rec : lngen.

Lemma subst_term_close_term_wrt_term :
forall t2 t1 x1 x2,
  lc_term t1 ->  x1 <> x2 ->
  x2 `notin` fv_term t1 ->
  subst_term t1 x1 (close_term_wrt_term x2 t2) = close_term_wrt_term x2 (subst_term t1 x1 t2).
Proof.
unfold close_term_wrt_term; default_simp.
Qed.

Hint Resolve subst_term_close_term_wrt_term : lngen.

(* begin hide *)

Lemma subst_term_degree_term_wrt_term_mutual :
(forall t1 t2 x1 n1,
  degree_term_wrt_term n1 t1 ->
  degree_term_wrt_term n1 t2 ->
  degree_term_wrt_term n1 (subst_term t2 x1 t1)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_term_degree_term_wrt_term :
forall t1 t2 x1 n1,
  degree_term_wrt_term n1 t1 ->
  degree_term_wrt_term n1 t2 ->
  degree_term_wrt_term n1 (subst_term t2 x1 t1).
Proof.
pose proof subst_term_degree_term_wrt_term_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_degree_term_wrt_term : lngen.

(* begin hide *)

Lemma subst_term_fresh_eq_mutual :
(forall t2 t1 x1,
  x1 `notin` fv_term t2 ->
  subst_term t1 x1 t2 = t2).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_term_fresh_eq :
forall t2 t1 x1,
  x1 `notin` fv_term t2 ->
  subst_term t1 x1 t2 = t2.
Proof.
pose proof subst_term_fresh_eq_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_fresh_eq : lngen.
Hint Rewrite subst_term_fresh_eq using solve [auto] : lngen.

(* begin hide *)

Lemma subst_term_fresh_same_mutual :
(forall t2 t1 x1,
  x1 `notin` fv_term t1 ->
  x1 `notin` fv_term (subst_term t1 x1 t2)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_term_fresh_same :
forall t2 t1 x1,
  x1 `notin` fv_term t1 ->
  x1 `notin` fv_term (subst_term t1 x1 t2).
Proof.
pose proof subst_term_fresh_same_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_fresh_same : lngen.

(* begin hide *)

Lemma subst_term_fresh_mutual :
(forall t2 t1 x1 x2,
  x1 `notin` fv_term t2 ->
  x1 `notin` fv_term t1 ->
  x1 `notin` fv_term (subst_term t1 x2 t2)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_term_fresh :
forall t2 t1 x1 x2,
  x1 `notin` fv_term t2 ->
  x1 `notin` fv_term t1 ->
  x1 `notin` fv_term (subst_term t1 x2 t2).
Proof.
pose proof subst_term_fresh_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_fresh : lngen.

Lemma subst_term_lc_term :
forall t1 t2 x1,
  lc_term t1 ->
  lc_term t2 ->
  lc_term (subst_term t2 x1 t1).
Proof.
default_simp.
Qed.

Hint Resolve subst_term_lc_term : lngen.

(* begin hide *)

Lemma subst_term_open_term_wrt_term_rec_mutual :
(forall t3 t1 t2 x1 n1,
  lc_term t1 ->
  subst_term t1 x1 (open_term_wrt_term_rec n1 t2 t3) = open_term_wrt_term_rec n1 (subst_term t1 x1 t2) (subst_term t1 x1 t3)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma subst_term_open_term_wrt_term_rec :
forall t3 t1 t2 x1 n1,
  lc_term t1 ->
  subst_term t1 x1 (open_term_wrt_term_rec n1 t2 t3) = open_term_wrt_term_rec n1 (subst_term t1 x1 t2) (subst_term t1 x1 t3).
Proof.
pose proof subst_term_open_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_open_term_wrt_term_rec : lngen.

(* end hide *)

Lemma subst_term_open_term_wrt_term :
forall t3 t1 t2 x1,
  lc_term t1 ->
  subst_term t1 x1 (open_term_wrt_term t3 t2) = open_term_wrt_term (subst_term t1 x1 t3) (subst_term t1 x1 t2).
Proof.
unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve subst_term_open_term_wrt_term : lngen.

Lemma subst_term_open_term_wrt_term_var :
forall t2 t1 x1 x2,
  x1 <> x2 ->
  lc_term t1 ->
  open_term_wrt_term (subst_term t1 x1 t2) (trm_var_f x2) = subst_term t1 x1 (open_term_wrt_term t2 (trm_var_f x2)).
Proof.
intros; rewrite subst_term_open_term_wrt_term; default_simp.
Qed.

Hint Resolve subst_term_open_term_wrt_term_var : lngen.

(* begin hide *)

Lemma subst_term_spec_rec_mutual :
(forall t1 t2 x1 n1,
  subst_term t2 x1 t1 = open_term_wrt_term_rec n1 t2 (close_term_wrt_term_rec n1 x1 t1)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma subst_term_spec_rec :
forall t1 t2 x1 n1,
  subst_term t2 x1 t1 = open_term_wrt_term_rec n1 t2 (close_term_wrt_term_rec n1 x1 t1).
Proof.
pose proof subst_term_spec_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_spec_rec : lngen.

(* end hide *)

Lemma subst_term_spec :
forall t1 t2 x1,
  subst_term t2 x1 t1 = open_term_wrt_term (close_term_wrt_term x1 t1) t2.
Proof.
unfold close_term_wrt_term; unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve subst_term_spec : lngen.

(* begin hide *)

Lemma subst_term_subst_term_mutual :
(forall t1 t2 t3 x2 x1,
  x2 `notin` fv_term t2 ->
  x2 <> x1 ->
  subst_term t2 x1 (subst_term t3 x2 t1) = subst_term (subst_term t2 x1 t3) x2 (subst_term t2 x1 t1)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_term_subst_term :
forall t1 t2 t3 x2 x1,
  x2 `notin` fv_term t2 ->
  x2 <> x1 ->
  subst_term t2 x1 (subst_term t3 x2 t1) = subst_term (subst_term t2 x1 t3) x2 (subst_term t2 x1 t1).
Proof.
pose proof subst_term_subst_term_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_subst_term : lngen.

(* begin hide *)

Lemma subst_term_close_term_wrt_term_rec_open_term_wrt_term_rec_mutual :
(forall t2 t1 x1 x2 n1,
  x2 `notin` fv_term t2 ->
  x2 `notin` fv_term t1 ->
  x2 <> x1 ->
  degree_term_wrt_term n1 t1 ->
  subst_term t1 x1 t2 = close_term_wrt_term_rec n1 x2 (subst_term t1 x1 (open_term_wrt_term_rec n1 (trm_var_f x2) t2))).
Proof.
apply_mutual_ind term_mutrec;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma subst_term_close_term_wrt_term_rec_open_term_wrt_term_rec :
forall t2 t1 x1 x2 n1,
  x2 `notin` fv_term t2 ->
  x2 `notin` fv_term t1 ->
  x2 <> x1 ->
  degree_term_wrt_term n1 t1 ->
  subst_term t1 x1 t2 = close_term_wrt_term_rec n1 x2 (subst_term t1 x1 (open_term_wrt_term_rec n1 (trm_var_f x2) t2)).
Proof.
pose proof subst_term_close_term_wrt_term_rec_open_term_wrt_term_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_close_term_wrt_term_rec_open_term_wrt_term_rec : lngen.

(* end hide *)

Lemma subst_term_close_term_wrt_term_open_term_wrt_term :
forall t2 t1 x1 x2,
  x2 `notin` fv_term t2 ->
  x2 `notin` fv_term t1 ->
  x2 <> x1 ->
  lc_term t1 ->
  subst_term t1 x1 t2 = close_term_wrt_term x2 (subst_term t1 x1 (open_term_wrt_term t2 (trm_var_f x2))).
Proof.
unfold close_term_wrt_term; unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve subst_term_close_term_wrt_term_open_term_wrt_term : lngen.

Lemma subst_term_trm_abs :
forall x2 A1 t2 t1 x1,
  lc_term t1 ->
  x2 `notin` fv_term t1 `union` fv_term t2 `union` singleton x1 ->
  subst_term t1 x1 (trm_abs A1 t2) = trm_abs (A1) (close_term_wrt_term x2 (subst_term t1 x1 (open_term_wrt_term t2 (trm_var_f x2)))).
Proof.
default_simp.
Qed.

Hint Resolve subst_term_trm_abs : lngen.

(* begin hide *)

Lemma subst_term_intro_rec_mutual :
(forall t1 x1 t2 n1,
  x1 `notin` fv_term t1 ->
  open_term_wrt_term_rec n1 t2 t1 = subst_term t2 x1 (open_term_wrt_term_rec n1 (trm_var_f x1) t1)).
Proof.
apply_mutual_ind term_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_term_intro_rec :
forall t1 x1 t2 n1,
  x1 `notin` fv_term t1 ->
  open_term_wrt_term_rec n1 t2 t1 = subst_term t2 x1 (open_term_wrt_term_rec n1 (trm_var_f x1) t1).
Proof.
pose proof subst_term_intro_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_term_intro_rec : lngen.
Hint Rewrite subst_term_intro_rec using solve [auto] : lngen.

Lemma subst_term_intro :
forall x1 t1 t2,
  x1 `notin` fv_term t1 ->
  open_term_wrt_term t1 t2 = subst_term t2 x1 (open_term_wrt_term t1 (trm_var_f x1)).
Proof.
unfold open_term_wrt_term; default_simp.
Qed.

Hint Resolve subst_term_intro : lngen.

(* *********************************************************************** *)
(** * "Restore" tactics *)

Ltac default_auto ::= auto; tauto.
Ltac default_autorewrite ::= fail.