From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq fintype path.
From fcsl
Require Import ordtype unionmap.
From Toychain
Require Import Types Parameters Address.
Require Import BinNat BinNatDef.
Require Import HexString String Ascii.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section NEq.
Lemma eq_NP : Equality.axiom N.eqb.
Proof.
case=>[x|p x]//=; case: x.
by constructor 1; apply N.Private_Tac.eq_refl.
by constructor 2.
by constructor 2.
move=> p' /=; case X: (BinPos.Pos.eqb p p'); constructor.
  by move/BinPos.Peqb_true_eq: X =>->.
by move/BinPos.Pos.eqb_neq: X => X; case.
Qed.
End NEq.

Section NOrd.
Lemma irr_ltbN : irreflexive N.ltb.
Proof. by case=>[|n]//; apply N.ltb_irrefl. Qed.

Lemma trans_ltbN : transitive N.ltb.
Proof.
by move=>x y z; move=>/N.ltb_lt A /N.ltb_lt B;
   apply/N.ltb_lt; move: (N.lt_trans _ _ _ A B).
Qed.

Lemma total_ltbN x y : [|| N.ltb x y, x == y | N.ltb y x].
Proof.
apply/or3P; case: (N.compare_spec x y).
by move=>->; constructor 2.
by constructor 1; apply/N.ltb_lt.
by constructor 3; apply/N.ltb_lt.
Qed.

Definition N_ordMixin := Eval hnf in OrdMixin irr_ltbN trans_ltbN total_ltbN.
Canonical N_ordType := Eval hnf in OrdType N N_ordMixin.
End NOrd.

Section StringEq.

(* Define so we can reuse proofs from above *)
Definition ascii_eqb (a b : ascii) : bool :=
 match a, b with
 | Ascii a0 a1 a2 a3 a4 a5 a6 a7,
   Ascii b0 b1 b2 b3 b4 b5 b6 b7 =>
   (a0 == b0) && (a1 == b1) && (a2 == b2) && (a3 == b3)
   && (a4 == b4) && (a5 == b5) && (a6 == b6) && (a7 == b7)
 end.

Lemma ascii_eqP : Equality.axiom ascii_eqb.
Proof.
case=>a0 a1 a2 a3 a4 a5 a6 a7; case=>b0 b1 b2 b3 b4 b5 b6 b7.
rewrite/ascii_eqb.
(case:a0;case:b0=>/=; do? by constructor);
(case:a1;case:b1=>/=; do? by constructor);
(case:a2;case:b2=>/=; do? by constructor);
(case:a3;case:b3=>/=; do? by constructor);
(case:a4;case:b4=>/=; do? by constructor);
(case:a5;case:b5=>/=; do? by constructor);
(case:a6;case:b6=>/=; do? by constructor);
(case:a7;case:b7=>/=; do? by constructor).
Qed.

Definition ascii_eqMixin := EqMixin ascii_eqP.
Canonical ascii_eqType := Eval hnf in EqType ascii ascii_eqMixin.

Fixpoint string_eqb (s1 s2 : string): bool :=
 match s1, s2 with
 | EmptyString, EmptyString => true
 | String c1 s1', String c2 s2' => ascii_eqb c1 c2 && string_eqb s1' s2'
 | _,_ => false
end.

Lemma ascii_eqb_refl x : ascii_eqb x x.
Proof. by case: x=>b0 b1 b2 b3 b4 b5 b6 b7//=; rewrite !eq_refl. Qed.

Lemma string_eqP : Equality.axiom string_eqb.
Proof.
rewrite/Equality.axiom=>s1; elim: s1; first by case; constructor.
move=>x xs Hi; case; first by constructor.
move=>y ys; case E: (x == y).
- move/eqP in E; rewrite -E//=.
  rewrite ascii_eqb_refl//=; move: (Hi ys).
  case; first by move=>->; constructor.
  by move=>X; constructor; case.
move/eqP in E; have X: (String x xs <> String y ys) by case.
specialize (Hi ys); rewrite/string_eqb.
case Q: (ascii_eqb x y)=>//=.
by move: (ascii_eqP x y Q).
by constructor.
Qed.

Definition string_eqMixin := EqMixin string_eqP.
Canonical string_eqType := Eval hnf in EqType string string_eqMixin.
End StringEq.

Section StringOrd.

Lemma ascii_eqb_N x y :
  ascii_eqb x y = (N_of_ascii x == N_of_ascii y).
Proof.
case E: (x == y); first by move/eqP: E=>->; rewrite ascii_eqb_refl eq_refl.
have X: (ssrfun.cancel N_of_ascii ascii_of_N)
  by move=>z; apply ascii_N_embedding.
move: (can_eq X x y)=>->; rewrite E.
case Z: (ascii_eqb x y)=>//.
by move: (ascii_eqP x y Z); move/eqP: E.
Qed.

