Require
  MathClasses.theory.naturals MathClasses.orders.semirings MathClasses.orders.integers MathClasses.orders.dec_fields.
Require Import
  Coq.setoid_ring.Ring Coq.setoid_ring.Field
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.naturals MathClasses.interfaces.integers
  MathClasses.interfaces.additional_operations MathClasses.interfaces.orders
  MathClasses.theory.nat_pow MathClasses.theory.int_abs MathClasses.theory.dec_fields.

(* * Properties of Int Pow *)
Section int_pow_properties.
Context `{DecField A} `{∀ x y, Decision (x = y)} `{Integers B} `{!IntPowSpec A B ipw}.

Add Field A : (dec_fields.stdlib_field_theory A).
Add Ring B : (rings.stdlib_ring_theory B).

Global Instance: Proper ((=) ==> (=) ==> (=)) ((^) : A → B → A) | 0.
Proof int_pow_proper.

Global Instance int_pow_mor_1: ∀ x : A, Setoid_Morphism (x^) | 0.
Proof. split; try apply _. Qed.

Global Instance int_pow_mor_2: ∀ n : B, Setoid_Morphism (^n) | 0.
Proof. split; try apply _. solve_proper. Qed.

Lemma int_pow_S_nonneg `{Apart B} `{!TrivialApart B} `{!FullPseudoSemiRingOrder (A:=B) Ble Blt} (x : A) (n : B) :
  0 ≤ n → x ^ (1+n) = x * x ^ n.
Proof.
  intros En. destruct (decide (x = 0)) as [Ex | Ex].
   rewrite Ex. rewrite int_pow_base_0. ring.
   intros E. destruct semirings.not_le_1_0.
   rewrite <-E. now apply semirings.nonneg_plus_le_compat_r.
  now rewrite int_pow_S.
Qed.

Lemma int_pow_negate (x : A) (n : B) : x ^ (-n) = /(x ^ n).
Proof.
  destruct (decide (x = 0)) as [Ex | Ex].
   rewrite Ex.
   destruct (decide (n = 0)) as [En | En].
    now rewrite En, rings.negate_0, int_pow_0, dec_recip_1.
   rewrite 2!int_pow_base_0; trivial.
    now rewrite dec_recip_0.
   now apply rings.flip_negate_ne_0.
  revert n. apply biinduction.
    solve_proper.
   now rewrite rings.negate_0, int_pow_0, dec_recip_1.
  intros n.
  setoid_replace (-n) with (1 - (1 + n)) by ring.
  rewrite 2!int_pow_S, dec_recip_distr; trivial.
  split; intros E.
   rewrite <-E. now field.
  rewrite E, associativity, dec_recip_inverse; trivial.
  ring.
Qed.

Lemma int_pow_negate_alt (x : A) (n : B) : x ^ n = /(x ^ (-n)).
Proof.
  rewrite <-int_pow_negate.
  now rewrite rings.negate_involutive.
Qed.

Lemma int_pow_mult (x y : A) (n : B) : (x * y) ^ n = x ^ n * y ^ n.
Proof.
  destruct (decide (x * y = 0)) as [Exy | Exy].
   rewrite Exy.
   destruct (decide (n = 0)) as [En | En].
    rewrite En, 3!int_pow_0. ring.
   destruct (zero_product x y Exy) as [E|E]; rewrite E, int_pow_base_0; trivial; ring.
  revert n. apply biinduction.
    solve_proper.
   rewrite 3!int_pow_0. ring.
  intros n.
  rewrite 3!int_pow_S; trivial.
    split; intros E.
     rewrite E. ring.
    apply (rings.left_cancellation_ne_0 (.*.) (x * y)); trivial.
    rewrite E. ring.
   intros E. apply Exy. rewrite E. ring.
  intros E. apply Exy. rewrite E. ring.
Qed.

Lemma int_pow_recip (x : A) (n : B) : (/x) ^ n = /(x ^ n).
Proof.
  destruct (decide (x = 0)) as [Ex | Ex].
   rewrite Ex, dec_recip_0.
   destruct (decide (n = 0)) as [En | En].
    now rewrite En, int_pow_0, dec_recip_1.
   now rewrite int_pow_base_0, dec_recip_0.
  revert n. apply biinduction.
    solve_proper.
   now rewrite 2!int_pow_0, dec_recip_1.
  intros n.
  assert (/x ≠ 0) by now apply dec_recip_ne_0.
  rewrite 2!int_pow_S, dec_recip_distr; trivial.
  split; intros E.
   now rewrite E.
  now apply (rings.left_cancellation_ne_0 (.*.) (/x)).
Qed.

Lemma int_pow_nat_pow `{Naturals N} `{!NatPowSpec A N pw} {f : N → B} `{!SemiRing_Morphism f} (x : A) (n : N) :
  x ^ (f n) = x ^ n.
Proof.
  revert n. apply naturals.induction.
    solve_proper.
   now rewrite rings.preserves_0, int_pow_0, nat_pow_0.
  intros n E.
  rewrite rings.preserves_plus, rings.preserves_1.
  rewrite int_pow_S_nonneg, nat_pow_S.
   now rewrite E.
  apply semirings.preserves_nonneg.
  now apply naturals.nat_nonneg.
Qed.

Global Instance int_pow_1: RightIdentity (^) (1:B).
Proof.
  intro. assert ((1:B) = 1 + 0) as E by ring. rewrite E.
  rewrite int_pow_S_nonneg, int_pow_0; [ring | reflexivity].
Qed.

Lemma int_pow_2 x : x ^ (2:B) = x * x.
Proof. now rewrite int_pow_S_nonneg, int_pow_1 by solve_propholds. Qed.

Lemma int_pow_3 x : x ^ (3:B) = x * (x * x).
Proof. now rewrite int_pow_S_nonneg, int_pow_2 by solve_propholds. Qed.

Lemma int_pow_4 x : x ^ (4:B) = x * (x * (x * x)).
Proof. now rewrite int_pow_S_nonneg, int_pow_3 by solve_propholds. Qed.

Global Instance int_pow_base_1: LeftAbsorb (^) (1:A).
Proof.
  red. apply biinduction.
    solve_proper.
   now apply int_pow_0.
  intros n. rewrite int_pow_S, left_identity.
   easy.
  now apply (rings.is_ne_0 1).
Qed.

Lemma int_pow_exp_plus (n m : B) (x : A) :
  x ≠ 0 → x ^ (n + m) = x ^ n * x ^ m.
Proof.
  intros nonneg.
  revert n. apply biinduction.
    solve_proper.
   rewrite int_pow_0, left_identity. ring.
  intros n. rewrite <-associativity, 2!int_pow_S; trivial.
  split; intros E.
   rewrite E. ring.
  apply (rings.left_cancellation_ne_0 (.*.) x); trivial.
  rewrite E. ring.
Qed.

Instance int_pow_ne_0 (x : A) (n : B) : PropHolds (x ≠ 0) → PropHolds (x ^ n ≠ 0).
Proof.
  intros nonneg. unfold PropHolds.
  revert n. apply biinduction.
    solve_proper.
   rewrite int_pow_0. apply (rings.is_ne_0 1).
  intros n. rewrite int_pow_S; trivial.
  split; intros E1 E2; destruct E1.
   apply (left_cancellation (.*.) x).
   now rewrite right_absorb.
  rewrite E2. ring.
Qed.

Lemma int_pow_exp_mult (x : A) (n m : B) :
  x ^ (n * m) = (x ^ n) ^ m.
Proof.
  destruct (decide (x = 0)) as [Ex|Ex].
   rewrite Ex.
   destruct (decide (n = 0)) as [En|En].
    rewrite En, left_absorb, int_pow_0.
    now rewrite left_absorb.
   destruct (decide (m = 0)) as [Em|Em].
    now rewrite Em, right_absorb, 2!int_pow_0.
   rewrite 3!int_pow_base_0; try easy.
   intros E. now destruct (zero_product n m E).
  revert m. apply biinduction.
    solve_proper.
   rewrite right_absorb. now rewrite 2!int_pow_0.
  intros m. split; intros E.
   rewrite int_pow_S, <-E.
    rewrite distribute_l, right_identity.
    now rewrite int_pow_exp_plus.
   now apply int_pow_ne_0.
  rewrite int_pow_S in E.
  rewrite distribute_l, right_identity, int_pow_exp_plus in E.
    apply (rings.left_cancellation_ne_0 (.*.) (x ^ n)).
     now apply int_pow_ne_0.
    now rewrite E.
   easy.
  now apply int_pow_ne_0.
Qed.

Context `{Apart A} `{!TrivialApart A} `{!FullPseudoSemiRingOrder (A:=A) Ale Alt}.
Context `{Apart B} `{!TrivialApart B} `{!FullPseudoSemiRingOrder (A:=B) Ble Blt}.

Instance int_pow_pos (x : A) (n : B) : PropHolds (0 < x) → PropHolds (0 < x ^ n).
Proof.
  intros nonneg. unfold PropHolds.
  revert n. apply biinduction.
    solve_proper.
   intros. rewrite int_pow_0. now apply semirings.lt_0_1.
  intros n; split; intros E.
   rewrite int_pow_S.
    now apply pos_mult_compat.
   apply not_symmetry. now apply orders.lt_ne.
  apply (strictly_order_reflecting (x *.)).
  rewrite <-int_pow_S.
   now rewrite right_absorb.
  apply not_symmetry. now apply orders.lt_ne.
Qed.

Instance int_pow_nonneg (x : A) (n : B) : PropHolds (0 ≤ x) → PropHolds (0 ≤ x ^ n).
Proof.
  intros E1. red in E1.
  destruct (orders.le_equiv_lt _ _ E1) as [E2|E2].
   rewrite <-E2.
   destruct (decide (n = 0)) as [En|En].
    rewrite En.
    rewrite int_pow_0.
    apply semirings.le_0_1.
   unfold PropHolds. now rewrite int_pow_base_0.
  now apply orders.lt_le, int_pow_pos.
Qed.

Lemma int_pow_ge_1 (x : A) (n : B) : 1 ≤ x → 0 ≤ n → 1 ≤ x ^ n.
Proof.
  intros E1 E2. revert n E2. apply integers.induction_nonneg; trivial.
    solve_proper.
   now rewrite int_pow_0.
  intros.
  rewrite int_pow_S.
   rewrite <-rings.mult_1_r.
   apply semirings.mult_le_compat; try apply semirings.le_0_1; auto.
  apply orders.lt_ne_flip.
  apply orders.lt_le_trans with 1; trivial.
  now apply semirings.lt_0_1.
Qed.

Lemma int_pow_gt_1 (x : A) (n : B) : 1 < x → 0 < n → 1 < x ^ n.
Proof.
  intros Ex En.
  apply nat_int.lt_iff_S_le in En.
  destruct (semirings.decompose_le En) as [z [Ez1 Ez2]]. ring_simplify in Ez2.
  rewrite Ez2. clear En Ez2 n.
  revert z Ez1. apply integers.induction_nonneg; try assumption.
    solve_proper.
   now rewrite left_identity, right_identity.
  intros n En E2.
  rewrite <-associativity, int_pow_S.
   apply semirings.gt_1_mult_lt_compat_l; auto.
   transitivity (1:A); [apply semirings.lt_0_1 | assumption].
  apply orders.lt_ne_flip.
  apply orders.le_lt_trans with 1; trivial.
  now apply semirings.le_0_1.
Qed.

(* Making these instances Global is not useful, we don't have PropHolds (1 ≤ x)
  instances and it will only slow down instance resolution (it increases the
  compilation time of dyadics from 1:35 to 2:28). *)
Instance int_pow_exp_le:
  ∀ x : A, PropHolds (1 ≤ x) → OrderPreserving (x^).
Proof.
  repeat (split; try apply _).
  assert (0 < x) by (apply orders.lt_le_trans with 1; [solve_propholds | easy]).
  intros n m E.
  destruct (semirings.decompose_le E) as [z [Ea Eb]].
  rewrite Eb.
  rewrite int_pow_exp_plus by now apply orders.lt_ne_flip.
  rewrite <-rings.mult_1_r at 1.
  apply (order_preserving (x ^ n *.)).
  now apply int_pow_ge_1.
Qed.

Instance int_pow_exp_lt:
  ∀ x : A, PropHolds (1 < x) → StrictlyOrderPreserving (x^).
Proof.
  repeat (split; try apply _).
  assert (0 < x) by (apply orders.le_lt_trans with 1; [solve_propholds | easy]).
  intros n m E.
  apply nat_int.lt_iff_plus_1_le in E.
  destruct (semirings.decompose_le E) as [z [Ea Eb]].
  rewrite Eb.
  rewrite <-associativity, int_pow_exp_plus by now apply orders.lt_ne_flip.
  rewrite <-(rings.mult_1_r (x ^ n)) at 1.
  apply (strictly_order_preserving (x^n *.)).
  apply int_pow_gt_1; trivial.
  now apply nat_int.le_iff_lt_S.
Qed.

Instance int_pow_exp_le_back:
  ∀ x : A, PropHolds (1 < x) → OrderReflecting (x^).
Proof.
  split; try apply _. intros n m E1.
  destruct (total (≤) n m) as [E2|E2]; trivial.
  destruct (orders.le_equiv_lt _ _ E2) as [E3|E3].
   now rewrite E3.
  contradict E1.
  apply orders.lt_not_le_flip.
  now apply (strictly_order_preserving (x^)).
Qed.

Instance int_pow_exp_lt_back:
  ∀ x : A, PropHolds (1 < x) → StrictlyOrderReflecting (x^).
Proof. intros ? E1. apply _. Qed.

Instance int_pow_inj:
  ∀ x : A, PropHolds (1 < x) → Injective (x^).
Proof.
  repeat (split; try apply _). intros n m E.
  apply (antisymmetry (≤)); apply (order_reflecting (x^)); trivial; rewrite E; reflexivity.
Qed.
End int_pow_properties.

