(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(** ** Bitwise operations on nat *)

Require Import Arith Nat Omega List Bool Setoid.
Require Import utils_tac utils_list utils_nat bool_list gcd sums power_decomp.

Set Implicit Arguments.

Local Notation power := (mscal mult 1).
Local Notation "∑" := (msum plus 0).

Local Reserved Notation "x ≲ y" (at level 70, no associativity).

(* if n and m are written in binary, LSB first:
       n = n0 n1 n2 ...
       m = m0 m1 m2 ...
    then n ≲ m means forall any i, n[i] <= m[i] *)

Inductive binary_le : nat -> nat -> Prop :=
 | in_ble_0 : forall n, 0 ≲ n
 | in_ble_1 : forall n m, rem n 2 <= rem m 2 -> div n 2 ≲ div m 2 -> n ≲ m
where "x ≲ y" := (binary_le x y).

Local Infix "≲" := binary_le (at level 70, no associativity).

Fact binary_le_inv n m : n ≲ m -> n = 0 \/ div n 2 ≲ div m 2 /\ rem n 2 <= rem m 2.
(* Goal: forall _ : binary_le n m, or (@eq nat n O) (and (binary_le (div n (S (S O))) (div m (S (S O)))) (le (rem n (S (S O))) (rem m (S (S O))))) *)
Proof. inversion 1; auto. Qed.

Fact binary_le_refl x : x ≲ x.
Proof.
(* Goal: binary_le x x *)
  induction on x as IH with measure x.
(* Goal: binary_le x x *)
  destruct (eq_nat_dec x 0).
  + subst; constructor.
  + constructor 2; auto.
(* Goal: binary_le (div x (S (S O))) (div x (S (S O))) *)
    apply IH, div_by_p_lt; auto.
Qed.

Fact binary_le_le x y : x ≲ y -> x <= y.
Proof.
(* Goal: forall _ : binary_le x y, le x y *)
  induction 1 as [ n | n m H1 H2 IH2 ]; try omega.
(* Goal: le n m *)
  rewrite (div_rem_spec1 n 2), (div_rem_spec1 m 2); omega.
Qed.

Fact binary_le_zero_inv n : n ≲ 0 -> n = 0.
Proof. intros H; apply binary_le_le in H; omega. Qed.

Fact binary_le_zero n : 0 ≲ n.
Proof. constructor. Qed.

Hint Resolve binary_le_zero binary_le_refl.

Local Notation "⟘" := false.
Local Notation "⟙" := true.

Definition bool2nat x := 
  match x with 
    | ⟘ => 0 
    | ⟙ => 1 
  end.
 
Fact rem_2_bool2nat b n : rem (bool2nat b+2*n) 2 = bool2nat b.
Proof. 
(* Goal: @eq nat (div (add (bool2nat b) (mul (S (S O)) n)) (S (S O))) n *)
  destruct b; unfold bool2nat.
  + apply rem_2_fix_2.
  + apply rem_2_fix_1.
Qed.

Fact div_2_bool2nat b n : div (bool2nat b+2*n) 2 = n.
Proof. 
(* Goal: @eq nat (div (add (bool2nat b) (mul (S (S O)) n)) (S (S O))) n *)
  destruct b; unfold bool2nat.
  + apply div_2_fix_2.
  + apply div_2_fix_1.
Qed.

Definition nat2bool x := 
  match x with 
    | 0 => ⟘ 
    | _ => ⟙ 
  end.

Fact bool2nat2bool : forall x, x < 2 -> bool2nat (nat2bool x) = x.
Proof. intros [ | [ | ] ] ?; simpl; omega. Qed.

Fact nat2bool2nat : forall x, nat2bool (bool2nat x) = x.
Proof. intros []; auto. Qed.

Local Hint Resolve power2_gt_0.

Local Notation lb := (list bool).

Local Infix "⪦" := leb (at level 70, no associativity).
Local Infix "⪯" := lb_mask (at level 70, no associativity).
Local Infix "≂" := lb_mask_equiv (at level 70, no associativity).
Local Infix "⟂" := lb_ortho (at level 70, no associativity).
Local Infix "↓" := lb_meet (at level 40, left associativity).
Local Infix "↑" := lb_join (at level 41, left associativity).

Local Reserved Notation "'⟦' l '⟧'".
Local Reserved Notation "'⟬' x '⟭'".

(* Section lb_nat. *)

  Fixpoint lb_nat (l : lb) :=
    match l with
      | nil    => 0
      | x :: l => bool2nat x + 2*⟦l⟧
    end
  where "⟦ l ⟧" := (lb_nat l).

  Fact lb_nat_fix_0 : ⟦nil⟧ = 0.                      Proof. trivial. Qed.
  Fact lb_nat_fix_1 l : ⟦⟘::l⟧ = 2*⟦l⟧.               Proof. trivial. Qed.
  Fact lb_nat_fix_2 l : ⟦⟙::l⟧ = 1+2*⟦l⟧.             Proof. trivial. Qed.
  Fact lb_nat_fix_3 x l : ⟦x::l⟧ = bool2nat x+2*⟦l⟧.  Proof. trivial. Qed.

  Fact lb_nat_app l m : lb_nat (l++m) = lb_nat l + (power (length l) 2)*(lb_nat m).
  Proof.
(* Goal: @eq nat (lb_nat (@app bool l m)) (add (lb_nat l) (mul (@mscal nat mul (S O) (@length bool l) (S (S O))) (lb_nat m))) *)
    induction l as [ | x l IHl ].
    + rewrite lb_nat_fix_0; simpl; omega.
    + simpl app; do 2 rewrite lb_nat_fix_3.
(* Goal: @eq nat (add (bool2nat x) (mul (S (S O)) (lb_nat (@app bool l m)))) (add (add (bool2nat x) (mul (S (S O)) (lb_nat l))) (mul (@mscal nat mul (S O) (@length bool (@cons bool x l)) (S (S O))) (lb_nat m))) *)
      simpl length; rewrite power_S.
(* Goal: @eq nat (add (bool2nat x) (mul (S (S O)) (lb_nat (@app bool l m)))) (add (add (bool2nat x) (mul (S (S O)) (lb_nat l))) (mul (mul (S (S O)) (@mscal nat mul (S O) (@length bool l) (S (S O)))) (lb_nat m))) *)
      rewrite IHl; ring.
  Qed.

  Fact lb_mask_binary_le l m : l ⪯ m -> ⟦l⟧ ≲ ⟦m⟧.
  Proof.
(* Goal: forall _ : lb_mask l m, binary_le (lb_nat l) (lb_nat m) *)
    induction 1 as [ l | l H1 IH1 | x y l m H1 H2 IH2 ].
    - constructor 1.
    - apply binary_le_zero_inv in IH1.
(* Goal: lb_ortho (@cons bool x l) (@nil bool) *)
      simpl; rewrite IH1; constructor.
    - do 2 rewrite lb_nat_fix_3.
(* Goal: binary_le (add (bool2nat x) (mul (S (S O)) (lb_nat l))) (add (bool2nat y) (mul (S (S O)) (lb_nat m))) *)
      constructor 2.
      * do 2 rewrite rem_2_bool2nat.
(* Goal: le (bool2nat x) (bool2nat y) *)
        revert x y H1; intros [] []; simpl; auto; discriminate.
      * do 2 rewrite div_2_bool2nat; auto.
  Qed.

  Section nat_lb_def.

    Inductive g_nlb : nat -> lb -> Prop :=
      | in_gnlb_0 : g_nlb 0 nil
      | in_gnlb_1 : forall n l, n <> 0 -> rem n 2 = 0 -> g_nlb (div n 2) l -> g_nlb n (⟘::l)
      | in_gnlb_2 : forall n l, n <> 0 -> rem n 2 = 1 -> g_nlb (div n 2) l -> g_nlb n (⟙::l).
   
    Fact g_nlb_fun n l1 l2 : g_nlb n l1 -> g_nlb n l2 -> l1 = l2.
    Proof.
(* Goal: forall (_ : g_nlb n l1) (_ : g_nlb n l2), @eq (list bool) l1 l2 *)
      intros H1 H2; revert H1 l2 H2.
(* Goal: forall (_ : g_nlb n l1) (l2 : list bool) (_ : g_nlb n l2), @eq (list bool) l1 l2 *)
      induction 1; inversion 1; auto; try omega; f_equal; auto.
    Qed.

    Let nat_lb_full n : { l | g_nlb n l }.
    Proof.
(* Goal: @eq nat (lb_nat (nat_lb n)) n *)
      induction on n as IHn with measure n.
(* Goal: @eq nat (lb_nat (nat_lb n)) n *)
      destruct (eq_nat_dec n 0) as [ | Hn ].
      + exists nil; subst; constructor.
      + destruct (IHn (div n 2)) as (l & Hl).
        * apply div_by_p_lt; omega.
        * case_eq (rem n 2).
          - intro; exists (⟘::l); constructor; auto.
          - intro; exists (⟙::l); constructor; auto.
(* Goal: @eq nat (rem n (S (S O))) (S O) *)
            generalize (rem_2_lt n); omega.
    Qed.

    Definition nat_lb n := proj1_sig (nat_lb_full n).
  
    Fact nat_lb_spec n : g_nlb n (nat_lb n).
    Proof. apply (proj2_sig (nat_lb_full _)). Qed.

  End nat_lb_def.

  Local Notation "⟬ n ⟭" := (nat_lb n).

  Hint Resolve nat_lb_spec.

  Fact nat_lb_fix_0 : ⟬ 0⟭ = nil.
  Proof. apply g_nlb_fun with 0; auto; constructor. Qed.

  Fact nat_lb_fix_1 n : n <> 0 -> ⟬ 2*n⟭ = ⟘::⟬ n⟭ .
  Proof.
(* Goal: forall _ : not (@eq nat n O), @eq (list bool) (nat_lb (mul (S (S O)) n)) (@cons bool false (nat_lb n)) *)
    intros Hn. 
    apply g_nlb_fun with (2*n); auto.
(* Goal: g_nlb (add (S O) (mul (S (S O)) n)) (@cons bool true (nat_lb n)) *)
    constructor; auto; try omega.
    + apply rem_2_fix_1.
    + rewrite div_2_fix_1; auto.
  Qed.

  Fact nat_lb_fix_2 n : ⟬1+2*n⟭ = ⟙::⟬ n⟭ .
  Proof.
    apply g_nlb_fun with (1+2*n); auto.
(* Goal: g_nlb (add (S O) (mul (S (S O)) n)) (@cons bool true (nat_lb n)) *)
    constructor; auto; try omega.
    + apply rem_2_fix_2.
    + rewrite div_2_fix_2; auto.
  Qed.

  Fact nat_lb_1 : ⟬ 1⟭ = ⟙::nil.
  Proof.
    change 1 with (1+2*0).
(* Goal: @eq (list bool) (nat_lb (add (S O) (mul (S (S O)) O))) (@cons bool true (@nil bool)) *)
    rewrite nat_lb_fix_2, nat_lb_fix_0.
(* Goal: @eq (list bool) (@cons bool true (@nil bool)) (@cons bool true (@nil bool)) *)
    trivial.
  Qed.

  Fact lb_nat_lb n : ⟦⟬ n ⟭⟧ = n.
  Proof.
(* Goal: @eq nat (lb_nat (nat_lb n)) n *)
    induction on n as IHn with measure n.
(* Goal: @eq nat (lb_nat (nat_lb n)) n *)
    destruct (eq_nat_dec n 0) as [ | Hn ].
    + subst; rewrite nat_lb_fix_0; auto.
    + destruct (euclid_2 n) as (q & [ Hq | Hq ]); subst n.
      * rewrite nat_lb_fix_1; try omega.
(* Goal: @eq nat (lb_nat (@cons bool false (nat_lb q))) (mul (S (S O)) q) *)
        rewrite lb_nat_fix_1; f_equal.
(* Goal: @eq nat (lb_nat (nat_lb q)) q *)
        apply IHn; omega.
      * rewrite nat_lb_fix_2; try omega.
(* Goal: @eq nat (lb_nat (@cons bool true (nat_lb q))) (add (S O) (mul (S (S O)) q)) *)
        rewrite lb_nat_fix_2; do 2 f_equal.
(* Goal: @eq nat (lb_nat (nat_lb q)) q *)
        apply IHn; omega.
  Qed.

  Fact nat_lb_length x n : x < power n 2 -> length ⟬ x ⟭ <= n.
  Proof.
(* Goal: forall _ : lt x (@mscal nat mul (S O) n (S (S O))), le (@length bool (nat_lb x)) n *)
    revert x; induction n as [ | n IHn ]; intros x.
    + rewrite power_0; intro; cutrewrite (x=0); try omega.
(* Goal: le (@length bool (nat_lb O)) O *)
      rewrite nat_lb_fix_0; simpl; omega.
    + rewrite power_S.
(* Goal: forall _ : lt x (mul (S (S O)) (@mscal nat mul (S O) n (S (S O)))), le (@length bool (nat_lb x)) (S n) *)
      destruct (euclid_2 x) as (y & [ H | H ]); intros Hx; subst.
      * destruct y.
        - simpl; rewrite nat_lb_fix_0;simpl; omega.
        - rewrite nat_lb_fix_1; try omega.
(* Goal: le (@length bool (@cons bool false (nat_lb (S y)))) (S n) *)
          simpl; apply le_n_S, IHn; omega.
      * rewrite nat_lb_fix_2; simpl.
(* Goal: le (S (@length bool (nat_lb y))) (S n) *)
        apply le_n_S, IHn; omega.
  Qed.

  Fact binary_le_lb_mask x y : x ≲ y -> ⟬ x ⟭ ⪯ ⟬ y ⟭ . 
  Proof.
(* Goal: forall _ : binary_le x y, lb_mask (nat_lb x) (nat_lb y) *)
    induction 1 as [ n | n m H1 H2 IH2 ].
    + rewrite nat_lb_fix_0; constructor.
    + destruct (eq_nat_dec n 0) as [ Hn | Hn ].
(* Goal: lb_ortho (@cons bool x l) (@nil bool) *)
      - subst; rewrite nat_lb_fix_0; constructor.
      - assert (n <= m) as Hmn.
(* Goal: forall (i : nat) (_ : lt i n), and (@eq nat (g i) (mul (h i) (@mscal nat mul (S O) (e i) r))) (binary_le (h i) (f i)) *)
(* Goal: @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m (@msum nat add O n (fun i : nat => mul (g i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
        { apply binary_le_le; constructor; auto. }
        destruct (euclid_2_div n) as (G1 & [ G2 | G2 ] );
(* Goal: le (S k) (S n) *)
        destruct (euclid_2_div m) as (G3 & [ G4 | G4 ] ); try omega.
        * rewrite G1, G2, G3, G4, Nat.add_0_l, Nat.add_0_l.
(* Goal: lb_mask (nat_lb (mul (S (S O)) (div n (S (S O))))) (nat_lb (mul (S (S O)) (div m (S (S O))))) *)
          do 2 (rewrite nat_lb_fix_1; [ | omega ]).
(* Goal: lb_mask (@cons bool true (nat_lb (div n (S (S O))))) (@cons bool true (nat_lb (div m (S (S O))))) *)
          constructor; auto.
        * rewrite G1, G2, G3, G4, Nat.add_0_l, nat_lb_fix_2.
(* Goal: lb_mask (nat_lb (mul (S (S O)) (div n (S (S O))))) (@cons bool true (nat_lb (div m (S (S O))))) *)
          rewrite nat_lb_fix_1; [ | omega ].
(* Goal: lb_mask (@cons bool true (nat_lb (div n (S (S O))))) (@cons bool true (nat_lb (div m (S (S O))))) *)
          constructor; auto.
        * rewrite G1, G2, G3, G4.
(* Goal: lb_mask (nat_lb (add (S O) (mul (S (S O)) (div n (S (S O)))))) (nat_lb (add (S O) (mul (S (S O)) (div m (S (S O)))))) *)
          do 2 rewrite nat_lb_fix_2.
(* Goal: lb_mask (@cons bool true (nat_lb (div n (S (S O))))) (@cons bool true (nat_lb (div m (S (S O))))) *)
          constructor; auto.
  Qed.

  Hint Resolve lb_mask_binary_le binary_le_lb_mask.

  Section lb_mask_nat.

    Let lb_mask_nat_1 l : ⟬ ⟦l⟧⟭  ⪯  l.
    Proof.
(* Goal: lb_mask l (nat_lb (lb_nat l)) *)
      induction l as [ | [|] l IHl ].
      + rewrite lb_nat_fix_0, nat_lb_fix_0; constructor.
      + rewrite lb_nat_fix_2, nat_lb_fix_2; constructor; auto.
      + rewrite lb_nat_fix_1.
(* Goal: lb_mask (@cons bool false l) (nat_lb (mul (S (S O)) (lb_nat l))) *)
        destruct (eq_nat_dec ⟦l⟧ 0) as [ Hl | Hl ]. 
(* Goal: lb_ortho (@cons bool x l) (@nil bool) *)
        - rewrite Hl; simpl; rewrite nat_lb_fix_0; constructor.
        - rewrite nat_lb_fix_1; auto; constructor; auto.
    Qed.

    Let lb_mask_nat_2 l : l ⪯  ⟬ ⟦l⟧⟭  .
    Proof.
(* Goal: lb_mask l (nat_lb (lb_nat l)) *)
      induction l as [ | [|] l IHl ].
      + constructor.
      + rewrite lb_nat_fix_2, nat_lb_fix_2; constructor; auto.
      + rewrite lb_nat_fix_1.
(* Goal: lb_mask (@cons bool false l) (nat_lb (mul (S (S O)) (lb_nat l))) *)
        destruct (eq_nat_dec ⟦l⟧ 0) as [ Hl | Hl ]. 
(* Goal: lb_ortho (@cons bool x l) (@nil bool) *)
        - rewrite Hl; simpl; rewrite nat_lb_fix_0; constructor.
(* Goal: lb_mask l (@nil bool) *)
          rewrite Hl, nat_lb_fix_0 in IHl; auto.
        - rewrite nat_lb_fix_1; auto; constructor; auto.
    Qed.

    Fact lb_mask_nat l : ⟬ ⟦l⟧⟭ ≂ l.
    Proof. split; auto. Qed.

  End lb_mask_nat.

  Definition nat_lb_nat := lb_mask_nat.

  (* We have a correspondance *)

  Lemma lb_mask_eq_binary_le l m : l ⪯ m <-> ⟦l⟧ ≲ ⟦m⟧.
  Proof.
(* Goal: iff (lb_mask l m) (binary_le (lb_nat l) (lb_nat m)) *)
    split; auto; intro.
    rewrite <- (lb_mask_nat l), <- (lb_mask_nat m); auto.
  Qed.

  Lemma binary_le_eq_lb_mask x y : x ≲ y <-> ⟬ x⟭  ⪯ ⟬ y⟭ .
  Proof.
(* Goal: and (@eq nat a (mul (nat_meet v b) (@mscal nat mul (S O) i r))) (binary_le (nat_meet v b) b) *)
    split; auto.
    intro; rewrite <- (lb_nat_lb x), <- (lb_nat_lb y); auto.
  Qed.

  Hint Resolve lb_mask_eq_binary_le binary_le_eq_lb_mask.

  Fact binary_le_trans x y z : x ≲ y -> y ≲ z -> x ≲ z.
  Proof.
(* Goal: forall (_ : binary_le x y) (_ : binary_le y z), binary_le x z *)
    do 3 rewrite binary_le_eq_lb_mask; apply lb_mask_trans.
  Qed.

  Fact lb_mask_equiv_equal l m : l ≂ m <-> ⟦l⟧ = ⟦m⟧.
  Proof.
(* Goal: iff (lb_mask_equiv l m) (@eq nat (lb_nat l) (lb_nat m)) *)
    unfold lb_mask_equiv.
(* Goal: iff (and (lb_mask l m) (lb_mask m l)) (@eq nat (lb_nat l) (lb_nat m)) *)
    do 2 rewrite lb_mask_eq_binary_le; split.
    + intros (? & ?); apply le_antisym; apply binary_le_le; auto.
    + intros H; rewrite H; split; auto. 
  Qed.

  Fact equal_lb_mask_equiv x y : x = y <-> ⟬ x⟭ ≂⟬ y⟭.
  Proof.
(* Goal: iff (@eq nat x y) (lb_mask_equiv (nat_lb x) (nat_lb y)) *)
    rewrite lb_mask_equiv_equal, lb_nat_lb, lb_nat_lb; tauto.
  Qed.

  Local Notation lbeq := lb_mask_equiv (only parsing).

  Add Parametric Morphism: (lb_nat) with signature (lbeq) ==> (eq) as lb_nat_eq.
  Proof. apply lb_mask_equiv_equal. Qed.

(*
  Hint Resolve dio_rel_binomial dio_rel_remainder.

  Section binary_le_dio.

    Let ble_equiv x y : x ≲ y <-> exists b, b = binomial y x /\ 1 = rem b 2.
    Proof.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      rewrite binary_le_binomial; split; eauto.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      intros (? & ? & ?); subst; auto.
    Qed.

    Theorem binary_le_diophatine x y : 
             dio_expression x
          -> dio_expression y
          -> dio_rel (fun v => x v ≲ y v).
    Proof.
      intros. 
      apply dio_rel_equiv with (1 := fun v => ble_equiv (x v) (y v)).
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      dio_rel_auto.
    Qed.

  End binary_le_dio.

  Definition lb_dio (R : (nat -> lb) -> Prop) := { f | forall v, df_pred f (fun n => ⟦v n⟧) <-> R v }.

  Theorem lb_mask_diophantine x y : lb_dio (fun v => v x ⪯  v y).
  Proof.
    destruct (binary_le_diophatine (dio_expr_var x) (dio_expr_var y)) as (f & Hf).
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    exists f; intros v; rewrite Hf, lb_mask_eq_binary_le; tauto.
  Qed.

*)

  Definition bool_add_with_rem a b c : bool * bool :=
    match a, b, c with 
     | ⟘, ⟘, ⟘ => (⟘,⟘)
     | ⟘, ⟘, ⟙ => (⟘,⟙)
     | ⟘, ⟙, ⟘ => (⟘,⟙)
     | ⟘, ⟙, ⟙ => (⟙,⟘)
     | ⟙, ⟘, ⟘ => (⟘,⟙)
     | ⟙, ⟘, ⟙ => (⟙,⟘)
     | ⟙, ⟙, ⟘ => (⟙,⟘)
     | ⟙, ⟙, ⟙ => (⟙,⟙)
    end.

  Notation bin_add := bool_add_with_rem.
  
  Fact bin_add_eq_00x x : bin_add ⟘ ⟘  x = (⟘,x).
  Proof. destruct x; auto. Qed.

  Fact bin_add_eq_0x0 x : bin_add ⟘ x ⟘  = (⟘,x).
  Proof. destruct x; auto. Qed.

  Fixpoint lb_succ a l :=
    match l with
      | nil  => a::nil
      | x::l => let (r,z) := bin_add ⟘ a x in z::lb_succ r l
    end.

  Fact lb_succ_spec_0 l : ⟦lb_succ ⟘ l⟧ = ⟦l⟧.
  Proof.
(* Goal: @eq nat (lb_nat (lb_succ false l)) (lb_nat l) *)
    induction l as [ | [] ]; simpl; auto.
  Qed.

  Fact lb_succ_spec_1 l : ⟦lb_succ ⟙ l⟧ = S ⟦l⟧.
  Proof.
(* Goal: @eq nat (lb_nat (lb_succ true l)) (S (lb_nat l)) *)
    induction l as [ | [] ]; auto.
    + simpl lb_succ; rewrite lb_nat_fix_2.
(* Goal: @eq nat (lb_nat (@cons bool false (lb_succ true l))) (S (add (S O) (mul (S (S O)) (lb_nat l)))) *)
      rewrite lb_nat_fix_1, IHl; omega.
    + simpl lb_succ; rewrite lb_nat_fix_2.
(* Goal: @eq nat (add (S O) (mul (S (S O)) (lb_nat (lb_succ false l)))) (S (lb_nat (@cons bool false l))) *)
      rewrite lb_nat_fix_1, lb_succ_spec_0; omega.
  Qed.

  Fact lb_succ_spec a l : ⟦lb_succ a l⟧ = bool2nat a + ⟦l⟧.
  Proof.
(* Goal: @eq nat (lb_nat (lb_succ a l)) (add (bool2nat a) (lb_nat l)) *)
    destruct a.
    + rewrite lb_succ_spec_1; auto.
    + rewrite lb_succ_spec_0; auto.
  Qed.

  Fact lb_succ_bot l : lb_succ ⟘ l ≂ l.
  Proof.
(* Goal: lb_mask_equiv (lb_succ false l) l *)
    induction l as [ | x ]; simpl; auto.
    + split; repeat constructor.
    + destruct x; rewrite IHl; auto.
  Qed.

  Fixpoint lb_plus a l m :=
    match l, m with
      | nil,   m   => lb_succ a m
      | l,    nil  => lb_succ a l
      | x::l, y::m => let (r,z) := bin_add a x y in z::lb_plus r l m
    end.

  Fact lb_plus_fix_0 a l : lb_plus a nil l = lb_succ a l.
  Proof. auto. Qed.

  Fact lb_plus_fix_1 a l : lb_plus a l nil = lb_succ a l.
  Proof. destruct l; auto. Qed.

  Fact lb_plus_fix_2 a x y l m : lb_plus a (x::l) (y::m) = let (r,z) := bin_add a x y in z::lb_plus r l m.
  Proof. auto. Qed.

  Fact lb_plus_spec a l m : ⟦lb_plus a l m⟧ = bool2nat a + ⟦l⟧ + ⟦m⟧.
  Proof.
(* Goal: @eq nat (lb_nat (lb_plus a l m)) (add (add (bool2nat a) (lb_nat l)) (lb_nat m)) *)
    revert a m; induction l as [ | x l IHl ]; intros a m.
    + rewrite lb_plus_fix_0, lb_succ_spec, lb_nat_fix_0; omega.
    + destruct m as [ | y m ].
      * rewrite lb_plus_fix_1, lb_succ_spec, lb_nat_fix_0; omega.
      * rewrite lb_plus_fix_2, lb_nat_fix_3, lb_nat_fix_3.
(* Goal: @eq nat (lb_nat (let (r, z) := bool_add_with_rem a x y in @cons bool z (lb_plus r l m))) (add (add (bool2nat a) (add (bool2nat x) (mul (S (S O)) (lb_nat l)))) (add (bool2nat y) (mul (S (S O)) (lb_nat m)))) *)
        destruct a; destruct x; destruct y; simpl; rewrite IHl; simpl; omega.
  Qed.

  Local Infix "⊕" := (lb_plus ⟘ ) (at level 41, left associativity). 

  Fact lb_plus_spec_0 l m : ⟦l⊕m⟧ = ⟦l⟧ + ⟦m⟧.
  Proof. rewrite lb_plus_spec; simpl; auto. Qed.

  Add Parametric Morphism a: (lb_plus a) with signature (lbeq) ==> (lbeq) ==> (lbeq) as lb_plus_eq.
  Proof.
(* Goal: forall (x y : list bool) (_ : lb_mask_equiv x y) (x0 y0 : list bool) (_ : lb_mask_equiv x0 y0), lb_mask_equiv (lb_plus a x x0) (lb_plus a y y0) *)
    intros x1 y1 E1 x2 y2 E2; revert E1 E2.
(* Goal: forall (_ : lb_mask_equiv x1 y1) (_ : lb_mask_equiv x2 y2), lb_mask_equiv (lb_plus a x1 x2) (lb_plus a y1 y2) *)
    do 3 rewrite lb_mask_equiv_equal.
(* Goal: forall (_ : @eq nat (lb_nat x1) (lb_nat y1)) (_ : @eq nat (lb_nat x2) (lb_nat y2)), @eq nat (lb_nat (lb_plus a x1 x2)) (lb_nat (lb_plus a y1 y2)) *)
    do 2 rewrite lb_plus_spec.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    intros; f_equal; auto.
  Qed.

  Fact lb_ortho_plus l m : l ⟂ m <-> l ⪯ l⊕m.
  Proof.
(* Goal: iff (@eq nat (@msum nat add O n (fun i : nat => mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (e i) r))) (@msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (f i) (g i)) *)
    split.
    + induction 1 as [ l | l | x y l m [ H1 | H1 ] H2 IH2 ].
(* Goal: lb_ortho (@cons bool x l) (@nil bool) *)
      * constructor. 
      * rewrite lb_plus_fix_1.
(* Goal: lb_mask l (lb_succ false l) *)
        rewrite lb_mask_eq_binary_le, lb_succ_spec; simpl.
        rewrite <- lb_mask_eq_binary_le; apply lb_mask_refl.
      * rewrite lb_plus_fix_2.
(* Goal: lb_mask (@cons bool x l) (let (r, z) := bool_add_with_rem false x y in @cons bool z (lb_plus r l m)) *)
        subst x; rewrite bin_add_eq_00x.
(* Goal: lb_mask (@cons bool true (nat_lb (div n (S (S O))))) (@cons bool true (nat_lb (div m (S (S O))))) *)
        destruct y; constructor; auto.
      * rewrite lb_plus_fix_2.
(* Goal: lb_mask (@cons bool x l) (let (r, z) := bool_add_with_rem false x y in @cons bool z (lb_plus r l m)) *)
        subst y; rewrite bin_add_eq_0x0.
(* Goal: lb_mask (@cons bool true (nat_lb (div n (S (S O))))) (@cons bool true (nat_lb (div m (S (S O))))) *)
        destruct x; constructor; auto.
    + revert m; induction l as [ | x l IHl ].
(* Goal: lb_ortho (@cons bool x l) (@nil bool) *)
      * intros; constructor.
      * intros [ | y m ] H.
(* Goal: lb_ortho (@cons bool x l) (@nil bool) *)
        - constructor.
        - rewrite lb_plus_fix_2 in H.
          destruct x; destruct y; simpl in H; try (apply lb_mask_inv_cons_cons in H; tauto);
(* Goal: lb_mask (@cons bool true (nat_lb (div n (S (S O))))) (@cons bool true (nat_lb (div m (S (S O))))) *)
            apply lb_mask_inv_cons, proj2 in H; constructor; auto.
  Qed.

(*

  Theorem lb_ortho_diophantine x y : lb_dio (fun v => v x ⟂ v y).
  Proof.
    destruct (@lb_mask_diophantine 0 1) as (f & Hf).
    exists (df_subst (fun n => match n with 0 => de_var x | _ => de_add (de_var x) (de_var y) end) f).
    intros v; rewrite df_pred_subst.
    set (w z := match z with 0 => v x | _ => lb_plus ⟘  (v x) (v y) end).
    rewrite df_pred_ext with (ω := fun n => ⟦ w n ⟧).
    + rewrite Hf; unfold w; symmetry; apply lb_ortho_plus.
    + intros [ | ]; simpl; auto.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      rewrite lb_plus_spec_0; auto.
  Qed.

*)

  Fact lb_ortho_plus_join x y : x ⟂ y -> x⊕y ≂ x↑y.
  Proof.
(* Goal: forall _ : lb_ortho x y, lb_mask_equiv (lb_plus false x y) (lb_join x y) *)
    induction 1 as [ m | l | x y l m H1 H2 IH2 ].
    + rewrite lb_plus_fix_0, lb_join_right; apply lb_succ_bot.
    + rewrite lb_plus_fix_1, lb_join_left; apply lb_succ_bot.
    + rewrite lb_join_cons.
(* Goal: @eq nat (lb_nat (lb_join (nat_lb (mul x (@mscal nat mul (S O) q (S (S O))))) (nat_lb (mul y (@mscal nat mul (S O) q (S (S O))))))) (lb_nat (lb_join (lb_shift q (nat_lb x)) (lb_shift q (nat_lb y)))) *)
      apply lb_mask_equiv_equal.
(* Goal: @eq nat (add (add (bool2nat x) (mul (S (S O)) (lb_nat l))) (add (bool2nat y) (mul (S (S O)) (lb_nat m)))) (add (bool2nat (orb x y)) (mul (S (S O)) (lb_nat (lb_plus false l m)))) *)
      rewrite lb_plus_spec_0.
(* Goal: @eq nat (add (lb_nat (@cons bool x l)) (lb_nat (@cons bool y m))) (lb_nat (@cons bool (orb x y) (lb_join l m))) *)
      do 3 rewrite lb_nat_fix_3.
(* Goal: @eq nat (add (add (bool2nat x) (mul (S (S O)) (lb_nat l))) (add (bool2nat y) (mul (S (S O)) (lb_nat m)))) (add (bool2nat (orb x y)) (mul (S (S O)) (lb_nat (lb_join l m)))) *)
      rewrite lb_mask_equiv_equal in IH2.
      rewrite <- IH2.
(* Goal: @eq nat (add (add (bool2nat x) (mul (S (S O)) (lb_nat l))) (add (bool2nat y) (mul (S (S O)) (lb_nat m)))) (add (bool2nat (orb x y)) (mul (S (S O)) (lb_nat (lb_plus false l m)))) *)
      rewrite lb_plus_spec_0.
(* Goal: @eq nat (add (add (bool2nat x) (mul (S (S O)) (lb_nat l))) (add (bool2nat y) (mul (S (S O)) (lb_nat m)))) (add (bool2nat (orb x y)) (mul (S (S O)) (add (lb_nat l) (lb_nat m)))) *)
      destruct x; destruct y; simpl; try ring.
(* Goal: @eq nat (S (add (add (lb_nat l) (add (lb_nat l) O)) (S (add (lb_nat m) (add (lb_nat m) O))))) (S (add (add (lb_nat l) (lb_nat m)) (add (add (lb_nat l) (lb_nat m)) O))) *)
      destruct H1; discriminate.
  Qed.

  Fact lb_ortho_plus_id a x y : a ⟂ x -> a ⟂ y -> x ⟂ y <-> (a⊕x)↓(a⊕y) ≂ a.
  Proof.
(* Goal: forall (_ : lt r1 (S (S O))) (_ : lt r2 (S (S O))), @eq nat (nat_meet (add r1 (mul (S (S O)) d1)) (add r2 (mul (S (S O)) d2))) (add (nat_meet r1 r2) (mul (S (S O)) (nat_meet d1 d2))) *)
    intros H1 H2. 
(* Goal: lb_mask_equiv a (lb_meet (lb_plus false a x) (lb_plus false a y)) *)
    do 2 (rewrite lb_ortho_plus_join; auto). 
    rewrite <- lb_join_meet_distr, lb_ortho_meet_nil.
(* Goal: iff (@eq nat (@msum nat add O n (fun i : nat => mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (e i) r))) (@msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (f i) (g i)) *)
    split.
    + intros H3; rewrite H3, lb_join_left; auto.
    + intros H3; apply lb_ortho_mask_nil with a.
      * revert H1; apply lb_ortho_anti; auto.
      * rewrite <- H3, lb_join_comm; auto.
  Qed.

  (* A purely Boolean algebraic proof *)

  Fact lb_minus_plus a b : a ⪯ b -> exists x, b ≂ a⊕x /\ a ⪯  a⊕x.
  Proof.
(* Goal: forall _ : binary_le a (mul b (@mscal nat mul (S O) i r)), @sig nat (fun a' : nat => and (@eq nat a (mul a' (@mscal nat mul (S O) i r))) (binary_le a' b)) *)
    intros H.
(* Goal: @ex (list bool) (fun x : list bool => and (lb_mask_equiv b (lb_plus false a x)) (lb_mask a (lb_plus false a x))) *)
    destruct lb_minus with (1 := H) as (x & H1 & H2).
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    exists x; rewrite lb_ortho_plus_join; auto.
  Qed.

  (* A diophantine representation of bitwise and *)
 
  Theorem lb_meet_dio a b c : a ≂ b↓c <-> exists x y, b ≂ a⊕x /\ c ≂ a⊕y /\ a ⪯  a⊕x /\ a ⪯  a⊕y /\ x ⪯  x⊕y.
  Proof.
(* Goal: iff (@eq nat (@msum nat add O n (fun i : nat => mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (e i) r))) (@msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (f i) (g i)) *)
    split.
    + intros H.
(* Goal: @ex (list bool) (fun x : list bool => @ex (list bool) (fun y : list bool => and (lb_mask_equiv b (lb_plus false a x)) (and (lb_mask_equiv c (lb_plus false a y)) (and (lb_mask a (lb_plus false a x)) (and (lb_mask a (lb_plus false a y)) (lb_mask x (lb_plus false x y))))))) *)
      destruct (@lb_minus_plus a b) as (x & H1 & H2).
(* Goal: forall (i : nat) (_ : lt i n), and (@eq nat (g i) (mul (h i) (@mscal nat mul (S O) (e i) r))) (binary_le (h i) (f i)) *)
(* Goal: @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m (@msum nat add O n (fun i : nat => mul (g i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
      { rewrite H; auto. }
(* Goal: @ex (list bool) (fun x : list bool => @ex (list bool) (fun y : list bool => and (lb_mask_equiv b (lb_plus false a x)) (and (lb_mask_equiv c (lb_plus false a y)) (and (lb_mask a (lb_plus false a x)) (and (lb_mask a (lb_plus false a y)) (lb_mask x (lb_plus false x y))))))) *)
      destruct (@lb_minus_plus a c) as (y & H3 & H4).
(* Goal: forall (i : nat) (_ : lt i n), and (@eq nat (g i) (mul (h i) (@mscal nat mul (S O) (e i) r))) (binary_le (h i) (f i)) *)
(* Goal: @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m (@msum nat add O n (fun i : nat => mul (g i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
      { rewrite H; auto. }
(* Goal: @ex (list bool) (fun x : list bool => @ex (list bool) (fun y : list bool => and (lb_mask_equiv b (lb_plus false a x)) (and (lb_mask_equiv c (lb_plus false a y)) (and (lb_mask a (lb_plus false a x)) (and (lb_mask a (lb_plus false a y)) (lb_mask x (lb_plus false x y))))))) *)
      exists x, y; repeat (split; auto).
      rewrite <- lb_ortho_plus in H2, H4 |- *.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      rewrite lb_ortho_plus_join in H1, H3; auto.
(* Goal: lb_ortho x y *)
      apply lb_ortho_meet_nil. 
(* Goal: lb_mask_equiv (lb_meet x y) (@nil bool) *)
      apply lb_ortho_mask_nil with (a := a).
      - revert H4; apply lb_ortho_anti; auto.
      - rewrite H, H1, H3.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
        apply lb_meet_mono; auto.
    + intros (x & y & H1 & H2 & H3 & H4 & H5).
      rewrite <- lb_ortho_plus in H3, H4, H5.
(* Goal: and (@eq nat (lb_nat (nat_lb b)) (lb_nat (lb_plus false (nat_lb a) (nat_lb x)))) (and (@eq nat (lb_nat (nat_lb c)) (lb_nat (lb_plus false (nat_lb a) (nat_lb y)))) (and (binary_le (lb_nat (nat_lb a)) (lb_nat (lb_plus false (nat_lb a) (nat_lb x)))) (and (binary_le (lb_nat (nat_lb a)) (lb_nat (lb_plus false (nat_lb a) (nat_lb y)))) (binary_le (lb_nat (nat_lb x)) (lb_nat (lb_plus false (nat_lb x) (nat_lb y))))))) *)
      rewrite H1, H2.
(* Goal: lb_mask_equiv a (lb_meet (lb_plus false a x) (lb_plus false a y)) *)
      do 2 (rewrite lb_ortho_plus_join; auto).
      rewrite <- lb_join_meet_distr. 
(* Goal: lb_mask_equiv a (lb_join a (lb_meet x y)) *)
      rewrite lb_ortho_meet_nil in H5.
(* Goal: lb_mask_equiv a (lb_join a (lb_meet x y)) *)
      rewrite H5; rew lb.
  Qed.

  (* A diophantine representation of bitwise or *)

  Fact lb_join_dio a b c : a ≂ b↑c <-> exists x, a ≂ b⊕x /\ b ⪯  b⊕x /\ x ⪯ c /\ c ⪯ a.
  Proof.
(* Goal: iff (@eq nat (@msum nat add O n (fun i : nat => mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (e i) r))) (@msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (f i) (g i)) *)
    split. 
    + intros H. 
      destruct (@lb_minus_plus b a) as (x & H1 & H2).
(* Goal: forall (i : nat) (_ : lt i n), and (@eq nat (g i) (mul (h i) (@mscal nat mul (S O) (e i) r))) (binary_le (h i) (f i)) *)
(* Goal: @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m (@msum nat add O n (fun i : nat => mul (g i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
      { rewrite H; auto. }
      exists x; repeat (split; auto).
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      2: rewrite H; auto.
      rewrite <- lb_ortho_plus in H2.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      rewrite  lb_ortho_plus_join in H1; auto.
      rewrite lb_ortho_meet_nil in H2.
      rewrite <- (lb_meet_join_idem x b), lb_join_comm.
      rewrite <- H1, H, lb_meet_join_distr, (lb_meet_comm _ b), H2.
      rew lb.
    + intros (x & H1 & H2 & H3 & H4).
      rewrite <- lb_ortho_plus in H2.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      rewrite lb_ortho_plus_join in H1; auto.
      rewrite lb_ortho_meet_nil in H2.
(* Goal: iff (@eq nat (@msum nat add O n (fun i : nat => mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (e i) r))) (@msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (f i) (g i)) *)
      split.
      * rewrite H1; apply lb_join_mono; auto.
      * apply lb_join_spec; auto; rewrite H1; auto.
  Qed.

(* End lb_nat. *)

  Fixpoint lb_bots n :=
    match n with 
      | 0   => nil
      | S n => ⟘ :: lb_bots n
    end.
      
  Definition lb_shift n l := lb_bots n ++ l.

  Fact lb_shift_0 l : lb_shift 0 l = l.
  Proof. auto. Qed.

  Fact lb_shift_S n l : lb_shift (S n) l = ⟘ :: lb_shift n l.
  Proof. auto. Qed.

  Fact lb_nat_shift n l : ⟦lb_shift n l⟧ = ⟦l⟧*power n 2.
  Proof.
(* Goal: @eq nat (lb_nat (lb_shift n l)) (mul (lb_nat l) (@mscal nat mul (S O) n (S (S O)))) *)
    unfold lb_shift.
(* Goal: @eq nat (lb_nat (@app bool (lb_bots n) l)) (mul (lb_nat l) (@mscal nat mul (S O) n (S (S O)))) *)
    induction n as [ | n IHn ]; simpl lb_bots.
    + rewrite power_0; simpl; ring.
    + simpl app; rewrite lb_nat_fix_1, IHn, power_S; ring.
  Qed.

  Fact lb_shift_meet n l m : lb_shift n (l↓m) = (lb_shift n l)↓(lb_shift n m).
  Proof.
(* Goal: @eq (list bool) (lb_shift n (lb_join l m)) (lb_join (lb_shift n l) (lb_shift n m)) *)
    induction n as [ | n IHn ].
    + repeat rewrite lb_shift_0; auto.
    + do 3 rewrite lb_shift_S.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      rewrite lb_meet_cons; f_equal; auto.
  Qed.

  Fact lb_shift_join n l m : lb_shift n (l↑m) = (lb_shift n l)↑(lb_shift n m).
  Proof.
(* Goal: @eq (list bool) (lb_shift n (lb_join l m)) (lb_join (lb_shift n l) (lb_shift n m)) *)
    induction n as [ | n IHn ].
    + repeat rewrite lb_shift_0; auto.
    + do 3 rewrite lb_shift_S.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      rewrite lb_join_cons; f_equal; auto.
  Qed.

  Fact lb_shift_ortho n l m : length l <= n -> l ⟂ lb_shift n m.
  Proof.
(* Goal: forall _ : le (@length bool l) n, lb_ortho l (lb_shift n m) *)
    revert n.
(* Goal: forall (n : nat) (_ : le (@length bool l) n), lb_ortho l (lb_shift n m) *)
    induction l as [ | x l IHl ]; intros [ | n ]; simpl; auto; try omega.
(* Goal: forall _ : le (S (@length bool l)) (S n), lb_ortho (@cons bool x l) (lb_shift (S n) m) *)
    intro; rewrite lb_shift_S; constructor; auto; apply IHl; omega.
  Qed.

  Fact lb_shift_ortho_meet n l m : length l <= n -> l ↓ lb_shift n m ≂ nil.
  Proof.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    intros; apply lb_ortho_meet_nil, lb_shift_ortho; auto.
  Qed.

  Fact nat_pow2_lb_shift n q : ⟬q*power n 2⟭ ≂ lb_shift n ⟬q⟭ .
  Proof.  
(* Goal: @eq nat (lb_nat (lb_join (nat_lb (mul x (@mscal nat mul (S O) q (S (S O))))) (nat_lb (mul y (@mscal nat mul (S O) q (S (S O))))))) (lb_nat (lb_join (lb_shift q (nat_lb x)) (lb_shift q (nat_lb y)))) *)
    apply lb_mask_equiv_equal.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    rewrite lb_nat_lb, lb_nat_shift, lb_nat_lb; auto.
  Qed.

  Fact nat_euclid_pow2_lb n r q : r < power n 2 -> ⟬r+q*power n 2⟭ ≂ ⟬r⟭ ↑lb_shift n ⟬q⟭ .
  Proof.
(* Goal: forall _ : binary_le a (mul b (@mscal nat mul (S O) i r)), @sig nat (fun a' : nat => and (@eq nat a (mul a' (@mscal nat mul (S O) i r))) (binary_le a' b)) *)
    intros H.
(* Goal: @eq nat (lb_nat (lb_join (nat_lb (mul x (@mscal nat mul (S O) q (S (S O))))) (nat_lb (mul y (@mscal nat mul (S O) q (S (S O))))))) (lb_nat (lb_join (lb_shift q (nat_lb x)) (lb_shift q (nat_lb y)))) *)
    apply lb_mask_equiv_equal.
    rewrite lb_nat_lb.
    rewrite <- lb_ortho_plus_join.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    2: apply lb_shift_ortho, nat_lb_length; auto.
    rewrite lb_plus_spec_0; f_equal.
    + rewrite lb_nat_lb; auto.
    + rewrite lb_nat_shift, lb_nat_lb; auto.
  Qed.

  Definition nat_meet n m := ⟦ ⟬n⟭↓⟬m⟭ ⟧.
  Local Infix "⇣" := nat_meet (at level 40, left associativity).

  Fact nat_meet_comm n m : n⇣m = m⇣n.
  Proof.
(* Goal: @eq nat (lb_nat (lb_join (nat_lb (mul x (@mscal nat mul (S O) q (S (S O))))) (nat_lb (mul y (@mscal nat mul (S O) q (S (S O))))))) (lb_nat (lb_join (lb_shift q (nat_lb x)) (lb_shift q (nat_lb y)))) *)
    apply lb_mask_equiv_equal.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    rewrite lb_meet_comm; auto.
  Qed.

  Fact nat_meet_left n m : n⇣m ≲ n.
  Proof.
(* Goal: binary_le m (nat_join n m) *)
    apply binary_le_eq_lb_mask.
(* Goal: lb_mask_equiv (nat_lb (nat_meet n n)) (nat_lb n) *)
    unfold nat_meet.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    rewrite lb_mask_nat; auto.
  Qed.

  Fact nat_meet_right n m : n⇣m ≲ m.
  Proof.
(* Goal: binary_le m (nat_join n m) *)
    apply binary_le_eq_lb_mask.
(* Goal: lb_mask_equiv (nat_lb (nat_meet n n)) (nat_lb n) *)
    unfold nat_meet.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    rewrite lb_mask_nat; auto.
  Qed.

  Hint Resolve nat_meet_left nat_meet_right.

  Fact binary_le_nat_meet n m : n ≲ m <-> n⇣m = n.
  Proof.
(* Goal: iff (binary_le n m) (@eq nat (nat_meet n m) n) *)
    rewrite equal_lb_mask_equiv.
(* Goal: iff (binary_le n m) (lb_mask_equiv (nat_lb (nat_meet n m)) (nat_lb n)) *)
    rewrite binary_le_eq_lb_mask.
(* Goal: lb_mask_equiv (nat_lb (nat_meet n n)) (nat_lb n) *)
    unfold nat_meet.
(* Goal: iff (lb_mask (nat_lb n) (nat_lb m)) (lb_mask_equiv (nat_lb (lb_nat (lb_meet (nat_lb n) (nat_lb m)))) (nat_lb n)) *)
    rewrite nat_lb_nat.
(* Goal: iff (lb_mask (nat_lb n) (nat_lb m)) (lb_mask_equiv (lb_meet (nat_lb n) (nat_lb m)) (nat_lb n)) *)
    apply lb_mask_meet.
  Qed.
  
  Theorem nat_meet_dio a b c : a = b⇣c <-> exists x y,  b = a+x
                                                     /\ c = a+y
                                                     /\ a ≲ a+x
                                                     /\ a ≲ a+y
                                                     /\ x ≲ x+y.
  Proof.
(* Goal: lb_mask_equiv (nat_lb (nat_meet n n)) (nat_lb n) *)
    unfold nat_meet.
(* Goal: iff (@eq nat a (lb_nat (lb_meet (nat_lb b) (nat_lb c)))) (@ex nat (fun x : nat => @ex nat (fun y : nat => and (@eq nat b (add a x)) (and (@eq nat c (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y)))))))) *)
    rewrite equal_lb_mask_equiv, nat_lb_nat.
(* Goal: iff (lb_mask_equiv (nat_lb a) (lb_meet (nat_lb b) (nat_lb c))) (@ex nat (fun x : nat => @ex nat (fun y : nat => and (@eq nat b (add a x)) (and (@eq nat c (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y)))))))) *)
    rewrite lb_meet_dio.
(* Goal: forall _ : @ex (list bool) (fun x : list bool => @ex (list bool) (fun y : list bool => and (lb_mask_equiv b (lb_plus false a x)) (and (lb_mask_equiv c (lb_plus false a y)) (and (lb_mask a (lb_plus false a x)) (and (lb_mask a (lb_plus false a y)) (lb_mask x (lb_plus false x y))))))), lb_mask_equiv a (lb_meet b c) *)
    split; intros (x & y & H1 & H2 & H3 & H4 & H5).
    + exists ⟦x⟧, ⟦y⟧.
(* Goal: and (@eq nat b (add a (lb_nat x))) (and (@eq nat c (add a (lb_nat y))) (and (binary_le a (add a (lb_nat x))) (and (binary_le a (add a (lb_nat y))) (binary_le (lb_nat x) (add (lb_nat x) (lb_nat y)))))) *)
      revert H1 H2 H3 H4 H5.
(* Goal: and (lb_mask_equiv (nat_lb b) (lb_plus false (nat_lb a) (nat_lb x))) (and (lb_mask_equiv (nat_lb c) (lb_plus false (nat_lb a) (nat_lb y))) (and (lb_mask (nat_lb a) (lb_plus false (nat_lb a) (nat_lb x))) (and (lb_mask (nat_lb a) (lb_plus false (nat_lb a) (nat_lb y))) (lb_mask (nat_lb x) (lb_plus false (nat_lb x) (nat_lb y)))))) *)
      repeat rewrite lb_mask_equiv_equal.
(* Goal: and (@eq nat (lb_nat (nat_lb b)) (lb_nat (lb_plus false (nat_lb a) (nat_lb x)))) (and (@eq nat (lb_nat (nat_lb c)) (lb_nat (lb_plus false (nat_lb a) (nat_lb y)))) (and (lb_mask (nat_lb a) (lb_plus false (nat_lb a) (nat_lb x))) (and (lb_mask (nat_lb a) (lb_plus false (nat_lb a) (nat_lb y))) (lb_mask (nat_lb x) (lb_plus false (nat_lb x) (nat_lb y)))))) *)
      repeat rewrite lb_mask_eq_binary_le.
(* Goal: @eq nat (add (add (bool2nat x) (mul (S (S O)) (lb_nat l))) (add (bool2nat y) (mul (S (S O)) (lb_nat m)))) (add (bool2nat (orb x y)) (mul (S (S O)) (lb_nat (lb_plus false l m)))) *)
      repeat rewrite lb_plus_spec_0.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      repeat rewrite lb_nat_lb; auto.
    + exists ⟬ x⟭, ⟬ y⟭ .
(* Goal: and (lb_mask_equiv (nat_lb b) (lb_plus false (nat_lb a) (nat_lb x))) (and (lb_mask_equiv (nat_lb c) (lb_plus false (nat_lb a) (nat_lb y))) (and (lb_mask (nat_lb a) (lb_plus false (nat_lb a) (nat_lb x))) (and (lb_mask (nat_lb a) (lb_plus false (nat_lb a) (nat_lb y))) (lb_mask (nat_lb x) (lb_plus false (nat_lb x) (nat_lb y)))))) *)
      repeat rewrite lb_mask_equiv_equal.
(* Goal: and (@eq nat (lb_nat (nat_lb b)) (lb_nat (lb_plus false (nat_lb a) (nat_lb x)))) (and (@eq nat (lb_nat (nat_lb c)) (lb_nat (lb_plus false (nat_lb a) (nat_lb y)))) (and (lb_mask (nat_lb a) (lb_plus false (nat_lb a) (nat_lb x))) (and (lb_mask (nat_lb a) (lb_plus false (nat_lb a) (nat_lb y))) (lb_mask (nat_lb x) (lb_plus false (nat_lb x) (nat_lb y)))))) *)
      repeat rewrite lb_mask_eq_binary_le.
(* Goal: and (@eq nat (lb_nat (nat_lb b)) (lb_nat (lb_plus false (nat_lb a) (nat_lb x)))) (and (@eq nat (lb_nat (nat_lb c)) (lb_nat (lb_plus false (nat_lb a) (nat_lb y)))) (and (binary_le (lb_nat (nat_lb a)) (lb_nat (lb_plus false (nat_lb a) (nat_lb x)))) (and (binary_le (lb_nat (nat_lb a)) (lb_nat (lb_plus false (nat_lb a) (nat_lb y)))) (binary_le (lb_nat (nat_lb x)) (lb_nat (lb_plus false (nat_lb x) (nat_lb y))))))) *)
      rewrite H1, H2.
(* Goal: @eq nat (add (add (bool2nat x) (mul (S (S O)) (lb_nat l))) (add (bool2nat y) (mul (S (S O)) (lb_nat m)))) (add (bool2nat (orb x y)) (mul (S (S O)) (lb_nat (lb_plus false l m)))) *)
      repeat rewrite lb_plus_spec_0.
      repeat rewrite lb_nat_lb.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      auto.
  Qed.

  (* This is how we compute the meet by division by powers of 2 *)

  Lemma nat_meet_mult_power2 q x y : (x*power q 2) ⇣ (y*power q 2) 
                                    = (x⇣y)*power q 2.
  Proof.
(* Goal: lb_mask_equiv (nat_lb (nat_meet n n)) (nat_lb n) *)
    unfold nat_meet.
    rewrite <- lb_nat_shift, lb_shift_meet.
(* Goal: @eq nat (lb_nat (lb_join (nat_lb (mul x (@mscal nat mul (S O) q (S (S O))))) (nat_lb (mul y (@mscal nat mul (S O) q (S (S O))))))) (lb_nat (lb_join (lb_shift q (nat_lb x)) (lb_shift q (nat_lb y)))) *)
    apply lb_mask_equiv_equal.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    do 2 rewrite nat_pow2_lb_shift; auto.
  Qed.

  Lemma nat_meet_euclid_power_2 q r1 d1 r2 d2 : 
           r1 < power q 2 
        -> r2 < power q 2 
        -> (r1+d1*power q 2) ⇣ (r2+d2*power q 2) 
         = (r1⇣r2) + (d1⇣d2)*power q 2.
  Proof.
(* Goal: lb_mask_equiv (nat_lb (nat_meet n n)) (nat_lb n) *)
    unfold nat_meet.
(* Goal: forall (_ : lt r1 (S (S O))) (_ : lt r2 (S (S O))), @eq nat (nat_meet (add r1 (mul (S (S O)) d1)) (add r2 (mul (S (S O)) d2))) (add (nat_meet r1 r2) (mul (S (S O)) (nat_meet d1 d2))) *)
    intros H1 H2.
    do 2 (rewrite nat_euclid_pow2_lb; auto).
    rewrite <- lb_nat_shift, <- lb_plus_spec_0.
(* Goal: @eq nat (lb_nat (lb_join (nat_lb (mul x (@mscal nat mul (S O) q (S (S O))))) (nat_lb (mul y (@mscal nat mul (S O) q (S (S O))))))) (lb_nat (lb_join (lb_shift q (nat_lb x)) (lb_shift q (nat_lb y)))) *)
    apply lb_mask_equiv_equal.
    rewrite lb_ortho_plus_join.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    2: apply lb_shift_ortho, lb_meet_length_le; apply nat_lb_length; auto.
    rewrite lb_shift_meet.
    rewrite lb_meet_join_distr.
    do 2 rewrite (lb_meet_comm (_↑_)).
    do 2 rewrite lb_meet_join_distr.
    rewrite lb_shift_ortho_meet; try (apply nat_lb_length; auto; fail).
    rew lb. 
    rewrite (lb_meet_comm (lb_shift _ _)).
    rewrite lb_shift_ortho_meet; try (apply nat_lb_length; auto; fail).
    rew lb.
    rewrite lb_meet_comm.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    rewrite (lb_meet_comm (lb_shift _ _)); auto.
  Qed.

  Lemma nat_meet_euclid_2 r1 d1 r2 d2 : 
           r1 < 2 
        -> r2 < 2 
        -> (r1+2*d1) ⇣ (r2+2*d2) 
         = (r1⇣r2) + 2*(d1⇣d2).
  Proof.
(* Goal: forall (_ : lt r1 (S (S O))) (_ : lt r2 (S (S O))), @eq nat (nat_meet (add r1 (mul (S (S O)) d1)) (add r2 (mul (S (S O)) d2))) (add (nat_meet r1 r2) (mul (S (S O)) (nat_meet d1 d2))) *)
    intros H1 H2.
(* Goal: @eq nat (nat_meet (add r1 (mul (S (S O)) d1)) (add r2 (mul (S (S O)) d2))) (add (nat_meet r1 r2) (mul (S (S O)) (nat_meet d1 d2))) *)
    do 3 rewrite (mult_comm 2).
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    apply nat_meet_euclid_power_2 with (q := 1); auto.
  Qed.
  
  Fact nat_meet_0n n : 0⇣n = 0.
  Proof.
(* Goal: @eq nat (nat_meet n (nat_join m k)) (nat_join (nat_meet n m) (nat_meet n k)) *)
    apply equal_lb_mask_equiv.
(* Goal: lb_mask_equiv (nat_lb (nat_meet n n)) (nat_lb n) *)
    unfold nat_meet.
    rewrite nat_lb_fix_0; rew lb.
(* Goal: lb_mask_equiv (nat_lb (lb_nat (nat_lb n))) (nat_lb n) *)
    apply nat_lb_nat.
  Qed.

  Fact nat_meet_n0 n : n⇣0 = 0.
  Proof. rewrite nat_meet_comm, nat_meet_0n; auto. Qed.

  Fact nat_meet_idem n : n⇣n = n.
  Proof. 
(* Goal: @eq nat (nat_meet n (nat_join m k)) (nat_join (nat_meet n m) (nat_meet n k)) *)
    apply equal_lb_mask_equiv.
(* Goal: lb_mask_equiv (nat_lb (nat_meet n n)) (nat_lb n) *)
    unfold nat_meet.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    rewrite nat_lb_nat, lb_meet_idem; auto.
  Qed.

  Hint Resolve nat_meet_0n nat_meet_n0 nat_meet_idem.

  Fact nat_meet_assoc n m k : n⇣(m⇣k) = n⇣m⇣k.
  Proof.
(* Goal: lb_mask_equiv (nat_lb (nat_meet n n)) (nat_lb n) *)
    apply equal_lb_mask_equiv; unfold nat_meet.
(* Goal: iff (lb_mask (nat_lb n) (nat_lb m)) (lb_mask_equiv (nat_lb (lb_nat (lb_meet (nat_lb n) (nat_lb m)))) (nat_lb n)) *)
    repeat rewrite nat_lb_nat.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    rewrite lb_meet_assoc; auto.
  Qed.

  Section nat_meet_power2_neq.

    Let nat_meet_power2_lt x y : x < y -> (power x 2) ⇣ (power y 2) = 0. 
    Proof.
(* Goal: forall _ : binary_le a (mul b (@mscal nat mul (S O) i r)), @sig nat (fun a' : nat => and (@eq nat a (mul a' (@mscal nat mul (S O) i r))) (binary_le a' b)) *)
      intros H.
      replace (power x 2) with (power x 2 + 0*power y 2) by ring.
      replace (power y 2) with (0 + 1*power y 2) at 2 by ring.
(* Goal: @eq nat (nat_meet (add (mul a (@mscal nat mul (S O) (mul i q) (S (S O)))) (mul O (@mscal nat mul (S O) (mul j q) (S (S O))))) (add O (mul b (@mscal nat mul (S O) (mul j q) (S (S O)))))) O *)
      rewrite nat_meet_euclid_power_2.
      + rewrite nat_meet_n0, nat_meet_0n; ring.
      + apply power_smono_l; omega.
      + apply power_ge_1; omega.
    Qed.

    Fact nat_meet_power2_neq x y : x <> y -> (power x 2) ⇣ (power y 2) = 0. 
    Proof.
(* Goal: forall _ : binary_le a (mul b (@mscal nat mul (S O) i r)), @sig nat (fun a' : nat => and (@eq nat a (mul a' (@mscal nat mul (S O) i r))) (binary_le a' b)) *)
      intros H.
(* Goal: @eq nat (nat_meet (@mscal nat mul (S O) x (S (S O))) (@mscal nat mul (S O) y (S (S O)))) O *)
      destruct (lt_eq_lt_dec x y) as [[]|]; try omega.
      + apply nat_meet_power2_lt; auto.
      + rewrite nat_meet_comm; apply nat_meet_power2_lt; auto.
    Qed.

  End nat_meet_power2_neq.

  Fact nat_meet_12n n : 1⇣(2*n) = 0.
  Proof.
    replace 1 with (1+0*power 1 2) at 1 by auto.
    replace (2*n) with (0+n*power 1 2) by (rewrite power_1; ring).
(* Goal: @eq nat (nat_meet (add (S O) (mul O (@mscal nat mul (S O) (S O) (S (S O))))) (add O (mul n (@mscal nat mul (S O) (S O) (S (S O)))))) O *)
    rewrite nat_meet_euclid_power_2; rewrite power_1; try omega.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    rewrite nat_meet_0n, nat_meet_n0; auto.
  Qed.

  Fact nat_meet_12 : 1⇣2 = 0.
  Proof. apply (nat_meet_12n 1). Qed.

  Fact power_2_minus_1 n : power (S n) 2 - 1 = 1 + 2*(power n 2 - 1).
  Proof.
(* Goal: @eq nat (sub (@mscal nat mul (S O) (S n) (S (S O))) (S O)) (add (S O) (mul (S (S O)) (sub (@mscal nat mul (S O) n (S (S O))) (S O)))) *)
    rewrite power_S.
(* Goal: @eq nat (sub (mul (S (S O)) (@mscal nat mul (S O) n (S (S O)))) (S O)) (add (S O) (mul (S (S O)) (sub (@mscal nat mul (S O) n (S (S O))) (S O)))) *)
    generalize (@power_ge_1 n 2); intros; omega.
  Qed.

  Fact power_2_minus_1_gt n x : x < power n 2 <-> x ≲ power n 2 - 1.
  Proof.
(* Goal: iff (@eq nat (@msum nat add O n (fun i : nat => mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (e i) r))) (@msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (f i) (g i)) *)
    split.
(* Goal: forall (i : nat) (_ : lt i n), and (@eq nat (g i) (mul (h i) (@mscal nat mul (S O) (e i) r))) (binary_le (h i) (f i)) *)
(* Goal: @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m (@msum nat add O n (fun i : nat => mul (g i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
    2: { intro Hx.
         apply binary_le_le in Hx.
         generalize (@power_ge_1 n 2); intros; omega. }
    intros H1.
    assert (x <= power n 2 -1) as H by omega; clear H1. 
    rewrite binary_le_nat_meet.
    revert x H; induction n as [ | n IHn ]; intros x Hx.
    + rewrite power_0 in Hx; cutrewrite (x=0); auto; omega.
    + destruct (eq_nat_dec x 0) as [ H | H ].
      - rewrite H; auto.
      - destruct (euclid_2_div x) as (H1 & H2).
        rewrite H1, power_2_minus_1.
        rewrite nat_meet_euclid_2; try omega.
(* Goal: @eq nat (add (f O) (@msum nat add O n (fun n : nat => f (S n)))) (nat_join (f O) (@msum nat nat_join O n (fun n : nat => f (S n)))) *)
        rewrite IHn.
        * f_equal; destruct H2 as [ H2 | H2 ]; rewrite H2; auto.
        * rewrite power_2_minus_1 in Hx; omega.
  Qed.

  Definition nat_join n m := ⟦ ⟬n⟭↑⟬m⟭ ⟧.
  Local Infix "⇡" := nat_join (at level 50, left associativity).

  Fact nat_join_comm n m : n⇡m = m⇡n.
  Proof.
(* Goal: @eq nat (lb_nat (lb_join (nat_lb (mul x (@mscal nat mul (S O) q (S (S O))))) (nat_lb (mul y (@mscal nat mul (S O) q (S (S O))))))) (lb_nat (lb_join (lb_shift q (nat_lb x)) (lb_shift q (nat_lb y)))) *)
    apply lb_mask_equiv_equal.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    rewrite lb_join_comm; auto.
  Qed.

  Fact nat_join_left n m : n ≲ n⇡m.
  Proof.
(* Goal: binary_le m (nat_join n m) *)
    apply binary_le_eq_lb_mask.
(* Goal: @eq nat (nat_join (mul x (@mscal nat mul (S O) q (S (S O)))) (mul y (@mscal nat mul (S O) q (S (S O))))) (mul (nat_join x y) (@mscal nat mul (S O) q (S (S O)))) *)
    unfold nat_join.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    rewrite lb_mask_nat; auto.
  Qed.

  Fact nat_join_right n m : m ≲ n⇡m.
  Proof.
(* Goal: binary_le m (nat_join n m) *)
    apply binary_le_eq_lb_mask.
(* Goal: @eq nat (nat_join (mul x (@mscal nat mul (S O) q (S (S O)))) (mul y (@mscal nat mul (S O) q (S (S O))))) (mul (nat_join x y) (@mscal nat mul (S O) q (S (S O)))) *)
    unfold nat_join.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    rewrite lb_mask_nat; auto.
  Qed.

  Hint Resolve nat_join_left nat_join_right.

  Fact nat_join_0n n : 0⇡n = n.
  Proof.
(* Goal: @eq nat (nat_meet n (nat_join m k)) (nat_join (nat_meet n m) (nat_meet n k)) *)
    apply equal_lb_mask_equiv.
(* Goal: @eq nat (nat_join (mul x (@mscal nat mul (S O) q (S (S O)))) (mul y (@mscal nat mul (S O) q (S (S O))))) (mul (nat_join x y) (@mscal nat mul (S O) q (S (S O)))) *)
    unfold nat_join.
    rewrite nat_lb_fix_0; rew lb.
(* Goal: lb_mask_equiv (nat_lb (lb_nat (nat_lb n))) (nat_lb n) *)
    apply nat_lb_nat.
  Qed.

  Fact nat_join_n0 n : n⇡0 = n.
  Proof. rewrite nat_join_comm, nat_join_0n; auto. Qed.

  Fact nat_join_idem n : n⇡n = n.
  Proof. 
(* Goal: @eq nat (nat_meet n (nat_join m k)) (nat_join (nat_meet n m) (nat_meet n k)) *)
    apply equal_lb_mask_equiv.
(* Goal: @eq nat (nat_join (mul x (@mscal nat mul (S O) q (S (S O)))) (mul y (@mscal nat mul (S O) q (S (S O))))) (mul (nat_join x y) (@mscal nat mul (S O) q (S (S O)))) *)
    unfold nat_join.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    rewrite nat_lb_nat, lb_join_idem; auto.
  Qed.

  Fact nat_join_mono a b u v : a ≲ b -> u ≲ v -> a⇡u ≲ b⇡v.
  Proof.
(* Goal: @eq nat (nat_join (mul x (@mscal nat mul (S O) q (S (S O)))) (mul y (@mscal nat mul (S O) q (S (S O))))) (mul (nat_join x y) (@mscal nat mul (S O) q (S (S O)))) *)
    do 3 rewrite binary_le_eq_lb_mask; unfold nat_join.
(* Goal: iff (lb_mask (nat_lb n) (nat_lb m)) (lb_mask_equiv (nat_lb (lb_nat (lb_meet (nat_lb n) (nat_lb m)))) (nat_lb n)) *)
    do 2 rewrite nat_lb_nat.
(* Goal: forall (_ : lb_mask (nat_lb a) (nat_lb b)) (_ : lb_mask (nat_lb u) (nat_lb v)), lb_mask (lb_join (nat_lb a) (nat_lb u)) (lb_join (nat_lb b) (nat_lb v)) *)
    apply lb_join_mono.
  Qed.

  Fact nat_join_assoc n m k : n⇡(m⇡k) = n⇡m⇡k.
  Proof.
(* Goal: @eq nat (nat_join (mul x (@mscal nat mul (S O) q (S (S O)))) (mul y (@mscal nat mul (S O) q (S (S O))))) (mul (nat_join x y) (@mscal nat mul (S O) q (S (S O)))) *)
    apply equal_lb_mask_equiv; unfold nat_join.
(* Goal: iff (lb_mask (nat_lb n) (nat_lb m)) (lb_mask_equiv (nat_lb (lb_nat (lb_meet (nat_lb n) (nat_lb m)))) (nat_lb n)) *)
    repeat rewrite nat_lb_nat.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    rewrite lb_join_assoc; auto.
  Qed.

  Fact nat_join_meet_distr_l n m k : n⇡(m⇣k) = (n⇡m)⇣(n⇡k).
  Proof.
(* Goal: @eq nat (nat_meet n (nat_join m k)) (nat_join (nat_meet n m) (nat_meet n k)) *)
    apply equal_lb_mask_equiv.
(* Goal: lb_mask_equiv (nat_lb (nat_meet n (nat_join m k))) (nat_lb (nat_join (nat_meet n m) (nat_meet n k))) *)
    unfold nat_join, nat_meet.
(* Goal: iff (lb_mask (nat_lb n) (nat_lb m)) (lb_mask_equiv (nat_lb (lb_nat (lb_meet (nat_lb n) (nat_lb m)))) (nat_lb n)) *)
    repeat rewrite nat_lb_nat.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    rewrite lb_join_meet_distr; auto.
  Qed.

  Fact nat_meet_join_distr_l n m k : n⇣(m⇡k) = (n⇣m)⇡(n⇣k).
  Proof.
(* Goal: @eq nat (nat_meet n (nat_join m k)) (nat_join (nat_meet n m) (nat_meet n k)) *)
    apply equal_lb_mask_equiv.
(* Goal: lb_mask_equiv (nat_lb (nat_meet n (nat_join m k))) (nat_lb (nat_join (nat_meet n m) (nat_meet n k))) *)
    unfold nat_join, nat_meet.
(* Goal: iff (lb_mask (nat_lb n) (nat_lb m)) (lb_mask_equiv (nat_lb (lb_nat (lb_meet (nat_lb n) (nat_lb m)))) (nat_lb n)) *)
    repeat rewrite nat_lb_nat.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    rewrite lb_meet_join_distr; auto.
  Qed.
  
  Hint Resolve nat_join_0n nat_join_n0 nat_join_assoc.

  Lemma nat_join_monoid : monoid_theory nat_join 0.
  Proof. split; auto. Qed.
 
  Hint Resolve nat_join_monoid nat_join_mono.

  Fact nat_meet_joins_distr_l m n f : m ⇣ msum nat_join 0 n f = msum nat_join 0 n (fun i => m ⇣ f i).
  Proof.
(* Goal: @eq nat (nat_meet m (@msum nat nat_join O n f)) (@msum nat nat_join O n (fun i : nat => nat_meet m (f i))) *)
    revert m f; induction n as [ | n IHn ]; intros m f.
    + do 2 rewrite msum_0; auto.
    + do 2 rewrite msum_S.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      rewrite nat_meet_join_distr_l, IHn; auto.
  Qed.

  Fact nat_join_binary_le n m k : n⇡m ≲ k <-> n ≲ k /\ m ≲ k.
  Proof.
(* Goal: iff (@eq nat (@msum nat add O n (fun i : nat => mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (e i) r))) (@msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (f i) (g i)) *)
    split.
    + intros H; split; apply binary_le_trans with (2 := H); auto.
    + intros (H1 & H2). rewrite <- (nat_join_idem k); auto.
  Qed. 

  Fact nat_joins_binary_le_left n f m : msum nat_join 0 n f ≲ m <-> forall i, i < n -> f i ≲ m.
  Proof.
(* Goal: iff (@eq nat (@msum nat nat_join O n (fun i : nat => nat_meet m (f i))) O) (forall (i : nat) (_ : lt i n), @eq nat (nat_meet m (f i)) O) *)
    revert f; induction n as [ | n IHn ]; intros f.
    + rewrite msum_0; split; auto; intros; omega.
    + rewrite msum_S, nat_join_binary_le, IHn.
(* Goal: iff (@eq nat (@msum nat add O n (fun i : nat => mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (e i) r))) (@msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (f i) (g i)) *)
      split.
      * intros [H1 H2] [] ?; auto; apply H2; omega.
      * intros H; split; intros; apply H; omega.
  Qed.

  Fact nat_joins_binary_le_right m n f : (exists i, i < n /\ m ≲ f i) -> m ≲ msum nat_join 0 n f.
  Proof.
(* Goal: forall _ : @ex nat (fun i : nat => and (lt i n) (binary_le m (f i))), binary_le m (@msum nat nat_join O n f) *)
    intros (i & H1 & H2).
(* Goal: binary_le m (@msum nat nat_join O n f) *)
    apply binary_le_trans with (1 := H2).
(* Goal: binary_le (f i) (@msum nat nat_join O n f) *)
    clear m H2.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    revert f i H1; induction n as [ | n IHn ]; intros f [ | i ] Hi; try omega; rewrite msum_S; auto.
(* Goal: binary_le (f (S i)) (nat_join (f O) (@msum nat nat_join O n (fun n : nat => f (S n)))) *)
    apply binary_le_trans with (2 := nat_join_right _ _).
(* Goal: binary_le (f (S i)) (@msum nat nat_join O n (fun n : nat => f (S n))) *)
    apply (IHn (fun i => f (S i))); omega.
  Qed.

  Fact nat_joins_binary_le n m f g :
           (forall i, i < n -> exists j, j < m /\ f i ≲ g j)
        -> msum nat_join 0 n f ≲ msum nat_join 0 m g.
  Proof.
(* Goal: forall _ : binary_le a (mul b (@mscal nat mul (S O) i r)), @sig nat (fun a' : nat => and (@eq nat a (mul a' (@mscal nat mul (S O) i r))) (binary_le a' b)) *)
    intros H.
(* Goal: binary_le (@msum nat nat_join O n (fun i : nat => @msum nat nat_join O i (f i))) (@msum nat nat_join O m g) *)
    rewrite nat_joins_binary_le_left.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    intros i Hi; apply nat_joins_binary_le_right; auto.
  Qed.

  Fact nat_double_joins_binary_le n m f g : 
           (forall i j, j < i < n -> exists k, k < m /\ f i j ≲ g k)
        -> msum nat_join 0 n (fun i => msum nat_join 0 i (f i)) ≲ msum nat_join 0 m g.
  Proof.
(* Goal: forall _ : binary_le a (mul b (@mscal nat mul (S O) i r)), @sig nat (fun a' : nat => and (@eq nat a (mul a' (@mscal nat mul (S O) i r))) (binary_le a' b)) *)
    intros H.
(* Goal: binary_le (@msum nat nat_join O n (fun i : nat => @msum nat nat_join O i (f i))) (@msum nat nat_join O m g) *)
    rewrite nat_joins_binary_le_left.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    intros; apply nat_joins_binary_le; auto.
  Qed.

  Fact binary_le_join_inv m a b : m ≲ a⇡b -> m = (m⇣a)⇡(m⇣b).
  Proof.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    rewrite binary_le_nat_meet, nat_meet_join_distr_l; auto.
  Qed.

  Fact binary_le_joins_inv m n f : m ≲ msum nat_join 0 n f
                              -> { k : nat & { g : nat -> nat & { h | m = msum nat_join 0 k g
                                                                   /\ k <= n 
                                                                   /\ (forall i, i < k -> g i <> 0 /\ g i ≲ f (h i))  
                                                                   /\ (forall i, i < k -> h i < n)
                                                                   /\ (forall i j, i < j < k -> h i < h j) } } }.
  Proof.
(* Goal: forall _ : binary_le m (@msum nat nat_join O n f), @sigT nat (fun k : nat => @sigT (forall _ : nat, nat) (fun g : forall _ : nat, nat => @sig (forall _ : nat, nat) (fun h : forall _ : nat, nat => and (@eq nat m (@msum nat nat_join O k g)) (and (le k n) (and (forall (i : nat) (_ : lt i k), and (not (@eq nat (g i) O)) (binary_le (g i) (f (h i)))) (and (forall (i : nat) (_ : lt i k), lt (h i) n) (forall (i j : nat) (_ : and (lt i j) (lt j k)), lt (h i) (h j)))))))) *)
    revert m f; induction n as [ | n IHn ]; intros m f H.
    + rewrite msum_0 in H; apply binary_le_zero_inv in H.
(* Goal: iff (@eq nat (@msum nat add O n (fun i : nat => mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (e i) r))) (@msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (f i) (g i)) *)
      subst; exists 0, (fun _ => 0), (fun _ => 0); split.
      - rewrite msum_0; auto.
      - split; [ | split; [ | split ] ]; intros; omega.
    + rewrite msum_S in H.
(* Goal: @sigT nat (fun k : nat => @sigT (forall _ : nat, nat) (fun g : forall _ : nat, nat => @sig (forall _ : nat, nat) (fun h : forall _ : nat, nat => and (@eq nat m (@msum nat nat_join O k g)) (and (le k (S n)) (and (forall (i : nat) (_ : lt i k), and (not (@eq nat (g i) O)) (binary_le (g i) (f (h i)))) (and (forall (i : nat) (_ : lt i k), lt (h i) (S n)) (forall (i j : nat) (_ : and (lt i j) (lt j k)), lt (h i) (h j)))))))) *)
      apply binary_le_join_inv in H.
      destruct (@IHn (m ⇣ msum nat_join 0 n (fun n => f (S n))) (fun n => f (S n)))
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
        as (k & g & h & H1 & H0 & H2 & H3 & H4); auto.
(* Goal: @sigT nat (fun k : nat => @sigT (forall _ : nat, nat) (fun g : forall _ : nat, nat => @sig (forall _ : nat, nat) (fun h : forall _ : nat, nat => and (@eq nat m (@msum nat nat_join O k g)) (and (le k (S n)) (and (forall (i : nat) (_ : lt i k), and (not (@eq nat (g i) O)) (binary_le (g i) (f (h i)))) (and (forall (i : nat) (_ : lt i k), lt (h i) (S n)) (forall (i j : nat) (_ : and (lt i j) (lt j k)), lt (h i) (h j)))))))) *)
      rewrite H1 in H.
(* Goal: @sigT nat (fun k : nat => @sigT (forall _ : nat, nat) (fun g : forall _ : nat, nat => @sig (forall _ : nat, nat) (fun h : forall _ : nat, nat => and (@eq nat m (@msum nat nat_join O k g)) (and (le k (S n)) (and (forall (i : nat) (_ : lt i k), and (not (@eq nat (g i) O)) (binary_le (g i) (f (h i)))) (and (forall (i : nat) (_ : lt i k), lt (h i) (S n)) (forall (i j : nat) (_ : and (lt i j) (lt j k)), lt (h i) (h j)))))))) *)
      case_eq (m ⇣ f 0).
      * intros E.
(* Goal: @sigT nat (fun k : nat => @sigT (forall _ : nat, nat) (fun g : forall _ : nat, nat => @sig (forall _ : nat, nat) (fun h : forall _ : nat, nat => and (@eq nat m (@msum nat nat_join O k g)) (and (le k (S n)) (and (forall (i : nat) (_ : lt i k), and (not (@eq nat (g i) O)) (binary_le (g i) (f (h i)))) (and (forall (i : nat) (_ : lt i k), lt (h i) (S n)) (forall (i j : nat) (_ : and (lt i j) (lt j k)), lt (h i) (h j)))))))) *)
        rewrite E, nat_join_0n in H.
(* Goal: @sigT nat (fun k : nat => @sigT (forall _ : nat, nat) (fun g : forall _ : nat, nat => @sig (forall _ : nat, nat) (fun h : forall _ : nat, nat => and (@eq nat m (@msum nat nat_join O k g)) (and (le k (S n)) (and (forall (i : nat) (_ : lt i k), and (not (@eq nat (g i) O)) (binary_le (g i) (f (h i)))) (and (forall (i : nat) (_ : lt i k), lt (h i) (S n)) (forall (i j : nat) (_ : and (lt i j) (lt j k)), lt (h i) (h j)))))))) *)
        exists k, g, (fun i => S (h i)); repeat (split; auto).
        - intros i Hi; specialize (H3 _ Hi); omega.
        - intros i j Hij; specialize (H4 _ _ Hij); omega.
      * intros u Hu.
        exists (S k), (fun i => match i with 0 => S u | S i => g i end),
                      (fun i => match i with 0 => 0   | S i => S (h i) end); split; [  | split; [ | split; [ | split ] ] ].
        - rewrite H, msum_S, <- Hu; auto.
        - omega.
        - intros [ | i ]; split; try omega. 
          ++ rewrite <- Hu; auto.
          ++ apply H2; omega.
          ++ apply H2; omega.
        - intros [ | i ] Hi; try omega.
(* Goal: le (S k) (S n) *)
          apply lt_S_n, H3 in Hi; omega.
        - intros [ | i ] [ | j ] (G1 & G2); simpl; try omega.
(* Goal: le (S k) (S n) *)
          apply lt_n_S, H4; omega.
  Qed.

  Fact binary_le_joins_inv' m n f : m ≲ msum nat_join 0 n f
                              -> { g | m = msum nat_join 0 n g /\ forall i, i < n -> g i ≲ f i }.  
  Proof.
(* Goal: iff (@eq nat (@msum nat add O n (fun i : nat => mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (e i) r))) (@msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (f i) (g i)) *)
    intros H; exists (fun i => m⇣f i); split.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    2: intros; auto.
    apply binary_le_nat_meet in H.
    rewrite <- H at 1.
    apply nat_meet_joins_distr_l.
  Qed.

  (* This is how we compute the meet by division by powers of 2 *)

  Lemma nat_join_mult_power2 q x y : (x*power q 2) ⇡ (y*power q 2) 
                                    = (x⇡y)*power q 2.
  Proof.
(* Goal: @eq nat (nat_join (mul x (@mscal nat mul (S O) q (S (S O)))) (mul y (@mscal nat mul (S O) q (S (S O))))) (mul (nat_join x y) (@mscal nat mul (S O) q (S (S O)))) *)
    unfold nat_join.
    rewrite <- lb_nat_shift, lb_shift_join.
(* Goal: @eq nat (lb_nat (lb_join (nat_lb (mul x (@mscal nat mul (S O) q (S (S O))))) (nat_lb (mul y (@mscal nat mul (S O) q (S (S O))))))) (lb_nat (lb_join (lb_shift q (nat_lb x)) (lb_shift q (nat_lb y)))) *)
    apply lb_mask_equiv_equal.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    do 2 rewrite nat_pow2_lb_shift; auto.
  Qed.

  Lemma binary_le_mult_power2_inv m x q : m ≲ x * power q 2 -> m <> 0 -> { y | m = y * power q 2 /\ y <> 0 /\ y ≲ x }.
  Proof.
(* Goal: forall (_ : lt r1 (S (S O))) (_ : lt r2 (S (S O))), @eq nat (nat_meet (add r1 (mul (S (S O)) d1)) (add r2 (mul (S (S O)) d2))) (add (nat_meet r1 r2) (mul (S (S O)) (nat_meet d1 d2))) *)
    intros H1 H2.
    destruct (@euclid m (power q 2)) as (d & r & H3 & H4).
    + generalize (@power_ge_1 q 2); intros; omega.
    + apply binary_le_nat_meet in H1.
      rewrite plus_comm in H3.
      rewrite H3, <- (Nat.add_0_l (x*_)) in H1.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      rewrite nat_meet_euclid_power_2 in H1; auto.
      rewrite nat_meet_n0 in H1.
      rewrite (plus_comm r), (plus_comm 0) in H1.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      apply div_rem_uniq in H1; auto.
(* Goal: le (S k) (S n) *)
      2: generalize (@power_ge_1 q 2); intros; omega.
      destruct H1 as (H0 & H1).
      subst r; simpl in H3.
(* Goal: and (@eq nat a (mul (nat_meet v b) (@mscal nat mul (S O) i r))) (binary_le (nat_meet v b) b) *)
      exists d; split; auto.
(* Goal: iff (@eq nat (@msum nat add O n (fun i : nat => mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (e i) r))) (@msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (f i) (g i)) *)
      split.
      - contradict H2; subst; auto.
      - rewrite <- H0; auto.
  Qed.
 
  Lemma nat_join_euclid2 q r1 d1 r2 d2 : 
           r1 < power q 2 
        -> r2 < power q 2 
        -> (r1+d1*power q 2) ⇡ (r2+d2*power q 2) 
         = (r1⇡r2) + (d1⇡d2)*power q 2.
  Proof.
(* Goal: @eq nat (nat_join (mul x (@mscal nat mul (S O) q (S (S O)))) (mul y (@mscal nat mul (S O) q (S (S O))))) (mul (nat_join x y) (@mscal nat mul (S O) q (S (S O)))) *)
    unfold nat_join.
(* Goal: forall (_ : lt r1 (S (S O))) (_ : lt r2 (S (S O))), @eq nat (nat_meet (add r1 (mul (S (S O)) d1)) (add r2 (mul (S (S O)) d2))) (add (nat_meet r1 r2) (mul (S (S O)) (nat_meet d1 d2))) *)
    intros H1 H2.
    do 2 (rewrite nat_euclid_pow2_lb; auto).
    rewrite <- lb_nat_shift, <- lb_plus_spec_0.
(* Goal: @eq nat (lb_nat (lb_join (nat_lb (mul x (@mscal nat mul (S O) q (S (S O))))) (nat_lb (mul y (@mscal nat mul (S O) q (S (S O))))))) (lb_nat (lb_join (lb_shift q (nat_lb x)) (lb_shift q (nat_lb y)))) *)
    apply lb_mask_equiv_equal.
    rewrite lb_ortho_plus_join.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    2: apply lb_shift_ortho, lb_join_length_le; apply nat_lb_length; auto.
    rewrite lb_shift_join.
    rewrite  lb_join_assoc, <- (lb_join_assoc ⟬ r1 ⟭).
    rewrite (lb_join_comm _ ⟬ r2 ⟭).
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
    repeat rewrite lb_join_assoc; auto.
  Qed.

  Fact nat_lb_plus n m : ⟬n+m⟭ ≂ ⟬n⟭⊕⟬m⟭.
  Proof.
(* Goal: lb_mask_equiv (nat_lb (add n m)) (lb_plus false (nat_lb n) (nat_lb m)) *)
    rewrite lb_mask_equiv_equal, lb_nat_lb, lb_plus_spec_0. 
(* Goal: @eq nat (add n m) (add (lb_nat (nat_lb n)) (lb_nat (nat_lb m))) *)
    f_equal; symmetry; apply lb_nat_lb.
  Qed.

  Fact nat_ortho_plus_join n m : n⇣m = 0 -> n+m = n⇡m.
  Proof.
(* Goal: iff (binary_le n m) (@eq nat (nat_meet n m) n) *)
    do 2 rewrite equal_lb_mask_equiv.
(* Goal: forall _ : lb_mask_equiv (nat_lb (nat_meet n m)) (nat_lb O), lb_mask_equiv (nat_lb (add n m)) (nat_lb (nat_join n m)) *)
    unfold nat_meet, nat_join.
(* Goal: iff (lb_mask (nat_lb n) (nat_lb m)) (lb_mask_equiv (nat_lb (lb_nat (lb_meet (nat_lb n) (nat_lb m)))) (nat_lb n)) *)
    do 2 rewrite nat_lb_nat.
(* Goal: forall _ : lb_mask_equiv (lb_meet (nat_lb n) (nat_lb m)) (nat_lb O), lb_mask_equiv (nat_lb (add n m)) (lb_join (nat_lb n) (nat_lb m)) *)
    rewrite nat_lb_plus, nat_lb_fix_0.
    rewrite <- lb_ortho_meet_nil.
(* Goal: forall _ : lb_ortho (nat_lb n) (nat_lb m), lb_mask_equiv (lb_plus false (nat_lb n) (nat_lb m)) (lb_join (nat_lb n) (nat_lb m)) *)
    apply lb_ortho_plus_join.
  Qed.

  Local Notation sum_powers := (fun r n f e => ∑ n (fun i => f i * power (e i) r)).

  Fact sum_powers_bound r n f e :
                 r <> 0
              -> (forall i, i < n -> f i < r) 
              -> (forall i j, i < j -> e i < e j)
              -> sum_powers r n f e < power (e n) r.
  Proof.
    intros Hr; revert f e.
    induction n as [ | n IHn ]; intros f e Hf He.
    + rewrite msum_0; apply power_ge_1; auto.
    + rewrite msum_plus1; auto.
      apply lt_le_trans with (power (S (e n)) r).
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      2: apply power_mono_l; try omega; apply He; auto.
(* Goal: @eq nat (sub (@mscal nat mul (S O) (S n) (S (S O))) (S O)) (add (S O) (mul (S (S O)) (sub (@mscal nat mul (S O) n (S (S O))) (S O)))) *)
      rewrite power_S.
      apply lt_le_trans with (1*power (e n) r + f n * power (e n) r).
      * rewrite Nat.mul_1_l; apply plus_lt_le_compat; auto.
      * rewrite <- Nat.mul_add_distr_r; apply mult_le_compat; auto.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
        apply Hf; auto.
  Qed.

  Fact sum_powers_euclid r n f e : (forall j, j < n -> e 1 <= e (S j))
        -> sum_powers r (S n) f e = f 0 * power (e 0) r 
                                  + sum_powers r n (fun i => f (S i)) (fun i => e (S i) - e 1) * power (e 1) r.
  Proof.
(* Goal: forall _ : forall (j : nat) (_ : lt j n), le (e (S O)) (e (S j)), @eq nat ((fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r))) r (S n) f e) (add (mul (f O) (@mscal nat mul (S O) (e O) r)) (mul ((fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r))) r n (fun i : nat => f (S i)) (fun i : nat => sub (e (S i)) (e (S O)))) (@mscal nat mul (S O) (e (S O)) r))) *)
    intros Hf; simpl; f_equal.
    rewrite <- sum_0n_scal_r.
(* Goal: @eq nat (@msum nat nat_join O k g) (@msum nat nat_join O k (fun i : nat => mul (g' i) (@mscal nat mul (S O) (e (h i)) r))) *)
    apply msum_ext.
(* Goal: forall (i : nat) (_ : lt i n), lt (sub (@mscal nat mul (S O) p (S (S O))) (S O)) r *)
    intros i Hi.
    rewrite <- mult_assoc; f_equal.
    rewrite <- power_plus; f_equal.
(* Goal: le (S k) (S n) *)
    generalize (Hf _ Hi); omega.
  Qed.

  Fact nat_meet_joins m n f : m⇣msum nat_join 0 n f = msum nat_join 0 n (fun i => m⇣f i).
  Proof.
(* Goal: iff (@eq nat (@msum nat nat_join O n (fun i : nat => nat_meet m (f i))) O) (forall (i : nat) (_ : lt i n), @eq nat (nat_meet m (f i)) O) *)
    revert f; induction n as [ | n IHn ]; intros f.
    + rewrite msum_0, msum_0, nat_meet_n0; auto.
    + do 2 rewrite msum_S.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      rewrite nat_meet_join_distr_l, IHn; auto.
  Qed.

  Fact nat_join_eq_0 n m : n⇡m = 0 <-> n = 0 /\ m = 0.
  Proof.
(* Goal: iff (@eq nat (@msum nat add O n (fun i : nat => mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (e i) r))) (@msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (f i) (g i)) *)
    split.
    + do 3 rewrite equal_lb_mask_equiv. 
(* Goal: iff (lb_mask (nat_lb n) (nat_lb m)) (lb_mask_equiv (nat_lb (lb_nat (lb_meet (nat_lb n) (nat_lb m)))) (nat_lb n)) *)
      unfold nat_join; rewrite nat_lb_nat.
(* Goal: forall _ : lb_mask_equiv (lb_join (nat_lb n) (nat_lb m)) (nat_lb O), and (lb_mask_equiv (nat_lb n) (nat_lb O)) (lb_mask_equiv (nat_lb m) (nat_lb O)) *)
      repeat rewrite nat_lb_fix_0.
(* Goal: forall _ : lb_mask_equiv (lb_join (nat_lb n) (nat_lb m)) (@nil bool), and (lb_mask_equiv (nat_lb n) (@nil bool)) (lb_mask_equiv (nat_lb m) (@nil bool)) *)
      apply lb_join_nil_eq.
    + intros []; subst; apply nat_join_0n.
  Qed.

  Fact nat_ortho_joins_left m n f : m⇣msum nat_join 0 n f = 0 
                           <-> forall i, i < n -> m⇣f i = 0.
  Proof.
(* Goal: @eq nat (nat_meet (mul (g i) (@mscal nat mul (S O) (e i) r)) (@msum nat nat_join O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r)))) (mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (e i) r)) *)
    rewrite nat_meet_joins.
(* Goal: iff (@eq nat (@msum nat nat_join O n (fun i : nat => nat_meet m (f i))) O) (forall (i : nat) (_ : lt i n), @eq nat (nat_meet m (f i)) O) *)
    revert f; induction n as [ | n IHn ]; intros f.
    + rewrite msum_0; split; auto; intros; omega.
    + rewrite msum_S, nat_join_eq_0, IHn.
(* Goal: iff (@eq nat (@msum nat add O n (fun i : nat => mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (e i) r))) (@msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (f i) (g i)) *)
      split.
      * intros [ H1 H2 ] [ | i ] ?; auto; apply H2; omega.
      * intros H; split; intros; apply H; omega.
  Qed.

  Fact nat_ortho_sum_join n f : (forall i j, i <> j -> i < n -> j < n -> f i ⇣ f j = 0)
                             -> ∑ n f = msum nat_join 0 n f.
  Proof.
(* Goal: forall _ : forall (i j : nat) (_ : not (@eq nat i j)) (_ : lt i n) (_ : lt j n), @eq nat (nat_meet (f i) (f j)) O, @eq nat (@msum nat add O n f) (@msum nat nat_join O n f) *)
    revert f; induction n as [ | n IHn ]; intros f Hf.
    + do 2 rewrite msum_0; auto.
    + do 2 rewrite msum_S.
(* Goal: @eq nat (add (f O) (@msum nat add O n (fun n : nat => f (S n)))) (nat_join (f O) (@msum nat nat_join O n (fun n : nat => f (S n)))) *)
      rewrite IHn.
(* Goal: @eq nat (add (f O) (@msum nat nat_join O n (fun n : nat => f (S n)))) (nat_join (f O) (@msum nat nat_join O n (fun n : nat => f (S n)))) *)
(* Goal: forall (i j : nat) (_ : not (@eq nat i j)) (_ : lt i n) (_ : lt j n), @eq nat (nat_meet (f (S i)) (f (S j))) O *)
      apply nat_ortho_plus_join, nat_ortho_joins_left.
      * intros; apply Hf; omega.
      * intros; apply Hf; omega.
  Qed.

  Fact nat_ortho_joins m n f g : msum nat_join 0 m f ⇣ msum nat_join 0 n g = 0 
                             <-> forall i j, i < m -> j < n -> f i ⇣ g j = 0.
  Proof.
(* Goal: iff (@eq nat (nat_meet (@msum nat nat_join O m f) (@msum nat nat_join O n g)) O) (forall (i j : nat) (_ : lt i m) (_ : lt j n), @eq nat (nat_meet (f i) (g j)) O) *)
    rewrite nat_ortho_joins_left.
(* Goal: forall _ : binary_le a (mul b (@mscal nat mul (S O) i r)), @sig nat (fun a' : nat => and (@eq nat a (mul a' (@mscal nat mul (S O) i r))) (binary_le a' b)) *)
    split; intros H.
    + intros i j H1 H2; specialize (H _ H2).
      rewrite nat_meet_comm in H |- *.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      rewrite nat_ortho_joins_left in H; auto.
    + intros i Hi; rewrite nat_meet_comm, nat_ortho_joins_left.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      intros j Hj; rewrite nat_meet_comm; auto.
  Qed.

  Local Notation "⇧" := (fun r n f e => msum nat_join 0 n (fun i => f i * power (e i) r)).

  Section nat_meet_digits.

    Variable (q : nat) (Hq : 0 < q) (r : nat) (Hr : r = power q 2).
          
    Implicit Types (f g : nat -> nat).

    Let Hr' : 2 <= r.
    Proof. rewrite Hr; apply (@power_mono_l 1 _ 2); omega. Qed.

    Fact nat_meet_powers_eq i a b : (a*power i r)⇣(b*power i r) = (a⇣b)*power i r.
    Proof. rewrite Hr, <- power_mult, nat_meet_mult_power2; auto. Qed.

    Fact binary_power_split i a : { u : nat & { v | a = u⇡(v*power i r) /\ forall k, u⇣(k*power i r) = 0 } }.
    Proof.
(* Goal: @sigT nat (fun u : nat => @sig nat (fun v : nat => and (@eq nat a (nat_join u (mul v (@mscal nat mul (S O) i r)))) (forall k : nat, @eq nat (nat_meet u (mul k (@mscal nat mul (S O) i r))) O))) *)
      destruct (@euclid a (power i r)) as (u & v & H1 & H2).
      + generalize (@power_ge_1 i r); intros; omega.
      + exists v, u.
        assert (forall k, v ⇣ (k*power i r) = 0) as E.
        { intros k; replace v with (v+0*power i r) by ring.
          replace (k*power i r) with (0+k*power i r) by ring.
          rewrite Hr, <- power_mult.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
          rewrite nat_meet_euclid_power_2, nat_meet_0n, nat_meet_n0; auto.
          rewrite power_mult, <- Hr; auto. }
(* Goal: and (@eq nat a (mul (nat_meet v b) (@mscal nat mul (S O) i r))) (binary_le (nat_meet v b) b) *)
        split; auto.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
        rewrite H1, plus_comm, nat_ortho_plus_join; auto.
    Qed.
        

    Fact binary_le_power_inv i a b : a ≲ b * power i r -> { a' | a = a' * power i r /\ a' ≲ b }.
    Proof.
(* Goal: forall _ : binary_le a (mul b (@mscal nat mul (S O) i r)), @sig nat (fun a' : nat => and (@eq nat a (mul a' (@mscal nat mul (S O) i r))) (binary_le a' b)) *)
      intros H.
(* Goal: @sig nat (fun a' : nat => and (@eq nat a (mul a' (@mscal nat mul (S O) i r))) (binary_le a' b)) *)
      destruct (binary_power_split i a) as (u & v & H1 & H2).
(* Goal: @sig nat (fun a' : nat => and (@eq nat a (mul a' (@mscal nat mul (S O) i r))) (binary_le a' b)) *)
      exists (v⇣b).
(* Goal: and (@eq nat a (mul (nat_meet v b) (@mscal nat mul (S O) i r))) (binary_le (nat_meet v b) b) *)
      rewrite binary_le_nat_meet in H.
(* Goal: and (@eq nat a (mul (nat_meet v b) (@mscal nat mul (S O) i r))) (binary_le (nat_meet v b) b) *)
      rewrite H1 in H at 1.
(* Goal: and (@eq nat a (mul (nat_meet v b) (@mscal nat mul (S O) i r))) (binary_le (nat_meet v b) b) *)
      rewrite nat_meet_comm, nat_meet_join_distr_l in H.
(* Goal: and (@eq nat a (mul (nat_meet v b) (@mscal nat mul (S O) i r))) (binary_le (nat_meet v b) b) *)
      rewrite (nat_meet_comm _ u), H2, nat_join_0n, nat_meet_comm in H.
      rewrite Hr, <- power_mult,  nat_meet_mult_power2, power_mult, <- Hr in H.
(* Goal: and (@eq nat a (mul (nat_meet v b) (@mscal nat mul (S O) i r))) (binary_le (nat_meet v b) b) *)
      split; auto.
    Qed.
  
    Section nat_meet_powers_neq.

      Let nat_meet_neq_powers i j a b : i < j -> a < r -> b < r -> (a*power i r)⇣(b*power j r) = 0.
      Proof.
(* Goal: forall (_ : lt i j) (_ : lt a r) (_ : lt b r), @eq nat (nat_meet (mul a (@mscal nat mul (S O) i r)) (mul b (@mscal nat mul (S O) j r))) O *)
        intros H1 Ha Hb.
        replace (a*power i r) with (a*power i r + 0*power j r) by ring.
        replace (b*power j r) with (0+b*power j r) by ring.
        rewrite Hr, <- power_mult, <- power_mult.
        rewrite  nat_meet_euclid_power_2.
        + rewrite nat_meet_n0, nat_meet_0n; ring.
        + do 2 rewrite power_mult; rewrite <- Hr.
(* Goal: lt (mul a (@mscal nat mul (S O) i r)) (@mscal nat mul (S O) j r) *)
          apply lt_le_trans with (power (S i) r).
          - rewrite power_S; apply mult_lt_compat_r; auto.
(* Goal: lt O (@mscal nat mul (S O) j r) *)
            apply power_ge_1; omega.
          - apply power_mono_l; omega.
        + rewrite power_mult, <- Hr.
(* Goal: lt O (@mscal nat mul (S O) j r) *)
          apply power_ge_1; omega.
      Qed.

      Fact nat_meet_powers_neq i j a b : i <> j -> a < r -> b < r -> (a*power i r)⇣(b*power j r) = 0.
      Proof.
(* Goal: forall (_ : not (@eq nat i j)) (_ : lt a r) (_ : lt b r), @eq nat (nat_meet (mul a (@mscal nat mul (S O) i r)) (mul b (@mscal nat mul (S O) j r))) O *)
        intros Hij Ha Hb.
(* Goal: le (S k) (S n) *)
        destruct (lt_eq_lt_dec i j) as [ [] | ]; try omega.
        + apply nat_meet_neq_powers; auto.
        + rewrite nat_meet_comm.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
          apply nat_meet_neq_powers; auto.
      Qed.
 
    End nat_meet_powers_neq.

    Fact sum_powers_ortho n f e : 
                 (forall i, i < n -> f i < r) 
              -> (forall i j, i < n -> j < n -> e i = e j -> i = j)
              -> sum_powers r n f e = ⇧ r n f e.
    Proof.
      revert f e; induction n as [ | n IHn ]; intros f e H1 H2.
      + do 2 rewrite msum_0; auto.
      + rewrite msum_S.
(* Goal: @eq nat (add (f O) (@msum nat add O n (fun n : nat => f (S n)))) (nat_join (f O) (@msum nat nat_join O n (fun n : nat => f (S n)))) *)
        rewrite IHn.
(* Goal: le (S k) (S n) *)
        2: intros; apply H1; omega.
(* Goal: le (S k) (S n) *)
        2: intros i j Hi Hj E; apply H2 in E; omega.
        rewrite nat_ortho_plus_join.
        * rewrite msum_S; auto.
        * apply nat_ortho_joins_left.
(* Goal: forall (i : nat) (_ : lt i n), lt (sub (@mscal nat mul (S O) p (S (S O))) (S O)) r *)
          intros i Hi.
          apply nat_meet_powers_neq.
          - intros E; apply H2 in E; omega.
          - apply H1; omega.
          - apply H1; omega.
    Qed.

    Section double_sum_powers_ortho.
 
      Variable (n : nat) (f e : nat -> nat -> nat)
               (Hf : forall i j, j < i < n -> f i j < r)
               (He : forall i1 j1 i2 j2, j1 < i1 < n -> j2 < i2 < n -> e i1 j1 = e i2 j2 -> i1 = i2 /\ j1 = j2).

      Let dsmpo_1 i : i < n -> sum_powers r i (f i) (e i) = ⇧ r i (f i) (e i).
      Proof.
(* Goal: forall _ : lt i n, @eq nat ((fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r))) r i (f i) (e i)) ((fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat nat_join O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r))) r i (f i) (e i)) *)
        intros Hi; apply sum_powers_ortho.
        + intros; apply Hf; omega.
        + intros ? ? ? ?; apply He; omega.
      Qed.

      Fact double_sum_powers_ortho : ∑ n (fun i => sum_powers r i (f i) (e i)) = msum nat_join 0 n (fun i => ⇧ r i (f i) (e i)).
      Proof.
(* Goal: @eq nat (@msum nat add O n (fun i : nat => (fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat add O n (fun i0 : nat => mul (f i0) (@mscal nat mul (S O) (e i0) r))) r i (f i) (e i))) (@msum nat nat_join O n (fun i : nat => (fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat nat_join O n (fun i0 : nat => mul (f i0) (@mscal nat mul (S O) (e i0) r))) r i (f i) (e i))) *)
        rewrite nat_ortho_sum_join.
        + apply msum_ext; intros; apply dsmpo_1; auto.
        + intros; do 2 (rewrite dsmpo_1; auto).
(* Goal: @eq nat (nat_meet (@msum nat nat_join O i (fun i0 : nat => mul (f i i0) (@mscal nat mul (S O) (e i i0) r))) (@msum nat nat_join O j (fun i : nat => mul (f j i) (@mscal nat mul (S O) (e j i) r)))) O *)
          apply nat_ortho_joins.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
          intros; apply nat_meet_powers_neq; auto.
(* Goal: le (S k) (S n) *)
          intros E; apply He in E; omega.
      Qed.

    End double_sum_powers_ortho.

    Fact sinc_injective n f : (forall i j, i < j < n -> f i < f j) -> forall i j, i < n -> j < n -> f i = f j -> i = j.
    Proof.
(* Goal: forall (_ : forall (i j : nat) (_ : and (lt i j) (lt j n)), lt (f i) (f j)) (i j : nat) (_ : lt i n) (_ : lt j n) (_ : @eq nat (f i) (f j)), @eq nat i j *)
      intros Hf i j Hi Hj E.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      destruct (lt_eq_lt_dec i j) as [ [] | ]; auto.
      + generalize (Hf i j); intros; omega.
      + generalize (Hf j i); intros; omega.
    Qed.

    Hint Resolve sinc_injective.

    Section binary_le_meet_sum_powers.

      Variable (n : nat) (f g e : nat -> nat)
               (Hf : forall i, i < n -> f i < r) 
               (Hg : forall i, i < n -> g i < r)
               (He : forall i j, i < j < n -> e i < e j).

      Fact meet_sum_powers : (sum_powers r n f e)⇣(sum_powers r n g e) 
                           = sum_powers r n (fun i => f i ⇣ g i) e.
      Proof.
(* Goal: @eq nat (nat_meet ((fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r))) r n f e) ((fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r))) r n g e)) ((fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r))) r n (fun i : nat => nat_meet (f i) (g i)) e) *)
        generalize (sinc_injective _ He); intros H0.
(* Goal: @eq nat (nat_meet (@msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r))) (@msum nat add O n (fun i : nat => mul (g i) (@mscal nat mul (S O) (e i) r)))) (@msum nat add O n (fun i : nat => mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (e i) r))) *)
        simpl; do 3 (rewrite sum_powers_ortho; auto).
(* Goal: @eq nat (nat_meet (mul (g i) (@mscal nat mul (S O) (e i) r)) (@msum nat nat_join O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r)))) (mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (e i) r)) *)
        rewrite nat_meet_joins.
        + apply msum_ext.
(* Goal: @eq nat (nat_meet (mul a (@mscal nat mul (S O) i r)) (mul b (@mscal nat mul (S O) j r))) O *)
          intros i Hi; rewrite nat_meet_comm.
(* Goal: @eq nat (nat_meet (mul (g i) (@mscal nat mul (S O) (e i) r)) (@msum nat nat_join O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r)))) (mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (e i) r)) *)
          rewrite nat_meet_joins.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
          rewrite msum_only_one with (i := i); auto.
          * rewrite nat_meet_comm, Hr, <- power_mult.
(* Goal: @eq nat (nat_meet (mul (f i) (@mscal nat mul (S O) (mul (e i) q) (S (S O)))) (mul (g i) (@mscal nat mul (S O) (mul (e i) q) (S (S O))))) (mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (mul (e i) q) (S (S O)))) *)
            apply nat_meet_mult_power2.
          * intros j G1 G2; apply nat_meet_powers_neq; auto.
        + intros i Hi.
(* Goal: lt (nat_meet (f i) (g i)) r *)
          apply le_lt_trans with (2 := Hf Hi).
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
          apply binary_le_le; auto.
      Qed.

      Fact binary_le_sum_powers : sum_powers r n f e ≲ sum_powers r n g e <-> forall i, i < n -> f i ≲ g i.
      Proof.
(* Goal: iff (binary_le ((fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r))) r n f e) ((fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r))) r n g e)) (forall (i : nat) (_ : lt i n), binary_le (f i) (g i)) *)
        rewrite binary_le_nat_meet, meet_sum_powers.
(* Goal: iff (@eq nat (@msum nat add O n (fun i : nat => mul (nat_meet (f i) (g i)) (@mscal nat mul (S O) (e i) r))) (@msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (f i) (g i)) *)
        split. 
        + intros E i Hi.
(* Goal: binary_le (f i) (g i) *)
          apply binary_le_nat_meet.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
          apply power_decomp_unique with (5 := E); auto.
(* Goal: forall (i : nat) (_ : lt i n), lt (nat_meet (f i) (g i)) r *)
          intros j Hj; apply le_lt_trans with (2 := Hf Hj).
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
          apply binary_le_le; auto.
        + intros H; apply msum_ext.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
          intros; f_equal; apply binary_le_nat_meet; auto.
      Qed.
          
    End binary_le_meet_sum_powers.

    Fact sum_power_binary_lt p n f a : 
            0 < p <= q
         -> (forall i j, i < j < n -> f i < f j)
         -> (forall i, i < n -> a i < power p 2)  -> ∑ n (fun i => a i * power (f i) r) 
                                                   ≲ (power p 2-1) * ∑ n (fun i => power (f i) r).
    Proof.
(* Goal: forall (_ : forall (i : nat) (_ : lt i n), lt (f i) r) (_ : forall (i j : nat) (_ : and (lt i j) (lt j n)), lt (e i) (e j)) (_ : binary_le m ((fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r))) r n f e)), @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m ((fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r))) r n g e)) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
      intros H1 H2 H3.
      generalize (sinc_injective _ H2); intros H4.
      rewrite <- sum_0n_scal_l.