Definition ascii_ltb (a b : ascii) : bool := N.ltb (N_of_ascii a) (N_of_ascii b).

Lemma irr_ascii : irreflexive ascii_ltb.
by rewrite/irreflexive/ascii_ltb=>x; apply irr_ltbN.
Qed.

Lemma trans_ascii : transitive ascii_ltb.
by rewrite/transitive/ascii_ltb=>x y z; apply trans_ltbN.
Qed.

Lemma total_ascii x y : [|| ascii_ltb x y, x == y | ascii_ltb y x].
Proof.
rewrite/ascii_ltb.
suff X: ((x == y) = (N_of_ascii x == N_of_ascii y))
  by rewrite X; apply total_ltbN.
case Q: (x == y); first by move/eqP: Q=>->; rewrite eq_refl.
rewrite -ascii_eqb_N; case X: (ascii_eqb x y)=>//=.
by move: (ascii_eqP x y X); move/eqP: Q.
Qed.

Definition ascii_ordMixin := OrdMixin irr_ascii trans_ascii total_ascii.
Canonical Structure ascii_ordType := Eval hnf in OrdType ascii ascii_ordMixin.

(* Make use of embedding string -> seq ascii;
   This way, we can reuse the proofs from above.
   For some reason, Strings.v doesn't export this; so have to copy/paste.
*)
Fixpoint string_of_list_ascii (s : list ascii) : string
  := match s with
     | nil => EmptyString
     | cons ch s => String ch (string_of_list_ascii s)
     end.

Fixpoint list_ascii_of_string (s : string) : list ascii
  := match s with
     | EmptyString => nil
     | String ch s => cons ch (list_ascii_of_string s)
end.

Lemma embedding_list_ascii s : string_of_list_ascii (list_ascii_of_string s) = s.
Proof.
  induction s as [|? ? IHs]; [ reflexivity | cbn; apply f_equal, IHs ].
Defined.

Definition string_ltb (s1 s2 : string): bool :=
  ords (list_ascii_of_string s1) (list_ascii_of_string s2).

Lemma irr_string : irreflexive string_ltb.
Proof. by elim=>[|c s x]; apply irr_ords. Qed.

Lemma trans_string : transitive string_ltb.
Proof.
by rewrite/transitive=>x y z; rewrite/string_ltb; apply trans_ords.
Qed.

Lemma total_string x y : [|| string_ltb x y, x == y | string_ltb y x].
Proof.
case X: ((x == y) == (list_ascii_of_string x == list_ascii_of_string y)).
by move/eqP in X; rewrite X; rewrite/string_ltb; apply total_ords.
have E: ssrfun.cancel list_ascii_of_string string_of_list_ascii .
  by move=>z; apply embedding_list_ascii.
by move: (can_eq E x y)=>X'; move: X; rewrite X' eq_refl.
Qed.

Definition string_ordMixin := OrdMixin irr_string trans_string total_string.
Canonical Structure string_ordType := Eval hnf in OrdType string string_ordMixin.

End StringOrd.

(** Instantiate the types *)
Module TypesImpl <: Types.
Definition Timestamp := N.
Definition Hash := string.
Definition VProof := N.
Definition Transaction := string.

(* XXX Having to do this is immensely annoying. Is there a better way? *)
Definition Hl (a b : Hash) := string_ltb a b.
Lemma irr_Hl : irreflexive Hl. Proof. by apply irr_string. Qed.
Lemma trans_Hl : transitive Hl. Proof. by apply trans_string. Qed.
Lemma total_Hl x y : [|| Hl x y, x == y | Hl y x]. Proof. by apply total_string. Qed.

Definition Hash_eqMixin := Eval hnf in EqMixin string_eqP.
Canonical Hash_eqType := Eval hnf in EqType Hash Hash_eqMixin.
Definition Hash_ordMixin := Eval hnf in OrdMixin irr_Hl trans_Hl total_Hl.
Canonical Hash_ordType := Eval hnf in OrdType Hash Hash_ordMixin.

Definition Vl (a b : VProof) := N.ltb a b.
Lemma irr_Vl : irreflexive Vl. Proof. by apply irr_ltbN. Qed.
Lemma trans_Vl : transitive Vl. Proof. by apply trans_ltbN. Qed.
Lemma total_Vl x y : [|| Vl x y, x == y | Vl y x]. Proof. by apply total_ltbN. Qed.

Canonical VProof_eqMixin := Eval hnf in EqMixin eq_NP.
Canonical VProof_eqType := Eval hnf in EqType VProof VProof_eqMixin.
Canonical VProof_ordMixin := Eval hnf in OrdMixin irr_Vl trans_Vl total_Vl.
Canonical VProof_ordType := Eval hnf in OrdType VProof VProof_ordMixin.