(* Due to bug #2528 *)
#[global]
Hint Extern 18 (PropHolds (_ ^ _ ≠ 0)) => eapply @int_pow_ne_0 : typeclass_instances.
#[global]
Hint Extern 18 (PropHolds (0 ≤ _ ^ _)) => eapply @int_pow_nonneg : typeclass_instances.
#[global]
Hint Extern 18 (PropHolds (0 < _ ^ _)) => eapply @int_pow_pos : typeclass_instances.

Section preservation.
  Context
    `{Integers B}
    `{DecField A1} `{∀ x y : A1, Decision (x = y)} `{!IntPowSpec A1 B ip1}
    `{DecField A2} `{∀ x y : A2, Decision (x = y)} `{!IntPowSpec A2 B ip2}
    {f : A1 → A2} `{!SemiRing_Morphism f}.

  Add Ring B2 : (rings.stdlib_ring_theory B).

  Lemma preserves_int_pow x (n : B) : f (x ^ n) = (f x) ^ n.
  Proof.
    destruct (decide (x = 0)) as [Ex | Ex].
     rewrite Ex, rings.preserves_0.
     destruct (decide (n = 0)) as [En|En].
      rewrite En, 2!int_pow_0.
      now apply rings.preserves_1.
     rewrite 2!int_pow_base_0; trivial.
     now apply rings.preserves_0.
    revert n. apply biinduction.
      solve_proper.
     rewrite int_pow_0, int_pow_0.
     now apply rings.preserves_1.
    intros n.
    assert (f x ≠ 0) by now apply rings.injective_ne_0.
    rewrite 2!int_pow_S, rings.preserves_mult; trivial.
    split; intros E.
     now rewrite E.
    now apply (left_cancellation (.*.) (f x)).
  Qed.
End preservation.

Section exp_preservation.
  Context `{Field A} `{∀ x y : A, Decision (x = y)}
   `{Integers B1} `{Integers B2} `{!IntPowSpec A B1 pw1} `{!IntPowSpec A B2 pw2}
    {f : B1 → B2} `{!SemiRing_Morphism f}.

  Lemma preserves_int_pow_exp x (n : B1) : x ^ (f n) = x ^ n.
  Proof.
    destruct (decide (x = 0)) as [Ex | Ex].
     rewrite Ex.
     destruct (decide (n = 0)) as [En|En].
      now rewrite En, rings.preserves_0, 2!int_pow_0.
     rewrite 2!int_pow_base_0; try easy.
     now apply rings.injective_ne_0.
    revert n. apply biinduction.
      solve_proper.
     rewrite rings.preserves_0.
     now rewrite 2!int_pow_0.
    intros n.
    rewrite rings.preserves_plus, rings.preserves_1.
    rewrite 2!int_pow_S by trivial.
    split; intros E.
     now rewrite E.
    now apply (rings.left_cancellation_ne_0 (.*.) x).
  Qed.
End exp_preservation.

(* Very slow default implementation by translation into Peano *)
Section int_pow_default.
  Context `{DecField A} `{∀ x y, Decision (x = y)}
    `{Integers B} `{Apart B} `{!TrivialApart B} `{!FullPseudoSemiRingOrder (A:=B) Ble Blt}.

  Add Ring B3 : (rings.stdlib_ring_theory B).

  Global Instance int_pow_default: Pow A B | 10 := λ x n,
    match (decide_rel (≤) 0 n) with
    | left _ => x ^ int_abs B nat n
    | right _ => /x ^ int_abs B nat n
    end.

  Global Instance: IntPowSpec A B int_pow_default.
  Proof.
    split; unfold pow, int_pow_default.
       intros ? ? E1 ? ? E2.
       now (case (decide_rel _); case (decide_rel _); rewrite E1, E2).
      intros x. case (decide_rel _); intros E.
       now rewrite int_abs_0.
      now destruct E.
     intros n ?. case (decide_rel _); intros E.
      now apply nat_pow_base_0, int_abs_ne_0.
     rewrite nat_pow_base_0.
     apply dec_recip_0.
     now apply int_abs_ne_0.
    intros x n E. case (decide_rel _); case (decide_rel _); intros E1 E2.
       now rewrite int_abs_nonneg_plus, int_abs_1 by (auto;solve_propholds).
      setoid_replace n with (-1 : B).
       rewrite rings.plus_negate_r, int_abs_0, nat_pow_0.
       rewrite int_abs_negate, int_abs_1, right_identity.
       symmetry. now apply dec_recip_inverse.
      apply (antisymmetry (≤)).
       apply orders.not_le_lt_flip in E1.
       apply nat_int.lt_iff_plus_1_le in E1.
       apply (order_reflecting (+1)).
       now ring_simplify.
      apply (order_reflecting (1+)). now rewrite rings.plus_negate_r.
     destruct E2. apply semirings.nonneg_plus_compat; [solve_propholds | assumption].
     rewrite <-int_abs_negate, <-(int_abs_negate n).
     setoid_replace (-n) with (1 - (1 + n)) by ring.
     rewrite (int_abs_nonneg_plus 1 (-(1 + n))), int_abs_1.
       rewrite nat_pow_S.
       rewrite dec_recip_distr, associativity.
       now rewrite dec_recip_inverse, left_identity.
      now apply (rings.is_nonneg 1).
     now apply rings.flip_nonpos_negate, orders.le_flip.
  Qed.
End int_pow_default.


Require Import Coqlib.
Require Import Iteration.
Require Import Maps.
Require Import maps_ext.
Require Import syntax.
Require Import infrastructure_props.
Require Import Metatheory.
Require Import Program.Tactics.
Require Import dom_libs.
Require Import dfs.

(* When the Kildall's algorithm propogates, it ``pulls'' data from the
   predecessors of a note to the node. *)
Module Weak_Pred_Dataflow_Solver (NS: PNODE_SET) (L: LATTICEELT).

Section Kildall.

Variable successors: PTree.t (list positive).
Variable predecessors: PTree.t (list positive).
Variable transf : positive -> L.t -> L.t.
Variable entrypoints: list (positive * L.t).

(** The state of the iteration has two components:
- A mapping from program points to values of type [L.t] representing
  the candidate solution found so far.
- A worklist of program points that remain to be considered.
*)

Record state : Type :=
  mkstate { st_in: PMap.t L.t; st_wrk: NS.t }.

(** Kildall's algorithm, in pseudo-code, is as follows:
<<
    while st_wrk is not empty, do
        extract a node n from st_wrk
        compute in = st_in[n]
        for each predecessor p of n:
            compute out = transf p st_in[p]
            compute in := lub in out
        end for
        if in <> st_in[n]:
            st_in[n] := in
            st_wrk := st_wrk union {successors of n}
        end if
    end while
    return st_in
>>

The initial state is built as follows:
- The initial mapping sets all program points to [L.bot], except
  those mentioned in the [entrypoints] list, for which we take
  the associated approximation as initial value.  Since a program
  point can be mentioned several times in [entrypoints], with different
  approximations, we actually take the l.u.b. of these approximations.
- The initial worklist contains all the program points. *)

Fixpoint start_state_in (ep: list (positive * L.t)) : PMap.t L.t :=
  match ep with
  | nil =>
      PMap.init L.bot
  | (n, v) :: rem =>
      let m := start_state_in rem in
      PMap.set n (fst (L.lub m ?? n v)) m
  end.

Definition start_state :=
  mkstate (start_state_in entrypoints) (NS.initial predecessors).

(** [propagate_pred_list] corresponds, in the pseudocode,
  to the [for] loop iterating over all predecessors. *)

Definition propagate_pred_list (s: state) (oldl: L.t) (preds: list positive)
  : (L.t * bool) :=
fold_left (fun acc p =>
           let '(accl, accb) := acc in
           let '(newl, changed) := L.lub accl (transf p s.(st_in) ?? p) in
           (newl, accb || changed)) preds (oldl, false).

(** [step] corresponds to the body of the outer [while] loop in the
  pseudocode. *)

Definition add_successors_into_worklist (rem: NS.t) (n: positive) : NS.t :=
fold_left (fun acc s => NS.add s acc) (successors ??? n) rem.

Definition step (s: state) : PMap.t L.t + state :=
  match NS.pick s.(st_wrk) with
  | None =>
      inl _ s.(st_in)
  | Some(n, rem) =>
      let oldl := s.(st_in) ?? n in
      let '(newl, changed) := propagate_pred_list s oldl (predecessors ??? n) in
      let s' :=
        if changed
        then mkstate (PMap.set n newl s.(st_in))
               (add_successors_into_worklist rem n)
        else mkstate s.(st_in) rem in
      inr _ s'
  end.

(** The whole fixpoint computation is the iteration of [step] from
  the start state. *)

Definition fixpoint : option (PMap.t L.t) :=
  PrimIter.iterate _ _ step start_state.

End Kildall.

End Weak_Pred_Dataflow_Solver.

(* Implement dominator analysis by the above Kildall's algorithm. *)
Module LDoms := Doms (MergeLt).
Module DomDS := Weak_Pred_Dataflow_Solver (PNodeSetMax) (LDoms).

Definition transfer (n:positive) (input: LDoms.t) : LDoms.t :=
match input with
| None => None
| Some ps => Some (n::ps)
end.

Require analysis.
Require Import infrastructure.
Import LLVMsyntax.

Definition dom_analyze (f: fdef) : PMap.t LDoms.t :=
  let asuccs := cfg.successors f in
  match LLVMinfra.getEntryBlock f with
  | Some (le, _) =>
      let 'mkPO _ a2p := dfs asuccs le 1%positive in
      let psuccs := asuccs_psuccs a2p asuccs in
      match ATree.get le a2p with
      | Some pe =>
        match DomDS.fixpoint psuccs
                (XPTree.make_predecessors psuccs)
                transfer ((pe, LDoms.top) :: nil) with
        | None => (PMap.set pe LDoms.top (PMap.init LDoms.bot))
        | Some res => res
        end
      | None => PMap.init LDoms.bot
      end
  | None => PMap.init LDoms.bot
  end.


Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrbool eqtype ssrnat seq fintype ssrfun tuple finset binomial bigop.
From Bits
     Require Import bits extraction.axioms32.

Require Import repr_op.

(**********************************************************************)
Definition ord_iota m n : seq 'I_wordsize := pmap insub (iota m n).
Definition set_iota m n : {set 'I_wordsize} := [set x in ord_iota m n].

Lemma mem_ord_iota m n x : x \in ord_iota m n = (m <= x < m + n).
Proof.
by rewrite mem_pmap_sub mem_iota.
Qed.

Lemma card_set_iota m n (lt_mn: m + n <= wordsize): #|set_iota m n| = n.
Proof.
rewrite cardsE cardE.
have/perm_eq_size -> : perm_eq (enum (ord_iota m n)) (ord_iota m n).
  rewrite uniq_perm_eq ?enum_uniq ?(pmap_uniq (insubK _)) ?iota_uniq //.
  exact: mem_enum.
rewrite size_pmap (eq_in_count (a2 := predT)) ?count_predT ?size_iota //.
by move=> x; rewrite mem_iota => /andP[h1 /leq_trans h2]; rewrite insubT ?h2.
Qed.

Section Extrema.

Variables (I : finType) (i0 : I) (i1 : I) (P : pred I) (F : I -> nat).

Hypothesis Pi0 : P i0.

Let FP n := [exists (i | P i), F i == n].
Let FP_F i : P i -> FP (F i).
Proof. by move=> Pi; apply/existsP; exists i; rewrite Pi /=. Qed.
Let exFP : exists n, FP n. Proof. by exists (F i0); apply: FP_F. Qed.

Lemma arg_minP: extremum_spec (I:=I) P F leq [arg min_(i < i1 | P i) F i].
Proof.
rewrite /arg_min; case: pickP => [i /andP[Pi /forallP/= min_i] | no_i].
  by split=> // j; apply/implyP.
case/ex_minnP: exFP => n ex_i min_i; case/pred0P: ex_i => i /=.
apply: contraFF (no_i i) => /andP[Pi /eqP def_n]; rewrite /= Pi.
by apply/forall_inP=> j Pj; rewrite def_n min_i ?FP_F.
Qed.

Lemma arg_maxP : extremum_spec (I:=I) P F geq [arg max_(i > i1 | P i) F i].
Proof.
rewrite /arg_max; case: pickP => [i /andP[Pi /forall_inP/= max_i] | no_i].
  by split=> // j; apply/implyP.
have (n): FP n -> n <= foldr maxn 0 (map F (enum P)).
  case/existsP=> i; rewrite -[P i]mem_enum andbC /= => /andP[/eqP <-].
  elim: (enum P) => //= j e IHe; rewrite leq_max orbC !inE.
  by case/predU1P=> [-> | /IHe-> //]; rewrite leqnn orbT.
case/ex_maxnP=> // n ex_i max_i; case/pred0P: ex_i => i /=.
apply: contraFF (no_i i) => /andP[Pi def_n]; rewrite /= Pi.
by apply/forall_inP=> j Pj; rewrite (eqP def_n) max_i ?FP_F.
Qed.

End Extrema.

Lemma ntz_repr:
  forall (bs: Int32) x y E, machine_repr bs E -> x \in E ->
    natural_repr (ntz bs) [arg min_(k < y in E) k].
Admitted.

Lemma keep_min_repr:
  forall i E x y, machine_repr i E -> x \in E ->
    machine_repr (keep_min i) [set [arg min_(k < y in E) k]].
Admitted.

Lemma create_repr: forall k, machine_repr (dec (lsl one (toInt k))) (set_iota 0 k).
Admitted.

(* TODO: move to ops/*.v *)
Lemma srn_repr_1:
  forall n (bs: BITS n) E (H: n.-1.+1 = n), spec.repr bs E -> forall k,
    spec.repr (shrBn bs k) [set i : 'I_n | i < n - k & cast_ord H (@inord n.-1 (i + k)) \in E].
Proof.
  move=> n bs E H HE.
  elim=> [|k Hk].
  + (* k = 0 *)
    rewrite /=.
    have ->: [set i : 'I_n | i < n - 0 & cast_ord H (inord (i + 0)) \in E] = E.
      apply/setP=> x; rewrite !inE.
      rewrite subn0 ltn_ord /=.
      rewrite addn0.
      have ->: cast_ord H (inord x) = x.
        apply ord_inj.
        rewrite nat_cast_ord inordK //.
        by rewrite H.
      rewrite //.
    rewrite //.
  + (* k~k.+1 *)
    rewrite /shrBn /= -/shrBn.
    have ->: [set i : 'I_n | i < n - k.+1 & cast_ord H (inord (i + k.+1)) \in E]
           = [set i : 'I_n | i < n.-1 & cast_ord H (@inord n.-1 i.+1) \in [set i : 'I_n | i < n - k & cast_ord H (inord (i + k)) \in E]].
      apply/setP=> x; rewrite !inE.
      case Hx: (x < n.-1)=> /=.
      + (* x < n.-1 *)
        have ->: (x < n - k.+1) = (@inord n.-1 x.+1 < n - k).
          rewrite inordK=> //.
          rewrite -[k.+1]addn1.
          rewrite subnDA.
          rewrite ltn_subRL.
          by rewrite addnC addn1.
        apply andb_id2l=> _.
        rewrite -[k.+1]addn1 -[x.+1]addn1.
        have ->: x + (k + 1) = @inord n.-1 (x + 1) + k.
          rewrite inordK.
          by rewrite -[x + 1 + k]addnA [k + 1]addnC.
          by rewrite -[n.-1.+1]addn1 ltn_add2r.
        rewrite //=.
      + (* x >= n.-1 *)
        have ->: x < n - k.+1 = false.
          rewrite ltnNge.
          apply negbF.
          apply (leq_trans (n := n.-1)).
          by rewrite -subn1 leq_sub2l.
          by rewrite leqNgt Hx.
        by rewrite /=.
    by apply shift.sr_repr.
Qed.

(* TODO: move somewhere *)
Lemma natural_repr_toInt: forall v, natural_repr (toInt v) v.
Proof.
  move=> v.
  apply/existsP.
  exists #v.
  rewrite eq_refl andbT.
  rewrite toInt_def /native_repr.
  by apply/eqInt32P.
Qed.

(* TODO: move to repr_op *)
Lemma srn_repr:
  forall i E s, s <= wordsize -> machine_repr i E ->
    machine_repr (lsr i (toInt s)) [set i : 'I_wordsize | i < wordsize - s & @inord wordsize.-1 (i + s) \in E].
Proof.
  move=> i E s Hs [bv [r_native r_set]].
  exists (shrBn bv s); split.
  apply lsr_repr=> //.
  apply natural_repr_toInt.
  have H: wordsize.-1.+1 = wordsize by trivial.
  have ->: [set i0 : 'I_wordsize | i0 < wordsize - s & inord (i0 + s) \in E]
         = [set i0 : 'I_wordsize | i0 < wordsize - s & cast_ord H (inord (i0 + s)) \in E].
    apply/setP=> x; rewrite !inE.
    apply andb_id2l=> _.
    have {1}->: inord (x + s) = (cast_ord H (inord (x + s))).
      apply ord_inj.
      by rewrite nat_cast_ord.
    rewrite //.
  by apply srn_repr_1.
Qed.

Lemma addB_zero_tt {n} (bs: BITS n.+1):
  addB [tuple of true :: spec.zero n.+1] [tuple of true :: bs]
= [tuple of false :: (addB [tuple of true :: spec.zero n] bs)].
Proof.
  apply toNat_inj.
  rewrite toNat_addB.
  rewrite /=.
  have ->: toNat [tuple of false :: addB [tuple of true :: nseq n false] bs]
         = (toNat (addB [tuple of true :: nseq n false] bs)).*2.
    by rewrite /toNat /= add0n.
  rewrite toNat_addB.
  rewrite -muln2.
  rewrite div.muln_modl=> //.
  have ->: toNat [tuple of true :: spec.zero n.+1] = 1 + (toNat [tuple of spec.zero n.+1]).*2 by trivial.
  have ->: toNat [tuple of true :: spec.zero n] = 1 + (toNat (spec.zero n)).*2 by trivial.
  have ->: toNat [tuple of true :: bs] = 1 + (toNat bs).*2 by trivial.
  rewrite expnSr.
  rewrite !toNat_zero.
  rewrite double0 addn0.
  rewrite -muln2 //.
Qed.

Lemma addB_zero_tf {n} (bs: BITS n.+1):
  addB [tuple of true :: spec.zero n.+1] [tuple of false :: bs]
= [tuple of true :: bs].
Proof.
  apply toNat_inj.
  rewrite toNat_addB.
  have ->: toNat [tuple of true :: spec.zero n.+1] = 1 + (toNat (spec.zero n.+1)).*2 by trivial.
  rewrite toNat_zero double0 addn0.
  have ->: toNat [tuple of false :: bs] = (toNat bs).*2 by trivial.
  have ->: toNat [tuple of true :: bs] = 1 + (toNat bs).*2 by trivial.
  rewrite div.modn_small //.
  rewrite -addn1.
  rewrite addnC addnA.
  have ->: 1 + 1 = 2 by trivial.
  rewrite -muln2.
  rewrite -{1}[2]mul1n.
  rewrite -mulnDl.
  rewrite expnSr.
  rewrite leq_mul2r.
  rewrite addnC addn1.
  by rewrite toNatBounded.
Qed.

Definition set_isNext_g {n} (S: {set 'I_n.+1}) y x := (y \notin S) && (y >= x).

Definition set_next_g {n} (S: {set 'I_n.+1}) x := [arg min_(y < ord0 | set_isNext_g S y x) y].

Lemma ripple_repr_1':
  forall n (bs: BITS n.+1) E f, spec.repr bs E -> set_isNext_g E f (@ord0 n) ->
    spec.repr (addB [tuple of true :: spec.zero n] bs) ((set_next_g E (@ord0 n)) |: [set y in E | y > set_next_g E (@ord0 n)]).
Proof.
  elim=> [|n IHn] /tupleP[b bs] E f Hbs HE.
  + (* n = 1 *)
    have Hf: f = ord0 by apply ord_inj; elim f; elim.
    rewrite (tuple0 bs) /=.
    rewrite /adcB /adcBmain /=.
    rewrite !tuple.theadCons /=.
    rewrite /joinlsb /=.
    case: b Hbs=> Hbs.
    + rewrite !tuple.theadCons !tuple.beheadCons /=.
      rewrite /spec.repr /=.
      apply/setP=> x.
      have Hx: x = ord0 by apply ord_inj; elim x; elim.
      rewrite !inE /getBit Hx /=.
      have ->: (ord0 == set_next_g E 0) = false.
        apply/eqP=> Habs.
        rewrite /set_next_g in Habs.
        move: Habs.
        case: (arg_minP _ f)=> //.
        move=> i Hi Hmin Hi'.
        rewrite -Hi' /set_isNext_g /= leqnn andbT in Hi.
        move: Hbs=> /setP /(_ ord0).
        rewrite inE /getBit /= => Habs.
        by rewrite Habs in Hi.
      rewrite /=.
      by rewrite ltn0 andbF.
    + rewrite !tuple.theadCons !tuple.beheadCons /=.
      rewrite /spec.repr /=.
      apply/setP=> x.
      have Hx: x = ord0 by apply ord_inj; elim x; elim.
      rewrite !inE /getBit Hx /=.
      have ->: ord0 == set_next_g E 0.
        rewrite /set_next_g.
        case: (arg_minP _ f)=> //.
        move=> i Hi Hmin.
        apply/eqP.
        apply ord_inj.
        rewrite /=.
        apply/eqP.
        rewrite eq_sym -leqn0.
        apply (Hmin ord0).
        by rewrite Hf in HE.
      by rewrite /=.
  + (* n.+1 ~ n.+2 *)
    case: b Hbs=> Hbs.
    + rewrite addB_zero_tt.
      have Hbs': ord0 \in E.
        move: Hbs=> /setP /(_ ord0) ->.
        by rewrite inE /getBit.
      set E' := [set x : 'I_n.+1 | inord(x.+1) \in E ].
      set f' := @inord n f.-1.
      have HE': spec.repr bs E'.
        by apply (spec.repr_rec (b := true)).
      have Hf': set_isNext_g E' f' (@ord0 n.+1).
        rewrite /set_isNext_g.
        rewrite /= leq0n andbT.
        apply/negP=> Habs.
        rewrite inE in Habs.
        have Hf1: f > 0.
          rewrite lt0n.
          apply/negP=> /eqP Habs'.
          have Habs'': f = ord0 by apply ord_inj.
          rewrite Habs'' in HE.
          move: HE=> /andP[Habs''' _].
          by rewrite Hbs' in Habs'''.
        have Hf': inord f'.+1 = f.
          rewrite inordK.
          rewrite prednK=> //.
          apply ord_inj.
          by rewrite inordK.
          apply (leq_trans (n := f)).
          rewrite -subn1.
          rewrite -{2}[nat_of_ord f]subn0.
          apply ltn_sub2l=> //.
          by rewrite -ltnS.
        rewrite Hf' in Habs.
        move: HE=> /andP [HE _].
        by rewrite Habs in HE.
      move: (IHn bs E' f' HE' Hf')=> /setP IHn'.
      apply/setP=> i; rewrite !inE.
      case Hi: (i == ord0).
      + move: Hi=> /eqP ->.
        rewrite /getBit /=.
        rewrite ltn0 andbF orbF.
        apply/eqP.
        rewrite /set_next_g.
        case: (arg_minP _ f)=> //.
        move=> i0 Hi0 Hi0' Habs.
        rewrite -Habs in Hi0.
        move: Hi0=> /andP[Habs' _].
        by rewrite Hbs' in Habs'.
      + move: Hi=> /eqP Hi''.
        have Hi': i > 0.
          rewrite lt0n.
          apply/eqP=> H.
          have Habs: i = ord0 by apply ord_inj.
          by rewrite Habs in Hi''.
        have Hi''': i.-1 < i.
          rewrite -subn1.
          rewrite -{2}[nat_of_ord i]subn0.
          apply ltn_sub2l=> //.
        have ->: i = inord i.-1.+1.
          apply ord_inj.
          rewrite inordK.
          rewrite prednK=> //.
          by rewrite prednK=> //.
        have ->: getBit [tuple of false :: addB [tuple of true :: spec.zero n] bs] (@inord n.+1 i.-1.+1)
               = getBit (addB [tuple of true :: spec.zero n] bs) i.-1.
          rewrite /getBit inordK=> //.
          by rewrite prednK=> //.
        move: (IHn' (inord i.-1))=> IHn''.
        rewrite !inE /= inordK in IHn''.
        rewrite -IHn''.
        have Hnext: set_next_g E 0 = inord (set_next_g E' 0).+1.
          rewrite /set_next_g.
          case: (arg_minP _ f)=> //.
          move=> i0 Hi0 Hi0'.
          case: (arg_minP _ f')=> //.
          move=> i1 Hi1 Hi1'.
          apply ord_inj.
          apply/eqP.
          rewrite eqn_leq.
          apply/andP; split.
          apply (Hi0' (inord i1.+1))=> //.
          rewrite /set_isNext_g leq0n andbT.
          rewrite /set_isNext_g leq0n andbT in Hi1.
          apply/negP=> Habs.
          have Habs': i1 \in E'.
            by rewrite inE.
          by rewrite Habs' in Hi1.
          rewrite inordK.
          have Hi0'': i0 > 0.
            rewrite lt0n.
            apply/eqP=> Habs.
            have Hi0'': i0 = ord0 by apply ord_inj.
            rewrite Hi0'' in Hi0.
            move: Hi0=> /andP [Habs' _].
            by rewrite Hbs' in Habs'.
          have Hok: i1 <= @inord n i0.-1.
            apply Hi1'.
            rewrite /set_isNext_g leq0n andbT.
            rewrite /set_isNext_g leq0n andbT in Hi0.
            apply/negP=> Habs.
            move: Hi0=> /negP Hi0.
            apply Hi0.
            rewrite inE inordK prednK in Habs=> //.
            by rewrite inord_val in Habs.
            by rewrite -ltnS.
          apply (leq_ltn_trans (n := @inord n i0.-1))=> //.
          rewrite inordK=> //.
          rewrite -subn1.
          rewrite -{2}[nat_of_ord i0]subn0.
          apply ltn_sub2l=> //.
          rewrite prednK=> //.
          rewrite -ltnS=> //.
          rewrite -addn1 -[n.+2]addn1.
          rewrite leq_add2r=> //.
        have ->: (inord i.-1.+1 == set_next_g E 0) = (inord i.-1 == set_next_g E' 0).
          rewrite Hnext.
          apply/eqP.
          case H: (inord i.-1 == set_next_g E' 0).
          + move/eqP: H=> H.
            apply ord_inj.
            rewrite !inordK=> //.
            apply/eqP.
            rewrite eqSS.
            rewrite -H.
            rewrite inordK=> //.
            apply (leq_trans (n := i))=> //.
            rewrite -ltnS=> //.
            rewrite -[(set_next_g E' 0).+1]addn1 -[n.+2]addn1.
            by rewrite ltn_add2r.
            rewrite prednK=> //.
          + move/eqP: H=> H.
            move=> Habs.
            have Habs': inord i.-1 = set_next_g E' 0.
              apply ord_inj.
              rewrite inordK.
              apply/eqP.
              rewrite -(eqn_add2r 1).
              rewrite !addn1.
              apply/eqP.
              have ->: i.-1.+1 = @inord n.+1 i.-1.+1.
                rewrite inordK=> //.
                by rewrite prednK.
              rewrite Habs.
              rewrite inordK=> //.
              by rewrite -[(set_next_g E' 0).+1]addn1 -[n.+2]addn1 ltn_add2r.
              apply (leq_trans (n := i))=> //.
              rewrite -ltnS=> //.
            by rewrite Habs' in H.
        have ->: (set_next_g E 0 < @inord n.+1 i.-1.+1) = (set_next_g E' 0 < i.-1).
          rewrite Hnext.
          rewrite !inordK.
          rewrite -addn1 -[i.-1.+1]addn1.
          by rewrite leq_add2r.
          rewrite prednK=> //.
          rewrite -addn1 -[n.+2]addn1.
          by rewrite leq_add2r.
        rewrite //.
        apply (leq_trans (n := i)).
        rewrite -subn1.
        rewrite -{2}[nat_of_ord i]subn0.
        apply ltn_sub2l=> //.
        by rewrite -ltnS.
    + rewrite addB_zero_tf.
      have Hbs': ord0 \notin E.
        move: Hbs=> /setP /(_ ord0) Hbs.
        rewrite Hbs.
        by rewrite inE /getBit /=.
      have ->: set_next_g E (@ord0 n.+1) = @ord0 n.+1.
        rewrite /set_next_g.
        case: (arg_minP _ f)=> //.
        move=> i Hi Hmin.
        apply ord_inj.
        rewrite /=.
        apply/eqP.
        rewrite -leqn0.
        apply (Hmin ord0).
        rewrite /set_isNext_g /= leqnn.
        by rewrite Hbs'.
      apply/setP=> x; rewrite !inE.
      case Hx: (x == ord0).
      + move: Hx=> /eqP ->.
        by rewrite /getBit.
      + have Hx': 0 < x.
          rewrite lt0n.
          apply/eqP=> Habs.
          have Habs': x = ord0.
            by apply ord_inj.
          by rewrite Habs' in Hx.
        rewrite /= Hx'.
        rewrite andbT /=.
        move: Hbs=> /setP /(_ x) ->.
        rewrite inE.
        rewrite /getBit /=.
        have ->: x = inord x.-1.+1.
          apply ord_inj.
          rewrite inordK prednK=> //.
        rewrite inordK //.
        rewrite prednK=> //.
Qed.

Lemma splitAt {n} (bs: BITS n) x (Hcast: n = x + (n - x)):
  bs = tcast (esym Hcast) ((high (n - x) (tcast Hcast bs)) ## (low x (tcast Hcast bs))).
Proof.
  apply allBitsEq=> i Hi.
  rewrite getBit_tcast.
  rewrite getBit_catB.
  rewrite getBit_low getBit_high.
  rewrite getBit_tcast.
  case Hx: (i < x)=> //.
  rewrite subnK=> //.
  by rewrite leqNgt Hx.
Qed.

Lemma addB_catB {n} (bs: BITS n) bs' x (Hcast: n = x + (n - x)):
  addB (tcast (esym Hcast) (high (n - x) (tcast Hcast bs') ## spec.zero x))
       (tcast (esym Hcast) (high (n - x) (tcast Hcast bs) ## low x (tcast Hcast bs)))
= tcast (esym Hcast) ((addB (high (n - x) (tcast Hcast bs')) (high (n - x) (tcast Hcast bs))) ## low x (tcast Hcast bs)).
Proof.
  apply toNat_inj.
  rewrite toNat_addB.
  rewrite !toNat_tcast.
  rewrite !toNatCat.
  rewrite -fromNat0 toNat_fromNat.
  rewrite toNat_addB.
  have: (toNat (low x (tcast Hcast bs))) < 2 ^ x by apply toNatBounded.
  move: (toNat (high (n - x) (tcast Hcast bs')))=> n1.
  move: (toNat (high (n - x) (tcast Hcast bs)))=> n2.
  move: (toNat (low x (tcast Hcast bs)))=> n3 H.
  rewrite div.mod0n addn0.
  rewrite addnA -mulnDl.
  rewrite div.muln_modl.
  have Hx: x <= n by rewrite Hcast -{1}[x]addn0 leq_add2l.
  rewrite -expnD subnK=> //.
  move: (n1 + n2)=> n4.
  rewrite (div.divn_eq n4 (2 ^ (n - x))).
  rewrite mulnDl.
  rewrite -mulnA.
  rewrite -expnD subnK=> //.
  rewrite -addnA.
  rewrite !div.modnMDl.
  rewrite ![div.modn _ (2 ^ n)]div.modn_small //.
  have ->: 2 ^ n = 2 ^ (n - x) * 2 ^ x by rewrite -expnD subnK.
  rewrite ltn_mul2r.
  apply/andP; split.
  rewrite expn_gt0=> //.
  rewrite div.ltn_mod expn_gt0 //.
  apply (leq_trans (n := div.modn n4 (2 ^ (n - x)) * 2 ^ x + 2 ^ x)).
  rewrite ltn_add2l //.
  have {2}->: 2 ^ x = 1 * 2 ^ x by rewrite mul1n.
  rewrite -mulnDl.
  have ->: 2 ^ n = 2 ^ (n - x) * 2 ^ x by rewrite -expnD subnK.
  rewrite leq_mul2r.
  apply/orP; right.
  rewrite addn1.
  rewrite div.ltn_mod.
  by rewrite expn_gt0.
  by rewrite expn_gt0.
Qed.

Lemma addB_tcast m n b1 b2 (Hcast: m = n): addB (tcast Hcast b2) b1 = tcast Hcast (addB b2 (tcast (esym Hcast) b1)).
Proof.
  apply toNat_inj.
  rewrite toNat_tcast.
  rewrite !toNat_addB.
  rewrite !toNat_tcast.
  move: (toNat b2 + toNat b1)=> x.
  clear b1 b2.
  by rewrite Hcast.
Qed.

Lemma ripple_repr_1:
  forall n (bs: BITS n.+1) bs' E x f, spec.repr bs E -> spec.repr bs' [set x] -> set_isNext_g E f x ->
    spec.repr (addB bs' bs) ((set_next_g E x) |: [set y in E | y < x] :|: [set y in E | y > set_next_g E x]).
Proof.
  move=> n bs bs' E x f Hbs Hbs' Hx.
  have Hcast: n.+1 = x + (n.+1 - x).
    rewrite subnKC=> //.
    by apply ltnW.
  rewrite (splitAt bs' x).
  have ->: low x (tcast Hcast bs') = spec.zero x.
    apply allBitsEq=> i Hi.
    rewrite getBit_low -fromNat0 getBit_zero getBit_tcast Hi.
    move: Hbs'=> /setP /(_ (inord i)) Hbs'.
    rewrite !inE /= inordK in Hbs'=> //.
    rewrite -Hbs'.
    apply/eqP=> Habs.
    have Habs': i = x.
      rewrite -Habs inordK=> //.
      apply (ltn_trans (n := x))=> //.
    by rewrite Habs' ltnn in Hi.
    apply (ltn_trans (n := x))=> //.
  rewrite (splitAt bs x).
  rewrite addB_catB.
  apply/setP=> i; rewrite !inE.
  rewrite getBit_tcast getBit_catB.
  move: Hbs=> /setP Hbs.
  move: Hbs'=> /setP Hbs'.
  case Hi: (i < x).
  + (* i < x *)
    rewrite getBit_low Hi getBit_tcast andbT.
    rewrite [(i \in E) && (set_next_g E x < i)]andbC.
    rewrite -orbA.
    rewrite andKb.
    have ->: (i == set_next_g E x) = false.
      apply/eqP=> Habs.
      have Habs': set_next_g E x >= x.
        rewrite /set_next_g.
        case: (arg_minP _ f)=> //.
        by move=> i0 /andP[_ Habs'] _.
      have Habs'': i < i.
        rewrite -Habs in Habs'.
        apply (leq_trans (n := x))=> //.
      by rewrite ltnn in Habs''.
    by rewrite (Hbs i) inE.
  + (* i >= x *)
    have Hcast2: (n - x).+1 = n.+1 - x.
      rewrite -subSn=> //.
      by rewrite -ltnS.
    have Hbs'1: high (n.+1 - x) (tcast Hcast bs') = tcast Hcast2 [tuple of true :: spec.zero (n - x)].
      apply allBitsEq=> i0 Hi0.
      rewrite getBit_high !getBit_tcast.
      case: i0 Hi0=> [Hi0|i0 Hi0].
      + rewrite add0n /getBit /=.
        move: (Hbs' x)=> Hbs'1.
        by rewrite !inE eq_refl /getBit in Hbs'1.
      + rewrite {2}/getBit /=.
        rewrite nth_nseq if_same.
        move: (Hbs' (inord (i0.+1 + x)))=> Hbs'1.
          rewrite !inE in Hbs'1.
          have Hi0': (inord (i0.+1 + x) == x) = false.
            apply/negP=> /eqP Habs.
            have Habs': i0.+1 + x = nat_of_ord x.
              rewrite -{2}Habs inordK=> //.
              rewrite addnC -ltn_subRL=> //.
            move: Habs'=> /eqP Habs'.
            rewrite gtn_eqF in Habs'=> //.
            rewrite -{1}[nat_of_ord x]add0n.
            rewrite ltn_add2r=> //.
          rewrite Hi0' in Hbs'1.
          rewrite Hbs'1.
          rewrite /getBit inordK //.
          rewrite addnC -ltn_subRL //.
    rewrite Hbs'1.
    rewrite andbF orbF.
    set E' := [set i in 'I_(n - x).+1 | inord (i + x) \in E].
    set f' := @inord (n - x) (f - x).
    set bs1 := tcast (esym Hcast2) (high (n.+1 - x) (tcast Hcast bs)).
    have Hlt: forall y, y < n.+1 -> x < n.+1 -> y - x < (n - x).+1.
      move=> y Hy.
      rewrite -[(n - x).+1]subSn.
      by rewrite ltn_sub2r.
      by rewrite -ltnS.
    have Hbs1: spec.repr bs1 E'.
      apply/setP=> j; rewrite !inE /=.
      rewrite getBit_tcast getBit_high getBit_tcast.
      rewrite (Hbs (inord (j + x))) inE /getBit inordK=> //.
      rewrite addnC -ltn_subRL subSn=> //.
      by rewrite -ltnS.
    have Hf': set_isNext_g E' f' 0.
      rewrite /set_isNext_g.
      rewrite leq0n andbT.
      move: Hx=> /andP[Hx' Hx''].
      apply/negP=> Habs.
      rewrite inE /= in Habs.
      have Habs': inord (f' + x) = f.
        rewrite inordK.
        apply ord_inj.
        rewrite inordK subnK=> //.
        rewrite (Hlt f)=> //.
      rewrite Habs' in Habs.
      by rewrite Habs in Hx'.
    have Hf'2: set_next_g E' 0 = inord ((set_next_g E x) - x).
      rewrite /set_next_g.
      apply ord_inj.
      rewrite inordK.
      case: (arg_minP _ f')=> //.
      move=> i0 /andP [Hi0 _] Hi0'.
      case: (arg_minP _ f)=> //.
      move=> i1 /andP [Hi1 Hi1''] Hi1'.
      apply/eqP.
      rewrite eqn_leq.
      apply/andP; split.
      + have ->: i1 - x = nat_of_ord (@inord (n - x) (i1 - x)).
          rewrite inordK //.
          rewrite (Hlt i1)=> //.
        apply (Hi0' (inord (i1 - x))).
        rewrite /set_isNext_g leq0n andbT.
        rewrite inE /= inordK.
        rewrite subnK=> //.
        by rewrite inord_val Hi1.
        rewrite (Hlt i1)=> //.
      + rewrite leq_subLR.
        have Hxi0: x + i0 < n.+1.
          apply (leq_trans (n := x + (n - x).+1)).
          rewrite ltn_add2l=> //.
          rewrite -subSn.
          rewrite subnKC=> //.
          rewrite ltnW=> //.
          rewrite -ltnS=> //.
        have ->: x + i0 = nat_of_ord (@inord n (x + i0)).
          rewrite inordK //.
        apply (Hi1' (@inord n (x + i0))).
        rewrite /set_isNext_g.
        rewrite inE /= addnC in Hi0.
        rewrite Hi0 /=.
        rewrite inordK=> //.
        by rewrite leq_addr=> //.
      rewrite (Hlt [arg min_(y < ord0 | set_isNext_g E y x) y])=> //.
    move: (ripple_repr_1' (n - x) bs1 E' f' Hbs1 Hf')=> /setP /(_ (inord (i - x))) H.
    rewrite !inE /= in H.
    have ->: getBit (addB (tcast Hcast2 [tuple of true :: spec.zero (n - x)])
        (high (n.+1 - x) (tcast Hcast bs))) (i - x) = getBit (addB [tuple of true :: spec.zero (n - x)] bs1) (@inord (n - x) (i - x)).
      rewrite /bs1.
      move: (high (n.+1 - x) (tcast Hcast bs))=> b1.
      move: ([tuple of true :: spec.zero (n - x)])=> b2.
      rewrite addB_tcast getBit_tcast /getBit inordK //.
      rewrite (Hlt i)=> //.
    rewrite -H.
    rewrite !Hf'2.
    have ->: (@inord (n - x) (i - x) == inord (set_next_g E x - x)) = (i == set_next_g E x).
      apply/eqP.
      case Hi': (i == set_next_g E x).
      + move: Hi'=> /eqP Hi'.
        by rewrite Hi'.
      + move: Hi'=> /eqP Hi'.
        move=> Habs.
        have Habs': i = set_next_g E x.
          apply ord_inj.
          have ->: nat_of_ord i = nat_of_ord (@inord (n - x) (i - x)) + x.
            rewrite inordK.
            rewrite subnK=> //.
            by rewrite leqNgt Hi.
            rewrite (Hlt i)=> //.
        rewrite Habs.
        rewrite inordK.
        rewrite subnK=> //.
        rewrite /set_next_g.
        case: (arg_minP _ f)=> //.
        by move=> i0 /andP[_ Habs'] _.
        rewrite (Hlt (set_next_g E x))=> //.
      by rewrite Habs' in Hi'.
    have ->: (@inord n (@inord (n - x) (i - x) + x) \in E) = (i \in E).
      rewrite inordK.
      rewrite subnK.
      by rewrite inord_val.
      by rewrite leqNgt Hi.
      by rewrite (Hlt i).
    rewrite !inordK.
    have ->: (set_next_g E x - x < i - x) = (set_next_g E x < i).
      case Hi': (set_next_g E x < i).
      + rewrite ltn_sub2r=> //.
        move: Hi'.
        rewrite /set_next_g.
        case: (arg_minP _ f)=> //.
        move=> i0 /andP[_ Hi0] Hmin Hi0'.
        apply (leq_ltn_trans (n := i0))=> //.
      + apply/negP=> Habs.
        have Habs': set_next_g E x < i.
          have ->: nat_of_ord (set_next_g E x) = set_next_g E x - x + x.
            rewrite subnK=> //.
            rewrite /set_next_g.
            case: (arg_minP _ f)=> //.
            by move=> i0 /andP[_ Hi0] _.
          have ->: nat_of_ord i = i - x + x.
            rewrite subnK=> //.
            by rewrite leqNgt Hi.
          by rewrite ltn_add2r Habs.
        by rewrite Habs' in Hi'.
    rewrite //.
    rewrite (Hlt i)=> //.
    rewrite (Hlt (set_next_g E x))=> //.
Qed.

Lemma ripple_repr:
  forall i j S x f, machine_repr i S -> machine_repr j [set x] -> set_isNext_g S f x ->
    machine_repr (add j i) ((set_next_g S x) |: [set y in S | y < x] :|: [set y in S | y > set_next_g S x]).
Proof.
  move=> i j S x f [bv [r_native r_set]] [bv' [r_native' r_set']] Hx.
  exists (addB bv' bv); split.
  apply add_repr=> //.
  by apply (ripple_repr_1 _ _ _ _ _ f).
Qed.

(* TODO: move from queens to somewhere else *)
Lemma ladd_repr:
  forall x y, add (toInt x) (toInt y) = toInt (x + y).
Admitted.

Definition set_min (S: {set 'I_wordsize}) := [arg min_(x < ord0 in S) x].

Definition set_isNext (S: {set 'I_wordsize}) x := (x \notin S) && [exists y, (y \in S) && (y < x)].

Definition set_next (S: {set 'I_wordsize}) := [arg min_(x < ord0 | set_isNext S x) x].

Lemma min_ripple_repr i (S: {set 'I_wordsize}) e (He: e \in S) f (Hf: set_isNext S f):
  machine_repr i S ->
  machine_repr (add (keep_min i) i) (set_next S |: [set x in S | set_next S < x]).
Proof.
  have HS: set_next S = set_next_g S (set_min S).
    rewrite /set_next /set_next_g.
    rewrite /arg_min.
    rewrite (eq_pick (Q := [pred i0 | set_isNext_g S i0 (set_min S) & [
               forall (j | set_isNext_g S j (set_min S)),
                 i0 <= j]])) //.
    move=> x /=.
    have Heq: forall x, [exists y, (y \in S) && (y < x)] = (set_min S < x).
      move=> x0.
      rewrite /set_min.
      case: (arg_minP _ e)=> //.
      move=> j Hj Hj'.
      case Hx: (j < x0).
      + apply/existsP.
        exists j.
        by rewrite Hj.
      + apply negbTE; rewrite negb_exists.
        apply/forallP=> y.
        rewrite negb_and.
        case Hy: (y \in S)=> //=.
        + move: (Hj' y Hy)=> Hy'.
          rewrite -leqNgt.
          apply (leq_trans (n := j))=> //.
          by rewrite leqNgt Hx.
    rewrite /set_isNext Heq.
    have Hhandy: forall y, (y \notin S) && (set_min S < y) = (y \notin S) && (set_min S <= y).
      move=> y.
      apply andb_id2l=> Hy.
      rewrite [set_min S <= y]leq_eqVlt.
      have Habs: set_min S \in S.
        rewrite /set_min.
        by case: (arg_minP _ e)=> //.
      have ->: (nat_of_ord (set_min S) == nat_of_ord y) = false.
        apply negbTE.
        apply/eqP=> Habs'.
        have Habs'': set_min S = y by apply ord_inj.
        rewrite Habs'' in Habs.
        by rewrite Habs in Hy.
      by rewrite /=.
    have ->: [forall (j | (j \notin S) && [exists y, (y \in S) && (y < j)]), x <= j]
           = [forall (j | (j \notin S) && (set_min S <= j)), x <= j].
      apply eq_forallb=> y.
      rewrite Heq.
      by rewrite Hhandy.
    rewrite /set_isNext_g.
    rewrite Hhandy.
    rewrite //.
  have ->: (set_next S |: [set x0 in S | set_next S < x0]) = ((set_next_g S (set_min S)) |: [set y in S | y < (set_min S)] :|: [set y in S | y > set_next_g S (set_min S)]).
    have ->: [set y in S | y < set_min S] = set0.
      apply/setP=> x; rewrite !inE.
      rewrite /set_min.
      case: (arg_minP _ e)=> //.
      move=> j Hj /(_ x) Hj'.
      case Hx: (x \in S); rewrite andbC.
      rewrite andbT.
      apply negbTE.
      rewrite -leqNgt.
      by apply Hj'.
      by rewrite andbF.
    by rewrite setU0 HS.
  move=> H.
  apply (ripple_repr _ _ _ _ f)=> //.
  apply (keep_min_repr _ _ e)=> //.
  rewrite /set_isNext_g.
  move: Hf=> /andP [Hf1 /existsP [y /andP [Hy1 Hy2]]].
  apply/andP; split=> //.
  apply (leq_trans (n := y))=> //.
  rewrite /set_min.
  case: (arg_minP _ e)=> //.
  move=> x Hx /(_ y) Hy.
  by apply Hy.
  by apply ltnW.
Qed.

(* TODO: move somewhere else *)
Lemma machine_repr_inj1: forall x y z, machine_repr x y -> machine_repr z y -> x = z.
Proof.
  move=> x y z [bx [/eqInt32P-> Hx]] [bz [/eqInt32P-> Hz]].
  have ->: bx = bz=> //.
  apply allBitsEq=> i Hi.
  have ->: getBit bx i = (inord i \in y) by rewrite Hx inE inordK.
  by have ->: getBit bz i = (inord i \in y) by rewrite Hz inE inordK.
Qed.
(**********************************************************************)

Section Enum_parts.

Definition enumNext (x: Int32) := (* 111001100 *)
  let smallest := keep_min x in(* 000000100 *)
  let ripple := add smallest x in  (* 111010000 *)
  let ones := lsr (lxor x ripple) (add (toInt 2) (ntz x)) in
  lor ripple ones.

Definition enumNext_set (S: {set 'I_wordsize}) :=
  let s_min := set_min S in
  let s_next := set_next S in
  [set s_next] :|: [set x in S | x > s_next] :|: (if s_next >= s_min + 2 then (set_iota 0 (s_next - s_min - 1)) else set0).

Lemma enumNext_cont (j : 'I_wordsize) (S: {set 'I_wordsize}) e (He: e \in S) f (Hf: set_isNext S f):
  set_min S <= j -> j < set_next S -> j \in S.
Proof.
  move=> Hj1 Hj2.
  case Hjmin: (set_min S == j).
  + move: Hjmin=> /eqP Hjmin.
    rewrite -Hjmin.
    rewrite /set_min.
    case: (arg_minP _ e)=> //.
  + have Hj1': set_min S < j.
    rewrite ltn_neqAle.
    apply/andP; split=> //.
    apply negbT=> //.
    rewrite /set_min in Hj1.
    move: Hj1.
    case: (arg_minP _ e)=> //.
    move=> i Hi1 Hi2 Hij.
    rewrite /set_next in Hj2.
    move: Hj2.
    case: (arg_minP _ f)=> //.
    move=> k /andP [Hk1 Hk2] Hk3 Hjk.
    move: (Hk3 j)=> Hminj.
    rewrite leqNgt Hjk /= in Hminj.
    case HjS: (j \in S)=> //.
    apply Hminj.
    apply/andP; split.
    by rewrite HjS.
    apply/existsP.
    exists (set_min S).
    apply/andP; split=> //.
    rewrite /set_min.
    case: (arg_minP _ e)=> //.
Qed.

Lemma enumNext_correct (i: Int32) (S: {set 'I_wordsize}) e (H: e \in S) f (Hf: set_isNext S f):
  2 + set_min S <= wordsize ->
  machine_repr i S -> machine_repr (enumNext i) (enumNext_set S).
Proof.
move=> Hlimit Hi.
apply union_repr=> //.
apply (min_ripple_repr _ _ _ H _ Hf)=> //.
have ->: add (toInt 2) (ntz i) = toInt (2 + set_min S).
  have ->: ntz i = toInt (set_min S).
    move: (ntz_repr i e ord0 S Hi H)=> Hntz.
    rewrite /natural_repr in Hntz.
    move: Hntz=> /existsP [x /andP [Hx1 Hx2]].
    rewrite /native_repr in Hx1.
    move: Hx1=> /eqInt32P Hx1.
    rewrite Hx1.
    move: Hx2=> /eqP Hx2.
    rewrite -Hx2.
    by rewrite toInt_def.
  by rewrite ladd_repr.
have Hrepr: machine_repr (lxor i (add (keep_min i) i))
     (set_next S |: [set x in S | x < set_next S]).
  set E' := (set_next S |: [set x0 in S | set_next S < x0]).
  have ->: (set_next S |: [set x0 in S | x0 < set_next S]) = (S :\: E') :|: (E' :\: S).
    apply/setP=> x; rewrite !inE.
    rewrite negb_or negb_and.
    rewrite andb_orr.
    rewrite andb_orl.
    rewrite -andbA.
    rewrite andNb andbF.
    symmetry.
    rewrite -orbA orbC orbF.
    rewrite andb_orr.
    rewrite orbA.
    rewrite andbA.
    rewrite andNb orbF.
    rewrite -leqNgt.
    rewrite -ltn_neqAle.
    rewrite orbC.
    rewrite andb_idl.
    by rewrite andbC.
    move/eqP ->.
    rewrite /set_next.
    case: (arg_minP _ f)=> //.
    move=> j Hj Hmin.
    by move: Hj=> /andP [Hj1 _].
  apply symdiff_repr=> //.
  by apply (min_ripple_repr _ _ _ H _ Hf)=> //.
case: ifP=> Hnext'.
have ->: set_iota 0 (set_next S - set_min S - 1) = [set x0 in 'I_wordsize | x0 <= set_next S - set_min S - 2].
  apply/setP=> x; rewrite !inE.
  rewrite mem_ord_iota /= add0n.
  rewrite -addn1.
  have ->: (set_next S - set_min S - 1) = (set_next S - set_min S - 2) + 1.
    rewrite /=.
    have ->: set_next S - set_min S - 2 = set_next S - set_min S - 1 - 1.
      have {3}->: 2 = 1 + 1 by trivial.
      by rewrite subnDA.
    rewrite subnK //.
    rewrite ltn_subRL.
    rewrite addn0 ltn_subRL.
    rewrite -addn1 -addnA.
    by rewrite Hnext'.
  rewrite leq_add2r //.
have ->: [set x0 in 'I_wordsize | x0 <= set_next S - set_min S - 2] =
[set i : 'I_wordsize | i < wordsize - (2 + set_min S) & @inord wordsize.-1 (i + (2 + set_min S)) \in ([set set_next S] :|: [set x in S | x < set_next S])].
  apply/setP=> x; rewrite !inE.
  rewrite andbC andbT.
  case Hx: (x < wordsize - (2 + set_min S)).
  + have Hx': x < wordsize.
      apply (leq_trans (n := wordsize - (2 + set_min S)))=> //.
      by apply leq_subr.
    rewrite [in _ || (_ && _)]andb_idl.
    rewrite -leq_eqVlt /=.
    have {2}->: set_next S = inord (set_next S - set_min S - 2 + (2 + set_min S)).
      apply ord_inj.
      rewrite inordK.
      rewrite -subnDA.
      rewrite [_ + 2]addnC.
      rewrite subnK //.
      rewrite addnC //.
      rewrite -subnDA.
      rewrite [_ + 2]addnC.
      rewrite subnK //.
      rewrite addnC //.
    rewrite !inordK.
    by rewrite leq_add2r.
    rewrite -subnDA.
    rewrite [set_min S + 2]addnC.
    rewrite subnK=> //.
    by rewrite addnC.
    rewrite addnC -ltn_subRL=> //.
    move=> Hx''.
    apply (enumNext_cont _ _ e H f)=> //.
    rewrite inordK.
    rewrite addnA.
    by rewrite leq_addl.
    rewrite addnC -ltn_subRL=> //.
  + rewrite andbC andbF.
    rewrite leqNgt.
    apply negbF.
    rewrite ltnNge in Hx.
    have Hx': wordsize - (2 + set_min S) <= x by apply negbFE; apply Hx.
    apply (leq_trans (n := wordsize - (2 + set_min S)))=> //.
    rewrite -subnDA addnC.
    apply ltn_sub2r=> //.
    rewrite addnC.
    apply (leq_ltn_trans (n := set_next S))=> //.
apply srn_repr=> //.
have ->: set0 = [set i : 'I_wordsize | i < wordsize - (2 + set_min S) & @inord wordsize.-1 (i + (2 + set_min S)) \in ([set set_next S] :|: [set x in S | x < set_next S])].
  apply/setP=> x; rewrite !inE.
  case Hx: (x < wordsize - (2 + set_min S)); last by rewrite andbC andbF.
  rewrite andbC andbT.
  rewrite ltn_subRL addnC in Hx.
  case Hx': (inord (x + (2 + set_min S)) == set_next S).
  + exfalso.
    move: Hx'=> /eqP Hx'.
    have Hx'': x + (2 + set_min S) = set_next S.
      rewrite -Hx'.
      rewrite inordK=> //.
      rewrite -Hx'' in Hnext'.
      rewrite addnC in Hnext'.
      by rewrite leq_addl in Hnext'.
  + rewrite /=.
    have ->: (@inord wordsize.-1 (x + (2 + set_min S)) < set_next S) = false.
      rewrite inordK=> //.
      rewrite ltnNge.
      apply negbF.
      apply (leq_trans (n := set_min S + 2)).
      apply ltnW.
      by rewrite ltnNge Hnext'.
      by rewrite addnC leq_addl.
    by rewrite andbF.
by apply srn_repr.
Qed.

Lemma set_min_leq (S: {set 'I_wordsize}) e (H: e \in S): forall x, x \in S -> set_min S <= x.
Proof.
  move=> x Hx.
  rewrite /set_min.
  case: (arg_minP _ e)=> //.
  by move=> i Hi /(_ x Hx) ->.
Qed.

Lemma set_min_S (S: {set 'I_wordsize}) e (H: e \in S): set_min S \in S.
Proof.
  rewrite /set_min.
  case: (arg_minP _ e)=> //.
Qed.

Lemma enumNext_case2_next (S: {set 'I_wordsize}) e (H: e \in S) f (Hf: set_isNext S f): set_next S < set_min S + 2 -> nat_of_ord (set_next S) = set_min S + 1.
Proof.
move=> Hc'.
apply/eqP.
rewrite eqn_leq.
apply/andP; split.
+ rewrite -(leq_add2r 1).
  rewrite -addnA /=.
  rewrite -addn1 in Hc'.
  by apply Hc'.
+ rewrite addn1.
  rewrite ltn_neqAle.
  apply/andP; split.
  - apply/eqP=> Habs.
    move: (ord_inj Habs)=> Habs'.
    have Habs'': set_next S \in S.
      rewrite -Habs'.
      rewrite /set_min.
      case: (arg_minP _ e)=> //.
    move: Habs''.
    rewrite /set_next.
    case: (arg_minP _ f)=> //.
    move=> i /andP[Hi1 _] _ Hi2.
    by rewrite Hi2 in Hi1.
  - rewrite /set_next.
    case: (arg_minP _ f)=> //.
    move=> i /andP [_ /existsP [x /andP [Hx1 Hx2]]] _.
    apply (leq_trans (n := x)).
    apply (set_min_leq _ e)=> //.
    apply ltnW=> //.
Qed.

Lemma enumNext_case2 (S: {set 'I_wordsize}) e (H: e \in S) f (Hf: set_isNext S f): set_next S < set_min S + 2 -> S = (set_min S) |: [set x in S | set_next S < x].
Proof.
move=> Hc'.
apply/setP=> x; rewrite !inE.
case Hx: (x \in S)=> //.
- rewrite /=.
  case Hx2: (x <= set_min S).
  + rewrite leq_eqVlt in Hx2.
    move: Hx2=> /orP; elim=> Hx2.
    move: Hx2=> /eqP Hx2.
    move: (ord_inj Hx2)=> Hx3.
    by rewrite Hx3 eq_refl.
    exfalso.
    move: Hx2; rewrite /set_min.
    case: (arg_minP _ e)=> //.
    move=> i Hi /(_ x) Hmin.
    by rewrite ltnNge Hmin.
  + have ->: set_next S < x.
      rewrite ltn_neqAle.
      apply/andP; split.
      apply/negP=> /eqP Habs.
      have Habs': x = inord (set_next S).
        rewrite Habs.
        apply ord_inj.
        by rewrite inordK=> //.
      rewrite Habs' in Hx.
      move: Hx.
      rewrite /set_next.
      case: (arg_minP _ f)=> //.
      move=> i /andP [Hi _] Hmin Hi'.
      rewrite inord_val in Hi'.
      by rewrite Hi' in Hi.
      rewrite (enumNext_case2_next _ e _ f)=> //.
      by rewrite addn1 ltnNge Hx2.
    by rewrite orbT.
- rewrite orbF.
  symmetry.
  apply negbTE.
  apply/negP=> /eqP Habs.
  rewrite Habs in Hx.
  by rewrite (set_min_S _ e) in Hx.
Qed.

Lemma enumNext_sameCard (S: {set 'I_wordsize}) e (H: e \in S) f (Hf: set_isNext S f):
  #|enumNext_set S| = #|S|.
Proof.
rewrite /enumNext_set.
have H1: set_next S \notin [set x in S | set_next S < x].
  apply/negP=> Habs.
  by rewrite !inE ltnn andbF in Habs.
have H2: set_min S < set_next S.
  rewrite /set_next.
  case: (arg_minP _ f)=> //.
  move=> i /andP [_ /existsP [x /andP [Hx1 Hx2]]] _.
  apply (leq_ltn_trans (n := x))=> //.
  by apply (set_min_leq _ e).
have H3: set_min S \notin [set x in S | set_next S < x].
  apply/negP=> Habs.
  rewrite !inE in Habs.
  move: Habs=> /andP [_ Habs].
  rewrite ltnNge in Habs.
  move: Habs=> /negP Habs.
  apply Habs.
  by rewrite ltnW.
have H4: (set_next S |: [set x in S | set_next S < x]) :&: (set_iota 0 (set_next S - set_min S - 1)) = set0.
  apply/setP=> x; rewrite !inE.
  apply/negP=> /andP [/orP Habs1 Habs2].
  rewrite mem_ord_iota add0n /= in Habs2.
  have Habs': x >= set_next S.
    case: Habs1=> Habs1.
    move: Habs1=> /eqP Habs1.
    rewrite Habs1=> //.
    move: Habs1=> /andP [_ Habs1].
    by apply ltnW.
  have Habs'': false.
    rewrite -(ltnn (set_next S)).
    apply (leq_ltn_trans (n := x))=> //.
    apply (ltn_trans (n := set_next S - set_min S - 1))=> //.
    rewrite -{2}[nat_of_ord (set_next S)]subn0.
    rewrite -subnDA.
    apply ltn_sub2l.
    apply (leq_ltn_trans (n := set_min S))=> //.
    rewrite addn1=> //.
  by trivial.
have H5: (set_min S |: [set x in S | set_next S < x]) :&: [set x in S | set_min S < x < set_next S] = set0.
  apply/setP=> x; rewrite !inE.
  apply/negP=> /andP [/orP Habs1 /andP [Habs2 /andP [Habs4 Habs3]]].
  case: Habs1=> Habs1.
  move: Habs1=> /eqP Habs1.
  rewrite Habs1 in Habs4.
  have Habs': false by rewrite -(ltnn (set_min S)).
  rewrite //.
  move: Habs1=> /andP [_ Habs1].
  have Habs': false.
    rewrite -(ltnn (set_next S)).
    by apply (ltn_trans (n := x)).
  rewrite //.
rewrite cardsU cardsU1 H1 /=.
case Hc: (set_min S + 2 <= set_next S).
+ rewrite H4 cards0 subn0.
  have {5}->: S = (set_min S) |: [set x in S | set_next S < x] :|: [set x in S | set_min S < x < set_next S].
    apply/setP=> x; rewrite !inE.
    have ->: (x == set_min S) = (x \in S) && (x == set_min S).
      case Hx: (x == set_min S).
      move: (set_min_S S e H)=> HSmin.
      rewrite -(eqP Hx) in HSmin.
      by rewrite HSmin.
      by rewrite andbF.
    case Hx: (x \in S)=> //.
    rewrite /=.
    symmetry.
    have Hx': (set_min S == x) || (set_min S < x).
      rewrite -leq_eqVlt.
      by apply (set_min_leq _ e).
    move: Hx'=> /orP Hx'.
    elim Hx'.
    move/eqP ->; by rewrite eq_refl.
    move ->.
    rewrite /=.
    rewrite -orbA -neq_ltn.
    apply/orP; right.
    apply/negP=> /eqP.
    rewrite /set_next.
    case: (arg_minP _ f)=> //.
    move=> i Hi Hmin Hi'.
    rewrite (ord_inj Hi') in Hi.
    rewrite /set_isNext in Hi.
    move: Hi=> /andP[Habs' _].
    by rewrite Hx in Habs'.
  rewrite cardsU.
  rewrite H5.
  rewrite cards0 subn0.
  rewrite cardsU1 H3 /=.
  have ->: [set x in S | set_min S < x < set_next S] = set_iota (set_min S).+1 (set_next S - (set_min S).+1).
    apply/setP=> x; rewrite !inE.
    rewrite andb_idl=> //.
    rewrite mem_ord_iota.
    rewrite subnKC=> //.
    move=> /andP [Hx2 Hx1].
    move: Hx1.
    rewrite /set_next.
    case: (arg_minP _ f)=> //.
    move=> i Hi Hmin Hi'.
    rewrite ltnNge in Hi'.
    apply/negP=> /negP Habs.
    have Habs': i <= x.
      apply Hmin.
      apply/andP; split=> //.
      apply/existsP.
      exists (set_min S).
      by rewrite (set_min_S _ e) // Hx2.
    by rewrite Habs' in Hi'.
  rewrite !card_set_iota.
  rewrite [_ - (set_min S).+1]subnS.
  by rewrite subn1.
  rewrite subnKC=> //.
  rewrite ltnW=> //.
  rewrite add0n.
  apply (leq_trans (n := set_next S)).
  rewrite -subnDA.
  rewrite -{2}[nat_of_ord (set_next S)]subn0.
  rewrite leq_sub2l=> //.
  rewrite ltnW //.
+ rewrite setI0 cards0 addn0 subn0.
  have Hc': set_next S < set_min S + 2.
    by rewrite ltnNge Hc.
  rewrite {3}(enumNext_case2 S e _ f)=> //.
  by rewrite cardsU1 H3.
Qed.

Variables (k: nat) (n: nat) (k_gt0: k > 0) (k_leqn: k <= n) (n_lt: n < wordsize).

Definition indToSet i := iter i (fun x => enumNext_set x) (set_iota 0 k).

Lemma allEnums_haveE: forall i, exists e, e \in indToSet i.
elim=> [|i IHi /=].
+ (* i = 0 *)
  exists ord0.
  by rewrite inE mem_ord_iota.
+ (* i ~ i.+1 *)
  exists (set_next (indToSet i)).
  rewrite /enumNext_set.
  rewrite -setUA.
  by rewrite setU11.
Qed.

(*** Knuth's formula ***)
Fixpoint setToInd_rec (S: {set 'I_wordsize}) i j :=
  match j with
  | 0 => 0
  | j'.+1 =>
    let min := [arg min_(x < ord0 | x \in S) x] in
    'C(min, i.+1) + setToInd_rec (S :\ min) (i.+1) j'
  end.

Definition setToInd (S: {set 'I_wordsize}) := setToInd_rec S 0 k.

Lemma setToInd_next (S: {set 'I_wordsize}) (HS: #|S| = k) e (He: e \in S) f (Hf: set_isNext S f): setToInd (enumNext_set S) = (setToInd S).+1.
Proof.
rewrite /enumNext_set.
case H: (set_min S + 2 <= set_next S).
+ (* H true *)
  admit. (* Hard case *)
+ (* H false *)
  have H': (set_next S < set_min S + 2) by rewrite ltnNge H.
  rewrite setU0.
  rewrite {4}(enumNext_case2 S e _ f)=> //.
  rewrite /setToInd.
  have Hmin: set_min S + 1 < wordsize.
    by admit.
  have {1}->: set_next S = inord (set_min S + 1).
    apply ord_inj.
    rewrite inordK=> //.
    rewrite (enumNext_case2_next _ e _ f)=> //.
  rewrite (enumNext_case2_next S e _ f)=> //.
  have ->: k = k.-1.+1 by rewrite prednK.
  rewrite /=.
  have ->: [arg min_(x < ord0 in inord (set_min S + 1) |: [set x0 in S | set_min S + 1 < x0]) x] = inord (set_min S + 1).
    by admit.
  have ->: [arg min_(x < ord0 in set_min S |: [set x0 in S | set_min S + 1 < x0]) x] = set_min S.
    by admit.
  rewrite !setU1K.
  rewrite !bin1.
  rewrite inordK=> //.
  rewrite -[(set_min S + setToInd_rec _ _ _).+1]addn1.
  rewrite -addnA.
  rewrite [(1 + _)]addnC.
  by rewrite addnA.
  rewrite inE.
  apply/negP=> /andP[_ Habs].
  rewrite addn1 in Habs.
  have Habs': false.
    rewrite -(ltnn (set_min S)).
    apply (ltn_trans (n := (set_min S).+1))=> //.
  rewrite //.
  rewrite inE.
  apply/negP=> /andP[_ Habs].
  rewrite inordK in Habs=> //.
  by rewrite ltnn in Habs.
Admitted.

Lemma setToInd_gtn_max (S: {set 'I_wordsize}) (HS: #|S| = k):
  setToInd S >= 'C([arg max_(x > ord0 | x \in S) x], k).
Proof.
Admitted.

Lemma indToSet_bounded (S: {set 'I_wordsize}) (HS: #|S| = k) x: setToInd S < 'C(n, k) -> x \in S -> x < n.
Proof.
move=> H Hx.
apply/negPn.
apply/negP=> gte_n_x.
rewrite -leqNgt in gte_n_x.
have Habs: setToInd S >= 'C(n, k).
apply (leq_trans (n := 'C([arg max_(x > ord0 | x \in S) x], k))).
apply leq_bin2l.
apply (leq_trans (n := x))=> //.
case: (arg_maxP _ x)=> //.
move=> i Hi Hmin.
move: Hmin=> /(_ x) Hmin.
apply Hmin=> //.
apply setToInd_gtn_max=> //.
rewrite leqNgt in Habs.
by rewrite H in Habs.
Qed.

Lemma allEnums_haveF_ind i (ltn_i: i < 'C(n, k)): setToInd (indToSet i) = i -> #|indToSet i| = k -> exists f, set_isNext (indToSet i) f.
  move=> Hi.
  move: (allEnums_haveE i)=> [e He].
  exists (inord n).
  rewrite /set_isNext.
  apply/andP; split.
  apply/negP=> Habs.
  have Habs': nat_of_ord (@inord wordsize.-1 n) < n.
    apply (indToSet_bounded (indToSet i))=> //.
    rewrite Hi //.
  rewrite inordK in Habs'=> //.
  have Habs'': false.
    by rewrite -(ltnn n).
  rewrite //.
  apply/existsP.
  exists e.
  rewrite He /=.
  rewrite inordK=> //.
  apply (indToSet_bounded (indToSet i))=> //.
  rewrite Hi //.
Qed.

Lemma setToInd_init: setToInd (set_iota 0 k) = 0.
Proof.
rewrite /setToInd.
have H: forall i j, i + j = k -> setToInd_rec (set_iota j (k - j)) j i = 0.
  elim=> [//| i Hi j Hj].
  rewrite /=.
  have ->: [arg min_(x < ord0 in set_iota j (k - j)) x] = inord j.
    admit.
  rewrite bin_small.
  rewrite add0n.
  have ->: ((set_iota j (k - j)) :\ inord j) = set_iota j.+1 (k - j.+1).
    admit.
  apply Hi.
  by rewrite -addn1 [j + 1]addnC addnA addn1.
  rewrite inordK //.
  apply (leq_trans (n := k)).
  rewrite -Hj.
  have {1}->: j = 0 + j by rewrite add0n.
  apply ltn_add2r.
  apply (leq_trans (n := n))=> //.
  rewrite ltnW //.
rewrite -{1}[k]subn0.
apply H.
by rewrite addn0.
Admitted.

Lemma indToSet_ind i (ltn_i: i < 'C(n, k)): #|indToSet i| = k /\ setToInd (indToSet i) = i.
Proof.
elim: i ltn_i=> [ltn_i|i IH ltn_i].
+ (* i = 0 *)
  split.
  rewrite card_set_iota //.
  rewrite add0n.
  apply (leq_trans (n := n))=> //.
  rewrite ltnW //.
  apply setToInd_init.
+ (* i ~ i.+1 *)
  have ltn'_i: i < 'C(n, k).
    apply (ltn_trans (n := i.+1))=> //.
  move: (IH ltn'_i)=> [IHi1 IHi2].
  move: (allEnums_haveE i)=> [e He].
  move: (allEnums_haveF_ind i ltn'_i IHi2 IHi1)=> [f Hf].
  split.
  rewrite /=.
  rewrite (enumNext_sameCard _ e _ f) //.
  rewrite /=.
  rewrite (setToInd_next _ _ e _ f)=> //.
  rewrite IHi2 //.
Qed.

Lemma indToSet_inv i (ltn_i: i < 'C(n, k)): setToInd (indToSet i) = i.
Proof.
by apply indToSet_ind.
Qed.

Lemma setToInd_inj (S1 S2: {set 'I_wordsize}) (HS1: #|S1| = k) (HS2: #|S2| = k): setToInd S1 = setToInd S2 -> S1 = S2.
(* Should come from the inverse + finite application between sets of same size (see cards_draws) *)
Admitted.

Definition allSubsets := [set A : {set 'I_wordsize} | (#|A| == k) && [forall x, (x \in A) ==> (x < n)]].

Lemma setToInd_bounded x: x \in allSubsets -> setToInd x < 'C(n, k).
Admitted.
(***********************)

Lemma allEnums_sameCard i (ltn_i: i < 'C(n, k)): #|indToSet i| = k.
Proof.
by apply indToSet_ind.
Qed.

Lemma allEnums_haveF i (ltn_i: i < 'C(n, k)): exists f, set_isNext (indToSet i) f.
Proof.
apply allEnums_haveF_ind=> //.
apply indToSet_inv=> //.
by apply allEnums_sameCard.
Qed.

Lemma setToInd_inv (S: {set 'I_wordsize}) (HS: S \in allSubsets): indToSet (setToInd S) = S.
Proof.
apply setToInd_inj=> //.
apply allEnums_sameCard.
apply setToInd_bounded=> //.
rewrite /allSubsets inE in HS.
by move: HS=> /andP [/eqP -> _].
rewrite indToSet_inv //.
apply setToInd_bounded=> //.
Qed.

Canonical int_eqMixin := EqMixin eqInt32P.
Canonical int_eqType := Eval hnf in EqType Int32 int_eqMixin.

Definition allEnums_set := [set (indToSet (nat_of_ord y)) | y in 'I_('C(n, k))].

Definition indToInt i := iter i enumNext (dec (lsl one (toInt k))).

Definition allEnums := mkseq indToInt 'C(n, k).

Lemma allEnums_eq: allEnums_set = allSubsets.
Proof.
apply/eqP.
rewrite eqEsubset.
apply/andP; split.
+ (* allEnums_set \subset allSubsets *)
  apply/subsetP=> x Hx.
  rewrite /allSubsets !inE.
  move: Hx=> /imsetP [y Hy1 Hy2].
  apply/andP; split.
  rewrite Hy2 allEnums_sameCard=> //.
  apply/forallP=> x0.
  apply/implyP=> Hx0.
  apply (indToSet_bounded x)=> //.
  rewrite Hy2 allEnums_sameCard //.
  rewrite Hy2 indToSet_inv=> //.
+ (* allSubsets \subset allEnums_set *)
  apply/subsetP=> x Hx.
  apply/imsetP.
  have Hcast: 'C(n, k).-1.+1 = 'C(n, k).
    rewrite prednK=> //.
    by rewrite bin_gt0.
  exists (cast_ord Hcast (inord (setToInd x)))=> //.
  rewrite /= inordK.
  rewrite setToInd_inv //.
  rewrite Hcast.
  by apply setToInd_bounded.
Qed.

Lemma allEnums_min_bounded i (ltn_i: i < 'C(n, k)): 2 + set_min (indToSet i) <= wordsize.
move: (allEnums_haveE i)=> [e He].
have H: set_min (indToSet i) < n.
  apply (indToSet_bounded (indToSet i)).
  apply allEnums_sameCard=> //.
  rewrite indToSet_inv=> //.
  apply (set_min_S _ e)=> //.
have {1}->: 2 = 1 + 1 by trivial.
rewrite addnC addnA.
rewrite addn1.
apply (leq_ltn_trans (n := n))=> //.
rewrite addn1=> //.
Qed.

Lemma allEnums_repr_i i (ltn_i: i < 'C(n, k)): machine_repr (indToInt i) (indToSet i).
Proof.
elim: i ltn_i=> [ltn_i|i IHi ltn_i].
rewrite /=.
apply create_repr.
rewrite /=.
move: (allEnums_haveE i)=> [e He].
have ltn'_i: i < 'C(n, k) by apply (ltn_trans (n := i.+1)).
move: (allEnums_haveF i ltn'_i)=> [f Hf].
apply (enumNext_correct _ _ e He f)=> //.
apply allEnums_min_bounded=> //.
by apply IHi.
Qed.

Lemma allEnums_repr: forall x,
  x \in allEnums <-> exists y, y \in allEnums_set /\ machine_repr x y.
Proof.
move=> x.
split.
+ (* -> *)
  move=> Hx.
  rewrite /allEnums in Hx.
  move: Hx=> /mapP [i Hi Hx].
  exists (indToSet i); split.
  rewrite /allEnums_set.
  apply/imsetP.
  have Hcast: 'C(n, k).-1.+1 = 'C(n, k).
    rewrite prednK=> //.
    by rewrite bin_gt0.
  exists (cast_ord Hcast (@inord 'C(n, k).-1 i))=> //.
  rewrite /= inordK=> //.
  rewrite Hcast.
  move: (mem_iota 0 'C(n, k) i)=> Hi'.
  rewrite Hi in Hi'.
  by rewrite /= add0n in Hi'.
  rewrite Hx.
  apply (allEnums_repr_i i).
  by rewrite mem_iota /= add0n in Hi.
+ (* <- *)
  move=> [y [Hy1 Hy2]].
  rewrite /allEnums.
  rewrite /allEnums_set in Hy1.
  apply/mapP.
  move: Hy1=> /imsetP [z Hz1 Hz2].
  exists (nat_of_ord z).
  rewrite mem_iota /= add0n //.
  apply (machine_repr_inj1 _ y)=> //.
  rewrite Hz2.
  by apply (allEnums_repr_i z).
Qed.

Theorem enumsNext_allEnum: forall x, x \in allEnums <-> exists y, y \in allSubsets /\ machine_repr x y.
Proof.
rewrite -allEnums_eq.
by apply allEnums_repr.
Qed.

End Enum_parts.

Cd "examples/enum_parts".

Require Import ExtrOcamlBasic.

Extraction "enum_parts.ml" enumNext.

Cd "../..".


From mathcomp Require Import ssreflect.
From Category.Base Require Import Logic Category Functor NatTran.

Set Universe Polymorphism.

Module Comma.

  Section CommaSection.
    Context {C D E : Category}.
    Variable F : Functor C E.
    Variable G : Functor D E.

    Definition obj := {ff : (Obj C) * (Obj D) & Hom (FApp F (fst ff)) (FApp G (snd ff))}.
    Definition dom (ff : obj) : Obj C := fst (projT1 ff).
    Definition codom (ff : obj) : Obj D := snd (projT1 ff).
    Definition arrow (ff : obj) : Hom (FApp F (dom ff)) (FApp G (codom ff)) := projT2 ff.

    Definition hom : obj -> obj -> Type :=
      fun ff1 ff2  =>
        let X1 : Obj C := dom ff1 in
        let X2 : Obj C := dom ff2 in
        let Y1 : Obj D := codom ff1 in
        let Y2 : Obj D := codom ff2 in
        let f1 : Hom (FApp F X1) (FApp G Y1) := arrow ff1 in
        let f2 : Hom (FApp F X2) (FApp G Y2) := arrow ff2 in
        {gg : (Hom X1 X2) * (Hom Y1 Y2) | (FAppH G (snd gg)) \o f1 = f2 \o (FAppH F (fst gg))}.

    Definition hom_fst {ff1 ff2 : obj} (hh : hom ff1 ff2) : Hom (dom ff1) (dom ff2) :=
      fst (proj1_sig hh).

    Definition hom_snd {ff1 ff2 : obj} (hh : hom ff1 ff2) : Hom (codom ff1) (codom ff2) :=
      snd (proj1_sig hh).

    Lemma Tohom_eq :
      forall {ff1 ff2 : obj},
      forall (hh gg : hom ff1 ff2),
        hom_fst hh = hom_fst gg -> hom_snd hh = hom_snd gg -> hh = gg.
    Proof.
      move => ff1 ff2.
      move => [[hh1 hh2] condh].
      move => [[gg1 gg2] condg].
      rewrite /hom_fst /hom_snd /=.
      move => eqh eqg.
      subst.
      rewrite(_:condh = condg).
      reflexivity.
      exact: p_proof_irrelevance.
    Qed.

    Program Definition id (ff : obj) : hom ff ff :=
      pair (\Id (dom ff)) (\Id (codom ff)).
    Next Obligation.
    Proof.
      repeat rewrite Functor_id_eq.
      move: Hom_IdL =>->.
      move: Hom_IdR =>->.
      reflexivity.
    Qed.

    Program Definition comp (ff1 ff2 ff3 : obj) : (hom ff2 ff3) -> (hom ff1 ff2) -> (hom ff1 ff3) :=
      fun hh gg =>
        pair (hom_fst hh \o hom_fst gg) (hom_snd hh \o hom_snd gg).
    Next Obligation.
    Proof.
      repeat rewrite FAppH_comp_eq.
      rewrite (Hom_assoc _ _ (arrow ff1)).
      move: (proj2_sig gg) =>->.
      rewrite <- (Hom_assoc (arrow ff3)).
      move: (proj2_sig hh) =><-.
      rewrite Hom_assoc.
      reflexivity.
    Qed.

  End CommaSection.
End Comma.

Section Definitions.

  Context {C D E : Category}.
  Context {F : Functor C E}.
  Context {G : Functor D E}.

  Program Definition CommaCat : Category :=
  {|
        Obj := Comma.obj F G;
        Hom := Comma.hom F G;
        Hom_Id := Comma.id F G;
        Hom_comp := Comma.comp F G
  |}.
  Next Obligation.
  Proof.
    apply: Comma.Tohom_eq.
    {
      unfold Comma.comp.
      unfold Comma.hom_fst.
      rewrite /=.
      exact: Hom_assoc.
    } {
      unfold Comma.comp.
      unfold Comma.hom_fst.
      rewrite /=.
      exact: Hom_assoc.
    }
  Qed.
  Next Obligation.
  Proof.
    unfold Comma.id.
    unfold Comma.comp.
    apply: Comma.Tohom_eq.
    {
      unfold Comma.hom_fst.
      rewrite /=.
      exact: Hom_IdL.
    } {
      unfold Comma.hom_snd.
      rewrite /=.
      exact: Hom_IdL.
    }
  Qed.
  Next Obligation.
    unfold Comma.id.
    unfold Comma.comp.
    apply: Comma.Tohom_eq.
    {
      unfold Comma.hom_fst.
      rewrite /=.
      exact: Hom_IdR.
    } {
      unfold Comma.hom_snd.
      rewrite /=.
      exact: Hom_IdR.
    }
  Qed.

  Definition CommaDom (f : Obj CommaCat) : Obj C := Comma.dom F G f.
  Definition CommaCodom (f : Obj CommaCat) : Obj D := Comma.codom F G f.
  Definition OfCommaObj (f : Obj CommaCat) : Hom (FApp F (CommaDom f)) (FApp G (CommaCodom f)) := Comma.arrow F G f.
  Definition CommaHom_fst {f1 f2 : Obj CommaCat} (hh : Hom f1 f2) : Hom (CommaDom f1) (CommaDom f2) := Comma.hom_fst F G hh.
  Definition CommaHom_snd {f1 f2 : Obj CommaCat} (hh : Hom f1 f2) : Hom (CommaCodom f1) (CommaCodom f2) := Comma.hom_snd F G hh.
  Lemma ToCommaHomEq :
    forall {ff1 ff2 : Obj CommaCat},
    forall (hh gg : Hom ff1 ff2),
      CommaHom_fst hh = CommaHom_fst gg -> CommaHom_snd hh = CommaHom_snd gg -> hh = gg.
  Proof.
    move => ff1 ff2 hh gg eqf eqs.
    apply: Comma.Tohom_eq.
    assumption.
    assumption.
  Qed.

End Definitions.

Global Arguments CommaCat {C D E} (F G).

Definition ToCommaObj
           {C D E}
           (F : Functor C E) (G : Functor D E)
           (X : Obj C) (Y : Obj D) (f : Hom (FApp F X) (FApp G Y))
  : Obj (CommaCat F G) :=
  existT _ (pair X Y) f.

Lemma Eq_ToCommaObj
      {C D E}
      (F : Functor C E) (G : Functor D E) :
  forall (h : Obj (CommaCat F G)),
    h = (ToCommaObj F G (CommaDom h) (CommaCodom h) (OfCommaObj h)).
Proof.
  rewrite /=.
  unfold ToCommaObj, CommaDom, CommaCodom, OfCommaObj.
  unfold Comma.dom, Comma.codom, Comma.arrow.
  case.
  case.
  simpl.
  move => X Y p.
  reflexivity.
Qed.

Definition ToCommaHomCond
           {C D E}
           {F : Functor C E} {G : Functor D E}
           {X1 X2 : Obj C} {Y1 Y2 : Obj D}
           (h1 : Hom (FApp F X1) (FApp G Y1)) (h2 : Hom (FApp F X2) (FApp G Y2))
           (f : Hom X1 X2) (g : Hom Y1 Y2) :=
  (FAppH G g) \o h1 = h2 \o (FAppH F f).

Definition ToCommaHom
           {C D E}
           {F : Functor C E} {G : Functor D E}
           {X1 X2 : Obj C} {Y1 Y2 : Obj D}
           (h1 : Hom (FApp F X1) (FApp G Y1)) (h2 : Hom (FApp F X2) (FApp G Y2))
           (f : Hom X1 X2) (g : Hom Y1 Y2)
           (cond : ToCommaHomCond h1 h2 f g)
  : Hom (ToCommaObj F G X1 Y1 h1) (ToCommaObj F G X2 Y2 h2) :=
  exist _ (pair f g) cond.

Definition ToCommaHom'Cond
           {C D E}
           {F : Functor C E} {G : Functor D E}
           (h1 h2 : Obj (CommaCat F G))
           (f : Hom (CommaDom h1) (CommaDom h2))
           (g : Hom (CommaCodom h1) (CommaCodom h2)) :=
  (FAppH G g) \o (OfCommaObj h1) = (OfCommaObj h2) \o (FAppH F f).

Definition ToCommaHom'
           {C D E}
           {F : Functor C E} {G : Functor D E}
           (h1 h2 : Obj (CommaCat F G))
           (f : Hom (CommaDom h1) (CommaDom h2))
           (g : Hom (CommaCodom h1) (CommaCodom h2))
           (cond : ToCommaHom'Cond h1 h2 f g)
  : Hom h1 h2 :=
  exist _ (pair f g) cond.

Lemma CommaHom_Cond
      {C D E}
      {F : Functor C E} {G : Functor D E}
      {X1 X2 : Obj C} {Y1 Y2 : Obj D}
      {f1 : Hom (FApp F X1) (FApp G Y1)}
      {f2 : Hom (FApp F X2) (FApp G Y2)} :
  forall (ff : Hom (ToCommaObj F G X1 Y1 f1) (ToCommaObj F G X2 Y2 f2)),
    (FAppH G (CommaHom_snd ff)) \o f1 = f2 \o (FAppH F (CommaHom_fst ff)).
Proof.
  case.
  case.
  unfold Comma.dom.
  unfold Comma.codom.
  simpl.
  move => h1 h2 cond.
  unfold CommaHom_fst.
  unfold CommaHom_snd.
  unfold Comma.hom_fst.
  unfold Comma.hom_snd.
  simpl.
  assumption.
Qed.


Require Export Fibrations Contractible Equivalences.
Require Export UsefulEquivalences FiberEquivalences.

(** In type theory [f] and [g] are extensionally equal if they give equal values.
   In HoTT such an equality might be called "pointwise homotopy" or just "homotopy". *)

Definition ext_dep_eq {X} {P : X -> Type} (f g : forall x, P x) := forall x : X, f x = g x.

(** A notation for extensional equality. *)

Notation "f == g" := (ext_dep_eq f g) (at level 50).

(** The simplest notion we call "naive functional extensionality".
   This is what a type theorist would probably write down when
   thinking of types as sets and identity types as equalities: it says
   that if two functions are equal pointwise, then they are equal.  It
   comes in both ordinary and dependent versions. *)

Definition funext_statement (X Y : Type) :=
  forall (f g : X -> Y), f == g -> f = g.

Definition funext_dep_statement {X : Type} (P : fibration X) :=
  forall (f g : section P), f == g -> (f = g).

(** However, there are clearly going to be problems with this in the
   homotopy world, since "being equal" is not merely a property, but
   being equipped with a path is structure.  We should expect some
   sort of coherence or canonicity of the path from f to g relating it
   to the pointwise homotopy we started with.

   A natural way to state a "homotopically good" notion of function
   extensionality is to observe that there is a canonical map in the
   other direction, taking paths between functions to pointwise
   homotopies.  We can thus just ask for that map to be an
   equivalence.  We call this "strong functional extensionality."  Of
   course, it also comes in ordinary and dependent versions.  *)

Definition strong_funext_statement (X Y : Type) :=
  forall (f g : X -> Y), is_equiv (@happly X Y f g).

Definition strong_funext_dep_statement {X : Type} (P : fibration X) :=
  forall (f g : section P), is_equiv (@happly_dep X P f g).

(** From the assumption that [happly_dep] is an equivalence we build
   the corresponding equivalence. *)

Definition happly_dep_equiv
  (X : Type) (P : fibration X) (f g : section P) (H : strong_funext_dep_statement P) :
  f = g <~> f == g.
Proof.
  exists (@happly_dep X P f g).
  apply H.
Defined.

(** Of course, strong functional extensionality implies naive
   functional extensionality, along with a computation rule. *)

Theorem strong_to_naive_funext:
  (forall X Y, strong_funext_statement X Y) -> (forall X P, funext_statement X P).
Proof.
  intros H X Y f g.
  exact ({| equiv_map := @happly X Y f g; equiv_is_equiv := H X Y f g|} ^-1).
Defined.

Theorem strong_funext_compute
  (strong_funext : forall X Y, strong_funext_statement X Y)
  (X Y : Type) (f g : X -> Y) (p : f == g) (x : X) :
  happly (strong_to_naive_funext strong_funext X Y f g p) x = p x.
Proof.
  intros.
  unfold strong_to_naive_funext.
  unfold inverse.
  simpl.
  exact (happly_dep (pr2 (pr1 (strong_funext X Y f g p))) x).
Defined.

Theorem strong_to_naive_funext_dep {X} (P : fibration X):
  strong_funext_dep_statement P -> funext_dep_statement P.
Proof.
  intros H f g.
  exact ({| equiv_map := @happly_dep X P f g ; equiv_is_equiv := H f g |} ^-1).
Defined.

Theorem strong_funext_dep_compute {X} (P : fibration X)
  (strong_funext_dep : strong_funext_dep_statement P)
  (f g : section P) (p : f == g) (x : X) :
  happly_dep (strong_to_naive_funext_dep P strong_funext_dep f g p) x = p x.
Proof.
  intros.
  unfold strong_to_naive_funext_dep, inverse.
  simpl.
  exact (happly_dep (pr2 (pr1 (strong_funext_dep f g p))) x).
Defined.

(** We also observe that for both strong and naive functional
   extensionality, the dependent version implies the non-dependent
   version.  *)

Theorem strong_funext_dep_to_nondep :
  (forall X (P : fibration X), strong_funext_dep_statement P) -> forall X Y, strong_funext_statement X Y.
Proof.
  intros H X Y f g.
  exact (H X (fun x => Y) f g).
Defined.

Theorem funext_dep_to_nondep :
  (forall X (P : fibration X), funext_dep_statement P) -> forall X Y, funext_statement X Y.
Proof.
  intros H X Y f g.
  exact (H X (fun x => Y) f g).
Defined.

(** Can we go backwards, getting to strong functional extensionality
   from naive functional extensionality?  At first the prospects don't
   look good; naive functional extensionality gives us a map going
   backwards, but it doesn't assert anything *about* that map, so it
   seems unlikely that it would be an inverse to [happly].

   However, it turns out that we can go backwards; the key is to first
   forget down to an even weaker axiom, called "weak functional
   extensionality".  This has only one version, which states that the
   dependent product of a family of (continuously) contractible types
   is contractible.  *)

Definition weak_funext_statement {X : Type} (P : fibration X) :=
    (forall x : X, is_contr (P x)) -> is_contr (section P).

(** It is easy to see that naive dependent functional extensionality
   implies weak functional extensionality. *)

Theorem funext_dep_to_weak {X : Type} (P : fibration X):
  funext_dep_statement P -> weak_funext_statement P.
Proof.
  intros H C.
  exists (fun x => pr1 (C x)).
  intro; apply H.
  intro; apply contr_path, C.
Defined.

(** Another (very) weak type of functional extensionality is the
   (propositional) eta rule, which is implied by naive functional
   extensionality. *)

Definition eta {A B} (f : A -> B) :=
  fun x => f x.

(** If we remove the type anontation [Type] in the definition below,
   Coq puts [eta_statement] in [Prop]. Why? This is worrisome, as other
   things might end up in [Prop] instead of [Type] without us noticing. *)

Definition eta_statement (A B : Type) : Type :=
  forall (f : A -> B), eta f = f.

Theorem naive_funext_implies_eta (A B : Type) :
  funext_statement A B -> eta_statement A B.
Proof.
  intros funext f.
  apply funext.
  intro; apply idpath.
Defined.

(** Here is the dependent version. *)

Definition eta_dep {A} {P : A -> Type} (f : section P) :=
  fun x => f x.

Definition eta_dep_statement {A : Type} (P : fibration A) :=
  forall (f : section P), eta_dep f = f.

Theorem naive_funext_dep_implies_eta {A : Type} (P : fibration A) :
  funext_dep_statement P -> eta_dep_statement P.
Proof.
  intros funext_dep f.
  apply funext_dep.
  intro; apply idpath.
Defined.

(** A "mini" form of the desired implication (naive => strong) is that
   the eta rule does implies directly that the eta map is an
   equivalence. *)

Lemma eta_equiv (A B : Type) : eta_statement A B -> (A -> B) <~> (A -> B).
Proof.
  intros H.
  apply equiv_pointwise_idmap with (f := @eta A B).
  assumption.
Defined.

(** And the dependent version. *)

Lemma eta_dep_equiv {A : Type} (P : fibration A) :
  eta_dep_statement P -> (section P <~> section P).
Proof.
  intro H.
  apply equiv_pointwise_idmap with (f := @eta_dep A P).
  apply H.
Defined.

Section AxiomOfChoiceEquiv'.

  (** The axiom of choice says that a relation is total iff it has a choice function,
     and there is a type-theoretic version of it, which we record first.

     We work with a fully dependent version of the total relation. *)

  Variable X : Type. (* the domain of the relation *)
  Variable P : fibration X. (* the codomain, which is dependent *)
  Variable Q : forall x, fibration (P x). (* the relation, which is dependent *)

  (** The usual axiom of choice for the total relation [Q]. *)

  Definition ac : (forall x, {y : P x & Q x y}) -> {h : section P & forall x, Q x (h x)}.
  Proof.
    intro f.
    exists (fun x => pr1 (f x)).
    intro x.
    exact (pr2 (f x)).
  Defined.

  (** And vice-versa. *)

  Definition acinv : {h : section P & forall x, Q x (h x)} -> forall x, {y : P x & Q x y}.
  Proof.
    intros [h H x].
    exists (h x).
    apply H.
  Defined.

  (** A homotopic version of the axiom of choice ought to state that [ac] is
     an equivalence. We need further assumption to exhibit this fact.
     Firstly, we assume the eta rule throghout. *)

  Hypothesis eta_dep_rule : forall Y (S : fibration Y), eta_dep_statement S.

  (** At this point we are able to provide a version of equivalence, called
     [ac_equiv'] below, in which we assume the weakest form of extensionality
     and an extra condition on [Q], namely that [Q] is single-valued in the
     sense that for every [x] any two elements of the space [{y : P x & Q x y}]
     are connected by a path. This requirement is equivalent to
     the space being an h-prop or h-level 1 (see [HLevel]), and so [ac_equiv']
     is a form of _unuque_ choice.

     We bother proving [ac_equiv'] because it is used in the proof that weak
     extensionality implies strong extensionality. And once we have that result,
     we will be able to show a second, desired version [ac_equiv] without any
     conditions [Q].
  *)

  Definition ac_equiv'
    (total_Q_prop : forall x, forall u v : {y : P x & Q x y}, u = v)
    (weak_funext : forall Y (S : fibration Y), weak_funext_statement S) :
    (forall x, {y : P x & Q x y}) <~> {h : section P & forall x, Q x (h x)}.
  Proof.
    apply (equiv_from_hequiv ac acinv).
    intros [h H].
    unfold ac; simpl.
    fold (eta_dep H).
    rewrite (eta_dep_rule _ _ H).
    fold (eta_dep h).
    (* The obvious thing here would be to rewrite with [E X P h] but that gives
       the dreaded "Error: Abstracting over the term ... which is ill-typed".
       Instead we are going to be a bit clever, as Mike Shulman put it. *)
    (* First, the left-hand side is the image of a map [f] which is an
       equivalence because it is the pullback of an equivalence. *)
    pose (R := (fun (g : section P) => forall x, Q x (g x))).
    pose (e := eta_dep_equiv P (eta_dep_rule _ P)).
    pose (f := pullback_total_equiv R e).
    path_via (f (h; H)).
    (* The following step is not needed in Coq 8.4 but is needed in 8.3 so we try it *)
    (* To show that an equivalence is homotopic to the identity, it
       suffices to show that is idempotent, which is easy. *)
    try now apply equiv_injective with f.
    (* The other half of the proof is easier than it looks because
       we get to apply weak extensionality. *)
    intro h.
    apply contr_path.
    apply weak_funext.
    intro x.
    exists (h x).
    (* And this is precisely our assumption on [Q]. *)
    intro; apply total_Q_prop.
  Defined.

  (** Continued below in section [AxiomOfChoice]... *)
End AxiomOfChoiceEquiv'.

Section WeakToStrongFunextDep.

  (** As an intermezzo of treatment of the axiom of choice we show the
     non-obvious fact that weak functional extensionality implies *strong*
     (dependent) functional extensionality, at least in the presence of the
     dependent eta rule. *)

  Hypothesis eta_dep_rule : forall X (P : fibration X), eta_dep_statement P.

  (** Assume a fibration [P] over [X]. *)
  Variable X : Type.
  Variable P : fibration X.

  (** We want to show that [weak_funext_statement P] implies
     [strong_funext_dep_statement P], which states that [happly_dep] is an
     equivalence. We fix a section [f] over [P] and view [happly_dep f] as a map
     over [section P] between the fibrations [Q] and [R], defined below. *)

  Variable f : section P.

  Let Q := (fun h => f = h) : fibration (section P).
  Let R := (fun h => f == h) : fibration (section P).

  (** We need to show that [happly_dep f] is fiber-wise equivalence. It is
     sufficient to show that the induced total map [total Q] -> [total R] is an
     equivalence, which it is because [total Q] and [total R] are contractible.
     The only tricky bit is to show that [total R] is contractible. *)

  Lemma is_contr_total_Q : is_contr (total Q).
  Proof.
    exists ((f; idpath _) : total Q).
    intros [h p].
    induction p; apply idpath.
  Defined.

  Hypothesis weak_funext : forall X (S : fibration X), weak_funext_statement S.

  Lemma is_contr_total_R : is_contr (total R).
  Proof.
    (* If we knew that our total space [total R] is equivalent to
       a space of sections, we could bring in [weak_funext]. Let us
       unfold a bit to see what is going on. *)
    unfold R, total, ext_dep_eq.
    (* [total R] is exactly of the form needed for [ac_equiv'] to kick in! *)
    apply contr_equiv_contr with (A := forall x, {y : P x & f x = y}).
    apply ac_equiv'; auto.
    (* The rest is a triviality. *)
    intros x u v. apply contr_path, pathspace_contr'.
    apply weak_funext.
    intro; apply pathspace_contr'.
  Defined.

  (** Now we can prove strong extensionality. *)

  Theorem weak_to_strong_funext_dep' (g : section P) : is_equiv (@happly_dep X P f g).
  Proof.
    apply (fiber_is_equiv ((@happly_dep X P f) : forall h, Q h -> R h)).
    apply contr_contr_is_equiv.
    apply is_contr_total_Q.
    apply is_contr_total_R.
  Defined.
End WeakToStrongFunextDep.

(** Let us record the results in a more compact form. *)
Theorem weak_to_strong_funext_dep (X : Type) (P : fibration X)
    (weak_funext: forall X (P : fibration X), weak_funext_statement P)
    (eta_dep_rule : forall X (P : fibration X), eta_dep_statement P) :
    strong_funext_dep_statement P.
Proof.
  intros H f g.
  apply weak_to_strong_funext_dep'; auto.
Defined.

Section AxiomOfChoiceEquiv.
  (** We may now continue with the strong version of the axiom of choice.
     Assuming the eta rule and weak extensionality suffices to show that
     [ac] is an equivalence. *)

  Hypothesis eta_dep_rule : forall Y (S : fibration Y), eta_dep_statement S.

  Hypothesis weak_funext: forall Y (S : fibration Y), weak_funext_statement S.

  Variable X : Type. (* the domain of the relation *)
  Variable P : fibration X. (* the codomain, which is dependent *)
  Variable Q : forall x, fibration (P x). (* the relation, which is dependent *)

  Definition ac_equiv:
    (forall x, {y : P x & Q x y}) <~> {h : section P & forall x, Q x (h x)}.
  Proof.
    (* We first derive strong extensionality. *)
    pose (strong_funext_dep := fun Y (S : fibration Y) =>
      weak_to_strong_funext_dep Y S weak_funext eta_dep_rule).
    pose (funext_dep :=
      fun Y (S : fibration Y) => strong_to_naive_funext_dep S (strong_funext_dep Y S)).
    apply (equiv_from_hequiv (ac X P Q) (acinv X P Q)).
    intros [h H].
    unfold ac; simpl.
    fold (eta_dep H).
    rewrite (eta_dep_rule _ _ H).
    fold (eta_dep h).
    (* So far the proof is the same as that of [ac_equiv'] but now we deviate
       from it. Strong extensionality gives us a path [p : eta_dep h = h] in
       the base with which we can reduce the problem to having a path in the
       fiber. *)
    pose (p := funext_dep X P (eta_dep h) h (fun a => idpath (h a))).
    apply @total_path with p; simpl.
    (* We switch from a path to a homotopy, it's easier. *)
    apply funext_dep; intro x.
    (* Since [p] was constructed using [strong_to_naive_funext_dep] we should
       aim at using [strong_funext_dep_compute]. But this means we need [p]
       as an argument of [happly_dep]. So we juggle a bit. *)
    (* Our path factors through a suitable [trans_map]. *)
    apply (concat (trans_map p (fun s' (r': forall x, Q x (s' x)) => r' x) H)).
    (* Ask Mike Shulman how he thought of the next step, but I think it
       goes like this: we really want [happly_dep p] to appear, so we stick
       it in and keep fiddling until it works. *)
    path_via (happly_dep p x # H x).
    (* The uninteresting subgoal is disposed of with [trans_map]. *)
    now (apply @map_trans with (f := fun h : forall x' : X, P x' => h x)).
    (* And the interesting one with [strong_funext_dep_compute]. *)
    now rewrite (strong_funext_dep_compute P (strong_funext_dep X P)) with
      (f := eta_dep h) (g := h) (p := fun x' : X => idpath (h x')).
    (* The other half of the proof is much easier. *)
    intros f.
    apply funext_dep.
    intro x.
    unfold ac, acinv; destruct (f x).
    apply idpath.
  Defined.
End AxiomOfChoiceEquiv.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Construction.Product.
Require Import Category.Construction.Opposite.
Require Import Category.Instance.Fun.
Require Import Category.Instance.Sets.

Generalizable All Variables.

(* Bifunctors can be curried:

  C × D ⟶ E --> C ⟶ [D, E] ~~~ (C, D) → E --> C → D → E

  Where ~~~ should be read as "Morally equivalent to".

  Note: We do not need to define Bifunctors as a separate class, since they
  can be derived from functors mapping to a category of functors. So in the
  following two definitions, [P] is effectively our bifunctor.

  The trick to [bimap] is that both the [Functor] instances we need (for
  [fmap] and [fmap1]), and the [Natural] instance, can be found in the
  category of functors we're mapping to by applying [P]. *)

Program Definition Hom `(C : Category) : C^op ∏ C ⟶ Sets := {|
  fobj := fun p => {| carrier   := @hom C (fst p) (snd p)
                    ; is_setoid := @homset (C) (fst p) (snd p) |};
  fmap := fun x y (f : x ~{C^op ∏ C}~> y) =>
            {| morphism := fun g => snd f ∘ g ∘ fst f |}
|}.
Next Obligation. now rewrite !comp_assoc. Qed.

Program Definition Curried_Hom `(C : Category) : C^op ⟶ [C, Sets] := {|
  fobj := fun x => {|
    fobj := fun y => {| carrier := @hom C x y
                      ; is_setoid := @homset C x y |};
    fmap := fun y z (f : y ~{C}~> z) =>
              {| morphism := fun (g : x ~{C}~> y) =>
                               (f ∘ g) : x ~{C}~> z |}
  |};
  fmap := fun x y (f : x ~{C^op}~> y) => {|
    transform := fun _ => {| morphism := fun g => g ∘ op f |}
  |}
|}.
Next Obligation.
  simpl; intros.
  unfold op.
  apply comp_assoc.
Qed.

Coercion Curried_Hom : Category >-> Functor.

Notation "[Hom A , ─]" := (@Curried_Hom _ A) : functor_scope.

#[export] Instance Yoneda_Faithful (C : Category) : Faithful (Curried_Hom C).
Proof.
  constructor.
  intros c c' f g same_nat_iso.
  simpl in same_nat_iso.
  specialize same_nat_iso with c id. now rewrite 2 id_left in same_nat_iso.
Qed.

#[export] Instance Yoneda_Full (C : Category) : Full (Curried_Hom C).
Proof.
  unshelve econstructor; simpl in *.
  - exact (fun c d f => f c id).
  - abstract(auto).
  - abstract(intros c; simpl; now autorewrite with categories).
  - abstract(intros; destruct f as [ftrans fnat ?]; simpl in *;
             rewrite <- (id_right (g x id)), <- fnat at 1; reflexivity).
  - abstract(intros x y [Ftrans Fnat ?] c f; simpl in *;
    unfold op;
    now rewrite Fnat, id_right).
Defined.

Program Definition CoHom_Alt `(C : Category) : C ∏ C^op ⟶ Sets :=
  Hom C ◯ Swap.

Program Definition CoHom `(C : Category) : C ∏ C^op ⟶ Sets := {|
  fobj := fun p => {| carrier   := @hom (C^op) (fst p) (snd p)
                    ; is_setoid := @homset (C^op) (fst p) (snd p) |};
  fmap := fun x y (f : x ~{C ∏ C^op}~> y) =>
    {| morphism := fun g => snd f ∘ g ∘ fst f |}
|}.

Program Definition Curried_CoHom `(C : Category) : C ⟶ [C^op, Sets] := {|
  fobj := fun x => {|
    fobj := fun y => {| carrier := @hom (C^op) x y
                      ; is_setoid := @homset (C^op) x y |};
    fmap := fun y z (f : y ~{C^op}~> z) =>
              {| morphism := fun (g : x ~{C^op}~> y) =>
                               (f ∘ g) : x ~{C^op}~> z |}
  |};
  fmap := fun x y (f : x ~{C}~> y) => {|
    transform := fun _ => {| morphism := fun g => g ∘ op f |}
  |}
|}.
Next Obligation.
  simpl; intros.
  symmetry.
  now rewrite !comp_assoc.
Qed.

Notation "[Hom ─ , A ]" := (@Curried_CoHom _ A) : functor_scope.


Require Export D.

(** **** Problem #7 : 2 stars (split) *)
(** The function [split] is the right inverse of combine: it takes a
    programing languages, this function is called [unzip].

    Uncomment the material below and fill in the definition of
    [split].  Make sure it passes the given unit tests. *)

Fixpoint add_prod {X Y : Type} (p : X * Y) (pl : list X * list Y) : list X * list Y
  := (cons (fst p) (fst pl), cons (snd p) (snd pl)).

Fixpoint split {X Y : Type} (l : list (X*Y)) : (list X) * (list Y) :=
  match l with
  | [] => ([], [])
  | h :: t => add_prod h (split t)
  end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof. reflexivity. Qed.

Check @map.
Print map.

Theorem split_map: forall X Y (l: list (X*Y)),
   fst (split l) = map fst l.
Proof.
  intros X Y l. induction l as [| (a, b)].
  - reflexivity.
  - simpl. rewrite -> IHl. reflexivity.
Qed.