(* Goal: binary_le (f i) (g i) *)
      apply binary_le_nat_meet.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      rewrite meet_sum_powers; auto.
(* Goal: le (S k) (S n) *)
      2: intros i Hi; rewrite Hr; apply lt_le_trans with (1 := H3 _ Hi), power_mono_l; omega. 
(* Goal: forall (i : nat) (_ : lt i n), and (@eq nat (g i) (mul (h i) (@mscal nat mul (S O) (e i) r))) (binary_le (h i) (f i)) *)
(* Goal: @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m (@msum nat add O n (fun i : nat => mul (g i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
      2: { rewrite Hr.
(* Goal: forall (i : nat) (_ : lt i n), lt (sub (@mscal nat mul (S O) p (S (S O))) (S O)) r *)
           intros i Hi. 
           generalize (@power_ge_1 p 2); intro.
           unfold lt.
           cutrewrite (S (power p 2 -1) = power p 2); try omega. 
           apply power_mono_l; omega. }
      apply msum_ext; intros i Hi; f_equal.
      apply binary_le_nat_meet, power_2_minus_1_gt.
(* Goal: le (S k) (S n) *)
      assert (a i < power p 2); try omega.
(* Goal: le (S k) (S n) *)
      apply lt_le_trans with (1 := H3 _ Hi), power_mono_l; omega.
    Qed.

    Fact sum_powers_binary_le_inv n f e m :
                 (forall i, i < n -> f i < r) 
              -> (forall i j, i < j < n -> e i < e j)
              -> m ≲ sum_powers r n f e
              -> { k : nat &
                 { g : nat -> nat & 
(* Goal: forall (i : nat) (_ : lt i n), and (@eq nat (g i) (mul (h i) (@mscal nat mul (S O) (e i) r))) (binary_le (h i) (f i)) *)
(* Goal: @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m (@msum nat add O n (fun i : nat => mul (g i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
                 { h |  m = sum_powers r k g (fun i => e (h i)) 
                     /\ k <= n
                     /\ (forall i, i < k -> g i <> 0 /\ g i ≲ f (h i))
                     /\ (forall i, i < k -> h i < n)
                     /\ (forall i j, i < j < k -> h i < h j) } } }.
    Proof.
(* Goal: forall (_ : forall (i : nat) (_ : lt i n), lt (f i) r) (_ : forall (i j : nat) (_ : and (lt i j) (lt j n)), lt (e i) (e j)) (_ : binary_le m ((fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r))) r n f e)), @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m ((fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r))) r n g e)) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
      intros H1 H2 H3.
(* Goal: @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m ((fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r))) r n g e)) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
      generalize (sinc_injective _ H2); intros H0.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      simpl in H3; rewrite sum_powers_ortho in H3; auto.
(* Goal: @sigT nat (fun k : nat => @sigT (forall _ : nat, nat) (fun g : forall _ : nat, nat => @sig (forall _ : nat, nat) (fun h : forall _ : nat, nat => and (@eq nat m (@msum nat add O k (fun i : nat => mul (g i) (@mscal nat mul (S O) (e (h i)) r)))) (and (le k n) (and (forall (i : nat) (_ : lt i k), and (not (@eq nat (g i) O)) (binary_le (g i) (f (h i)))) (and (forall (i : nat) (_ : lt i k), lt (h i) n) (forall (i j : nat) (_ : and (lt i j) (lt j k)), lt (h i) (h j)))))))) *)
      apply binary_le_joins_inv in H3.
(* Goal: @sigT nat (fun k : nat => @sigT (forall _ : nat, nat) (fun g : forall _ : nat, nat => @sig (forall _ : nat, nat) (fun h : forall _ : nat, nat => and (@eq nat m (@msum nat add O k (fun i : nat => mul (g i) (@mscal nat mul (S O) (e (h i)) r)))) (and (le k n) (and (forall (i : nat) (_ : lt i k), and (not (@eq nat (g i) O)) (binary_le (g i) (f (h i)))) (and (forall (i : nat) (_ : lt i k), lt (h i) n) (forall (i j : nat) (_ : and (lt i j) (lt j k)), lt (h i) (h j)))))))) *)
      destruct H3 as (k & g & h & H4 & H10 & H5 & H6 & H7).
(* Goal: @sigT nat (fun k : nat => @sigT (forall _ : nat, nat) (fun g : forall _ : nat, nat => @sig (forall _ : nat, nat) (fun h : forall _ : nat, nat => and (@eq nat m (@msum nat add O k (fun i : nat => mul (g i) (@mscal nat mul (S O) (e (h i)) r)))) (and (le k n) (and (forall (i : nat) (_ : lt i k), and (not (@eq nat (g i) O)) (binary_le (g i) (f (h i)))) (and (forall (i : nat) (_ : lt i k), lt (h i) n) (forall (i j : nat) (_ : and (lt i j) (lt j k)), lt (h i) (h j)))))))) *)
      generalize (sinc_injective _ H7); intros H8.
      assert (forall i, { a | i < k -> g i = a * power (e (h i)) r /\ a <> 0 /\ a ≲ f (h i) }) as H.
(* Goal: forall (i : nat) (_ : lt i n), and (@eq nat (g i) (mul (h i) (@mscal nat mul (S O) (e i) r))) (binary_le (h i) (f i)) *)
(* Goal: @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m (@msum nat add O n (fun i : nat => mul (g i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
      { intros i.
(* Goal: @sig nat (fun a : nat => forall _ : lt i k, and (@eq nat (g i) (mul a (@mscal nat mul (S O) (e (h i)) r))) (and (not (@eq nat a O)) (binary_le a (f (h i))))) *)
        destruct (le_lt_dec k i) as [ H | H ].
        * exists 0; intros; omega.
        * destruct (H5 _ H) as (G1 & G2).
          rewrite Hr, <- power_mult in G2.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
          apply binary_le_mult_power2_inv in G2; auto.
(* Goal: @sig nat (fun a : nat => forall _ : lt i k, and (@eq nat (g i) (mul a (@mscal nat mul (S O) (e (h i)) r))) (and (not (@eq nat a O)) (binary_le a (f (h i))))) *)
          destruct G2 as (a & G2 & G3 & G4).
          rewrite power_mult, <- Hr in G2.
          exists a; auto. }
(* Goal: @sigT nat (fun k : nat => @sigT (forall _ : nat, nat) (fun g : forall _ : nat, nat => @sig (forall _ : nat, nat) (fun h : forall _ : nat, nat => and (@eq nat m (@msum nat add O k (fun i : nat => mul (g i) (@mscal nat mul (S O) (e (h i)) r)))) (and (le k n) (and (forall (i : nat) (_ : lt i k), and (not (@eq nat (g i) O)) (binary_le (g i) (f (h i)))) (and (forall (i : nat) (_ : lt i k), lt (h i) n) (forall (i j : nat) (_ : and (lt i j) (lt j k)), lt (h i) (h j)))))))) *)
      set (g' := fun i => proj1_sig (H i)).
      assert (Hg' : forall i, i < k -> g i = g' i * power (e (h i)) r /\ g' i <> 0 /\ g' i ≲ f (h i)).
(* Goal: forall (i : nat) (_ : lt i n), and (@eq nat (g i) (mul (h i) (@mscal nat mul (S O) (e i) r))) (binary_le (h i) (f i)) *)
(* Goal: @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m (@msum nat add O n (fun i : nat => mul (g i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
      { intro i; apply (proj2_sig (H i)). }
(* Goal: @sigT nat (fun k : nat => @sigT (forall _ : nat, nat) (fun g : forall _ : nat, nat => @sig (forall _ : nat, nat) (fun h : forall _ : nat, nat => and (@eq nat m (@msum nat add O k (fun i : nat => mul (g i) (@mscal nat mul (S O) (e (h i)) r)))) (and (le k n) (and (forall (i : nat) (_ : lt i k), and (not (@eq nat (g i) O)) (binary_le (g i) (f (h i)))) (and (forall (i : nat) (_ : lt i k), lt (h i) n) (forall (i j : nat) (_ : and (lt i j) (lt j k)), lt (h i) (h j)))))))) *)
      generalize g' Hg'; clear H g' Hg'; intros g' Hg'.

(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      exists k, g', h; split; [ | split; [ | split ] ]; auto.
      - rewrite sum_powers_ortho, H4.
        * apply msum_ext. intros; apply Hg'; auto.
        * intros i Hi; apply le_lt_trans with (f (h i)).
          + apply binary_le_le, Hg'; auto.
          + apply H1, H6; auto.
        * intros ? ? ? ? E; apply H0 in E; auto.
      - intros; apply Hg'; auto.
    Qed.

    Fact binary_le_sum_powers_inv n f e m :
                 (forall i, i < n -> f i < r) 
              -> (forall i j, i < j < n -> e i < e j)
              -> m ≲ sum_powers r n f e
              -> { g | m = sum_powers r n g e /\ forall i, i < n -> g i ≲ f i }.
    Proof.
(* Goal: forall (_ : forall (i : nat) (_ : lt i n), lt (f i) r) (_ : forall (i j : nat) (_ : and (lt i j) (lt j n)), lt (e i) (e j)) (_ : binary_le m ((fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r))) r n f e)), @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m ((fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r))) r n g e)) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
      intros H1 H2 H3.
(* Goal: @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m ((fun (r n : nat) (f e : forall _ : nat, nat) => @msum nat add O n (fun i : nat => mul (f i) (@mscal nat mul (S O) (e i) r))) r n g e)) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
      generalize (sinc_injective _ H2); intros H0.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      simpl in H3; rewrite sum_powers_ortho in H3; auto.
(* Goal: @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m (@msum nat add O n (fun i : nat => mul (g i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
      apply binary_le_joins_inv' in H3.
(* Goal: @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m (@msum nat add O n (fun i : nat => mul (g i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
      destruct H3 as (g & H3 & H4).
      assert (forall i, i < n -> { h | g i = h * power (e i) r /\ h ≲ f i }) as h_full.
(* Goal: forall (i : nat) (_ : lt i n), and (@eq nat (g i) (mul (h i) (@mscal nat mul (S O) (e i) r))) (binary_le (h i) (f i)) *)
(* Goal: @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m (@msum nat add O n (fun i : nat => mul (g i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
      { intros i Hi; apply binary_le_power_inv; auto. }
(* Goal: @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m (@msum nat add O n (fun i : nat => mul (g i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
      set (h := fun i => match le_lt_dec n i with left _ => 0 | right H => proj1_sig (h_full _ H) end).
      assert (Hh : forall i, i < n ->  g i = h i * power (e i) r /\ h i ≲ f i).
(* Goal: forall (i : nat) (_ : lt i n), and (@eq nat (g i) (mul (h i) (@mscal nat mul (S O) (e i) r))) (binary_le (h i) (f i)) *)
(* Goal: @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m (@msum nat add O n (fun i : nat => mul (g i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
      { intros i Hi; unfold h; destruct (le_lt_dec n i) as [ | H' ]; try omega.
        apply (proj2_sig (h_full _ H')). }
(* Goal: @sig (forall _ : nat, nat) (fun g : forall _ : nat, nat => and (@eq nat m (@msum nat add O n (fun i : nat => mul (g i) (@mscal nat mul (S O) (e i) r)))) (forall (i : nat) (_ : lt i n), binary_le (g i) (f i))) *)
      generalize h Hh; clear h_full h Hh; intros h Hh.
(* Goal: and (@eq nat a (mul (nat_meet v b) (@mscal nat mul (S O) i r))) (binary_le (nat_meet v b) b) *)
      exists h; split; auto.
      + rewrite H3.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
        rewrite sum_powers_ortho; auto.
        * apply msum_ext; intros; apply Hh; auto.
        * intros i Hi; apply le_lt_trans with (2 := H1 _ Hi), binary_le_le, Hh; auto.
      + intros; apply Hh; auto.
    Qed.

    Fact sum_power_binary_lt_inv p n f e m :
            0 < p <= q
         -> (forall i j, i < j < n -> f i < f j)
         -> (forall i j, i < j < n -> e i < e j)
         -> m ≲ (power p 2-1) * ∑ n (fun i => power (f i) r)
         -> exists a, m = ∑ n (fun i => a i * power (f i) r) 
                   /\ forall i, i < n -> a i < power p 2.
    Proof.
(* Goal: forall (_ : and (lt O p) (le p q)) (_ : forall (i j : nat) (_ : and (lt i j) (lt j n)), lt (f i) (f j)) (_ : forall (i j : nat) (_ : and (lt i j) (lt j n)), lt (e i) (e j)) (_ : binary_le m (mul (sub (@mscal nat mul (S O) p (S (S O))) (S O)) (@msum nat add O n (fun i : nat => @mscal nat mul (S O) (f i) r)))), @ex (forall _ : nat, nat) (fun a : forall _ : nat, nat => and (@eq nat m (@msum nat add O n (fun i : nat => mul (a i) (@mscal nat mul (S O) (f i) r)))) (forall (i : nat) (_ : lt i n), lt (a i) (@mscal nat mul (S O) p (S (S O))))) *)
      intros H1 H2 H3 H4.
      rewrite <- sum_0n_scal_l in H4.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
      apply binary_le_sum_powers_inv in H4; auto.
      + destruct H4 as (a & H5 & H6).
(* Goal: and (@eq nat a (mul (nat_meet v b) (@mscal nat mul (S O) i r))) (binary_le (nat_meet v b) b) *)
        exists a; split; auto.
(* Goal: and (@eq nat (add a x) (add a x)) (and (@eq nat (add a y) (add a y)) (and (binary_le a (add a x)) (and (binary_le a (add a y)) (binary_le x (add x y))))) *)
        intros i Hi; apply power_2_minus_1_gt; auto.
      + intros i Hi.
(* Goal: lt (sub (@mscal nat mul (S O) p (S (S O))) (S O)) r *)
        apply lt_le_trans with (power p 2).
        - generalize (@power_ge_1 p 2); intros; omega.
        - rewrite Hr; apply power_mono_l; omega.
    Qed.

  End nat_meet_digits.

    
        
       
 
      


