Require Export D.

Check optimize_1mult.
(*
[optimize_1mult] is defined as follows:

Fixpoint optimize_1mult (a:aexp) : aexp :=
  match a with
  | ANum n =>
      ANum n
  | APlus e1 e2 =>
      APlus (optimize_1mult e1) (optimize_1mult e2)
  | AMinus e1 e2 =>
      AMinus (optimize_1mult e1) (optimize_1mult e2)
  | AMult (ANum 1) e2 =>
      optimize_1mult e2
  | AMult e1 (ANum 1) =>
      optimize_1mult e1
  | AMult e1 e2 =>
      AMult (optimize_1mult e1) (optimize_1mult e2)
  end.
*)

(** Hint:
    If you use the tacticals [;], [try] and [omega] well,
    you can prove the following theorem in 5 lines.
 **)

 Tactic Notation "aexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ANum" | Case_aux c "APlus"
  | Case_aux c "AMinus"  | Case_aux c "AMult" ].

 Tactic Notation "inductive_cases" tactic(first) ident(c) :=
   first;
   [ Case_aux c "O" | Case_aux c "S n"].

Theorem optimize_1mult_sound: forall a,
  aeval (optimize_1mult a) = aeval a.
Proof.
  intros. aexp_cases (induction a) Case; try reflexivity; try (simpl; omega).
   aexp_cases (destruct a1) SCase.
  (* SCase = "ANum" *)
  destruct n.
  SSCase "n = 0".
      aexp_cases (destruct a2) SSSCase; try reflexivity. destruct n. reflexivity. destruct n; try reflexivity.
  SSCase "n = S n".
    aexp_cases (destruct a2) SSSCase. destruct n. destruct n0; try reflexivity. simpl in *. omega. simpl in *. destruct n0; try reflexivity. simpl. destruct n0; try reflexivity. simpl. omega.
  destruct n; simpl in *; rewrite IHa2; [try omega|reflexivity].
  destruct n; simpl in *; rewrite IHa2; [try omega|reflexivity].
  destruct n; simpl in *; rewrite IHa2; [try omega|reflexivity].

  (* SCase = "APlus" *)
   aexp_cases (destruct a2) SSSCase.  destruct n. simpl in *. rewrite IHa1. omega. destruct n.  simpl in *. rewrite IHa1. omega. simpl in *. rewrite IHa1. omega.
  simpl in *. rewrite IHa1. rewrite IHa2. omega.
  simpl in *. rewrite IHa1. rewrite IHa2. omega.
  simpl in *. rewrite IHa1. rewrite IHa2. omega.

  (* SCase = "AMinus" *)
   aexp_cases (destruct a2) SSSCase.  destruct n. simpl in *. rewrite IHa1. omega. destruct n.  simpl in *. rewrite IHa1. omega. simpl in *. rewrite IHa1. omega.
  simpl in *. rewrite IHa1. rewrite IHa2. omega.
  simpl in *. rewrite IHa1. rewrite IHa2. omega.
  simpl in *. rewrite IHa1. rewrite IHa2. omega.

  (* SCase = "AMult" *)
   aexp_cases (destruct a2) SSSCase.  destruct n. simpl in *. rewrite IHa1. omega. destruct n.  simpl in *. rewrite IHa1. omega. simpl in *. rewrite IHa1. omega.
  simpl in *. rewrite IHa1. rewrite IHa2. omega.
  simpl in *. rewrite IHa1. rewrite IHa2. omega.
  simpl in *. rewrite IHa1. rewrite IHa2. omega.

Qed.


From LADR Require Import VectorSpace.
Include DEFINITIONS.
Require Import Ensembles.
Require Import Vector.
Require Import Logic.FunctionalExtensionality.
Require Import Logic.PropExtensionality.
Fixpoint zipwith {A B C : Type} {n : nat}
         (f : A -> B -> C) (v1 : t A n) (v2 : t B n) : t C n
  := match v1 in t _ n return t B n -> t C n with
     | nil _ => fun _ => nil C
     | cons _ x1 _ v1' =>
       fun v2 =>
         cons _ (f x1 (hd v2)) _ (zipwith f v1' (tl v2))
     end v2.
Definition zip {A B C : Type} {n : nat} := @zipwith A B (A*B) n pair.
Lemma nil_unique {A : Type} : forall (xs : t A 0), xs = nil A.
Proof. apply case0. reflexivity. Qed.

(*2.5*)
Definition span {n : nat} (xs : t V n) : V -> Prop
  :=
    fun x => exists ys, x = fold_left vadd 0 (zipwith vsmult ys xs).

(*2.8*)
Definition spans {n : nat} (xs : t V n) : Prop
  :=
    span xs = Full_set V.

(*2.5*)
Theorem span_empty_zero : span (@nil V) = fun x => x = 0.
Proof.
  apply (functional_extensionality (span (@nil V)) (fun x => x = 0)).
  intros x.
  unfold span.
  apply propositional_extensionality.
  split.
  - intros.
    destruct H as [ys H].
    rewrite (nil_unique ys) in H; simpl in H.
    apply H.
  - simpl.
    intros.
    exists (@nil F).
    simpl.
    apply H.
  Qed.
(*
(*2.10*)
Definition finite_dimensional (V : Type) (H__vectorspace : )
*)
(*Linear Independence*)

(*2.17*)
Definition linearly_independent {n : nat} (xs : t V n) : Prop :=
  forall (ys : t F n),
    fold_left vadd 0 (zipwith vsmult ys xs) = 0 ->
    Forall (fun y => y = 0%fieldsc) ys.

(*2.17 b*)
Theorem empty_independent : linearly_independent (@nil V).
Proof.
  unfold linearly_independent; intros.
  specialize (nil_unique ys); intros.
  rewrite H0.
  apply Forall_nil.
Qed.

(*2.19*)
Definition linearly_dependent {n : nat} (xs : t V n) : Prop :=
  exists (ys : t F n),
    Exists (fun y => y <> 0%fieldsc) ys -> fold_left vadd 0 (zipwith vsmult ys xs) = 0.

Definition three_zeros : t V 3 :=
  (cons V 0 2 (cons V 0 1 (cons V 0 0 (nil V)))).
(*)
  Definition coprojection {A : Type} {n : nat} (v : t A n) (j : nat) (H : j < n) : t A (n-1) :=
    (*[x for i, x in enumerate(xs) if i != j]*)
    take (n-1) v.
*)
Check nth_order (cons V 0 2 (cons V 0 1 (cons V 0 0 (nil V)))).
Definition a_leq_prop := 5 <= 7.

(*2.21*)
Theorem linear_dependence_lemma1 {n : nat} (xs : t V n) (H : linearly_dependent xs) :
  exists (j : nat),
  forall (H0 : j <= n) (H1 : j < n),
    (span (take j H0 xs) (nth_order xs H1)).
Proof.
  exists 1%nat.
  intros.
  induction xs.
  - inversion H0.
  - simpl.
    unfold linearly_dependent in H.
    destruct H as [ys H].
    unfold span.

Admitted.

