(***************************************************************************
* Principality of type inference for mini-ML with structural polymorphism  *
* Jacques Garrigue, August 2008                                            *
***************************************************************************)

Set Implicit Arguments.

Require Import List Metatheory.
Require Import ML_SP_Definitions ML_SP_Soundness.

Module MkRename(Cstr:CstrIntf)(Const:CstIntf).

Module Sound := MkSound(Cstr)(Const).
Import Sound.
Import Infra.
Import Defs.
Import Metatheory_Env.Env.

Module Mk2(Delta:DeltaIntf).

Module Sound2 := Sound.Mk2(Delta).
Import Sound2.
Import JudgInfra.
Import Judge.

(* ********************************************************************** *)
(** Renaming lemmas *)

Lemma trm_fv_open : forall t' t n,
  trm_fv (trm_open_rec n t' t) << trm_fv t \u trm_fv t'.
Proof.
  induction t; intros; intros x Hx; simpl in *; auto*.
  destruct (n0 === n); simpl in *; auto.
  apply* (IHt (S n)).
  puts (IHt1 n); use (IHt2 (S n)).
  puts (IHt1 n); use (IHt2 n).
Qed.

Lemma typing_rename : forall gc K E x y M E' t T,
  K ; E & x ~ M & E' |gc|= t ~: T ->
  y \notin (dom E \u dom E' \u {{x}} \u trm_fv t) ->
  K ; E & y ~ M & E' |gc|= trm_subst x (trm_fvar y) t ~: T.
Proof.
  introv Typ.
  gen_eq (E & x ~ M & E') as E0. gen E'.
  induction Typ; intros; subst; simpl trm_subst.
  (* Var *)
  destruct (x0 == x).
    subst.
    puts (binds_mid _ _ _ _ (proj1 H0)).
    puts (binds_func H1 H3).
    subst; clear H3.
    apply* typing_var.
  apply* typing_var.
  binds_cases H1; auto.
  (* Abs *)
  clear H0.
  apply* (@typing_abs gc (L \u {{y}} \u {{x}})).
  intros.
  forward~ (H1 x0) as Typ; clear H1.
  rewrite concat_assoc in Typ.
  forward~ (Typ _ (refl_equal _)) as Typ'; clear Typ.
    simpl in *; disjoint_solve.
    puts (trm_fv_open _ _ _ H1).
    simpl in H2; auto.
  repeat rewrite <- concat_assoc in Typ'.
  rewrite trm_subst_open in Typ' by auto.
  simpl trm_subst in Typ'.
  destruct* (x0 == x).
  subst. elim H0; auto.
  (* Let *)
  clear H H1.
  simpl in H4.
  apply~ (@typing_let gc M0 L1 (L2 \u {{y}} \u {{x}})).
  clear H0; intros.
  forward~ (H2 x0) as Typ0; clear H2.
  rewrite concat_assoc in Typ0.
  forward (Typ0 _ (refl_equal _)) as Typ; clear Typ0.
    simpl in *. disjoint_solve.
    puts (trm_fv_open _ _ _ H0).
    simpl in H1; auto.
  rewrite <- concat_assoc in Typ.
  rewrite trm_subst_open in Typ by auto.
  simpl trm_subst in Typ.
  destruct* (x0 == x).
  subst. elim H; auto.
  (* App *)
  simpl in H0.
  apply* (@typing_app gc K (E & y ~ M & E') S).
  (* Cst *)
  apply* typing_cst.
  (* GC *)
  apply* typing_gc.
Qed.

Lemma typing_abs_rename : forall x1 gc K E x2 M t T,
  x1 \notin trm_fv t ->
  x2 \notin dom E \u {{x1}} \u trm_fv t ->
  K; E & x1 ~ M |gc|= t ^ x1 ~: T -> K; E & x2 ~ M |gc|= t ^ x2 ~: T.
Proof.
  intros. replace (E & x2 ~ M) with (E & x2 ~ M & empty) by simpl*.
  replace (t ^ x2) with ([x1~>trm_fvar x2]t^x1).
    apply typing_rename. simpl*.
    disjoint_solve.
    puts (trm_fv_open _ _ _ H2).
    simpl in H3; auto.
  rewrite trm_subst_open by auto.
  rewrite trm_subst_fresh  by auto.
  simpl. destruct* (x1 == x1).
Qed.

Lemma binds_rename : forall (Ks:list kind) Xs Ys L Z k,
  length Ks = length Xs ->
  fresh L (length Xs) Ys ->
  binds Z k (combine Xs Ks) ->
  exists Z',
    typ_subst (combine Xs (typ_fvars Ys)) (typ_fvar Z) = typ_fvar Z'
    /\ binds Z' k (combine Ys Ks).
Proof.
  unfold binds.
  induction Ks; destruct Xs; destruct Ys; simpl; intros; try discriminate.
    elim H0.
  destruct (Z==v).
    inversion H1. exists v0. destruct* (v0 == v0).
  inversion H; clear H. destruct H0.
  destruct* (IHKs Xs Ys (L \u {{v0}}) Z k) as [Z' [HT HG]].
  exists Z'.
  simpl in HT.
  split2*.
  destruct* (Z' == v0).
  subst.
  puts (binds_dom HG).
  rewrite dom_combine in H2; auto.
  elim (fresh_disjoint _ _ H0 H2); auto.
Qed.

Lemma in_env_rename : forall (Ks:list kind) Xs Ys L Z k,
  length Ks = length Xs ->
  fresh L (length Ys) Xs ->
  In (Z, k) (combine Xs Ks) ->
  exists Z',
    typ_subst (combine Xs (typ_fvars Ys)) (typ_fvar Z) = typ_fvar Z'
    /\ In (Z', k) (combine Ys Ks).
Proof.
  induction Ks; destruct Xs; destruct Ys; simpl; intros; try contradiction.
  destruct H1.
    inversions H1. exists v0. destruct* (Z == Z).
  inversion H; clear H. destruct H0.
  destruct* (IHKs Xs Ys (L \u {{v}}) Z k) as [Z' [HT HG]].
  exists Z'.
  simpl in HT.
  split2*.
  destruct* (Z == v).
  subst.
  elim (in_fresh _ _ H0 (in_combine_l _ _ _ _ H1)). auto.
Qed.

Lemma kinds_subst_fresh : forall S Ks,
  disjoint (dom S) (kind_fv_list Ks) ->
  List.map (kind_subst S) Ks = Ks.
Proof.
  induction Ks; intros. auto.
  simpl in *.
  rewrite* kind_subst_fresh.
  rewrite* IHKs.
Qed.

Lemma well_subst_rename : forall K Ks Xs Ys,
  let S := combine Xs (typ_fvars Ys) in
  fresh (fv_in kind_fv K) (length Ks) Xs ->
  fresh (mkset Xs) (length Xs) Ys ->
  well_subst
    (K & kinds_open_vars Ks Xs & combine Ys (kinds_open Ks (typ_fvars Xs)))
    (K & map (kind_subst S) (combine Ys (kinds_open Ks (typ_fvars Xs)))) S.
Proof.
  intros; intro; intros.
  destruct k as [[kc kv kr kh]|]; [|auto].
  assert (DS: dom S = mkset Xs) by apply* dom_combine.
  binds_cases H1.
      rewrite typ_subst_fresh.
        rewrite* kind_subst_fresh.
        rewrite DS.
        use (fv_in_spec kind_fv _ _ _ (binds_in B0)).
      rewrite DS; simpl*.
    unfold kinds_open_vars in B1.
    assert (length (kinds_open Ks (typ_fvars Xs)) = length Xs)
      by (unfold kinds_open; auto).
    destruct (binds_rename _ _ _ _ H1 H0 B1) as [Z' [HT HG]].
    unfold S at 3. rewrite HT.
    simpl; apply* wk_kind.
    use (binds_map (kind_subst S) HG).
  rewrite typ_subst_fresh.
    unfold kind_subst. simpl.
    use (binds_map (kind_map (typ_subst S)) B0).
  rewrite* DS.
Qed.

Lemma typing_rename_typ : forall E M K Xs Ys gc t,
  fresh (env_fv E \u sch_fv M \u dom K \u fv_in kind_fv K)
    (sch_arity M) Xs ->
  fresh (dom K \u mkset Xs) (length Xs) Ys ->
  K & kinds_open_vars (sch_kinds M) Xs; E |gc|= t ~: M ^ Xs ->
  K & kinds_open_vars (sch_kinds M) Ys; E |gc|= t ~: M ^ Ys.
Proof.
  intros.
  set (S := combine Xs (typ_fvars Ys)).
  assert (DS: dom S = mkset Xs) by (unfold S; rewrite~ dom_combine).
  assert (TS: env_prop type S).
    unfold S; apply list_forall_env_prop. refine (proj2 (types_typ_fvars _)).
  unfold sch_open_vars, typ_open_vars.
  unfold sch_fv in H.
  rewrite~ (typ_subst_intro Xs (Us:=typ_fvars Ys)).
    fold S.
    replace E with (E & map (sch_subst S) empty) by auto.
    replace (kinds_open_vars (sch_kinds M) Ys) with
      (map(kind_subst S)(combine Ys (kinds_open (sch_kinds M) (typ_fvars Xs)))).
      apply* typing_typ_subst.
          rewrite* DS.
        apply* well_subst_rename.
      apply* typing_weaken_kinds'.
      kenv_ok_solve.
        apply* ok_combine_fresh.
      apply list_forall_env_prop.
      apply* (env_prop_list_forall _ _ H4).
    rewrite map_combine.
    rewrite* kinds_subst_open.
    rewrite kinds_subst_fresh.
      subst S.
      rewrite* (fresh_subst {} Xs (typ_fvars Ys)).
      unfold typ_fvars; rewrite map_length.
      rewrite* <- (fresh_length _ _ _ H0).
    rewrite* DS.
  rewrite* (fresh_length _ _ _ H0).
Qed.

(** Type generalization and reopening *)

Fixpoint typ_generalize (Bs:list var) (T:typ) {struct T} : typ :=
  match T with
  | typ_bvar n =>
    typ_bvar (length Bs + n)
  | typ_fvar x =>
    match index eq_var_dec 0 x Bs with
    | None   => T
    | Some n => typ_bvar n
    end
  | typ_arrow T1 T2 =>
    typ_arrow (typ_generalize Bs T1) (typ_generalize Bs T2)
  end.

Definition sch_generalize Bs T Ks :=
  Sch (typ_generalize Bs T) (List.map (kind_map (typ_generalize Bs)) Ks).

Lemma typ_generalize_reopen : forall Xs T,
  type T -> typ_open (typ_generalize Xs T) (typ_fvars Xs) = T.
Proof.
  induction 1; simpl.
    case_eq (index eq_var_dec 0 X Xs); simpl; intros.
      unfold typ_fvars.
      destruct (index_ok _ var_default _ _ H).
      rewrite <- (map_length typ_fvar) in H0.
      rewrite <- (f_equal typ_fvar H1).
      rewrite <- (map_nth typ_fvar).
      apply* nth_indep.
    auto.
  congruence.
Qed.

Lemma kind_generalize_reopen : forall Xs k,
  All_kind_types type k ->
  kind_open (kind_map (typ_generalize Xs) k) (typ_fvars Xs) = k.
Proof.
  unfold All_kind_types.
  intros; destruct k as [[kc kv kr kh]|]; simpl in *; auto.
  apply kind_pi; simpl*.
  clear kh; induction kr; simpl*.
  destruct a. simpl in *.
  inversions H.
  rewrite* typ_generalize_reopen. rewrite* IHkr.
Qed.

Lemma kind_list_generalize_reopen : forall Ks Xs,
  list_forall (All_kind_types type) Ks ->
  kinds_open (List.map (kind_map (typ_generalize Xs)) Ks) (typ_fvars Xs) = Ks.
Proof.
  intros.
  induction H. simpl*.
  simpl. rewrite* kind_generalize_reopen.
  congruence.
Qed.

Lemma kinds_generalize_reopen : forall Xs Ks,
  list_forall (All_kind_types type) Ks ->
  kinds_open_vars (List.map (kind_map (typ_generalize Xs)) Ks) Xs =
  combine Xs Ks.
Proof.
  unfold kinds_open_vars, kinds_open; intros.
  apply (f_equal (combine (B:=kind) Xs)).
  apply (kind_list_generalize_reopen Xs H).
Qed.

Lemma type_generalize : forall Bs Xs T,
  length Bs = length Xs ->
  type T ->
  type (typ_open_vars (typ_generalize Bs T) Xs).
Proof.
  intros.
  apply* (typ_open_vars_type Bs).
  unfold typ_open_vars.
  rewrite* typ_generalize_reopen.
Qed.

Lemma scheme_generalize : forall Bs Ks T,
  length Bs = length Ks ->
  type T -> list_forall (All_kind_types type) Ks ->
  scheme (sch_generalize Bs T Ks).
Proof.
  intros.
  intro; simpl; intros.
  rewrite map_length in H2.
  rewrite H2 in H.
  split. apply* type_generalize.
  apply* list_forall_map; intros.
  apply All_kind_types_map.
  apply* All_kind_types_imp; intros.
  apply* type_generalize.
Qed.

Lemma typ_generalize_disjoint : forall Bs T,
  disjoint (typ_fv (typ_generalize Bs T)) (mkset Bs).
Proof.
  induction T; simpl*.
  case_eq (index eq_var_dec 0 v Bs); simpl; intros; auto.
  use (index_none_notin _ _ _ _ H).
Qed.

Lemma kinds_generalize_disjoint : forall Bs Ks,
  disjoint (kind_fv_list (List.map (kind_map (typ_generalize Bs)) Ks))
    (mkset Bs).
Proof.
  intros. unfold kind_fv_list.
  induction Ks; simpl*.
  disjoint_solve.
  revert H; unfold kind_fv.
  clear Hin Ks; destruct a as [[kc kv kr kh]|]; simpl*.
  clear kh; induction kr; simpl*.
  use (typ_generalize_disjoint Bs (snd a)).
Qed.

Lemma sch_generalize_disjoint : forall Bs T Ks,
  disjoint (sch_fv (sch_generalize Bs T Ks)) (mkset Bs).
Proof.
  intros.
  unfold sch_generalize, sch_fv; simpl.
  disjoint_solve. apply (typ_generalize_disjoint _ _ H Hy').
  apply (kinds_generalize_disjoint _ _ H Hy').
Qed.

(** Free variables *)

Lemma typ_fv_open : forall Us T,
  typ_fv (typ_open T Us) << typ_fv T \u typ_fv_list Us.
Proof.
  induction T; simpl*.
  intros x Hx.
  gen n; induction Us; destruct n; simpl; intros; auto.
  use (IHUs n Hx).
Qed.

Lemma kind_fv_open : forall Us k,
  kind_fv (kind_open k Us) << kind_fv k \u typ_fv_list Us.
Proof.
  destruct k as [[kc kv kr kh]|]; unfold kind_fv; simpl*.
  rewrite list_snd_map_snd.
  clear; induction kr; simpl*.
  disjoint_solve.
  use (typ_fv_open _ _ H).
Qed.

Lemma fv_in_kinds_open_vars : forall Ks Xs,
  fv_in kind_fv (kinds_open_vars Ks Xs) << kind_fv_list Ks \u mkset Xs.
Proof.
  unfold kinds_open_vars.
  intros.
  rewrite <- typ_fv_typ_fvars.
  set (Us := typ_fvars Xs); clearbody Us.
  gen Ks; induction Xs; destruct Ks; simpl*.
  sets_solve.
    use (kind_fv_open _ _ H).
  use (IHXs Ks _ H).
Qed.

(** A more general form of kinds weakening *)

Lemma typing_kenv_incl : forall gc K E t T,
  K; E |gc|= t ~: T ->
  forall K',
    incl K K' -> kenv_ok K' -> K'; E |gc|= t ~:T.
Proof.
  induction 1; intros; auto*.
  (* Var *)
  apply* typing_var.
  destruct H2; split2*.
  apply* list_forall2_imp.
  intros.
  inversions* H6.
  (* Let *)
  apply* (@typing_let gc M (L1 \u dom K')).
  intros.
  assert (kenv_ok (K' & kinds_open_vars (sch_kinds M) Xs)) by forward~ (H Xs).
  apply* H0.
  intro; intros.
  destruct* (in_app_or _ _ _ H7).
  (* Cst *)
  apply* typing_cst.
  destruct H1; split; intuition.
  apply* list_forall2_imp.
  intros.
  inversions* H5.
  (* Gc *)
  apply* (@typing_gc gc Ks (L \u dom K')).
  intros.
  assert (kenv_ok (K' & kinds_open_vars Ks Xs)) by forward~ (H0 Xs).
  apply* (H1 Xs).
  intro; intros.
  destruct* (in_app_or _ _ _ H6).
Qed.

(** Miscellanous lemmata *)

Lemma kind_fv_list_app : forall K2 K1,
  kind_fv_list (K1 ++ K2) = kind_fv_list K1 \u kind_fv_list K2.
Proof.
  unfold kind_fv_list; induction K1; simpl. rewrite* union_empty_l.
  rewrite* IHK1. rewrite* union_assoc.
Qed.

(* ********************************************************************** *)
(** Removing Gc through inversion *)

(* An alternative way to get rid of Gc, eliminating it completely.
   This part of the development is not needed for soundness, as we can
   use the canonization lemma in ML_SP_Soundness.v.
   However, many lemmas proved here are actually required for
   the proof of soundness and principality of type inference.
   Originally the proof was about 1350 lines long, which contrasts
   with the mere 100 lines of canonicalization, but some lemmas, like
   renaming, have been moved around.
   This proof demonstrates how difficult it is to remove _all_ uses
   of typing_gc in this approach, and how muddy things become when
   you start needing renaming. *)

(* Idea of the proof: in order to prove that if K; E |= t ~: T using
   typing_gc then we can find K' such that K,K'; E |= t ~: T without it,
   we prove by induction that K,K'; F |= t ~: T for any F "weaker" than E,
   i.e. where any binding (x : Sch U Ks) of E may be replaced by a binding
   (x : Sch U (Ks ++ Ks')). This way, in the Let rule, we can transfer
   the extra kinds of the kinding environment to the type environment of
   the right derivation.
   On paper, the proof is straightforward. Here, we need renaming for both
   terms and types, and to prove a lot of technical properties on the way. *)

Definition env_weaker E F :=
  forall x T Ks,
    binds x (Sch T Ks) E ->
    exists Ks', binds x (Sch T (Ks++Ks')) F.

Lemma typ_open_extra : forall Us Vs T,
  type (typ_open T Us) ->
  typ_open T Us = typ_open T (Us ++ Vs).
Proof.
  induction T; simpl; intros; auto.
    gen Us; induction n; destruct Us; simpl in *; intros; auto ; inversion* H.
  inversions H.
  rewrite* IHT1. rewrite* IHT2.
Qed.

Lemma kind_open_extra : forall Us Vs k,
  All_kind_types type (kind_open k Us) ->
  kind_open k Us = kind_open k (Us ++ Vs).
Proof.
  unfold All_kind_types.
  destruct k as [[kc kv kr kh]|]; simpl*; intros.
  apply* kind_pi; simpl.
  clear -H; induction kr; simpl in *. auto.
  inversions H; clear H.
  rewrite* (typ_open_extra Us Vs).
  rewrite* IHkr.
Qed.

Lemma env_weaker_ok : forall Us U Ks Ks' k Xs',
  types (length Ks) Us ->
  length Ks' = length Xs' ->
  scheme (Sch U (Ks ++ Ks')) ->
  In k (kinds_open Ks' (Us ++ typ_fvars Xs')) ->
  All_kind_types type k.
Proof.
  intros.
  destruct (var_freshes {} (length Ks)) as [Xs Fr].
  destruct (H1 (Xs ++ Xs')) as [_ HA]; clear H1.
    simpl. repeat rewrite app_length.
    rewrite H0. rewrite* (fresh_length _ _ _ Fr).
  clear H0.
  use (list_forall_app_inv _ _ HA); clear HA.
  induction H0; simpl in *. elim H2.
  destruct H2; subst.
    unfold kind_open.
    clear -H Fr H1.
    apply All_kind_types_map.
    apply* All_kind_types_imp.
    simpl; intros.
    unfold typ_open_vars in H0.
    eapply typ_open_other_type. apply H0.
    unfold typ_fvars. rewrite map_length.
    split.
      repeat rewrite app_length; rewrite map_length.
      rewrite* <- (fresh_length _ _ _ Fr).
    destruct H.
    clear -H2. induction H2; simpl*.
    induction Xs'; simpl*.
  apply* IHlist_forall.
Qed.

Lemma well_kinded_combine : forall K Ks' Xs Us,
  fresh (dom K) (length Ks') Xs ->
  list_forall2 (well_kinded
    (K & combine Xs (List.map (fun k => kind_open k (Us ++ typ_fvars Xs)) Ks')))
   (List.map (fun k => kind_open k (Us ++ typ_fvars Xs)) Ks') (typ_fvars Xs).
Proof.
  intros.
  assert (fresh (dom (empty(A:=kind))) (length Ks') Xs) by auto.
  use (list_forall2_binds _ _ _ H0).
  simpl in H1.
  unfold typ_fvars; apply* list_forall2_map.
  simpl; intros.
  destruct x; try apply wk_any.
  simpl.
  apply* wk_kind.
  apply binds_prepend.
  rewrite <- map_combine.
  apply (binds_map (fun k => kind_open k (Us ++ List.map typ_fvar Xs)) H2).
Qed.

Lemma well_kinded_combine2 : forall K U Ks Us Ks' Xs,
  proper_instance K Ks Us ->
  typ_body U Ks ->
  typ_body U (Ks ++ Ks') ->
  fresh (dom K) (length Ks') Xs ->
  list_forall2
    (well_kinded (K & combine Xs (kinds_open Ks' (Us ++ typ_fvars Xs))))
    (kinds_open (Ks ++ Ks') (Us ++ typ_fvars Xs))
    (Us ++ typ_fvars Xs).
Proof.
  introv PI HS0 HS Fr.
  destruct PI as [HT HW].
  simpl in *.
  unfold kinds_open. rewrite map_app.
  apply list_forall2_app.
    unfold kinds_open in HW.
    (* destruct HS0 as [L' HF]. *)
    destruct (var_freshes {} (length Ks)) as [Xs' Fr'].
    use (proj2 (HS0 Xs' (fresh_length _ _ _ Fr'))).
    clear -HT Fr Fr' HW H.
    remember Us as Vs.
    destruct HT.
    rewrite H0 in Fr'.
    pattern Vs at 1 in HW.
    pattern Vs at -3.
    rewrite HeqVs in *.
    rewrite <- HeqVs in H0.
    clear HeqVs.
    gen Vs; induction Ks; destruct Vs; intros; simpl in *; try discriminate.
      auto.
    inversions HW; inversion H0; inversions H; clear HW H H0.
    constructor; auto.
    clear -Fr Fr' H1 H5 H8.
    destruct a; simpl in *; try apply wk_any.
    destruct t; inversions H5; clear H5.
    eapply wk_kind.
      apply* binds_concat_fresh.
    destruct c as [kc kv kr kh]; simpl in *.
    destruct H4; split2*. clear H.
    intros.
    apply H0; clear H0.
    unfold All_kind_types in H8; simpl in *.
    clear -Fr' H8 H H1.
    induction kr; simpl in *. auto.
    inversion_clear H8; destruct* H.
    clear IHkr; left*; subst.
    rewrite* (typ_open_extra Us (typ_fvars Xs)).
    unfold typ_open_vars in H0.
    apply (typ_open_other_type (typ_fvars Xs')). auto.
    split2*.
  clear -Fr.
  apply* well_kinded_combine.
Qed.

Lemma incl_swap : forall (A:Set) (E E1 E2:Env.env A),
  ok (E & E1 & E2) -> incl (E & E2 & E1) (E & E1 & E2).
Proof.
  intros; intro; intros.
  destruct* (in_app_or _ _ _ H0).
  destruct* (in_app_or _ _ _ H1).
Qed.

Lemma env_weaker_push : forall E F x U Ks Ks',
  env_weaker E F -> x # F ->
  env_weaker (E & x ~ Sch U Ks) (F & x ~ Sch U (Ks++Ks')).
Proof.
  intros; intro; intros.
  binds_cases H1.
    destruct (H _ _ _ B) as [Ks1 HB].
    exists* Ks1.
  inversions H2.
  exists* Ks'.
Qed.

Lemma ok_combine_other : forall (A B:Set) Xs (Us:list A) (Vs:list B),
  ok (combine Xs Us) -> length Us = length Vs -> ok (combine Xs Vs).
Proof.
  induction Xs; simpl; intros. fold (empty(A:=B)). auto.
  destruct Vs; destruct Us; try discriminate.
    fold (empty(A:=B)). auto.
  inversion H0.
  inversions H. apply* (@ok_push B (combine Xs Vs) a b).
  clear -H2 H6.
  gen Us Vs; induction Xs; simpl; intros. auto.
  destruct Us; destruct Vs; try discriminate; auto.
  simpl in *.
  assert (a # combine Xs Vs) by apply* (IHXs Us).
  auto.
Qed.

Lemma ok_fresh : forall (A:Set) Xs (Us:list A) L,
  ok (combine Xs Us) ->
  length Xs = length Us ->
  disjoint (mkset Xs) L ->
  fresh L (length Xs) Xs.
Proof.
  induction Xs; destruct Us; simpl; intros; try discriminate. auto.
  split2*.
  inversions H.
  apply* (IHXs Us).
Qed.

Lemma typing_remove_gc_var : forall K E x M Us F LK,
  kenv_ok K ->
  env_ok E ->
  binds x M E ->
  proper_instance K (sch_kinds M) Us ->
  env_weaker E F ->
  env_ok F ->
  exists K',
    disjoint (dom K') LK /\
    K & K'; F | (false, GcAny) |= trm_fvar x ~: sch_open M Us.
Proof.
  intros.
  destruct M as [U Ks].
  destruct (H3 x _ _ H1) as [Ks' HB]. destruct* H2.
  destruct (var_freshes (LK \u dom K) (length Ks')) as [Xs Fr].
  exists (combine Xs (kinds_open Ks' (Us ++ typ_fvars Xs))).
  assert (dom (combine Xs (kinds_open Ks' (Us ++ typ_fvars Xs))) = mkset Xs)
    by rewrite* dom_combine.
  split.
    rewrite* H6.
  assert (HS: scheme (Sch U (Ks ++ Ks'))) by apply* (proj2 H4 x).
  assert (HS0: scheme (Sch U Ks)) by apply* env_prop_binds.
  replace (sch_open (Sch U Ks) Us)
    with (sch_open (Sch U (Ks++Ks')) (Us ++ typ_fvars Xs)).
    apply* typing_var.
      destruct H.
      split.
        apply* disjoint_ok. apply* ok_combine_fresh.
      apply* env_prop_concat.
      intro; intros.
      eapply env_weaker_ok.
            apply H2.
          apply (fresh_length _ _ _ Fr).
        apply (proj2 H4 _ _ (binds_in HB)).
      apply (in_combine_r _ _ _ _ H8).
    split.
      destruct H2.
      split2*.
      clear -H7; induction Us; simpl; inversion* H7.
      induction Xs; simpl*.
    simpl; apply* well_kinded_combine2. simpl in *. split2*.
  unfold sch_open. simpl.
  assert (K; E |(false,GcAny)|= trm_fvar x ~: (Sch U Ks) ^^ Us).
    apply* typing_var. split2*.
  assert (type ((Sch U Ks) ^^ Us)) by auto.
  unfold sch_open in H8. simpl in H8.
  rewrite* (typ_open_extra Us (typ_fvars Xs)).
Qed.

Lemma kenv_ok_rename : forall Xs Xs' Ks,
  list_forall (fun o : kind => All_kind_types type o)
    (kinds_open Ks (typ_fvars Xs)) ->
  fresh (kind_fv_list Ks) (length Xs') Xs ->
  list_forall (fun o : kind => All_kind_types type o)
    (kinds_open Ks (typ_fvars Xs')).
Proof.
  induction Ks; simpl; intros. auto.
  inversions H.
  constructor.
    auto.
  clear -H0 H4.
  unfold kind_open in *.
  apply All_kind_types_map.
  puts (All_kind_types_inv _ _ H4).
  apply* All_kind_types_imp.
  clear H H4; simpl; intros.
  apply (typ_open_other_type (Vs:=typ_fvars Xs') _ _ H).
  split. unfold typ_fvars; repeat rewrite map_length.
    rewrite* (fresh_length _ _ _ H0).
  clear. unfold typ_fvars; induction Xs'; simpl; auto.
Qed.

Lemma kenv_ok_swap : forall (K K1 K2 : kenv),
  kenv_ok (K & K1 & K2) -> kenv_ok (K & K2 & K1).
Proof.
  intros.
  destruct H.
  destruct (ok_concat_inv _ _ H).
  destruct (ok_concat_inv _ _ H1).
  split.
    apply* disjoint_ok.
  intro; intros.
  apply (H0 x).
  destruct* (in_app_or _ _ _ H5).
  destruct* (in_app_or _ _ _ H6).
Qed.

Lemma scheme_extra : forall U Ks Xs K,
  let Ks' :=
    List.map (kind_map (typ_generalize (Xs ++ list_fst K))) (list_snd K) in
  length Ks = length Xs ->
  kenv_ok K ->
  scheme (Sch U Ks) ->
  scheme (Sch U (Ks ++ Ks')).
Proof.
  intros until Ks'; intros HXs HK HM; intro; intros.
  simpl in *. rewrite app_length in H.
  rewrite HXs in H. unfold Ks' in H.
  rewrite map_length in H.
  rewrite <- length_fst_snd in H.
  rewrite <- app_length in H.
  destruct (HM Xs). simpl*.
  simpl in *.
  split.
    unfold typ_open_vars.
    apply (typ_open_other_type (typ_fvars (Xs ++ list_fst K))).
      rewrite typ_fvars_app.
      rewrite* <- typ_open_extra.
    unfold typ_fvars; rewrite map_length. rewrite H.
    apply types_typ_fvars.
  apply list_forall_app.
    clear -H1 H.
    induction H1. auto.
    constructor. auto.
    apply* All_kind_types_imp. intros. simpl in *.
    clear -H H2. unfold typ_open_vars in *.
    apply (typ_open_other_type (typ_fvars (Xs ++ list_fst K))).
      rewrite typ_fvars_app.
      rewrite* <- typ_open_extra.
    unfold typ_fvars; rewrite map_length. rewrite H.
    apply types_typ_fvars.
  unfold Ks'.
  destruct HK.
  rewrite <- (combine_fst_snd K) in H3.
  use (env_prop_list_forall _ _ H3). rewrite combine_fst_snd in H4.
  use (H4 H2 (length_fst_snd K)).
  clear -H5 H.
  induction H5; simpl*.
  constructor. auto.
  apply All_kind_types_map.
  apply* All_kind_types_imp. clear -H; intros.
  unfold typ_open_vars.
  apply (typ_open_other_type (typ_fvars (Xs ++ list_fst K))).
    rewrite* typ_generalize_reopen.
  unfold typ_fvars. rewrite map_length; rewrite H.
  apply types_typ_fvars.
Qed.

Lemma typing_remove_gc_let : forall L1 L2 LK E M F K K1 Xs t1 t2 T2,
  (forall x,
    x \notin L2 ->
    forall LK F,
      env_weaker (E & x ~ M) F -> env_ok F ->
      exists K',
        disjoint (dom K') LK /\ K & K'; F | (false, GcAny) |= t2 ^ x ~: T2) ->
  env_weaker E F -> env_ok F -> scheme M ->
  fresh (L1 \u env_fv F \u sch_fv M \u dom K \u fv_in kind_fv K)
    (sch_arity M) Xs ->
  disjoint (dom K1)
    (LK \u mkset Xs \u env_fv F \u sch_fv M \u dom K \u fv_in kind_fv K) ->
  K & kinds_open_vars (sch_kinds M) Xs & K1; F |(false, GcAny)|= t1 ~: M ^ Xs ->
  exists K' : Env.env kind,
    disjoint (dom K') LK /\
    K & K'; F | (false, GcAny) |= trm_let t1 t2 ~: T2.
Proof.
  intros until T2. intros H2 H3 H4 HM HXs HD1 Typ1.
  use (kenv_ok_swap K (kinds_open_vars (sch_kinds M) Xs) K1
          (proj41 (typing_regular Typ1))).
  poses Typ1a (typing_kenv_incl Typ1 (incl_swap _ _ _ (proj1 H)) H).
  clear Typ1 H.
  pose (Ks' :=
    List.map (kind_map (typ_generalize (Xs ++ list_fst K1))) (list_snd K1)).
  destruct M as [U Ks]; simpl in *.
  destruct (var_fresh (L2 \u trm_fv t2 \u dom F)) as [x Hx].
  rewrite concat_assoc in Typ1a.
  assert (HKM: kenv_ok (K1 & kinds_open_vars Ks Xs)) by auto.
  assert (env_weaker (E & x ~ Sch U Ks) (F & x ~ Sch U (Ks++Ks'))).
    apply* env_weaker_push.
  assert (Hx': x \notin L2) by auto.
  assert (HK1: kenv_ok K1) by auto.
  assert (HM': scheme (Sch U (Ks ++ Ks')))
    by (unfold Ks'; apply* scheme_extra).
  destruct* (H2 x Hx' LK (F & x ~ Sch U (Ks ++ Ks'))) as [K2 [HD2 Typ2]];
    clear H2 Hx'.
  exists K2; split2*.
  assert (LenS: length (Ks ++ Ks') = length (Xs ++ list_fst K1)).
    repeat rewrite app_length; unfold list_fst; rewrite map_length.
    unfold Ks', list_snd; repeat rewrite map_length.
    rewrite* (fresh_length _ _ _ HXs).
  apply* (@typing_let (false,GcAny) (Sch U (Ks++Ks'))
             (L1 \u dom K \u dom K2 \u mkset (Xs ++ list_fst K1))
             (L2 \u dom F \u {{x}} \u trm_fv t2)).
    intros.
    apply typing_weaken_kinds.
      simpl.
      apply (@typing_rename_typ F (Sch U (Ks++Ks')) K (Xs ++ list_fst K1)).
          simpl.
          apply* disjoint_fresh.
            unfold kinds_open_vars in HKM.
            rewrite LenS.
            rewrite <- (combine_fst_snd K1) in HKM.
            unfold concat in HKM.
            rewrite <- combine_app in HKM.
            apply~ (ok_fresh _ _ (L:={}) (proj1 HKM)).
              do 2 rewrite app_length.
              unfold kinds_open; rewrite map_length. rewrite* length_fst_snd.
            unfold kinds_open; rewrite map_length.
            rewrite* (fresh_length _ _ _ HXs).
          puts (kinds_generalize_disjoint (Xs ++ list_fst K1) (list_snd K1)).
          fold Ks' in H1.
          rewrite mkset_app.
          unfold sch_fv in *; simpl in *.
          rewrite kind_fv_list_app.
          assert (mkset (list_fst K1) = dom K1).
            rewrite <- (dom_combine (list_fst K1) (list_snd K1)).
              rewrite* combine_fst_snd.
            unfold list_fst, list_snd; auto.
          rewrite <- H2 in *.
          clear -HD1 HXs H1.
          rewrite mkset_app in H1.
          disjoint_solve.
        rewrite* <- LenS.
      simpl.
      unfold sch_open_vars, typ_open_vars in *.
      simpl typ_open in *.
      unfold typ_fvars in *. rewrite map_app.
      rewrite* <- typ_open_extra.
      unfold kinds_open_vars. unfold kinds_open.
      rewrite map_app. rewrite combine_app.
        fold (kinds_open Ks' (typ_fvars (Xs ++ list_fst K1))).
        unfold Ks'; rewrite* kind_list_generalize_reopen.
          rewrite combine_fst_snd.
          replace
            (List.map (fun k => kind_open k (typ_fvars (Xs ++ list_fst K1))) Ks)
            with (kinds_open Ks (typ_fvars Xs)).
            apply Typ1a.
          unfold kinds_open.
          destruct (HM Xs). simpl*.
          simpl in H2.
          clear -H2; induction H2. simpl*.
          simpl. rewrite IHlist_forall. clear -H.
          rewrite typ_fvars_app.
          rewrite* <- kind_open_extra.
          unfold kind_open.
          apply* All_kind_types_map.
        rewrite <- (combine_fst_snd K1) in HK1.
        apply* env_prop_list_forall.
        apply length_fst_snd.
      rewrite map_length. symmetry. auto*.
    kenv_ok_solve. apply* ok_combine_fresh.
    simpl.
    apply list_forall_env_prop.
    unfold kinds_open.
    destruct* (HM' Xs0). simpl in H16.
    apply* list_forall_map.
    intros.
    unfold kind_open.
    apply* All_kind_types_map.
  intros.
  simpl gc_raise.
  replace (F & x0 ~ Sch U (Ks++Ks')) with (F & x0 ~ Sch U (Ks++Ks') & empty)
    in * by (simpl; auto).
  replace (F & x ~ Sch U (Ks++Ks')) with (F & x ~ Sch U (Ks++Ks') & empty)
    in Typ2 by (simpl; auto).
  rewrite* (@trm_subst_intro x t2 (trm_fvar x0)).
  apply (typing_rename (y:=x0) _ _ _ Typ2). simpl.
  puts (trm_fv_open (trm_fvar x) t2 0). simpl in H1.
  unfold trm_open. auto.
Qed.

Lemma typing_remove_gc : forall gc K E t T,
  K ; E |gc|= t ~: T ->
  forall LK F,
    env_weaker E F -> env_ok F ->
    exists K',
      disjoint (dom K') LK /\ K & K' ; F |(false,GcAny)|= t ~: T.
Proof.
  induction 1; intros.
  (* Var *)
  apply (typing_remove_gc_var LK H H0 H1 H2 H3 H4).
  (* Abs *)
  clear H0 gc.
  destruct (var_fresh (L \u trm_fv t1 \u dom F)) as [x Hx].
  assert (Hx' : x \notin L) by auto.
  assert (HF : env_weaker (E & x ~ Sch U nil) (F & x ~ Sch U nil)).
    intro; intros.
    binds_cases H0.
      destruct (H2 x0 T0 Ks B) as [Ks' HB].
      exists* Ks'.
    exists (nil(A:=kind)).
    rewrite <- app_nil_end. auto.
  destruct (H1 x Hx' LK _ HF) as [K' [HD Typ]]; clear H1 Hx'.
    split2*. destruct H3; apply* env_prop_concat.
    intro; intros. destruct* H3. inversions H3.
    intro; intros. simpl. split2*. unfold typ_open_vars.
    clear -H; induction H; simpl*.
  exists K'; split2*.
  apply* (@typing_abs (false,GcAny) (L \u dom F \u trm_fv t1 \u {{x}})).
  intros.
  replace (F & x0 ~ Sch U nil) with (F & x0 ~ Sch U nil & empty)
    by (simpl; auto).
  rewrite* (@trm_subst_intro x t1 (trm_fvar x0)).
  apply* typing_rename.
  assert (x0 \notin trm_fv (t1 ^ x)).
    apply* (notin_subset (trm_fv_open (trm_fvar x) t1 0)).
    simpl; auto.
  simpl; auto.
  (* Let *)
  destruct (var_freshes (L1 \u env_fv F \u sch_fv M \u dom K \u
      fv_in kind_fv K) (sch_arity M)) as [Xs HXs].
  assert (HXs': fresh L1 (sch_arity M) Xs) by auto.
  use (H Xs HXs').
  destruct* (H0 Xs HXs' (LK \u mkset Xs \u env_fv F \u sch_fv M
                         \u dom K \u fv_in kind_fv K) _ H3)
    as [K1 [HD1 Typ1]].
  assert (scheme M).
    destruct (var_fresh L2). puts (proj42 (typing_regular (H1 _ n))).
    apply* (proj2 H6 x).
  clear H H0 H1 H5 HXs'.
  apply* typing_remove_gc_let.
  (* App *)
  clear H H0.
  destruct (IHtyping1 LK F H1 H2) as [K1 [HD1 Typ1]].
  destruct (IHtyping2 (LK \u dom K1) F H1 H2) as [K2 [HD2 Typ2]].
  exists (K1 & K2).
  assert (kenv_ok (K & K1 & K2)) by auto.
  split2*.
  rewrite <- concat_assoc.
  eapply typing_app.
    apply* typing_weaken_kinds'.
  simpl. apply* typing_weaken_kinds.
  (* Cst *)
  exists (empty(A:=kind)).
  simpl*.
  (* GC *)
  destruct (var_freshes (L \u LK) (length Ks)) as [Xs Hs].
  assert (fresh L (length Ks) Xs) by auto.
  destruct (H1 Xs H4 LK F H2 H3) as [K' [HD Typ]].
  exists (kinds_open_vars Ks Xs & K').
  rewrite dom_concat.
  rewrite* dom_kinds_open_vars.
  rewrite* <- concat_assoc.
Qed.

(* End of removing GC *)

End Mk2.

End MkRename.


(** This module defines the interface for reflexive DPLL solvers. *)
Require Export Cnf Semantics Env Sat.

(** * The module type [DPLL] *)
Module Type DPLL (Import F : CNF).
  Declare Module Export E : ENV_INTERFACE F.

  Inductive Res : Type :=
    Sat : E.t -> Res
  | Unsat.

  Parameter dpll : F.formula -> Res.
  Axiom dpll_correct :
    forall Pb, dpll Pb = Unsat ->
      F.Sem.incompatible {} (F.make Pb).
End DPLL.


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

(** Additional operations and proofs about binary integers,
    on top of the ZArith standard library. *)

    Require Import Psatz Zquot.
    Require Import Coqlib.

    (** ** Modulo arithmetic *)

    (** We define and state properties of equality and arithmetic modulo a
      positive integer. *)

    Section EQ_MODULO.

    Variable modul: Z.
    Hypothesis modul_pos: modul > 0.

    Definition eqmod (x y: Z) : Prop := exists k, x = k * modul + y.

    Lemma eqmod_refl: forall x, eqmod x x.
    Proof.
      intros; red. exists 0. lia.
    Qed.

    Lemma eqmod_refl2: forall x y, x = y -> eqmod x y.
    Proof.
      intros. subst y. apply eqmod_refl.
    Qed.

    Lemma eqmod_sym: forall x y, eqmod x y -> eqmod y x.
    Proof.
      intros x y [k EQ]; red. exists (-k). subst x. ring.
    Qed.

    Lemma eqmod_trans: forall x y z, eqmod x y -> eqmod y z -> eqmod x z.
    Proof.
      intros x y z [k1 EQ1] [k2 EQ2]; red.
      exists (k1 + k2). subst x; subst y. ring.
    Qed.

    Lemma eqmod_small_eq:
      forall x y, eqmod x y -> 0 <= x < modul -> 0 <= y < modul -> x = y.
    Proof.
      intros x y [k EQ] I1 I2.
      generalize (Zdiv_unique _ _ _ _ EQ I2). intro.
      rewrite (Z.div_small x modul I1) in H. subst k. lia.
    Qed.

    Lemma eqmod_mod_eq:
      forall x y, eqmod x y -> x mod modul = y mod modul.
    Proof.
      intros x y [k EQ]. subst x.
      rewrite Z.add_comm. apply Z_mod_plus. auto.
    Qed.

    Lemma eqmod_mod:
      forall x, eqmod x (x mod modul).
    Proof.
      intros; red. exists (x / modul).
      rewrite Z.mul_comm. apply Z_div_mod_eq. auto.
    Qed.

    Lemma eqmod_add:
      forall a b c d, eqmod a b -> eqmod c d -> eqmod (a + c) (b + d).
    Proof.
      intros a b c d [k1 EQ1] [k2 EQ2]; red.
      subst a; subst c. exists (k1 + k2). ring.
    Qed.

    Lemma eqmod_neg:
      forall x y, eqmod x y -> eqmod (-x) (-y).
    Proof.
      intros x y [k EQ]; red. exists (-k). rewrite EQ. ring.
    Qed.

    Lemma eqmod_sub:
      forall a b c d, eqmod a b -> eqmod c d -> eqmod (a - c) (b - d).
    Proof.
      intros a b c d [k1 EQ1] [k2 EQ2]; red.
      subst a; subst c. exists (k1 - k2). ring.
    Qed.

    Lemma eqmod_mult:
      forall a b c d, eqmod a c -> eqmod b d -> eqmod (a * b) (c * d).
    Proof.
      intros a b c d [k1 EQ1] [k2 EQ2]; red.
      subst a; subst b.
      exists (k1 * k2 * modul + c * k2 + k1 * d).
      ring.
    Qed.

    End EQ_MODULO.

    Lemma eqmod_divides:
      forall n m x y, eqmod n x y -> Z.divide m n -> eqmod m x y.
    Proof.
      intros. destruct H as [k1 EQ1]. destruct H0 as [k2 EQ2].
      exists (k1*k2). rewrite <- Z.mul_assoc. rewrite <- EQ2. auto.
    Qed.

    (** ** Fast normalization modulo [2^n] *)

    Fixpoint P_mod_two_p (p: positive) (n: nat) {struct n} : Z :=
      match n with
      | O => 0
      | S m =>
          match p with
          | xH => 1
          | xO q => Z.double (P_mod_two_p q m)
          | xI q => Z.succ_double (P_mod_two_p q m)
          end
      end.

    Definition Z_mod_two_p (x: Z) (n: nat) : Z :=
      match x with
      | Z0 => 0
      | Zpos p => P_mod_two_p p n
      | Zneg p => let r := P_mod_two_p p n in if zeq r 0 then 0 else two_power_nat n - r
      end.

    Lemma P_mod_two_p_range:
      forall n p, 0 <= P_mod_two_p p n < two_power_nat n.
    Proof.
      induction n; simpl; intros.
      - rewrite two_power_nat_O. lia.
      - rewrite two_power_nat_S. destruct p.
        + generalize (IHn p). rewrite Z.succ_double_spec. lia.
        + generalize (IHn p). rewrite Z.double_spec. lia.
        + generalize (two_power_nat_pos n). lia.
    Qed.

    Lemma P_mod_two_p_eq:
      forall n p, P_mod_two_p p n = (Zpos p) mod (two_power_nat n).
    Proof.
      assert (forall n p, exists y, Zpos p = y * two_power_nat n + P_mod_two_p p n).
      {
        induction n; simpl; intros.
        - rewrite two_power_nat_O. exists (Zpos p). ring.
        - rewrite two_power_nat_S. destruct p.
          + destruct (IHn p) as [y EQ]. exists y.
            change (Zpos p~1) with (2 * Zpos p + 1). rewrite EQ.
            rewrite Z.succ_double_spec. ring.
          + destruct (IHn p) as [y EQ]. exists y.
            change (Zpos p~0) with (2 * Zpos p). rewrite EQ.
            rewrite (Z.double_spec (P_mod_two_p p n)). ring.
          + exists 0; lia.
      }
      intros.
      destruct (H n p) as [y EQ].
      symmetry. apply Zmod_unique with y. auto. apply P_mod_two_p_range.
    Qed.

    Lemma Z_mod_two_p_range:
      forall n x, 0 <= Z_mod_two_p x n < two_power_nat n.
    Proof.
      intros; unfold Z_mod_two_p. generalize (two_power_nat_pos n); intros.
      destruct x.
      - intuition.
      - apply P_mod_two_p_range.
      - set (r := P_mod_two_p p n).
        assert (0 <= r < two_power_nat n) by apply P_mod_two_p_range.
        destruct (zeq r 0).
        + intuition.
        + Psatz.lia.
    Qed.

    Lemma Z_mod_two_p_eq:
      forall n x, Z_mod_two_p x n = x mod (two_power_nat n).
    Proof.
      intros. unfold Z_mod_two_p. generalize (two_power_nat_pos n); intros.
      destruct x.
      - rewrite Zmod_0_l. auto.
      - apply P_mod_two_p_eq.
      - generalize (P_mod_two_p_range n p) (P_mod_two_p_eq n p). intros A B.
        exploit (Z_div_mod_eq (Zpos p) (two_power_nat n)); auto. intros C.
        set (q := Zpos p / two_power_nat n) in *.
        set (r := P_mod_two_p p n) in *.
        rewrite <- B in C.
        change (Z.neg p) with (- (Z.pos p)). destruct (zeq r 0).
        + symmetry. apply Zmod_unique with (-q). rewrite C; rewrite e. Psatz.lia.
          intuition.
        + symmetry. apply Zmod_unique with (-q - 1). rewrite C. Psatz.lia.
          intuition.
    Qed.

    (** ** Bit-level operations and properties *)

    (** Shift [x] left by one and insert [b] as the low bit of the result. *)

    Definition Zshiftin (b: bool) (x: Z) : Z :=
      if b then Z.succ_double x else Z.double x.

    Remark Ztestbit_0: forall n, Z.testbit 0 n = false.
    Proof Z.testbit_0_l.

    Remark Ztestbit_1: forall n, Z.testbit 1 n = zeq n 0.
    Proof.
      intros. destruct n; simpl; auto.
    Qed.

    Remark Ztestbit_m1: forall n, 0 <= n -> Z.testbit (-1) n = true.
    Proof.
      intros. destruct n; simpl; auto.
    Qed.

    Remark Zshiftin_spec:
      forall b x, Zshiftin b x = 2 * x + (if b then 1 else 0).
    Proof.
      unfold Zshiftin; intros. destruct b.
      - rewrite Z.succ_double_spec. lia.
      - rewrite Z.double_spec. lia.
    Qed.

    Remark Zshiftin_inj:
      forall b1 x1 b2 x2,
      Zshiftin b1 x1 = Zshiftin b2 x2 -> b1 = b2 /\ x1 = x2.
    Proof.
      intros. rewrite !Zshiftin_spec in H.
      destruct b1; destruct b2.
      split; [auto|lia].
      extlia.
      extlia.
      split; [auto|lia].
    Qed.

    Remark Zdecomp:
      forall x, x = Zshiftin (Z.odd x) (Z.div2 x).
    Proof.
      intros. destruct x; simpl.
      - auto.
      - destruct p; auto.
      - destruct p; auto. simpl. rewrite Pos.pred_double_succ. auto.
    Qed.

    Remark Ztestbit_shiftin:
      forall b x n,
      0 <= n ->
      Z.testbit (Zshiftin b x) n = if zeq n 0 then b else Z.testbit x (Z.pred n).
    Proof.
      intros. rewrite Zshiftin_spec. destruct (zeq n 0).
      - subst n. destruct b.
        + apply Z.testbit_odd_0.
        + rewrite Z.add_0_r. apply Z.testbit_even_0.
      - assert (0 <= Z.pred n) by lia.
        set (n' := Z.pred n) in *.
        replace n with (Z.succ n') by (unfold n'; lia).
        destruct b.
        + apply Z.testbit_odd_succ; auto.
        + rewrite Z.add_0_r. apply Z.testbit_even_succ; auto.
    Qed.

    Remark Ztestbit_shiftin_base:
      forall b x, Z.testbit (Zshiftin b x) 0 = b.
    Proof.
      intros. rewrite Ztestbit_shiftin; reflexivity.
    Qed.

    Remark Ztestbit_shiftin_succ:
      forall b x n, 0 <= n -> Z.testbit (Zshiftin b x) (Z.succ n) = Z.testbit x n.
    Proof.
      intros. rewrite Ztestbit_shiftin. rewrite zeq_false. rewrite Z.pred_succ. auto.
      lia. lia.
    Qed.

    Lemma Zshiftin_ind:
      forall (P: Z -> Prop),
      P 0 ->
      (forall b x, 0 <= x -> P x -> P (Zshiftin b x)) ->
      forall x, 0 <= x -> P x.
    Proof.
      intros. destruct x.
      - auto.
      - induction p.
        + change (P (Zshiftin true (Z.pos p))). auto.
        + change (P (Zshiftin false (Z.pos p))). auto.
        + change (P (Zshiftin true 0)). apply H0. lia. auto.
      - compute in H1. intuition congruence.
    Qed.

    Lemma Zshiftin_pos_ind:
      forall (P: Z -> Prop),
      P 1 ->
      (forall b x, 0 < x -> P x -> P (Zshiftin b x)) ->
      forall x, 0 < x -> P x.
    Proof.
      intros. destruct x; simpl in H1; try discriminate.
      induction p.
        + change (P (Zshiftin true (Z.pos p))). auto.
        + change (P (Zshiftin false (Z.pos p))). auto.
        + auto.
    Qed.

    (** ** Bit-wise decomposition ([Z.testbit]) *)

    Remark Ztestbit_eq:
      forall n x, 0 <= n ->
      Z.testbit x n = if zeq n 0 then Z.odd x else Z.testbit (Z.div2 x) (Z.pred n).
    Proof.
      intros. rewrite (Zdecomp x) at 1. apply Ztestbit_shiftin; auto.
    Qed.

    Remark Ztestbit_base:
      forall x, Z.testbit x 0 = Z.odd x.
    Proof.
      intros. rewrite Ztestbit_eq; reflexivity.
    Qed.

    Remark Ztestbit_succ:
      forall n x, 0 <= n -> Z.testbit x (Z.succ n) = Z.testbit (Z.div2 x) n.
    Proof.
      intros. rewrite Ztestbit_eq. rewrite zeq_false. rewrite Z.pred_succ. auto.
      lia. lia.
    Qed.

    Lemma eqmod_same_bits:
      forall n x y,
      (forall i, 0 <= i < Z.of_nat n -> Z.testbit x i = Z.testbit y i) ->
      eqmod (two_power_nat n) x y.
    Proof.
      induction n; intros.
      - change (two_power_nat 0) with 1. exists (x-y); ring.
      - rewrite two_power_nat_S.
        assert (eqmod (two_power_nat n) (Z.div2 x) (Z.div2 y)).
          apply IHn. intros. rewrite <- !Ztestbit_succ. apply H. rewrite Nat2Z.inj_succ; lia.
          lia. lia.
      destruct H0 as [k EQ].
      exists k. rewrite (Zdecomp x). rewrite (Zdecomp y).
      replace (Z.odd y) with (Z.odd x).
      rewrite EQ. rewrite !Zshiftin_spec. ring.
      exploit (H 0). rewrite Nat2Z.inj_succ; lia.
      rewrite !Ztestbit_base. auto.
    Qed.

    Lemma same_bits_eqmod:
      forall n x y i,
      eqmod (two_power_nat n) x y -> 0 <= i < Z.of_nat n ->
      Z.testbit x i = Z.testbit y i.
    Proof.
      induction n; intros.
      - simpl in H0. extlia.
      - rewrite Nat2Z.inj_succ in H0. rewrite two_power_nat_S in H.
        rewrite !(Ztestbit_eq i); intuition.
        destruct H as [k EQ].
        assert (EQ': Zshiftin (Z.odd x) (Z.div2 x) =
                     Zshiftin (Z.odd y) (k * two_power_nat n + Z.div2 y)).
        {
          rewrite (Zdecomp x) in EQ. rewrite (Zdecomp y) in EQ.
          rewrite EQ. rewrite !Zshiftin_spec. ring.
        }
        exploit Zshiftin_inj; eauto. intros [A B].
        destruct (zeq i 0).
        + auto.
        + apply IHn. exists k; auto. lia.
    Qed.

    Lemma equal_same_bits:
      forall x y,
      (forall i, 0 <= i -> Z.testbit x i = Z.testbit y i) ->
      x = y.
    Proof Z.bits_inj'.

    Lemma Z_one_complement:
      forall i, 0 <= i ->
      forall x, Z.testbit (-x-1) i = negb (Z.testbit x i).
    Proof.
      intros i0 POS0. pattern i0. apply Zlt_0_ind; auto.
      intros i IND POS x.
      rewrite (Zdecomp x). set (y := Z.div2 x).
      replace (- Zshiftin (Z.odd x) y - 1)
         with (Zshiftin (negb (Z.odd x)) (- y - 1)).
      rewrite !Ztestbit_shiftin; auto.
      destruct (zeq i 0). auto. apply IND. lia.
      rewrite !Zshiftin_spec. destruct (Z.odd x); simpl negb; ring.
    Qed.

    Lemma Ztestbit_above:
      forall n x i,
      0 <= x < two_power_nat n ->
      i >= Z.of_nat n ->
      Z.testbit x i = false.
    Proof.
      induction n; intros.
      - change (two_power_nat 0) with 1 in H.
        replace x with 0 by lia.
        apply Z.testbit_0_l.
      - rewrite Nat2Z.inj_succ in H0. rewrite Ztestbit_eq. rewrite zeq_false.
        apply IHn. rewrite two_power_nat_S in H. rewrite (Zdecomp x) in H.
        rewrite Zshiftin_spec in H. destruct (Z.odd x); lia.
        lia. lia. lia.
    Qed.

    Lemma Ztestbit_above_neg:
      forall n x i,
      -two_power_nat n <= x < 0 ->
      i >= Z.of_nat n ->
      Z.testbit x i = true.
    Proof.
      intros. set (y := -x-1).
      assert (Z.testbit y i = false).
        apply Ztestbit_above with n.
        unfold y; lia. auto.
      unfold y in H1. rewrite Z_one_complement in H1.
      change true with (negb false). rewrite <- H1. rewrite negb_involutive; auto.
      lia.
    Qed.

    Lemma Zsign_bit:
      forall n x,
      0 <= x < two_power_nat (S n) ->
      Z.testbit x (Z.of_nat n) = if zlt x (two_power_nat n) then false else true.
    Proof.
      induction n; intros.
      - change (two_power_nat 1) with 2 in H.
        assert (x = 0 \/ x = 1) by lia.
        destruct H0; subst x; reflexivity.
      - rewrite Nat2Z.inj_succ. rewrite Ztestbit_eq. rewrite zeq_false. rewrite Z.pred_succ.
        rewrite IHn. rewrite two_power_nat_S.
        destruct (zlt (Z.div2 x) (two_power_nat n)); rewrite (Zdecomp x); rewrite Zshiftin_spec.
        rewrite zlt_true. auto. destruct (Z.odd x); lia.
        rewrite zlt_false. auto. destruct (Z.odd x); lia.
        rewrite (Zdecomp x) in H; rewrite Zshiftin_spec in H.
        rewrite two_power_nat_S in H. destruct (Z.odd x); lia.
        lia. lia.
    Qed.

    Lemma Ztestbit_le:
      forall x y,
      0 <= y ->
      (forall i, 0 <= i -> Z.testbit x i = true -> Z.testbit y i = true) ->
      x <= y.
    Proof.
      intros x y0 POS0; revert x; pattern y0; apply Zshiftin_ind; auto; intros.
      - replace x with 0. lia. apply equal_same_bits; intros.
        rewrite Ztestbit_0. destruct (Z.testbit x i) as [] eqn:E; auto.
        exploit H; eauto. rewrite Ztestbit_0. auto.
      - assert (Z.div2 x0 <= x).
        { apply H0. intros. exploit (H1 (Z.succ i)).
            lia. rewrite Ztestbit_succ; auto. rewrite Ztestbit_shiftin_succ; auto.
        }
        rewrite (Zdecomp x0). rewrite !Zshiftin_spec.
        destruct (Z.odd x0) as [] eqn:E1; destruct b as [] eqn:E2; try lia.
        exploit (H1 0). lia. rewrite Ztestbit_base; auto.
        rewrite Ztestbit_shiftin_base. congruence.
    Qed.

    Lemma Ztestbit_mod_two_p:
      forall n x i,
      0 <= n -> 0 <= i ->
      Z.testbit (x mod (two_p n)) i = if zlt i n then Z.testbit x i else false.
    Proof.
      intros n0 x i N0POS. revert x i; pattern n0; apply natlike_ind; auto.
      - intros. change (two_p 0) with 1. rewrite Zmod_1_r. rewrite Z.testbit_0_l.
        rewrite zlt_false; auto. lia.
      - intros. rewrite two_p_S; auto.
        replace (x0 mod (2 * two_p x))
           with (Zshiftin (Z.odd x0) (Z.div2 x0 mod two_p x)).
        rewrite Ztestbit_shiftin; auto. rewrite (Ztestbit_eq i x0); auto. destruct (zeq i 0).
        + rewrite zlt_true; auto. lia.
        + rewrite H0. destruct (zlt (Z.pred i) x).
          * rewrite zlt_true; auto. lia.
          * rewrite zlt_false; auto. lia.
          * lia.
        + rewrite (Zdecomp x0) at 3. set (x1 := Z.div2 x0). symmetry.
          apply Zmod_unique with (x1 / two_p x).
          rewrite !Zshiftin_spec. rewrite Z.add_assoc. f_equal.
          transitivity (2 * (two_p x * (x1 / two_p x) + x1 mod two_p x)).
          f_equal. apply Z_div_mod_eq. apply two_p_gt_ZERO; auto.
          ring.
          rewrite Zshiftin_spec. exploit (Z_mod_lt x1 (two_p x)). apply two_p_gt_ZERO; auto.
          destruct (Z.odd x0); lia.
    Qed.

    Corollary Ztestbit_two_p_m1:
      forall n i, 0 <= n -> 0 <= i ->
      Z.testbit (two_p n - 1) i = if zlt i n then true else false.
    Proof.
      intros. replace (two_p n - 1) with ((-1) mod (two_p n)).
      rewrite Ztestbit_mod_two_p; auto. destruct (zlt i n); auto. apply Ztestbit_m1; auto.
      apply Zmod_unique with (-1). ring.
      exploit (two_p_gt_ZERO n). auto. lia.
    Qed.

    Corollary Ztestbit_neg_two_p:
      forall n i, 0 <= n -> 0 <= i ->
      Z.testbit (- (two_p n)) i = if zlt i n then false else true.
    Proof.
      intros.
      replace (- two_p n) with (- (two_p n - 1) - 1) by lia.
      rewrite Z_one_complement by auto.
      rewrite Ztestbit_two_p_m1 by auto.
      destruct (zlt i n); auto.
    Qed.

    Lemma Z_add_is_or:
      forall i, 0 <= i ->
      forall x y,
      (forall j, 0 <= j <= i -> Z.testbit x j && Z.testbit y j = false) ->
      Z.testbit (x + y) i = Z.testbit x i || Z.testbit y i.
    Proof.
      intros i0 POS0. pattern i0. apply Zlt_0_ind; auto.
      intros i IND POS x y EXCL.
      rewrite (Zdecomp x) in *. rewrite (Zdecomp y) in *.
      transitivity (Z.testbit (Zshiftin (Z.odd x || Z.odd y) (Z.div2 x + Z.div2 y)) i).
      - f_equal. rewrite !Zshiftin_spec.
        exploit (EXCL 0). lia. rewrite !Ztestbit_shiftin_base. intros.
    Opaque Z.mul.
        destruct (Z.odd x); destruct (Z.odd y); simpl in *; discriminate || ring.
      - rewrite !Ztestbit_shiftin; auto.
        destruct (zeq i 0).
        + auto.
        + apply IND. lia. intros.
          exploit (EXCL (Z.succ j)). lia.
          rewrite !Ztestbit_shiftin_succ. auto.
          lia. lia.
    Qed.

    (** ** Zero and sign extensions *)

    (** In pseudo-code:
    <<
        Fixpoint Zzero_ext (n: Z) (x: Z) : Z :=
          if zle n 0 then
            0
          else
            Zshiftin (Z.odd x) (Zzero_ext (Z.pred n) (Z.div2 x)).
        Fixpoint Zsign_ext (n: Z) (x: Z) : Z :=
          if zle n 1 then
            if Z.odd x then -1 else 0
          else
            Zshiftin (Z.odd x) (Zzero_ext (Z.pred n) (Z.div2 x)).
    >>
      We encode this [nat]-like recursion using the [Z.iter] iteration
      function, in order to make the [Zzero_ext] and [Zsign_ext]
      functions efficiently executable within Coq.
    *)

    Definition Zzero_ext (n: Z) (x: Z) : Z :=
      Z.iter n
        (fun rec x => Zshiftin (Z.odd x) (rec (Z.div2 x)))
        (fun x => 0)
        x.

    Definition Zsign_ext (n: Z) (x: Z) : Z :=
      Z.iter (Z.pred n)
        (fun rec x => Zshiftin (Z.odd x) (rec (Z.div2 x)))
        (fun x => if Z.odd x && zlt 0 n then -1 else 0)
        x.

    Lemma Ziter_base:
      forall (A: Type) n (f: A -> A) x, n <= 0 -> Z.iter n f x = x.
    Proof.
      intros. unfold Z.iter. destruct n; auto. compute in H. elim H; auto.
    Qed.

    Lemma Ziter_succ:
      forall (A: Type) n (f: A -> A) x,
      0 <= n -> Z.iter (Z.succ n) f x = f (Z.iter n f x).
    Proof.
      intros. destruct n; simpl.
      - auto.
      - rewrite Pos.add_1_r. apply Pos.iter_succ.
      - compute in H. elim H; auto.
    Qed.

    Lemma Znatlike_ind:
      forall (P: Z -> Prop),
      (forall n, n <= 0 -> P n) ->
      (forall n, 0 <= n -> P n -> P (Z.succ n)) ->
      forall n, P n.
    Proof.
      intros. destruct (zle 0 n).
      apply natlike_ind; auto. apply H; lia.
      apply H. lia.
    Qed.

    Lemma Zzero_ext_spec:
      forall n x i, 0 <= i ->
      Z.testbit (Zzero_ext n x) i = if zlt i n then Z.testbit x i else false.
    Proof.
      unfold Zzero_ext. induction n using Znatlike_ind.
      - intros. rewrite Ziter_base; auto.
        rewrite zlt_false. rewrite Ztestbit_0; auto. lia.
      - intros. rewrite Ziter_succ; auto.
        rewrite Ztestbit_shiftin; auto.
        rewrite (Ztestbit_eq i x); auto.
        destruct (zeq i 0).
        + subst i. rewrite zlt_true; auto. lia.
        + rewrite IHn. destruct (zlt (Z.pred i) n).
          rewrite zlt_true; auto. lia.
          rewrite zlt_false; auto. lia.
          lia.
    Qed.

    Lemma Zsign_ext_spec:
      forall n x i, 0 <= i ->
      Z.testbit (Zsign_ext n x) i = Z.testbit x (if zlt i n then i else n - 1).
    Proof.
      intros n0 x i I0. unfold Zsign_ext.
      unfold proj_sumbool; destruct (zlt 0 n0) as [N0|N0]; simpl.
    - revert x i I0. pattern n0. apply Zlt_lower_bound_ind with (z := 1); [ | lia ].
      unfold Zsign_ext. intros.
      destruct (zeq x 1).
      + subst x; simpl.
        replace (if zlt i 1 then i else 0) with 0.
        rewrite Ztestbit_base.
        destruct (Z.odd x0); [ apply Ztestbit_m1; auto | apply Ztestbit_0 ].
        destruct (zlt i 1); lia.
      + set (x1 := Z.pred x). replace x1 with (Z.succ (Z.pred x1)) by lia.
        rewrite Ziter_succ by (unfold x1; lia). rewrite Ztestbit_shiftin by auto.
        destruct (zeq i 0).
        * subst i. rewrite zlt_true. rewrite Ztestbit_base; auto. lia.
        * rewrite H by (unfold x1; lia).
          unfold x1; destruct (zlt (Z.pred i) (Z.pred x)).
          ** rewrite zlt_true by lia.
             rewrite (Ztestbit_eq i x0) by lia.
             rewrite zeq_false by lia. auto.
          ** rewrite zlt_false by lia.
             rewrite (Ztestbit_eq (x - 1) x0) by lia.
             rewrite zeq_false by lia. auto.
    - rewrite Ziter_base by lia. rewrite andb_false_r.
      rewrite Z.testbit_0_l, Z.testbit_neg_r. auto.
      destruct (zlt i n0); lia.
    Qed.

    (** [Zzero_ext n x] is [x modulo 2^n] *)

    Lemma Zzero_ext_mod:
      forall n x, 0 <= n -> Zzero_ext n x = x mod (two_p n).
    Proof.
      intros. apply equal_same_bits; intros.
      rewrite Zzero_ext_spec, Ztestbit_mod_two_p by auto. auto.
    Qed.

    (** [Zzero_ext n x] is the unique integer congruent to [x] modulo [2^n] in the range [0...2^n-1]. *)

    Lemma Zzero_ext_range:
      forall n x, 0 <= n -> 0 <= Zzero_ext n x < two_p n.
    Proof.
      intros. rewrite Zzero_ext_mod; auto. apply Z_mod_lt. apply two_p_gt_ZERO. lia.
    Qed.

    Lemma eqmod_Zzero_ext:
      forall n x, 0 <= n -> eqmod (two_p n) (Zzero_ext n x) x.
    Proof.
      intros. rewrite Zzero_ext_mod; auto. apply eqmod_sym. apply eqmod_mod.
      apply two_p_gt_ZERO. lia.
    Qed.

    (** Relation between [Zsign_ext n x] and (Zzero_ext n x] *)

    Lemma Zsign_ext_zero_ext:
      forall n, 0 <= n -> forall x,
      Zsign_ext n x = Zzero_ext n x - (if Z.testbit x (n - 1) then two_p n else 0).
    Proof.
      intros. apply equal_same_bits; intros.
      rewrite Zsign_ext_spec by auto.
      destruct (Z.testbit x (n - 1)) eqn:SIGNBIT.
    - set (n' := - two_p n).
      replace (Zzero_ext n x - two_p n) with (Zzero_ext n x + n') by (unfold n'; lia).
      rewrite Z_add_is_or; auto.
      rewrite Zzero_ext_spec by auto. unfold n'; rewrite Ztestbit_neg_two_p by lia.
      destruct (zlt i n). rewrite orb_false_r; auto. auto.
      intros. rewrite Zzero_ext_spec by lia. unfold n'; rewrite Ztestbit_neg_two_p by lia.
      destruct (zlt j n); auto using andb_false_r.
    - replace (Zzero_ext n x - 0) with (Zzero_ext n x) by lia.
      rewrite Zzero_ext_spec by auto.
      destruct (zlt i n); auto.
    Qed.

    (** [Zsign_ext n x] is the unique integer congruent to [x] modulo [2^n]
        in the range [-2^(n-1)...2^(n-1) - 1]. *)

    Lemma Zsign_ext_range:
      forall n x, 0 < n -> -two_p (n-1) <= Zsign_ext n x < two_p (n-1).
    Proof.
      intros.
      assert (A: 0 <= Zzero_ext n x < two_p n) by (apply Zzero_ext_range; lia).
      assert (B: Z.testbit (Zzero_ext n x) (n - 1) =
                 if zlt (Zzero_ext n x) (two_p (n - 1)) then false else true).
      { set (N := Z.to_nat (n - 1)).
        generalize (Zsign_bit N (Zzero_ext n x)).
        rewrite ! two_power_nat_two_p.
        rewrite inj_S.  unfold N; rewrite Z2Nat.id by lia.
        intros X; apply X.  replace (Z.succ (n - 1)) with n by lia. exact A.
      }
      assert (C: two_p n = 2 * two_p (n - 1)).
      { rewrite <- two_p_S by lia. f_equal; lia. }
      rewrite Zzero_ext_spec, zlt_true in B by lia.
      rewrite Zsign_ext_zero_ext by lia. rewrite B.
      destruct (zlt (Zzero_ext n x) (two_p (n - 1))); lia.
    Qed.

    Lemma eqmod_Zsign_ext:
      forall n x, 0 <= n ->
      eqmod (two_p n) (Zsign_ext n x) x.
    Proof.
      intros. rewrite Zsign_ext_zero_ext by auto.
      apply eqmod_trans with (x - 0).
      apply eqmod_sub.
      apply eqmod_Zzero_ext; lia.
      exists (if Z.testbit x (n - 1) then 1 else 0). destruct (Z.testbit x (n - 1)); ring.
      apply eqmod_refl2; lia.
    Qed.

    (** ** Decomposition of a number as a sum of powers of two. *)

    Fixpoint Z_one_bits (n: nat) (x: Z) (i: Z) {struct n}: list Z :=
      match n with
      | O => nil
      | S m =>
          if Z.odd x
          then i :: Z_one_bits m (Z.div2 x) (i+1)
          else Z_one_bits m (Z.div2 x) (i+1)
      end.

    Fixpoint powerserie (l: list Z): Z :=
      match l with
      | nil => 0
      | x :: xs => two_p x + powerserie xs
      end.

    Lemma Z_one_bits_powerserie:
      forall n x, 0 <= x < two_power_nat n -> x = powerserie (Z_one_bits n x 0).
    Proof.
      assert (forall n x i,
        0 <= i ->
        0 <= x < two_power_nat n ->
        x * two_p i = powerserie (Z_one_bits n x i)).
      {
      induction n; intros.
      simpl. rewrite two_power_nat_O in H0.
      assert (x = 0) by lia. subst x. lia.
      rewrite two_power_nat_S in H0. simpl Z_one_bits.
      rewrite (Zdecomp x) in H0. rewrite Zshiftin_spec in H0.
      assert (EQ: Z.div2 x * two_p (i + 1) = powerserie (Z_one_bits n (Z.div2 x) (i + 1))).
        apply IHn. lia.
        destruct (Z.odd x); lia.
      rewrite two_p_is_exp in EQ. change (two_p 1) with 2 in EQ.
      rewrite (Zdecomp x) at 1. rewrite Zshiftin_spec.
      destruct (Z.odd x); simpl powerserie; rewrite <- EQ; ring.
      lia. lia.
      }
      intros. rewrite <- H. change (two_p 0) with 1. lia.
      lia. exact H0.
    Qed.

    Lemma Z_one_bits_range:
      forall n x i, In i (Z_one_bits n x 0) -> 0 <= i < Z.of_nat n.
    Proof.
      assert (forall n x i j,
        In j (Z_one_bits n x i) -> i <= j < i + Z.of_nat n).
      {
      induction n; simpl In.
      tauto.
      intros x i j. rewrite Nat2Z.inj_succ.
      assert (In j (Z_one_bits n (Z.div2 x) (i + 1)) -> i <= j < i + Z.succ (Z.of_nat n)).
        intros. exploit IHn; eauto. lia.
      destruct (Z.odd x); simpl.
      intros [A|B]. subst j. lia. auto.
      auto.
      }
      intros. generalize (H n x 0 i H0). lia.
    Qed.

    Remark Z_one_bits_zero:
      forall n i, Z_one_bits n 0 i = nil.
    Proof.
      induction n; intros; simpl; auto.
    Qed.

    Remark Z_one_bits_two_p:
      forall n x i,
      0 <= x < Z.of_nat n ->
      Z_one_bits n (two_p x) i = (i + x) :: nil.
    Proof.
      induction n; intros; simpl. simpl in H. extlia.
      rewrite Nat2Z.inj_succ in H.
      assert (x = 0 \/ 0 < x) by lia. destruct H0.
      subst x; simpl. decEq. lia. apply Z_one_bits_zero.
      assert (Z.odd (two_p x) = false /\ Z.div2 (two_p x) = two_p (x-1)).
        apply Zshiftin_inj. rewrite <- Zdecomp. rewrite !Zshiftin_spec.
        rewrite <- two_p_S. rewrite Z.add_0_r. f_equal; lia. lia.
      destruct H1 as [A B]; rewrite A; rewrite B.
      rewrite IHn. f_equal; lia. lia.
    Qed.

    (** ** Recognition of powers of two *)

    Fixpoint P_is_power2 (p: positive) : bool :=
      match p with
      | xH => true
      | xO q => P_is_power2 q
      | xI q => false
      end.

    Definition Z_is_power2 (x: Z) : option Z :=
      match x with
      | Z0 => None
      | Zpos p => if P_is_power2 p then Some (Z.log2 x) else None
      | Zneg _ => None
      end.

    Remark P_is_power2_sound:
      forall p, P_is_power2 p = true -> Z.pos p = two_p (Z.log2 (Z.pos p)).
    Proof.
      induction p; simpl P_is_power2; intros.
    - discriminate.
    - change (Z.pos p~0) with (2 * Z.pos p).  apply IHp in H.
      rewrite Z.log2_double by extlia. rewrite two_p_S.  congruence.
      apply Z.log2_nonneg.
    - reflexivity.
    Qed.

    Lemma Z_is_power2_nonneg:
      forall x i, Z_is_power2 x = Some i -> 0 <= i.
    Proof.
      unfold Z_is_power2; intros. destruct x; try discriminate.
      destruct (P_is_power2 p) eqn:P; try discriminate.
      replace i with (Z.log2 (Z.pos p)) by congruence. apply Z.log2_nonneg.
    Qed.

    Lemma Z_is_power2_sound:
      forall x i, Z_is_power2 x = Some i -> x = two_p i /\ i = Z.log2 x.
    Proof.
      unfold Z_is_power2; intros. destruct x; try discriminate.
      destruct (P_is_power2 p) eqn:P; try discriminate.
      apply P_is_power2_sound in P. rewrite P; split; congruence.
    Qed.

    Corollary Z_is_power2_range:
      forall n x i,
      0 <= n -> 0 <= x < two_p n -> Z_is_power2 x = Some i -> 0 <= i < n.
    Proof.
      intros.
      assert (x <> 0) by (red; intros; subst x; discriminate).
      apply Z_is_power2_sound in H1. destruct H1 as [P Q]. subst i.
      split. apply Z.log2_nonneg. apply Z.log2_lt_pow2. lia. rewrite <- two_p_equiv; tauto.
    Qed.

    Lemma Z_is_power2_complete:
      forall i, 0 <= i -> Z_is_power2 (two_p i) = Some i.
    Proof.
    Opaque Z.log2.
      assert (A: forall x i, Z_is_power2 x = Some i -> Z_is_power2 (2 * x) = Some (Z.succ i)).
      { destruct x; simpl; intros; try discriminate.
        change (2 * Z.pos p) with (Z.pos (xO p)); simpl.
        destruct (P_is_power2 p); inv H. rewrite <- Z.log2_double by extlia. auto.
      }
      induction i using Znatlike_ind; intros.
    - replace i with 0 by lia. reflexivity.
    - rewrite two_p_S by lia. apply A. apply IHi; lia.
    Qed.

    Definition Z_is_power2m1 (x: Z) : option Z := Z_is_power2 (Z.succ x).

    Lemma Z_is_power2m1_nonneg:
      forall x i, Z_is_power2m1 x = Some i -> 0 <= i.
    Proof.
      unfold Z_is_power2m1; intros. eapply Z_is_power2_nonneg; eauto.
    Qed.

    Lemma Z_is_power2m1_sound:
      forall x i, Z_is_power2m1 x = Some i -> x = two_p i - 1.
    Proof.
      unfold Z_is_power2m1; intros. apply Z_is_power2_sound in H. lia.
    Qed.

    Lemma Z_is_power2m1_complete:
      forall i, 0 <= i -> Z_is_power2m1 (two_p i - 1) = Some i.
    Proof.
      intros. unfold Z_is_power2m1. replace (Z.succ (two_p i - 1)) with (two_p i) by lia.
      apply Z_is_power2_complete; auto.
    Qed.

    Lemma Z_is_power2m1_range:
      forall n x i,
      0 <= n -> 0 <= x < two_p n -> Z_is_power2m1 x = Some i -> 0 <= i <= n.
    Proof.
      intros. destruct (zeq x (two_p n - 1)).
    - subst x. rewrite Z_is_power2m1_complete in H1 by auto. inv H1; lia.
    - unfold Z_is_power2m1 in H1. apply (Z_is_power2_range n (Z.succ x) i) in H1; lia.
    Qed.

    (** ** Relation between bitwise operations and multiplications / divisions by powers of 2 *)

    (** Left shifts and multiplications by powers of 2. *)

    Lemma Zshiftl_mul_two_p:
      forall x n, 0 <= n -> Z.shiftl x n = x * two_p n.
    Proof.
      intros. destruct n; simpl.
      - lia.
      - pattern p. apply Pos.peano_ind.
        + change (two_power_pos 1) with 2. simpl. ring.
        + intros. rewrite Pos.iter_succ. rewrite H0.
          rewrite Pplus_one_succ_l. rewrite two_power_pos_is_exp.
          change (two_power_pos 1) with 2. ring.
      - compute in H. congruence.
    Qed.

    (** Right shifts and divisions by powers of 2. *)

    Lemma Zshiftr_div_two_p:
      forall x n, 0 <= n -> Z.shiftr x n = x / two_p n.
    Proof.
      intros. destruct n; unfold Z.shiftr; simpl.
      - rewrite Zdiv_1_r. auto.
      - pattern p. apply Pos.peano_ind.
        + change (two_power_pos 1) with 2. simpl. apply Zdiv2_div.
        + intros. rewrite Pos.iter_succ. rewrite H0.
          rewrite Pplus_one_succ_l. rewrite two_power_pos_is_exp.
          change (two_power_pos 1) with 2.
          rewrite Zdiv2_div. rewrite Z.mul_comm. apply Zdiv_Zdiv.
          rewrite two_power_pos_nat. apply two_power_nat_pos. lia.
      - compute in H. congruence.
    Qed.

    (** ** Properties of [shrx] (signed division by a power of 2) *)

    Lemma Zquot_Zdiv:
      forall x y,
      y > 0 ->
      Z.quot x y = if zlt x 0 then (x + y - 1) / y else x / y.
    Proof.
      intros. destruct (zlt x 0).
      - symmetry. apply Zquot_unique_full with ((x + y - 1) mod y - (y - 1)).
         + red. right; split. lia.
           exploit (Z_mod_lt (x + y - 1) y); auto.
           rewrite Z.abs_eq. lia. lia.
         + transitivity ((y * ((x + y - 1) / y) + (x + y - 1) mod y) - (y-1)).
           rewrite <- Z_div_mod_eq. ring. auto. ring.
      - apply Zquot_Zdiv_pos; lia.
    Qed.

    Lemma Zdiv_shift:
      forall x y, y > 0 ->
      (x + (y - 1)) / y = x / y + if zeq (Z.modulo x y) 0 then 0 else 1.
    Proof.
      intros. generalize (Z_div_mod_eq x y H). generalize (Z_mod_lt x y H).
      set (q := x / y). set (r := x mod y). intros.
      destruct (zeq r 0).
      apply Zdiv_unique with (y - 1). rewrite H1. rewrite e. ring. lia.
      apply Zdiv_unique with (r - 1). rewrite H1. ring. lia.
    Qed.

    (** ** Size of integers, in bits. *)

    Definition Zsize (x: Z) : Z :=
      match x with
      | Zpos p => Zpos (Pos.size p)
      | _ => 0
      end.

    Remark Zsize_pos: forall x, 0 <= Zsize x.
    Proof.
      destruct x; simpl. lia. compute; intuition congruence. lia.
    Qed.

    Remark Zsize_pos': forall x, 0 < x -> 0 < Zsize x.
    Proof.
      destruct x; simpl; intros; try discriminate. compute; auto.
    Qed.

    Lemma Zsize_shiftin:
      forall b x, 0 < x -> Zsize (Zshiftin b x) = Z.succ (Zsize x).
    Proof.
      intros. destruct x; compute in H; try discriminate.
      destruct b.
      change (Zshiftin true (Zpos p)) with (Zpos (p~1)).
      simpl. f_equal. rewrite Pos.add_1_r; auto.
      change (Zshiftin false (Zpos p)) with (Zpos (p~0)).
      simpl. f_equal. rewrite Pos.add_1_r; auto.
    Qed.

    Lemma Ztestbit_size_1:
      forall x, 0 < x -> Z.testbit x (Z.pred (Zsize x)) = true.
    Proof.
      intros x0 POS0; pattern x0; apply Zshiftin_pos_ind; auto.
      intros. rewrite Zsize_shiftin; auto.
      replace (Z.pred (Z.succ (Zsize x))) with (Z.succ (Z.pred (Zsize x))) by lia.
      rewrite Ztestbit_shiftin_succ. auto. generalize (Zsize_pos' x H); lia.
    Qed.

    Lemma Ztestbit_size_2:
      forall x, 0 <= x -> forall i, i >= Zsize x -> Z.testbit x i = false.
    Proof.
      intros x0 POS0. destruct (zeq x0 0).
      - subst x0; intros. apply Ztestbit_0.
      - pattern x0; apply Zshiftin_pos_ind.
        + simpl. intros. change 1 with (Zshiftin true 0). rewrite Ztestbit_shiftin.
          rewrite zeq_false. apply Ztestbit_0. lia. lia.
        + intros. rewrite Zsize_shiftin in H1; auto.
          generalize (Zsize_pos' _ H); intros.
          rewrite Ztestbit_shiftin. rewrite zeq_false. apply H0. lia.
          lia. lia.
        + lia.
    Qed.

    Lemma Zsize_interval_1:
      forall x, 0 <= x -> 0 <= x < two_p (Zsize x).
    Proof.
      intros.
      assert (x = x mod (two_p (Zsize x))).
        apply equal_same_bits; intros.
        rewrite Ztestbit_mod_two_p; auto.
        destruct (zlt i (Zsize x)). auto. apply Ztestbit_size_2; auto.
        apply Zsize_pos; auto.
      rewrite H0 at 1. rewrite H0 at 3. apply Z_mod_lt. apply two_p_gt_ZERO. apply Zsize_pos; auto.
    Qed.

    Lemma Zsize_interval_2:
      forall x n, 0 <= n -> 0 <= x < two_p n -> n >= Zsize x.
    Proof.
      intros. set (N := Z.to_nat n).
      assert (Z.of_nat N = n) by (apply Z2Nat.id; auto).
      rewrite <- H1 in H0. rewrite <- two_power_nat_two_p in H0.
      destruct (zeq x 0).
      subst x; simpl; lia.
      destruct (zlt n (Zsize x)); auto.
      exploit (Ztestbit_above N x (Z.pred (Zsize x))). auto. lia.
      rewrite Ztestbit_size_1. congruence. lia.
    Qed.

    Lemma Zsize_monotone:
      forall x y, 0 <= x <= y -> Zsize x <= Zsize y.
    Proof.
      intros. apply Z.ge_le. apply Zsize_interval_2. apply Zsize_pos.
      exploit (Zsize_interval_1 y). lia.
      lia.
    Qed.

    (** ** Bit insertion, bit extraction *)

    (** Extract and optionally sign-extend bits [from...from+len-1] of [x] *)
    Definition Zextract_u (x: Z) (from: Z) (len: Z) : Z :=
      Zzero_ext len (Z.shiftr x from).

    Definition Zextract_s (x: Z) (from: Z) (len: Z) : Z :=
      Zsign_ext len (Z.shiftr x from).

    Lemma Zextract_u_spec:
      forall x from len i,
      0 <= from -> 0 <= len -> 0 <= i ->
      Z.testbit (Zextract_u x from len) i =
      if zlt i len then Z.testbit x (from + i) else false.
    Proof.
      unfold Zextract_u; intros. rewrite Zzero_ext_spec, Z.shiftr_spec by auto.
      rewrite Z.add_comm. auto.
    Qed.

    Lemma Zextract_s_spec:
      forall x from len i,
      0 <= from -> 0 < len -> 0 <= i ->
      Z.testbit (Zextract_s x from len) i =
      Z.testbit x (from + (if zlt i len then i else len - 1)).
    Proof.
      unfold Zextract_s; intros. rewrite Zsign_ext_spec by auto. rewrite Z.shiftr_spec.
      rewrite Z.add_comm. auto.
      destruct (zlt i len); lia.
    Qed.

    (** Insert bits [0...len-1] of [y] into bits [to...to+len-1] of [x] *)

    Definition Zinsert (x y: Z) (to: Z) (len: Z) : Z :=
      let mask := Z.shiftl (two_p len - 1) to in
      Z.lor (Z.land (Z.shiftl y to) mask) (Z.ldiff x mask).

    Lemma Zinsert_spec:
      forall x y to len i,
      0 <= to -> 0 <= len -> 0 <= i ->
      Z.testbit (Zinsert x y to len) i =
        if zle to i && zlt i (to + len)
        then Z.testbit y (i - to)
        else Z.testbit x i.
    Proof.
      unfold Zinsert; intros. set (mask := two_p len - 1).
      assert (M: forall j, 0 <= j -> Z.testbit mask j = if zlt j len then true else false).
      { intros; apply Ztestbit_two_p_m1; auto. }
      rewrite Z.lor_spec, Z.land_spec, Z.ldiff_spec by auto.
      destruct (zle to i).
    - rewrite ! Z.shiftl_spec by auto. rewrite ! M by lia.
      unfold proj_sumbool; destruct (zlt (i - to) len); simpl;
      rewrite andb_true_r, andb_false_r.
    + rewrite zlt_true by lia. apply orb_false_r.
    + rewrite zlt_false by lia; auto.
    - rewrite ! Z.shiftl_spec_low by lia. simpl. apply andb_true_r.
    Qed.


(** FIXME: rework to follow the same approach as [Monad]
  wrt its relation with [Functor]. *)

Require Export Coq.Program.Basics.
Require Import ExtensionalityAxioms.
Require Import Functor.
Require Import Lens.

(** * Interface of comonads *)

(** Comonads are defined in terms of [extract] and [extend]. *)

Class ComonadOps (W: Type -> Type) := {
  extract {A}: W A -> A;
  extend {A B}: (W A -> B) -> W A -> W B
}.

Class Comonad (W: Type -> Type) `{Wops: ComonadOps W}: Prop := {
  comonad_extract_extend {A B} (f: W A -> B) (w: W A):
    extract (extend f w) = f w;
  comonad_extend_extract {A} (w: W A):
    extend extract w = w;
  comonad_extend_extend {A B C} (f : W B -> C) (g: W A -> B) (w: W A):
    extend f (extend g w) = extend (fun w => f (extend g w)) w
}.

Hint Rewrite
    @comonad_extract_extend
    @comonad_extend_extract
    @comonad_extend_extend
  using typeclasses eauto : comonad.

(** * Comonads are functors *)

Section FUNCTOR.
  Context `{HW: Comonad}.

  Global Instance comonad_fmap: FunctorOps W := {
    fmap A B f :=
      extend (fun w => f (extract w))
  }.

  Global Instance comonad_functor: Functor W.
  Proof.
    split; intros; simpl; autorewrite with comonad.
    - reflexivity.
    - setoid_rewrite comonad_extract_extend.
      reflexivity.
  Qed.
End FUNCTOR.

(** * Definitions and theorems *)

Section THEORY.
  Context `{HW: Comonad}.

  Definition put {A B} (x: B): W A -> W B :=
    extend (const x).

  Theorem comonad_extend_eq {A B} (f g: W A -> B) (w: W A):
    extend f w = extend g w -> f w = g w.
  Proof.
    intros.
    apply (f_equal extract) in H.
    rewrite !comonad_extract_extend in H.
    assumption.
  Qed.

  Theorem comonad_put_eq {A B} (x y: B) (w: W A):
    put x w = put y w <-> x = y.
  Proof.
    split.
    - apply comonad_extend_eq.
    - intro; apply f_equal2; trivial.
  Qed.

  Theorem comonad_extract_put {A B} (x: A) (w: W B):
    extract (put x w) = x.
  Proof.
    unfold put.
    apply comonad_extract_extend.
  Qed.

  Theorem comonad_put_put {A B C} (x: A) (y: B) (w: W C):
    put x (put y w) = put x w.
  Proof.
    unfold put, const.
    rewrite comonad_extend_extend.
    reflexivity.
  Qed.
End THEORY.

(** * Comonad-based lens *)

(** Given a comonad [W], we can define lens operations, where we get
  a substructure of type [A] in a structure of type [W A]. However,
  [LensSetGet] does not follow from the comonad laws. *)

Section LENS.
  Context (W: Type -> Type) `{HW: Comonad W} (A: Type).

  Global Instance comonad_lensops: LensOps (V:=A) extract := {
    set := put
  }.

  Global Instance comonad_get_set: LensGetSet extract := {
    lens_get_set := comonad_extract_put
  }.

  Global Instance comonad_set_set: LensSetSet extract := {
    lens_set_set := comonad_put_put
  }.

  (** [LensSetGet] does not hold in general -- for instance in the store
    comonad, [put] overwrites all entries instead of just the focused one. *)
  Context `{Hps: !LensSetGet extract}.

  (** Provided the Put/Get law is proved separately, we get a lens. *)
  Global Instance comonad_lens: Lens extract := {}.

  (** In addition, we can provide this equivalent lemma, formulated in
    terms of extract and set. *)
  Lemma comonad_put_extract (w: W A):
    put (extract w) w = w.
  Proof.
    exact (lens_set_get w).
  Qed.
End LENS.

Hint Rewrite
    @comonad_put_eq
    @comonad_extract_put
    @comonad_put_put
    @comonad_put_extract
  using typeclasses eauto: comonad.

(** * Some instances *)

Section INSTANCES.
  Open Scope type_scope.

  (** ** [A * -] is a comonad. *)

  Global Instance prod_comonad_ops {A}: ComonadOps (prod A) := {
    extract := @snd A;
    extend X Y f x := (fst x, f x)
  }.

  Global Instance prod_comonad {A}: Comonad (prod A).
  Proof.
    split; simpl; try destruct w; now reflexivity.
  Qed.

  (** ** [- * A] is a comonad *)

  Global Instance prod_l_comonad_ops {A}: ComonadOps (fun X => X * A) := {
    extract X := @fst X A;
    extend X Y f x := (f x, snd x)
  }.

  Global Instance prod_l_comonad {A}: Comonad (fun X => X * A).
  Proof.
    split; intros; try destruct w; now reflexivity.
  Qed.
End INSTANCES.