(** * Uniform and Bernoulli CF trees using Z instead of nat. *)

Set Implicit Arguments.

From Coq Require Import
  Basics
  ClassicalChoice
  Nat
  PeanoNat
  QArith
  Lia
  Lra
  Eqdep
  Equivalence
  Reals
  String
  List
  ZArith
.

Local Open Scope program_scope.
Import ListNotations.

From zar Require Import
  cpGCL
  cpo
  cwp
  misc
  order
  pow_2
  Q
  eR
  tcwp
  tcwp_facts
  tcwp_geometric
  tree
  tactics
.

Inductive btree (A : Type) : Type :=
| BLeaf : A -> btree A
| BNode : btree A -> btree A -> btree A.

Fixpoint btree_map {A B} (f : A -> B) (t : btree A) : btree B :=
  match t with
  | BLeaf x => BLeaf (f x)
  | BNode t1 t2 => BNode (btree_map f t1) (btree_map f t2)
  end.

Fixpoint btree_infer {A} (f : A -> eR) (t : btree A) : eR :=
  match t with
  | BLeaf x => f x
  | BNode t1 t2 => Q2eR (1#2) * btree_infer f t1 + Q2eR (1#2) * btree_infer f t2
  end.

Fixpoint btree_to_tree {A} (t : btree A) : tree A :=
  match t with
  | BLeaf x => Leaf x
  | BNode t1 t2 =>
      Choice (1#2) (fun b => if b then btree_to_tree t1 else btree_to_tree t2)
  end.

Lemma twp_btree_to_tree {A} (f : A -> eR) (t : btree A) :
  twp (btree_to_tree t) f = btree_infer f t.
Proof.
  unfold twp; revert f; induction t; intro f; simpl; auto.
  rewrite IHt1, IHt2; f_equal; f_equal.
  rewrite Q2eR_one_half, eRminus_1_2; reflexivity.
Qed.

Lemma tree_unbiased_btree_to_tree {A} (t : btree A) :
  tree_unbiased (btree_to_tree t).
Proof. induction t; constructor; try reflexivity; intros []; auto. Qed.

Import Lqa.
Lemma wf_tree_btree_to_tree {A} (t : btree A) :
  wf_tree (btree_to_tree t).
Proof. induction t; constructor; try lra; intros []; auto. Qed.
Lemma wf_tree'_btree_to_tree {A} (t : btree A) :
  wf_tree' (btree_to_tree t).
Proof.
  induction t; constructor; simpl; try lra; auto; intros []; auto.
Qed.
#[global] Hint Resolve wf_tree_btree_to_tree : tree.
#[global] Hint Resolve wf_tree'_btree_to_tree : tree.
Import Lra.

(* Instead of divide list, take and drop 2^n' from the list. *)
Fixpoint list_btree_aux {A} (l : list A) (n : nat) : btree (unit + A) :=
  match n with
  | O => match l with
        | x :: _ => BLeaf (inr x)
        | _ => BLeaf (inl tt)
        end
  | S n' =>
      BNode (list_btree_aux (take (2^n') l) n')
        (list_btree_aux (drop (2^n') l) n')
  end.

Definition list_btree {A} (l : list A) : btree (unit + A) :=
  list_btree_aux l (log2 (next_pow_2 (length l))).

(** Eliminate unnecessary fails. *)
Fixpoint reduce_btree {A} (t : btree (unit + A)) : btree (unit + A) :=
  match t with
  | BNode l r => let l' := reduce_btree l in
                let r' := reduce_btree r in
                match (l', r') with
                | (BLeaf (inl tt), BLeaf (inl tt)) => BLeaf (inl tt)
                | _ => BNode l' r'
                end
  | _ => t
  end.

(** More general -- coalesce leaf nodes. *)
Fixpoint reduce_btree' {A} `{EqType A} (t : btree A) : btree A :=
  match t with
  | BNode l r =>
      let l' := reduce_btree' l in
      let r' := reduce_btree' r in
      match (l', r') with
      | (BLeaf x, BLeaf y) => if eqb x y then BLeaf x else BNode l' r'
      | _ => BNode l' r'
      end
  | _ => t
  end.

Lemma reduce_btree_infer {A} (f : unit + A -> eR) (t : btree (unit + A)) :
  btree_infer f (reduce_btree t) = btree_infer f t.
Proof.
  revert f; induction t; intro f; simpl; auto.
  destruct (reduce_btree t1) eqn:Ht1.
  - destruct s; simpl in *.
    + destruct u, (reduce_btree t2) eqn:Ht2; simpl.
      * destruct s; simpl in *.
        { destruct u; rewrite <- IHt1, <- IHt2.
          rewrite Q2eR_one_half.
          rewrite <- eRmult_2_plus.
          rewrite <- eRmult_assoc.
          rewrite <- eRmult_half_div_2.
          eRauto.
          rewrite eRmult_eRdiv_assoc.
          rewrite eRmult_div_cancel; eRauto. }
        { rewrite <- IHt1, IHt2; eRauto. }
      * rewrite <- IHt1, <- IHt2; simpl; eRauto.
    + rewrite IHt1, IHt2; reflexivity.
  - simpl; rewrite <- IHt1, IHt2; simpl; eRauto.
Qed.

Lemma reduce_btree'_infer {A} `{EqType A} (f : A -> eR) (t : btree A) :
  btree_infer f (reduce_btree' t) = btree_infer f t.
Proof.
  revert f; induction t; intro f; simpl; auto.
  destruct (reduce_btree' t1) eqn:Ht1.
  - simpl in *.
    + destruct (reduce_btree' t2) eqn:Ht2; simpl.
      * simpl in *.
        { rewrite <- IHt1, <- IHt2.
          rewrite Q2eR_one_half.
          rewrite 2!eRmult_half_div_2.
          rewrite eRplus_combine_fract.
          destruct (eqb_spec a a0); subst; simpl.
          - rewrite <- eRmult_2_plus.
            rewrite eRmult_div_cancel; eRauto.
          - rewrite Q2eR_one_half.
            rewrite 2!eRmult_half_div_2.
            rewrite eRplus_combine_fract; auto. }
      * rewrite <- IHt1, <- IHt2; simpl; eRauto.
  - simpl; rewrite <- IHt1, IHt2; simpl; eRauto.
Qed.

Fixpoint rev_range_positive (p : positive) : list Z :=
  match p with
  | xH => [Z0]
  | xO p' => List.map (Z.add (Zpos p')) (rev_range_positive p') ++ rev_range_positive p'
  | xI p' => Zpos (2 * p')%positive ::
              List.map (Z.add (Zpos p')) (rev_range_positive p') ++ rev_range_positive p'
  end.

Definition rev_range_Z (n : Z) : list Z :=
  match n with
  | Zpos p => rev_range_positive p
  | _ => []
  end.

Lemma length_rev_range_positive (p : positive) :
  length (rev_range_positive p) = Pos.to_nat p.
Proof.
  induction p; simpl; auto; rewrite app_length, map_length, IHp; lia.
Qed.

Lemma length_rev_range_Z (n : Z) :
  length (rev_range_Z n) = Z.to_nat n.
Proof.
  destruct n; simpl; auto; apply length_rev_range_positive.
Qed.

(* Definition uniform_btree (n : Z) : btree (unit + Z) := *)
(*   btree_map (sum_map id Z.of_nat) *)
(*     (reduce_btree (list_btree (rev_range (Z.to_nat n)))). *)

(** It turns out that Z.of_nat is very slow so the following
    implementation builds much more quickly than the above. *)
Definition uniform_btree (n : Z) : btree (unit + Z) :=
  reduce_btree (list_btree (rev_range_Z n)).

(* Eval compute in (uniform_btree 10). *)
(* Eval compute in (reduce_btree (uniform_btree 10)). *)

Inductive congruent {A B} : btree A -> btree B -> Prop :=
| congruent_leaf : forall x y, congruent (BLeaf x) (BLeaf y)
| congruent_node : forall t1 t1' t2 t2',
    congruent t1 t1' ->
    congruent t2 t2' ->
    congruent (BNode t1 t2) (BNode t1' t2').

Inductive perfect {A} : btree A -> Prop :=
| perfect_leaf : forall x, perfect (BLeaf x)
| perfect_choice : forall t1 t2,
    congruent t1 t2 ->
    perfect t1 ->
    perfect t2 ->
    perfect (BNode t1 t2).

Fixpoint countb {A} (f : A -> bool) (t : btree A) : nat :=
  match t with
  | BLeaf x => if f x then 1 else 0
  | BNode t1 t2 => countb f t1 + countb f t2
  end.

Lemma congruent_list_btree_aux {A} (n : nat) (l1 l2 : list A) :
  congruent (list_btree_aux l1 n) (list_btree_aux l2 n).
Proof.
  revert l1 l2; induction n; intros l1 l2; simpl.
  - destruct l1, l2; constructor.
  - constructor; auto.
Qed.

Lemma perfect_list_btree_aux {A} (n : nat) (l : list A) :
  perfect (list_btree_aux l n).
Proof.
  revert l; induction n; intros l; simpl.
  - destruct l; constructor.
  - constructor; auto; apply congruent_list_btree_aux.
Qed.

Lemma perfect_list_btree {A} (l : list A) :
  perfect (list_btree l).
Proof. apply perfect_list_btree_aux. Qed.

Lemma list_btree_aux_count {A} (n : nat) (l : list A) (f : A -> bool) :
  (length l <= 2 ^ n)%nat ->
  countb (cotuple (const false) f) (list_btree_aux l n) = countb_list f l.
Proof.
  revert l f; induction n; simpl; intros l f H0.
  - destruct l; simpl in *; auto.
    assert (l = nil).
    { apply length_zero_iff_nil; lia. }
    subst; simpl; lia.
  - rewrite Nat.add_0_r in H0.
    rewrite 2!IHn.
    + rewrite <- countb_list_app, take_drop_spec; auto.
    + etransitivity.
      { apply length_drop_le. }
      lia.
    + apply take_length.
Qed.

Lemma list_btree_count {A} (l : list A) (f : A -> bool) :
  countb (cotuple (const false) f) (list_btree l) = countb_list f l.
Proof.
  apply list_btree_aux_count.
  generalize (is_power_of_2_next_pow_2 (length l)); intros [k H0].
  rewrite <- H0, Nat.log2_pow2; try lia.
  rewrite H0; apply next_pow_2_ub.
Qed.

Lemma list_btree_aux_countb {A} (n : nat) (l : list A) :
  (length l <= 2^n)%nat ->
  countb (cotuple (const false) (const true)) (list_btree_aux l n) = length l.
Proof.
  revert l; induction n; simpl; intros l H0.
  - destruct l; simpl in *; auto; lia.
  - rewrite Nat.add_0_r in H0.
    rewrite 2!IHn.
    + rewrite <- app_length, take_drop_spec; reflexivity.
    + etransitivity.
      * apply length_drop_le.
      * lia.
    + apply take_length.
Qed.

Lemma list_btree_aux_countb' {A} (n : nat) (l : list A) :
  (length l <= 2^n)%nat ->
  countb (cotuple (const true) (const false)) (list_btree_aux l n) = (2^n - length l)%nat.
Proof.
  revert l; induction n; simpl; intros l H0.
  - destruct l; simpl in *; auto; lia.
  - rewrite Nat.add_0_r in H0.
    rewrite 2!IHn.
    +
      rewrite Nat.add_0_r.
      replace (2 ^ n - length (take (2 ^ n) l) + (2 ^ n - length (drop (2 ^ n) l)))%nat with
        (2^n + 2^n - (length (take (2^n) l) + length (drop (2^n) l)))%nat.
      2: { assert (length (take (2^n) l) <= 2^n)%nat.
           { apply take_length. }
           assert (length (drop (2^n) l) <= 2^n)%nat.
           { etransitivity.
             - apply length_drop_le.
             - lia. }
           lia. }
      rewrite <- app_length, take_drop_spec; reflexivity.
    + etransitivity.
      * apply length_drop_le.
      * lia.
    + apply take_length.
Qed.

Lemma list_btree_countb {A} (l : list A) :
  countb (cotuple (const false) (const true)) (list_btree l) = length l.
Proof.
  unfold list_btree.
  apply list_btree_aux_countb.
  generalize (is_power_of_2_next_pow_2 (length l)); intros [k H0].
  rewrite <- H0, Nat.log2_pow2; try lia.
  rewrite H0; apply next_pow_2_ub.
Qed.

Lemma countb_partition {A} (P : A -> bool) (t : btree A) :
  (countb P t + countb (fun s => negb (P s)) t = countb (const true) t)%nat.
Proof.
  revert P; induction t; intro P; simpl; auto.
  - destruct (P a); simpl; auto.
  - replace (countb P t1 + countb P t2 +
               (countb (fun s => negb (P s)) t1 +
                  countb (fun s => negb (P s)) t2))%nat with
      (countb P t1 + countb (fun s => negb (P s)) t1 +
         (countb P t2 + countb (fun s => negb (P s)) t2))%nat by lia.
    rewrite IHt1, IHt2; reflexivity.
Qed.

Lemma perfect_congruent_countb_const_true {A B} (t1 : btree A) (t2 : btree B) :
  perfect t1 ->
  perfect t2 ->
  congruent t1 t2 ->
  countb (const true) t1 = countb (const true) t2.
Proof.
  revert t2.
  induction t1; intros t2 Hp1 Hp2 Hcong;
    inv Hcong; inv Hp1; inv Hp2; simpl; auto.
Qed.

Lemma perfect_countb_nonzero {A} (t : btree A) :
  perfect t ->
  (0 < countb (const true) t)%nat.
Proof. induction 1; simpl; lia. Qed.

Lemma perfect_btree_infer {A} (f : A -> bool) (t : btree A)  :
  perfect t ->
  btree_infer (fun x => if f x then 1 else 0) t =
    INeR (countb f t) / INeR (countb (const true) t).
Proof.
  induction t; intro Hperf; simpl; inv Hperf.
  - destruct (f a); simpl.
    + eRauto; rewrite INeR_1; eRauto.
    + rewrite INeR_0, INeR_1; eRauto.
  - rewrite IHt1, IHt2; auto.
    rewrite 2!plus_INeR.
    apply perfect_congruent_countb_const_true in H1; auto.
    rewrite H1; clear H1.
    replace (Q2eR (1#2)) with (1/2).
    2: { rewrite Q2eR_one_half; reflexivity. }
    assert (H0: INeR (countb (const true) t2) <> 0).
    { apply perfect_countb_nonzero in H3.
      intro HC; replace 0 with (INeR 0) in HC by apply INeR_0.
      apply INeR_eq in HC; lia. }
    rewrite 2!eRmult_fract; auto.
    2: { eRauto. }
    2: { eRauto. }
    rewrite 2!eRmult_1_l.
    rewrite eRplus_combine_fract.
    f_equal; eRauto.
Qed.

Definition bernoulli_btree (n d : Z) : btree (unit + bool) :=
  reduce_btree' (btree_map (sum_map (fun x => x) (fun i => Z.ltb i n))
                   (uniform_btree d)).

(* Eval compute in (bernoulli_btree 1 3). *)

Definition bernoulli_tree_open (n d : Z) : tree (unit + bool) :=
  btree_to_tree (bernoulli_btree n d).

Definition bernoulli_tree (p : Q) : tree bool :=
  let t := bernoulli_tree_open (Qnum p) (Zpos (Qden p)) in
  Fix (inl tt) is_inl (fun _ => t) (cotuple (fun _ => Leaf false) (@Leaf _)).

(** TODO: could omit Fix node when n is a power of 2 (to enable more
    aggressive optimizations since Fix nodes complicate things). *)
Definition uniform_tree_open (n : Z) : tree (unit + Z) :=
  btree_to_tree (uniform_btree n).

Definition uniform_tree (n : Z) : tree Z :=
  let t := uniform_tree_open n in
  Fix (inl tt) is_inl (fun _ => t) (cotuple (fun _ => Leaf Z0) (@Leaf _)).

Lemma btree_infer_fmap_bool {A} (f : A -> bool) (g : bool -> eR) (t : btree (unit + A)) :
  btree_infer (cotuple (const 0) g) (btree_map (sum_map (fun x => x) f) t) =
    btree_infer (cotuple (const 0) (g ∘ f)) t.
Proof.
  revert f; induction t; intro f; simpl; try lra.
  - destruct a; auto.
  - rewrite IHt1, IHt2; reflexivity.
Qed.

Lemma congruent_btree_map {A B} (f : A -> B) (t1 t2 : btree A) :
  congruent t1 t2 ->
  congruent (btree_map f t1) (btree_map f t2).
Proof. induction 1; simpl; constructor; auto. Qed.

Lemma perfect_btree_map {A B} (f : A -> B) (t : btree A) :
  perfect t ->
  perfect (btree_map f t).
Proof.
  induction t; intro Ht; simpl; inv Ht; constructor; auto.
  apply congruent_btree_map; auto.
Qed.

Lemma btree_infer_btree_map {A B} (t : btree A) (f : A -> B) (g : B -> eR) :
  btree_infer g (btree_map f t) = btree_infer (g ∘ f) t.
Proof. induction t; simpl; auto; rewrite IHt1, IHt2; auto. Qed.

Lemma countb_list_all_false {A} (P : A -> bool) (l : list A) :
  Forall (is_true ∘ negb ∘ P) l ->
  countb_list P l = O.
Proof.
  induction l; simpl; unfold compose; intro Hall; auto; inv Hall.
  destr; simpl in *; try congruence; auto.
Qed.

Lemma countb_list_all_true {A} (P : A -> bool) (l : list A) :
  Forall (is_true ∘ P) l ->
  countb_list P l = length l.
Proof.
  induction l; simpl; unfold compose; intro Hall; auto; inv Hall.
  destr; simpl in *; try congruence; auto.
Qed.

Lemma forall_lt_rev_range_positive (p : positive) :
  Forall (fun x => Z.lt x (Zpos p)) (rev_range_positive p).
Proof.
  unfold compose; induction p; simpl.
  - constructor; try lia.
    apply Forall_app; split.
    + apply Forall_map; eapply Forall_impl; eauto.
      intros a Ha; simpl in Ha; lia.
    + eapply Forall_impl; eauto.
      intros a Ha; simpl in Ha; lia.
  - apply Forall_app; split.
    + apply Forall_map; eapply Forall_impl; eauto.
      intros a Ha; simpl in Ha; lia.
    + eapply Forall_impl; eauto.
      intros a Ha; simpl in Ha; lia.
  - constructor; try lia; constructor.
Qed.

Lemma Forall_impl' {A} (P Q : A -> Prop) (l : list A) :
  (forall a, In a l -> P a -> Q a) ->
  Forall P l ->
  Forall Q l.
Proof.
  induction l; intros HPQ HP; inv HP; constructor; firstorder.
Qed.

Lemma rev_range_add (n m : nat) :
  rev_range (n + m) = map (Nat.add m) (rev_range n) ++ rev_range m.
Proof.
  revert m; induction n; intro m; simpl; auto.
  rewrite Nat.add_comm; f_equal.
  rewrite <- IHn, Nat.add_comm; auto.
Qed.

Lemma rev_range_positive_rev_range (p : positive) :
  rev_range_positive p = map Z.of_nat (rev_range (Pos.to_nat p)).
Proof.
  induction p; simpl; auto.
  - rewrite IHp.
    f_equal.
    + rewrite <- positive_nat_Z; auto.
    + rewrite <- IHp.
      rewrite Pmult_nat_mult.
      replace (Pos.to_nat p * 2)%nat with (Pos.to_nat p + Pos.to_nat p)%nat by lia.
      rewrite rev_range_add, map_app, <- IHp.
      f_equal; rewrite IHp, 2!map_map.
      f_equal; ext i; lia.
  - unfold Pos.to_nat; simpl.
    rewrite Pmult_nat_mult.
    replace (Pos.to_nat p * 2)%nat with (Pos.to_nat p + Pos.to_nat p)%nat by lia.
    rewrite rev_range_add, map_app, <- IHp.
    f_equal; rewrite IHp, 2!map_map.
    f_equal; ext i; lia.
Qed.

Lemma rev_range_Z_rev_range (z : Z) :
  rev_range_Z z = map Z.of_nat (rev_range (Z.to_nat z)).
Proof.
  destruct z; simpl; auto; apply rev_range_positive_rev_range.
Qed.

Lemma in_rev_range_positive_nonnegative (n : Z) (p : positive) :
  In n (rev_range_positive p) ->
  (0 <= n)%Z.
Proof.
  revert n; induction p; simpl; intros n Hin.
  - destruct Hin as [Heq | Hin]; subst; try lia.
    apply in_app_or in Hin.
    destruct Hin as [Hin | Hin].
    + apply in_map_iff in Hin.
      destruct Hin as [x [Heq Hin]]; subst.
      apply IHp in Hin; lia.
    + apply IHp; auto.
  - apply in_app_or in Hin.
    destruct Hin as [Hin | Hin].
    + apply in_map_iff in Hin.
      destruct Hin as [x [Heq Hin]]; subst.
      apply IHp in Hin; lia.
    + apply IHp; auto.
  - lia.
Qed.

Lemma countb_list_rev_range_positive n p :
  (0 <= n < Z.pos p)%Z ->
  countb_list (Z.eqb n) (rev_range_positive p) = 1%nat.
Proof.
  revert n; induction p; intros n Hnp; simpl.
  - rewrite countb_list_app.
    destruct (Z.eqb_spec n (Zpos p~0)); subst; simpl.
    + rewrite 2!countb_list_all_false; try lia.
      * eapply Forall_impl.
        2: { apply forall_lt_rev_range_positive. }
        intros a Ha; simpl in Ha; unfold compose.
        destruct (Z.eqb_spec (Zpos p~0) a); subst; try lia.
        constructor.
      * apply Forall_map.
        eapply Forall_impl.
        2: { apply forall_lt_rev_range_positive. }
        intros a Ha; simpl in Ha; unfold compose.
        destruct (Z.eqb_spec (Zpos p~0) (Z.pos p + a)); subst; try lia.
        constructor.
    + destruct (Z.ltb_spec n (Z.pos p)).
      * rewrite countb_list_all_false; simpl.
        2: { apply Forall_map.
             eapply Forall_impl'.
             2: { apply forall_lt_rev_range_positive. }
             unfold compose.
             intros a Hin lt.
             destruct (Z.eqb_spec n (Z.pos p + a)); subst; simpl; auto.
             apply in_rev_range_positive_nonnegative in Hin; lia. }
        apply IHp; lia.
      * rewrite Nat.add_comm.
        rewrite countb_list_all_false; simpl.
        2: { eapply Forall_impl'.
             2: { apply forall_lt_rev_range_positive. }
             unfold compose.
             intros a Hin lt.
             destruct (Z.eqb_spec n a); subst; simpl; auto; lia. }
        rewrite countb_list_map.
        replace (Z.eqb n ∘ Z.add (Z.pos p)) with (Z.eqb (n - Z.pos p)).
        2: { ext i; unfold compose; lia. }
        apply IHp; lia.
  - rewrite countb_list_app.
    destruct (Z.ltb_spec n (Z.pos p)).
    * rewrite countb_list_all_false; simpl.
      2: { apply Forall_map.
           eapply Forall_impl'.
           2: { apply forall_lt_rev_range_positive. }
           unfold compose.
           intros a Hin lt.
           destruct (Z.eqb_spec n (Z.pos p + a)); subst; simpl; auto.
           apply in_rev_range_positive_nonnegative in Hin; lia. }
      apply IHp; lia.
    * rewrite Nat.add_comm.
      rewrite countb_list_all_false; simpl.
      2: { eapply Forall_impl'.
           2: { apply forall_lt_rev_range_positive. }
           unfold compose.
           intros a Hin lt.
           destruct (Z.eqb_spec n a); subst; simpl; auto; lia. }
      rewrite countb_list_map.
      replace (Z.eqb n ∘ Z.add (Z.pos p)) with (Z.eqb (n - Z.pos p)).
      2: { ext i; unfold compose; lia. }
      apply IHp; lia.
  - destruct (Z.eqb_spec n 0); subst; lia.
Qed.

Lemma countb_list_rev_range_Z n d :
  (0 <= n < d)%Z ->
  countb_list (eqb n) (rev_range_Z d) = S O.
Proof.
  intro Hnd; destruct d; simpl; try lia.
  apply countb_list_rev_range_positive; auto.
Qed.

Lemma ltb_N_nat i n :
  (i <? Z.to_nat n) = (Z.of_nat i <? n)%Z.
Proof. destruct (Nat.ltb_spec i (Z.to_nat n)); lia. Qed.

Lemma countb_list_rev_range_Z_lt n d :
  (n <= d)%Z ->
  countb_list (fun i : Z => Z.ltb i n) (rev_range_Z d) = Z.to_nat n.
Proof.
  intro Hle.
  rewrite rev_range_Z_rev_range.
  rewrite countb_list_map.
  unfold compose.
  replace (fun x : nat => (Z.of_nat x <? n)%Z) with (fun x => x <? Z.to_nat n).
  2: { ext i; apply ltb_N_nat. }
  apply countb_list_rev_range_lt; lia.
Qed.

Lemma btree_infer_uniform_btree n i :
  (0 <= i < n)%Z ->
  btree_infer (cotuple (fun _ : unit => 0) (fun x : Z => if Z.eqb x i then 1 else 0))
    (uniform_btree n) = 1 / INeR (next_pow_2 (Z.to_nat n)).
Proof.
  intro Hlt.
  unfold uniform_btree.
  (* rewrite btree_infer_btree_map. *)
  rewrite reduce_btree_infer.
  replace (cotuple (fun _ => 0) (fun x => if Z.eqb x i then 1 else 0)) with
    (fun x : unit + Z => if (match x with
                          | inl _ => false
                          | inr j => Z.eqb j i
                          end) then 1 else 0).
  2: { ext lr; destruct lr; auto. }
  rewrite perfect_btree_infer.
  2: { apply perfect_list_btree. }
  replace (fun x : unit + Z => match x with
                            | inl _ => false
                            | inr x => Z.eqb x i
                            end) with
    (cotuple (fun _ : unit => false) (Z.eqb i)).
  2: { ext x; destruct x; auto; simpl; rewrite Z.eqb_sym; reflexivity. }
  rewrite list_btree_count.
  rewrite <- countb_partition with (P := cotuple (const false) (const true)).
  rewrite list_btree_count.
  rewrite countb_list_const_true.
  replace (fun s : unit + Z => negb (cotuple (const false) (const true) s)) with
    (cotuple (fun _ : unit => true) (fun _ : Z => false)).
  2: { ext x; destruct x; auto. }
  unfold list_btree.
  rewrite list_btree_aux_countb'.
  - rewrite length_rev_range_Z.
    generalize (is_power_of_2_next_pow_2 (Z.to_nat n)).
    unfold is_power_of_2.
    intros [k H]; rewrite <- H.
    rewrite Nat.log2_pow2; try lia.
    rewrite Nat.add_comm, Nat.sub_add.
    2: { rewrite H; apply next_pow_2_ub. }
    (* rewrite <- rev_range_spec. *)
    (* replace (Z.eqb i ∘ Z.of_nat) with (Nat.eqb (Z.to_nat i)). *)
    (* 2: { ext j; unfold compose. *)
    (*      destruct (Z.eqb_spec i (Z.of_nat j)); subst. *)
    (*      - rewrite Nat2Z.id; apply Nat.eqb_refl. *)
    (*      - destruct (Nat.eqb_spec (Z.to_nat i) j); subst; lia. } *)
    rewrite countb_list_rev_range_Z; try lia.
    f_equal; apply INeR_1.
  - rewrite length_rev_range_Z.
    generalize (is_power_of_2_next_pow_2 (Z.to_nat n)).
    unfold is_power_of_2.
    intros [k H].
    rewrite <- H.
    rewrite Nat.log2_pow2; try lia.
    rewrite H.
    apply next_pow_2_ub.
  Qed.

Lemma INeR_IZeR (n : Z) :
  INeR (Z.to_nat n) = IZeR n.
Proof.
  apply eR_eq.
  destruct n; simpl; auto.
  rewrite Zmax_right; try lia.
  rewrite INR_IZR_INZ; f_equal; lia.
Qed.

Lemma btree_infer_uniform_btree_lt n d :
  (0 <= n <= d)%Z ->
  btree_infer (cotuple (fun _ : unit => 0) (fun x : Z => if Z.ltb x n then 1 else 0))
    (uniform_btree d) = IZeR n / INeR (next_pow_2 (Z.to_nat d)).
Proof.
  intro Hle.
  unfold uniform_btree.
  replace (cotuple (fun _ => 0) (fun i => if Z.ltb i n then 1 else 0)) with
    (fun x : unit + Z => if (match x with
                          | inl _ => false
                          | inr i => Z.ltb i n
                          end) then 1 else 0).
  2: { ext x; destruct x; auto. }
  rewrite reduce_btree_infer.
  rewrite perfect_btree_infer.
  - replace (fun x : unit + Z => match x with
                              | inl _ => false
                              | inr i => Z.ltb i n
                              end) with
      (cotuple (fun _ : unit => false) (fun i => Z.ltb i n)).
    2: { ext x; destruct x; auto. }
    rewrite list_btree_count.
    rewrite <- countb_partition with (P := cotuple (const false) (const true)).
    rewrite list_btree_count.
    rewrite countb_list_const_true.
    replace (fun s : unit + Z => negb (cotuple (const false) (const true) s)) with
      (cotuple (fun _ : unit => true) (fun _ : Z => false)).
    2: { ext x; destruct x; auto. }
    unfold list_btree.
    rewrite list_btree_aux_countb'.
    + rewrite length_rev_range_Z.
      generalize (is_power_of_2_next_pow_2 (Z.to_nat d)).
      unfold is_power_of_2.
      intros [k H].
      rewrite <- H.
      rewrite Nat.log2_pow2; try lia.
      rewrite Nat.add_comm, Nat.sub_add.
      2:{ rewrite H; apply next_pow_2_ub. }
      rewrite countb_list_rev_range_Z_lt; try lia.
      rewrite H, INeR_IZeR; auto.
    + rewrite length_rev_range_Z.
      generalize (is_power_of_2_next_pow_2 (Z.to_nat d)).
      unfold is_power_of_2.
      intros [k H].
      rewrite <- H.
      rewrite Nat.log2_pow2; try lia.
      rewrite H.
      apply next_pow_2_ub.
  - apply perfect_list_btree.
Qed.

Lemma btree_infer_list_btree_const_1 {A} (l : list A) :
  btree_infer (cotuple (fun _ => 0) (fun _ => 1)) (list_btree l) =
    INeR (length l) / INeR (next_pow_2 (length l)).
Proof.
  replace (cotuple (fun _ : unit => 0) (fun _ : A => 1)) with
    (fun x : unit + A => if (match x with
                             | inl _ => false
                             | inr _ => true
                             end) then 1 else 0).
  rewrite perfect_btree_infer.
  { f_equal.
    - f_equal.
      replace (fun x : unit + A => match x with
                                   | inl _ => false
                                   | inr _ => true
                                   end) with
        (cotuple (fun _ : unit => false) (fun _ : A =>  true)).
      { apply list_btree_countb. }
      ext x; destruct x; auto.
    - f_equal.
      unfold list_btree.
      rewrite <- countb_partition with (P := cotuple (const false) (const true)).
      assert (length l <= 2 ^ log2 (next_pow_2 (length l)))%nat.
      { generalize (is_power_of_2_next_pow_2 (length l)); intros [k H].
        rewrite <- H.
        rewrite Nat.log2_pow2; try lia.
        rewrite H; apply next_pow_2_ub. }
      rewrite list_btree_aux_countb; auto.
      replace (fun s : unit + A => negb (cotuple (const false) (const true) s)) with
        (cotuple (fun _ : unit => true) (fun _ : A =>  false)).
      2: { ext x; destruct x; auto. }
      rewrite list_btree_aux_countb'; auto.
      generalize (is_power_of_2_next_pow_2 (length l)); intros [k H1].
      rewrite <- H1.
      rewrite Nat.log2_pow2; try lia.
      rewrite Nat.add_comm, Nat.sub_add; auto.
      rewrite H1; apply next_pow_2_ub. }
  { apply perfect_list_btree. }
  ext x; destruct x; auto.
Qed.

Lemma btree_infer_uniform_btree_const_1 n :
  btree_infer (cotuple (fun _ => 0) (fun _ => 1)) (uniform_btree n) =
    IZeR n / INeR (next_pow_2 (Z.to_nat n)).
Proof.
  unfold uniform_btree.
  rewrite reduce_btree_infer.
  rewrite btree_infer_list_btree_const_1.
  rewrite length_rev_range_Z, INeR_IZeR; reflexivity.
Qed.

Lemma btree_infer_bernoulli_btree_n n d :
  (0 <= n <= d)%Z ->
  btree_infer (cotuple (const 0) (fun b : bool => if b then 1 else 0))
    (bernoulli_btree n d) = IZeR n / INeR (next_pow_2 (Z.to_nat d)).
Proof.
  unfold bernoulli_btree.
  intro Hnd.
  rewrite reduce_btree'_infer.
  rewrite btree_infer_fmap_bool.
  unfold compose, const.
  apply btree_infer_uniform_btree_lt; auto.
Qed.

Lemma btree_infer_uniform_btree_n n i :
  (0 <= i < n)%Z ->
  btree_infer (cotuple (const 0) (fun x : Z => if eqb x i then 1 else 0))
    (uniform_btree n) = INeR 1 / INeR (next_pow_2 (Z.to_nat n)).
Proof.
  unfold uniform_btree, compose, const; rewrite INeR_1.
  apply btree_infer_uniform_btree.
Qed.

Lemma btree_infer_bernoulli_btree_const_1 n d :
  btree_infer (cotuple (const 0) (const 1)) (bernoulli_btree n d) =
    IZeR d / INeR (next_pow_2 (Z.to_nat d)).
Proof.
  unfold bernoulli_btree.
  rewrite reduce_btree'_infer.
  rewrite btree_infer_fmap_bool.
  apply btree_infer_uniform_btree_const_1.
Qed.

Lemma simple_btree_to_tree {A} (t : btree A) :
  simple (btree_to_tree t).
Proof. induction t; constructor; intros []; auto. Qed.

Lemma btree_infer_sum_1 {A} (f : A -> eR) (t : btree A) :
  bounded f 1 ->
  btree_infer f t + btree_infer (fun a => 1 - f a) t = 1.
Proof.
  revert f; induction t; intros f Hf; simpl.
  { eRauto. }
  rewrite <- eRplus_assoc.
  rewrite eRplus_comm4.
  rewrite eRplus_assoc.
  rewrite <- 2!eRmult_plus_distr_l.
  rewrite IHt1, IHt2; auto.
  rewrite eRmult_1_r, Q2eR_one_half.
  apply eRplus_half_plus_half.
Qed.

Corollary btree_infer_complement' {A} (f : A -> eR) (t : btree A) :
  bounded f 1 ->
  btree_infer f t = 1 - btree_infer (fun a => 1 - f a) t.
Proof.
  intro Hf; apply eRplus_eq_minus.
  { eRauto. }
  rewrite eRplus_comm; apply btree_infer_sum_1; auto.
Qed.

Lemma btree_infer_const_1_bernoulli_btree_positive n d :
  (0 < d)%Z ->
  0 < btree_infer (cotuple (const 0) (const 1)) (bernoulli_btree n d).
Proof.
  intro Hlt.
  unfold bernoulli_btree.
  rewrite reduce_btree'_infer.
  rewrite btree_infer_fmap_bool.
  unfold compose.
  unfold const.
  rewrite btree_infer_uniform_btree_const_1.
  apply eRlt_0_eRdiv; eRauto.
  apply IZeR_positive; auto.
Qed.

Lemma btree_infer_const_1_uniform_btree_positive n :
  (0 < n)%Z ->
  0 < btree_infer (cotuple (const 0) (const 1)) (uniform_btree n).
Proof.
  intro Hlt.
  unfold compose.
  unfold const.
  rewrite btree_infer_uniform_btree_const_1.
  apply eRlt_0_eRdiv; eRauto.
  apply IZeR_positive; auto.
Qed.

Corollary btree_infer_bernoulli_btree_lt_1 n d :
  (0 < d)%Z ->
  btree_infer (cotuple (const 1) (const 0)) (bernoulli_btree n d) < 1.
Proof.
  intro Hd.
  rewrite btree_infer_complement'.
  2: { intros []; eRauto. }
  apply eRminus_pos_lt; eRauto.
  replace (fun a : unit + bool => 1 - cotuple (const 1) (const 0) a) with
    (cotuple (@const eR unit 0) (@const eR bool 1)).
  2: { ext lr; destruct lr; eRauto. }
  apply btree_infer_const_1_bernoulli_btree_positive; auto.
Qed.

Corollary btree_infer_uniform_btree_lt_1 n :
  (0 < n)%Z ->
  btree_infer (cotuple (const 1) (const 0)) (uniform_btree n) < 1.
Proof.
  intro Hd.
  rewrite btree_infer_complement'.
  2: { intros []; eRauto. }
  apply eRminus_pos_lt; eRauto.
  replace (fun a : unit + Z => 1 - cotuple (const 1) (const 0) a) with
    (cotuple (@const eR unit 0) (@const eR Z 1)).
  2: { ext lr; destruct lr; eRauto. }
  apply btree_infer_const_1_uniform_btree_positive; auto.
Qed.

Lemma no_fail_btree_to_tree {A} (b : btree A) :
  no_fail' (btree_to_tree b).
Proof. induction b; simpl; constructor; intros []; auto. Qed.

Lemma bernoulli_tree_twp_p (p : Q) :
  Qred p = p ->
  (0 <= p <= 1)%Q ->
  twp (bernoulli_tree p) (fun b => if b then 1 else 0) = Q2eR p.
Proof.
  intros Hp [H0p Hp0].
  unfold bernoulli_tree.
  rewrite twp_fix_iid; eauto with tree eR.
  { unfold bernoulli_tree_open.
    replace (fun s : unit + bool =>
               if is_inl s
               then 0
               else
                 twp (cotuple (fun _ : unit => Leaf false) (Leaf (A:=bool)) s)
                   (fun b : bool => if b then 1 else 0)) with
      (cotuple (@const eR unit 0) (fun x => twp (Leaf x)
                                           (fun b : bool => if b then 1 else 0))).
    2: { ext s; destruct s; simpl; auto. }
    rewrite twp_btree_to_tree.
    replace (fun s : unit + bool => if is_inl s then 1 else 0) with
      (@cotuple unit bool eR (const 1) (const 0)).
    2: { ext s; destruct s; auto. }
    rewrite twp_btree_to_tree.
    rewrite btree_infer_bernoulli_btree_n.
    2: { split.
         - apply Qnum_nonnegative; auto.
         - generalize (Q_num_le_den Hp0); lia. }
    replace (cotuple (const 1) (const 0)) with
      (fun s : unit + bool => 1 - cotuple (const 0) (const 1) s).
    2: { ext lr; destruct lr; eRauto. }
    rewrite <- btree_infer_complement'.
    2: { intros []; eRauto. }
    rewrite btree_infer_bernoulli_btree_const_1.
    rewrite eRdiv_cancel_r.
    - rewrite <- 2!INeR_IZeR.
      apply INeR_Qnum_Qden_Q2R; auto.
    - rewrite <- INeR_IZeR; apply not_0_INeR.
      generalize (Pos2Nat.is_pos (Qden p)); lia.
    - apply not_0_INeR; rewrite Z2Nat.inj_pos.
      generalize (next_pow_2_positive (Pos.to_nat (Qden p))); lia.
    - apply not_infty_INeR. }
  { intros []; constructor. }
  { unfold bernoulli_tree_open.
    replace (fun s : unit + bool => if is_inl s then 1 else 0) with
      (@cotuple unit bool eR (const 1) (const 0)).
    2: { ext s; destruct s; auto. }
    rewrite twp_btree_to_tree.
    rewrite btree_infer_complement'.
    2: { intros []; eRauto. }
    apply eRminus_pos_lt; eRauto.
    replace (fun a : unit + bool => 1 - cotuple (const 1) (const 0) a) with
      (cotuple (@const eR unit 0) (@const eR bool 1)).
    2: { ext lr; destruct lr; eRauto. }
    apply btree_infer_const_1_bernoulli_btree_positive.
    lia. }
Qed.

Lemma twp_bernoulli_tree_open_lt_1 n d :
  (0 < d)%Z ->
  twp (bernoulli_tree_open n d)
    (fun s : unit + bool => if is_inl s then 1 else 0) < 1.
Proof.
  intro Hd.
  unfold bernoulli_tree_open.
  rewrite twp_btree_to_tree.
  replace (fun s : unit + bool => if is_inl s then 1 else 0) with
    (@cotuple unit bool eR (const 1) (const 0)).
  2: { ext s; destruct s; auto. }
  apply btree_infer_bernoulli_btree_lt_1; auto.
Qed.

Lemma twp_uniform_tree_open_lt_1 n :
  (0 < n)%Z ->
  twp (uniform_tree_open n)
    (fun s : unit + Z => if is_inl s then 1 else 0) < 1.
Proof.
  intro Hd.
  replace (fun s : unit + Z => if is_inl s then 1 else 0) with
    (fun s => @cotuple unit Z eR (const 1) (const 0) s +
             cotuple (const 0) (const 0) s).
  2: { ext s; destruct s; simpl; unfold const; eRauto. }
  unfold uniform_tree_open.
  rewrite twp_plus.
  replace (cotuple (const 0) (const 0)) with (@const eR (unit + Z) 0).
  2: { ext s; destruct s; unfold const; auto. }
  unfold twp.
  rewrite twp_strict; eRauto.
  rewrite fold_twp.
  rewrite twp_btree_to_tree.
  apply btree_infer_uniform_btree_lt_1; auto.
Qed.

Lemma twpfail_uniform_tree_const_1 n :
  (0 < n)%Z ->
  twpfail (uniform_tree n) (const 1) = 1.
Proof.
  intro Hn.
  unfold twpfail.
  rewrite no_fail'_twp.
  2: { constructor; intros []; simpl; try constructor;
       apply no_fail_btree_to_tree. }
  unfold uniform_tree.
  erewrite twp_fix_iid.
  { apply eRdiv_eq_1.
    - intro HC.
      symmetry in HC.
      apply eRminus_eq_plus in HC.
      + rewrite eRplus_0_r in HC; revert HC.
        apply eRlt_neq; apply twp_uniform_tree_open_lt_1; auto.
      + eRauto.
      + apply twp_bounded.
        * apply wf_tree_btree_to_tree.
        * intro s; destr; eRauto.
    - apply eRle_infty_not_infty with (b:=1); eRauto.
    - rewrite simple_twp_twlp.
      2: { apply simple_btree_to_tree. }
      2: { unfold twp; intros []; simpl; eRauto. }
      rewrite <- no_fail'_twp with (fl:=true).
      2: { apply no_fail_btree_to_tree. }
      unfold twlp.
      rewrite twlp_twp_complement.
      2: { apply wf_tree_btree_to_tree. }
      2: { unfold twp; intros []; simpl; eRauto. }
      unfold twp; f_equal; f_equal; ext s; destruct s; simpl; eRauto. }
  { apply wf_tree_btree_to_tree. }
  { intros []; constructor. }
  { apply twp_uniform_tree_open_lt_1; auto. }
  { reflexivity. }
Qed.

Lemma twpfail_bernoulli_tree_const_1 p :
  twpfail (bernoulli_tree p) (const 1) = 1.
Proof.
  unfold twpfail.
  rewrite no_fail'_twp.
  2: { constructor; intros []; try constructor; apply no_fail_btree_to_tree. }
  unfold bernoulli_tree.
  erewrite twp_fix_iid.
  { apply eRdiv_eq_1.
    - intro HC.
      symmetry in HC.
      apply eRminus_eq_plus in HC.
      + rewrite eRplus_0_r in HC; revert HC.
        apply eRlt_neq, twp_bernoulli_tree_open_lt_1; lia.
      + eRauto.
      + apply twp_bounded.
        * apply wf_tree_btree_to_tree.
        * intro s; destr; eRauto.
    - apply eRle_infty_not_infty with (b:=1); eRauto.
    - rewrite simple_twp_twlp.
      2: { apply simple_btree_to_tree. }
      2: { unfold twp; intros []; eRauto. }
      rewrite <- no_fail'_twp with (fl:=true).
      2: { apply no_fail_btree_to_tree. }
      unfold twlp.
      rewrite twlp_twp_complement.
      2: { apply wf_tree_btree_to_tree. }
      2: { unfold twp; intros []; eRauto. }
      unfold twp; f_equal; f_equal; ext s; destruct s; eRauto. }
  { apply wf_tree_btree_to_tree. }
  { intros []; constructor. }
  { apply twp_bernoulli_tree_open_lt_1; lia. }
  { reflexivity. }
Qed.

Lemma uniform_tree_twp_twlp fl n f :
  (0 < n)%Z ->
  bounded f 1 ->
  twp_ fl (uniform_tree n) f = twlp_ fl (uniform_tree n) f.
Proof.
  intros Hn Hf.
  rewrite twlp_twp_complement; auto.
  2: { constructor; intros []; try constructor; apply wf_tree_btree_to_tree. }
  apply eRplus_eq_minus.
  { eRauto. }
  destruct fl.
  - rewrite <- twp__plus.
    etransitivity.
    2: { apply twpfail_uniform_tree_const_1; eauto. }
    unfold twpfail; f_equal.
    ext s; unfold const.
    rewrite <- eRminus_assoc; eRauto.
  - rewrite eRplus_comm.
    rewrite <- twp__plus.
    etransitivity.
    2: { apply twpfail_uniform_tree_const_1, Hn. }
    unfold twpfail; f_equal.
    ext s; unfold const; eRauto.
Qed.

Lemma bernoulli_tree_twp_twlp fl p f :
  bounded f 1 ->
  twp_ fl (bernoulli_tree p) f = twlp_ fl (bernoulli_tree p) f.
Proof.
  intro Hf.
  rewrite twlp_twp_complement; auto.
  2: { constructor; intros []; try constructor; apply wf_tree_btree_to_tree. }
  apply eRplus_eq_minus.
  { eRauto. }
  destruct fl.
  - rewrite <- twp__plus.
    etransitivity.
    2: { apply twpfail_bernoulli_tree_const_1. }
    unfold twpfail; f_equal.
    ext s; unfold const.
    rewrite <- eRminus_assoc; eRauto.
  - rewrite eRplus_comm.
    rewrite <- twp__plus.
    etransitivity.
    2: { apply twpfail_bernoulli_tree_const_1. }
    unfold twpfail; f_equal.
    ext s; unfold const; eRauto.
Qed.

Theorem twp_uniform_tree (n i : Z) :
  (0 < n)%Z ->
  (0 <= i < n)%Z ->
  twp (uniform_tree n) (fun n => if eqb n i then 1 else 0) = 1 / IZeR n.
Proof.
  intros Hn Hi.  unfold uniform_tree.
  rewrite twp_fix_iid; eauto with tree eR.
  { unfold uniform_tree_open.
    replace (fun s : unit + Z =>
     if is_inl s
     then 0
     else
      twp (cotuple (fun _ : unit => Leaf 0%Z) (Leaf (A:=Z)) s)
        (fun n0 : Z => if eqb n0 i then 1 else 0)) with
      (cotuple (@const eR unit 0) (fun n => if eqb n i then 1 else 0)).
    2: { ext s; destruct s; simpl; auto. }
    rewrite twp_btree_to_tree.
    replace (fun s : unit + Z => if is_inl s then 1 else 0) with
      (@cotuple unit Z eR (const 1) (const 0)).
    2: { ext s; destruct s; auto. }
    rewrite twp_btree_to_tree.
    rewrite btree_infer_uniform_btree_n; auto.
    replace (cotuple (const 1) (const 0)) with
      (fun s : unit + Z => 1 - cotuple (const 0) (const 1) s).
    2: { ext lr; destruct lr; eRauto. }
    rewrite <- btree_infer_complement'.
    2: { intros []; eRauto. }
    rewrite btree_infer_uniform_btree_const_1.
    rewrite eRdiv_cancel_r.
    - rewrite INeR_1; reflexivity.
    - rewrite <- INeR_IZeR; apply not_0_INeR; lia.
    - apply not_0_INeR; generalize (next_pow_2_positive (Z.to_nat n)); lia.
    - apply not_infty_INeR. }
  { destruct s; constructor. }
  { unfold uniform_tree_open.
    replace (fun s : unit + Z => if is_inl s then 1 else 0) with
      (@cotuple unit Z eR (const 1) (const 0)).
    2: { ext s; destruct s; auto. }
    rewrite twp_btree_to_tree.
    rewrite btree_infer_complement'.
    2: { intros []; eRauto. }
    apply eRminus_pos_lt; eRauto.
    replace (fun a : unit + Z => 1 - cotuple (const 1) (const 0) a) with
      (cotuple (@const eR unit 0) (@const eR Z 1)).
    2: { ext lr; destruct lr; eRauto. }
    apply btree_infer_const_1_uniform_btree_positive; auto. }
Qed.

Inductive btree_all {A} (P : A -> Prop) : btree A -> Prop :=
| btree_all_leaf : forall x, P x -> btree_all P (BLeaf x)
| btree_all_node : forall l r,
    btree_all P l ->
    btree_all P r ->
    btree_all P (BNode l r).

Inductive btree_some {A} (P : A -> Prop) : btree A -> Prop :=
| btree_some_leaf : forall x, P x -> btree_some P (BLeaf x)
| btree_some_node_l : forall l r,
    btree_some P l ->
    btree_some P (BNode l r)
| btree_some_node_r : forall l r,
    btree_some P r ->
    btree_some P (BNode l r).

Lemma btree_some_impl {A} (P Q : A -> Prop) (t : btree A) :
  (forall x, P x -> Q x) ->
  btree_some P t ->
  btree_some Q t.
Proof. induction t; intros HPQ HP; inv HP; solve [constructor; auto]. Qed.

Lemma Forall_btree_all_list_btree_aux {A} (P : A -> Prop) (l : list A) n :
  Forall P l ->
  btree_all (cotuple (const True) P) (list_btree_aux l n).
Proof.
  simpl.
  revert P l; induction n; intros P l Hl; simpl.
  - destruct l; simpl.
    + constructor; apply I.
    + constructor; inv Hl; auto.
  - constructor; eauto.
    + apply IHn, Forall_take; auto.
    + apply IHn, Forall_drop; auto.
Qed.

Lemma btree_all_tree_all_btree_to_tree {A} P (t : btree A) :
  btree_all P t ->
  tree_all P (btree_to_tree t).
Proof.
  induction t; intros Hall; inv Hall; simpl; constructor; auto.
  intros []; auto.
Qed.

Lemma btree_infer_bounded {A} (t : btree A) f ub :
  bounded f ub ->
  btree_infer f t <= ub.
Proof.
  revert f ub; induction t; intros f ub Hf; simpl; auto.
  rewrite Q2eR_one_half.
  replace (1 / 2 * btree_infer f t2) with ((1 - 1 / 2) * btree_infer f t2).
  2: { rewrite eRminus_1_2; reflexivity. }
  apply eRle_convex_sum; auto.
  cut (1 / 2 <= 2 / 2).
  { eRauto. }
  apply eRle_div; constructor; lra.
Qed.

Lemma btree_some_0_btree_infer_lt_1 {A} f (t : btree A) :
  bounded f 1 ->
  btree_some (fun x => f x = 0) t ->
  btree_infer f t < 1.
Proof.
  revert f; induction t; intros f Hf Hsome; inv Hsome; simpl.
  - rewrite H0; eRauto.
  - apply IHt1 in H0; auto.
    rewrite <- eRmult_plus_distr_l.
    apply eRmult_lt_compat_l with (c := 2).
    rewrite <- eRmult_assoc.
    replace (2 * Q2eR (1 # 2)) with 1.
    2: { unfold eRmult; simpl; apply eR_eq; compute; lra. }
    rewrite eRmult_1_l.
    replace (2 * 1) with (1 + 1).
    2: { apply eR_eq; lra. }
    eapply btree_infer_bounded in Hf.
    apply eRplus_lt_compat; eauto with eR.
  - apply IHt2 in H0; auto.
    rewrite <- eRmult_plus_distr_l.
    apply eRmult_lt_compat_l with (c := 2).
    rewrite <- eRmult_assoc.
    replace (2 * Q2eR (1 # 2)) with 1.
    2: { unfold eRmult; simpl; apply eR_eq; compute; lra. }
    rewrite eRmult_1_l.
    replace (2 * 1) with (1 + 1).
    2: { apply eR_eq; lra. }
    eapply btree_infer_bounded in Hf.
    rewrite eRplus_comm.
    apply eRplus_lt_compat; eauto with eR.
Qed.

Lemma reduce_btree_all {A} (t : btree (unit + A)) P :
  btree_all (cotuple (const True) P) t ->
  btree_all (cotuple (const True) P) (reduce_btree t).
Proof.
  revert P; induction t; intros P Ht; inv Ht; simpl.
  { constructor; auto. }
  destruct (reduce_btree t1) eqn:Ht1.
  - destruct s.
    + destruct u.
      destruct (reduce_btree t2) eqn:Ht2.
      * destruct s.
        { destruct u; constructor; apply I. }
        constructor; auto.
      * constructor; auto.
    + constructor; auto.
  - constructor; auto.
Qed.

Lemma btree_some_reduce_btree' {A} `{EqType A} P (t : btree A) :
  btree_some P t ->
  btree_some P (reduce_btree' t).
Proof.
  induction t; intro Ht; simpl; auto; inv Ht.
  - destruct (reduce_btree' t1) eqn:Ht1.
    + destruct (reduce_btree' t2) eqn:Ht2.
      * destr; auto; constructor; auto.
      * constructor; auto.
    + constructor; auto.
  - destruct (reduce_btree' t1) eqn:Ht1.
    + destruct (reduce_btree' t2) eqn:Ht2.
      * destruct (eqb_spec a a0); subst; auto.
        apply btree_some_node_r; auto.
      * apply btree_some_node_r; auto.
    + apply btree_some_node_r; auto.
Qed.

Lemma btree_some_btree_map {A B} (P : B -> Prop) (f : A -> B) (t : btree A) :
  btree_some (P ∘ f) t ->
  btree_some P (btree_map f t).
Proof.
  induction t; intro Hsome; simpl; inv Hsome; solve [constructor; auto].
Qed.

Lemma btree_some_is_inr_list_btree_aux {A} (l : list A) (n : nat) :
  l <> nil ->
  btree_some (fun x : unit + A => is_true (is_inr x)) (list_btree_aux l n).
Proof.
  revert l; induction n; intros l Hl; simpl; destruct l; try congruence.
  - constructor; auto.
  - constructor.
    apply IHn.
    apply take_not_nil; auto.
    apply pow_positive; lia.
Qed.

Lemma btree_some_is_inr_list_btree {A} (l : list A) :
  l <> nil ->
  btree_some (fun x : unit + A => is_true (is_inr x)) (list_btree l).
Proof. apply btree_some_is_inr_list_btree_aux; auto. Qed.

Lemma countb_btree_map {A B} (f : B -> bool) (g : A -> B) (t : btree A) :
  countb f (btree_map g t) = countb (f ∘ g) t.
Proof. unfold compose; induction t; simpl; auto. Qed.

Lemma countb_true_list_btree_aux_pow_2 {A} (l : list A) (k : nat) :
  countb (const true) (list_btree_aux l k) = (2 ^ k)%nat.
Proof.
  revert l; induction k; intro l; simpl.
  { destruct l; auto. }
  rewrite 2!IHk; lia.
Qed.

Lemma countb_length_list_btree {A} (l : list A) :
  countb (const true) (list_btree l) = next_pow_2 (length l).
Proof.
  unfold list_btree.
  simpl.
  generalize (is_power_of_2_next_pow_2 (length l)).
  intros [k Hk].
  rewrite <- Hk.
  rewrite Nat.log2_pow2; try lia.
  apply countb_true_list_btree_aux_pow_2.
Qed.

Lemma countb_list_btree_aux_le_pow_2 {A} P (l : list A) n :
  (countb P (list_btree_aux l n) <= 2^n)%nat.
Proof.
  revert l; induction n; intro l; simpl.
  - destruct l; simpl; destr; lia.
  - rewrite Nat.add_0_r.
    pose proof (IHn (take (2^n) l)).
    specialize (IHn (drop (2^n) l)); lia.
Qed.

Lemma no_fail_uniform_tree (n : Z) :
  no_fail' (uniform_tree n).
Proof.
  constructor.
  - intros; apply no_fail_btree_to_tree.
  - intros []; constructor.
Qed.

Lemma no_fail_bernoulli_tree (p : Q) :
  no_fail' (bernoulli_tree p).
Proof.
  constructor.
  - intros; apply no_fail_btree_to_tree.
  - intros []; constructor.
Qed.

Lemma wf_tree_uniform_tree (n : Z) :
  wf_tree (uniform_tree n).
Proof.
  constructor.
  - intros; apply wf_tree_btree_to_tree.
  - intros []; constructor.
Qed.

Lemma wf_tree_bernoulli_tree (p : Q) :
  wf_tree (bernoulli_tree p).
Proof.
  constructor.
  - intros; apply wf_tree_btree_to_tree.
  - intros []; constructor.
Qed.

Lemma twlp_const_1_uniform_tree (n : Z) :
  twlp (uniform_tree n) (const 1) = 1.
Proof.
  rewrite twlp_fail.
  { rewrite no_fail_twlp; eRauto.
    apply no_fail_uniform_tree. }
  apply wf_tree_uniform_tree.
Qed.

Lemma twlp_const_1_bernoulli_tree (p : Q) :
  twlp (bernoulli_tree p) (const 1) = 1.
Proof.
  rewrite twlp_fail.
  { rewrite no_fail_twlp; eRauto.
    apply no_fail_bernoulli_tree. }
  apply wf_tree_bernoulli_tree.
Qed.

Lemma tree_unbiased_uniform_tree (n : Z) :
  tree_unbiased (uniform_tree n).
Proof.
  constructor.
  - intros; apply tree_unbiased_btree_to_tree.
  - intros []; constructor.
Qed.

Lemma tree_unbiased_bernoulli_tree (p : Q) :
  tree_unbiased (bernoulli_tree p).
Proof.
  constructor.
  - intros; apply tree_unbiased_btree_to_tree.
  - intros []; constructor.
Qed.


Require Import AutoSep.
Require Import TimeAbstract.

(** Factorial is mandatory, isn't it? *)

Inductive factR : W -> W -> Prop :=
| FR0 : factR 0 1
| FRS : forall w r : W, w <> 0 -> factR (w ^- $1) r -> factR w (w ^* r).

Lemma FR0' : forall w : W, w = 0 -> factR w $1.
  intros; subst; apply FR0.
Qed.

Lemma FRS' : forall w r v : W, w <> 0 -> factR (w ^- $1) r -> v = w ^* r -> factR w v.
  intros; subst; eapply FRS; eauto.
Qed.

Hint Resolve FR0' FRS'.

Definition factS : spec := SPEC("n") reserving 1
  PRE[V] Emp
  POST[R] [| factR (V "n") R |].

Definition fact := bmodule "fact" {{
  bfunction "fact"("n", "acc") [factS]
    "acc" <- 1;;

    [PRE[V] Emp
     POST[R] [| exists r, factR (V "n") r /\ R = V "acc" ^* r |] ]
    While ("n" <> 0) {
      "acc" <- "n" * "acc";;
      "n" <- "n" - 1
    };;

    Return "acc"
  end
}}.

Lemma times_1 : forall (n m x : W), factR n x
  -> m = $1 ^* x
  -> factR n m.
  intros; subst; replace ($1 ^* x) with x by W_eq; auto.
Qed.

Hint Resolve times_1.

Theorem factOk : moduleOk fact.
(*TIME  Clear Timing Profile. *)
(*TIME  (time "vcgen:all" *) vcgen
(*TIME ) *); time_abstract ltac:(sep_auto; eauto; words).
(*TIME  Print Timing Profile. *)
Qed.

Definition factDriver := bimport [[ "fact"!"fact" @ [factS] ]]
  bmodule "factDriver" {{
    bfunction "main"("x") [SPEC reserving 4
      PRE[_] Emp
      POST[R] [| R = $24 |] ]
      "x" <-- Call "fact"!"fact"(4)
      [PRE[_, R] Emp
       POST[R'] [| R' = R |]];;
      Return "x"
    end
  }}.

Theorem factR_4 : forall r, factR 4 r -> r = 24.
  intros;
    repeat match goal with
             | [ H : factR _ _ |- _ ] => inversion H; clear H; subst; []
           end;
    match goal with
      | [ H : factR _ _ |- _ ] => inversion H; clear H; subst; [ reflexivity
        | elimtype False; match goal with
                            | [ H : _ |- _ ] => apply H; reflexivity
                          end ]
    end.
Qed.

Hint Resolve factR_4.

Theorem factDriverOk : moduleOk factDriver.
(*TIME  Clear Timing Profile. *)
(*TIME  (time "vcgen:all" *) vcgen
(*TIME ) *); time_abstract ltac:(sep_auto; words).
(*TIME  Print Timing Profile. *)
Qed.

Definition factProg := link fact factDriver.

Theorem factProgOk : moduleOk factProg.
  link factOk factDriverOk.
Qed.


Require Import core fintype.

Require Import core_axioms fintype_axioms.
Require Import Setoid Morphisms Relation_Definitions.

Module renSubst.

Inductive tm (n_tm : nat) : Type :=
  | var_tm : fin n_tm -> tm n_tm
  | app : tm n_tm -> tm n_tm -> tm n_tm
  | lam : tm (S n_tm) -> tm n_tm
  | pair : tm n_tm -> tm n_tm -> tm n_tm
  | matchpair : tm n_tm -> tm (S (S n_tm)) -> tm n_tm.

Lemma congr_app {m_tm : nat} {s0 : tm m_tm} {s1 : tm m_tm} {t0 : tm m_tm}
  {t1 : tm m_tm} (H0 : s0 = t0) (H1 : s1 = t1) :
  app m_tm s0 s1 = app m_tm t0 t1.
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => app m_tm x s1) H0))
         (ap (fun x => app m_tm t0 x) H1)).
Qed.

Lemma congr_lam {m_tm : nat} {s0 : tm (S m_tm)} {t0 : tm (S m_tm)}
  (H0 : s0 = t0) : lam m_tm s0 = lam m_tm t0.
Proof.
exact (eq_trans eq_refl (ap (fun x => lam m_tm x) H0)).
Qed.

Lemma congr_pair {m_tm : nat} {s0 : tm m_tm} {s1 : tm m_tm} {t0 : tm m_tm}
  {t1 : tm m_tm} (H0 : s0 = t0) (H1 : s1 = t1) :
  pair m_tm s0 s1 = pair m_tm t0 t1.
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => pair m_tm x s1) H0))
         (ap (fun x => pair m_tm t0 x) H1)).
Qed.

Lemma congr_matchpair {m_tm : nat} {s0 : tm m_tm} {s1 : tm (S (S m_tm))}
  {t0 : tm m_tm} {t1 : tm (S (S m_tm))} (H0 : s0 = t0) (H1 : s1 = t1) :
  matchpair m_tm s0 s1 = matchpair m_tm t0 t1.
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => matchpair m_tm x s1) H0))
         (ap (fun x => matchpair m_tm t0 x) H1)).
Qed.

Lemma upRen_tm_tm {m : nat} {n : nat} (xi : fin m -> fin n) :
  fin (S m) -> fin (S n).
Proof.
exact (up_ren xi).
Defined.

Lemma upRen_list_tm_tm (p : nat) {m : nat} {n : nat} (xi : fin m -> fin n) :
  fin (plus p m) -> fin (plus p n).
Proof.
exact (upRen_p p xi).
Defined.

Fixpoint ren_tm {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm)
(s : tm m_tm) {struct s} : tm n_tm :=
  match s with
  | var_tm _ s0 => var_tm n_tm (xi_tm s0)
  | app _ s0 s1 => app n_tm (ren_tm xi_tm s0) (ren_tm xi_tm s1)
  | lam _ s0 => lam n_tm (ren_tm (upRen_tm_tm xi_tm) s0)
  | pair _ s0 s1 => pair n_tm (ren_tm xi_tm s0) (ren_tm xi_tm s1)
  | matchpair _ s0 s1 =>
      matchpair n_tm (ren_tm xi_tm s0)
        (ren_tm (upRen_tm_tm (upRen_tm_tm xi_tm)) s1)
  end.

Lemma up_tm_tm {m : nat} {n_tm : nat} (sigma : fin m -> tm n_tm) :
  fin (S m) -> tm (S n_tm).
Proof.
exact (scons (var_tm (S n_tm) var_zero) (funcomp (ren_tm shift) sigma)).
Defined.

Lemma up_list_tm_tm (p : nat) {m : nat} {n_tm : nat}
  (sigma : fin m -> tm n_tm) : fin (plus p m) -> tm (plus p n_tm).
Proof.
exact (scons_p p (funcomp (var_tm (plus p n_tm)) (zero_p p))
         (funcomp (ren_tm (shift_p p)) sigma)).
Defined.

Fixpoint subst_tm {m_tm : nat} {n_tm : nat} (sigma_tm : fin m_tm -> tm n_tm)
(s : tm m_tm) {struct s} : tm n_tm :=
  match s with
  | var_tm _ s0 => sigma_tm s0
  | app _ s0 s1 => app n_tm (subst_tm sigma_tm s0) (subst_tm sigma_tm s1)
  | lam _ s0 => lam n_tm (subst_tm (up_tm_tm sigma_tm) s0)
  | pair _ s0 s1 => pair n_tm (subst_tm sigma_tm s0) (subst_tm sigma_tm s1)
  | matchpair _ s0 s1 =>
      matchpair n_tm (subst_tm sigma_tm s0)
        (subst_tm (up_tm_tm (up_tm_tm sigma_tm)) s1)
  end.

Lemma upId_tm_tm {m_tm : nat} (sigma : fin m_tm -> tm m_tm)
  (Eq : forall x, sigma x = var_tm m_tm x) :
  forall x, up_tm_tm sigma x = var_tm (S m_tm) x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n => ap (ren_tm shift) (Eq fin_n)
       | None => eq_refl
       end).
Qed.

Lemma upId_list_tm_tm {p : nat} {m_tm : nat} (sigma : fin m_tm -> tm m_tm)
  (Eq : forall x, sigma x = var_tm m_tm x) :
  forall x, up_list_tm_tm p sigma x = var_tm (plus p m_tm) x.
Proof.
exact (fun n =>
       scons_p_eta (var_tm (plus p m_tm))
         (fun n => ap (ren_tm (shift_p p)) (Eq n)) (fun n => eq_refl)).
Qed.

Fixpoint idSubst_tm {m_tm : nat} (sigma_tm : fin m_tm -> tm m_tm)
(Eq_tm : forall x, sigma_tm x = var_tm m_tm x) (s : tm m_tm) {struct s} :
subst_tm sigma_tm s = s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (idSubst_tm sigma_tm Eq_tm s0) (idSubst_tm sigma_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam (idSubst_tm (up_tm_tm sigma_tm) (upId_tm_tm _ Eq_tm) s0)
  | pair _ s0 s1 =>
      congr_pair (idSubst_tm sigma_tm Eq_tm s0)
        (idSubst_tm sigma_tm Eq_tm s1)
  | matchpair _ s0 s1 =>
      congr_matchpair (idSubst_tm sigma_tm Eq_tm s0)
        (idSubst_tm (up_tm_tm (up_tm_tm sigma_tm))
           (upId_tm_tm _ (upId_tm_tm _ Eq_tm)) s1)
  end.

Lemma upExtRen_tm_tm {m : nat} {n : nat} (xi : fin m -> fin n)
  (zeta : fin m -> fin n) (Eq : forall x, xi x = zeta x) :
  forall x, upRen_tm_tm xi x = upRen_tm_tm zeta x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n => ap shift (Eq fin_n)
       | None => eq_refl
       end).
Qed.

Lemma upExtRen_list_tm_tm {p : nat} {m : nat} {n : nat} (xi : fin m -> fin n)
  (zeta : fin m -> fin n) (Eq : forall x, xi x = zeta x) :
  forall x, upRen_list_tm_tm p xi x = upRen_list_tm_tm p zeta x.
Proof.
exact (fun n =>
       scons_p_congr (fun n => eq_refl) (fun n => ap (shift_p p) (Eq n))).
Qed.

Fixpoint extRen_tm {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm)
(zeta_tm : fin m_tm -> fin n_tm) (Eq_tm : forall x, xi_tm x = zeta_tm x)
(s : tm m_tm) {struct s} : ren_tm xi_tm s = ren_tm zeta_tm s :=
  match s with
  | var_tm _ s0 => ap (var_tm n_tm) (Eq_tm s0)
  | app _ s0 s1 =>
      congr_app (extRen_tm xi_tm zeta_tm Eq_tm s0)
        (extRen_tm xi_tm zeta_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (extRen_tm (upRen_tm_tm xi_tm) (upRen_tm_tm zeta_tm)
           (upExtRen_tm_tm _ _ Eq_tm) s0)
  | pair _ s0 s1 =>
      congr_pair (extRen_tm xi_tm zeta_tm Eq_tm s0)
        (extRen_tm xi_tm zeta_tm Eq_tm s1)
  | matchpair _ s0 s1 =>
      congr_matchpair (extRen_tm xi_tm zeta_tm Eq_tm s0)
        (extRen_tm (upRen_tm_tm (upRen_tm_tm xi_tm))
           (upRen_tm_tm (upRen_tm_tm zeta_tm))
           (upExtRen_tm_tm _ _ (upExtRen_tm_tm _ _ Eq_tm)) s1)
  end.

Lemma upExt_tm_tm {m : nat} {n_tm : nat} (sigma : fin m -> tm n_tm)
  (tau : fin m -> tm n_tm) (Eq : forall x, sigma x = tau x) :
  forall x, up_tm_tm sigma x = up_tm_tm tau x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n => ap (ren_tm shift) (Eq fin_n)
       | None => eq_refl
       end).
Qed.

Lemma upExt_list_tm_tm {p : nat} {m : nat} {n_tm : nat}
  (sigma : fin m -> tm n_tm) (tau : fin m -> tm n_tm)
  (Eq : forall x, sigma x = tau x) :
  forall x, up_list_tm_tm p sigma x = up_list_tm_tm p tau x.
Proof.
exact (fun n =>
       scons_p_congr (fun n => eq_refl)
         (fun n => ap (ren_tm (shift_p p)) (Eq n))).
Qed.

Fixpoint ext_tm {m_tm : nat} {n_tm : nat} (sigma_tm : fin m_tm -> tm n_tm)
(tau_tm : fin m_tm -> tm n_tm) (Eq_tm : forall x, sigma_tm x = tau_tm x)
(s : tm m_tm) {struct s} : subst_tm sigma_tm s = subst_tm tau_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (ext_tm sigma_tm tau_tm Eq_tm s0)
        (ext_tm sigma_tm tau_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (ext_tm (up_tm_tm sigma_tm) (up_tm_tm tau_tm) (upExt_tm_tm _ _ Eq_tm)
           s0)
  | pair _ s0 s1 =>
      congr_pair (ext_tm sigma_tm tau_tm Eq_tm s0)
        (ext_tm sigma_tm tau_tm Eq_tm s1)
  | matchpair _ s0 s1 =>
      congr_matchpair (ext_tm sigma_tm tau_tm Eq_tm s0)
        (ext_tm (up_tm_tm (up_tm_tm sigma_tm)) (up_tm_tm (up_tm_tm tau_tm))
           (upExt_tm_tm _ _ (upExt_tm_tm _ _ Eq_tm)) s1)
  end.

Lemma up_ren_ren_tm_tm {k : nat} {l : nat} {m : nat} (xi : fin k -> fin l)
  (zeta : fin l -> fin m) (rho : fin k -> fin m)
  (Eq : forall x, funcomp zeta xi x = rho x) :
  forall x, funcomp (upRen_tm_tm zeta) (upRen_tm_tm xi) x = upRen_tm_tm rho x.
Proof.
exact (up_ren_ren xi zeta rho Eq).
Qed.

Lemma up_ren_ren_list_tm_tm {p : nat} {k : nat} {l : nat} {m : nat}
  (xi : fin k -> fin l) (zeta : fin l -> fin m) (rho : fin k -> fin m)
  (Eq : forall x, funcomp zeta xi x = rho x) :
  forall x,
  funcomp (upRen_list_tm_tm p zeta) (upRen_list_tm_tm p xi) x =
  upRen_list_tm_tm p rho x.
Proof.
exact (up_ren_ren_p Eq).
Qed.

Fixpoint compRenRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(xi_tm : fin m_tm -> fin k_tm) (zeta_tm : fin k_tm -> fin l_tm)
(rho_tm : fin m_tm -> fin l_tm)
(Eq_tm : forall x, funcomp zeta_tm xi_tm x = rho_tm x) (s : tm m_tm) {struct
 s} : ren_tm zeta_tm (ren_tm xi_tm s) = ren_tm rho_tm s :=
  match s with
  | var_tm _ s0 => ap (var_tm l_tm) (Eq_tm s0)
  | app _ s0 s1 =>
      congr_app (compRenRen_tm xi_tm zeta_tm rho_tm Eq_tm s0)
        (compRenRen_tm xi_tm zeta_tm rho_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (compRenRen_tm (upRen_tm_tm xi_tm) (upRen_tm_tm zeta_tm)
           (upRen_tm_tm rho_tm) (up_ren_ren _ _ _ Eq_tm) s0)
  | pair _ s0 s1 =>
      congr_pair (compRenRen_tm xi_tm zeta_tm rho_tm Eq_tm s0)
        (compRenRen_tm xi_tm zeta_tm rho_tm Eq_tm s1)
  | matchpair _ s0 s1 =>
      congr_matchpair (compRenRen_tm xi_tm zeta_tm rho_tm Eq_tm s0)
        (compRenRen_tm (upRen_tm_tm (upRen_tm_tm xi_tm))
           (upRen_tm_tm (upRen_tm_tm zeta_tm))
           (upRen_tm_tm (upRen_tm_tm rho_tm))
           (up_ren_ren _ _ _ (up_ren_ren _ _ _ Eq_tm)) s1)
  end.

Lemma up_ren_subst_tm_tm {k : nat} {l : nat} {m_tm : nat}
  (xi : fin k -> fin l) (tau : fin l -> tm m_tm) (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp tau xi x = theta x) :
  forall x, funcomp (up_tm_tm tau) (upRen_tm_tm xi) x = up_tm_tm theta x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n => ap (ren_tm shift) (Eq fin_n)
       | None => eq_refl
       end).
Qed.

Lemma up_ren_subst_list_tm_tm {p : nat} {k : nat} {l : nat} {m_tm : nat}
  (xi : fin k -> fin l) (tau : fin l -> tm m_tm) (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp tau xi x = theta x) :
  forall x,
  funcomp (up_list_tm_tm p tau) (upRen_list_tm_tm p xi) x =
  up_list_tm_tm p theta x.
Proof.
exact (fun n =>
       eq_trans (scons_p_comp' _ _ _ n)
         (scons_p_congr (fun z => scons_p_head' _ _ z)
            (fun z =>
             eq_trans (scons_p_tail' _ _ (xi z))
               (ap (ren_tm (shift_p p)) (Eq z))))).
Qed.

Fixpoint compRenSubst_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(xi_tm : fin m_tm -> fin k_tm) (tau_tm : fin k_tm -> tm l_tm)
(theta_tm : fin m_tm -> tm l_tm)
(Eq_tm : forall x, funcomp tau_tm xi_tm x = theta_tm x) (s : tm m_tm) {struct
 s} : subst_tm tau_tm (ren_tm xi_tm s) = subst_tm theta_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (compRenSubst_tm xi_tm tau_tm theta_tm Eq_tm s0)
        (compRenSubst_tm xi_tm tau_tm theta_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (compRenSubst_tm (upRen_tm_tm xi_tm) (up_tm_tm tau_tm)
           (up_tm_tm theta_tm) (up_ren_subst_tm_tm _ _ _ Eq_tm) s0)
  | pair _ s0 s1 =>
      congr_pair (compRenSubst_tm xi_tm tau_tm theta_tm Eq_tm s0)
        (compRenSubst_tm xi_tm tau_tm theta_tm Eq_tm s1)
  | matchpair _ s0 s1 =>
      congr_matchpair (compRenSubst_tm xi_tm tau_tm theta_tm Eq_tm s0)
        (compRenSubst_tm (upRen_tm_tm (upRen_tm_tm xi_tm))
           (up_tm_tm (up_tm_tm tau_tm)) (up_tm_tm (up_tm_tm theta_tm))
           (up_ren_subst_tm_tm _ _ _ (up_ren_subst_tm_tm _ _ _ Eq_tm)) s1)
  end.

Lemma up_subst_ren_tm_tm {k : nat} {l_tm : nat} {m_tm : nat}
  (sigma : fin k -> tm l_tm) (zeta_tm : fin l_tm -> fin m_tm)
  (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp (ren_tm zeta_tm) sigma x = theta x) :
  forall x,
  funcomp (ren_tm (upRen_tm_tm zeta_tm)) (up_tm_tm sigma) x =
  up_tm_tm theta x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n =>
           eq_trans
             (compRenRen_tm shift (upRen_tm_tm zeta_tm)
                (funcomp shift zeta_tm) (fun x => eq_refl) (sigma fin_n))
             (eq_trans
                (eq_sym
                   (compRenRen_tm zeta_tm shift (funcomp shift zeta_tm)
                      (fun x => eq_refl) (sigma fin_n)))
                (ap (ren_tm shift) (Eq fin_n)))
       | None => eq_refl
       end).
Qed.

Lemma up_subst_ren_list_tm_tm {p : nat} {k : nat} {l_tm : nat} {m_tm : nat}
  (sigma : fin k -> tm l_tm) (zeta_tm : fin l_tm -> fin m_tm)
  (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp (ren_tm zeta_tm) sigma x = theta x) :
  forall x,
  funcomp (ren_tm (upRen_list_tm_tm p zeta_tm)) (up_list_tm_tm p sigma) x =
  up_list_tm_tm p theta x.
Proof.
exact (fun n =>
       eq_trans (scons_p_comp' _ _ _ n)
         (scons_p_congr
            (fun x => ap (var_tm (plus p m_tm)) (scons_p_head' _ _ x))
            (fun n =>
             eq_trans
               (compRenRen_tm (shift_p p) (upRen_list_tm_tm p zeta_tm)
                  (funcomp (shift_p p) zeta_tm)
                  (fun x => scons_p_tail' _ _ x) (sigma n))
               (eq_trans
                  (eq_sym
                     (compRenRen_tm zeta_tm (shift_p p)
                        (funcomp (shift_p p) zeta_tm) (fun x => eq_refl)
                        (sigma n))) (ap (ren_tm (shift_p p)) (Eq n)))))).
Qed.

Fixpoint compSubstRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(sigma_tm : fin m_tm -> tm k_tm) (zeta_tm : fin k_tm -> fin l_tm)
(theta_tm : fin m_tm -> tm l_tm)
(Eq_tm : forall x, funcomp (ren_tm zeta_tm) sigma_tm x = theta_tm x)
(s : tm m_tm) {struct s} :
ren_tm zeta_tm (subst_tm sigma_tm s) = subst_tm theta_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (compSubstRen_tm sigma_tm zeta_tm theta_tm Eq_tm s0)
        (compSubstRen_tm sigma_tm zeta_tm theta_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (compSubstRen_tm (up_tm_tm sigma_tm) (upRen_tm_tm zeta_tm)
           (up_tm_tm theta_tm) (up_subst_ren_tm_tm _ _ _ Eq_tm) s0)
  | pair _ s0 s1 =>
      congr_pair (compSubstRen_tm sigma_tm zeta_tm theta_tm Eq_tm s0)
        (compSubstRen_tm sigma_tm zeta_tm theta_tm Eq_tm s1)
  | matchpair _ s0 s1 =>
      congr_matchpair (compSubstRen_tm sigma_tm zeta_tm theta_tm Eq_tm s0)
        (compSubstRen_tm (up_tm_tm (up_tm_tm sigma_tm))
           (upRen_tm_tm (upRen_tm_tm zeta_tm)) (up_tm_tm (up_tm_tm theta_tm))
           (up_subst_ren_tm_tm _ _ _ (up_subst_ren_tm_tm _ _ _ Eq_tm)) s1)
  end.

Lemma up_subst_subst_tm_tm {k : nat} {l_tm : nat} {m_tm : nat}
  (sigma : fin k -> tm l_tm) (tau_tm : fin l_tm -> tm m_tm)
  (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp (subst_tm tau_tm) sigma x = theta x) :
  forall x,
  funcomp (subst_tm (up_tm_tm tau_tm)) (up_tm_tm sigma) x = up_tm_tm theta x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n =>
           eq_trans
             (compRenSubst_tm shift (up_tm_tm tau_tm)
                (funcomp (up_tm_tm tau_tm) shift) (fun x => eq_refl)
                (sigma fin_n))
             (eq_trans
                (eq_sym
                   (compSubstRen_tm tau_tm shift
                      (funcomp (ren_tm shift) tau_tm) (fun x => eq_refl)
                      (sigma fin_n))) (ap (ren_tm shift) (Eq fin_n)))
       | None => eq_refl
       end).
Qed.

Lemma up_subst_subst_list_tm_tm {p : nat} {k : nat} {l_tm : nat} {m_tm : nat}
  (sigma : fin k -> tm l_tm) (tau_tm : fin l_tm -> tm m_tm)
  (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp (subst_tm tau_tm) sigma x = theta x) :
  forall x,
  funcomp (subst_tm (up_list_tm_tm p tau_tm)) (up_list_tm_tm p sigma) x =
  up_list_tm_tm p theta x.
Proof.
exact (fun n =>
       eq_trans
         (scons_p_comp' (funcomp (var_tm (plus p l_tm)) (zero_p p)) _ _ n)
         (scons_p_congr
            (fun x => scons_p_head' _ (fun z => ren_tm (shift_p p) _) x)
            (fun n =>
             eq_trans
               (compRenSubst_tm (shift_p p) (up_list_tm_tm p tau_tm)
                  (funcomp (up_list_tm_tm p tau_tm) (shift_p p))
                  (fun x => eq_refl) (sigma n))
               (eq_trans
                  (eq_sym
                     (compSubstRen_tm tau_tm (shift_p p) _
                        (fun x => eq_sym (scons_p_tail' _ _ x)) (sigma n)))
                  (ap (ren_tm (shift_p p)) (Eq n)))))).
Qed.

Fixpoint compSubstSubst_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(sigma_tm : fin m_tm -> tm k_tm) (tau_tm : fin k_tm -> tm l_tm)
(theta_tm : fin m_tm -> tm l_tm)
(Eq_tm : forall x, funcomp (subst_tm tau_tm) sigma_tm x = theta_tm x)
(s : tm m_tm) {struct s} :
subst_tm tau_tm (subst_tm sigma_tm s) = subst_tm theta_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (compSubstSubst_tm sigma_tm tau_tm theta_tm Eq_tm s0)
        (compSubstSubst_tm sigma_tm tau_tm theta_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (compSubstSubst_tm (up_tm_tm sigma_tm) (up_tm_tm tau_tm)
           (up_tm_tm theta_tm) (up_subst_subst_tm_tm _ _ _ Eq_tm) s0)
  | pair _ s0 s1 =>
      congr_pair (compSubstSubst_tm sigma_tm tau_tm theta_tm Eq_tm s0)
        (compSubstSubst_tm sigma_tm tau_tm theta_tm Eq_tm s1)
  | matchpair _ s0 s1 =>
      congr_matchpair (compSubstSubst_tm sigma_tm tau_tm theta_tm Eq_tm s0)
        (compSubstSubst_tm (up_tm_tm (up_tm_tm sigma_tm))
           (up_tm_tm (up_tm_tm tau_tm)) (up_tm_tm (up_tm_tm theta_tm))
           (up_subst_subst_tm_tm _ _ _ (up_subst_subst_tm_tm _ _ _ Eq_tm)) s1)
  end.

Lemma rinstInst_up_tm_tm {m : nat} {n_tm : nat} (xi : fin m -> fin n_tm)
  (sigma : fin m -> tm n_tm)
  (Eq : forall x, funcomp (var_tm n_tm) xi x = sigma x) :
  forall x, funcomp (var_tm (S n_tm)) (upRen_tm_tm xi) x = up_tm_tm sigma x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n => ap (ren_tm shift) (Eq fin_n)
       | None => eq_refl
       end).
Qed.

Lemma rinstInst_up_list_tm_tm {p : nat} {m : nat} {n_tm : nat}
  (xi : fin m -> fin n_tm) (sigma : fin m -> tm n_tm)
  (Eq : forall x, funcomp (var_tm n_tm) xi x = sigma x) :
  forall x,
  funcomp (var_tm (plus p n_tm)) (upRen_list_tm_tm p xi) x =
  up_list_tm_tm p sigma x.
Proof.
exact (fun n =>
       eq_trans (scons_p_comp' _ _ (var_tm (plus p n_tm)) n)
         (scons_p_congr (fun z => eq_refl)
            (fun n => ap (ren_tm (shift_p p)) (Eq n)))).
Qed.

Fixpoint rinst_inst_tm {m_tm : nat} {n_tm : nat}
(xi_tm : fin m_tm -> fin n_tm) (sigma_tm : fin m_tm -> tm n_tm)
(Eq_tm : forall x, funcomp (var_tm n_tm) xi_tm x = sigma_tm x) (s : tm m_tm)
{struct s} : ren_tm xi_tm s = subst_tm sigma_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (rinst_inst_tm xi_tm sigma_tm Eq_tm s0)
        (rinst_inst_tm xi_tm sigma_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (rinst_inst_tm (upRen_tm_tm xi_tm) (up_tm_tm sigma_tm)
           (rinstInst_up_tm_tm _ _ Eq_tm) s0)
  | pair _ s0 s1 =>
      congr_pair (rinst_inst_tm xi_tm sigma_tm Eq_tm s0)
        (rinst_inst_tm xi_tm sigma_tm Eq_tm s1)
  | matchpair _ s0 s1 =>
      congr_matchpair (rinst_inst_tm xi_tm sigma_tm Eq_tm s0)
        (rinst_inst_tm (upRen_tm_tm (upRen_tm_tm xi_tm))
           (up_tm_tm (up_tm_tm sigma_tm))
           (rinstInst_up_tm_tm _ _ (rinstInst_up_tm_tm _ _ Eq_tm)) s1)
  end.

Lemma renRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : fin m_tm -> fin k_tm) (zeta_tm : fin k_tm -> fin l_tm)
  (s : tm m_tm) :
  ren_tm zeta_tm (ren_tm xi_tm s) = ren_tm (funcomp zeta_tm xi_tm) s.
Proof.
exact (compRenRen_tm xi_tm zeta_tm _ (fun n => eq_refl) s).
Qed.

Lemma substRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : fin m_tm -> tm k_tm) (zeta_tm : fin k_tm -> fin l_tm)
  (s : tm m_tm) :
  ren_tm zeta_tm (subst_tm sigma_tm s) =
  subst_tm (funcomp (ren_tm zeta_tm) sigma_tm) s.
Proof.
exact (compSubstRen_tm sigma_tm zeta_tm _ (fun n => eq_refl) s).
Qed.

Lemma renSubst_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : fin m_tm -> fin k_tm) (tau_tm : fin k_tm -> tm l_tm) (s : tm m_tm)
  : subst_tm tau_tm (ren_tm xi_tm s) = subst_tm (funcomp tau_tm xi_tm) s.
Proof.
exact (compRenSubst_tm xi_tm tau_tm _ (fun n => eq_refl) s).
Qed.

Lemma substSubst_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : fin m_tm -> tm k_tm) (tau_tm : fin k_tm -> tm l_tm)
  (s : tm m_tm) :
  subst_tm tau_tm (subst_tm sigma_tm s) =
  subst_tm (funcomp (subst_tm tau_tm) sigma_tm) s.
Proof.
exact (compSubstSubst_tm sigma_tm tau_tm _ (fun n => eq_refl) s).
Qed.

Lemma rinstInst'_tm {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm)
  (s : tm m_tm) : ren_tm xi_tm s = subst_tm (funcomp (var_tm n_tm) xi_tm) s.
Proof.
exact (rinst_inst_tm xi_tm _ (fun n => eq_refl) s).
Qed.

Lemma instId'_tm {m_tm : nat} (s : tm m_tm) : subst_tm (var_tm m_tm) s = s.
Proof.
exact (idSubst_tm (var_tm m_tm) (fun n => eq_refl) s).
Qed.

Lemma rinstId'_tm {m_tm : nat} (s : tm m_tm) : ren_tm id s = s.
Proof.
exact (eq_ind_r (fun t => t = s) (instId'_tm s) (rinstInst'_tm id s)).
Qed.

Lemma varL'_tm {m_tm : nat} {n_tm : nat} (sigma_tm : fin m_tm -> tm n_tm)
  (x : fin m_tm) : subst_tm sigma_tm (var_tm m_tm x) = sigma_tm x.
Proof.
exact (eq_refl).
Qed.

Lemma varLRen'_tm {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm)
  (x : fin m_tm) : ren_tm xi_tm (var_tm m_tm x) = var_tm n_tm (xi_tm x).
Proof.
exact (eq_refl).
Qed.

Class Up_tm X Y :=
    up_tm : X -> Y.

Instance Subst_tm  {m_tm n_tm : nat}: (Subst1 _ _ _) := (@subst_tm m_tm n_tm).

Instance Up_tm_tm  {m n_tm : nat}: (Up_tm _ _) := (@up_tm_tm m n_tm).

Instance Ren_tm  {m_tm n_tm : nat}: (Ren1 _ _ _) := (@ren_tm m_tm n_tm).

Instance VarInstance_tm  {n_tm : nat}: (Var _ _) := (@var_tm n_tm).

Notation "[ sigma_tm ]" := (subst_tm sigma_tm)
  ( at level 1, left associativity, only printing) : fscope.

Notation "s [ sigma_tm ]" := (subst_tm sigma_tm s)
  ( at level 7, left associativity, only printing) : subst_scope.

Notation "↑__tm" := up_tm (only printing) : subst_scope.

Notation "↑__tm" := up_tm_tm (only printing) : subst_scope.

Notation "⟨ xi_tm ⟩" := (ren_tm xi_tm)
  ( at level 1, left associativity, only printing) : fscope.

Notation "s ⟨ xi_tm ⟩" := (ren_tm xi_tm s)
  ( at level 7, left associativity, only printing) : subst_scope.

Notation "'var'" := var_tm ( at level 1, only printing) : subst_scope.

Notation "x '__tm'" := (@ids _ _ VarInstance_tm x)
  ( at level 5, format "x __tm", only printing) : subst_scope.

Notation "x '__tm'" := (var_tm x) ( at level 5, format "x __tm") :
  subst_scope.

Instance subst_tm_morphism  {m_tm : nat} {n_tm : nat}:
 (Proper (respectful (pointwise_relation _ eq) (respectful eq eq))
    (@subst_tm m_tm n_tm)).
Proof.
exact (fun f_tm g_tm Eq_tm s t Eq_st =>
       eq_ind s (fun t' => subst_tm f_tm s = subst_tm g_tm t')
         (ext_tm f_tm g_tm Eq_tm s) t Eq_st).
Qed.

Instance ren_tm_morphism  {m_tm : nat} {n_tm : nat}:
 (Proper (respectful (pointwise_relation _ eq) (respectful eq eq))
    (@ren_tm m_tm n_tm)).
Proof.
exact (fun f_tm g_tm Eq_tm s t Eq_st =>
       eq_ind s (fun t' => ren_tm f_tm s = ren_tm g_tm t')
         (extRen_tm f_tm g_tm Eq_tm s) t Eq_st).
Qed.

Ltac auto_unfold := repeat
                     unfold VarInstance_tm, Var, ids, Ren_tm, Ren1, ren1,
                      Up_tm_tm, Up_tm, up_tm, Subst_tm, Subst1, subst1.

Tactic Notation "auto_unfold" "in" "*" := repeat
                                           unfold VarInstance_tm, Var, ids,
                                            Ren_tm, Ren1, ren1, Up_tm_tm,
                                            Up_tm, up_tm, Subst_tm, Subst1,
                                            subst1 in *.

Ltac asimpl' := repeat (first
                 [ progress setoid_rewrite substSubst_tm
                 | progress rewrite ?substSubst_tm
                 | progress setoid_rewrite renSubst_tm
                 | progress rewrite ?renSubst_tm
                 | progress setoid_rewrite substRen_tm
                 | progress rewrite ?substRen_tm
                 | progress setoid_rewrite renRen_tm
                 | progress rewrite ?renRen_tm
                 | progress setoid_rewrite varLRen'_tm
                 | progress rewrite ?varLRen'_tm
                 | progress setoid_rewrite varL'_tm
                 | progress rewrite ?varL'_tm
                 | progress setoid_rewrite rinstId'_tm
                 | progress rewrite ?rinstId'_tm
                 | progress setoid_rewrite instId'_tm
                 | progress rewrite ?instId'_tm
                 | progress
                    unfold up_list_tm_tm, up_tm_tm, upRen_list_tm_tm,
                     upRen_tm_tm, up_ren
                 | progress cbn[subst_tm ren_tm]
                 | progress fsimpl
                 | repeat unfold funcomp ]).

Ltac asimpl := check_no_evars; repeat try unfold_funcomp;
                repeat
                 unfold VarInstance_tm, Var, ids, Ren_tm, Ren1, ren1,
                  Up_tm_tm, Up_tm, up_tm, Subst_tm, Subst1, subst1 in *;
                asimpl'; minimize.

Tactic Notation "asimpl" "in" hyp(J) := revert J; asimpl; intros J.

Tactic Notation "auto_case" := auto_case ltac:(asimpl; cbn; eauto).

Ltac substify := auto_unfold; try setoid_rewrite rinstInst'_tm.

Ltac renamify := auto_unfold; try setoid_rewrite_left rinstInst'_tm.

End renSubst.

Module fext.

Import
renSubst.

Lemma rinstInst_tm {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm) :
  ren_tm xi_tm = subst_tm (funcomp (var_tm n_tm) xi_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => rinst_inst_tm xi_tm _ (fun n => eq_refl) x)).
Qed.

Lemma instId_tm {m_tm : nat} : subst_tm (var_tm m_tm) = id.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => idSubst_tm (var_tm m_tm) (fun n => eq_refl) (id x))).
Qed.

Lemma rinstId_tm {m_tm : nat} : @ren_tm m_tm m_tm id = id.
Proof.
exact (eq_trans (rinstInst_tm (id _)) instId_tm).
Qed.

Lemma varL_tm {m_tm : nat} {n_tm : nat} (sigma_tm : fin m_tm -> tm n_tm) :
  funcomp (subst_tm sigma_tm) (var_tm m_tm) = sigma_tm.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => eq_refl)).
Qed.

Lemma varLRen_tm {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm) :
  funcomp (ren_tm xi_tm) (var_tm m_tm) = funcomp (var_tm n_tm) xi_tm.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => eq_refl)).
Qed.

Lemma renRen'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : fin m_tm -> fin k_tm) (zeta_tm : fin k_tm -> fin l_tm) :
  funcomp (ren_tm zeta_tm) (ren_tm xi_tm) = ren_tm (funcomp zeta_tm xi_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => renRen_tm xi_tm zeta_tm n)).
Qed.

Lemma substRen'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : fin m_tm -> tm k_tm) (zeta_tm : fin k_tm -> fin l_tm) :
  funcomp (ren_tm zeta_tm) (subst_tm sigma_tm) =
  subst_tm (funcomp (ren_tm zeta_tm) sigma_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => substRen_tm sigma_tm zeta_tm n)).
Qed.

Lemma renSubst'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : fin m_tm -> fin k_tm) (tau_tm : fin k_tm -> tm l_tm) :
  funcomp (subst_tm tau_tm) (ren_tm xi_tm) = subst_tm (funcomp tau_tm xi_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => renSubst_tm xi_tm tau_tm n)).
Qed.

Lemma substSubst'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : fin m_tm -> tm k_tm) (tau_tm : fin k_tm -> tm l_tm) :
  funcomp (subst_tm tau_tm) (subst_tm sigma_tm) =
  subst_tm (funcomp (subst_tm tau_tm) sigma_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => substSubst_tm sigma_tm tau_tm n)).
Qed.

Ltac asimpl_fext' := repeat (first
                      [ progress setoid_rewrite substSubst_tm
                      | progress setoid_rewrite renSubst_tm
                      | progress setoid_rewrite substRen_tm
                      | progress setoid_rewrite renRen_tm
                      | progress setoid_rewrite substSubst'_tm
                      | progress setoid_rewrite renSubst'_tm
                      | progress setoid_rewrite substRen'_tm
                      | progress setoid_rewrite renRen'_tm
                      | progress setoid_rewrite varLRen_tm
                      | progress setoid_rewrite varL_tm
                      | progress setoid_rewrite rinstId_tm
                      | progress setoid_rewrite instId_tm
                      | progress
                         unfold up_list_tm_tm, up_tm_tm, upRen_list_tm_tm,
                          upRen_tm_tm, up_ren
                      | progress cbn[subst_tm ren_tm]
                      | fsimpl_fext ]).

Ltac asimpl_fext := check_no_evars; repeat try unfold_funcomp;
                     repeat
                      unfold VarInstance_tm, Var, ids, Ren_tm, Ren1, ren1,
                       Up_tm_tm, Up_tm, up_tm, Subst_tm, Subst1, subst1
                       in *; asimpl_fext'; repeat try unfold_funcomp.

Tactic Notation "asimpl_fext" "in" hyp(J) := revert J; asimpl_fext; intros J.

Ltac substify_fext := auto_unfold; try repeat erewrite ?rinstInst_tm.

Ltac renamify_fext := auto_unfold; try repeat erewrite <- ?rinstInst_tm.

End fext.

Module interface.

Export renSubst.

Export
fext.

Arguments matchpair {n_tm}.

Arguments pair {n_tm}.

Arguments lam {n_tm}.

Arguments app {n_tm}.

Arguments var_tm {n_tm}.

End interface.

Export interface.