(*2.23*)
Theorem length_linearly_independent_list_leq_length_spanning_list {n m : nat} :
  forall (xs : t V n) (xs' : t V m),
    linearly_independent xs -> spans F V vadd vsmult 0 veq xs' -> n <= m.
Proof.
  intros.
  unfold linearly_independent in H.
  unfold spans, span in H0.
Admitted.

Lemma fold_commute {n : nat} {a__k : t F n} {xs : t V n} {l : F} :
  fold_left vadd 0 (map (vsmult l) (zipwith vsmult a__k xs)) = vsmult l (fold_left vadd 0 (zipwith vsmult a__k xs)).
Proof.
  generalize dependent a__k.
  induction xs; intros a__k.
  - specialize (nil_unique a__k); intros.
    rewrite H.
    simpl.
    symmetry.
    apply number_times_zero with (r0 := r0) (r1 := r1) (radd := radd) (rmul := rmul)
                                 (rsub := rsub) (ropp := ropp) (req := req) (rdiv := rdiv)
                                 (rinv := rinv) (vadd := vadd) (veq := veq); give_up.
  - simpl.
Admitted.

Lemma factor_out_scalar {n : nat} {a__k : t F n} {xs : t V n} : forall (l : F) (H__l : l <> 0%fieldsc),
    fold_left vadd 0 (map (vsmult l) (zipwith vsmult a__k xs)) = 0 ->
    fold_left vadd 0 (zipwith vsmult a__k xs) = 0.
Proof.
  intros l H__l H__xsl.
  rewrite fold_commute in H__xsl.
  Admitted.

(*exercise 2.A.8*)
Theorem scalar_ind {n : nat} :
  forall (l : F) (H__l : l <> 0%fieldsc) (xs : t V n) (H__xs : linearly_independent xs),
    linearly_independent (map (vsmult l) xs).
Proof.
  intros l H__l xs H__xs.
  unfold linearly_independent in *.
  intros b__k H__lx.
  specialize (H__xs b__k).
Admitted.

(*exercise 2.A.9*)
(*This is actually false, counterexample is v = [2,0], [0,1] and w = [1, 2], [3, 1]*)
Theorem sum_ind {n : nat} : forall (xs ys : t V n) (H__xs : linearly_independent xs) (H__ys : linearly_independent ys),
    linearly_independent (zipwith vadd xs ys).
Proof.
  intros xs ys H__xs H__ys.
  unfold linearly_independent in *.
  intros b__k H__xys.
  specialize (H__xs b__k).
  apply H__xs.


Require Export GeoCoq.Elements.OriginalProofs.lemma_betweennotequal.

Section Euclid.

Context `{Ax1:euclidean_neutral}.

Lemma lemma_lessthannotequal :
   forall A B C D,
   Lt A B C D ->
   neq A B /\ neq C D.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists E, (BetS C E D /\ Cong C E A B)) by (conclude_def Lt );destruct Tf as [E];spliter.
assert (neq C E) by (forward_using lemma_betweennotequal).
assert (neq A B) by (conclude axiom_nocollapse).
assert (neq C D) by (forward_using lemma_betweennotequal).
close.
Qed.

End Euclid.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor.
From Categories Require Import Functor.Functor_Ops.

Local Open Scope functor_scope.

Section Functor_Properties.
  Context {C C' : Category} (F : C –≻ C').

  Local Open Scope object_scope.
  Local Open Scope isomorphism_scope.
  Local Open Scope morphism_scope.

  (** A functor is said to be injective if its object map is. *)
  Definition Injective_Func := ∀ (c c' : Obj), F _o c = F _o c' → c = c'.

  (** A functor is said to be essentially injective if its object map maps
equal objects to isomorphic objects in the codomain category. *)
  Definition Essentially_Injective_Func :=
    ∀ (c c' : Obj), F _o c = F _o c' → c ≃ c'.

  (** A functor is said to be surjective if its object map is. *)
  Definition Surjective_Func := ∀ (c : Obj), {c' : Obj | F _o c' = c}.

  (** A functor is said to be essentially surjective if for each object in the
codomain category there is an aobject in the domain category that is mapped
to an aobject isomorphic to it. *)
  Definition Essentially_Surjective_Func :=
    ∀ (c : Obj), {c' : Obj & F _o c' ≃ c}.

  (** A functor is said to be faithful if its arrow map is injective. *)
  Definition Faithful_Func := ∀ (c c' : Obj) (h h' : (c –≻ c')%morphism),
      F _a h = F _a h' → h = h'.

  (** A functor is said to be full if its arrow map is surjective. *)
  Definition Full_Func :=
    ∀ (c1 c2 : Obj) (h' : ((F _o c1) –≻ (F _o c2))%morphism),
      {h : (c1 –≻ c2)%morphism | F _a h = h'}
  .

  Local Ltac Inv_FTH :=
    match goal with
      [fl : Full_Func |- _] =>
      progress (
          repeat
            match goal with
              [|- context [(F _a (proj1_sig (fl _ _ ?x)))]] =>
              rewrite (proj2_sig (fl _ _ x))
            end
        )
    end
  .

  Local Hint Extern 1 => Inv_FTH.

  Local Hint Extern 1 => rewrite F_compose.

  Local Hint Extern 1 =>
  match goal with
    [fth : Faithful_Func |- _ = _ ] => apply fth
  end
  .

  Local Obligation Tactic := basic_simpl; auto 6.

  (** Any fully-faithful functor is essentially surjective. *)
  Program Definition Fully_Faithful_Essentially_Injective
          (fth : Faithful_Func) (fl : Full_Func) : Essentially_Injective_Func
    :=
      fun c c' eq =>
        {|
          iso_morphism :=
            proj1_sig (
                fl
                  _
                  _
                  match eq in _ = y return
                        (_ –≻ y)%morphism
                  with
                    eq_refl => id (F _o c)
                  end
              );
          inverse_morphism :=
            proj1_sig (
                fl
                  _
                  _
                  match eq in _ = y return
                        (y –≻ _)%morphism
                  with
                    eq_refl => id (F _o c)
                  end
              )
        |}
  .

  (** Any fully-faithful functor is conservative.
      A conservative functor is one for which we have to objects of the domain
      category are isomorphic if their images are ismorphic. *)
  Program Definition Fully_Faithful_Conservative
          (fth : Faithful_Func) (fl : Full_Func)
    : ∀ (c c' : Obj), F _o c ≃ F _o c' → c ≃ c' :=
    fun c c' I =>
      {|
        iso_morphism := proj1_sig (fl _ _ I);
        inverse_morphism := proj1_sig (fl _ _ (I⁻¹))
      |}
  .

End Functor_Properties.

(** Functors Preserve Isomorphisms. *)
Section Functors_Preserve_Isos.
  Context {C C' : Category} (F : C –≻ C')
          {a b : C} (I : (a ≃≃ b ::> C)%isomorphism).

  Program Definition Functors_Preserve_Isos : (F _o a ≃ F _o b)%isomorphism :=
    {|
      iso_morphism := (F _a I)%morphism;
      inverse_morphism := (F _a (I⁻¹))%morphism
    |}.

End Functors_Preserve_Isos.

Section Embedding.
  Context (C C' : Category).

  (**
    An embedding is a functor that is fully-faithful. Such a functor is
    necessarily essentially injective and conservative, i.e.,
    if F _O c ≃ F _O c' then c ≃ c'.
   *)

  Record Embedding : Type :=
    {
      Emb_Func : C –≻ C';

      Emb_Faithful : Faithful_Func Emb_Func;

      Emb_Full : Full_Func Emb_Func
    }.

  Coercion Emb_Func : Embedding >-> Functor.

  Definition Emb_Essent_Inj (E : Embedding) :=
    Fully_Faithful_Essentially_Injective
      (Emb_Func E) (Emb_Faithful E) (Emb_Full E).

  Definition Emb_Conservative (E : Embedding) :=
    Fully_Faithful_Conservative
      (Emb_Func E) (Emb_Faithful E) (Emb_Full E).

End Embedding.

Arguments Emb_Func {_ _} _.
Arguments Emb_Faithful {_ _} _ {_ _} _ _ _.
Arguments Emb_Full {_ _} _ {_ _} _.


(************************************************************************)
(* Copyright 2006 Milad Niqui                                           *)
(* This file is distributed under the terms of the                      *)
(* GNU Lesser General Public License Version 2.1                        *)
(* A copy of the license can be found at                                *)
(*                  <http://www.gnu.org/licenses>                       *)
(************************************************************************)

Require Import digits.
Require Import Refining_T.
Require Import quadratic.
Require Import Streams_addenda.
Require Import rep.
Require Import RIneq.
From QArithSternBrocot Require Import R_addenda.

(** * Coinductive correctness of the quadratic algorithm. *)

(** Calculating the left and right products of [xi] and the first [n] elements of [alpha] and [beta]. *)

Fixpoint product_init_zip (xi:Tensor) (alpha beta:Reals) (n:nat) {struct n}: Tensor :=
 match n with
 | O => xi
 | S n' => right_product (left_product (product_init_zip xi alpha beta n') (Str_nth n' alpha)) (Str_nth n' beta)
 end.

Lemma product_init_zip_S:forall xi alpha beta n,
   product_init_zip xi alpha beta (S n) =
        right_product (left_product (product_init_zip xi alpha beta n) (Str_nth n alpha)) (Str_nth n beta).
Proof.
 intros xi alpha beta [|n]; trivial.
Qed.

Lemma product_init_zip_folds:forall xi alpha beta n,
   product_init_zip xi alpha beta (S n) =
       product_init_zip (right_product (left_product xi (Streams.hd alpha)) (Streams.hd beta)) (Streams.tl alpha) (Streams.tl beta) n.
Proof.
 intros xi alpha beta n; generalize xi alpha beta; clear xi alpha beta; induction n; intros xi alpha beta; simpl; trivial;
 rewrite <- IHn; rewrite product_init_zip_S; apply (f_equal2 right_product); trivial.
Defined.

Lemma product_init_zip_init_rev_id: forall xi alpha beta n,
    xi =
   (right_product (left_product (product_init_zip xi alpha beta n) (product_init_rev alpha n)) (product_init_rev beta n)).
Proof.
 intros xi alpha beta n; generalize xi alpha beta; clear xi alpha beta; induction n; intros xi alpha beta.

  unfold product_init_zip, product_init_rev; simpl; rewrite right_left_product_idM_identity_right; reflexivity.

  unfold product_init_rev; repeat rewrite rev_take_S_Str_nth; repeat rewrite fold_right_cons;
  replace (fold_right product idM (rev (take n (Streams.map inv_digit alpha)))) with (product_init_rev alpha n); trivial;
  replace (fold_right product idM (rev (take n (Streams.map inv_digit beta)))) with (product_init_rev beta n); trivial;
  repeat rewrite <- Str_nth_map_pointwise;
  rewrite product_init_zip_S; rewrite product_left_right_product_associative;
  rewrite (product_associative (map_digits (Str_nth n alpha))); rewrite product_digit_inv_digit_identity_right;
  rewrite (product_associative (map_digits (Str_nth n beta))); rewrite product_digit_inv_digit_identity_right;
  rewrite <- product_left_right_product_associative; rewrite right_left_product_idM_identity_right; apply IHn.
Qed.

Lemma product_init_zip_product_init_pure:forall xi alpha beta n,
 product_init_zip xi alpha beta n = right_product (left_product xi (product_init_pure alpha n)) (product_init_pure beta n).
Proof.
 intros xi alpha beta n; revert xi alpha beta; induction n; intros xi alpha beta; unfold product_init_pure.
  (* O *)
  simpl; rewrite right_left_product_idM_identity_right; trivial.
  (* S n *)
  repeat rewrite Streams_addenda.take_S_n;
  repeat rewrite (Streams_addenda.fold_right_cons product);
  rewrite <- product_left_right_product_associative;
  rewrite product_init_zip_folds;
  rewrite (IHn (right_product (left_product xi (Streams.hd alpha)) (Streams.hd beta)) (Streams.tl alpha) (Streams.tl beta)); trivial.
Qed.

Section depth_of_modulus_q.

Fixpoint depth_q (xi:Tensor) (alpha beta:Reals) (H1:emits_q xi alpha beta) {struct H1}:nat:=
   match Incl_T_dec_D xi LL with
   | left _ => 0
   | right H_emission_L =>
       match Incl_T_dec_D xi RR with
       | left _ => 0
       | right H_emission_R =>
           match Incl_T_dec_D xi MM with
           | left _ => 0
           | right H_emission_M =>
               S(depth_q (right_product (left_product xi (Streams.hd alpha)) (Streams.hd beta)) (Streams.tl alpha) (Streams.tl beta)
                 (emits_q_absorbs_inv xi alpha beta H_emission_L H_emission_R H_emission_M H1))
           end
       end
   end.

Lemma depth_q_PI:forall xi alpha beta H1 H2,  depth_q xi alpha beta H1 = depth_q xi alpha beta H2.
Proof.
 intros xi alpha beta H1.
 pattern alpha, beta, H1.
 elim H1 using emits_q_ind_dep;
 clear H1 xi;
   [ intros xi alpha0 beta0 i H2; generalize i
   | intros xi alpha0 beta0 i H2; generalize i
   | intros xi alpha0 beta0 i H2; generalize i
   | intros xi alpha0 beta0 f H H2; generalize f H
   ];
   pattern alpha0, beta0, H2;
   elim H2 using emits_q_ind_dep;
   first
    [ intros xi0 alpha' beta' H_primity H_primity'; simpl; case (Incl_T_dec_D xi0 LL); intro; trivial; contradiction
    | intros xi0 alpha' beta' H_primity H_primity'; simpl; case (Incl_T_dec_D xi0 RR); intro; trivial; contradiction
    | intros xi0 alpha' beta' H_primity H_primity'; simpl; case (Incl_T_dec_D xi0 MM); intro; trivial; contradiction
    | intros; contradiction]  ||
    (intro xi0; intros; simpl;
      case (Incl_T_dec_D xi0 LL); intro; contradiction ||
	case (Incl_T_dec_D xi0 RR); intro; contradiction ||
	  case (Incl_T_dec_D xi0 MM); intro; contradiction ||
	    trivial;apply eq_S; trivial).
Defined.

Lemma depth_q_PI_strong:forall xi xi' alpha beta alpha' beta' H1 H2, xi=xi'->alpha=alpha' -> beta = beta' ->
   depth_q xi alpha beta H1 = depth_q xi' alpha' beta' H2.
Proof.
 intros; subst; apply depth_q_PI.
Defined.

Lemma depth_q_L:forall (xi:Tensor) (alpha beta:Reals) (t: emits_q xi alpha beta),(Incl_T xi LL) ->
                 depth_q xi alpha beta t=0.
Proof.
 intros xi alpha beta t t_l.
 transitivity (depth_q xi alpha beta (emits_q_L _ _ _ t_l)).
 apply depth_q_PI.
 simpl;
  case (Incl_T_dec_D xi LL); try contradiction;
   intros; reflexivity.
Defined.

Lemma depth_q_R:forall (xi:Tensor) (alpha beta:Reals) (t: emits_q xi alpha beta), ~(Incl_T xi LL) ->  (Incl_T xi RR) ->
                 depth_q xi alpha beta t=0.
Proof.
 intros xi alpha beta t t_l t_r.
 transitivity (depth_q xi alpha beta (emits_q_R _ _ _ t_r)).
 apply depth_q_PI.
 simpl;
   case (Incl_T_dec_D xi LL); try contradiction;
     case (Incl_T_dec_D xi RR); try contradiction;
      intros; reflexivity.
Defined.

Lemma depth_q_M:forall (xi:Tensor) (alpha beta:Reals) (t: emits_q xi alpha beta),~(Incl_T xi LL)->~(Incl_T xi RR)->(Incl_T xi MM)->
                 depth_q xi alpha beta t=0.
Proof.
 intros xi alpha beta t t_l t_r t_m.
 transitivity (depth_q xi alpha beta (emits_q_M _ _ _ t_m)).
 apply depth_q_PI.
 simpl;
 case (Incl_T_dec_D xi LL); try contradiction;
  case (Incl_T_dec_D xi RR); try contradiction;
   case (Incl_T_dec_D xi MM); try contradiction;
    intros; reflexivity.
Defined.

Lemma depth_q_absorbs:forall (xi:Tensor) (alpha beta:Reals) (t: emits_q xi alpha beta),~(Incl_T xi LL)->~(Incl_T xi RR)->~(Incl_T xi MM)->
  forall t', depth_q xi alpha beta t = S(depth_q (right_product (left_product xi (Streams.hd alpha)) (Streams.hd beta)) (Streams.tl alpha) (Streams.tl beta) t').
Proof.
 intros xi alpha beta t t_l t_r t_m t'.
 transitivity (depth_q xi alpha beta (emits_q_absorbs _ _ _ t')).
 apply depth_q_PI.
 simpl.
 case (Incl_T_dec_D xi LL); try contradiction;
  case (Incl_T_dec_D xi RR); try contradiction;
   case (Incl_T_dec_D xi MM); try contradiction;
    intros _; reflexivity.
Defined.

Lemma depth_q_modulus_q:forall (xi:Tensor) (alpha beta:Reals) (t: emits_q xi alpha beta) n,depth_q xi alpha beta t=n->
       exists d:Digit, modulus_q xi alpha beta t =
                                     pairT d (pairT (m_product (inv_digit d) (product_init_zip xi alpha beta n))
                                                    (pairT (drop n alpha) (drop n beta))).
Proof.
 intros xi alpha beta t n H_eq.
 generalize xi alpha beta t H_eq; clear xi alpha beta t H_eq; induction n; intros xi alpha beta t H_eq.
  (* n=0 *)
  simpl.
  case (Incl_T_dec_D xi LL); intro t_l.
   exists LL; rewrite (modulus_q_L _ _ _ t t_l); trivial.
   case (Incl_T_dec_D xi RR); intro t_r.
    exists RR; rewrite (modulus_q_R _ _ _ t t_l t_r); trivial.
    case (Incl_T_dec_D xi MM); intro t_m.
     exists MM; rewrite (modulus_q_M _ _ _ t t_l t_r t_m); trivial.

     apply False_ind;
     rewrite (depth_q_absorbs xi alpha beta t t_l t_r t_m (emits_q_absorbs_inv xi alpha beta t_l t_r t_m t)) in H_eq;
     discriminate.
  (* n=S n *)
  case (Incl_T_dec_D xi LL); intro t_l.
   apply False_ind; rewrite (depth_q_L xi alpha beta t t_l) in H_eq; discriminate.
   case (Incl_T_dec_D xi RR); intro t_r.
    apply False_ind; rewrite (depth_q_R xi alpha beta t t_l t_r) in H_eq; discriminate.
    case (Incl_T_dec_D xi MM); intro t_m.
     apply False_ind; rewrite (depth_q_M xi alpha beta t t_l t_r t_m) in H_eq; discriminate.

     rewrite (depth_q_absorbs xi alpha beta t t_l t_r t_m (emits_q_absorbs_inv xi alpha beta t_l t_r t_m t)) in H_eq.
     destruct (IHn _ _ _ _ (eq_add_S _ _ H_eq)) as [d H_ind]; exists d.
     rewrite (modulus_q_absorbs xi alpha beta t t_l t_r t_m (emits_q_absorbs_inv xi alpha beta t_l t_r t_m t)).
     rewrite H_ind.
     apply (@f_equal2 _ _ _ (@pairT Digit (@prodT Tensor (@prodT Reals Reals)))); trivial;
     apply (@f_equal2 _ _ _ (@pairT Tensor (@prodT Reals Reals))); trivial.
     rewrite product_init_zip_folds; trivial.
     destruct alpha; destruct beta; reflexivity.
Defined.

Lemma depth_q_Incl_T_inf_strong : forall xi alpha beta (t: emits_q xi alpha beta) n, depth_q xi alpha beta t = n ->
        {Incl_T (product_init_zip xi alpha beta n) LL/\ fst (modulus_q xi alpha beta t)=LL}+
        {Incl_T (product_init_zip xi alpha beta n) RR/\ fst (modulus_q xi alpha beta t)=RR}+
        {Incl_T (product_init_zip xi alpha beta n) MM/\ fst (modulus_q xi alpha beta t)=MM}.
Proof.
 intros xi alpha beta t n H_eq.
 generalize xi alpha beta t H_eq.
 clear xi alpha beta t H_eq.
 induction n; intros xi alpha beta t H_eq.
  case (Incl_T_dec_D xi LL); intro t_l.
   left; left; split; trivial; rewrite (modulus_q_L _ _ _ t t_l); trivial.
   case (Incl_T_dec_D xi RR); intro t_r.
    left; right; split; trivial; rewrite (modulus_q_R _ _ _ t t_l t_r); trivial.
    case (Incl_T_dec_D xi MM); intro t_m.
    right; split; trivial; rewrite (modulus_q_M _ _ _ t t_l t_r t_m); trivial...

    apply False_rec;
    rewrite (depth_q_absorbs xi alpha beta t t_l t_r t_m (emits_q_absorbs_inv xi alpha beta t_l t_r t_m t)) in H_eq;
    discriminate...

  case (Incl_T_dec_D xi LL); intro t_l.
   apply False_rec; rewrite (depth_q_L xi alpha beta t t_l) in H_eq; discriminate.
   case (Incl_T_dec_D xi RR); intro t_r.
    apply False_rec; rewrite (depth_q_R xi alpha beta t t_l t_r) in H_eq; discriminate.
     case (Incl_T_dec_D xi MM); intro t_m.
     apply False_rec; rewrite (depth_q_M xi alpha beta t t_l t_r t_m) in H_eq; discriminate.

     rewrite (depth_q_absorbs xi alpha beta t t_l t_r t_m (emits_q_absorbs_inv xi alpha beta t_l t_r t_m t)) in H_eq.
     rewrite product_init_zip_folds.
     destruct (IHn _ _ _ _ (eq_add_S _ _ H_eq)) as  [[[H_Incl H_modulus]|[H_Incl H_modulus]]|[H_Incl H_modulus]];
     [ left; left
     | left; right
     | right
     ]; split; trivial;
     rewrite <- H_modulus;
     apply (f_equal (@fst Digit (Tensor*(Reals*Reals))));
     rewrite (modulus_q_absorbs _ _ _ t t_l t_r t_m (emits_q_absorbs_inv xi alpha beta t_l t_r t_m t)); trivial.
Defined.

Lemma depth_q_Incl_T_inf_strong_general
     : forall (xi : Tensor) (alpha beta: Reals) (t : emits_q xi alpha beta) (n : nat),
       depth_q xi alpha beta t = n ->
           exists d,Incl_T (product_init_zip xi alpha beta n) d /\ fst (modulus_q xi alpha beta t) = d.
Proof.
 intros xi alpha beta t n H_depth.
 destruct (depth_q_Incl_T_inf_strong _ _ _ t n H_depth) as [[Hd|Hd]|Hd];
  [ exists LL
  | exists RR
  | exists MM
  ]; assumption.
Qed.

End depth_of_modulus_q.

Lemma quadratic_emits_strong: forall xi alpha beta (p:productive_q xi alpha beta),
      exists n,
       (exists d:Digit,
               productive_q (m_product (inv_digit d) (product_init_zip xi alpha beta n)) (drop n alpha) (drop n beta) /\
	       Incl_T (product_init_zip xi alpha beta n) d/\
	       forall p', bisim (quadratic xi alpha beta p)
       (Cons d (quadratic (m_product (inv_digit d) (product_init_zip xi alpha beta n)) (drop n alpha) (drop n beta) p'))).
Proof.
 intros xi alpha beta H_productive.
 generalize (productive_q_emits_q xi alpha beta H_productive); intro H_emits.

 exists (depth_q xi alpha beta H_emits).
 destruct (depth_q_modulus_q xi alpha beta H_emits (depth_q xi alpha beta H_emits) (refl_equal _)) as [d H_modulus].
 exists d; split.
  generalize (modulus_q_productive_q xi alpha beta H_emits H_productive); rewrite H_modulus; trivial.
  split.

   destruct (depth_q_Incl_T_inf_strong _ _ _ H_emits (depth_q xi alpha beta H_emits) (refl_equal _)) as
         [[[H_Incl H_modulus']|[H_Incl H_modulus']]|[H_Incl H_modulus']];
    rewrite H_modulus in H_modulus'; simpl in H_modulus'; rewrite H_modulus'; assumption...

   intros H_productive'.
   rewrite (quadratic_unfolded xi alpha beta H_productive);
   constructor; simpl;
   [ idtac
   | apply quadratic_EPI_strong
   ];
   rewrite <- (modulus_q_PI _ _ _ H_emits (productive_q_emits_q xi alpha beta H_productive));
   rewrite H_modulus;
   trivial.
Defined.

Theorem quadratic_correctness : forall (xi:Tensor) (alpha beta:Reals) (H:productive_q xi alpha beta) (r1 r2:Rdefinitions.R),
     rep alpha r1 ->  rep beta r2-> rep (quadratic xi alpha beta H) (as_Tensor xi r1 r2).
Proof.
 cofix.
 intros xi alpha beta H_productive r1 r2 Hr1_alpha Hr2_beta;
 destruct (quadratic_emits_strong xi alpha beta H_productive) as [n [[ | | ] [H_productive_dropped [H_Incl H_bis]]]];
 unfold inv_digit in H_bis; unfold inv_digit;
 generalize (H_bis H_productive_dropped); clear H_bis; intro H_bis.
  (* L *)
  replace (as_Tensor xi r1 r2) with (as_Tensor (m_product LL (m_product inv_LL xi)) r1 r2);
  [ idtac | rewrite <- m_product_inv_L;  reflexivity];
  replace (m_product inv_LL xi) with (m_product inv_LL
  (right_product (left_product (product_init_zip xi alpha beta n) (product_init_rev alpha n)) (product_init_rev beta n)));
  [ idtac | rewrite <- product_init_zip_init_rev_id; trivial].

  assert (H_base: (-1<=as_Tensor (m_product inv_LL (right_product (left_product (product_init_zip xi alpha beta n)
                                 (product_init_rev alpha n)) (product_init_rev beta n))) r1 r2 <= 1)%R).
   rewrite m_product_left_right_product_associative.
   rewrite as_Tensor_right_left_product_as_Moebius.
    apply Is_refining_T_property;
     try (apply rep_drop_in_range; assumption).
     replace inv_LL with (inv_digit LL); trivial; apply Incl_T_absorbs_Is_refining_T; assumption.
    apply denom_nonvanishing_product_init; assumption.
    apply denom_nonvanishing_product_init; assumption.
    apply rep_drop_in_range; assumption.
    apply rep_drop_in_range; assumption.
    replace inv_LL with (inv_digit LL); trivial; apply Incl_T_absorbs_Is_refining_T; assumption.

  rewrite as_Tensor_L; try exact H_base.
   refine
     (rep_L
       (quadratic (m_product inv_LL (product_init_zip xi alpha beta n)) (drop n alpha) (drop n beta) H_productive_dropped)
       _ _ _ _ H_bis).

    exact H_base.

    rewrite m_product_left_right_product_associative;
    rewrite as_Tensor_right_left_product_as_Moebius.
     apply quadratic_correctness;
     [ apply (rep_drop _ _ n Hr1_alpha)
     | apply (rep_drop _ _ n Hr2_beta)
     ].
     apply denom_nonvanishing_product_init; assumption.
     apply denom_nonvanishing_product_init; assumption.
     apply rep_drop_in_range; assumption.
     apply rep_drop_in_range; assumption.
     replace inv_LL with (inv_digit LL); trivial; apply Incl_T_absorbs_Is_refining_T; assumption.
   rewrite m_product_left_right_product_associative; apply denom_nonvanishing_T_left_right_product.
    apply denom_nonvanishing_product_init; assumption.
    apply denom_nonvanishing_product_init; assumption.
    apply rep_drop_in_range; assumption.
    apply rep_drop_in_range; assumption.
    replace inv_LL with (inv_digit LL); trivial; apply Incl_T_absorbs_Is_refining_T; assumption.
  (* R *)
  replace (as_Tensor xi r1 r2) with (as_Tensor (m_product RR (m_product inv_RR xi)) r1 r2);
  [ idtac | rewrite <- m_product_inv_R;  reflexivity];
  replace (m_product inv_RR xi) with (m_product inv_RR
  (right_product (left_product (product_init_zip xi alpha beta n) (product_init_rev alpha n)) (product_init_rev beta n)));
  [ idtac | rewrite <- product_init_zip_init_rev_id; trivial].

  assert (H_base: (-1<=as_Tensor (m_product inv_RR (right_product (left_product (product_init_zip xi alpha beta n)
                                 (product_init_rev alpha n)) (product_init_rev beta n))) r1 r2 <= 1)%R).
   rewrite m_product_left_right_product_associative.
   rewrite as_Tensor_right_left_product_as_Moebius.
    apply Is_refining_T_property;
     try (apply rep_drop_in_range; assumption).
     replace inv_RR with (inv_digit RR); trivial; apply Incl_T_absorbs_Is_refining_T; assumption.
    apply denom_nonvanishing_product_init; assumption.
    apply denom_nonvanishing_product_init; assumption.
    apply rep_drop_in_range; assumption.
    apply rep_drop_in_range; assumption.
    replace inv_RR with (inv_digit RR); trivial; apply Incl_T_absorbs_Is_refining_T; assumption.

  rewrite as_Tensor_R; try exact H_base.
   refine
     (rep_R
       (quadratic (m_product inv_RR (product_init_zip xi alpha beta n)) (drop n alpha) (drop n beta) H_productive_dropped)
       _ _ _ _ H_bis).

    exact H_base.

    rewrite m_product_left_right_product_associative;
    rewrite as_Tensor_right_left_product_as_Moebius.
     apply quadratic_correctness;
     [ apply (rep_drop _ _ n Hr1_alpha)
     | apply (rep_drop _ _ n Hr2_beta)
     ].
     apply denom_nonvanishing_product_init; assumption.
     apply denom_nonvanishing_product_init; assumption.
     apply rep_drop_in_range; assumption.
     apply rep_drop_in_range; assumption.
     replace inv_RR with (inv_digit RR); trivial; apply Incl_T_absorbs_Is_refining_T; assumption.
   rewrite m_product_left_right_product_associative; apply denom_nonvanishing_T_left_right_product.
    apply denom_nonvanishing_product_init; assumption.
    apply denom_nonvanishing_product_init; assumption.
    apply rep_drop_in_range; assumption.
    apply rep_drop_in_range; assumption.
    replace inv_RR with (inv_digit RR); trivial; apply Incl_T_absorbs_Is_refining_T; assumption.
  (* M *)
  replace (as_Tensor xi r1 r2) with (as_Tensor (m_product MM (m_product inv_MM xi)) r1 r2);
  [ idtac | rewrite <- m_product_inv_M;  reflexivity];
  replace (m_product inv_MM xi) with (m_product inv_MM
  (right_product (left_product (product_init_zip xi alpha beta n) (product_init_rev alpha n)) (product_init_rev beta n)));
  [ idtac | rewrite <- product_init_zip_init_rev_id; trivial].

  assert (H_base: (-1<=as_Tensor (m_product inv_MM (right_product (left_product (product_init_zip xi alpha beta n)
                                 (product_init_rev alpha n)) (product_init_rev beta n))) r1 r2 <= 1)%R).
   rewrite m_product_left_right_product_associative.
   rewrite as_Tensor_right_left_product_as_Moebius.
    apply Is_refining_T_property;
     try (apply rep_drop_in_range; assumption).
     replace inv_MM with (inv_digit MM); trivial; apply Incl_T_absorbs_Is_refining_T; assumption.
    apply denom_nonvanishing_product_init; assumption.
    apply denom_nonvanishing_product_init; assumption.
    apply rep_drop_in_range; assumption.
    apply rep_drop_in_range; assumption.
    replace inv_MM with (inv_digit MM); trivial; apply Incl_T_absorbs_Is_refining_T; assumption.

  rewrite as_Tensor_M; try exact H_base.
   refine
     (rep_M
       (quadratic (m_product inv_MM (product_init_zip xi alpha beta n)) (drop n alpha) (drop n beta) H_productive_dropped)
       _ _ _ _ H_bis).

    exact H_base.

    rewrite m_product_left_right_product_associative;
    rewrite as_Tensor_right_left_product_as_Moebius.
     apply quadratic_correctness;
     [ apply (rep_drop _ _ n Hr1_alpha)
     | apply (rep_drop _ _ n Hr2_beta)
     ].
     apply denom_nonvanishing_product_init; assumption.
     apply denom_nonvanishing_product_init; assumption.
     apply rep_drop_in_range; assumption.
     apply rep_drop_in_range; assumption.
     replace inv_MM with (inv_digit MM); trivial; apply Incl_T_absorbs_Is_refining_T; assumption.
   rewrite m_product_left_right_product_associative; apply denom_nonvanishing_T_left_right_product.
    apply denom_nonvanishing_product_init; assumption.
    apply denom_nonvanishing_product_init; assumption.
    apply rep_drop_in_range; assumption.
    apply rep_drop_in_range; assumption.
    replace inv_MM with (inv_digit MM); trivial; apply Incl_T_absorbs_Is_refining_T; assumption.
Defined.


Require Import init.

Require Export analysis_base.
Require Import analysis_topology.
Require Import order_minmax.

Definition cauchy_seq {U} `{Metric U} (f : sequence U) :=
    ∀ ε, 0 < ε → ∃ N, ∀ i j, N ≤ i → N ≤ j → d (f i) (f j) < ε.

Definition complete U `{Metric U} := ∀ f, cauchy_seq f → seq_converges f.

Definition seq_bounded {U} `{Metric U} (f : nat → U)
    := ∃ M, ∀ m n, d (f m) (f n) ≤ M.
(* begin hide *)

Section AnalysisSequence.

Context {U} `{Metric U}.
(* end hide *)

Theorem metric_seq_lim : ∀ f x, seq_lim f x ↔
    ∀ ε, 0 < ε → ∃ N, ∀ n, N ≤ n → d x (f n) < ε.
Proof.
    intros f x.
    rewrite basis_seq_lim.
    split.
    -   intros lim ε ε_pos.
        pose proof (open_ball_basis x [ε|ε_pos]) as x_basis.
        pose proof (open_ball_self x [ε|ε_pos]) as x_in.
        exact (lim _ x_basis x_in).
    -   intros lim S S_basis Sx.
        destruct S_basis as [z [ε eq]]; subst S.
        pose proof (open_ball_ex _ _ _ Sx) as [δ sub].
        specialize (lim [δ|] [|δ]) as [N lim].
        exists N.
        intros n n_gt.
        apply sub.
        apply lim.
        exact n_gt.
Qed.

Theorem metric_seq_closure : ∀ (A : U → Prop) x,
    (∃ f, (∀ n, A (f n)) ∧ seq_lim f x) ↔ closure A x.
Proof.
    intros A x.
    split.
    -   intros [f [Af lim]].
        exact (seq_closure A x f Af lim).
    -   intros Ax.
        assert (∀ n, 0 < / from_nat (nat_suc n)) as n_pos.
        {
            intros n.
            apply div_pos.
            rewrite <- homo_zero.
            rewrite <- homo_lt2.
            apply nat_pos2.
        }
        pose (B n := open_ball x [_|n_pos n]).
        assert (∀ n, ∃ a, B n a ∧ A a) as f_ex.
        {
            intros n.
            rewrite in_closure in Ax.
            assert (open (B n)) as B_open.
            {
                unfold B.
                apply open_ball_open.
            }
            assert (B n x) as Bnx by apply open_ball_self.
            specialize (Ax (B n) B_open Bnx).
            apply empty_neq in Ax as [a a_in].
            rewrite inter_comm in a_in.
            exists a.
            exact a_in.
        }
        exists (λ n, ex_val (f_ex n)).
        split.
        +   intros n.
            rewrite_ex_val a a_in.
            apply a_in.
        +   rewrite metric_seq_lim.
            intros ε ε_pos.
            pose proof (archimedean2 _ ε_pos) as [N N_lt].
            exists N.
            intros n n_gt.
            rewrite_ex_val a a_in.
            destruct a_in as [Bna Aa].
            unfold B in Bna.
            apply (trans2 N_lt).
            rewrite <- nat_sucs_le in n_gt.
            rewrite (homo_le2 (f := from_nat)) in n_gt.
            apply le_div_pos in n_gt.
            2: apply from_nat_pos.
            apply (lt_le_trans2 n_gt).
            exact Bna.
Qed.

Theorem metric_seq_closed :
    ∀ A, closed A ↔ (∀ f x, (∀ n, A (f n)) → seq_lim f x → A x).
Proof.
    intros A.
    split.
    -   intros A_closed f x Af fx.
        apply closed_if_closure in A_closed.
        rewrite A_closed.
        exact (seq_closure A x f Af fx).
    -   intros all_f.
        apply closed_if_closure.
        apply antisym; try apply closure_sub.
        intros x Ax.
        apply metric_seq_closure in Ax.
        destruct Ax as [f [all_n f_seq]].
        exact (all_f f x all_n f_seq).
Qed.

Theorem converges_cauchy : ∀ f, seq_converges f → cauchy_seq f.
Proof.
    intros f [x fx] ε ε_pos.
    pose proof (half_pos ε_pos) as ε2_pos.
    rewrite metric_seq_lim in fx.
    specialize (fx _ ε2_pos) as [N fx].
    exists N.
    intros i j i_gt j_gt.
    pose proof (lt_lrplus (fx i i_gt) (fx j j_gt)) as ltq.
    rewrite plus_half in ltq.
    apply (le_lt_trans2 ltq).
    rewrite (d_sym x).
    apply d_tri.
Qed.

Theorem limit_point_seq_ex :
    ∀ X x, limit_point X x → ∃ f, (∀ n, X (f n) ∧ x ≠ f n) ∧ seq_lim f x.
Proof.
    intros X x x_lim.
    assert (∀ n, ∃ a, open_ball x [_|real_n_div_pos n] a ∧ X a ∧ x ≠ a) as f_ex.
    {
        intros n.
        unfold limit_point in x_lim.
        specialize (x_lim (open_ball x [_|real_n_div_pos n])).
        specialize (x_lim (open_ball_open _ _) (open_ball_self _ _)).
        apply empty_neq in x_lim.
        destruct x_lim as [a [[Xa nxa] a_in]].
        exists a.
        rewrite singleton_eq in nxa.
        split; [>|split]; assumption.
    }
    exists (λ n, ex_val (f_ex n)).
    split.
    -   intros n.
        rewrite_ex_val a a_H.
        split; apply a_H.
    -   rewrite metric_seq_lim.
        intros ε ε_pos.
        pose proof (archimedean2 ε ε_pos) as [N N_lt].
        exists N.
        intros m m_geq.
        rewrite_ex_val b b_H.
        destruct b_H as [b_in [Xb xb]].
        unfold open_ball in b_in; cbn in b_in.
        apply (trans b_in).
        apply (le_lt_trans2 N_lt).
        apply le_div_pos.
        1: apply from_nat_pos.
        change (1 + from_nat m) with (from_nat (U := real) (nat_suc m)).
        rewrite <- homo_le2.
        rewrite nat_sucs_le.
        exact m_geq.
Qed.

Theorem cauchy_subseq_converge :
    ∀ a b x, cauchy_seq a → subsequence a b → seq_lim b x → seq_lim a x.
Proof.
    intros a b x a_cauchy [f [f_sub ab_eq]] b_lim.
    rewrite metric_seq_lim in *.
    intros ε ε_pos.
    pose proof (half_pos ε_pos) as ε2_pos.
    specialize (b_lim (ε / 2) ε2_pos) as [N1 b_lim].
    specialize (a_cauchy (ε / 2) ε2_pos) as [N2 a_cauchy].
    exists (max N1 N2).
    intros n n_geq.
    specialize (b_lim n (trans (lmax N1 N2) n_geq)).
    rewrite <- ab_eq in b_lim.
    pose proof (subsequence_seq_leq f f_sub n) as fn_leq.
    apply (trans n_geq) in fn_leq.
    apply (trans (rmax N1 N2)) in n_geq, fn_leq.
    specialize (a_cauchy (f n) n fn_leq n_geq).
    pose proof (lt_lrplus b_lim a_cauchy) as ltq.
    rewrite plus_half in ltq.
    apply (le_lt_trans2 ltq).
    apply d_tri.
Qed.

(* begin hide *)
Open Scope card_scope.
(* end hide *)
Theorem cauchy_bounded : ∀ a, cauchy_seq a → seq_bounded a.
Proof.
    intros a a_cauchy.
    specialize (a_cauchy 1 one_pos) as [N a_cauchy].
    classic_case (0 = N) as [N_z|N_nz].
    {
        exists 1.
        intros i j.
        subst N.
        apply a_cauchy; apply nat_pos.
    }
    pose (S m := ∃ i j, i < 1 + N ∧ j < 1 + N ∧ m = d (a i) (a j)).
    assert (finite (|set_type S|)) as S_fin.
    {
        unfold finite.
        apply (le_lt_trans2 (nat_is_finite ((1 + N)*(1 + N)))).
        rewrite <- nat_to_card_mult.
        unfold mult, le, nat_to_card; equiv_simpl.
        pose (to_i (x : set_type S) := ex_val [|x]).
        pose (to_j (x : set_type S) := ex_val (ex_proof [|x])).
        pose (to_i_lt (x : set_type S)
            := land (ex_proof (ex_proof [|x]))).
        pose (to_j_lt (x : set_type S)
            := land (rand (ex_proof (ex_proof [|x])))).
        exists (λ x : set_type S, ([to_i x|to_i_lt x], [to_j x|to_j_lt x])).
        split.
        intros x y eq.
        inversion eq as [[eq1 eq2]].
        clear eq to_i_lt to_j_lt.
        unfold to_i, to_j in *.
        unfold ex_val in eq1 at 1; unfold ex_proof in eq2 at 1.
        destruct (ex_to_type _) as [i C0]; cbn in *.
        rewrite_ex_val j [i_lt [j_lt x_eq]]; clear C0.
        unfold ex_val in eq1; unfold ex_proof in eq2.
        destruct (ex_to_type _) as [i' C0]; cbn in *.
        rewrite_ex_val j' [i'_lt [j'_lt y_eq]]; clear C0.
        subst i' j'.
        apply set_type_eq.
        rewrite x_eq, y_eq.
        reflexivity.
    }
    assert (∃ x, S x) as S_ex.
    {
        exists (d (a 0) (a 0)). (* Really just zero, but this is simpler. *)
        exists 0, 0.
        split.
        2: split.
        1, 2: split; try apply nat_pos.
        1, 2: intros contr; inversion contr.
        reflexivity.
    }
    pose proof (finite_well_ordered_set_max S S_fin S_ex) as [M[Sm M_greatest]].
    assert (∀ i j, i < 1 + N → j < 1 + N → d (a i) (a j) < M + 1) as lem1.
    {
        intros i j i_lt j_lt.
        pose proof one_pos as ltq.
        apply lt_lplus with M in ltq.
        rewrite plus_rid in ltq.
        apply (le_lt_trans2 ltq).
        apply M_greatest.
        exists i, j.
        split.
        2: split.
        -   exact i_lt.
        -   exact j_lt.
        -   reflexivity.
    }
    assert (∀ i j, 1 + N ≤ i → j < 1 + N → d (a i) (a j) < M + 1) as lem2.
    {
        intros i j i_ge j_lt.
        pose proof (trans (nat_le_suc N) i_ge) as i_ge2.
        specialize (a_cauchy _ _ i_ge2 (refl N)).
        assert (d (a N) (a j) ≤ M) as leq.
        {
            apply M_greatest.
            exists N, j.
            split.
            2: split.
            -   apply nat_lt_suc.
            -   exact j_lt.
            -   reflexivity.
        }
        pose proof (le_lt_lrplus leq a_cauchy) as ltq.
        clear - ltq.
        apply (le_lt_trans2 ltq).
        rewrite plus_comm.
        apply d_tri.
    }
    assert (∀ i j, 1 + N ≤ i → 1 + N ≤ j → d (a i) (a j) < M + 1) as lem3.
    {
        intros i j i_ge j_ge.
        assert (N ≤ i) as i_ge2.
        {
            apply (trans2 i_ge).
            apply nat_le_suc.
        }
        assert (N ≤ j) as j_ge2.
        {
            apply (trans2 j_ge).
            apply nat_le_suc.
        }
        specialize (a_cauchy i j i_ge2 j_ge2).
        apply (lt_le_trans a_cauchy).
        rewrite <- (plus_lid 1) at 1.
        apply le_rplus.
        apply M_greatest.
        exists 0, 0.
        split.
        2: split.
        1, 2: apply nat_pos2.
        rewrite d_zero.
        reflexivity.
    }
    exists (M + 1).
    intros i j.
    classic_case (i < 1 + N) as [i_lt|i_ge];
    classic_case (j < 1 + N) as [j_lt|j_ge].
    -   apply lem1; assumption.
    -   rewrite nlt_le in j_ge.
        rewrite d_sym.
        apply lem2; assumption.
    -   rewrite nlt_le in i_ge.
        apply lem2; assumption.
    -   rewrite nlt_le in i_ge, j_ge.
        apply lem3; assumption.
Qed.
(* begin hide *)

Close Scope card_scope.

End AnalysisSequence.
(* end hide *)


(*
  Author(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

Require Import List Lia.
Import ListNotations.
Require Import Undecidability.SystemF.SysF Undecidability.SystemF.Autosubst.syntax Undecidability.SystemF.Autosubst.unscoped.
Import UnscopedNotations.
Require Import Undecidability.SystemF.Util.Facts Undecidability.SystemF.Util.poly_type_facts.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

(* evaluates predicate p on all free variables *)
Fixpoint allfv_pure_term (p: nat -> Prop) (M: pure_term) :=
  match M with
  | pure_var x => p x
  | pure_app M N => allfv_pure_term p M /\ allfv_pure_term p N
  | pure_abs M => allfv_pure_term (scons True p) M
  end.

Lemma allfv_pure_term_impl {p1 p2: nat -> Prop} {M}:
  (forall x, p1 x -> p2 x) -> allfv_pure_term p1 M -> allfv_pure_term p2 M.
Proof.
  elim: M p1 p2.
  - move=> >. by apply.
  - by move=> ? IH1 ? IH2 > /= /copy [/IH1 {}IH1 /IH2 {}IH2] [/IH1 ? /IH2 ?].
  - move=> > IH > H /=. apply: IH. by case.
Qed.

Lemma allfv_pure_term_ren_pure_term {p ξ M} :
  allfv_pure_term p (ren_pure_term ξ M) <-> allfv_pure_term (ξ >> p) M.
Proof.
  elim: M ξ p.
  - done.
  - move=> ? IH1 ? IH2 > /=. by rewrite IH1 IH2.
  - move=> ? IH > /=. rewrite IH. constructor; apply: allfv_pure_term_impl; by case.
Qed.

Lemma allfv_pure_term_TrueI {p: nat -> Prop} {M} : (forall x, p x) -> allfv_pure_term p M.
Proof.
  move=> Hp. elim: M.
  - move=> > /=. by apply: Hp.
  - by move=> ? + ? + /=.
  - move=> ? /=. apply: allfv_pure_term_impl. case; first done.
    move=> *. by apply: Hp.
Qed.

Lemma ren_pure_term_id {M} : ren_pure_term id M = M.
Proof.
  elim: M.
  - done.
  - move=> /=. congruence.
  - move=> /=. rewrite /upRen_pure_term_pure_term.
    move=> > ?. under extRen_pure_term => ? do rewrite up_ren_id. by congruence.
Qed.

Lemma ren_pure_term_id' {ξ M} : (forall x, ξ x = x) -> ren_pure_term ξ M = M.
Proof. move=> ?. rewrite -[RHS]ren_pure_term_id. by apply: extRen_pure_term. Qed.

Fixpoint pure_var_bound (M: pure_term) :=
  match M with
  | pure_var x => 1 + x
  | pure_app M N => 1 + pure_var_bound M + pure_var_bound N
  | pure_abs M => 1 + pure_var_bound M
  end.

Lemma pure_var_boundP M : allfv_pure_term (gt (pure_var_bound M)) M.
Proof.
  elim: M.
  - move=> /=. by lia.
  - move=> ? IH1 ? IH2 /=. constructor; [move: IH1 | move: IH2]; apply: allfv_pure_term_impl; by lia.
  - move=> ? /=. apply: allfv_pure_term_impl. case; first done. move=> /=. by lia.
Qed.


(**************************************************************)
(*   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 as list bool *)

Require Import List Lia Bool Setoid.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac.

Set Implicit Arguments.

(* Section lb. *)

  Local Reserved Notation "x ⪯ y" (at level 70, no associativity).
  Local Reserved Notation "x ⟂ y" (at level 70, no associativity).
  Local Reserved Notation "x ↓ y" (at level 40, left associativity).
  Local Reserved Notation "x ↑ y" (at level 41, left associativity).

  Local Notation lb := (list bool).
  Local Notation "⟘" := false.
  Local Notation "⟙" := true.
  Local Infix "⪦" := Bool.le (at level 70, no associativity).

  Fact leb_refl : forall x, x ⪦ x.
  Proof. intros []; simpl; auto. Qed.

  Fact leb_trans : forall x y z, x ⪦ y -> y ⪦ z -> x ⪦ z.
  Proof. intros [] [] []; simpl; auto. Qed.

  Fact leb_strict : ⟘ ⪦ ⟙.
  Proof. exact I. Qed.

  #[export] Hint Resolve leb_refl leb_trans leb_strict : core.

  (* We develop the Boolean algebra of lists of Booleans *)

  (* The masking relation *)

  Inductive lb_mask : lb -> lb -> Prop :=
    | in_lb_mask_0 : forall l,                            nil ⪯ l
    | in_lb_mask_1 : forall l,                l ⪯ nil -> ⟘::l ⪯  nil
    | in_lb_mask_2 : forall x y l m, x ⪦ y -> l ⪯ m   -> x::l ⪯  y::m
  where "l ⪯ m" := (lb_mask l m).

  Fact lb_mask_inv_nil l : ⟘::l ⪯  nil -> l ⪯  nil.
  Proof. inversion 1; auto. Qed.

  Fact lb_mask_inv_left x l : x::l ⪯  nil -> x = ⟘ /\ l ⪯  nil.
  Proof. inversion 1; auto. Qed.

  Fact lb_mask_inv_cons x y l m : x::l ⪯ y::m -> Bool.le x y /\ l ⪯  m.
  Proof. inversion 1; tauto. Qed.

  Fact lb_mask_inv_cons_nil l : ⟙::l ⪯ nil -> False.
  Proof. inversion 1. Qed.

  Fact lb_mask_inv_cons_cons l m : ⟙::l ⪯ ⟘::m -> False.
  Proof.
    intros H; apply lb_mask_inv_cons, proj1 in H; discriminate.
  Qed.

  Definition lb_mask_leb := in_lb_mask_2.

  Fact lb_mask_refl l : l ⪯ l.
  Proof. induction l as [ | [] ]; constructor; simpl; auto. Qed.

  Fact lb_mask_trans l m k : l ⪯ m -> m ⪯ k -> l ⪯ k.
  Proof.
    intros H1; revert H1 k.
    induction 1 as [ l | l H1 IH1 | x y l m H1 IH1 ].
    + intros; constructor.
    + intros [ | z k ] Hk.
      * constructor; auto.
      * constructor; simpl; auto; apply IH1; constructor.
    + intros [ | z k ] Hk.
      * apply lb_mask_inv_left in Hk; destruct Hk as (? & Hk); subst y.
        destruct x; simpl in H1; try discriminate.
        constructor; auto.
      * apply lb_mask_inv_cons in Hk.
        destruct Hk as (H2 & Hk).
        constructor; auto.
        revert x y z H1 H2.
        intros [] [] []; simpl; auto.
  Qed.

  #[export] Hint Resolve lb_mask_refl lb_mask_trans : core.

  Definition lb_mask_equiv l m := l ⪯ m /\ m ⪯ l.

  Local Infix "≂" := lb_mask_equiv (at level 70, no associativity).

  Fact lb_mask_equiv_refl l : l ≂ l.
  Proof. split; auto. Qed.

  Fact lb_mask_equiv_sym l m : l ≂ m -> m ≂ l.
  Proof. intros []; split; auto. Qed.

  Fact lb_mask_equiv_trans l m k : l ≂ m -> m ≂ k -> l ≂ k.
  Proof. intros [] []; split; eauto. Qed.

  #[export] Hint Resolve in_lb_mask_0 lb_mask_refl lb_mask_equiv_refl : core.

  Add Parametric Relation: (lb) (lb_mask_equiv)
      reflexivity proved by  lb_mask_equiv_refl
      symmetry proved by     lb_mask_equiv_sym
      transitivity proved by lb_mask_equiv_trans
    as lb_mask_equiv_rst.

  Local Notation lbeq := lb_mask_equiv (only parsing).

  Add Parametric Morphism: (lb_mask) with signature (lbeq) ==> (lbeq) ==> (iff) as lb_mask_le_iff.
  Proof.
    intros x1 y1 (H1 & H2) x2 y2 (H3 & H4); split; intros H5.
    + apply lb_mask_trans with (1 := H2), lb_mask_trans with (1 := H5); auto.
    + apply lb_mask_trans with (1 := H1), lb_mask_trans with (1 := H5); auto.
  Qed.

  Add Parametric Morphism: (@cons bool) with signature (eq) ==> (lbeq) ==> (lbeq) as lb_mask_equiv_cons.
  Proof.
    intros [] ? ? []; split; apply lb_mask_leb; simpl; auto.
  Qed.

  Fact lb_mask_app l m a b : length l = length m -> l ⪯ m -> a ⪯ b -> l++a ⪯ m++b.
  Proof.
    revert m; induction l as [ | x l IHl ]; intros [ | y m ]; try discriminate; auto;
      simpl; intros H H1 H2.
    apply lb_mask_inv_cons in H1; destruct H1 as (H1 & H3).
    constructor 3; auto.
  Qed.

  Fact lb_mask_equiv_app l m a b : length l = length m -> l ≂ m -> a ≂ b -> l++a ≂ m++b.
  Proof.
    intros H (? & ?) (? & ?); split; apply lb_mask_app; auto.
  Qed.

  Inductive lb_ortho : lb -> lb -> Prop :=
    | in_lb_ortho_0 : forall l, nil ⟂ l
    | in_lb_ortho_1 : forall l, l ⟂ nil
    | in_lb_ortho_2 : forall x y l m, (x = ⟘ \/ y = ⟘) -> l ⟂ m -> x::l ⟂ y::m
  where "x ⟂ y" := (lb_ortho x y).

  #[export] Hint Constructors lb_ortho : core.

  Fact lb_ortho_cons_inv x y l m : x::l ⟂ y::m -> (x = ⟘ \/ y = ⟘) /\ l ⟂ m.
  Proof. inversion 1; auto. Qed.

  Fact lb_ortho_anti_left a b x : a ⪯ b -> b ⟂ x -> a ⟂ x.
  Proof.
    intros H; revert H x.
    induction 1 as [ l | m H1 IH1 | x y l m H1 H2 IH2  ]; intros z H3; try (constructor; fail);
      destruct z as [ | v z ]; try (constructor; fail).
    + constructor; auto; apply IH1; constructor.
    + apply lb_ortho_cons_inv in H3.
      destruct H3 as (H3 & H4).
      constructor; auto.
      revert x y v H1 H3.
      intros [] [] []; simpl; auto.
  Qed.

  Fact lb_ortho_sym a b : a ⟂ b -> b ⟂ a.
  Proof. induction 1; constructor; tauto. Qed.

  Fact lb_ortho_anti a b x y : a ⪯ b -> x ⪯ y -> b ⟂ y -> a ⟂ x.
  Proof.
    intros H1 H2 H3.
    apply lb_ortho_anti_left with (1 := H1), lb_ortho_sym,
          lb_ortho_anti_left with (1 := H2), lb_ortho_sym.
    trivial.
  Qed.

  Add Parametric Morphism: (lb_ortho) with signature (lbeq) ==> (lbeq) ==> (iff) as lb_ortho_iff.
  Proof. intros ? ? [] ? ? []; split; apply lb_ortho_anti; auto. Qed.

  Section lb_pointwise.

    Variable (f : bool -> bool -> bool).

    Fixpoint lb_pointwise l m :=
      match l, m with
        | nil,   nil  => nil
        |  _,    nil  => map (fun x => f x ⟘) l
        | nil,     _  => map (f ⟘) m
        | x::l, y::m  => f x y :: lb_pointwise l m
      end.

    Fact lb_pointwise_nil : lb_pointwise nil nil = nil.
    Proof. trivial. Qed.

    Fact lb_pointwise_left l : lb_pointwise l nil = map (fun x => f x ⟘) l.
    Proof. destruct l; trivial. Qed.

    Fact lb_pointwise_right l : lb_pointwise nil l = map (f ⟘) l.
    Proof. destruct l; trivial. Qed.

    Fact lb_pointwise_cons x l y m : lb_pointwise (x::l) (y::m) = f x y :: lb_pointwise l m.
    Proof. trivial. Qed.

    Fact lb_pointwise_length n l m : length l <= n -> length m <= n -> length (lb_pointwise l m) <= n.
    Proof.
      revert l m; induction n as [ | n IHn ].
      + intros [] []; simpl; lia.
      + intros [ | x l ] [ | y m ]; simpl; try rewrite map_length; auto.
        intros; apply le_n_S, IHn; lia.
    Qed.

    Fact lb_pointwise_sym l m : (forall x y, f x y = f y x) -> lb_pointwise l m = lb_pointwise m l.
    Proof.
      intros H; revert l m; induction l as [ | x l IHl ]; intros m.
      + rewrite lb_pointwise_left, lb_pointwise_right.
        apply map_ext; intro; auto.
      + destruct m as [ | y m ].
        * rewrite lb_pointwise_left, lb_pointwise_right.
          apply map_ext; intro; auto.
        * do 2 rewrite lb_pointwise_cons; f_equal; auto.
    Qed.

    Variable (Hf1 : forall x a b, Bool.le a b -> Bool.le (f x a) (f x b))
             (Hf2 : f ⟘ ⟘ = ⟘).

    Let lbpw_mono_1 l m :  lb_pointwise l nil ⪯   lb_pointwise l m.
    Proof.
      rewrite lb_pointwise_left.
      revert m; induction l as [ | x l IHl ]; intros m.
      + simpl; constructor.
      + destruct m as [ | y m ]; simpl.
        * apply lb_mask_refl.
        * apply lb_mask_leb; auto.
    Qed.

    Let lbpw_mono_f_0 g l m : g ⟘ = ⟘ -> Bool.le (g ⟘) (g ⟙) -> l ⪯ m -> map g l ⪯  map g m.
    Proof.
      intros H1 H2.
      assert (Hg : forall x y, x ⪦ y -> g x ⪦ g y).
      { intros [] []; simpl; auto; discriminate. }
      induction 1; simpl; try rewrite H1; constructor; auto.
    Qed.

    Let lbpw_mono_2 l m : m ⪯ nil -> lb_pointwise l m ⪯   lb_pointwise l nil.
    Proof.
      revert m; induction l as [ | x l IHl ]; intros [ | y m ] H.
      + constructor.
      + rewrite lb_pointwise_right.
        apply lbpw_mono_f_0 with (g := f ⟘) in H; auto.
      + apply lb_mask_refl.
      + rewrite lb_pointwise_cons, lb_pointwise_left.
        apply lb_mask_inv_left in H.
        destruct H as (E & H); subst y.
        simpl.
        apply lb_mask_leb.
        1: destruct (f x ⟘); simpl; auto.
        apply lb_mask_trans with (1 := IHl _ H).
        rewrite lb_pointwise_left.
        apply lb_mask_refl.
    Qed.

    Fact lb_pointwise_mono_left l m k : l ⪯  m -> lb_pointwise k l ⪯   lb_pointwise k m.
    Proof using Hf1 Hf2.
      intros H; revert m H k.
      induction l as [ | x l IHl ]; intros m H k; auto.
      destruct m as [ | y m ].
      * apply lbpw_mono_2; auto.
      * destruct k as [ | u k ].
        - apply lbpw_mono_f_0; auto.
        - do 2 rewrite lb_pointwise_cons.
          apply lb_mask_inv_cons in H; destruct H.
          apply lb_mask_leb; auto.
    Qed.

  End lb_pointwise.

  Definition lb_meet := (lb_pointwise andb).
  Definition lb_join := (lb_pointwise orb).

  Local Infix "↓" := lb_meet.
  Local Infix "↑" := lb_join.

  Fact lb_meet_left x : x↓nil ≂ nil.
  Proof.
    unfold lb_meet.
    split; try (constructor; fail).
    rewrite lb_pointwise_left.
    induction x as [ | [] x ]; simpl; constructor; auto.
  Qed.

  Fact lb_meet_comm l m : l↓m = m↓l.
  Proof.
    apply lb_pointwise_sym.
    destruct x; destruct y; auto.
  Qed.

  Fact lb_meet_right x : nil↓x ≂ nil.
  Proof.
    rewrite lb_meet_comm; apply lb_meet_left.
  Qed.

  Fact lb_meet_cons x y l m : (x::l) ↓ (y::m) = x && y :: l↓m.
  Proof. auto. Qed.

  Fact lb_meet_mono l m a b : l ⪯ m -> a ⪯ b -> l↓a ⪯  m↓b.
  Proof.
    intros H1 H2.
    apply lb_mask_trans with (l↓b).
    + apply lb_pointwise_mono_left;auto.
      intros [] [] []; simpl; auto; discriminate.
    + do 2 rewrite (lb_meet_comm _ b).
      apply lb_pointwise_mono_left;auto.
      intros [] [] []; simpl; auto; discriminate.
  Qed.

  Add Parametric Morphism: (lb_meet) with signature (lbeq) ==> (lbeq) ==> (lbeq) as lb_meet_eq.
  Proof. intros ? ? [] ? ? []; split; apply lb_meet_mono; auto. Qed.

  Fact lb_meet_length_le n l m : length l <= n -> length m <= n -> length (l↓m) <= n.
  Proof. apply lb_pointwise_length. Qed.

  Fact lb_meet_length a b : length a = length b -> length (a↓b) = length a.
  Proof.
    revert b; induction a as [ | x a IHa ]; intros [ | y b ]; try discriminate; auto;
      intros H.
    rewrite lb_meet_cons; simpl; f_equal; auto.
  Qed.

  Fact lb_meet_app l m a b : length l = length m -> (l++a)↓(m++b) = l↓m++a↓b.
  Proof.
    revert m; induction l as [ | x l IHl ]; intros [ | y m ]; try discriminate; intros H.
    + simpl; auto.
    + simpl app.
      rewrite lb_meet_cons; f_equal.
      apply IHl.
      simpl in H; inversion H; auto.
  Qed.

  Fact lb_join_left x : x↑nil = x.
  Proof.
    unfold lb_join.
    rewrite lb_pointwise_left.
    induction x as [ | [] ]; simpl; f_equal; auto.
  Qed.

  Fact lb_join_comm l m : l↑m = m↑l.
  Proof.
    apply lb_pointwise_sym.
    destruct x; destruct y; auto.
  Qed.

  Fact lb_join_right x : nil↑x = x.
  Proof.
    rewrite lb_join_comm; apply lb_join_left.
  Qed.

  Fact lb_join_cons x y l m : (x::l) ↑ (y::m) = x || y :: l↑m.
  Proof. auto. Qed.

  Fact lb_join_length_le n l m : length l <= n -> length m <= n -> length (l↑m) <= n.
  Proof. apply lb_pointwise_length. Qed.

  Fact lb_join_mono l m a b : l ⪯ m -> a ⪯ b -> l↑a ⪯  m↑b.
  Proof.
    intros H1 H2.
    apply lb_mask_trans with (l↑b).
    + apply lb_pointwise_mono_left;auto.
      intros [] [] []; simpl; auto; discriminate.
    + do 2 rewrite (lb_join_comm _ b).
      apply lb_pointwise_mono_left;auto.
      intros [] [] []; simpl; auto; discriminate.
  Qed.

  Add Parametric Morphism: (lb_join) with signature (lbeq) ==> (lbeq) ==> (lbeq) as lb_join_eq.
  Proof. intros ? ? [] ? ? []; split; apply lb_join_mono; auto. Qed.

  Fact lb_ortho_meet_nil x y : x ⟂ y <-> x↓y ≂ nil.
  Proof.
    split.
    + intros H; split; try constructor; revert H.
      induction 1 as [ m | l | x y l m ].
      - rewrite lb_meet_right; constructor.
      - rewrite lb_meet_left; constructor.
      - rewrite lb_meet_cons.
        simpl; destruct H; [ destruct y | destruct x ]; try discriminate; subst; simpl; constructor; auto.
    + intros [ H1 _ ]; revert H1.
      revert y; induction x as [ | x l IHl ]; intros [ | y m ]; simpl; intros H; try (constructor; fail).
      destruct x; destruct y; simpl in H |- *; try (inversion H; fail);
        apply lb_mask_inv_nil in H; constructor; auto.
  Qed.

  #[export] Hint Resolve lb_mask_equiv_refl : core.

  Fact lb_join_inc_left a b : a ⪯  a↑b.
  Proof.
    revert b; induction a as [ | x a IHa ]; intros b.
    + constructor.
    + destruct b as [ | y b ].
      * rewrite lb_join_left; auto.
      * rewrite lb_join_cons.
        apply lb_mask_leb; auto.
        destruct x; destruct y; simpl; auto.
  Qed.

  Fact lb_meet_dec_left a b : a↓b ⪯  a.
  Proof.
    revert b; induction a as [ | x a IHa ]; intros b.
    + rewrite lb_meet_right; constructor.
    + destruct b as [ | y b ].
      * rewrite lb_meet_left; constructor.
      * rewrite lb_meet_cons.
        apply lb_mask_leb; auto.
        destruct x; destruct y; simpl; auto.
  Qed.

  Fact lb_join_inc_right a b : b ⪯  a↑b.
  Proof. rewrite lb_join_comm; apply lb_join_inc_left. Qed.

  Fact lb_meet_dec_right a b : a↓b ⪯  b.
  Proof. rewrite lb_meet_comm; apply lb_meet_dec_left. Qed.

  #[export] Hint Resolve lb_join_inc_left lb_join_inc_right lb_meet_dec_left lb_meet_dec_right : core.

  Fact lb_mask_join a b : a ⪯  b <-> a↑b ≂ b.
  Proof.
    split.
    + intros H; split.
      2: rewrite lb_join_comm; auto.
      induction H as [ | | x y ? ? H ].
      * rewrite lb_join_right; auto.
      * rewrite lb_join_left; constructor; auto.
      * rewrite lb_join_cons; constructor; auto.
        revert x y H; intros [] []; simpl; auto.
    + intros (H1 & _).
      apply lb_mask_trans with (2 := H1); auto.
  Qed.

  Fact lb_mask_meet a b : a ⪯  b <-> a↓b ≂ a.
  Proof.
    split.
    + intros H; split; auto.
      induction H as [ | | x y ? ? H ].
      * constructor.
      * rewrite lb_meet_left; constructor; auto.
      * rewrite lb_meet_cons; constructor; auto.
        revert x y H; intros [] []; simpl; auto.
    + intros (H1 & H2).
      apply lb_mask_trans with (1 := H2).
      rewrite lb_meet_comm; auto.
  Qed.

  Fact lb_meet_idem a : a↓a = a.
  Proof.
    induction a as [ | x a ]; auto.
    rewrite lb_meet_cons; f_equal; auto.
    destruct x; simpl; auto.
  Qed.

  Fact lb_join_idem a : a↑a = a.
  Proof.
    induction a as [ | x a ]; auto.
    rewrite lb_join_cons; f_equal; auto.
    destruct x; simpl; auto.
  Qed.

  Tactic Notation "rew" "lb"  :=
       repeat (  rewrite lb_meet_left || rewrite lb_meet_right
              || rewrite lb_join_left || rewrite lb_join_right); auto.

  Fact lb_join_meet_distr a b c : a↑(b↓c) ≂ (a↑b)↓(a↑c).
  Proof.
    revert b c; induction a as [ | x a IHa ]; intros b c.
    + rew lb.
    + destruct b as [ | y b ].
      * rew lb.
        rewrite (proj1 (lb_mask_meet _ _)); auto.
      * destruct c as [ | z c ].
        - rew lb.
          rewrite lb_meet_comm.
          rewrite (proj1 (lb_mask_meet _ _)); auto.
        - repeat rewrite lb_meet_cons.
          repeat rewrite lb_join_cons.
          repeat rewrite lb_meet_cons.
          apply lb_mask_equiv_cons; auto.
          destruct x; destruct y; destruct z; simpl; auto.
  Qed.

  Fact lb_meet_join_distr a b c : a↓(b↑c) ≂ (a↓b)↑(a↓c).
  Proof.
    revert b c; induction a as [ | x a IHa ]; intros b c.
    + rew lb.
    + destruct b as [ | y b ].
      * rew lb.
      * destruct c as [ | z c ].
        - rew lb.
        - repeat rewrite lb_meet_cons.
          repeat rewrite lb_join_cons.
          repeat rewrite lb_meet_cons.
          apply lb_mask_equiv_cons; auto.
          destruct x; destruct y; destruct z; simpl; auto.
  Qed.

  Fact lb_meet_assoc a b c : a↓(b↓c) ≂ a↓b↓c.
  Proof.
    revert b c; induction a as [ | x a IHa ]; intros b c.
    + rew lb.
    + destruct b as [ | y b ].
      * rew lb.
      * destruct c as [ | z c ].
        - rew lb.
        - repeat rewrite lb_meet_cons.
          apply lb_mask_equiv_cons; auto.
          destruct x; destruct y; destruct z; simpl; auto.
  Qed.

  Fact lb_join_assoc a b c : a↑(b↑c) ≂ a↑b↑c.
  Proof.
    revert b c; induction a as [ | x a IHa ]; intros b c.
    + rew lb.
    + destruct b as [ | y b ].
      * rew lb.
      * destruct c as [ | z c ].
        - rew lb.
        - repeat rewrite lb_join_cons.
          apply lb_mask_equiv_cons; auto.
          destruct x; destruct y; destruct z; simpl; auto.
  Qed.

  #[export] Hint Resolve lb_meet_mono lb_join_mono : core.

  Fact lb_join_spec a b c : a ⪯  c -> b ⪯  c -> a↑b ⪯  c.
  Proof. intros; rewrite <- (lb_join_idem c); auto. Qed.

  Fact lb_meet_spec a b c : c ⪯  a -> c ⪯  b -> c ⪯  a↓b.
  Proof. intros; rewrite <- (lb_meet_idem c); auto. Qed.

  Fact lb_meet_join_idem a b : a↓(a↑b) ≂ a.
  Proof. rewrite <- lb_mask_meet; auto. Qed.

  Fact lb_join_meet_idem a b : a↑(a↓b) ≂ a.
  Proof. rewrite lb_join_comm, <- lb_mask_join; auto. Qed.

  Fact lb_join_nil_eq a b : a↑b ≂ nil -> a ≂ nil /\ b ≂ nil.
  Proof.
    intros H; split.
    rewrite <- (lb_meet_left a), <- H, lb_meet_join_idem; auto.
    rewrite <- (lb_meet_left b), <- H, lb_join_comm, lb_meet_join_idem; auto.
  Qed.

  Fact lb_ortho_join a x y : a ⟂ x↑y <-> a ⟂ x /\ a ⟂ y.
  Proof.
    do 3 rewrite lb_ortho_meet_nil; split.
    + intros H; apply lb_join_nil_eq.
      rewrite <- lb_meet_join_distr, H; auto.
    + intros (H1 & H2).
      rewrite lb_meet_join_distr, H1, H2; auto.
  Qed.

  Fact lb_ortho_mask_nil a x : a ⟂ x -> x ⪯  a -> x ≂ nil.
  Proof.
    induction 1 as [ | | x y l m H1 H2 IH2 ]; auto.
    + split; auto.
    + intros H.
      apply lb_mask_inv_cons in H; destruct H as (H3 & H4).
      rewrite IH2; auto; split; auto.
      revert x y H1 H3.
      intros [] []; simpl; intros [] ?; try discriminate; constructor; auto.
  Qed.

  (* c = a - b *)

  Section lb_complement.

    Let bin_comp a b :=
      match a, b with
        | ⟘, ⟘  => ⟘
        | ⟘, ⟙  => ⟘
        | ⟙, ⟘  => ⟙
        | ⟙, ⟙  => ⟘
    end.

    Definition lb_complement a b : { c | b ⟂ c /\ a↑b ≂ c↑b }.
    Proof.
       revert b; induction a as [ | x a IHa ]; intros b.
       + exists nil; split; auto.
       + destruct b as [ | y b ].
         - exists (x :: a); split; auto.
         - destruct (IHa b) as (c & H1 & H2).
           exists (bin_comp x y::c).
           revert x y; intros [] []; simpl; split; auto;
             rewrite H2; simpl; auto.
    Qed.

  End lb_complement.

  Definition lb_minus a b : a ⪯ b -> { c | a ⟂ c /\ b ≂ a↑c }.
  Proof.
    intros H.
    destruct (lb_complement b a) as (c & H1 & H2).
    exists c; split; auto.
    rewrite lb_mask_join in H.
    rewrite <- H, (lb_join_comm a), (lb_join_comm a); auto.
  Qed.

(* End lb.

#[export] Hint Resolve leb_refl leb_trans leb_strict.
#[export] Hint Resolve lb_mask_refl lb_mask_trans.
#[export] Hint Resolve in_lb_mask_0 lb_mask_refl lb_mask_equiv_refl.
Local Hint Constructors lb_mask lb_ortho.
#[export] Hint Resolve lb_mask_equiv_refl.
#[export] Hint Resolve lb_join_inc lb_meet_dec_left lb_meet_dec_right.
*)