Require Export Fibrations Equivalences.

(** For compatibility with Coq 8.2. *)
Unset Automatic Introduction.

(** The map on total spaces induced by a map of fibrations *)

Definition total_map {A B : Type} {P : A -> Type} {Q : B -> Type}
  (f : A -> B) (g : forall x:A, P x -> Q (f x)) :
  sigT P -> sigT Q.
Proof.
  intros A B P Q f g.
  intros [x y].
  exists (f x).
  exact (g x y).
Defined.

(** We first consider maps between fibrations over the same base
   space.  The theorem is that such a map induces an equivalence on
   total spaces if and only if it is an equivalence on all fibers. *)

Section FiberMap.

  Variable A : Type.
  Variables P Q : A -> Type.
  Variable g : forall x, P x -> Q x.

  Let tg := total_map (idmap A) g.

  (* There is a subtlety here that is easy to get confused about.  The
     type [sigT P] is *inductively generated* by elements of the form
     [(x ; y)].  This does *not* mean that every element of [total
     P] is *definitionally* equal to one of that form.  In particular,
     although it appears that [total_map f g] "acts as [f] on the base
     space," we cannot assert that *definitionally* except for
     arguments of the form [(x ; y)].  Hence we need the following
     lemma.  *)

  Let tg_is_fiberwise (z : sigT P) : pr1 z == pr1 (tg z).
    intros [x y].
    auto.
  Defined.

  (* Similarly, the following lemma says that the fiber component of
     [tg z] is obtained by applying the fiberwise function [f] to the
     fiber component of [z], modulo the previously defined path in the
     base.  *)

  Let tg_isg_onfibers (z : sigT P) :
    g _ (transport (tg_is_fiberwise z) (pr2 z)) == pr2 (tg z).
  Proof.
    intros [x y].
    auto.
  Defined.

  (* And the following lemma tells us that the same is true for its
     action on paths. *)

  Let tg_isfib_onpaths (z w : sigT P) (p : z == w) :
    (tg_is_fiberwise z @ base_path (map tg p) @ !tg_is_fiberwise w) == base_path p.
  Proof.
    path_induction.
    destruct x. simpl. auto.
  Defined.

  (* Now let's suppose the total function is an equivalence. *)

  Section TotalIsEquiv.

    Hypothesis tot_iseqv : is_equiv tg.

    Let tot_eqv : (sigT P) <~> (sigT Q) := (tg ; tot_iseqv).

    (* We want to show that each function [g x] is an equivalence, so we
       start by defining its inverse. *)

    Let ginv (x:A) (y: Q x) : P x.
    Proof.
      intros x y.
      (* The obvious thing to look at first is this. *)
      set (inv1 := pr2 ((tot_eqv^-1) (x ; y))).
      (* Unfortunately, this does not live in the fiber over [x], but
         rather in some other fiber.  We need to transport it along some
         path.  Our first guess at such a path might be this. *)
      apply (transport (base_path (inverse_is_section tot_eqv (x ; y)))).
      simpl.
      (* This type is not quite the type of [inv1] yet; it involves
         knowing something about the base component of an image under
         [tg].  This is what [tg_is_fiberwise] is for.   *)
      apply (transport (tg_is_fiberwise ((tot_eqv^-1) (x ; y)))).
      (* Now we are back to the type of [inv1]. *)
      assumption.
    Defined.

    (* Now we are ready to prove that [g x] is an equivalence. *)

    Theorem fiber_is_equiv (x:A) : is_equiv (g x).
    Proof.
      intros x.
      set (is_section := inverse_is_section tot_eqv).
      set (is_retraction := inverse_is_retraction tot_eqv).
      set (triangle := inverse_triangle tot_eqv).
      (* We have our putative inverse ready to hand. *)
      apply @hequiv_is_equiv with (g := ginv x).
      (* First we have to show it is a section of [f x]. *)
      intro y.
      path_via (transport (P := Q)
        (base_path (is_section (x ; y)))
        (pr2 (tot_eqv (tot_eqv^-1 (x ; y))))).
      path_via (transport
        (base_path (is_section (x ; y)))
        (g _ (transport (tg_is_fiberwise (tot_eqv^-1 (x ; y)))
          (pr2 (tot_eqv^-1 (x ; y)))))).
      apply trans_map.
      exact (fiber_path (is_section (existT _ x y))).
      (* And now that it is a retraction. *)
      intro y.
      path_via (transport (base_path (map tg (is_retraction (x ; y))))
      (transport (tg_is_fiberwise (tot_eqv^-1 (x ; (g x y))))
        (pr2 (tot_eqv^-1 (x ; (g x y)))))).
      unfold ginv.
      apply happly, map, map.
      apply opposite, triangle.
      path_via (transport
        (base_path (is_retraction (x ; y)))
        (pr2 (tot_eqv^-1 (x ; (g x y))))).
      path_via (transport
        ((tg_is_fiberwise (tot_eqv^-1 (x ; (g x y))))
          @ (base_path (map tg (is_retraction (x ; y)))))
        (pr2 ((tot_eqv^-1) (x ; (g x y))))).
      apply opposite, trans_concat.
      apply happly, map.
      (* Here is where we need [tg_isfib_onpaths], but it is easy to
         get confused because the second copy of [tg_is_fiberwise]
         appears to be missing.  The reason is that it would be
         instantiated at an element of the form [(x ; y)], in which
         case it happens to be an identity.  Thus, we can just add it
         back in. *)
      path_via (tg_is_fiberwise (tot_eqv^-1 (x ; (g x y))) @
        base_path (map tg (is_retraction (x ; y))) @
        !tg_is_fiberwise (x ; y)).
      exact (fiber_path (is_retraction (existT _ x y))).
    Defined.

    Definition fiber_equiv (x:A) : P x <~> Q x :=
      (g x ; fiber_is_equiv x).

  End TotalIsEquiv.

  (* Now let's suppose instead that the maps on fibers are equivalences. *)

  Section FiberIsEquiv.

    Hypothesis fiber_iseqv : forall x, is_equiv (g x).

    Let fiber_eqv x : P x <~> Q x := (g x ; fiber_iseqv x).

    Let total_inv : sigT Q -> sigT P.
    Proof.
      intros [x y].
      exists x.
      apply ((fiber_eqv x)^-1).
      assumption.
    Defined.

    Theorem total_is_equiv : is_equiv tg.
    Proof.
      eapply hequiv_is_equiv.
      instantiate (1 := total_inv).
      intros [x y].
      eapply total_path.
      instantiate (1 := idpath x).
      path_via (fiber_eqv x ((fiber_eqv x ^-1) y)).
      apply inverse_is_section.
      intros [x y].
      eapply total_path.
      instantiate (1 := idpath x).
      path_via (fiber_eqv x ^-1 (fiber_eqv x y)).
      apply inverse_is_retraction.
    Defined.

    Definition total_equiv : sigT P <~> sigT Q :=
      (tg ; total_is_equiv).

  End FiberIsEquiv.

End FiberMap.

Implicit Arguments fiber_equiv [A].
Implicit Arguments fiber_is_equiv [A].
Implicit Arguments total_equiv [A].
Implicit Arguments total_is_equiv [A].

(** Next we consider a fibration over one space and its pullback along
   a map from another base space.  The theorem is that if the map we
   pull back along is an equivalence, so is the induced map on total
   spaces. *)

Section PullbackMap.

  Variables A B : Type.
  Variable Q : B -> Type.
  Variable f : A <~> B.

  Let pbQ : A -> Type := Q o f.

  Let g (x:A) : pbQ x -> Q (f x) := idmap (Q (f x)).

  Let tg := total_map f g.

  Let tginv : sigT Q -> sigT pbQ.
  Proof.
    intros [x z].
    exists (f^-1 x).
    apply (transport (! inverse_is_section f x)).
    assumption.
  Defined.

  Theorem pullback_total_is_equiv : is_equiv tg.
  Proof.
    apply @hequiv_is_equiv with (g := tginv).
    intros [x z].
    apply total_path with (p := inverse_is_section f x).
    simpl.
    path_via (transport (! inverse_is_section f x @ inverse_is_section f x) z).
    apply opposite, trans_concat.
    path_via (transport (idpath x) z).
    apply @map with (f := fun p => transport p z).
    cancel_opposites.
    intros [x z].
    apply total_path with (p := inverse_is_retraction f x).
    simpl.
    path_via (transport (map f (inverse_is_retraction f x))
     (transport (!inverse_is_section f (f x)) z)).
    apply (map_trans Q).
    path_via (transport (!inverse_is_section f (f x) @ map f (inverse_is_retraction f x)) z).
    apply opposite, trans_concat.
    path_via (transport (idpath (f x)) z).
    assert (p : (!inverse_is_section f (f x) @ map f (inverse_is_retraction f x)) == idpath (f x)).
    moveright_onleft.
    cancel_units.
    apply inverse_triangle.
    exact (@map _ _ (!inverse_is_section f (f x) @ map f (inverse_is_retraction f x))
      (idpath (f x))
      (fun p => transport p z) p).
  Defined.

  Definition pullback_total_equiv : sigT pbQ <~> sigT Q :=
    existT _ tg pullback_total_is_equiv.

End PullbackMap.

Implicit Arguments pullback_total_is_equiv [A B].
Implicit Arguments pullback_total_equiv [A B].

(** Finally, we can put these together to prove that given a map of
   fibrations lying over an equivalence of base spaces, the induced
   map on total spaces is an equivalence if and only if the map on
   each fiber is an equivalence. *)

Section FibrationMap.

  Variables A B : Type.
  Variable P : A -> Type.
  Variable Q : B -> Type.

  Variable f : A <~> B.
  Variable g : forall x:A, P x -> Q (f x).

  Let tg := total_map f g.

  Let pbQ := Q o f.

  Let pbg (x : A) : P x -> pbQ x := g x.

  Theorem fibseq_fiber_is_equiv :
    is_equiv tg -> forall x, is_equiv (g x).
  Proof.
    intro H.
    set (pbmap_equiv := pullback_total_is_equiv Q f).
    apply fiber_is_equiv.
    apply @equiv_cancel_left with (C := sigT Q) (g := pullback_total_equiv Q f).
    apply @equiv_homotopic with (g := tg).
    intros [x y].
    auto.
    assumption.
  Defined.

  Definition fibseq_fiber_equiv :
    is_equiv tg -> forall x, P x <~> Q (f x) :=
      fun H x => (g x ; fibseq_fiber_is_equiv H x).

  (* Instead of proving directly that [tg] is an equivalence, we'll
  prove first that a different map from [sigT P] to [sigT Q] is an
  equivalence, then that [tg] is homotopic to that map. *)

  Let fibseq_a_totalequiv :
    (forall x, is_equiv (g x)) -> (sigT P <~> sigT Q).
  Proof.
    intro H.
    apply @equiv_compose with (B := sigT pbQ).
    exists (total_map (idmap A) pbg).
    apply @total_is_equiv.
    apply H.
    apply pullback_total_equiv.
  Defined.

  Theorem fibseq_total_is_equiv :
    (forall x, is_equiv (g x)) -> is_equiv tg.
  Proof.
    intro H.
    apply @equiv_homotopic with (g := fibseq_a_totalequiv H).
    intros [x y].
    auto.
    exact (pr2 (fibseq_a_totalequiv H)).
  Defined.

  Definition fibseq_total_equiv :
    (forall x, is_equiv (g x)) -> (sigT P <~> sigT Q) :=
    fun H => (tg ; fibseq_total_is_equiv H).

End FibrationMap.

Implicit Arguments fibseq_fiber_is_equiv [A B].
Implicit Arguments fibseq_fiber_equiv [A B].
Implicit Arguments fibseq_total_is_equiv [A B].
Implicit Arguments fibseq_total_equiv [A B].


(* this file proves various properties of subsets of real numbers *)

Require Import Real.

Section RealSubsets.

  Generalizable Variables K M Real.

  Context `{klb : LazyBool K} `{M_Monad : Monad M}
          {MultivalueMonad_description : Monoid_hom M_Monad NPset_Monad}
          {M_MultivalueMonad : MultivalueMonad}
          {Real : Type}
          {SemiDecOrderedField_Real : SemiDecOrderedField Real}
          {ComplArchiSemiDecOrderedField_Real : ComplArchiSemiDecOrderedField}.

  (* ring structure on Real *)
  Ltac IZReal_tac t :=
    match t with
    | real_0 => constr:(0%Z)
    | real_1 => constr:(1%Z)
    | IZreal ?u =>
      match isZcst u with
      | true => u
      | _ => constr:(InitialRing.NotConstant)
      end
    | _ => constr:(InitialRing.NotConstant)
    end.

  Add Ring realRing : (realTheory ) (constants [IZReal_tac]).

  Definition real_subset := Real -> Prop.
  Definition complement : real_subset -> real_subset := fun P x => ~ P x.
  Definition is_open : real_subset -> Prop := fun P => forall x, P x -> exists n, forall y, dist x y < prec n -> P y.
  Definition is_closed S := is_open (complement S).
  Definition w_approx (P : Real -> Prop) (n : nat) (x : Real) : Prop
    := exists y, P y /\ dist x y <= prec n.

  (* a predicate [P : Real -> Prop] is complete if for any converging seqeunce
   [f : nat -> real_] such that [w_approx P n (f n)] holds for all [n : nat],
   the limit point satisfies [P x]. For example, [Real \ {0}] is not complete. *)
  Definition is_seq_closed (P : Real -> Prop) :=
    forall f : nat -> Real,
      is_fast_cauchy f -> (forall n, w_approx P n (f n)) -> (forall x, is_fast_limit x f -> P x).

  Definition is_closed_is_seq_complete : forall P, is_closed P -> is_seq_closed P.
  Proof.
    intros P H f c j a b.
    destruct (lem (P a)); auto.
    pose proof (H _ H0).
    destruct H1.

    pose proof (j (S (S x))).
    unfold w_approx in H2.
    destruct H2.
    destruct H2.
    pose proof (H1 x0).
    contradict H2.
    apply H4.
    pose proof (b (S (S x))).
    (* pose proof (proj2 (dist_le_prop a (f (S (S x))) (prec (S (S x)))) H2). *)
    pose proof (dist_tri a (f (S (S x))) x0).
    pose proof (real_le_le_plus_le _ _ _ _ H2 H3).
    apply (real_ge_le) in H5.
    pose proof (real_le_le_le _ _ _ H5 H6).
    apply (real_le_lt_lt _ _ _ H7).
    assert ( prec (S (S x)) + prec (S (S x)) = prec (S x)).
    simpl.
    unfold real_div.
    replace (prec x * / real_2_neq_0 * / real_2_neq_0 +
             prec x * / real_2_neq_0 * / real_2_neq_0) with (prec x * (/ real_2_neq_0 * (real_1 + real_1) ) * / real_2_neq_0) by ring.
    rewrite real_mult_inv.
    ring_simplify.
    auto.
    rewrite H8.
    apply prec_S.
  Defined.
End RealSubsets.


Require Import Rpos.
Require Import FOL_R.
Require Import lt_nat_tuples.
Require Import RL.hr.term.
Require Import RL.hr.semantic.
Require Import RL.hr.hseq.

Require Import CMorphisms.
Require Import Lra.
Require Import Lia.

Require Import RL.OLlibs.List_more.
Require Import RL.OLlibs.List_Type.
Require Import RL.OLlibs.Permutation_Type_more.
Require Import RL.OLlibs.Permutation_Type_solve.
Require Import RL.OLlibs.wf_prod.

Local Open Scope R_scope.

Ltac sem_is_pos_decomp val a :=
  let H := fresh "H" in
  let HeqH := fresh "HeqH" in
  assert {H & R_order_dec (FOL_R_term_sem val a) = H} as [H HeqH] by (split with (R_order_dec (FOL_R_term_sem val a)); reflexivity); destruct H as [H | H | H];
  rewrite ? HeqH; revert H HeqH.

(** * Definitions *)

Definition p_sequent : Set := list (FOL_R_term * term).

Definition p_seq_is_atomic (T : p_sequent) := Forall_inf (fun x => match x with (a , A) => is_atom A end) T.

Fixpoint eval_p_sequent (val : nat -> R) (T : p_sequent) : sequent :=
  match T with
  | nil => nil
  | (a , A) :: T => match R_order_dec (FOL_R_term_sem val a) with
                    | R_is_gt _ H => (existT (fun x => 0 <? x = true) (FOL_R_term_sem val a) H, A) :: (eval_p_sequent val T)
                    | R_is_lt _ H => (existT (fun x => 0 <? x = true) (-(FOL_R_term_sem val a)) H, -S A) :: (eval_p_sequent val T)
                    | R_is_null _ H => eval_p_sequent val T
                    end
  end.

Fixpoint to_p_sequent (T : sequent) : p_sequent :=
  match T with
  | nil => nil
  | (a, A) :: T => (FOL_R_cst (projT1 a), A) :: (to_p_sequent T)
  end.

Definition Permutation_Type_p_seq val (T1 T2 : p_sequent) := Permutation_Type (eval_p_sequent val T1) (eval_p_sequent val T2).

Definition p_hypersequent : Set := list p_sequent.

Definition p_hseq_is_atomic G := Forall_inf p_seq_is_atomic G.

Definition Permutation_Type_p_hseq val (G1 G2 : p_hypersequent) := Permutation_Type (map (eval_p_sequent val) G1) (map (eval_p_sequent val) G2).

Fixpoint to_p_hypersequent (G : hypersequent) : p_hypersequent :=
  match G with
  | nil => nil
  | T :: G => (to_p_sequent T) :: (to_p_hypersequent G)
  end.

(** ** Complexity *)
Fixpoint HR_complexity_p_seq (T : p_sequent) :=
  match T with
  | nil => 0%nat
  | (a, A) :: T => ((HR_complexity_term A) + (HR_complexity_p_seq T))%nat
  end.

Fixpoint HR_complexity_p_hseq G :=
  match G with
  | nil => (0%nat, 0%nat)
  | T :: G => if HR_complexity_p_seq T =? fst (HR_complexity_p_hseq G) then (fst (HR_complexity_p_hseq G), S (snd (HR_complexity_p_hseq G)))
              else if (HR_complexity_p_seq T <? fst (HR_complexity_p_hseq G))%nat then (fst (HR_complexity_p_hseq G) , snd (HR_complexity_p_hseq G))
                   else (HR_complexity_p_seq T, 1%nat)
  end.

(** ** Max variable appearing in a term of a hypersequent *)
Fixpoint max_var_p_seq (T : p_sequent) :=
  match T with
  | nil => 0%nat
  | (r, A) :: T => Nat.max (max_var_term A) (max_var_p_seq T)
  end.

Fixpoint max_var_p_hseq G :=
  match G with
  | nil => 0%nat
  | T :: G => Nat.max (max_var_p_seq T) (max_var_p_hseq G)
  end.

(** ** Min variable appearing in a weight of a hypersequent *)
Fixpoint max_var_weight_p_seq (T : p_sequent) :=
  match T with
  | nil => 0%nat
  | (r, A) :: T => Nat.max (max_var_FOL_R_term r) (max_var_weight_p_seq T)
  end.

Fixpoint max_var_weight_p_hseq (G : p_hypersequent) :=
  match G with
  | nil => 0%nat
  | T :: G => Nat.max (max_var_weight_p_seq T) (max_var_weight_p_hseq G)
  end.

(** ** Substitution *)
Fixpoint subs_p_seq (D : p_sequent) n t :=
  match D with
  | nil => nil
  | (r, A) :: D => (r , subs A n t) :: (subs_p_seq D n t)
  end.

(** ** Definitions and properties of \vec{r}.A *)

Fixpoint vec (l : list FOL_R_term) (A : term) :=
  match l with
  | nil => nil
  | r :: l => (r , A) :: (vec l A)
  end.

Fixpoint sum_vec (l : list FOL_R_term) :=
  match l with
  | nil => FOL_R_cst 0
  | r :: l => r +R (sum_vec l)
  end.

Fixpoint copy_p_seq n (T : p_sequent) :=
  match n with
  | 0 => nil
  | S n => (copy_p_seq n T) ++ T
  end.

Fixpoint mul_vec r (l : list FOL_R_term) :=
  match l with
  | nil => nil
  | r0 :: l => (FOL_R_mul r r0) :: (mul_vec r l)
  end.

Fixpoint vec_mul_vec l1 l2 :=
  match l1 with
  | nil => nil
  | r :: l1 => (mul_vec r l2) ++ (vec_mul_vec l1 l2)
  end.

(** ** Sum of the weights *)
Fixpoint sum_weight_p_seq_var n (T : p_sequent) :=
  match T with
  | nil => FOL_R_cst 0
  | ((r , HR_var n0) :: T) => if n =? n0 then r +R (sum_weight_p_seq_var n T) else sum_weight_p_seq_var n T
  | ( _ :: T) => sum_weight_p_seq_var n T
  end.
Fixpoint sum_weight_p_seq_covar n (T : p_sequent) :=
  match T with
  | nil => FOL_R_cst 0
  | ((r , HR_covar n0) :: T) => if n =? n0 then r +R (sum_weight_p_seq_covar n T) else sum_weight_p_seq_covar n T
  | ( _ :: T) => sum_weight_p_seq_covar n T
  end.
Fixpoint p_sum_weight_var n G :=
  match G with
  | nil => FOL_R_cst 0
  | T :: G => (sum_weight_p_seq_var n T) +R (p_sum_weight_var n G)
  end.
Fixpoint p_sum_weight_covar n G :=
  match G with
  | nil => FOL_R_cst 0
  | T :: G => (sum_weight_p_seq_covar n T) +R (p_sum_weight_covar n G)
  end.

(** ** well defined hypersequent with regard to a valuation (i.e. all the weights of the hypersequent are strictly positive with this valuation) *)
Definition p_seq_well_defined (val : nat -> R) (T : p_sequent) :=
  Forall_inf (fun x => (0 <? FOL_R_term_sem val (fst x)) = true) T.

Definition p_hseq_well_defined (val : nat -> R) G : Type :=
  Forall_inf (p_seq_well_defined val) G.

(** * Properties *)
(** ** vec *)
Lemma vec_app : forall vr1 vr2 A, vec (vr1 ++ vr2) A = vec vr1 A ++ vec vr2 A.
Proof.
  induction vr1; intros vr2 A; simpl; try rewrite IHvr1; try reflexivity.
Qed.

Lemma sum_vec_app : forall vr1 vr2 val, FOL_R_pred_sem val ((sum_vec (vr1 ++ vr2)) =R ((sum_vec vr1) +R (sum_vec vr2))).
Proof.
  induction vr1; intros vr2 val.
  - rewrite app_nil_l; simpl; nra.
  - simpl.
    rewrite IHvr1.
    destruct a; simpl; nra.
Qed.

Lemma mul_vec_sum_vec : forall r vr val, FOL_R_pred_sem val (sum_vec (mul_vec r vr) =R r *R (sum_vec vr)).
Proof.
  intro r; induction vr; intros val.
  - simpl; nra.
  - simpl.
    rewrite IHvr.
    simpl; nra.
Qed.

Lemma sum_vec_vec_mul_vec : forall vr vs val, FOL_R_pred_sem val (sum_vec (vec_mul_vec vr vs) =R (sum_vec vr) *R (sum_vec vs)).
Proof.
  induction vr; intros vs val.
  - simpl; nra.
  - unfold vec_mul_vec; fold vec_mul_vec.
    unfold sum_vec; fold sum_vec.
    simpl; rewrite sum_vec_app.
    simpl; rewrite mul_vec_sum_vec.
    rewrite IHvr.
    simpl; nra.
Qed.

Lemma vec_mul_vec_nil_r : forall vr, vec_mul_vec vr nil = nil.
Proof with try reflexivity.
  induction vr...
  simpl; rewrite IHvr...
Qed.

Lemma vec_mul_vec_cons_r : forall vr1 vr2 r val, Permutation_Type_FOL_R_term val (vec_mul_vec vr1 (r :: vr2)) (mul_vec r vr1 ++ vec_mul_vec vr1 vr2).
Proof.
  unfold Permutation_Type_FOL_R_term.
  induction vr1; intros vr2 r val; simpl; try reflexivity.
  replace (FOL_R_term_sem val a * FOL_R_term_sem val r) with (FOL_R_term_sem val r * FOL_R_term_sem val a) by (simpl; nra).
  apply Permutation_Type_skip.
  rewrite ? map_app; rewrite app_assoc.
  etransitivity ; [ | apply Permutation_Type_app ; [ apply Permutation_Type_app_comm | reflexivity ] ].
  rewrite <- app_assoc; apply Permutation_Type_app; try reflexivity.
  rewrite <- map_app; apply IHvr1.
Qed.

Lemma vec_mul_vec_comm : forall vr1 vr2 val, Permutation_Type_FOL_R_term val (vec_mul_vec vr1 vr2) (vec_mul_vec vr2 vr1).
Proof.
  unfold Permutation_Type_FOL_R_term.
  induction vr1; intros vr2 val.
  - simpl; rewrite vec_mul_vec_nil_r; reflexivity.
  - simpl.
    etransitivity ; [ | symmetry; apply vec_mul_vec_cons_r ].
    rewrite ? map_app; apply Permutation_Type_app; try reflexivity.
    apply IHvr1.
Qed.

Lemma mul_vec_app : forall vr vs r, mul_vec r (vr ++ vs) = mul_vec r vr ++ mul_vec r vs.
Proof.
  induction vr; intros vs r; simpl; try rewrite IHvr; try reflexivity.
Qed.

Lemma mul_vec_perm : forall vr vs r val, Permutation_Type_FOL_R_term val vr vs ->  Permutation_Type_FOL_R_term val (mul_vec r vr) (mul_vec r vs).
Proof.
  unfold Permutation_Type_FOL_R_term.
  intros vr vs r val Hperm.
  remember (map (FOL_R_term_sem val) vr) as lr; remember (map (FOL_R_term_sem val) vs) as ls.
  revert vr vs Heqlr Heqls; induction Hperm; intros vr vs Heqlr Heqls.
  - symmetry in Heqlr; apply map_eq_nil in Heqlr; symmetry in Heqls; apply map_eq_nil in Heqls; subst.
    reflexivity.
  - destruct vr; destruct vs; inversion Heqlr; inversion Heqls; subst.
    simpl; rewrite H2; apply Permutation_Type_skip.
    apply IHHperm; reflexivity.
  - destruct vr; [ | destruct vr]; (destruct vs; [ | destruct vs]); inversion Heqlr; inversion Heqls; subst.
    simpl; rewrite H3; rewrite H4.
    replace (map (FOL_R_term_sem val) (mul_vec r vs)) with (map (FOL_R_term_sem val) (mul_vec r vr)); [ apply Permutation_Type_swap | ].
    clear - H5.
    revert vs H5; induction vr; intros vs H5.
    + destruct vs; try now inversion H5.
    + destruct vs; inversion H5; subst.
      simpl; rewrite H0.
      now rewrite IHvr with vs.
  - subst.
    apply Permutation_Type_map_inv in Hperm2 as [vr' Heq' Hperm']; subst.
    etransitivity; [apply IHHperm1 | apply IHHperm2]; auto.
Qed.

Lemma vec_perm : forall vr1 vr2 A val,
    Permutation_Type_FOL_R_term val vr1 vr2 -> Permutation_Type_p_seq val (vec vr1 A) (vec vr2 A).
Proof.
  unfold Permutation_Type_FOL_R_term; unfold Permutation_Type_p_seq.
  intros vr1 vr2 A val Hperm.
  remember (map (FOL_R_term_sem val) vr1) as l1; remember (map (FOL_R_term_sem val) vr2) as l2.
  revert vr1 vr2 Heql1 Heql2; induction Hperm; intros vr1 vr2 Heql1 Heql2.
  - destruct vr1; destruct vr2; inversion Heql1; now inversion Heql2.
  - destruct vr1; destruct vr2; inversion Heql1; inversion Heql2; subst.
    simpl; rewrite H2.
    sem_is_pos_decomp val f0; intros;
      try apply Permutation_Type_skip;
      now apply IHHperm.
  - destruct vr1; [ | destruct vr1]; (destruct vr2; [ | destruct vr2]); inversion Heql1; inversion Heql2; simpl; subst.
    rewrite H3; rewrite H4.
    replace (eval_p_sequent val (vec vr1 A)) with (eval_p_sequent val (vec vr2 A)) ; [ sem_is_pos_decomp val f1; sem_is_pos_decomp val f2 ;intros; now try apply Permutation_Type_swap | ].
    clear - H5.
    revert vr2 H5; induction vr1; intros vr2 H5; destruct vr2; inversion H5; subst; try reflexivity.
    simpl; rewrite H0; now rewrite IHvr1.
  - subst.
    apply Permutation_Type_map_inv in Hperm2 as [vr' Heq' Hperm']; subst.
    etransitivity; [apply IHHperm1 | apply IHHperm2]; auto.
Qed.

Lemma sum_mul_vec : forall val l r, FOL_R_pred_sem val (sum_vec (mul_vec r l) =R FOL_R_mul r (sum_vec l)).
Proof.
  intros val; induction l; intros r.
  - simpl; nra.
  - specialize (IHl r).
    simpl in *.
    rewrite IHl.
    nra.
Qed.

Lemma sum_vec_perm : forall val vr vs,
    Permutation_Type vr vs ->
    FOL_R_pred_sem val (sum_vec vr =R sum_vec vs).
Proof.
  intros val vr vs Hperm; induction Hperm; simpl in *; nra.
Qed.

Lemma mul_vec_length : forall r vr,
    length (mul_vec r vr) = length vr.
Proof.
  intros r; induction vr; simpl; try rewrite IHvr; reflexivity.
Qed.

(** ** Sequent *)

Lemma eval_p_sequent_cons : forall val r H A T,
    (existT _ (FOL_R_term_sem val r) H, A) :: eval_p_sequent val T = eval_p_sequent val ((r, A) :: T).
Proof.
  intros val r H A T.
  simpl in *.
  sem_is_pos_decomp val r; intros e He;
    [ | exfalso; clear - H e; apply R_blt_lt in H; apply R_blt_lt in e; lra
      | exfalso; clear - H e; apply R_blt_lt in H; lra].
  replace H with e by (apply Eqdep_dec.UIP_dec; apply Bool.bool_dec).
  reflexivity.
Qed.

Lemma Permutation_Type_eval_p_sequent : forall val T D,
    Permutation_Type T D ->
    Permutation_Type (eval_p_sequent val T) (eval_p_sequent val D).
Proof.
  intros val T D Hperm; induction Hperm; auto.
  - destruct x as [a A]; simpl.
    sem_is_pos_decomp val a; intros e He; try apply Permutation_Type_skip; assumption.
  - destruct x as [a A]; destruct y as [b B]; simpl.
    sem_is_pos_decomp val a; sem_is_pos_decomp val b; intros eb Heb ea Hea; try reflexivity; try apply Permutation_Type_swap.
  - etransitivity; [ apply IHHperm1 | apply IHHperm2 ].
Qed.

Lemma Permutation_Type_perm_eval_inv : forall val l T,
    Permutation_Type l (eval_p_sequent val T) ->
    { D & l = eval_p_sequent val D}.
Proof.
  intros val l T Hperm.
  remember (eval_p_sequent val T).
  revert T Heqs; induction Hperm; intros T Heqs.
  - split with nil; reflexivity.
  - induction T; try now inversion Heqs.
    destruct a as [a A]; simpl in Heqs.
    revert Heqs; sem_is_pos_decomp val a; intros e He Heqs;
      inversion Heqs; subst.
    + specialize (IHHperm T eq_refl) as [D Heq].
      split with ((a , A) :: D); simpl; rewrite He; rewrite Heq; try reflexivity.
    + specialize (IHHperm T eq_refl) as [D Heq].
      split with ((a , A) :: D); simpl; rewrite He; rewrite Heq; try reflexivity.
    + apply IHT.
      apply Heqs.
  - remember (length T).
    revert T Heqs Heqn.
    induction n; intros T Heqs Heqn.
    { destruct T; inversion Heqs; inversion Heqn. }
    destruct T ; [ | destruct T]; try now inversion Heqn.
    + exfalso.
      destruct p as [a A].
      simpl in Heqs.
      sem_is_pos_decomp val a; intros e He; rewrite He in Heqs; inversion Heqs.
    + destruct p as [a A]; destruct p0 as [b B]; simpl in Heqs.
      sem_is_pos_decomp val a; intros ea Hea; rewrite Hea in Heqs;
        sem_is_pos_decomp val b; intros eb Heb; rewrite Heb in Heqs;
          try (inversion Heqs; subst;
               split with ((b , B) :: (a , A) :: T);
               simpl; rewrite Hea; rewrite Heb; reflexivity);
          try (apply (IHn ((a, A) :: T));
               [simpl; rewrite Hea; apply Heqs |
                simpl in *; lia]);
          try (apply (IHn ((b, B) :: T));
               [simpl; rewrite Heb; apply Heqs |
                simpl in *; lia]).
  - specialize (IHHperm2 T Heqs) as [D Heq].
    apply IHHperm1 with D.
    apply Heq.
Qed.

Fixpoint seq_mul (r : FOL_R_term) (T : p_sequent) :=
  match T with
  | nil => nil
  | ((a , A) :: T) => (FOL_R_mul r a, A) :: (seq_mul r T)
  end.

Lemma seq_mul_app : forall T1 T2 r, seq_mul r (T1 ++ T2) = seq_mul r T1 ++ seq_mul r T2.
Proof.
  induction T1; intros T2 r; try reflexivity.
  destruct a as (a , A).
  simpl; rewrite IHT1.
  reflexivity.
Qed.

Fixpoint seq_mul_vec vr T :=
  match vr with
  | nil => nil
  | r :: vr => (seq_mul r T) ++ (seq_mul_vec vr T)
  end.

Lemma seq_mul_vec_nil_r : forall vr,
    seq_mul_vec vr nil = nil.
Proof.
  induction vr; simpl; try rewrite IHvr; reflexivity.
Qed.

Lemma seq_mul_vec_app_l : forall T vr1 vr2,
    seq_mul_vec (vr1 ++ vr2) T = seq_mul_vec vr1 T ++ seq_mul_vec vr2 T.
Proof.
  intros T; induction vr1; intros vr2; try reflexivity.
  simpl.
  rewrite IHvr1.
  rewrite app_assoc; reflexivity.
Qed.

(** ** sum_weight_p_seq_(co)var *)

Lemma sum_weight_p_seq_var_lt_max_var : forall val n T1,
    (max_var_p_seq T1 < n)%nat ->
    FOL_R_term_sem val (sum_weight_p_seq_var n T1) = 0.
Proof.
  intros val n; induction T1; intros Hlt; auto.
  destruct a as [a A].
  destruct A; simpl in *; try (apply IHT1; simpl ; lia).
  replace (n =? n0) with false by (symmetry; apply Nat.eqb_neq; lia).
  apply IHT1.
  lia.
Qed.

Lemma sum_weight_p_seq_covar_lt_max_var : forall val n T1,
    (max_var_p_seq T1 < n)%nat ->
    FOL_R_term_sem val (sum_weight_p_seq_covar n T1) = 0.
Proof.
  intros val n; induction T1; intros Hlt; auto.
  destruct a as [a A].
  destruct A; simpl in *; try (apply IHT1 ; lia).
  replace (n =? n0) with false by (symmetry; apply Nat.eqb_neq; lia).
  apply IHT1.
  lia.
Qed.

Lemma sum_weight_p_seq_var_app : forall val n T1 T2,
    FOL_R_pred_sem val (sum_weight_p_seq_var n (T1 ++ T2) =R sum_weight_p_seq_var n T1 +R sum_weight_p_seq_var n T2).
Proof.
  intros val n T1; induction T1; intros T2; simpl; try nra.
  destruct a as [a A]; simpl.
  specialize (IHT1 T2).
  destruct A; try case (n =? n0); simpl in *; try nra.
Qed.

Lemma sum_weight_p_seq_covar_app : forall val n T1 T2,
    FOL_R_pred_sem val (sum_weight_p_seq_covar n (T1 ++ T2) =R sum_weight_p_seq_covar n T1 +R sum_weight_p_seq_covar n T2).
Proof.
  intros val n T1; induction T1; intros T2; simpl; try nra.
  destruct a as [a A]; simpl.
  specialize (IHT1 T2).
  destruct A; try case (n =? n0); simpl in *; try nra.
Qed.

Lemma sum_weight_p_seq_var_mul : forall val n T r,
    FOL_R_pred_sem val (sum_weight_p_seq_var n (seq_mul r T) =R r *R sum_weight_p_seq_var n T).
Proof.
  intros val n T r; induction T; simpl in *; try nra.
  destruct a as [a A]; simpl.
  destruct A; try case (n =? n0); destruct a; destruct r; simpl in *; try nra.
Qed.

Lemma sum_weight_p_seq_covar_mul : forall val n T r,
    FOL_R_pred_sem val (sum_weight_p_seq_covar n (seq_mul r T) =R r *R sum_weight_p_seq_covar n T).
Proof.
  intros val n T r; induction T; simpl in *; try nra.
  destruct a as [a A]; simpl.
  destruct A; try case (n =? n0); destruct a; destruct r; simpl in *; try nra.
Qed.

Lemma sum_weight_p_seq_var_vec_var_eq : forall val n r,
    FOL_R_pred_sem val (sum_weight_p_seq_var n (vec r (HR_var n)) =R sum_vec r).
Proof.
  intros val n; induction r; simpl in *; try (rewrite Nat.eqb_refl; simpl; rewrite IHr); reflexivity.
Qed.

Lemma sum_weight_p_seq_covar_vec_covar_eq : forall val n r,
    FOL_R_pred_sem val (sum_weight_p_seq_covar n (vec r (HR_covar n)) =R sum_vec r).
Proof.
  intros val n; induction r; simpl; try (rewrite Nat.eqb_refl; simpl; rewrite IHr); nra.
Qed.

Lemma sum_weight_p_seq_var_vec_neq : forall val n A r,
    HR_var n <> A ->
    FOL_R_term_sem val (sum_weight_p_seq_var n (vec r A)) = 0.
Proof.
  intros val n A; induction r; intros Hneq; simpl; try reflexivity.
  destruct A; try (case_eq (n =? n0) ; [ intros H; exfalso; apply Nat.eqb_eq in H; now subst | ]); auto.
Qed.

Lemma sum_weight_p_seq_covar_vec_neq : forall val n A r,
    HR_covar n <> A ->
    FOL_R_term_sem val (sum_weight_p_seq_covar n (vec r A)) = 0.
Proof.
  intros val n A; induction r; intros Hneq; simpl; try reflexivity.
  destruct A; try (case_eq (n =? n0) ; [ intros H; exfalso; apply Nat.eqb_eq in H; now subst | ]); auto.
Qed.

Lemma p_seq_non_atomic_perm :
  forall T,
    (p_seq_is_atomic T -> False) ->
    {' (A , D) : _ &
                 Permutation_Type T (A :: D) &
                 ~ (is_atom (snd A)) }.
Proof.
  induction T; intros Hnat; [exfalso; apply Hnat; apply Forall_inf_nil | ].
  destruct a as [a A].
  destruct A.
  - destruct IHT as [[A D] Hperm H].
    { intros Hat; apply Hnat; apply Forall_inf_cons; auto.
      apply I. }
    split with (A, ((a, HR_var n) :: D)); auto.
    Permutation_Type_solve.
  - destruct IHT as [[A D] Hperm H].
    { intros Hat; apply Hnat; apply Forall_inf_cons; auto.
      apply I. }
    split with (A, ((a, HR_covar n) :: D)); auto.
    Permutation_Type_solve.
  - split with ((a, HR_zero), T); auto.
  - split with ((a, A1 +S A2), T); auto.
  - split with ((a, r *S A), T); auto.
  - split with ((a, A1 \/S A2), T); auto.
  - split with ((a, A1 /\S A2), T); auto.
Qed.

Lemma p_seq_atomic_seq_atomic : forall val T,
    p_seq_is_atomic T ->
    seq_is_atomic (eval_p_sequent val T).
Proof.
  intros val T; induction T; intros Hall.
  - apply Forall_inf_nil.
  - destruct a as [a A].
    simpl in Hall |- *.
    inversion Hall; subst.
    sem_is_pos_decomp val a; intros; simpl; try apply Forall_inf_cons; try apply IHT; auto.
    destruct A; inversion X; auto.
Qed.

Lemma p_hseq_atomic_hseq_atomic : forall val G,
    p_hseq_is_atomic G ->
    hseq_is_atomic (map (eval_p_sequent val) G).
Proof.
  intros val; induction G; intros Hat; try apply Forall_inf_nil.
  simpl; inversion Hat; subst; apply Forall_inf_cons; [ apply p_seq_atomic_seq_atomic | apply IHG]; auto.
Qed.

(** Complexity related theorem *)

Lemma complexity_p_seq_perm : forall T1 T2,
    Permutation_Type T1 T2 ->
    HR_complexity_p_seq T1 = HR_complexity_p_seq T2.
Proof.
  intros T1 T2 Hperm; induction Hperm; try destruct x; try destruct y; simpl; lia.
Qed.

Lemma complexity_p_hseq_perm : forall G1 G2,
    Permutation_Type G1 G2 ->
    HR_complexity_p_hseq G1 = HR_complexity_p_hseq G2.
Proof.
  intros G1 G2 Hperm; induction Hperm.
  - reflexivity.
  - simpl.
    rewrite IHHperm.
    case (HR_complexity_p_seq x =? fst (HR_complexity_p_hseq l'));
      case (HR_complexity_p_seq x <? fst (HR_complexity_p_hseq l'))%nat; reflexivity.
  - simpl.
    case_eq (HR_complexity_p_seq x =? fst (HR_complexity_p_hseq l)); intros H1;
      case_eq (HR_complexity_p_seq y =? fst (HR_complexity_p_hseq l)); intros H2;
        case_eq (HR_complexity_p_seq x <? fst (HR_complexity_p_hseq l))%nat; intros H3;
          case_eq (HR_complexity_p_seq y <? fst (HR_complexity_p_hseq l))%nat; intros H4;
            case_eq (HR_complexity_p_seq x =? HR_complexity_p_seq y); intros H5;
              case_eq (HR_complexity_p_seq x <? HR_complexity_p_seq y)%nat; intros H6;
                case_eq (HR_complexity_p_seq y <? HR_complexity_p_seq x)%nat; intros H7;
                  repeat (simpl; try rewrite H1; try rewrite H2; try rewrite H3; try rewrite H4; try rewrite H5; try (rewrite Nat.eqb_sym in H5; rewrite H5); try rewrite H6; try rewrite H7);
                  try reflexivity;
                  (apply Nat.eqb_eq in H1 + apply Nat.eqb_neq in H1);
                  (apply Nat.eqb_eq in H2 + apply Nat.eqb_neq in H2);
                  (apply Nat.ltb_lt in H3 + apply Nat.ltb_nlt in H3);
                  (apply Nat.ltb_lt in H4 + apply Nat.ltb_nlt in H4);
                  (apply Nat.eqb_eq in H5 + apply Nat.eqb_neq in H5);
                  (apply Nat.ltb_lt in H6 + apply Nat.ltb_nlt in H6);
                  (apply Nat.ltb_lt in H7 + apply Nat.ltb_nlt in H7);
                  try lia.
    rewrite H5; reflexivity.
  - transitivity (HR_complexity_p_hseq l'); assumption.
Qed.

Lemma complexity_p_hseq_perm_fst : forall G,
    G <> nil ->
    {' (T, H) : _ &
                Permutation_Type G (T :: H) &
                HR_complexity_p_seq T = fst (HR_complexity_p_hseq G) }.
  induction G; intros H; [ exfalso; apply H; reflexivity | clear H ].
  simpl.
  case_eq (HR_complexity_p_seq a =? fst (HR_complexity_p_hseq G)); intros H1.
  - split with (a, G); try reflexivity.
    apply Nat.eqb_eq in H1; rewrite H1; reflexivity.
  - case_eq (HR_complexity_p_seq a <? fst (HR_complexity_p_hseq G))%nat; intros H2.
    + destruct G; [ inversion H2 | ].
      destruct IHG as [[T H] Hperm Heq].
      { intros H; inversion H. }
      split with (T, (a :: H)).
      * transitivity (a :: T :: H); Permutation_Type_solve.
      * rewrite (complexity_p_hseq_perm _ _ Hperm).
        rewrite (complexity_p_hseq_perm _ _ Hperm) in Heq.
        rewrite Heq; reflexivity.
    + split with (a, G); reflexivity.
Qed.

Lemma complexity_p_hseq_perm_fst_p_seq : forall T1 T2 G,
    Permutation_Type T1 T2 ->
    HR_complexity_p_hseq (T1 :: G) = HR_complexity_p_hseq (T2 :: G).
Proof.
  intros T1 T2 G Hperm.
  simpl.
  rewrite (complexity_p_seq_perm _ _ Hperm).
  reflexivity.
Qed.

Lemma complexity_p_seq_app : forall T1 T2,
    HR_complexity_p_seq (T1 ++ T2) = (HR_complexity_p_seq T1 + HR_complexity_p_seq T2)%nat.
Proof.
  induction T1; intros T2; simpl; try rewrite IHT1; try destruct a; lia.
Qed.

Lemma complexity_p_seq_vec : forall r A,
    HR_complexity_p_seq (vec r A) = (length r * HR_complexity_term A)%nat.
Proof.
  induction r; intros A; simpl; try rewrite IHr; lia.
Qed.

Lemma p_seq_is_atomic_complexity_0 :
  forall T,
    p_seq_is_atomic T ->
    HR_complexity_p_seq T = 0%nat.
Proof.
  induction T; intros Hat;
    inversion Hat; simpl; try destruct a; try rewrite IHT; try rewrite is_atom_complexity_0;
      auto.
Qed.

Lemma p_seq_is_atomic_complexity_0_inv :
  forall T,
    HR_complexity_p_seq T = 0%nat ->
    p_seq_is_atomic T.
Proof.
  induction T; intros Heq; [ apply Forall_inf_nil |] .
  destruct a as [a A]; simpl in *.
  apply Forall_inf_cons ; [ apply is_atom_complexity_0_inv  | apply IHT]; lia.
Qed.

Lemma p_hseq_is_atomic_complexity_0 :
  forall G,
    p_hseq_is_atomic G ->
    fst (HR_complexity_p_hseq G) = 0%nat.
Proof.
  induction G; intros Hat; [ reflexivity | ].
  inversion Hat; subst; specialize (IHG X0).
  simpl.
  rewrite p_seq_is_atomic_complexity_0 ; [ | apply X].
  rewrite IHG; reflexivity.
Qed.

Lemma p_hseq_is_atomic_complexity_0_inv :
  forall G,
    fst (HR_complexity_p_hseq G) = 0%nat ->
    p_hseq_is_atomic G.
Proof.
  induction G; intros Heq; [ apply Forall_inf_nil | ].
  simpl in *.
  case_eq (HR_complexity_p_seq a =? fst (HR_complexity_p_hseq G)); intros H; rewrite H in Heq; simpl in Heq ; [ apply Nat.eqb_eq in H | apply Nat.eqb_neq in H ].
  { apply Forall_inf_cons; [ apply p_seq_is_atomic_complexity_0_inv | apply IHG ]; lia. }
  exfalso.
  case_eq (HR_complexity_p_seq a <? fst (HR_complexity_p_hseq G))%nat; intros H2; rewrite H2 in Heq; [apply Nat.ltb_lt in H2 | apply Nat.ltb_nlt in H2]; simpl in *; lia.
Qed.

Lemma hrr_Z_decrease_complexity : forall G T r,
    r <> nil ->
    HR_complexity_p_seq (vec r HR_zero ++ T) = fst (HR_complexity_p_hseq ((vec r HR_zero ++ T) :: G)) ->
    HR_complexity_p_hseq (T :: G) <2 HR_complexity_p_hseq ((vec r HR_zero ++ T) :: G).
Proof.
  intros G T r Hnnil Heq.
  simpl.
  case_eq (HR_complexity_p_seq T =? fst (HR_complexity_p_hseq G)); intros H1; case_eq (HR_complexity_p_seq (vec r HR_zero ++ T) =? fst (HR_complexity_p_hseq G)); intros H2.
  - exfalso.
    destruct r; [ apply Hnnil; reflexivity | ].
    apply Nat.eqb_eq in H1; apply Nat.eqb_eq in H2.
    simpl in H2.
    rewrite complexity_p_seq_app in H2.
    lia.
  - case_eq (HR_complexity_p_seq (vec r HR_zero ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H3.
    + exfalso.
      apply Nat.eqb_eq in H1; apply Nat.eqb_neq in H2; apply Nat.ltb_lt in H3.
      destruct r; [ apply Hnnil; reflexivity | ].
      simpl; rewrite complexity_p_seq_app in H2; rewrite complexity_p_seq_app in H3.
      lia.
    + apply fst_lt2.
      apply Nat.eqb_neq in H2; apply Nat.ltb_nlt in H3.
      lia.
  - case_eq (HR_complexity_p_seq T <? fst (HR_complexity_p_hseq G))%nat; intros H3.
    + apply snd_lt2.
      lia.
    + exfalso.
      apply Nat.eqb_eq in H2; apply Nat.ltb_nlt in H3.
      rewrite complexity_p_seq_app in H2; destruct r ; [ apply Hnnil; reflexivity | ].
      simpl in H2; lia.
  - simpl in Heq; rewrite H2 in Heq.
    case_eq (HR_complexity_p_seq T <? fst (HR_complexity_p_hseq G))%nat; intros H3;
      case_eq (HR_complexity_p_seq (vec r HR_zero ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H4; rewrite H4 in Heq; simpl in Heq.
    + exfalso.
      apply Nat.eqb_neq in H2; apply H2; apply Heq.
    + apply fst_lt2.
      apply Nat.ltb_nlt in H4; apply Nat.eqb_neq in H2; lia.
    + exfalso.
      apply Nat.ltb_nlt in H3; apply Nat.ltb_lt in H4.
      rewrite complexity_p_seq_app in H4; lia.
    + apply fst_lt2.
      rewrite complexity_p_seq_app; destruct r; [ exfalso; apply Hnnil; reflexivity | ].
      simpl; lia.
Qed.

Lemma hrr_plus_decrease_complexity : forall G T A B r,
    r <> nil ->
    HR_complexity_p_seq (vec r (A +S B) ++ T) = fst (HR_complexity_p_hseq ((vec r (A +S B) ++ T) :: G)) ->
    HR_complexity_p_hseq ((vec r A ++ vec r B ++ T) :: G) <2 HR_complexity_p_hseq ((vec r (A +S B) ++ T) :: G).
Proof.
  intros G T A B r Hnnil Heq.
  simpl.
  case_eq (HR_complexity_p_seq (vec r A ++ vec r B ++ T) =? fst (HR_complexity_p_hseq G)); intros H1; case_eq (HR_complexity_p_seq (vec r (A +S B) ++ T) =? fst (HR_complexity_p_hseq G)); intros H2; rewrite 2 complexity_p_seq_app in H1.
  - exfalso.
    destruct r; [ apply Hnnil; reflexivity | ].
    apply Nat.eqb_eq in H1; apply Nat.eqb_eq in H2.
    simpl in H1, H2.
    rewrite complexity_p_seq_app in H2.
    rewrite ? complexity_p_seq_vec in *.
    simpl in H2.
    lia.
  - case_eq (HR_complexity_p_seq (vec r (A +S B) ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H3.
    + exfalso.
      apply Nat.eqb_eq in H1; apply Nat.eqb_neq in H2; apply Nat.ltb_lt in H3.
      destruct r; [ apply Hnnil; reflexivity | ].
      simpl; rewrite complexity_p_seq_app in H2; rewrite complexity_p_seq_app in H3.
      rewrite ? complexity_p_seq_vec in *; simpl in H1,H2,H3.
      lia.
    + apply fst_lt2.
      apply Nat.eqb_neq in H2; apply Nat.ltb_nlt in H3.
      lia.
  - case_eq (HR_complexity_p_seq (vec r A ++ vec r B ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H3.
    + apply snd_lt2.
      lia.
    + exfalso.
      apply Nat.eqb_eq in H2; apply Nat.ltb_nlt in H3.
      rewrite ? complexity_p_seq_app in *; destruct r ; [ apply Hnnil; reflexivity | ].
      simpl in H2; rewrite ? complexity_p_seq_vec in *; simpl in H1,H2,H3.
      lia.
  - simpl in Heq; rewrite H2 in Heq.
    case_eq (HR_complexity_p_seq (vec r A ++ vec r B ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H3;
      case_eq (HR_complexity_p_seq (vec r (A +S B) ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H4; rewrite H4 in Heq; simpl in Heq.
    + exfalso.
      apply Nat.eqb_neq in H2; apply H2; apply Heq.
    + apply fst_lt2.
      apply Nat.ltb_nlt in H4; apply Nat.eqb_neq in H2; lia.
    + exfalso.
      apply Nat.ltb_nlt in H3; apply Nat.ltb_lt in H4.
      rewrite ? complexity_p_seq_app in *; rewrite ? complexity_p_seq_vec in *; lia.
    + apply fst_lt2.
      rewrite ? complexity_p_seq_app; destruct r; [ exfalso; apply Hnnil; reflexivity | ].
      rewrite ? complexity_p_seq_vec; simpl; lia.
Qed.

Lemma hrr_mul_decrease_complexity : forall G T A r0 r,
    r <> nil ->
    HR_complexity_p_seq (vec r (r0 *S A) ++ T) = fst (HR_complexity_p_hseq ((vec r (r0 *S A) ++ T) :: G)) ->
    HR_complexity_p_hseq ((vec (mul_vec (FOL_R_cst (projT1 r0)) r) A ++ T) :: G) <2 HR_complexity_p_hseq ((vec r (r0 *S A) ++ T) :: G).
Proof.
  intros G T A r0 r Hnnil Heq.
  simpl.
  case_eq (HR_complexity_p_seq (vec (mul_vec (FOL_R_cst (projT1 r0)) r) A ++ T) =? fst (HR_complexity_p_hseq G)); intros H1; case_eq (HR_complexity_p_seq (vec r (r0 *S A) ++ T) =? fst (HR_complexity_p_hseq G)); intros H2; rewrite complexity_p_seq_app in H1.
  - exfalso.
    destruct r; [ apply Hnnil; reflexivity | ].
    apply Nat.eqb_eq in H1; apply Nat.eqb_eq in H2.
    simpl in H1, H2.
    rewrite complexity_p_seq_app in H2.
    rewrite ? complexity_p_seq_vec in *.
    simpl in H2.
    rewrite mul_vec_length in H1.
    lia.
  - case_eq (HR_complexity_p_seq (vec r (r0 *S A) ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H3.
    + exfalso.
      apply Nat.eqb_eq in H1; apply Nat.eqb_neq in H2; apply Nat.ltb_lt in H3.
      destruct r; [ apply Hnnil; reflexivity | ].
      simpl; rewrite complexity_p_seq_app in H2; rewrite complexity_p_seq_app in H3.
      rewrite ? complexity_p_seq_vec in *; simpl in H1,H2,H3.
      rewrite mul_vec_length in H1.
      lia.
    + apply fst_lt2.
      apply Nat.eqb_neq in H2; apply Nat.ltb_nlt in H3.
      lia.
  - case_eq (HR_complexity_p_seq (vec (mul_vec (FOL_R_cst (projT1 r0)) r) A ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H3.
    + apply snd_lt2.
      lia.
    + exfalso.
      apply Nat.eqb_eq in H2; apply Nat.ltb_nlt in H3.
      rewrite ? complexity_p_seq_app in *; destruct r ; [ apply Hnnil; reflexivity | ].
      simpl in H2; rewrite ? complexity_p_seq_vec in *; simpl in H1,H2,H3.
      rewrite mul_vec_length in *; lia.
  - simpl in Heq; rewrite H2 in Heq.
    case_eq (HR_complexity_p_seq (vec (mul_vec (FOL_R_cst (projT1 r0)) r) A ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H3;
      case_eq (HR_complexity_p_seq (vec r (r0 *S A) ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H4; rewrite H4 in Heq; simpl in Heq.
    + exfalso.
      apply Nat.eqb_neq in H2; apply H2; apply Heq.
    + apply fst_lt2.
      apply Nat.ltb_nlt in H4; apply Nat.eqb_neq in H2; lia.
    + exfalso.
      apply Nat.ltb_nlt in H3; apply Nat.ltb_lt in H4.
      rewrite ? complexity_p_seq_app in *; rewrite ? complexity_p_seq_vec in *; lia.
    + apply fst_lt2.
      rewrite ? complexity_p_seq_app; destruct r; [ exfalso; apply Hnnil; reflexivity | ].
      rewrite ? complexity_p_seq_vec; rewrite mul_vec_length in *; simpl; lia.
Qed.

Lemma hrr_min_r_decrease_complexity : forall G T A B r,
    r <> nil ->
    HR_complexity_p_seq (vec r (A /\S B) ++ T) = fst (HR_complexity_p_hseq ((vec r (A /\S B) ++ T) :: G)) ->
    HR_complexity_p_hseq ((vec r A ++ T) :: G) <2 HR_complexity_p_hseq ((vec r (A /\S B) ++ T) :: G).
  intros G T A B r Hnnil Heq.
  simpl.
  case_eq (HR_complexity_p_seq (vec r A ++ T) =? fst (HR_complexity_p_hseq G)); intros H1; case_eq (HR_complexity_p_seq (vec r (A /\S B) ++ T) =? fst (HR_complexity_p_hseq G)); intros H2; rewrite ? complexity_p_seq_app in H1.
  - exfalso.
    destruct r; [ apply Hnnil; reflexivity | ].
    apply Nat.eqb_eq in H1; apply Nat.eqb_eq in H2.
    simpl in H1, H2.
    rewrite complexity_p_seq_app in H2.
    rewrite ? complexity_p_seq_vec in *.
    simpl in H2.
    lia.
  - case_eq (HR_complexity_p_seq (vec r (A /\S B) ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H3.
    + exfalso.
      apply Nat.eqb_eq in H1; apply Nat.eqb_neq in H2; apply Nat.ltb_lt in H3.
      destruct r; [ apply Hnnil; reflexivity | ].
      simpl; rewrite complexity_p_seq_app in H2; rewrite complexity_p_seq_app in H3.
      rewrite ? complexity_p_seq_vec in *; simpl in H1,H2,H3.
      lia.
    + apply fst_lt2.
      apply Nat.eqb_neq in H2; apply Nat.ltb_nlt in H3.
      lia.
  - case_eq (HR_complexity_p_seq (vec r A ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H3.
    + apply snd_lt2.
      lia.
    + exfalso.
      apply Nat.eqb_eq in H2; apply Nat.ltb_nlt in H3.
      rewrite ? complexity_p_seq_app in *; destruct r ; [ apply Hnnil; reflexivity | ].
      simpl in H2; rewrite ? complexity_p_seq_vec in *; simpl in H1,H2,H3.
      lia.
  - simpl in Heq; rewrite H2 in Heq.
    case_eq (HR_complexity_p_seq (vec r A ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H3;
      case_eq (HR_complexity_p_seq (vec r (A /\S B) ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H4; rewrite H4 in Heq; simpl in Heq.
    + exfalso.
      apply Nat.eqb_neq in H2; apply H2; apply Heq.
    + apply fst_lt2.
      apply Nat.ltb_nlt in H4; apply Nat.eqb_neq in H2; lia.
    + exfalso.
      apply Nat.ltb_nlt in H3; apply Nat.ltb_lt in H4.
      rewrite ? complexity_p_seq_app in *; rewrite ? complexity_p_seq_vec in *; lia.
    + apply fst_lt2.
      rewrite ? complexity_p_seq_app; destruct r; [ exfalso; apply Hnnil; reflexivity | ].
      rewrite ? complexity_p_seq_vec; simpl; lia.
Qed.

Lemma hrr_min_l_decrease_complexity : forall G T A B r,
    r <> nil ->
    HR_complexity_p_seq (vec r (A /\S B) ++ T) = fst (HR_complexity_p_hseq ((vec r (A /\S B) ++ T) :: G)) ->
    HR_complexity_p_hseq ((vec r B ++ T) :: G) <2 HR_complexity_p_hseq ((vec r (A /\S B) ++ T) :: G).
  intros G T A B r Hnnil Heq.
  simpl.
  case_eq (HR_complexity_p_seq (vec r B ++ T) =? fst (HR_complexity_p_hseq G)); intros H1; case_eq (HR_complexity_p_seq (vec r (A /\S B) ++ T) =? fst (HR_complexity_p_hseq G)); intros H2; rewrite complexity_p_seq_app in H1.
  - exfalso.
    destruct r; [ apply Hnnil; reflexivity | ].
    apply Nat.eqb_eq in H1; apply Nat.eqb_eq in H2.
    simpl in H1, H2.
    rewrite complexity_p_seq_app in H2.
    rewrite ? complexity_p_seq_vec in *.
    simpl in H2.
    lia.
  - case_eq (HR_complexity_p_seq (vec r (A /\S B) ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H3.
    + exfalso.
      apply Nat.eqb_eq in H1; apply Nat.eqb_neq in H2; apply Nat.ltb_lt in H3.
      destruct r; [ apply Hnnil; reflexivity | ].
      simpl; rewrite complexity_p_seq_app in H2; rewrite complexity_p_seq_app in H3.
      rewrite ? complexity_p_seq_vec in *; simpl in H1,H2,H3.
      lia.
    + apply fst_lt2.
      apply Nat.eqb_neq in H2; apply Nat.ltb_nlt in H3.
      lia.
  - case_eq (HR_complexity_p_seq (vec r B ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H3.
    + apply snd_lt2.
      lia.
    + exfalso.
      apply Nat.eqb_eq in H2; apply Nat.ltb_nlt in H3.
      rewrite ? complexity_p_seq_app in *; destruct r ; [ apply Hnnil; reflexivity | ].
      simpl in H2; rewrite ? complexity_p_seq_vec in *; simpl in H1,H2,H3.
      lia.
  - simpl in Heq; rewrite H2 in Heq.
    case_eq (HR_complexity_p_seq (vec r B ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H3;
      case_eq (HR_complexity_p_seq (vec r (A /\S B) ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H4; rewrite H4 in Heq; simpl in Heq.
    + exfalso.
      apply Nat.eqb_neq in H2; apply H2; apply Heq.
    + apply fst_lt2.
      apply Nat.ltb_nlt in H4; apply Nat.eqb_neq in H2; lia.
    + exfalso.
      apply Nat.ltb_nlt in H3; apply Nat.ltb_lt in H4.
      rewrite ? complexity_p_seq_app in *; rewrite ? complexity_p_seq_vec in *; lia.
    + apply fst_lt2.
      rewrite ? complexity_p_seq_app; destruct r; [ exfalso; apply Hnnil; reflexivity | ].
      rewrite ? complexity_p_seq_vec; simpl; lia.
Qed.

Lemma hrr_max_decrease_complexity : forall G T A B r,
    r <> nil ->
    HR_complexity_p_seq (vec r (A \/S B) ++ T) = fst (HR_complexity_p_hseq ((vec r (A \/S B) ++ T) :: G)) ->
    HR_complexity_p_hseq ((vec r B ++ T) :: (vec r A ++ T) :: G) <2 HR_complexity_p_hseq ((vec r (A \/S B) ++ T) :: G).
Proof.
  intros G T A B r Hnnil Heq.
  simpl.
  case_eq (HR_complexity_p_seq (vec r A ++ T) =? fst (HR_complexity_p_hseq G)); intros H1; case_eq (HR_complexity_p_seq (vec r (A \/S B) ++ T) =? fst (HR_complexity_p_hseq G)); intros H2; rewrite complexity_p_seq_app in H1.
  - exfalso.
    destruct r; [ apply Hnnil; reflexivity | ].
    apply Nat.eqb_eq in H1; apply Nat.eqb_eq in H2.
    simpl in H1, H2.
    rewrite complexity_p_seq_app in H2.
    rewrite ? complexity_p_seq_vec in *.
    simpl in H2.
    lia.
  - case_eq (HR_complexity_p_seq (vec r (A \/S B) ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H3.
    + exfalso.
      apply Nat.eqb_eq in H1; apply Nat.eqb_neq in H2; apply Nat.ltb_lt in H3.
      destruct r; [ apply Hnnil; reflexivity | ].
      simpl; rewrite complexity_p_seq_app in H2; rewrite complexity_p_seq_app in H3.
      rewrite ? complexity_p_seq_vec in *; simpl in H1,H2,H3.
      lia.
    + simpl.
      case_eq (HR_complexity_p_seq (vec r B ++ T) =? fst (HR_complexity_p_hseq G)); intros H4.
      * apply fst_lt2.
        apply Nat.eqb_neq in H2; apply Nat.ltb_nlt in H3.
        lia.
      * case_eq (HR_complexity_p_seq (vec r B ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H5.
        -- apply fst_lt2.
           apply Nat.eqb_neq in H2; apply Nat.ltb_nlt in H3.
           lia.
        -- apply fst_lt2.
           rewrite ? complexity_p_seq_app; rewrite ? complexity_p_seq_vec; destruct r; [ exfalso; apply Hnnil; reflexivity | ]; simpl; lia.
  - replace (HR_complexity_p_seq (vec r A ++ T) <? fst (HR_complexity_p_hseq G))%nat with true.
    2:{ symmetry.
        apply Nat.ltb_lt; apply Nat.eqb_neq in H1; apply Nat.eqb_eq in H2.
        rewrite ? complexity_p_seq_app in *; rewrite ? complexity_p_seq_vec in *; simpl in *; lia. }
    simpl.
    replace (HR_complexity_p_seq (vec r B ++ T) =? fst (HR_complexity_p_hseq G)) with false.
    2:{ symmetry.
        apply Nat.eqb_neq; apply Nat.eqb_eq in H2.
        destruct r; [ exfalso; apply Hnnil; reflexivity | ].
        rewrite ? complexity_p_seq_app in *; rewrite ? complexity_p_seq_vec in *; simpl in *; lia. }
    replace (HR_complexity_p_seq (vec r B ++ T) <? fst (HR_complexity_p_hseq G))%nat with true.
    2:{ symmetry.
        apply Nat.ltb_lt; apply Nat.eqb_eq in H2.
        destruct r; [ exfalso; apply Hnnil; reflexivity | ].
        rewrite ? complexity_p_seq_app in *; rewrite ? complexity_p_seq_vec in *; simpl in *; lia. }
    apply snd_lt2; lia.
  - simpl in Heq.
    rewrite H2 in Heq.
    assert ((HR_complexity_p_seq (vec r (A \/S B) ++ T) <? fst (HR_complexity_p_hseq G))%nat = false) as H3.
    { apply Nat.ltb_nlt; apply Nat.eqb_neq in H2.
      intros H; apply Nat.ltb_lt in H.
      rewrite H in Heq.
      simpl in Heq.
      apply H2; apply Heq. }
    rewrite H3; clear Heq.
    case_eq (HR_complexity_p_seq (vec r A ++ T) <? fst (HR_complexity_p_hseq G))%nat; intros H4; simpl.
    + case (HR_complexity_p_seq (vec r B ++ T) =? fst (HR_complexity_p_hseq G));
        [ | case (HR_complexity_p_seq (vec r B ++ T) <? fst (HR_complexity_p_hseq G))%nat];
        apply fst_lt2; apply Nat.eqb_neq in H2; apply Nat.ltb_nlt in H3; apply Nat.ltb_lt in H4;
          rewrite ? complexity_p_seq_app in *; rewrite ? complexity_p_seq_vec in *;
            (destruct r; [ exfalso; apply Hnnil; reflexivity | ]); simpl in *; lia.
    + case (HR_complexity_p_seq (vec r B ++ T) =? HR_complexity_p_seq (vec r A ++ T));
        [ | case (HR_complexity_p_seq (vec r B ++ T) <? HR_complexity_p_seq (vec r A ++ T))%nat];
      apply fst_lt2;
        rewrite ? complexity_p_seq_app in *; rewrite ? complexity_p_seq_vec in *;
          (destruct r; [ exfalso; apply Hnnil; reflexivity | ]); simpl in *; lia.
Qed.

(** ** max_(co)var *)

Lemma max_var_seq_le_p_seq : forall val T,
    (max_var_seq (eval_p_sequent val T) <= max_var_p_seq T)%nat.
Proof.
  intros val; induction T; simpl; auto.
  destruct a as [a A].
  sem_is_pos_decomp val a; intros e He; simpl; try lia.
  clear - IHT.
  induction A; simpl; try lia.
Qed.

Lemma max_var_hseq_le_p_hseq : forall val G,
    (max_var_hseq (map (eval_p_sequent val) G) <= max_var_p_hseq G)%nat.
Proof.
  intros val; induction G; simpl; auto.
  assert (H := max_var_seq_le_p_seq val a).
  lia.
Qed.

Lemma max_var_p_hseq_perm : forall G H,
    Permutation_Type G H ->
    max_var_p_hseq G = max_var_p_hseq H.
Proof.
  intros G H Hperm.
  induction Hperm; simpl; lia.
Qed.

Lemma max_var_p_seq_perm : forall T1 T2,
    Permutation_Type T1 T2 ->
    max_var_p_seq T1 = max_var_p_seq T2.
Proof.
  intros T1 T2 Hperm; induction Hperm; simpl; try destruct x; try destruct y; try lia.
Qed.

(** ** well defined *)
Lemma p_seq_well_defined_perm : forall val T D,
    Permutation_Type T D ->
    p_seq_well_defined val T ->
    p_seq_well_defined val D.
Proof.
  intros val T D Hperm.
  induction Hperm; intros Hwd; inversion Hwd; subst; (try constructor); auto.
  - apply IHHperm; auto.
  - inversion X; auto.
  - inversion X; subst.
    apply Forall_inf_cons; auto.
Qed.

Lemma p_hseq_well_defined_perm : forall val G H,
    Permutation_Type G H ->
    p_hseq_well_defined val G ->
    p_hseq_well_defined val H.
Proof.
  intros val G H Hperm.
  induction Hperm; intros Hwd; inversion Hwd; subst; (try constructor); auto.
  - apply IHHperm; auto.
  - inversion X0; auto.
  - inversion X0; subst.
    apply Forall_inf_cons; auto.
Qed.

(** ** to_p_hypersequent *)

Lemma to_p_sequent_well_defined : forall val T,
    p_seq_well_defined val (to_p_sequent T).
Proof.
  intros val; induction T; [ apply Forall_inf_nil | ].
  destruct a as [[a Ha] A]; simpl.
  apply Forall_inf_cons; assumption.
Qed.

Lemma to_p_hypersequent_well_defined : forall val G,
    p_hseq_well_defined val (to_p_hypersequent G).
Proof.
  intros val; induction G; [ apply Forall_inf_nil | ].
  apply Forall_inf_cons; [ apply to_p_sequent_well_defined | assumption ].
Qed.

Lemma eval_p_sequent_to_p_sequent : forall val T,
    eval_p_sequent val (to_p_sequent T) = T.
Proof.
  intros val; induction T; try reflexivity.
  destruct a as [[a Ha] A]; simpl.
  assert {H & R_order_dec a = H} as [e He] by (split with (R_order_dec a); reflexivity); destruct e as [e | e | e];
    rewrite ? He;
    [ | exfalso; clear - e Ha; simpl in *; apply R_blt_lt in Ha; apply R_blt_lt in e; nra
      | exfalso; clear - e Ha; simpl in *; apply R_blt_lt in Ha; nra].
  replace e with Ha by (apply Eqdep_dec.UIP_dec; apply Bool.bool_dec).
  rewrite IHT; reflexivity.
Qed.

Lemma eval_p_hypersequent_to_p_hypersequent : forall val G,
    map (eval_p_sequent val) (to_p_hypersequent G) = G.
Proof.
  intros val; induction G; try reflexivity.
  simpl.
  rewrite eval_p_sequent_to_p_sequent; rewrite IHG.
  reflexivity.
Qed.


Require Import
        HoTT.Spaces.Nat.
Require Import
        HoTT.Tactics.
Require Import
        HoTT.Classes.interfaces.abstract_algebra
        HoTT.Classes.interfaces.naturals
        HoTT.Classes.interfaces.orders
        HoTT.Classes.implementations.peano_naturals
        HoTT.Classes.theory.rings
        HoTT.Classes.orders.semirings
        HoTT.Classes.theory.apartness.

Section basics.

  (* This definition of binary naturals is due to Martín Escardó and
     Cory Knapp *)

  Inductive binnat : Type :=
  | bzero   :           binnat  (* zero *)
  | double1 : binnat -> binnat  (* 2n+1 *)
  | double2 : binnat -> binnat. (* 2n+2 *)

  Fixpoint Succ (n : binnat) : binnat :=
    match n with
    | bzero      => double1 bzero
    | double1 n' => double2 n'
    | double2 n' => double1 (Succ n')
    end.

  Fixpoint double (n : binnat) : binnat :=
    match n with
    | bzero      => bzero
    | double1 n' => double2 (double n')
    | double2 n' => double2 (Succ (double n'))
    end.

  Fixpoint Double (n : nat) : nat :=
    match n with
    | O    => O
    | S n' => S (S (Double n'))
    end.

  Definition Double1 (n : nat) : nat := S (Double n).

  Definition Double2 (n : nat) : nat := S (S (Double n)).

  Fixpoint binary (n : nat) : binnat :=
    match n with
    | O    => bzero
    | S n' => Succ (binary n')
    end.

End basics.

Section binary_equiv.

  Local Fixpoint unary' (n : binnat) : nat :=
    match n with
    | bzero      => O
    | double1 n' => Double1 (unary' n')
    | double2 n' => Double2 (unary' n')
    end.

  Let succunary (n : binnat) : unary' (Succ n) = S (unary' n).
  Proof.
    induction n.
    - reflexivity.
    - reflexivity.
    - simpl. rewrite IHn. reflexivity.
  Qed.

  Let unarybinary : unary' o binary == idmap.
  Proof.
    intros n; induction n as [|n IHn].
    - reflexivity.
    - simpl. rewrite succunary. apply ap. exact IHn.
  Qed.

  Definition double1binary (n : nat) : binary (Double1 n) = double1 (binary n).
  Proof.
    induction n.
    - reflexivity.
    - change (binary (Double1 n.+1)) with (Succ (Succ (binary (Double n).+1))).
      rewrite IHn. reflexivity.
  Qed.

  Definition double2binary (n : nat) : binary (Double2 n) = double2 (binary n).
  Proof.
    induction n.
    - reflexivity.
    - change (binary (Double2 n.+1)) with (Succ (Succ (binary (Double n).+2))).
      rewrite IHn. reflexivity.
  Qed.

  Let binaryunary : binary o unary' == idmap.
  Proof.
    intros n; induction n.
    - reflexivity.
    - rewrite double1binary. apply ap. exact IHn.
    - rewrite double2binary. apply ap. exact IHn.
  Qed.

  Global Instance isequiv_binary : IsEquiv binary :=
    isequiv_adjointify binary unary' binaryunary unarybinary.

  Definition equiv_binary : nat <~> binnat :=
    Build_Equiv _ _  binary isequiv_binary.

End binary_equiv.

Notation equiv_unary  := equiv_binary ^-1.
Notation unary := equiv_unary.

Section semiring_struct.

  Global Instance binnat_0 : Zero binnat := bzero.
  Global Instance binnat_1 : One binnat := double1 bzero.

  Local Fixpoint binnat_plus' (m n : binnat) : binnat :=
    match m, n with
    | bzero      , n'         => n'
    | double1 m' , bzero      => double1 m'
    (* compute m + n as 2m'+1 + 2n'+1 = 2(m'+n') + 2 *)
    | double1 m' , double1 n' => double2 (binnat_plus' m' n')
    (* compute m + n as 2m'+1 + 2n'+2 = 2(m'+n')+2 + 1 = 2(m' + n' + 1) + 1 *)
    | double1 m' , double2 n' => double1 (Succ (binnat_plus' m' n'))
    | double2 m' , bzero      => double2 m'
    (* compute m + n as 2m'+2 + 2n'+1 = 2(m'+n')+2 + 1 = 2(m' + n' + 1) + 1 *)
    | double2 m' , double1 n' => double1 (Succ (binnat_plus' m' n'))
    (* compute m + n as 2m'+2 + 2n'+2 = 2(m'+n')+2 + 2 = 2(m' + n' + 1) + 2*)
    | double2 m' , double2 n' => double2 (Succ (binnat_plus' m' n'))
    end.
  Global Instance binnat_plus : Plus binnat := binnat_plus'.

  Local Fixpoint binnat_mult' (m n : binnat) : binnat :=
    match m with
    | bzero      => bzero
    (* compute (2m'+1)*n as 2m'n+n *)
    | double1 m' => (binnat_mult' m' n) + (binnat_mult' m' n) + n
    | double2 m' => (binnat_mult' m' n) + (binnat_mult' m' n) + n + n
    end.
  Global Instance binnat_mult : Mult binnat := binnat_mult'.

End semiring_struct.

Section semiring_laws.

  Definition binarysucc (n : nat) : binary n.+1 = Succ (binary n).
  Proof.
    reflexivity.
  Qed.

  Definition unarysucc : forall m, unary (Succ m) = S (unary m).
  Proof.
    equiv_intros binary n.
    rewrite <- binarysucc.
    rewrite eissect, eissect.
    reflexivity.
  Qed.

  Definition binnatplussucc : forall (m n : binnat), (Succ m) + n = Succ (m + n).
  Proof.
    induction m; induction n; try reflexivity; simpl; rewrite <- IHm; done.
  Qed.

  Definition binaryplus (m n : nat) : binary m + binary n = binary (m + n).
  Proof.
    induction m; induction n; try reflexivity.
    - simpl. rewrite binnatplussucc. apply ap. done.
    - simpl. rewrite <- IHm. rewrite binnatplussucc. done.
  Qed.

  Definition unaryplus (m n : binnat) : unary m + unary n = unary (m + n).
  Proof.
    etransitivity (unary (binary (_^-1 m + _^-1 n))).
    - apply ((eissect binary (unary m + unary n)) ^).
    - rewrite <- binaryplus.
      rewrite (eisretr binary m), (eisretr binary n).
      reflexivity.
  Qed.

  Local Instance binnat_add_assoc : Associative binnat_plus.
  Proof.
    hnf; equiv_intros binary x y z.
    change binnat_plus with plus.
    rewrite binaryplus, binaryplus, binaryplus, binaryplus.
    apply ap.
    apply associativity.
  Qed.

  Local Instance binnat_add_comm : Commutative binnat_plus.
  Proof.
    hnf; equiv_intros binary x y.
    change binnat_plus with plus.
    rewrite binaryplus, binaryplus.
    apply ap.
    apply plus_comm.
  Qed.

  Definition binnatmultsucc : forall (m n : binnat), (Succ m) * n = n + (m * n).
  Proof.
    induction m.
    - intros n. change (bzero + n = n + bzero).
      apply commutativity.
    - intros n. simpl.
      change (double2 m * n) with ((m * n) + (m * n) + n + n).
      apply commutativity.
    - intros n. simpl.
      change (double1 (Succ m) * n) with ((Succ m) * n + (Succ m) * n + n).
      rewrite IHm.
      rewrite (commutativity n (double2 m * n)).
      rewrite (commutativity n (m * n)).
      rewrite <- (associativity (m * n) n (m * n + n)).
      rewrite (commutativity n (m * n + n)).
      rewrite (associativity (m * n) _ _).
      rewrite (associativity (m * n) (m * n) n).
      done.
  Qed.

  Definition binarymult (m n : nat) : binary m * binary n = binary (m * n).
  Proof.
    induction m; induction n; try reflexivity; rewrite binnatmultsucc, IHm, binaryplus; done.
  Qed.

  Definition unarymult (m n : binnat) : unary m * unary n = unary (m * n).
  Proof.
    etransitivity (unary (binary (_^-1 m * _^-1 n))).
    - apply ((eissect binary (unary m * unary n)) ^).
    - rewrite <- binarymult.
      rewrite (eisretr binary m), (eisretr binary n).
      reflexivity.
  Qed.

  Local Instance binnat_mult_assoc : Associative binnat_mult.
  Proof.
    hnf; equiv_intros binary x y z.
    change binnat_mult with mult.
    rewrite binarymult, binarymult, binarymult, binarymult.
    apply ap.
    apply associativity.
  Qed.

  Local Instance binnat_mult_comm : Commutative binnat_mult.
  Proof.
    hnf; equiv_intros binary x y.
    change binnat_mult with mult.
    rewrite binarymult, binarymult.
    apply ap.
    apply commutativity.
  Qed.

  Local Instance binnat_distr_l : LeftDistribute binnat_mult binnat_plus.
  Proof.
    hnf; equiv_intros binary x y z.
    change binnat_plus with plus.
    change binnat_mult with mult.
    rewrite binaryplus, binarymult, binarymult, binarymult, binaryplus.
    apply ap.
    apply plus_mult_distr_l.
  Qed.

  Local Instance binnat_distr_r : RightDistribute binnat_mult binnat_plus.
  Proof.
    hnf; equiv_intros binary x y z.
    change binnat_plus with plus.
    change binnat_mult with mult.
    rewrite binaryplus, binarymult, binarymult, binarymult, binaryplus.
    apply ap.
    apply plus_mult_distr_r.
  Qed.

  Global Instance binnat_set : IsHSet binnat.
  Proof.
    apply (istrunc_isequiv_istrunc nat binary).
  Qed.

  Global Instance binnat_semiring : IsSemiRing binnat.
  Proof.
    split; try split; try split; try split; hnf; intros.
    1, 5: exact (binnat_set x y).
    all: apply (equiv_inj unary).
    1, 2, 3, 7: repeat rewrite <- unaryplus.
    4, 5, 6, 7: rewrite <- unarymult.
    4, 5, 7: rewrite <- unarymult.
    4, 5: rewrite <- unarymult.
    4: rewrite <- unaryplus.
    5: rewrite <- unarymult.
    all: apply nat_semiring.
  Qed.

End semiring_laws.

Section naturals.

  Local Instance binary_preserving : IsSemiRingPreserving binary.
  Proof.
    split; split.
    1, 3: hnf; intros x y; [> apply (binaryplus x y) ^ | apply (binarymult x y) ^ ].
    all: reflexivity.
  Qed.

  Global Instance binnat_le : Le binnat := fun m n => unary m <= unary n.
  Global Instance binnat_lt : Lt binnat := fun m n => unary m < unary n.
  Global Instance binnat_apart : Apart binnat := fun m n => unary m ≶ unary n.
  Local Instance binnart_apart_symmetric : IsApart binnat.
  Proof.
    split.
    - apply _.
    - intros x y. apply nat_full.
    - intros x y. apply nat_full.
    - intros x y z w. apply nat_full. assumption.
    - intros m n. split.
      + intros E. apply (equiv_inj unary). apply nat_full. assumption.
      + intros p. apply nat_full. exact (ap unary p).
  Qed.

  Local Instance binnat_full : FullPseudoSemiRingOrder binnat_le binnat_lt.
  Proof.
    split.
    - intros m n; apply nat_le_hprop.
    - split; try intros m n; try apply nat_full.
      + split; try intros m n; try apply nat_full.
        * split; try intros m n; try apply nat_full.
          -- apply _.
          -- apply cotransitive.
          -- split; intros E.
             ++ assert (X : unary m = unary n) by by apply tight_apart.
                apply (((equiv_ap unary m n) ^-1) X).
             ++ rewrite E. apply nat_full. reflexivity.
        * intros E k. apply nat_full. exact E.
      + intros E.
        assert (H : exists w, (unary n) = (unary m) + w) by by apply nat_full.
        destruct H as [w L].
        exists (binary w).
        rewrite <- (eisretr unary w), unaryplus in L.
        apply (equiv_inj unary). exact L.
      + intros m. split; intros k l E; unfold lt, binnat_lt in *.
        * rewrite <- unaryplus, <- unaryplus. apply nat_full. exact E.
        * rewrite <- unaryplus, <- unaryplus in E.
          apply (strictly_order_reflecting (plus (unary m))). exact E.
      + intros k l E. apply nat_full.
        unfold apart, binnat_apart in E.
        rewrite <- (unarymult m n), <- (unarymult k l) in E. exact E.
      + intros E F. unfold lt, binnat_lt. rewrite <- (unarymult m n).
        apply nat_full; assumption.
    - intros m n. apply nat_full.
  Qed.

  Global Instance binnat_naturals_to_semiring : NaturalsToSemiRing binnat:=
    fun _ _ _ _ _ _ => fix f (n: binnat) :=
      match n with
      | bzero => 0
      | double1 n' => 2 * (f n') + 1
      | double2 n' => 2 * (f n') + 2 end.

  Definition nat_to_semiring_helper : NaturalsToSemiRing nat :=
    fun _ _ _ _ _ _ => fix f (n: nat) :=
      match n with
      | 0%nat => 0
      | S n' => 1 + f n'
      end.

  Section for_another_semiring.
    Universe U.
    Context {R:Type} `{IsSemiRing R}.

    Notation toR := (naturals_to_semiring binnat R).
    Notation toR_fromnat := (naturals_to_semiring nat R).
    Notation toR_vianat := (toR_fromnat ∘ unary).

    Definition f_suc (m : binnat) : toR (Succ m) = (toR m)+1.
    Proof.
      induction m.
      - change (2 * 0 + 1 = 0 + 1).
        rewrite mult_comm.
        rewrite mult_0_l.
        done.
      - change (2 * (toR m) + 2 = 2 * (toR m) + 1 + 1).
        apply plus_assoc.
      - induction m as [|m _|m _].
        + change (2 * (2 * 0 + 1) + 1 = 2 * 0 + 2 + 1).
          rewrite plus_mult_distr_l.
          rewrite (@mult_1_r _ Aplus Amult Azero Aone H _).
          rewrite mult_0_r, mult_0_r.
          reflexivity.
        + change (2 * (2 * (toR m) + 2) + 1 = 2 * (2 * (toR m) + 1 ) + 2 + 1).
          apply (ap (fun z => z + 1)).
          assert (L : 2 * toR m + 2 = 2 * toR m + 1 + 1) by by rewrite plus_assoc.
          rewrite L; clear L.
          rewrite plus_mult_distr_l.
          rewrite mult_1_r.
          reflexivity.
        + simpl in IHm.
          change ((2 * (toR (double1 (Succ m))) + 1 = 2 * (toR (double2 m)) + 2 + 1)).
          rewrite IHm; clear IHm.
          rewrite plus_mult_distr_l.
          rewrite mult_1_r.
          reflexivity.
    Qed.

    Definition f_nat : forall m : binnat, toR m = toR_vianat m.
    Proof.
      equiv_intro binary n.
      induction n as [|n IHn].
      - reflexivity.
      - induction n as [|n _].
        + change ((1 + 1) * 0 + 1 = 1).
          rewrite mult_0_r. apply plus_0_l.
        + rewrite f_suc. rewrite IHn.
          assert (L : (toR_fromnat ∘ binary^-1) (binary n.+1) + 1
                      = toR_fromnat ((binary^-1 (binary n.+1)).+1)%nat).
          {
            simpl rewrite (plus_comm _ 1).
            simpl rewrite unarysucc.
            reflexivity.
          }
          rewrite L; clear L.
          rewrite <- unarysucc.
          rewrite <- binarysucc.
          reflexivity.
    Qed.

    Let f_preserves_0: toR 0 =  0.
    Proof. reflexivity. Qed.

    Let f_preserves_1: toR 1 = 1.
    Proof.
      rewrite (f_nat 1).
      reflexivity.
    Qed.

    Let f_preserves_plus (a a' : binnat) : toR (a + a') = toR a + toR a'.
    Proof.
      rewrite f_nat, f_nat, f_nat.
      unfold Compose.
      rewrite <- (unaryplus a a').
      apply nat_to_sr_morphism.
    Qed.

    Let f_preserves_mult (a a' : binnat) : toR (a * a') = toR a * toR a'.
    Proof.
      rewrite f_nat, f_nat, f_nat.
      unfold Compose.
      rewrite <- (unarymult a a').
      apply nat_to_sr_morphism.
    Qed.

    Global Instance binnat_to_sr_morphism
      : IsSemiRingPreserving toR.
    Proof.
      repeat (split;try apply _);trivial.
    Qed.

    Lemma binnat_toR_unique (h : binnat -> R) `{!IsSemiRingPreserving h} : forall x,
        toR x = h x.
    Proof.
      equiv_intro binary n.
      rewrite f_nat; unfold Compose.
      rewrite eissect.
      refine (toR_unique (h ∘ binary) n).
    Qed.
  End for_another_semiring.

  Global Instance binnat_naturals : Naturals binnat.
  Proof.
    split.
    - exact binnat_semiring.
    - exact binnat_full.
    - intros. apply binnat_to_sr_morphism.
    - intros. apply binnat_toR_unique. assumption.
  Qed.

End naturals.

Section decidable.

  Let ineq_bzero_double1 n : bzero <> double1 n.
  Proof.
    intros p.
    change ((fun x => match x with | double1 y => Unit | _ => Empty end) bzero).
    rapply (@transport binnat).
    - exact p^.
    - exact tt.
  Qed.

  Let ineq_bzero_double2 n : bzero <> double2 n.
  Proof.
    intros p.
    change ((fun x => match x with | double2 y => Unit | _ => Empty end) bzero).
    rapply (@transport binnat).
    - exact p^.
    - exact tt.
  Qed.

  Let ineq_double1_double2 m n : double1 m <> double2 n.
  Proof.
    intros p.
    change ((fun x => match x with | double2 y => Unit | _ => Empty end) (double1 m)).
    rapply (@transport binnat).
    - exact p^.
    - exact tt.
  Qed.

  Let undouble (m : binnat) : binnat :=
    match m with
    | bzero => bzero
    | double1 k => k
    | double2 k => k
    end.

  Local Instance double1_inj : IsInjective double1
  := { injective := fun a b E => ap undouble E }.

  Local Instance double2_inj : IsInjective double2
  := { injective := fun a b E => ap undouble E }.

  Global Instance binnat_dec : DecidablePaths binnat.
  Proof.
    intros m; induction m as [|m IHm|m IHm]; intros n; induction n as [|n IHn|n IHn].
    all:
      first
        [ left ; reflexivity
        | right ; (idtac + apply symmetric_neq);
          first
               [ apply ineq_bzero_double1
               | apply ineq_bzero_double2
               | apply ineq_double1_double2
               ]
        | destruct (IHm n) as [eq | ineq];
          [ left; apply ap; exact eq
          | right; intros E;
            first
              [ apply (injective double1) in E
              | apply (injective double2) in E
              ]; auto
          ]
        ].
  Defined.

End decidable.

Section other_laws.

Instance binnat_plus_cancel_l (z:binnat) : LeftCancellation plus z.
Proof.
  intros x y p.
  apply (equiv_inj unary).
  apply (ap unary) in p.
  rewrite <- unaryplus, <- unaryplus in p.
  exact (left_cancellation _ _ _ _ p).
Qed.

Instance binnat_mult_cancel_l (z : binnat): PropHolds (z <> 0) -> LeftCancellation (.*.) z.
Proof.
  intros E. hnf in E.
  assert (H : unary z <> unary 0).
  {
    intros q.
    apply (equiv_inj unary) in q.
    exact (E q).
  }
  intros x y p.
  apply (ap unary) in p.
  rewrite <- unarymult, <- unarymult in p.
  exact (equiv_inj unary (nat_mult_cancel_l (unary z) H _ _ p)).
Qed.

Local Instance binnat_le_total : TotalRelation (_:Le binnat).
Proof.
  intros x y. apply nat_le_total.
Qed.
Local Instance binnat_lt_irrefl : Irreflexive (_:Lt binnat).
Proof.
  intros x. apply nat_lt_irrefl.
Qed.

End other_laws.

Section trichotomy.

  (* TODO this is an inefficient implementation. Instead, write this
  without going via the unary naturals. *)
  Instance binnat_trichotomy : Trichotomy (lt:Lt binnat).
  Proof.
    intros x y.
    pose (T := nat_trichotomy (unary x) (unary y)).
    destruct T as [l|[c|r]].
    - left; assumption.
    - right; left. apply (equiv_inj unary); assumption.
    - right; right; assumption.
  Defined.

End trichotomy.

Section minus.

  Local Definition Pred (m : binnat) : binnat :=
    match m with
    | bzero      => bzero
    | double1 m' => double m'
    | double2 m' => double1 m'
    end.

  Let succ_double (m : binnat) : Succ (double m) = double1 m.
  Proof.
    induction m.
    - reflexivity.
    - change (double1 (Succ (double m)) = double1 (double1 m)).
      rewrite IHm; reflexivity.
    - change (double1 (Succ (Succ (double m))) = double1 (double2 m)).
      rewrite IHm; reflexivity.
  Qed.

  Let double_succ (m : binnat) : double (Succ m) = double2 m.
  Proof.
    induction m.
    - reflexivity.
    - change (double2 (Succ (double m)) = double2 (double1 m)).
      rewrite succ_double; reflexivity.
    - change (double2 (double (Succ m)) = double2 (double2 m)).
      rewrite IHm; reflexivity.
  Qed.

  Let pred_succ (m : binnat) : Pred (Succ m) = m.
  Proof.
    induction m; try reflexivity.
    - exact (double_succ m).
  Qed.

  Let double_pred (m : binnat) : double (Pred m) = Pred (Pred (double m)).
  Proof.
    induction m; try reflexivity.
    - exact (double_succ (double m))^.
  Qed.

  Let pred_double2 (m : binnat) : Pred (double2 m) = double1 m.
  Proof.
    induction m; reflexivity.
  Qed.

  Let pred_double1 (m : binnat) : Pred (double1 m) = double m.
  Proof.
    induction m; reflexivity.
  Qed.

  (*     2*(m-1)+1 = 2*m - 1 *)

  Local Fixpoint binnat_cut_minus' (m n : binnat) : binnat :=
    match m, n with
    | bzero      , n'         => bzero
    | m'         , bzero      => m'
    (* compute m - n as 2m'+1 - 2n'+1 = 2(m'-n') *)
    | double1 m' , double1 n' => double (binnat_cut_minus' m' n')
    (* compute m - n as 2m'+1 - 2n'+2 = 2(m'-n') - 1 = Pred (double (m' - n')) *)
    | double1 m' , double2 n' => Pred (double (binnat_cut_minus' m' n'))
    (* compute m - n as 2m'+2 - 2n'+1 *)
    | double2 m' , double1 n' => Pred (double (binnat_cut_minus' (Succ m') n'))
    (* compute m - n as 2m'+2 - 2n'+2 = 2(m'-n') = double (m' - n') *)
    | double2 m' , double2 n' => double (binnat_cut_minus' m' n')
    end.

  Global Instance binnat_cut_minus: CutMinus binnat := binnat_cut_minus'.

  Let binnat_minus_zero (m : binnat) : m ∸ bzero = m.
  Proof.
    induction m; reflexivity.
  Qed.

  Let binnat_zero_minus (m : binnat) : bzero ∸ m = bzero.
  Proof.
    induction m; reflexivity.
  Qed.

  Let pred_succ_minus (m n : binnat) : Pred (Succ m ∸ n) = m ∸ n.
  Proof.
    revert n; induction m; intros n; induction n; try reflexivity.
    - change (Pred (double (bzero ∸ n)) = bzero).
      rewrite binnat_zero_minus; reflexivity.
    - change (Pred (Pred (double (bzero ∸ n))) = bzero ∸ double2 n).
      rewrite binnat_zero_minus, binnat_zero_minus; reflexivity.
    - change (Pred (Pred (double (Succ m ∸ n))) = double (m ∸ n)).
      rewrite <- double_pred.
      apply ap.
      exact (IHm n).
    - change (double (Succ m) = double2 m ∸ bzero).
      rewrite binnat_minus_zero.
      exact (double_succ m).
    - change (Pred (Pred (double (Succ m ∸ n))) = double (m ∸ n)).
      rewrite <- double_pred.
      apply ap.
      exact (IHm n).
  Qed.

  Let double_cases (m : binnat) : (bzero = double m) + hfiber double2 (double m).
  Proof.
    induction m.
    - left; reflexivity.
    - right; exists (double m); reflexivity.
    - right; exists (Succ (double m)); reflexivity.
  Defined.

  Let binnat_minus_succ (m n : binnat) : Succ m ∸ Succ n = m ∸ n.
  Proof.
    revert n; induction m; intros n; induction n; try reflexivity.
    - change (Pred (double (bzero ∸ n)) = bzero ∸ double1 n).
      rewrite binnat_zero_minus, binnat_zero_minus. reflexivity.
    - change (double (bzero ∸ (Succ n)) = bzero ∸ double2 n).
      rewrite binnat_zero_minus, binnat_zero_minus. reflexivity.
    - change (Pred (double (Succ m ∸ bzero)) = double1 m ∸ bzero).
      rewrite binnat_minus_zero, binnat_minus_zero.
      rewrite double_succ, pred_double2. reflexivity.
    - change (Pred (double (Succ m ∸ Succ n)) = Pred (double (m ∸ n))).
      rewrite IHm. reflexivity.
    - change (double (Succ m ∸ bzero) = double2 m ∸ bzero).
      rewrite binnat_minus_zero, binnat_minus_zero, double_succ.
      reflexivity.
    - change (double (Succ m ∸ Succ n) = double (m ∸ n)).
      rewrite IHm. reflexivity.
  Qed.

  Let binaryminus (x y : nat) : binary x ∸ binary y = binary (x ∸ y).
  Proof.
    revert y; induction x; intros y; induction y; try reflexivity.
    - apply binnat_zero_minus.
    - apply binnat_minus_zero.
    - simpl in *. rewrite binnat_minus_succ.
      rewrite IHx. reflexivity.
  Qed.

  Let unaryminus (m n : binnat) : unary m ∸ unary n = unary (m ∸ n).
  Proof.
    etransitivity (unary (binary (_^-1 m ∸ _^-1 n))).
    - apply ((eissect binary (unary m ∸ unary n)) ^).
    - rewrite <- binaryminus.
      rewrite (eisretr binary m), (eisretr binary n).
      reflexivity.
  Qed.

  Global Instance binnat_cut_minus_spec : CutMinusSpec binnat binnat_cut_minus.
  Proof.
    split.
    - intros m n E. apply (equiv_inj unary).
      rewrite <- unaryplus, <- unaryminus.
      apply nat_cut_minus_spec.
      assumption.
    - intros m n E. apply (equiv_inj unary).
      rewrite <- unaryminus.
      apply nat_cut_minus_spec.
      assumption.
  Qed.

End minus.


Require Import CSet Var.
Require Import Util Map Get Take LengthEq SafeFirst.
Require Export StableFresh VarsUpTo LeastFresh FreshList NaturalRep PidgeonHole.

Set Implicit Arguments.

Lemma all_in_lv_cardinal (lv:set var) n
  : (forall m, _lt m n -> m \In lv) -> cardinal lv >= pred (Pos.to_nat n).
Proof.
  revert lv.
  induction n using Pos.peano_ind; simpl; intros.
  - omega.
  - exploit (IHn (lv \ singleton n)).
    + intros. cset_tac'.
      * eapply H. etransitivity; eauto. nr.
        omega.
    + assert (EQ:lv [=] {n; lv \ singleton n }). {
        exploit (H n); eauto. nr. omega.
        cset_tac.
      }
      rewrite EQ.
      assert (n ∉ lv \ singleton n) by cset_tac.
      erewrite cardinal_2; eauto. nr. omega.
Qed.

Definition fresh (s : set var) : var :=
  Pos.succ (fold Pos.max s 1%positive).

Lemma max_transpose
  : transpose _eq Pos.max.
Proof.
  hnf; intros. hnf.
  rewrite Pos.max_comm.
  rewrite <- Pos.max_assoc.
  setoid_rewrite Pos.max_comm at 2. reflexivity.
Qed.

Lemma fold_max_lt (G:set var)
  : forall (x:var), x ∈ G -> _lt x (Pos.succ (fold Pos.max G 1%positive)).
Proof.
  pattern G. pattern (fold Pos.max G 1%positive). eapply fold_rec.
  - cset_tac.
  - intros ? ? ? ? IN NOTIN ADD LT y yIn.
    eapply ADD in yIn. destruct yIn.
    + rewrite fold_2; eauto.
      * rewrite <- H.
        eapply inj_lt. nr.
        decide ((Pos.to_nat x) < (Pos.to_nat (fold Pos.max s' 1%positive))).
        -- rewrite Max.max_r; eauto. omega.
        -- rewrite Max.max_l; eauto. omega.
      * intuition.
      * eapply max_transpose.
    + rewrite fold_2; eauto using max_transpose.
      * exploit LT; eauto.
        eapply inj_lt. eapply inj_lt in H0. nr.
        decide ((Pos.to_nat x) <= (Pos.to_nat (fold Pos.max s' 1%positive))).
        rewrite Max.max_r; eauto.
        rewrite Max.max_l; omega.
      * intuition.
Qed.

Lemma fresh_spec G : fresh G ∉ G.
Proof.
  intro A. unfold fresh in A.
  pose proof (fold_max_lt A) as B.
  eapply lt_antirefl in B; eauto.
Qed.

Lemma fresh_variable_always_exists (lv:set var) n
  : safe (fun x => x ∉ lv) n.
Proof.
  - decide (_lt (fold Pos.max lv (Pos.of_succ_nat 0)) n).
    + econstructor; intro.
      exploit fold_max_lt. cset_tac.
      exfalso. simpl in *. nr.
      omega.
    + eapply safe_antitone with (n:=Pos.succ (fold Pos.max lv (Pos.of_succ_nat 0))).
      * unfold Proper, respectful. intros. rewrite H. reflexivity.
      * econstructor. intro. exploit fold_max_lt; eauto.
        cset_tac.
        exfalso. simpl in *. nr. omega.
      * simpl in *. nr. omega.
Qed.

Definition least_fresh_gen (lv:set var) : var.
  refine (@safe_first _ _ _ _ (fun x => x ∉ lv) _ (Pos.of_succ_nat 0) _).
  - eapply fresh_variable_always_exists.
Defined.

(*
  Lemma all_in_lv_cardinal (lv:set nat) n
    : (forall m : nat, m < n -> m \In lv) -> cardinal lv >= n.
  Proof.
    general induction n; simpl.
    - omega.
    - exploit (IHn _ _ _ _ _ (lv \ singleton n)).
      + intros. cset_tac'; omega.
      + assert (lv [=] {n; lv \ singleton n }). {
          exploit (H3 (n)); eauto.
          cset_tac.
        }
        rewrite H5.
        assert (n ∉ lv \ singleton n) by cset_tac.
        erewrite cardinal_2; eauto. omega.
  Qed.

  Lemma neg_pidgeon_hole (lv:set nat)
    : (forall m : nat, m <= cardinal lv -> m \In lv) -> False.
  Proof.
    intros. exploit (@all_in_lv_cardinal lv (S (cardinal lv))).
    intros; eapply H; eauto. omega. omega.
  Qed.
 *)

Lemma least_fresh_full_spec G
  : least_fresh_gen G ∉ G
    /\ pred (Pos.to_nat (least_fresh_gen G)) <= cardinal G
    /\ forall m, _lt m (least_fresh_gen G) -> m ∈ G.
Proof.
  unfold least_fresh_gen.
  eapply safe_first_spec
    with (I:= fun n => le (pred (Pos.to_nat n)) (cardinal G) /\ forall m, _lt m n -> m ∈ G).
  - intros ? [A B] NOTIN.
    assert (IN:n ∈ G) by cset_tac. clear NOTIN.
    split.
    + eapply all_in_lv_cardinal.
      intros. decide (Pos.to_nat m = Pos.to_nat n); try rewrite e in *; eauto.
      * eapply Pos2Nat.inj in e. subst; eauto.
      * unfold NaturalRep.succ in *. simpl in *.
        eapply B. nr. omega.
    + intros. decide (Pos.to_nat m = Pos.to_nat n); try rewrite e in *; eauto.
      * eapply Pos2Nat.inj in e. subst; eauto.
      * unfold NaturalRep.succ in *. simpl in *.
        eapply B. nr. omega.
  - intuition.
  - split; intros; simpl in *. omega.
    exfalso.
    eapply Pos.nlt_1_r in H; eauto.
Qed.

Lemma least_fresh_gen_ext (G G':set var)
  : G [=] G'
    -> least_fresh_gen G = least_fresh_gen G'.
Proof.
  intros. unfold least_fresh_gen.
  eapply safe_first_ext; eauto.
  split; intros.
  - rewrite <- H; eauto.
  - rewrite H; eauto.
Qed.

Instance LeastFreshNat : LeastFresh.LeastFresh var :=
  {
    least_fresh := @least_fresh_gen
  }.
Proof.
  - intros. eapply least_fresh_full_spec.
  - intros. eapply least_fresh_full_spec; eauto.
  - intros. eapply least_fresh_gen_ext; eauto.
Qed.

Lemma least_fresh_list_small (G:set var) n
  : forall i x, get (fresh_list least_fresh G n) i x -> pred (Pos.to_nat x) < cardinal G + n.
Proof.
  general induction n; simpl in *; isabsurd.
  - invc H.
    + clear IHn.
      pose proof (least_fresh_least G).
      eapply all_in_lv_cardinal in H.
      omega.
    + exploit IHn; eauto.
      erewrite cardinal_2 with (s:=G) in H. omega.
      eapply (least_fresh_spec). cset_tac.
Qed.

Lemma least_fresh_list_ext X `{LeastFresh X}  n (G:set X) G'
  : G [=] G'
    -> fresh_list least_fresh G n = fresh_list least_fresh G' n.
Proof.
  intros.
  eapply fresh_list_ext; eauto.
  eapply least_fresh_spec.
  eapply least_fresh_ext.
Qed.

Lemma least_fresh_list_small_vars_up_to (G:set var) (n:nat)
  : of_list (fresh_list least_fresh G n) ⊆ vars_up_to (Pos.of_succ_nat (cardinal G + n)).
Proof.
  eapply get_in_incl; intros.
  eapply in_vars_up_to.
  eapply least_fresh_list_small in H; eauto.
  rewrite <- Pos.succ_of_nat.
  - eapply inj_lt.
    rewrite Pos2Nat.inj_succ. rewrite Nat2Pos.id. omega. omega.
  - omega.
Qed.

(*
Lemma inverse_on_update_fresh_list (D:set nat) (Z:list nat) (ϱ ϱ' : nat -> nat)
 : inverse_on (D \ of_list Z) ϱ ϱ'
  -> inverse_on D (update_with_list Z (fresh_list fresh (lookup_set ϱ (D \ of_list Z)) (length Z)) ϱ)
                 (update_with_list (fresh_list fresh (lookup_set ϱ (D \ of_list Z)) ((length Z))) Z ϱ').
Proof.
  intros. eapply inverse_on_update_fresh; eauto. intros.
  eapply fresh_list_nodup, fresh_spec. eauto with len.
  eapply fresh_list_spec, fresh_spec.
Qed.
 *)


Set Implicit Arguments.
Require Import List Omega std calculus
higher_order_unification nth_order_unification.

(** * Enumerability *)

(** ** Terms, Types and Contexts *)
Section ListEnumerability.
  Variable (X: Const).

  Hypothesis (enumX: enumT X).

  Fixpoint L_exp (n: nat) : list (exp X) :=
    match n with
    | 0 => nil
    | S n => L_exp n
                  ++ [var x | x ∈ L_T nat n]
                  ++ [const c | c ∈ L_T X n]
                  ++ [lambda s | s ∈ L_exp n]
                  ++ [app s t | (s, t) ∈ (L_exp n × L_exp n)]
    end.

  Global Instance enumT_exp: enumT (exp X) := { L_T := L_exp }.
  Proof.
    - eauto.
    - induction x as [y|c|s| s IH1 t IH2].
      + destruct (el_T y). exists (S x). cbn.
        in_app 2. now in_collect y.
      + destruct (el_T c). exists (S x). cbn.
        in_app 3. now in_collect c.
      + destruct IHs. exists (S x). cbn.
        in_app 4. now in_collect s.
      + destruct IH1 as [x1], IH2 as [x2]. exists (S (x1 + x2)). cbn.
        in_app 5. in_collect (s, t); eapply cum_ge'; eauto.
  Qed.

  Fixpoint L_type (n: nat) : list (type) :=
    match n with
    | 0 => nil
    | S n => L_type n
                   ++ [typevar x | x ∈ L_T nat n]
                   ++ [A → B | (A, B) ∈ (L_type n × L_type n)]
    end.

  Global Instance enumT_type: enumT type := { L_T := L_type }.
  Proof.
    - eauto.
    - induction x as [beta|A IH1 B IH2].
      + destruct (el_T beta). exists (S x). cbn.
        in_app 2. now in_collect beta.
      + destruct IH1 as [x1], IH2 as [x2]. exists (S (x1 + x2)). cbn.
        in_app 5. in_collect (A, B); eapply cum_ge'; eauto.
  Qed.

  (** ** Typing Proofs *)
  Fixpoint L_typingT Gamma s A n : list (Gamma ⊢ (s: exp X) : A) :=
    match n with
    | 0 => nil
    | S n => L_typingT Gamma s A n ++
                      match s as s return list (Gamma ⊢ s : A) with
                      | var i => [typingVar Gamma i H where H: nth Gamma i = Some A]
                      | const c => [cast (typingConst Gamma c) H where H : ctype X c = A]
                      | lambda s => match A with
                              | typevar beta => nil
                              | A → B => [ typingLam H | H ∈ L_typingT (A :: Gamma) s B n]
                              end
                      | app s t =>
                        [typingApp H1 H2 | (H1, H2) ∈ (L_typingT Gamma s (A1 → A) n × L_typingT Gamma t A1 n) & A1 ∈ L_T n]
                      end
    end.

  Scheme typing_strong_ind := Induction for typing Sort Prop.

  Global Instance enumT_typing Gamma (s: exp X) A: enumT (Gamma ⊢ s: A) := { L_T := L_typingT Gamma s A }.
  Proof.
    - eauto.
    - intros x.
      induction x using typing_strong_ind.
      + exists 1. cbn. destruct dec; intuition. in_app 1. f_equal.
        eapply Eqdep_dec.inj_pair2_eq_dec. eapply eq_dec. now destruct e, e0.
      + exists 1. cbn. destruct dec; intuition; cbn. left.
        unfold cast; rewrite <-Eqdep_dec.eq_rect_eq_dec; eauto. decide equality. decide equality.
      + edestruct IHx as [m]. exists (S m); cbn.
        in_app 2. now in_collect x.
      + edestruct IHx1 as [x1'], IHx2 as [x2'], (el_T A) as [x3'].
        exists (S (x1' + x2' + x3')); cbn; in_app 3.
        eapply in_flat_map. exists A. split.
        2: in_collect (x1, x2).
        all: eauto using cum_ge'.
  Qed.

  Fixpoint L_typing n : list (ctx * exp X * type) :=
    match n with
    | 0 => nil
    | S n =>
      L_typing n ++ [(Gamma, s, A) | (Gamma, s, A) ∈ (L_T n × L_T n × L_T n), |@L_T (Gamma ⊢ s : A) _ n| <> 0]
    end.

  Lemma enum_typing:
    enum (fun '(Gamma, s, A) => Gamma ⊢ (s: exp X) : A) L_typing.
  Proof with eauto using cum_ge'.
    split; eauto.
    intros [[Gamma s] A]; split.
    - intros H. destruct (el_T Gamma) as [x1], (el_T s) as [x2], (el_T A) as [x3], (el_T H) as [x4]. exists (S (x1+x2+x3+x4)); cbn.
      in_app 2. in_collect (Gamma, s, A).
      1 - 3: eapply cum_ge'; eauto; omega.
      eapply dec_decb. eapply cum_ge' with (m := x1 + x2 + x3 + x4) in H3; eauto.
      destruct (@L_T (Gamma ⊢ s : A) _ _); cbn; eauto.
    - intros [m H];  induction m in Gamma, s, A, H |-*; cbn in *. eauto.
      inv_collect; injection H; intros; subst.  eapply decb_dec in H1; intuition; subst.
      destruct (@L_T (Gamma ⊢ s : A) _ m); intuition.
  Qed.

  Fixpoint L_uni (n: nat) : list (uni X) :=
    match n with
    | 0 => nil
    | S n => L_uni n ++ flat_map (fun '(Gamma, s, t, A) => [@Build_uni _ Gamma s t A H1 H2 | (H1, H2) ∈ (L_T n × L_T n)])
                  [(Gamma, s, t, A) | (Gamma, s, t, A) ∈ (L_T n × L_T n × L_T n × L_T n)]
    end.

  Global Instance enumT_uni:
    enumT (uni X) := {L_T := L_uni}.
  Proof with eauto using cum_ge'.
    - eauto.
    - intros [Gamma s t A H1 H2].
      destruct (el_T Gamma) as [x1], (el_T s) as [x2], (el_T t) as [x3], (el_T A) as [x4], (el_T H1) as [x5], (el_T H2) as [x6].
      exists (S (x1 + x2 + x3 + x4 + x5 + x6)); cbn. in_app 2.
      eapply in_flat_map. exists (Gamma, s, t, A). intuition.
      + in_collect (Gamma, s, t, A); eapply cum_ge'; eauto;omega.
      + in_collect (H1, H2)...
  Qed.

  Fixpoint L_subst (tau: fin -> exp X) (n: nat) :  list (ctx * (fin -> exp X) * ctx) :=
    match n with
    | 0 => nil
    | S n => L_subst tau  n
                    ++ [(Delta, tau, nil) | Delta ∈ L_T n]
                    ++ [(Delta, s .: sigma, A :: Gamma) | ((Delta, sigma, Gamma), (Delta', s, A)) ∈ (L_subst (S >> tau) n × L_typing n), Delta = Delta']
    end.

  (** ** Substitutions *)
  Lemma enum_substs tau:
    enum (fun '(Delta, sigma, Gamma) => Delta ⊩ (sigma: fin -> exp X) : Gamma /\ forall x, x >= | Gamma | -> sigma x = tau x) (L_subst tau).
  Proof.
    destruct enum_typing as [_ E'].
    split; eauto; intros [[Delta sigma] Gamma]; split.
    - intros [H1 H2].
      induction Gamma as [| A Gamma] in sigma, tau, H1, H2 |-*.
      + destruct (el_T Delta) as [x]; exists (S x); cbn.
        in_app 2. in_collect Delta; eauto. repeat f_equal. symmetry; fext; intros; eapply H2; cbn; omega.
      + specialize (IHGamma (S >> tau) (S >> sigma) ); mp IHGamma; [| mp IHGamma]; eauto.
        * intros ???. now eapply H1.
        * intros; unfold funcomp; eapply H2; cbn; omega.
        * assert (Delta ⊢ sigma 0 : A) by eauto.
          specialize (E' (Delta, sigma 0, A)); cbn in E'. eapply E' in H as [x1].
          destruct IHGamma as [x2]. exists (1 + x1 + x2); cbn.
          in_app 3. in_collect ((Delta, S >> sigma, Gamma), (Delta, sigma 0, A)); eauto using cum_ge'.
          repeat f_equal; fext; now intros [].
    - intros [m H]; induction m in tau, sigma, Gamma, H |-*; cbn in H; eauto.
      inv_collect; try injection H; intros; subst; eauto.
      1 - 2: eapply IHm in H; intuition.
      + intros []?; cbn; discriminate.
      + eapply decb_dec in H1; subst. eapply typingSubst_cons.
        eapply IHm; eauto. eapply (E' (c, e, t)). eauto.
      + eapply decb_dec in H2; subst. destruct x; cbn in H0; try omega; cbn.
        edestruct IHm as [_ ->]; eauto; omega.
  Qed.

  Definition Uextended '(I, Delta, sigma) :=
    Delta ⊩ sigma : @Gammaᵤ X I /\ sigma • sᵤ ≡ sigma • tᵤ /\ forall x, x >= |Gammaᵤ| -> sigma x = var x.

  Fixpoint L_Uextended (n: nat) : list (uni X * ctx * (fin -> exp X)) :=
    match n with
    | 0 => nil
    | S n => L_Uextended n ++ [(I, Delta, sigma) | (I, (Delta, sigma, Gamma)) ∈ (@L_T (uni X) _ n × L_subst var n ),
                                  Gamma = Gammaᵤ  /\ xi n (sigma • sᵤ) <> None /\ xi n (sigma • tᵤ) <> None /\ xi n (sigma • sᵤ) = xi n (sigma • tᵤ)]

    end.

  Lemma enum_unification' : enum Uextended L_Uextended.
    split; eauto.
    intros [[I Delta] sigma]. unfold Uextended; cbn; split.
    - intros (H3 & H4 & H5). destruct (el_T I) as [x1].
      destruct (enum_substs var) as [_ E].
      specialize (E (Delta, sigma, Gammaᵤ)); cbn in E; destruct E as [[x2 E] _]; [intuition|].
      assert ({ s' | (sigma • sᵤ) ▷ s' }) as [s' E1] by
            (eapply compute_evaluation_step, termination_steps, preservation_under_substitution; eauto using H1ᵤ).
      assert ({ t' | (sigma • tᵤ) ▷ t' }) as [t' E2] by
            (eapply compute_evaluation_step, termination_steps, preservation_under_substitution; eauto using H2ᵤ).
      eapply xi_correct in E1 as E1'; destruct E1' as [x3];
        eapply xi_correct in E2 as E2'; destruct E2' as [x4].
      exists (S (x1 + x2 + x3 + x4)); cbn. in_app 2.
      in_collect (I, (Delta, sigma, Gammaᵤ)).
      + eapply cum_ge'; eauto; omega.
      + eapply cum_ge'; eauto; omega.
      + eapply xi_monotone with (m := x1 + x2 + x3 + x4) in H0; [|omega].
        eapply xi_monotone with (m := x1 + x2 + x3 + x4) in H1; [|omega].
        eapply dec_decb; intuition; try congruence.
        rewrite H0, H1. f_equal. destruct E1, E2.
        rewrite H2, H7 in H4. eapply equiv_unique_normal_forms; eauto.
    - intros [m H]; induction m; cbn in H; eauto.
      eapply (inhabited_ind id).
      inv_collect; injection H; intros; subst.
      eapply decb_dec in H1. intuition; subst.
      destruct (enum_substs var) as [_ H'].
      specialize (H' (Delta, sigma, Gammaᵤ)) as [_ H']; cbn in H'.
      mp H'; eauto. eapply inhabits; intuition.
      destruct (xi m (sigma • sᵤ)) eqn: Hs; intuition.
      destruct (xi m (sigma • tᵤ)) eqn: Ht; intuition.
      injection H6 as <-.
      eapply equiv_huet_backward with (v1 := e) (v2 := e); eauto.
      all: eapply xi_correct; now (exists m).
  Qed.

End ListEnumerability.

(** ** Higher-Order Unification *)
Theorem enumerable_unification (X: Const): enumerable__T X -> enumerable (U X).
Proof.
  rewrite enum_enumT. intros [EX].
  eapply enumerable_iff with (P := fun I => exists Delta sigma, Uextended (I, Delta, sigma)).
  - intros [Gamma s t A ? ?]; unfold Uextended, U; cbn; split; intros [Delta [sigma []]].
    exists Delta; exists sigma; intuition.
    pose (tau x := if nth Gamma x then sigma x else var x). exists Delta; exists tau; intuition.
    unfold tau; intros ?? H'; rewrite H'; eauto.
    repeat rewrite subst_extensional with (sigma0 := tau) (tau0 := sigma); eauto.
    1 - 2: intros ? H'; assert (x ∈ dom Gamma) as H1 by eauto using typing_variables; unfold tau; now domin H1.
    unfold tau. now eapply nth_error_None in H1 as ->.
  - eapply projection with (p := fun x: uni X * ctx => exists sigma, let (I, Delta) := x in Uextended (I, Delta, sigma)).
    eapply projection with (p := @Uextended X).
    eapply enumerable_enum; exists (@L_Uextended X EX); eapply enum_unification'.
Qed.


Require Import Coq.Arith.Arith.
Require Import RGref.DSL.DSL.

(** * A Strictly Positive Monotonic Counter
   A monotonically increasing non-zero counter.
   A slightly better basic example than the plain monotonic counter since this one has a nontrivial refinement. *)

Definition increasing : hrel nat := (fun n n' _ _ => n <= n').
Hint Unfold increasing.

Definition pos : hpred nat := (fun n _ => n > 0).

(** We'll give the Program extension some hints for this module *)
Local Obligation Tactic := intros; eauto with arith; compute; eauto with arith.

(** Now the definition of a verified monotonically increasing counter is
    barely more work than a completely unchecked counter. *)
Program Definition posmonotonic_counter := ref{nat|pos}[increasing,increasing].

Program Definition read_counter (c:posmonotonic_counter) : nat := !c.

Program Definition inc_monotonic { Γ } (p:posmonotonic_counter) : rgref Γ unit Γ :=
  [p]:= !p + 1.

Program Definition mkCounter { Γ } (u:unit) : rgref Γ posmonotonic_counter Γ :=
  Alloc 1.

Program Example test_counter { Γ } (u:unit) : rgref Γ unit Γ :=
  x <- mkCounter tt;
  inc_monotonic x.