Definition Tl (a b : Transaction) := string_ltb a b.
Lemma irr_Tl : irreflexive Hl. Proof. by apply irr_string. Qed.
Lemma trans_Tl : transitive Hl. Proof. by apply trans_string. Qed.
Lemma total_Tl x y : [|| Tl x y, x == y | Tl y x]. Proof. by apply total_string. Qed.

Definition Transaction_eqMixin := Eval hnf in EqMixin string_eqP.
Canonical Transaction_eqType := Eval hnf in EqType Transaction Transaction_eqMixin.
Definition Transaction_ordMixin := Eval hnf in OrdMixin irr_Tl trans_Tl total_Tl.
Canonical Transaction_ordType := Eval hnf in OrdType Transaction Transaction_ordMixin.

Record Block  :=
  mkB {
    prevBlockHash : Hash;
    txs : seq Transaction;
    proof : VProof;
  }.

Definition eq_block b b':=
  match b, b' with
  | mkB p t pf, mkB p' t' pf' =>
    [&& p == p', t == t' & pf == pf']
  end.

Lemma eq_blockP : Equality.axiom eq_block.
Proof.
case=> p t pf; case=> p' t' pf'; rewrite /eq_block/=.
case H2: (p == p'); [move/eqP: H2=>?; subst p'| constructor 2];
  last by case=>?; subst p';rewrite eqxx in H2.
case H3: (t == t'); [move/eqP: H3=>?; subst t'| constructor 2];
  last by case=>?; subst t';rewrite eqxx in H3.
case H4: (pf == pf'); [move/eqP: H4=>?; subst pf'| constructor 2];
  last by case=>?; subst pf';rewrite eqxx in H4.
by constructor 1.
Qed.

Definition Block_eqMixin := Eval hnf in EqMixin eq_blockP.
Canonical Block_eqType := Eval hnf in EqType Block Block_eqMixin.

Lemma eq_block_fields b b':
  prevBlockHash b == prevBlockHash b' ->
  txs b == txs b' ->
  proof b == proof b' ->
  b == b'.
Proof.
by case: b=>b0 b1 b2; case: b'=> b0' b1' b2'=>//=; move=>/eqP -> /eqP -> /eqP ->.
Qed.

(* Do not confuse with FCR, which is what the protocol actually uses.
   This is a tie-breaker in case two blockchains have the same total work. *)
Definition block_ltb b b' :=
  let eA := txs b == txs b' in
  let eB := prevBlockHash b == prevBlockHash b' in
  let eC := proof b == proof b' in
  let A := ords (txs b) (txs b') in
  let B := Hl (prevBlockHash b) (prevBlockHash b') in
  let C := Vl (proof b) (proof b') in

  match eA, eB, eC with
  | true, true, true => false
  | true, true, false => C
  | true, _, _ => B
  | false, _, _ => A
  end.

  (* The definition above seems like overkill, but is actually minimal
      wrt. being provably both transitive and total. The one below is
      total, but not transitive:

        [|| ords (txs b) (txs b'), Hl (prevBlockHash b) (prevBlockHash b') |
                Vl (proof b) (proof b')].
   *)

Lemma irr_bl : irreflexive block_ltb.
Proof. by move=>x; rewrite/block_ltb !eq_refl. Qed.

Lemma trans_bl : transitive block_ltb.
Proof.
move=>x y z; rewrite/block_ltb; case: ifP; case: ifP; case: ifP=>//=;
move=> A B C D; (do? rewrite A; do? rewrite B; do? rewrite C; do? rewrite D).
- case: ifP; case: ifP=>//=.
  case: ifP; case: ifP=>//=.
  case: ifP. case: ifP.
    by move/eqP=><- _ _ _ _ _ D'; move: (trans_Vl D D') (irr_Vl (proof y))=>->.
    by move=>_ _ _ _ _ _ D'; move: (trans_Vl D D').
    by move/eqP: B=>-> ->.
    by move/eqP: C=>-> ->.
    by move/eqP in C; move/eqP in B; rewrite B C=>-> ->.
    by move/eqP: C=>-> /eqP -> /eqP.
    by move/eqP: C=>->.
- case: ifP; case: ifP=>//=.
  case: ifP. case: ifP. case: ifP;
    by move=>_ /eqP <- _ _ /eqP B'; rewrite B' in B; move/eqP: B.
    by move=>_ _ _ /eqP X; move: X D=>->.
    by move/eqP: A; move/eqP: C=>->->/eqP.
  case: ifP. case: ifP;
    by move=>_/eqP <- _ _ D'; move: (trans_Hl D' D) (irr_Hl (prevBlockHash x))=>->.
    by move=>_ _ _ D'; move: (trans_Hl D D').
    by move/eqP: A; move/eqP: C=>->-> /eqP.
- case: ifP. case: ifP. case: ifP;
    by move=>_ _ /eqP; move/eqP: C=>-> A'; rewrite A' eq_refl in A.
    by move=>_ /eqP; move/eqP: C=>-> A'; rewrite A' eq_refl in A.
    by move/eqP: C=>->.
- case: ifP=>//=. case: ifP.
  by move/eqP in B; rewrite B in C; rewrite C.
  by move/eqP: B=><-.
- by move/eqP  in B; rewrite B in C; rewrite C; rewrite B in D.
- by move: D; move/eqP: A=>-> X Y; move: (trans_ords X Y) (irr_ords (txs z))=>->.
by apply trans_ords.
Qed.

Lemma total_bl x y : [|| block_ltb x y, x == y | block_ltb y x].
Proof.
rewrite/block_ltb.
case: ifP; case: ifP.
- case: ifP; case: ifP.
  by move=>_ B C A; move: (eq_block_fields C A B)=>/eqP ->; rewrite !eq_refl.
  by move=>A _ _ /eqP A'; rewrite A' in A; move/eqP: A.
  move=>_ B /eqP C A; rewrite C eq_refl (eq_sym (proof _)) B;
  case/or3P: (total_Vl (proof x) (proof y)); first by move=>->.
    by move/eqP=>B'; rewrite B' in B; move/eqP: B.
    by move=>->; apply/or3P; constructor 3.
  by move=>A _ _ /eqP A'; rewrite A' in A; move/eqP: A.
- case: ifP. case: ifP. case: ifP;
  by move=>_ /eqP ->; rewrite eq_refl.
  case/or3P: (total_Hl (prevBlockHash x) (prevBlockHash y)).
    by move=>->.
    by move/eqP=>->; rewrite eq_refl.
    by move=>-> _ _ _ _; apply/or3P; constructor 3.
  by move=>A _ /eqP A'; rewrite A' in A; move/eqP: A.
- by move/eqP=>->; rewrite eq_refl.
- move=>_ X; case/or3P: (total_ords (txs x) (txs y)).
  by move=>->.
  by move/eqP=>X'; rewrite X' in X; move/eqP: X.
  by move=>->; apply/or3P; constructor 3.
Qed.

Definition block := Block.
Definition block_ordMixin := Eval hnf in OrdMixin irr_bl trans_bl total_bl.
Canonical block_ordType := Eval hnf in OrdType block block_ordMixin.

Definition Blockchain := seq block.

Definition TxPool := seq Transaction.
Definition BlockTree := union_map [ordType of Hash] block.
End TypesImpl.


Require Import Coqlib.
Require Import Coqlib2.

(* deliberately imported here *)
Require Import Coq.Wellfounded.Inclusion.
Require Import Coq.Wellfounded.Inverse_Image.

Require Import ssreflect ssrbool ssrnat ssrfun fintype.
Set Implicit Arguments.

Require Import pos.
Require Import cast.

(** * Well-Founded Orders *)

(** This file defines a generalized lexicographic order on dependently
typed products.  It exposes the following interface: *)

(** Assumptions:
- [Variable N : nat.]
- [Variable N_pos : (0 < N)%coq_nat.]
- [Variable types : 'I_N -> Type.]
- [Variable ords  : forall i : 'I_N, types i -> types i -> Prop.]
- [Variable wf_ords : forall i : 'I_N, well_founded (@ords i).] *)

(** Exported:
- [t        : Type]
- [mk       : (forall i : 'I_N, types i) -> t]
- [get      : (i : 'I_N) (d : t), types i]
- [set      : {i : 'I_N} (d : t) (x : types i), t]
- [ord      : t -> t -> Prop]
- [wf_ord   : well_founded ord]
- [ord_set  : (i : 'I_N) (d : t) (x : types i),
               ords i x (get i d) -> ord (set d x) d]
- [gss      : (i : 'I_N) (x : types i) (d : t), get i (set i x d) = x]
- [gso      : (i j : 'I_N) (x : types i) (d : t),
               i <> j -> get j (set i x d) = get j d] *)

(** In addition, it defines a WF order on the [\Sigma]-type
      [\Sigma ix : 'I_N. T ix] *)

Lemma ord_dec (N : nat) (i j : 'I_N) : {i=j} + {~i=j}.
Proof.
case: i; case: j=> m pf n pf'; move: pf pf'; case: (eq_nat_dec n m).
by move=> -> pf pf'; left; f_equal; apply: proof_irr.
by move=> neq pf pf'; right; case.
Qed.

Lemma wf_eta {A: Type}{f: A -> A -> Prop} :
  well_founded f -> well_founded (fun a1 a2 => f a1 a2).
Proof.
by move=> H1; have ->: ((fun a1 a2 => f a1 a2) = f) by do 2 extensionality.
Qed.

Lemma wf_eta' {A: Type}{f: A -> A -> Prop} :
  well_founded (fun a1 a2 => f a1 a2) -> well_founded f.
Proof.
by move=> H1; have <-: ((fun a1 a2 => f a1 a2) = f) by do 2 extensionality.
Qed.

Lemma wf_funct {A B: Type}{R: B -> B -> Prop}(f: A -> B) :
  well_founded R -> well_founded (fun a1 a2 => R (f a1) (f a2)).
Proof.
move=> H1; set (F := fun a b => f a = b).
apply: (wf_incl _ _
 (fun x y: A => exists2 b : B, F x b & forall c : B, F y c -> R b c)).
by move=> a1 a2 HR; exists (f a1); rewrite/F=> //; move=> b <-.
by apply: wf_inverse_rel.
Qed.

Module Type LEX.

Parameter t : forall (N : pos) (types : 'I_N -> Type), Type.

Arguments t {N} types.

Parameter ord : forall (N : pos)
  (types : 'I_N -> Type) (ords : forall i : 'I_N, types i -> types i -> Prop),
  t types -> t types -> Prop.

Parameter wf_ord : forall (N : pos)
  (types : 'I_N -> Type) (ords : forall i : 'I_N, types i -> types i -> Prop)
  (wf_ords : forall i : 'I_N, well_founded (ords i)),
  well_founded (ord ords).

Section lex.

Variable N : pos.
Variable types : 'I_N -> Type.
Variable ords  : forall i : 'I_N, types i -> types i -> Prop.
Variable wf_ords : forall i : 'I_N, well_founded (@ords i).

Notation t   := (t types).
Notation ord := (@ord N types ords).

Parameter mk  : (forall i : 'I_N, types i) -> t.
Parameter get : forall i : 'I_N, t -> types i.
Parameter set : forall (i : 'I_N) (x : types i), t -> t.
Parameter ord_upd :
  forall (i : 'I_N) (x : types i) (d : t),
  ords x (get i d) -> ord (set x d) d.
Parameter gss :
  forall (i : 'I_N) (x : types i) (d : t), get i (set x d) = x.
Parameter gso :
  forall (i j : 'I_N) (x : types i) (d : t), i <> j ->
    get j (set x d) = get j d.

End lex. End LEX.

Module Lex : LEX. Section lex.

Variable N : pos.
Variable types : 'I_N -> Type.
Variable ords  : forall i : 'I_N, types i -> types i -> Prop.
Variable wf_ords : forall i : 'I_N, well_founded (@ords i).

Lemma N_minus_lt (n : nat) : ((N - S n) < N)%N.
Proof. case: N=> m pf; rewrite -minusE; apply/ltP=> /=; omega. Qed.

Definition t : Type := forall i : 'I_N, types i.

Definition mk : t -> t := id.

Fixpoint ty' (n : nat) : Type :=
  match n with
    | O => unit
    | S n' => (types (Ordinal (N_minus_lt n')) * ty' n')%type
  end.

Fixpoint ty_intro' (n : nat) (data : t) : ty' n :=
  match n as m in nat return ty' m with
    | O => tt
    | S n' => (data (Ordinal (N_minus_lt n')), ty_intro' n' data)
  end.

Definition ty := ty' N.

Definition ty_intro := ty_intro' N.

Fixpoint ord' (n : nat) : ty' n -> ty' n -> Prop :=
  match n as m in nat return ty' m -> ty' m -> Prop with
    | O => fun d1 d2 => False
    | S n' => fun d1 d2 =>
        lex_ord (@ords (Ordinal (N_minus_lt n'))) (ord' n') d1 d2
  end.

Lemma wf_ord' n : well_founded (ord' n).
Proof.
rewrite/ord'; move: wf_ords; move: ords; clear ords wf_ords.
induction n=> ords WF; first by constructor.
apply: wf_eta; apply: wf_lex_ord; first by [].
by apply: (IHn ords).
Qed.

Definition ord (d1 d2 : t) := ord' N (ty_intro d1) (ty_intro d2).

Lemma wf_ord : well_founded ord.
Proof. by rewrite/ord; apply: wf_funct; apply: wf_ord'. Qed.

Definition cast_ty (T1 T2: Type) (pf: T1=T2) (x : T1) : T2.
Proof.
rewrite pf in x; refine x.
Defined.

Lemma types_eq (i j : 'I_N) : i=j -> types i=types j.
Proof. by move=> ->. Defined.

Definition get i (d : t) : types i := d i.

Definition set i (new_i : types i) (d : t) : t :=
  fun j : 'I_N =>
    match ord_dec i j with
      | left pf => cast_ty (types_eq pf) new_i
      | right _ => d j
    end.
Implicit Arguments set [].

Lemma gss i x d : get i (set i x d) = x.
Proof.
rewrite/get/set; case: (ord_dec i i)=> //.
rewrite/cast_ty/eq_rect_r/eq_rect/types_eq/eq_ind_r/eq_ind/eq_rect=> e.
by rewrite (UIP_refl _ _ e).
Qed.

Lemma gso i j x d : i<>j -> get j (set i x d) = get j d.
Proof. by rewrite/get/set; case: (ord_dec i j). Qed.

Local Open Scope nat_scope.

Lemma ord_upd' : forall i data1 data2 num_cores,
  @ords i (get i data2) (get i data1) ->
  (N - num_cores <= i < N)%nat -> (num_cores <= N)%nat ->
  (forall j : 'I_N, j < i -> get j data1=get j data2) ->
  ord' num_cores (ty_intro' num_cores data2) (ty_intro' num_cores data1).
Proof.
move=> [i pf] d1 d2 num_cores H1; move/andP=> []; move/leP=> H2; move/ltP.
induction num_cores as [|n]; first by rewrite -minusE /= in H2=> /= H3; omega.
move=> /= H3 H4 H5; case: (ord_dec (Ordinal pf) (Ordinal (N_minus_lt n))).
by move=> EQ; apply: lex_ord_left; rewrite -EQ.
rewrite/get in H5; move=> NEQ; rewrite -H5; have NEQ2: (i <> N - n.+1)
  by move=> H6; apply: NEQ; subst; f_equal; apply: proof_irr.
have: (N - S n < i) by apply/ltP; simpl in H2; omega.
move/ltP=> H6; apply lex_ord_right; apply: IHn=> //=.
by move: H6; rewrite -minusE=> H6; omega.
by move: (ltP H4)=> H7; apply/leP; omega.
have H6: (i <> N - n.+1)
  by move=> H6; apply: NEQ; subst; f_equal; apply: proof_irr.
by move: H2=> /= H2; apply/ltP; omega.
Qed.

Lemma ord_upd i x d : ords x (get i d) -> ord (set i x d) d.
Proof.
move=> A; apply ord_upd' with (i := i)=> //.
rewrite gss=> //.
have B: (O <= i < N) by apply/andP; split.
rewrite -minusE; move: (andP B)=> {A B}[]A B.
move: (leP A)=> A'; move: (ltP B)=> B'; apply/andP; split.
- by apply/leP; omega.
- by apply/ltP; omega.
move=> j Hlt; rewrite gso=> //.
case: i x A Hlt; case: j=> /= i pf new_i A Hlt j pf'=> H1.
by move: pf'; case: H1=> ->; move/ltP=> ?; omega.
Qed.

End lex.

End Lex.

(** The following defines a wf-order on the type
      \Sigma ix : 'I_N. T ix *)

Section sig_ord.

Variable N : pos.

Variable T : 'I_N -> Type.

Variable ords : forall ix : 'I_N, T ix -> T ix -> Prop.

Variable ords_wf : forall ix, well_founded (@ords ix).

Definition sig_data := {ix : 'I_N & T ix}.

Definition sig_ord (x y : sig_data) :=
  exists pf : projT1 x = projT1 y,
    (@ords (projT1 x))
      (projT2 x)
      (cast_ty (lift_eq _ (sym_eq pf)) (projT2 y)).

Lemma wf_sig_ord : well_founded sig_ord.
Proof.
move=> []i.
apply (well_founded_induction (@ords_wf i)).
move=> x IH.
apply: Acc_intro=> []j []/=pf H2.

have H3: @ords i (cast _ pf (projT2 j)) x.
{ move: pf H2; case: j=> /= ix j pf; subst ix.
  by rewrite !cast_ty_erefl. }

case: (IH _ H3)=> H4.

apply: Acc_intro=> y H5; apply: H4.

have pf2: projT1 y = i.
{ by case: H5=> pf0 _; rewrite pf0. }

exists pf2=> /=.

move: pf2; set r := projT1 y; subst i.
rewrite cast_ty_erefl.

move=> pf2; move: H5; subst r; case=> pf3.
by have ->: sym_eq pf3 = sym_eq pf2 by apply: proof_irr.
Qed.

End sig_ord.


From FA Require Import String DFA NFA.
From mathcomp Require Import all_ssreflect.

Lemma ms_dist: forall (n: nfa) (A: {set (@nfa_state n) }) (x y: String),
  nfa_multistep n A (concat x y) = nfa_multistep n (nfa_multistep n A x) y.
Proof. intros n A x y.
       revert n A x.
       induction y; intros.
       - simpl. reflexivity.
       - simpl. rewrite <- IHy.
         reflexivity.
Qed.

Lemma nfa_dfa: forall n: nfa, dfa.
Proof. intro n.
       unshelve econstructor.
       - exact (set_of_finType (@nfa_state n)).
       - cbn. exact (@nfa_start n).
       - intros A S.
         destruct S.
         + exact (nfa_multistep n A (glue eps a)).
         + exact (nfa_multistep n A (glue eps b)).
       - cbn.
(*          exact [set A: {set n} | A :&: (@nfa_finals n) != set0]. *)
         exact [set A:{set n} | [exists x, (x\in A) && (x\in(@nfa_finals n))]].
Defined.

Lemma nfa_dfa_state (n: nfa) (s: n): (@dfa_state (nfa_dfa n)).
Proof. destruct n as (Q, S, D, F).
       cbn in *.
       exact ([set s]).
Defined.

Lemma nfa_dfa_set_state (n: nfa) (s: {set n}): (@dfa_state (nfa_dfa n)).
Proof. destruct n as (Q, S, D, F).
       cbn in *.
       exact s.
Defined.

Lemma nfa_to_dfa_ms: forall s (A: nfa) (x: {set A}),
  nfa_multistep A x s = dfa_multistep (nfa_dfa A) (nfa_dfa_set_state A x) s.
Proof. intro s.
       induction s; intros.
       - simpl.
         destruct A as (Q, S, delta, F).
         simpl. reflexivity.
       - simpl.
         specialize (IHs A).
         destruct A as (Q, S, delta, F).
         simpl in *.
         specialize (IHs x).
         rewrite IHs.
         destruct s0; easy.
Qed.

Lemma nfa_dfa_set_state_eq: forall n A, (nfa_dfa_set_state n A) = A.
Proof. intros.
       destruct n.
       cbn in *.
       easy.
Qed.

Lemma nfa_dfa_acc_eq: forall (n: nfa) (A: {set (@nfa_state n)}) (x: String),
  nfa_acceptance n A x =
  dfa_acceptance (nfa_dfa n) A x.
Proof. intros.
       unfold nfa_acceptance, dfa_acceptance.
       rewrite nfa_to_dfa_ms.
       unfold dfa_finals.
       simpl in *.
       apply/idP/idP => /=.
       intros Ha.
       move=>/existsP in Ha.
       destruct Ha as (y, Ha).
       apply/existsP.
       simpl.
       exists (dfa_multistep (nfa_dfa n) A x).
       apply/andP.
       split.
         move=>/andP in Ha.
         destruct Ha as (Ha, Hb).
         apply/eqP. easy.
         rewrite inE.
         apply/existsP.
         exists y.
         rewrite nfa_dfa_set_state_eq in Ha.
         easy.

         intros Ha.
         move=>/existsP in Ha.
         destruct Ha as (y, Ha).
         simpl in *.
         move=>/andP in Ha.
         destruct Ha as (Ha, Hb).
         rewrite inE in Hb.
         move=>/existsP in Hb.
         destruct Hb as (z, Hb).
         move=>/eqP in Ha.
         apply/existsP.
         exists z.
         subst.
         rewrite nfa_dfa_set_state_eq.
         easy.
Qed.

Lemma nfa_dfa_lang_eqi_l: forall n y,
y \in [pred w | [exists y0,
           (y0 \in nfa_multistep n (nfa_start n) w) && (y0 \in nfa_finals n)]] ->
y  \in [pred w | [exists y0,
           (y0 == dfa_multistep (nfa_dfa n) (nfa_start n) w) &&
           (y0 \in [set A:{set n} | [exists x, (x \in A) && (x \in nfa_finals n)]])]].
Proof. intros n y Ha.
       move=>/existsP in Ha.
       destruct Ha as (x, Ha).
       move=>/andP in Ha.
       destruct Ha as (Ha, Hb).
       apply/existsP.
       specialize (nfa_to_dfa_ms y n (nfa_start n)); intro H.
       destruct n as (Q, S, delta, F).
       simpl in *.
       rewrite <- H.
       exists(nfa_multistep {| nfa_state := Q; nfa_start := S; nfa_transition := delta; nfa_finals := F |} S y).
       apply/andP.
       split.
       + easy.
       + rewrite !inE.
         apply/existsP.
         exists x.
         apply/andP.
         split; easy.
Qed.

Lemma nfa_dfa_lang_eqi_r: forall n y,
y  \in [pred w | [exists y0,
           (y0 == dfa_multistep (nfa_dfa n) (nfa_start n) w) &&
           (y0 \in [set A:{set n} | [exists x, (x \in A) && (x \in nfa_finals n)]])]] ->
y \in [pred w | [exists y0,
           (y0 \in nfa_multistep n (nfa_start n) w) && (y0 \in nfa_finals n)]].
Proof. intros n y Ha.
       move=>/existsP in Ha.
       destruct Ha as (a, Ha).
       move=>/andP in Ha.
       destruct Ha as (Ha, Hb).
       rewrite !inE in Hb.
       move=>/existsP in Hb.
       specialize (nfa_to_dfa_ms y n (nfa_start n)); intro H.
       apply/existsP.
       destruct n as (Q, S, delta, F).
       simpl in *.
       rewrite H.
       move=>/eqP in Ha.
       rewrite <- Ha.
       easy.
Qed.

Lemma nfa_dfa_lang_eqi: forall n, nfa_language n =i dfa_language (nfa_dfa n).
Proof. intros.
       unfold nfa_language, dfa_language.
       unfold nfa_acceptance, dfa_acceptance.
       move => y. apply/idP/idP => /=.
       - intro Ha.
         apply nfa_dfa_lang_eqi_l.
         easy.
       - intro Ha.
         apply nfa_dfa_lang_eqi_r.
         easy.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.ZRange.BasicLemmas.
Require Import Crypto.Util.ZRange.Operations.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Tactics.PeelLe.
Require Import Crypto.Util.ZUtil.Tactics.ReplaceNegWithPos.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.ZSimplify.
Require Import Crypto.Util.ZUtil.ZSimplify.Core.
Require Import Crypto.Util.ZUtil.Modulo.
Require Import Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.
Local Open Scope Z_scope.

Module ZRange.
  Lemma is_bounded_by_bool_split_bounds_pos x r m (Hm : 0 < m)
  : is_bounded_by_bool x r = true
    -> andb (is_bounded_by_bool (x mod m) (fst (Operations.ZRange.split_bounds_pos r m)))
            (is_bounded_by_bool (x / m) (snd (Operations.ZRange.split_bounds_pos r m))) = true.
  Proof.
    cbv [is_bounded_by_bool Operations.ZRange.split_bounds_pos andb].
    repeat first [ progress intros
                 | break_innermost_match_step
                 | break_innermost_match_hyps_step
                 | progress subst
                 | progress cbn [fst snd lower upper] in *
                 | reflexivity
                 | discriminate
                 | lia
                 | progress Z.ltb_to_lt
                 | progress Z.peel_le
                 | match goal with
                   | [ r : zrange |- _ ] => let l := fresh "l" in let u := fresh "u" in destruct r as [l u]
                   | [ H : (?x < ?m)%Z, H' : (?m * ?q + _ <= ?x)%Z |- _ ]
                     => assert (q < 0 \/ q = 0 \/ 0 < q)%Z by nia; destruct_head'_or;
                        [ assert (m * q < 0)%Z by nia; nia | progress subst | assert (0 < m * q)%Z by nia; nia ]
                   end
                 | progress autorewrite with zsimplify_const in *
                 | progress Z.div_mod_to_quot_rem
                 | nia ].
  Qed.

  Lemma is_bounded_by_bool_fst_split_bounds_pos x r m (Hm : 0 < m)
    : is_bounded_by_bool x r = true
      -> (is_bounded_by_bool (x mod m) (fst (Operations.ZRange.split_bounds_pos r m))) = true.
  Proof. intro H; pose proof (@is_bounded_by_bool_split_bounds_pos x r m Hm H); Bool.split_andb; assumption. Qed.

  Lemma is_bounded_by_bool_snd_split_bounds_pos x r m (Hm : 0 < m)
    : is_bounded_by_bool x r = true
      -> (is_bounded_by_bool (x / m) (snd (Operations.ZRange.split_bounds_pos r m))) = true.
  Proof. intro H; pose proof (@is_bounded_by_bool_split_bounds_pos x r m Hm H); Bool.split_andb; assumption. Qed.

  Lemma is_bounded_by_bool_split_bounds x r m
    : is_bounded_by_bool x r = true
      -> andb (is_bounded_by_bool (x mod m) (fst (Operations.ZRange.split_bounds r m)))
              (is_bounded_by_bool (x / m) (snd (Operations.ZRange.split_bounds r m))) = true.
  Proof.
    intro; cbv [ZRange.split_bounds]; eta_expand; break_match; cbn [fst snd] in *.
    all: Z.ltb_to_lt.
    all: Z.replace_all_neg_with_pos.
    - now apply is_bounded_by_bool_split_bounds_pos.
    - autorewrite with zsimplify_const. now rewrite 1?Bool.andb_comm.
    - rewrite Z.div_opp_r, Z.mod_opp_r, ZRange.is_bounded_by_bool_opp.
      now apply is_bounded_by_bool_split_bounds_pos; [lia|rewrite ZRange.is_bounded_by_bool_opp].
  Qed.

  Lemma is_bounded_by_bool_split_bounds_and x r m
    : is_bounded_by_bool x r = true
      -> and (is_bounded_by_bool (x mod m) (fst (Operations.ZRange.split_bounds r m)) = true)
             (is_bounded_by_bool (x / m) (snd (Operations.ZRange.split_bounds r m)) = true).
  Proof.
    intro H; pose proof (@is_bounded_by_bool_split_bounds x r m H).
    Bool.split_andb; split; assumption.
  Qed.
End ZRange.


Require Import Rpos.
Require Import FOL_R.
Require Import RL.Utilities.riesz_logic_Nat_more.
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.