(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2009-03-19 (setoid)
- Adam Koprowski, 2007-04-14

Semi-ring structure.
*)

Require Export Ring Ring_theory.
Require Import RelDec Relations Max Arith Compare LogicUtil Bool RelExtras1
  Setoid EqUtil NatUtil ZUtil RelExtras Morphisms.

(* SemiRingType *)

Class SemiRingType := {
   semi_setoid :> Setoid;
   semi_A0 : s_typ;
   semi_A1 : s_typ;
   semi_Aplus : s_typ -> s_typ -> s_typ;
   semi_Amult : s_typ -> s_typ -> s_typ;
   semi_Aplus_mor : Proper (s_eq ==> s_eq ==> s_eq) semi_Aplus;
   semi_Amult_mor: Proper (s_eq ==> s_eq ==> s_eq) semi_Amult;
   semi_A_semi_ring : semi_ring_theory semi_A0 semi_A1 semi_Aplus semi_Amult
   s_eq
}.

(***********************************************************************)
(** Natural numbers as a semi-ring *)

Instance Nat_as_SemiRingType : SemiRingType.

Proof.
  apply Build_SemiRingType with
  (semi_setoid := Leibniz_Setoid nat)
  (semi_A0 := 0)(semi_A1 := 1)
  (semi_Aplus := plus) (semi_Amult := mult).
  simpl. intros x x' xx' y y' yy'. auto.
  simpl. intros x x' xx' y y' yy'. auto.
  apply natSRth.
Defined.

(***********************************************************************)
(** Integers as a semi-ring *)

Require Import ZArith.

Instance Z_as_SemiRingType : SemiRingType.

Proof.
  apply Build_SemiRingType with
  (semi_setoid := Leibniz_Setoid Z)
  (semi_A0 := 0%Z)(semi_A1 := 1%Z)
  (semi_Aplus := Zplus) (semi_Amult := Zmult).
  simpl. intros x x' xx' y y' yy'. rewrite xx'. rewrite yy'. auto.
  simpl. intros x x' xx' y y' yy'. rewrite xx'. rewrite yy'. auto.
  constructor.
  exact Zplus_0_l.
  exact Zplus_comm.
  exact Zplus_assoc.
  exact Zmult_1_l.
  exact Zmult_0_l.
  exact Zmult_comm.
  exact Zmult_assoc.
  exact Zmult_plus_distr_l.
Defined.

(***********************************************************************)
(** Arctic semi-ring over naturals with minus infinity and
    plus-max operations *)

Require Import SemiRing.

(* max is a <+> operation in the semi-ring *)
Definition Aplus m n :=
  match m, n with
    | MinusInf, n => n
    | m, MinusInf => m
    | Pos m, Pos n => Pos (max m n)
  end.

(* plus is a <*> operation in the semi-ring *)
Definition Amult m n :=
  match m, n with
    | MinusInf, _ => MinusInf
    | _, MinusInf => MinusInf
    | Pos m, Pos n => Pos (m + n)
  end.

Lemma A_plus_comm : forall m n, Aplus m n = Aplus n m.

Proof.
  intros. unfold Aplus. destruct m; destruct n; trivial.
  rewrite max_comm. trivial.
Qed.

Lemma A_plus_assoc : forall m n p, Aplus m (Aplus n p) = Aplus (Aplus m n) p.

Proof.
  intros. unfold Aplus.
  destruct m; destruct n; destruct p; trivial.
  rewrite max_assoc. trivial.
Qed.

Lemma A_mult_comm : forall m n, Amult m n = Amult n m.

Proof.
  intros. unfold Amult. destruct m; destruct n; trivial.
  rewrite plus_comm. trivial.
Qed.

Lemma A_mult_assoc : forall m n p, Amult m (Amult n p) = Amult (Amult m n) p.

Proof.
  intros. unfold Amult.
  destruct m; destruct n; destruct p; trivial.
  rewrite plus_assoc. trivial.
Qed.

Import Compare. Import Max.

Lemma A_mult_plus_distr : forall m n p,
                            Amult (Aplus m n) p = Aplus (Amult m p) (Amult n p).

Proof.
  intros. unfold Amult, Aplus.
  destruct m; destruct n; destruct p; trivial.
  destruct (le_dec n n0).
  rewrite max_l. rewrite max_l. trivial. auto with arith. trivial.
  rewrite max_r. rewrite max_r. trivial. auto with arith. trivial.
Qed.

Instance Arctic_as_SemiRingType : SemiRingType.

Proof.
   apply Build_SemiRingType with
  (semi_setoid := Leibniz_Setoid ArcticDom)
  (semi_A0 := MinusInf)(semi_A1 := Pos 0)
  (semi_Aplus := Aplus) (semi_Amult := Amult).
   simpl. intros x x' xx' y y' yy'. rewrite xx'. rewrite yy'. auto.
   simpl. intros x x' xx' y y' yy'. rewrite xx'. rewrite yy'. auto.
   constructor; intros.
   compute; trivial.
   apply A_plus_comm.
   apply A_plus_assoc.
   destruct n; compute; trivial.
   compute; trivial.
   apply A_mult_comm.
   apply A_mult_assoc.
   apply A_mult_plus_distr.
Defined.

(***********************************************************************)
(** Arctic semi-ring over integers with minus infinity and
    plus-max operations *)

Require Import ZUtil.

(* max is a <+> operation in the semi-ring *)
Definition AplusBZ m n :=
  match m, n with
    | MinusInfBZ, n => n
    | m, MinusInfBZ => m
    | Fin m, Fin n => Fin (Zmax m n)
  end.

(* plus is a <*> operation in the semi-ring *)
Definition AmultBZ m n :=
  match m, n with
    | MinusInfBZ, _ => MinusInfBZ
    | _, MinusInfBZ => MinusInfBZ
    | Fin m, Fin n => Fin (m + n)
  end.

Lemma A_plus_commBZ : forall m n, AplusBZ m n = AplusBZ n m.

Proof.
  intros. unfold AplusBZ. destruct m; destruct n; trivial.
  rewrite Zmax_comm. refl.
Qed.

Lemma A_plus_assocBZ : forall m n p, AplusBZ m (AplusBZ n p) = AplusBZ (AplusBZ m n) p.

Proof.
  intros. unfold AplusBZ.
  destruct m; destruct n; destruct p; trivial.
  rewrite Zmax_assoc. refl.
Qed.

Lemma A_mult_commBZ : forall m n, AmultBZ m n = AmultBZ n m.

Proof.
  intros. unfold AmultBZ. destruct m; destruct n; trivial.
  rewrite Zplus_comm. refl.
Qed.

Lemma A_mult_assocBZ : forall m n p, AmultBZ m (AmultBZ n p) = AmultBZ (AmultBZ m n) p.

Proof.
  intros. unfold AmultBZ.
  destruct m; destruct n; destruct p; trivial.
  rewrite Zplus_assoc. refl.
Qed.

Lemma A_mult_plus_distrBZ : forall m n p,
                            AmultBZ (AplusBZ m n) p = AplusBZ (AmultBZ m p) (AmultBZ n p).

Proof.
  intros. unfold AmultBZ, AplusBZ.
  destruct m; destruct n; destruct p; trivial.
  rewrite Zplus_max_distr_r.
  destruct (Zmax_irreducible_inf z z0); rewrite e; refl.
Qed.

Instance ArcticBZ_as_SemiRingType : SemiRingType.

Proof.
  apply Build_SemiRingType with
  (semi_setoid := Leibniz_Setoid ArcticBZDom)
  (semi_A0 := MinusInfBZ)(semi_A1 := Fin 0)
  (semi_Aplus := AplusBZ) (semi_Amult := AmultBZ).
  simpl. intros x x' xx' y y' yy'. rewrite xx'. rewrite yy'. auto.
  simpl. intros x x' xx' y y' yy'. rewrite xx'. rewrite yy'. auto.
  constructor; intros.
  compute; trivial.
  apply A_plus_commBZ.
  apply A_plus_assocBZ.
  destruct n; unfold s_eq; refl.
  unfold s_eq. simpl. trivial.
  apply A_mult_commBZ.
  apply A_mult_assocBZ.
  apply A_mult_plus_distrBZ.
Defined.

(***********************************************************************)
(** Tropical semi-ring over naturals with plus infinity and
    plus-min operations *)

(* min is a <+> operation in the semi-ring *)
Definition AplusT m n :=
  match m, n with
    | PlusInf, n => n
    | m, PlusInf => m
    | TPos m, TPos n => TPos (min m n)
  end.

(* plus is a <*> operation in the semi-ring *)
Definition AmultT m n :=
  match m, n with
    | PlusInf, _ => PlusInf
    | _, PlusInf => PlusInf
    | TPos m, TPos n => TPos (m + n)
  end.

Lemma A_plus_commT : forall m n, AplusT m n = AplusT n m.

Proof.
  intros. unfold AplusT. destruct m; destruct n; trivial.
  rewrite min_comm. trivial.
Qed.

Lemma A_plus_assocT : forall m n p, AplusT m (AplusT n p) = AplusT (AplusT m n) p.

Proof.
  intros. unfold AplusT.
  destruct m; destruct n; destruct p; trivial.
  rewrite min_assoc. trivial.
Qed.

Lemma A_mult_commT : forall m n, AmultT m n = AmultT n m.

Proof.
  intros. unfold AmultT. destruct m; destruct n; trivial.
  rewrite plus_comm. trivial.
Qed.

Lemma A_mult_assocT : forall m n p, AmultT m (AmultT n p) = AmultT (AmultT m n) p.

Proof.
  intros. unfold AmultT.
  destruct m; destruct n; destruct p; trivial.
  rewrite plus_assoc. trivial.
Qed.

Import Compare. Import Min.

Lemma A_mult_plus_distrT : forall m n p,
                            AmultT (AplusT m n) p = AplusT (AmultT m p) (AmultT n p).

Proof.
  intros. unfold AmultT, AplusT.
  destruct m; destruct n; destruct p; trivial.
  destruct (le_dec n0 n).
  rewrite min_l. rewrite min_l. trivial. auto with arith. trivial.
  rewrite min_r. rewrite min_r. trivial. auto with arith. trivial.
Qed.

Instance Tropical_as_SemiRingType : SemiRingType.

Proof.
 apply Build_SemiRingType with
  (semi_setoid := Leibniz_Setoid TropicalDom)
  (semi_A0 := PlusInf)(semi_A1 := TPos 0)
  (semi_Aplus := AplusT) (semi_Amult := AmultT).
  simpl. intros x x' xx' y y' yy'. rewrite xx'. rewrite yy'. auto.
  simpl. intros x x' xx' y y' yy'. rewrite xx'. rewrite yy'. auto.
  constructor; intros.
  compute; trivial.
  apply A_plus_commT.
  apply A_plus_assocT.
  destruct n; compute; trivial.
  compute; trivial.
  apply A_mult_commT.
  apply A_mult_assocT.
  apply A_mult_plus_distrT.
Defined.

(***********************************************************************)
(** Semi-ring of booleans with 'or' and 'and' *)

Definition AplusB := orb.
Definition AmultB := andb.

Instance Bool_as_SemiRingType : SemiRingType.

Proof.
  apply Build_SemiRingType with
  (semi_setoid := Leibniz_Setoid bool)
    (semi_A0 := false)(semi_A1 := true)
    (semi_Aplus := AplusB) (semi_Amult := AmultB).
  simpl. intros x x' xx' y y' yy'. rewrite xx'. rewrite yy'. auto.
  simpl. intros x x' xx' y y' yy'. rewrite xx'. rewrite yy'. auto.
  constructor; intros.
  apply orb_false_l.
  apply orb_comm.
  apply orb_assoc.
  apply andb_true_l.
  apply andb_false_l.
  apply andb_comm.
  apply andb_assoc.
  apply andb_orb_distrib_l.
Defined.


Require Import Coq.Lists.List.
Require Import Coq.Arith.Arith.
Require Import Coq.Strings.String.

Import ListNotations.

(* Syntax of Clock-based Dynamic Logic *)

(* Syntax of SEP_exp (Synchonous Event Program) *)

(* ========================= Syntax of SEP_exp ========================*)

(* =============== Syntax of Expressions ===================*)

(* Arith Expression `e'*)

Inductive Var := var : nat -> Var.
(* in this version, I try to understand variables as identifications numbered by natural numbers,
which we believe is more convenient than considering them as strings in practical derivations*)

Inductive e_exp :=
  enumC : nat -> e_exp |
  evarC : Var -> e_exp |
  eplusC : e_exp -> e_exp -> e_exp |
  (*non-necessary expression*)
  eminusC : e_exp -> e_exp -> e_exp |
  emulC : e_exp -> e_exp -> e_exp |
  edivC : e_exp -> e_exp -> e_exp
.
Print e_exp.

Notation "e1 '+ e2" := (eplusC e1 e2) (at level 31, right associativity).
Locate "'+".
Notation "e1 '- e2" := (eminusC e1 e2) (at level 31, right associativity).

Notation "e1 '* e2" := (emulC e1 e2) (at level 21, right associativity).

(*** Open Scope e_exp_scope. ***)

Locate "*".
Check (enumC 4) '* (enumC 5 '+ enumC 6).
Coercion evarC : Var >-> e_exp.
Notation "e1 '/ e2" := (edivC e1 e2) (at level 21, right associativity).
Check (enumC 4) '/ (enumC 4).

Coercion enumC : nat >-> e_exp.
Definition x : Var := (var 1).
Definition y : Var := (var 2).
Definition z : Var := (var 3).
Definition k : Var := (var 4).

Check 4 '* (5 '+ 2).
Check (5 '+ 4) '* 8.
Check x '- 3.
Compute x '- 3.
Check 5 '+ 4 '* 5.

(* Boolean Expression `P'*)
Inductive P_exp :=
  PtrueC : P_exp |
  PlteC : e_exp -> e_exp -> P_exp |
  PnegC : P_exp -> P_exp |
  PandC : P_exp -> P_exp -> P_exp |
  (*non-necesarry expression*)
  PfalseC : P_exp |
  PltC : e_exp -> e_exp -> P_exp |
  PgtC : e_exp -> e_exp -> P_exp |
  PgteC : e_exp -> e_exp -> P_exp |
  PeqC : e_exp -> e_exp -> P_exp |
  PorC : P_exp -> P_exp -> P_exp |
  PimpC : P_exp -> P_exp -> P_exp
.
Print P_exp.

(* 33 - 41 *)
Notation "''tt'" := PtrueC (at level 35).
Notation "e1 '<= e2" := (PlteC e1 e2) (at level 33).
Notation "'~ P" := (PnegC P) (at level 36).
Notation "P1 '/\ P2" := (PandC P1 P2) (at level 37, right associativity).
Notation "''ff'" := PfalseC (at level 35).
Notation "e1 '< e2" := (PltC e1 e2) (at level 33).
Notation "e1 '> e2" := (PgtC e1 e2) (at level 33).
Notation "e1 '>= e2" := (PgteC e1 e2) (at level 33).
Notation "e1 '= e2" := (PeqC e1 e2) (at level 33).
Notation "P1 '\/ P2" := (PorC P1 P2) (at level 37, right associativity).
Notation "P1 '-> P2" := (PimpC P1 P2) (at level 38, right associativity).

Locate "'/\".
Check 'tt '-> 'ff.
Check 5 '+ x '>= 5 '-> 3 '> 7.
Compute 5 '+ x '>= 5 '-> 3 '> 7.

(* Evaluation *)
Definition state := Var -> nat.

(***
  Definging the evaluation for expressions is for checking the validation of FOL formulas after
  transformation.
***)

Fixpoint eval_e_exp (e : e_exp) (st : state) : nat :=
(* st maps each var name to a value --- it is a state *)
  match e with
  | enumC n => n
  | evarC s => st s
  | eplusC e1 e2 => (eval_e_exp e1 st) + (eval_e_exp e2 st)
  | eminusC e1 e2 => (eval_e_exp e1 st) - (eval_e_exp e2 st)
  | emulC e1 e2 => (eval_e_exp e1 st) * (eval_e_exp e2 st)
  | edivC e1 e2 => (eval_e_exp e1 st) / (eval_e_exp e2 st)
  end.

Fixpoint eval_P_exp (P : P_exp) (st : state) : Prop :=
  match P with
  | PtrueC => True
  | PlteC e1 e2 => (eval_e_exp e1 st) <= (eval_e_exp e2 st)
  | PnegC P' => ~ (eval_P_exp P' st)
  | PandC P1 P2 => (eval_P_exp P1 st) /\ (eval_P_exp P1 st)
  | PfalseC => False
  | PltC e1 e2 => (eval_e_exp e1 st) < (eval_e_exp e2 st)
  | PgtC e1 e2 => (eval_e_exp e1 st) > (eval_e_exp e2 st)
  | PgteC e1 e2 => (eval_e_exp e1 st) >= (eval_e_exp e2 st)
  | PeqC e1 e2 => (eval_e_exp e1 st) = (eval_e_exp e2 st)
  | PorC P1 P2 => (eval_P_exp P1 st) \/ (eval_P_exp P1 st)
  | PimpC P1 P2 => (eval_P_exp P1 st) -> (eval_P_exp P1 st)
  end.

(* =============== Syntax of Event ===================*)

(* Event *)
Inductive EvtElement :=
  sigC : Var -> e_exp -> EvtElement | (* Signal *)
  assC : Var -> e_exp -> EvtElement  (* Assignment *)
.
Check EvtElement.

Notation "s ! e" := (sigC s e) (at level 45).
Notation "x :=' e" := (assC x e) (at level 45).

(* currently we do not make distinguish between variable and clock names, both are strings*)
Definition c : Var := (var 5).
Definition d : Var := (var 6).
Definition c1 : Var  := (var 7).
Definition c2 : Var  := (var 8).
Definition c3 : Var  := (var 9).
Definition c4 : Var  := (var 10).

Check x :=' 4.
Compute x :=' 4.
Check c ! (x '+ 4).

Definition Evt := list EvtElement.

Check Evt.
Check (x :=' 4) :: (c!(x '+ 4)) :: nil.

(* ========================= Syntax of program ========================*)
Inductive SEP_exp : Type :=
  skip : SEP_exp | (* skip program $\varepsilon$ *)
  evtC : Evt -> SEP_exp | (* Event *)
  tstC : P_exp -> Evt -> SEP_exp | (* Test *)
  seqC : SEP_exp -> SEP_exp -> SEP_exp | (* sequence *)
  choC : SEP_exp -> SEP_exp -> SEP_exp | (* choice *)
  loopC : SEP_exp -> SEP_exp (* loop *)
.

Coercion evtC : Evt >-> SEP_exp.
Notation "{ a1 | .. | an }" := (cons a1 .. (cons an nil) .. ) (at level 45).
Notation "@ a" := (evtC a) (at level 46).
Definition idle : Evt := nil.
Notation "P ? a" := (tstC P a) (at level 48).
Notation "P1 ; P2" := (seqC P1 P2) (at level 49, left associativity).
Notation "P1 'U' P2" := (choC P1 P2) (at level 51, left associativity).
Notation "P **" := (loopC P) (at level 47, left associativity).

Locate "**".
Check x :=' 4 :: nil.
Check evtC (x :=' 4 :: nil).
Check { x :=' 4 }.
Check { x :=' 4 | c1 ! 5}.
Check @ { x :=' 4 | c1 ! 5 }.
Check idle.
Check x '> 0 ? {c!4}.

(* ========================================= Syntax of CDL Formula ===============================================*)

(* ================== CCSL ======================== *)
(* clock relation *)
(***
  Currently, we model clocks as `strings', becuase now we don't need to give its semantics.
  It won't work anymore if we consider its semantics later.
***)

Inductive CRel :=
  crSubClC : Var -> Var -> CRel |
  crExclC : Var -> Var -> CRel |
  crPrecC : Var -> Var -> CRel |
  crCausC : Var -> Var -> CRel
.
Check CRel.

Notation "c1 'sub' c2" := (crSubClC c1 c2) (at level 52).
Notation "c1 # c2" := (crExclC c1 c2) (at level 52).
Notation "c1 << c2" := (crPrecC c1 c2) (at level 52).
Notation "c1 <<= c2" := (crCausC c1 c2) (at level 52).

Check c1 << c2.
Check c1 # c2.
Check c1 sub c2.
Compute c1 << c2.

(* ================== CDL Formula ======================== *)
(* Clock relation in formula *)
Inductive rel :=
  rRelC : CRel -> rel |
  rConjC : list CRel -> rel
.
Print rel.

Coercion rRelC : CRel >-> rel.
Check c1 << c2.

Notation "/\{ c1 , .. , cn }" := (rConjC (cons c1 .. (cons cn nil) ..)).
Check /\{ c1 << c2 , c2 sub c3 , c1 <<= c3}.

(* Arith Expression `E' *)
(*DEL
(* define a map that maps each clock/signal to a variable that records the number it has ticked in history. *)
Definition CntClk := string -> string.

(* define a map that maps each clock/signal to a variable that records the current state of this clock. *)
Definition StClk := string -> string.
DEL*)

Inductive E_exp :=
  EvarC : Var -> E_exp |
  ECntClkC : Var -> E_exp | (* define a map that maps each clock/signal to a variable that records the number it has ticked in history. *)
  EStClkC : Var -> E_exp | (* define a map that maps each clock/signal to a variable that records the current state of this clock. *)
  EnumC : nat -> E_exp |
  EplusC : E_exp -> E_exp -> E_exp |
  (* unecessary expression *)
  EmulC : E_exp -> E_exp -> E_exp |
  EminusC : E_exp -> E_exp -> E_exp |
  EdivC : E_exp -> E_exp -> E_exp
.
Print E_exp.

Coercion EvarC : Var >-> E_exp.
Notation "n( c )" := (ECntClkC c) (at level 52). (* the only DIFFERENCE between e_exp and E_exp *)
Notation "s( c )" := (EStClkC c) (at level 52).
Coercion EnumC : nat >-> E_exp.
Notation "e1 +' e2" := (EplusC e1 e2) (at level 55, right associativity).
Notation "e1 *' e2" := (EmulC e1 e2) (at level 53, right associativity).
Notation "e1 -' e2" := (EminusC e1 e2) (at level 55, right associativity).
Notation "e1 /' e2" := (EdivC e1 e2) (at level 53, right associativity).

Check 5 +' 3.
Check 5 '+ 3.
Check 5 *' (3 +' 5).
Check n(c) *' 4.
Compute n(c) *' 4.

(* CDL Formula *)
Inductive CDL_exp :=
  cdl_trueC : CDL_exp |
  cdl_ltC : E_exp -> E_exp -> CDL_exp |
  cdl_box1C : SEP_exp -> rel -> CDL_exp |
  cdl_box2C : SEP_exp -> CDL_exp -> CDL_exp |
  cdl_negC : CDL_exp -> CDL_exp |
  cdl_andC : CDL_exp -> CDL_exp -> CDL_exp |
  cdl_forallC : Var -> CDL_exp -> CDL_exp |
  (* unnecessary expressions *)
  cdl_falseC : CDL_exp |
  cdl_lteC : E_exp -> E_exp -> CDL_exp |
  cdl_gtC : E_exp -> E_exp -> CDL_exp |
  cdl_gteC : E_exp -> E_exp -> CDL_exp |
  cdl_eqC : E_exp -> E_exp -> CDL_exp |
  cdl_dia1C : SEP_exp -> rel -> CDL_exp |
  cdl_dia2C : SEP_exp -> CDL_exp -> CDL_exp |
  cdl_orC : CDL_exp -> CDL_exp -> CDL_exp |
  cdl_impC : CDL_exp -> CDL_exp -> CDL_exp
.

Notation "'tt''" := cdl_trueC (at level 65).
Notation "e1 <' e2" := (cdl_ltC e1 e2) (at level 61).
Notation "[ p ]' r" := (cdl_box1C p r) (at level 63, p at level 62, r at level 62).
Notation "[ p ] e" := (cdl_box2C p e) (at level 63, p at level 62, e at level 62).
Notation "~' e" := (cdl_negC e) (at level 67).
Notation "e1 /\' e2" := (cdl_andC e1 e2) (at level 69, right associativity).
Notation "'all' x , e" := (cdl_forallC x e) (at level 68, x at level 67).
(* unnecessary expressions *)
Notation "'ff''" := cdl_falseC (at level 65).
Notation "e1 <=' e2" := (cdl_lteC e1 e2) (at level 61).
Notation "e1 >' e2" := (cdl_gtC e1 e2) (at level 61).
Notation "e1 >=' e2" := (cdl_gteC e1 e2) (at level 61).
Notation "e1 =' e2" := (cdl_eqC e1 e2) (at level 61).
Notation "< p >' r" := (cdl_dia1C p r) (at level 63).
Notation "< p > e" := (cdl_dia2C p e) (at level 63).
Notation "e1 \/' e2" := (cdl_orC e1 e2) (at level 71, right associativity).
Notation "e1 ->' e2" := (cdl_impC e1 e2) (at level 72, right associativity).

Check tt'.
Check ff'.
Check (5 -' 3) <' 2.
Check ([ skip ]' c1 << c2) /\' 2 >' 5 /\' tt'.
Check [ @ {x :=' 4 | c1 ! 5} ; (x '> 0) ? {c2!4} ; @ idle; skip] n(c) >' 0.
Check [(@ {x :=' 4 | c1 ! 5} ; (x '> 0) ? {c2!4} ; @ idle; skip)** ]' c1<<c2.
Check [ skip ]' c1 << c2 .
Check all x , 4 =' 5.

(* ===================================================== CDL Calculus ======================================*)

(*************************** Auxiliary Functions ***************************)
(*check if a dynamic formula is a pure FOL formula *)

Fixpoint CheckPureFOL (e : CDL_exp) : Prop :=
  match e with
  | cdl_trueC => True
  | cdl_ltC e1 e2 => True
  | cdl_box1C p r => False
  | cdl_box2C p e' => False
  | cdl_negC e' => CheckPureFOL e'
  | cdl_andC e1 e2 => (CheckPureFOL e1) /\ (CheckPureFOL e2)
  | cdl_forallC x e' => (CheckPureFOL e')
  | cdl_falseC => True
  | cdl_lteC e1 e2 => True
  | cdl_gtC e1 e2 => True
  | cdl_gteC e1 e2 => True
  | cdl_eqC e1 e2 => True
  | cdl_dia1C p r => False
  | cdl_dia2C p e' => False
  | cdl_orC e1 e2 => (CheckPureFOL e1) /\ (CheckPureFOL e2)
  | cdl_impC e1 e2 => (CheckPureFOL e1) /\ (CheckPureFOL e2)
  end.

(* a structure of (true, false, `undefined') *)
Inductive Bool :=
  bBoolC : Prop -> Bool |
  bUndefC : Bool
.

(*
Notation "[ b ]" := (bBoolC b) (at level 74).
Notation "_|_" := bUndefC (at level 74).
*)

(* evaluate a pure FOL formula in CDL formula *)

(* during the derivation we need to translate expression e to expression E. In the semantics of dynamic logic, their
corresponding arithmetical opertors have the same meanings *)

Fixpoint e_2_E (e : e_exp) : E_exp :=
  match e with
  | enumC n => EnumC n
  | evarC s => EvarC s
  | eplusC e1 e2 => EplusC (e_2_E e1) (e_2_E e2)
  | eminusC e1 e2 => EminusC (e_2_E e1) (e_2_E e2)
  | emulC e1 e2 => EmulC (e_2_E e1) (e_2_E e2)
  | edivC e1 e2 => EdivC (e_2_E e1) (e_2_E e2)
  end.

(* -------------------------------computation of free variables in cdl formula----------------------------------------*)
(***
Note that actually here we compute all occurrences of free variables in a cdl formula, not really all free variables, because
here we use `list' as the structure to `store' each appearance of free variables.
It is enough for us to check whether a variable is a free variable or not in a formula checking if it does not equal to
each occurrence of variables.
***)

(* compare the id of two variables *)
Definition eqv (x : Var) (y: Var) : bool :=
  match x, y with
  | var n, var m => if n =? m then true else false
  end.

(* this function check whether a variable (i.e. a string) belongs to a list of variables (list of string) *)
Fixpoint NotIn_bool (s : Var) (vec : list Var) : bool :=
  match vec with
  | nil => true
  | v :: vec' => if (eqv s v) then false else NotIn_bool s vec'
  end.

Compute NotIn_bool x (x :: y :: z :: nil).
Compute NotIn_bool c (x :: y :: z :: nil).

(* this is another version for Prop type, just in case we need it in building the proof system*)
Fixpoint NotIn (s : Var) (vec : list Var) : Prop :=
  match vec with
  | nil => True
  | v :: vec' => if (eqv s v) then False else NotIn s vec'
  end.

Compute NotIn x (x :: y :: z :: nil).
Compute NotIn c (x :: y :: z :: nil).

Fixpoint In (s : Var) (vec : list Var) : Prop :=
  match vec with
  | nil => False
  | v :: vec' => if (eqv s v) then True else In s vec'
  end.

Fixpoint E_exp_FV (e : E_exp) (bv : list Var) : list Var := (*bv : list of bounded variables at current time *)
  match e with
  | EvarC v => if (NotIn_bool v bv) then (v :: nil) else nil
  | ECntClkC c => nil
  | EStClkC c => nil
  | EnumC n => nil
  | EplusC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | EmulC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | EminusC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | EdivC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  end
.

Compute E_exp_FV (x +' 3 *' n(c)) nil.
Compute E_exp_FV (x +' 3 *' z) nil.
Compute E_exp_FV (x +' 3 *' z) (x :: nil).

Fixpoint e_exp_FV (e : e_exp) (bv : list Var) : list Var :=
  match e with
  | enumC n => nil
  | evarC s => if (NotIn_bool s bv) then (s :: nil) else nil
  | eplusC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | eminusC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | emulC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | edivC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  end
.

Compute e_exp_FV (x '+ 3 '* 5) nil.
Compute e_exp_FV (x '+ 3 '* z) nil.
Compute e_exp_FV (x '+ 3 '/ z) (x :: nil).

Fixpoint P_exp_FV (P : P_exp) (bv : list Var) : list Var :=
  match P with
  | PtrueC => nil
  | PlteC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | PnegC P' => P_exp_FV P' bv
  | PandC P1 P2 => (P_exp_FV P1 bv) ++ (P_exp_FV P2 bv)
  | PfalseC => nil
  | PltC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | PgtC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | PgteC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | PeqC e1 e2 => (e_exp_FV e1 bv) ++ (e_exp_FV e2 bv)
  | PorC P1 P2 => (P_exp_FV P1 bv) ++ (P_exp_FV P2 bv)
  | PimpC P1 P2 => (P_exp_FV P1 bv) ++ (P_exp_FV P2 bv)
  end
.

Compute P_exp_FV ('tt '/\ (3 '= 5 '* x)) nil.
Compute P_exp_FV ('tt '/\ (3 '= 5 '* x)) (x :: nil).
Compute P_exp_FV (y '<= 5 '/\ (3 '= 5 '* x)) (z :: nil).

Fixpoint EvtE_FV (e : EvtElement) (bv : list Var) : list Var :=
  match e with
  | sigC s e' => e_exp_FV e' bv
  | assC s e' => e_exp_FV e' bv
  end
.

Fixpoint Evt_FV (evt : Evt) (bv : list Var) : list Var :=
  match evt with
  | nil => nil
  | e :: evt' => (EvtE_FV e bv) ++ (Evt_FV evt' bv)
  end
.

Compute Evt_FV ({ x:='y '+ 2 | c ! (z '* 38)}) nil.
Compute Evt_FV ({ x:='y '+ 2 | c ! (z '* 38)}) (y :: nil).

Fixpoint SEP_exp_FV (e : SEP_exp) (bv : list Var) : list Var :=
  match e with
  | skip => nil
  | evtC evt => (Evt_FV evt bv)
  | tstC P evt => (P_exp_FV P bv) ++ (Evt_FV evt bv)
  | seqC e1 e2 => (SEP_exp_FV e1 bv) ++ (SEP_exp_FV e2 bv)
  | choC e1 e2 => (SEP_exp_FV e1 bv) ++ (SEP_exp_FV e2 bv)
  | loopC e' => (SEP_exp_FV e' bv)
  end
.

Check x '> 2 ? { y :=' y '- z}.
Compute SEP_exp_FV ((@ { x :=' 5}; x '> 2 ? { y :=' y '- z} U skip) **) nil.

Fixpoint cdl_FV (e : CDL_exp) (bv : list Var) : list Var := (*bv : list of bounded variables at current time *)
  match e with
  | cdl_trueC => nil
  | cdl_ltC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | cdl_box1C p r => SEP_exp_FV p bv
  | cdl_box2C p e' => (SEP_exp_FV p bv) ++ (cdl_FV e' bv)
  | cdl_negC e' => cdl_FV e' bv
  | cdl_andC e1 e2 => (cdl_FV e1 bv) ++ (cdl_FV e2 bv)
  | cdl_forallC x1 e' => cdl_FV e' (x1 :: bv) (* x1 is a bounded variable *)
  | cdl_falseC => nil
  | cdl_lteC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | cdl_gtC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | cdl_gteC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | cdl_eqC e1 e2 => (E_exp_FV e1 bv) ++ (E_exp_FV e2 bv)
  | cdl_dia1C p r => SEP_exp_FV p bv
  | cdl_dia2C p e' => (SEP_exp_FV p bv) ++ (cdl_FV e' bv)
  | cdl_orC e1 e2 => (cdl_FV e1 bv) ++ (cdl_FV e2 bv)
  | cdl_impC e1 e2 => (cdl_FV e1 bv) ++ (cdl_FV e2 bv)
  end
.

Check ( all y , y =' 7 ) .
Compute cdl_FV ([ (@ { x :=' 5}; x '> 2 ? { y :=' y '- z} U skip) ] x >' 0 /\' ( all y , y =' 7 ) ) nil.
Compute cdl_FV ([ (@ { x :=' 5}; x '> 2 ? { y :=' y '- z} U skip) ] x >' 0 /\' ( all y , y =' 7 ) ) (y :: nil).

(* for list *)
Fixpoint cdl_FV_l (T : list CDL_exp) (bv : list Var) : list Var :=
  match T with
  | nil => nil
  | e :: T' => (cdl_FV e bv) ++ (cdl_FV_l T' bv)
  end.

(* -------------------------------substitution for single variable----------------------------------------*)
Fixpoint E_exp_subs (e : E_exp) (x' : Var) (x : Var) : E_exp :=
  match e with
  | EvarC v => if (eqv v x) then EvarC x' else EvarC v
  | ECntClkC c => ECntClkC c (* do not consider replacing a clock-related variable *)
  | EStClkC c => EStClkC c
  | EnumC n => EnumC n
  | EplusC e1 e2 => EplusC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | EmulC e1 e2 => EmulC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | EminusC e1 e2 => EminusC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | EdivC e1 e2 => EdivC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  end
.

Compute E_exp_subs (x +' y) y x.
Compute E_exp_subs (x *' z) y c.
Compute E_exp_subs (n(c) *' z) y z.

Notation "e [ x' 'subs-E' x ]" := (E_exp_subs e x' x) (at level 9).

Fixpoint e_exp_subs (e : e_exp) (x' : Var) (x : Var) : e_exp :=
  match e with
  | enumC n => enumC n
  | evarC s => if (eqv s x) then evarC x' else evarC s
  | eplusC e1 e2 => eplusC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | eminusC e1 e2 => eminusC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | emulC e1 e2 => emulC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | edivC e1 e2 => edivC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  end
.

Compute (z '- 5) '* x '+ z.
Compute e_exp_subs ((z '- 5) '* x '+ z) y z.

Fixpoint P_exp_subs (P : P_exp) (x' : Var) (x : Var) : P_exp :=
  match P with
  | PtrueC => PtrueC
  | PlteC e1 e2 => PlteC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | PnegC P' => PnegC (P_exp_subs P' x' x)
  | PandC P1 P2 => PandC (P_exp_subs P1 x' x) (P_exp_subs P2 x' x)
  | PfalseC => PfalseC
  | PltC e1 e2 => PltC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | PgtC e1 e2 => PgtC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | PgteC e1 e2 => PgteC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | PeqC e1 e2 => PeqC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | PorC P1 P2 => PorC (P_exp_subs P1 x' x) (P_exp_subs P2 x' x)
  | PimpC P1 P2 => PimpC (P_exp_subs P1 x' x) (P_exp_subs P2 x' x)
  end
.

Compute 'tt '/\ '~ (x '< 5).
Compute P_exp_subs ('tt '/\ '~ (x '< 5)) z x.

Fixpoint EvtE_subs (e : EvtElement) (x' : Var) (x : Var) : EvtElement :=
  match e with
  | sigC s e' => sigC s (e_exp_subs e' x' x)
  | assC s e' => assC s (e_exp_subs e' x' x)
  end
.

Compute EvtE_subs (c ! x '+ 5) y x.
Compute EvtE_subs (x :=' (5 '* x '+ 3 '/ y)) z x.

Fixpoint Evt_subs (evt : Evt) (x' : Var) (x : Var) : Evt :=
  match evt with
  | nil => nil
  | e :: evt' => (EvtE_subs e x' x) :: (Evt_subs evt' x' x)
  end
.

Compute { c ! x '+ 5 | x :=' 5 '* x '+ 3 '/ y }.
Compute Evt_subs ( { c ! x '+ 5 | x :=' 5 '* x '+ 3 '/ y }) z x.

Fixpoint SEP_exp_subs (e : SEP_exp) (x' : Var) (x : Var) : SEP_exp :=
  match e with
  | skip => skip
  | evtC evt => evtC (Evt_subs evt x' x)
  | tstC P evt => tstC (P_exp_subs P x' x) (Evt_subs evt x' x)
  | seqC e1 e2 => seqC (SEP_exp_subs e1 x' x) (SEP_exp_subs e2 x' x)
  | choC e1 e2 => choC (SEP_exp_subs e1 x' x) (SEP_exp_subs e2 x' x)
  | loopC e' => loopC (SEP_exp_subs e' x' x)
  end
.

Compute @ { c ! x '+ 5 | x :=' 5 '* x '+ 3 '/ y }.
Compute SEP_exp_subs ( @ { c ! x '+ 5 | x :=' 5 '* x '+ 3 '/ y }) z x.

Fixpoint cdl_subs (e : CDL_exp) (x' : Var) (x : Var) : CDL_exp := (* e[x' // x] *)
  match e with
  | cdl_trueC => cdl_trueC
  | cdl_ltC e1 e2 => cdl_ltC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | cdl_box1C p r => cdl_box1C (SEP_exp_subs p x' x) r (* do not consider replacing a clock-related variable *)
  | cdl_box2C p e' => cdl_box2C (SEP_exp_subs p x' x) (cdl_subs e' x' x)
  | cdl_negC e' => cdl_negC (cdl_subs e' x' x)
  | cdl_andC e1 e2 => cdl_andC (cdl_subs e1 x' x) (cdl_subs e2 x' x)
  | cdl_forallC x1 e' => if (eqv x1 x) then cdl_forallC x1 e' else (cdl_subs e' x' x)
  | cdl_falseC => cdl_falseC
  | cdl_lteC e1 e2 => cdl_lteC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | cdl_gtC e1 e2 => cdl_gtC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | cdl_gteC e1 e2 => cdl_gteC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | cdl_eqC e1 e2 => cdl_eqC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | cdl_dia1C p r => cdl_dia1C (SEP_exp_subs p x' x) r (* do not consider replacing a clock-related variable *)
  | cdl_dia2C p e' => cdl_dia2C (SEP_exp_subs p x' x) (cdl_subs e' x' x)
  | cdl_orC e1 e2 => cdl_orC (cdl_subs e1 x' x) (cdl_subs e2 x' x)
  | cdl_impC e1 e2 => cdl_impC (cdl_subs e1 x' x) (cdl_subs e2 x' x)
  end.

Notation "e [ x' 'subs' x ]" := (cdl_subs e x' x) (at level 9).
Check [ skip ]' c1 << c2 .
Locate "/".
Locate "//".

Compute [ y '> 1 ? { x :=' x '+ 1 }; skip ; @ { x :=' x '+ 1 }]' c1 << c2.
Compute ([ y '> 1 ? { x :=' x '+ 1 }; skip ; @ { x :=' x '+ 1 }]' c1 << c2) [ y subs x ] .

(* substitution for list *)
Fixpoint cdl_subs_l (T : list CDL_exp) (x' : Var) (x : Var) : list CDL_exp := (* T [x' // x] *)
  match T with
  | nil => nil
  | e :: T' => (cdl_subs e x' x) :: (cdl_subs_l T' x' x)
  end.

Notation "T [ x' 'subs-l' x ]" := (cdl_subs_l T x' x) (at level 9).

(* ====================================================== CDL Rules =============================================*)

Definition Gamma := list CDL_exp.
Definition Delta := list CDL_exp.

(***DEL Definition SequentL : Gamma -> CDL_exp -> Delta -> Prop.*)

(* we arrange a place special for the dynamic formula we want to verify in the sequent, other formulas in Gamma
and Delta are pure FOL formulas.

We define two types of sequent: sequentL and sequentR, where L and R indicate the verifiying formula is on the left
or right side of the sequent.
*)

Inductive place :=
  exp : CDL_exp -> place |
  empty : place
.

(*
Notation "'<<' e '>>'" := (exp e) (at level 74, e at level 72).
Notation "<< >>" := empty (at level 74).
Check << x <=' y >> .
Check << >>.
Locate "<< >>".
*)

Reserved Notation "{ T , p1 ==> p2 , D }" (at level 75).
(*Reserved Notation "T ==> p , D" (at level 75).*)

Locate "==>".

(*&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& a simple test &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&*)

(*** as a test, we firstly implement a simple rule here, to check if everything in my mind would work well,
we first realize the rule:
    T[x'/x],x = e[x'/x] => E, D[x'/x]
    ---------------------------------
    T => [x := e] E, D

It is equavalent to realize the rule:
    forall x'. (x' not free in T, e, D) -> (T[x'/x],x = e[x'/x] => E, D[x'/x]) -> (T => [x := e] E, D)
***)

(* To be simple, we firstly define a sequent as a triple (\Gamma, formula, \Delta), where \Gamma and \Delta are the context of
the formula that we are going to transform. *)

(**DEL
Inductive tstSeq : Gamma -> place -> place -> Delta -> Type :=
  tst1 : forall (T : Gamma) (D : Delta) (e : e_exp) (phi : CDL_exp) (x : string),
          (
          forall (z : string),
          (tstSeq ((x =' (e_2_E e) [z subs-E x]) :: (T [ z subs-l x ]))
                   empty
                  (exp phi)
                  (D [ z subs-l x ]) )
        ) ->
    (tstSeq T empty (exp ([ @ {x :=' e} ] phi)) D)
where "{ T , p1 ==> p2 , D }" := (tstSeq T p1 p2 D)
.

(* Theorem thm1 : (x =' 1) :: nil , empty ==> [ @ {x :=' x '+ 1}] x >' 2 , nil .*)

Theorem thm1 : tstSeq ((y =' 1) :: nil) empty (exp ([ @ {y :=' y '+ z}] y >' 2)) nil .
Proof.
apply tst1.
intros. simpl.
Abort.

Theorem thm2 : { ((y =' 1):: nil) , empty ==> exp ([ @ {y :=' y '+ z}] y >' 2) , nil }.
DEL**)

Inductive tstSeq2 : Gamma -> place -> place -> Delta -> Type :=
  tst2 : forall (T : Gamma) (D : Delta) (e : e_exp) (phi : CDL_exp) (x : string) (A : Evt),
          (
          forall (z : string),
          (forall (n : string), (In n ((cdl_FV_l T nil) ++ (cdl_FV_l D nil) ++ (e_exp_FV e nil) ++ (Evt_FV A nil) ++ (cdl_FV phi nil)))
                                  -> (n <> z)
          ) ->
          (tstSeq2 ((x =' (e_2_E e) [z subs-E x]) :: (T [ z subs-l x ]))
                   empty
                  (exp ([ @ A ] phi))
                  (D [ z subs-l x ]) )
        ) ->
    (tstSeq2 T empty (exp ([ @ ((x :=' e) :: A) ] phi)) D)
  |
  tst3 : forall (T : Gamma) (D : Delta) (phi : CDL_exp),
          (
          tstSeq2 T
                   empty
                  (exp phi)
                  D
        ) ->
    (tstSeq2 T empty (exp ([ @ idle ] phi)) D)
where "{ T , p1 ==> p2 , D }" := (tstSeq2 T p1 p2 D)
.

Locate "<>".

Compute x = y.

Theorem thm2 : { ((y =' 1):: nil) , empty ==> exp ([ @ {y :=' y '+ z | y :=' y '+ 1}] y >' 2) , nil }.
Proof.
apply tst2.
intros. simpl.
apply tst2.
intros. simpl.
apply tst3. simpl.
simpl H.
Abort.

(*DEL
Inductive E_expt :=
  tvarC : Type -> E_expt |
  tCntClkC : Type -> E_expt |
  tStClkC : Type -> E_expt |
  tnumC : nat -> E_expt |
  tplusC : E_expt -> E_expt -> E_expt |
  (* unecessary expression *)
  tmulC : E_expt -> E_expt -> E_expt |
  tminusC : E_expt -> E_expt -> E_expt |
  tdivC : E_expt -> E_expt -> E_expt
.
Print E_expt.

Variable X : Type.
Variable Y : Type.

Fixpoint E_expt_subs (e : E_expt) (x' : Type) (x : Type) : E_expt :=
  match e with
  | tvarC x => tvarC x
  | tCntClkC c => tCntClkC c (* do not consider replacing a clock-related variable *)
  | tStClkC c => tStClkC c
  | tnumC n => tnumC n
  | tplusC e1 e2 => tplusC (E_expt_subs e1 x' x) (E_expt_subs e2 x' x)
  | tmulC e1 e2 => tmulC (E_expt_subs e1 x' x) (E_expt_subs e2 x' x)
  | tminusC e1 e2 => tminusC (E_expt_subs e1 x' x) (E_expt_subs e2 x' x)
  | tdivC e1 e2 => tdivC (E_expt_subs e1 x' x) (E_expt_subs e2 x' x)
  end
.
Print E_expt_subs.
***DEL*)

(*** exploring how the `apply' works and how the pattern matching works in Coq ***)
Inductive ev : nat -> Prop :=
  ev_0 : ev 0 |
  ev_SS : forall (n : nat), ev n -> ev ( S (S n))
.

Theorem ev_4 : ev 4.
Proof.
apply ev_SS. apply ev_SS. apply ev_0.
Qed.

Theorem ev_plus4 : forall n, ev n -> ev (4 + n).
Proof.
  intros n. simpl. intros Hn.
  apply ev_SS. apply ev_SS. apply Hn.
Qed.

Inductive month : Set :=
  Jan | Feb | Mar
.

(*&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&  end of test &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&*)
Inductive validSeq : sequent -> Type :=
  tst : forall (T : Gamma) (p : CDL_exp) (D : Delta), (CheckPureFOL p) -> validSeq ( T ==> p , D ).


Require Import Aux List Setoid Field VectorSpace.

Section Kn.

(* This is our scalar space with its dimension *)
Variable p : params.
(* The operations for scalar have the exprected properties *)
Hypothesis Hp : fparamsProp p.

(* We recover the usual mathematical notation *)
Notation "'K'" := (K p).

Delimit Scope kn_scope with k.
Open Scope vector_scope.
Open Scope kn_scope.

(* A vector is a list of length n *)

Fixpoint kn (n: nat): Set :=
  match n with O => unit | S n1 => (K * kn n1)%type end.

(** We first build the functions of the vector space *)

(* Equality of two vectors as list *)
Fixpoint eq (n : nat) : kn n -> kn n -> bool :=
  match n return (kn n -> kn n -> bool) with
  | 0%nat => fun a b => true
  | S n1 =>
      fun l1 l2 =>
      let (v1, l3) := l1 in
      let (v2, l4) := l2 in
      if (v1 ?= v2)%f then eq n1 l3 l4 else false
  end.

(* Generate the constant k for the dimension n *)
Fixpoint genk (n: nat) (k: K) {struct n}: (kn n) :=
   match n return kn n with 0%nat => tt |
                            (S n1) => (k, genk n1 k) end.

Notation " [ k ] " := (genk _ k) (at level 10): kn_scope.

(* Adding two vectors as list *)
Fixpoint add (n : nat) : kn n -> kn n -> kn n :=
  match n return (kn n -> kn n -> kn n) with
  | 0%nat => fun a b => tt
  | S n1 =>
      fun l1 l2 =>
      let (v1, l3) := l1 in
      let (v2, l4) := l2 in ((v1 + v2)%f, add n1 l3 l4)
  end.

(* Multiplication by a scalar *)
Fixpoint scal (n : nat) (k: K) {struct n}: kn n -> kn n :=
  match n return (kn n -> kn n) with
  | 0%nat => fun a => tt
  | S n1 =>
      fun l1 =>
      let (v1,l2) := l1 in ((k * v1)%f , scal n1 k l2)
  end.

Canonical Structure vn_eparams (n: nat) :=
  Build_eparams (kn n) K (genk n 0%f) (eq n) (add n) (scal n).

Definition fn n : vparamsProp (vn_eparams n).
apply Build_vparamsProp; auto.
(* eq Dec *)
induction n as [| n IH]; simpl.
  intros [] []; auto.
intros (v1,l1) (v2, l2);
  generalize (eqK_dec _ Hp v1 v2); case eqK; intros HH; subst.
  generalize (IH l1 l2); unfold eqE; simpl.
case eq; intros HH; subst; auto.
  intros HH1; injection HH1; intros; case HH; auto.
intros HH1; injection HH1; intros; case HH; auto.
(* assoc *)
induction n as [| n IH]; simpl; auto.
intros (v1,l3) (v2, l4) (v3, l5); simpl in IH;
 rewrite IH, (addK_assoc _ Hp); auto.
(* comm *)
induction n as [| n IH]; simpl; auto.
intros (v1,l3) (v2, l4); simpl in IH;
  rewrite (addK_com _ Hp), (IH l3); auto.
(* 0 is  a left neutral element for + *)
induction n as [| n IH]; simpl; auto.
  intros []; auto.
intros (l1,l2); simpl in IH; rewrite (addK0l _ Hp), IH; auto.
(* Multiplication by 0 *)
induction n as [| n IH]; simpl; auto.
intros (l1, l2); simpl in IH; rewrite (multK0l _ Hp), IH; auto.
(* Multiplication by 1 *)
induction n as [| n IH]; simpl.
  intros []; auto.
intros (l1, l2); simpl in IH; rewrite (multK1l _ Hp), IH; auto.
(* Left addition of the multiplication by a scalar *)
induction n as [| n IH]; simpl; auto.
intros k1 k2 (l1, l2); simpl in IH; rewrite (add_multKl _ Hp), IH; auto.
(* Right addition of the multiplication by a scalar *)
induction n as [| n IH]; simpl; auto.
intros k (l1, l3) (l2, l4); simpl in IH; rewrite (add_multKr _ Hp), IH; auto.
(* Composition of the multiplication by a scalar *)
induction n as [| n IH]; simpl; auto.
intros k1 k2 (k, x); simpl in IH; rewrite (multK_assoc _ Hp), IH; auto.
Qed.

Hint Resolve fn.

Ltac Kfold n :=
     change (add n) with (addE (vn_eparams n));
     change (scal n) with (scalE (vn_eparams n));
     change (genk n 0%f) with (E0 (vn_eparams n)).

(* scal is integral *)
Lemma scal_integral n k (x: kn n) : k .* x = 0 -> k = 0%f \/ x = 0.
Proof.
induction n as [| n IH]; simpl; auto.
  destruct x; auto.
destruct x as (x1, x2); intros HH; injection HH; intros HH1 HH2.
case (IH _ _ HH1); case (multK_integral _ Hp k x1); auto.
intros; right; apply f_equal2 with (f := @pair _ _); auto.
Qed.

Lemma genk_inj n k1 k2 : [k1] = [k2] :> kn n.+1 -> k1 = k2.
Proof.
simpl; intros HH; injection HH; auto.
Qed.

Lemma genk0_dec n (x: kn n) :  x = 0 \/ x <> 0.
Proof.
induction n as [| n IH]; simpl; auto.
destruct x; auto.
destruct x as (x1, x2).
case (IH x2); intros H1; subst; auto.
generalize (eqK_dec _ Hp x1 0%f); case eqK;intros H1; subst; auto.
right; intro HH; case H1; injection HH; auto.
right; intro HH; case H1; injection HH; auto.
Qed.

(* Conversion from list to kn *)
Fixpoint l2kn (n:nat) (l:list K) {struct l} : kn n:=
  match n return kn n with
  | 0 => tt
  | S n1 => match l with
            | nil => genk (S n1) 0%f
            | a::l1 =>  (a,l2kn n1 l1)
            end
  end.

Fixpoint kn2l (n : nat) : kn n -> list K :=
  match n return (kn n -> list K) with
  | 0 => fun x => nil
  | S n1 => fun v => let (a, v1) := v in a :: kn2l n1 v1
  end.

Lemma kn2ll2knE n x : l2kn n (kn2l n x) = x.
Proof.
induction n as [| n IH]; destruct x; simpl; auto.
rewrite IH; auto.
Qed.

Lemma genk_id0 n i : In i (kn2l n (genk n 0%f)) -> i = 0%f.
Proof.
induction n as [| n IH]; simpl;
  intros HH; case HH; auto.
Qed.

Inductive eql_t0 : list K -> list K -> Prop :=
  eql_t0N: eql_t0 nil nil
| eql_t0Nl: forall l, eql_t0 l nil -> eql_t0 (0%f :: l) nil
| eql_t0Nr: forall l, eql_t0 nil l -> eql_t0 nil (0%f :: l)
| eql_t0R: forall a l1 l2, eql_t0 l1 l2 -> eql_t0 (a :: l1) (a :: l2).

Hint Constructors eql_t0.

Lemma eql_refl l : eql_t0 l l.
Proof. elim l; auto. Qed.

Lemma eql_sym l1 l2 : eql_t0 l1 l2 -> eql_t0 l2 l1.
Proof. intros HH; elim HH; auto.
Qed.

Lemma eql_trans l2 l1 l3 : eql_t0 l1 l2 -> eql_t0 l2 l3 -> eql_t0 l1 l3.
Proof.
intros HH; generalize l3; elim HH; auto; clear l1 l2 l3 HH.
intros l1 HH IH l3 HH1.
  generalize (IH _ HH1); inversion_clear HH1; auto.
intros l1 HH IH l3 HH1.
  inversion_clear HH1; auto.
intros a l1 l2 HH IH l3 HH1.
  inversion_clear HH1; auto.
Qed.

Lemma dmap2_eql a l1 l2 l3 :
  eql_t0 l2 l3 ->
  eql_t0 (dmap2 (multK K) a l1 l2) (dmap2 (multK K) a l1 l3).
Proof.
intros HH; generalize l1; elim HH; clear l1 l2 l3 HH; simpl; auto.
intros [|b l1]; auto.
intros l2 HH IH [|b l1].
  rewrite multK0r; auto; apply eql_t0Nl.
  generalize (IH nil); auto.
  rewrite multK0r; auto; apply eql_t0Nl.
  generalize (IH l1); auto; case l1; auto.
intros l2 HH IH [|b l1].
  rewrite multK0r; auto; apply eql_t0Nr.
  generalize (IH nil); auto.
  rewrite multK0r; auto; apply eql_t0Nr.
  generalize (IH l1); auto; case l1; auto.
intros b l2 l3 HH IH [|c l1].
 apply eql_t0R; auto.
 apply eql_t0R; auto.
Qed.

Lemma kn2l_0 n : eql_t0 (kn2l n 0) nil.
Proof. elim n; simpl; auto. Qed.

(* Generate the p element of the base in dimension n *)
Fixpoint gen (n: nat) (p: nat) {struct n} : kn n :=
  match n return kn n with O => tt | S n1 =>
    match p with
      0 => (1%f, genk n1 0%f)
    | S p1 =>  (0%f, gen n1 p1)
    end
  end.

Notation " 'e_ p" := (gen _ p) (at level 70): kn_scope.

Lemma gen_inj n p1 p2 : p1 < n -> p2 < n ->
  'e_p1 = ('e_p2 : kn n)  -> p1 = p2.
Proof.
generalize p1 p2; clear p1 p2.
induction n as [| n IH]; auto.
intros p1 p2 Hp1; contradict Hp1; auto with arith.
intros [|p1] [|p2] HH1 HH2; simpl; auto.
intros HH; injection HH; intros; case (one_diff_zero _ Hp); auto.
intros HH; injection HH; intros; case (one_diff_zero _ Hp); auto.
intros HH; rewrite (IH p1 p2); auto with arith.
injection HH; auto.
Qed.

Lemma kn2l_e0 n : eql_t0 (kn2l n.+1 ('e_0)) (1%f :: nil).
Proof.
simpl; auto.
apply eql_t0R.
apply kn2l_0; auto.
Qed.

Lemma kn2l_ei n i :
  eql_t0 (kn2l n.+1 ('e_i.+1))  (0%f :: kn2l n ('e_i)).
Proof.
apply eql_refl.
Qed.

(* Lift a vector of dimension n into a vector of dimension n+1 whose
   first component is 0 *)
Definition lift (n: nat) (v: kn n) : (kn (S n)) :=  (0%f, v).

Lemma lift0 n : lift n 0 = 0.
Proof. auto. Qed.

(* Lift of generator of the base *)
Lemma lift_e : forall n i, 'e_(S i) = lift n ('e_i).
Proof. auto. Qed.

(* Lift on add *)
Lemma lift_add n x y : lift n (x + y) = lift n x + lift n y.
Proof. unfold lift; simpl; rewrite addK0l; auto. Qed.

(* Lift on scalar multiplication *)
Lemma lift_scal n k x :  lift n (k .* x) = scalE (vn_eparams (S n)) k (lift n x).
Proof. unfold lift; simpl; rewrite multK0r; auto. Qed.

(* Lift on the multiple product *)
Lemma lift_mprod (n: nat) ks vs : ks *X* map (lift n) vs =
  lift n (mprod (vn_eparams n) ks vs).
Proof.
generalize vs; clear vs; induction ks as [| k ks IH].
  intros vs; repeat rewrite mprod0l; auto.
intros [| v vs]; simpl; try rewrite mprod0r; auto.
rewrite (mprod_S (vn_eparams n.+1)); auto.
rewrite mprod_S; auto.
rewrite IH, lift_add, lift_scal; auto.
Qed.

(* The base as the list of all the generators *)
Fixpoint base (n : nat) : list (kn n) :=
  match n return list (kn n) with
  | 0 => nil
  | S n1 => ('e_0: kn (S n1)) :: map (lift n1) (base n1)
  end.

(* Each generator is in the base *)
Lemma e_in_base n i : i < n -> In ('e_i) (base n).
Proof.
generalize i; clear i; induction n as [| n IH].
  intros i HH; contradict HH; auto with arith.
intros [| p1] Hp1; simpl; Kfold n; auto; right.
refine (in_map _ _ _ _); auto with arith.
Qed.

(* An element of the base is a generator *)
Lemma e_in_base_ex n v :
  In v (base n) -> exists p1, p1 < n /\ v = 'e_p1.
Proof.
generalize v; clear v; induction n as [| n IH].
  intros v [].
simpl; intros [vv1 vv2] [H1 | H1].
  exists 0%nat; auto with arith.
rewrite in_map_iff in H1; case H1.
intros vv3 [Hvv3 Hvv3'].
case (IH _ Hvv3'); intros p1 [Hp1 Hp2].
exists (S p1); split; auto with arith.
rewrite <- Hvv3; rewrite Hp2; auto.
Qed.

(* The length of the base is n *)
Lemma base_length n : length (base n) = n.
Proof.
induction n as [| n IH]; simpl; auto.
rewrite map_length; rewrite IH; auto.
Qed.

(* The base is free *)
Lemma base_free n : free _ (base n).
Proof.
  induction n as [|n IH].
  *
     intro. simpl. intros H H0 k H1.
    assert (ks = nil) by (destruct ks; auto; discriminate).  subst.  inversion H1.
  * intro. destruct ks as [| k ks].
  - simpl. intros. discriminate.
  -
    intros H1. simpl base. rewrite mprod_S, lift_mprod; auto.
    simpl. intros HH. injection HH. clear HH.
    Kfold n.
    rewrite scalE0r, addE0l, addK0r; auto.
    intros H2 H3 k1 [Hk1 | Hk1].
    +
      case (multK_integral _ Hp _ _ H3); try subst; auto; intros Heq.
      case (one_diff_zero (vn_eparams n)); auto; apply (vgenk_inj _ _ _ Heq).
    +
      injection H1; rewrite map_length; auto.
      intros Hl; apply (IH ks); auto.
Qed.

Lemma k2l_mprod n (v: kn n) : kn2l n v *X* base n = v.
Proof.
generalize v; clear v; induction n as [| n IH].
simpl; intros []; auto.
simpl; intros (x, v).
rewrite (mprod_S (vn_eparams n.+1)); auto.
rewrite lift_mprod, IH.
simpl; Kfold n; auto.
Krm1; Vrm0.
Qed.

(* Every vector is a linear combination of the base *)
Lemma cbl_base n v : cbl _ (base n) v.
Proof. rewrite <- (k2l_mprod n v); apply mprod_cbl; auto. Qed.

Lemma  kn_induct n (P: kn n -> Prop) :
     P 0 ->
     (forall p, p < n -> P ('e_p)) ->
     (forall v1 v2, P v1 -> P v2 -> P (v1 + v2)) ->
     (forall k v, P v -> P (k .* v)) ->
     (forall x, P x).
Proof.
intros H1 H2 H3 H4 x.
elim (cbl_base n x); clear x; auto.
intros v HH; case (e_in_base_ex _ _ HH); intros m (Hl,Hm).
rewrite Hm; auto with arith.
Qed.

(* Coordinates for k vector *)
Fixpoint proj (n: nat) k : (kn n) -> K :=
  match n return kn n -> K with
  | O => fun _ => 0%f
  | S n1 => fun l => let (a,l1) := l in
          match k with | O => a | S k1 =>
           proj n1 k1 l1
          end
  end.

Lemma proj0 n i : proj n i 0 = 0%f.
Proof.
generalize i; clear i.
induction n as [| n IH]; intros [|i]; simpl; auto.
Qed.

Lemma proj_e n i j : j < n ->
  proj n i ('e_j) = if (i ?= j)%nat then 1%f else 0%f.
Proof.
generalize i j; clear i j.
induction n as [| n IH]; intros [|i] [|j] H;
  simpl; auto with arith; try (contradict H; auto with arith; fail).
rewrite proj0; auto.
Qed.

Lemma proj_scal n i k x :  proj n i (k .* x) = (k * proj n i x)%f.
Proof.
generalize i x; clear i x.
induction n as [| n IH]; simpl; auto.
Krm0.
intros [| i] [x1 x2]; auto.
exact (IH _ i x2).
Qed.

Lemma proj_add n i x y :
 proj n i (x + y) = (proj n i x + proj n i y)%f.
Proof.
generalize  i x y; clear i x y.
induction n as [| n IH]; simpl; auto.
intros [| i]; Krm0.
intros [| i] (x1,x2) (x3,x4); auto.
exact (IH i x2 x4).
Qed.

Fixpoint pscal (n: nat): (kn n) -> (kn n) -> K :=
  match n return kn n -> kn n -> K with
  | O => fun a b => 0%f
  | S n1 => fun l1 l2 => let (a,l3) := l1 in let (b,l4) := l2 in
                         (a * b + pscal n1 l3 l4)%f
  end.

Notation "a  [.]  b" := (pscal _ a b) (at level 40): kn_scope.

Lemma pscal0l n (x: kn n) : 0 [.] x = 0%f.
Proof.
induction n as [| n IH]; simpl.
 intros; Krm0.
destruct x; rewrite IH; Krm0.
Qed.

Lemma pscal0r n (x: kn n) : x [.] 0 = 0%f.
Proof.
induction n as [| n IH]; simpl.
 intros; Krm0.
destruct x; rewrite IH; Krm0.
Qed.

Lemma pscal_com n (x y: kn n) : x [.] y = y [.] x.
Proof.
induction n as [| n IH]; simpl.
 intros; Krm0.
destruct x; destruct y; rewrite multK_com, IH; auto.
Qed.

Lemma pscal_e n (i j: nat) : i < n -> j < n ->
  ('e_i: kn n) [.] ('e_j) = if (i ?= j)%nat then 1%f else 0%f.
Proof.
generalize i j; clear i j.
induction n as [| n IH].
  intros i j HH; contradict HH; auto with arith.
intros [|i] [|j] Hi Hj;
  simpl; auto with arith;
  try rewrite pscal0l; try rewrite pscal0r; Krm0; Krm1.
apply IH; auto with arith.
Qed.

Lemma pscal_scall n k (x y: kn n) :
  (k .* x) [.] y = (k * (x [.] y))%f.
Proof.
induction n as [| n IH]; simpl; auto; try Kfold n; Krm0.
destruct x; destruct y.
rewrite add_multKr, multK_assoc, IH; auto.
Qed.

Lemma pscal_scalr n k (x y: kn n) :
  x [.] (k .* y) = (k * (x [.] y))%f.
Proof.
induction n as [| n IH]; simpl; auto; try Kfold n; Krm0.
destruct x as [a x]; destruct y.
rewrite add_multKr, <-multK_assoc, (multK_com _ Hp a), multK_assoc, IH; auto.
Qed.

Lemma pscal_addl n (x y z: kn n) :
  (x + y) [.] z = (x [.] z + (y [.] z))%f.
Proof.
induction n as [| n IH]; simpl; auto; try Kfold n; Krm0.
destruct x; destruct y as [b y]; destruct z as [c z].
rewrite add_multKl, IH; auto.
rewrite !addK_assoc; auto.
rewrite <-(addK_assoc _ Hp (b * c)%f), (addK_com _ Hp (b * c)%f),
        !addK_assoc; auto.
Qed.

Lemma pscal_addr n (x y z: kn n) :
  z [.] (x + y) = (z [.] x + (z [.] y))%f.
Proof.
induction n as [| n IH]; simpl; auto; try Kfold n; Krm0.
destruct x; destruct y as [b y]; destruct z as [c z].
rewrite add_multKr, IH; auto.
rewrite !addK_assoc; auto.
rewrite <-(addK_assoc _ Hp (c * b)%f), (addK_com _ Hp (c * b)%f),
        !addK_assoc; auto.
Qed.

(* Our final vector *)
Definition Kn := kn p.
Definition K0 := genk p 0%f.
Definition Keq: Kn -> Kn -> bool := eq p.
Definition Kadd: Kn -> Kn -> Kn := add p.
Definition Kscal: K -> Kn -> Kn := scal p.
Definition Kproj: nat -> Kn -> K := proj p.
Definition Ksprod: Kn -> Kn -> K := pscal p.
Definition Kgen := gen p.

Canonical Structure v_eparams :=
  Build_eparams Kn K K0 Keq Kadd Kscal.
Definition f : vparamsProp v_eparams := fn p.

(* Prod of two vectors as list *)
Fixpoint kprod (n : nat) : kn n -> kn n -> kn n :=
  match n with
  | 0%nat => fun a b => tt
  | S n1 =>
      fun l1 l2 =>
      let (v1, l3) := l1 in
      let (v2, l4) := l2 in ((v1 * v2)%f, kprod n1 l3 l4)
  end.

Local Notation "a  [*]  b" := (kprod _ a b) (at level 40).

Lemma kprod0l n a : 0 [*] a = 0 :> kn n.
Proof.
induction n as [|n IH]; simpl; auto.
destruct a; simpl; rewrite IH; Krm0.
Qed.

Lemma kprod0r n a : a [*] 0 = 0 :> kn n.
Proof.
induction n as [|n IH]; simpl; auto.
destruct a; simpl; rewrite IH; Krm0.
Qed.

Lemma kprodkl n k a : [k] [*] a = k .* a :> kn n.
Proof.
induction n as [|n IH]; destruct a; simpl; auto.
rewrite IH; Krm1.
Qed.

Lemma kprodkr n k a : a [*] [k] = k .* a :> kn n.
Proof.
induction n as [|n IH]; destruct a; simpl; auto.
rewrite IH, multK_com; Krm1.
Qed.

Lemma kprod1l n a : [1%f] [*] a = a :> kn n.
Proof.
rewrite kprodkl, scalE1; auto.
Qed.

Lemma kprod1r n a : a [*] [1%f] = a :> kn n.
Proof.
rewrite kprodkr, scalE1; auto.
Qed.

Lemma kprod_addl n a b c :
  (a + b) [*] c = a [*] c + b [*] c :> kn n.
Proof.
induction n as [|n IH]; simpl; auto.
destruct a; destruct b; destruct c; simpl.
Kfold n; rewrite IH, add_multKl; Krm0.
Qed.

Lemma kprod_addr n a b c :
  a [*] (b + c) = a [*] b + a [*] c :> kn n.
Proof.
induction n as [|n IH]; simpl; auto.
destruct a; destruct b; destruct c; simpl.
Kfold n; rewrite IH, add_multKr; Krm0.
Qed.

Lemma kprod_scall n k a b :
  (k .* a) [*] b = k .* (a [*] b) :> kn n.
Proof.
induction n as [|n IH]; simpl; auto.
destruct a; destruct b; simpl.
Kfold n; rewrite IH, multK_assoc; Krm0.
Qed.

Lemma kprod_scalr n k a b :
  a [*] (k .* b) = k .* (a [*] b) :> kn n.
Proof.
induction n as [|n IH]; simpl; auto.
destruct a; destruct b; simpl.
Kfold n; rewrite IH, multK_swap; Krm0.
Qed.

Lemma kprod_assoc n a b c :
  (a [*] b) [*] c = a [*] (b [*] c) :> kn n.
Proof.
induction n as [|n IH]; simpl; auto.
destruct a; destruct b; destruct c; simpl.
Kfold n; rewrite IH, multK_assoc; Krm0.
Qed.

End Kn.

Notation " 'e_ p" := (gen _ _ p) (at level 8) : Kn_scope.
Notation " [ k ] " := (genk _ _ k) (at level 9) : Kn_scope.
Notation "a  [.]  b" := (pscal _ _ a b) (at level 40): Kn_scope.
Notation "a  [*]  b" := (kprod _ _ a b) (at level 40): Kn_scope.

Delimit Scope Kn_scope with Kn.

Hint Constructors eql_t0.


From mathcomp Require Import all_ssreflect finmap.
From hanoi Require Import extra.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Main.

Variable a b : nat.
Hypothesis aL1 : 1 < a.
Hypothesis aLb : a < b.
Hypothesis aCb : coprime a b.

Let bL1 : 1 < b.
Proof. by apply: ltn_trans aLb. Qed.

Fixpoint alphal (n : nat) :=
 if n isn't n1.+1 then [:: 1; a; b]
 else
 let l := alphal n1 in
   merge leq
   (let c := head 1 l in
    let l1 := if b * c \in l then [::] else [:: b * c] in
    if a * c \in l then l1 else a * c :: l1)
   (behead l).

Definition alpha n := head 1 (alphal n).

Lemma behead_sorted (T: eqType) (r : rel T) (l : seq T) :
  sorted r l -> sorted r (behead l).
Proof. by case: l => //= a1 [|b1 l /andP[]]. Qed.

Lemma sorted_alphal n : sorted leq (alphal n).
Proof.
elim: n => /= [|n IH]; first by rewrite ltnW //= ltnW.
apply: merge_sorted; first by apply: leq_total.
  by do 2 case: (_ \in _) => //=; rewrite leq_mul2r orbC ltnW.
by apply: behead_sorted.
Qed.

Lemma gt0_alphal n i : i \in alphal n -> 0 < i.
Proof.
elim: n i => /= [i|n].
  by rewrite !inE => /or3P[] /eqP-> //; rewrite ltnW // (ltn_trans aL1).
case: (alphal n) => [/= _ i|/= a1 l IH i]; rewrite !inE.
  by case/orP=> /eqP->; rewrite muln1 ltnW.
have H1 : 0 < a1 by apply: IH; rewrite inE eqxx.
have IH1 i1 : i1 \in l -> 0 < i1.
  by move=> U; apply: IH; rewrite inE orbC U.
rewrite mem_merge.
(do 2 case: (_ || _)); rewrite //= ?inE; first by apply: IH1.
- by case/orP=> [/eqP->|/IH1//]; rewrite muln_gt0 ltnW.
- by case/orP=> [/eqP->|/IH1//]; rewrite muln_gt0 ltnW.
by case/or3P=> [/eqP->|/eqP->|/IH1//]; rewrite muln_gt0 ltnW.
Qed.

Lemma alphal_neq_nil n : alphal n != nil.
Proof.
case: n => //= n.
rewrite -size_eq0 size_merge.
case: (alphal n) (@gt0_alphal n) => //= c l H.
case E : (_ \in _) => //; case : (_ \in _) => //.
case: l H E aL1 => // /(_ c); rewrite !inE eqxx => /(_ is_true_true).
case: c => // c1 _.
by rewrite -{2}[_.+1]mul1n eqn_mul2r /= => /idP/eqP->.
Qed.

Lemma uniq_alphal n : uniq (alphal n).
Proof.
elim: n =>  /=[|n IH].
  by rewrite !inE negb_or !neq_ltn aL1 aLb /= (ltn_trans aL1).
case: (alphal n) (@gt0_alphal n) IH => //= [_ _|c l U /andP[cL uL]].
  by rewrite !inE !muln1 neq_ltn aLb.
(have [H1|H1] := boolP (_ \in _); have [H2|H2] := boolP (_ \in _);
         rewrite merge_uniq); rewrite /= ?uL ?andbT //=.
- by move: H2; rewrite inE negb_or => /andP[].
- by move: H1; rewrite inE negb_or => /andP[].
move: H1 H2; rewrite !inE !negb_or => /andP[_ ->] /andP[_ ->].
by rewrite eqn_mul2r negb_or !neq_ltn aLb U ?orbT // inE eqxx.
Qed.

Lemma alpha_ltn n : alpha n < alpha n.+1.
Proof.
rewrite /alpha /=.
set h := head _ _.
have hP : 0 < h.
  rewrite /h.
  case: (alphal n) (@gt0_alphal n) => // c l /(_ c)-> //.
  by rewrite inE eqxx.
set l1 := merge _ _ _.
have hIl1 : head 1 l1 \in l1.
  have /= := alphal_neq_nil n.+1.
  by rewrite -/l1; case: l1 => //= c l; rewrite inE eqxx.
suff hLi i :  i \in l1 -> h < i.
  by apply/hLi/hIl1.
rewrite mem_merge mem_cat.
suff hLi1 : (i \in behead (alphal n)) -> h < i => [|H].
  have [H1|H1] := boolP (_ \in alphal _);
    have [H2|H2] := boolP (_ \in alphal _); rewrite /= ?inE -/h //.
  - by case/orP=> [/eqP->|//]; rewrite ltn_Pmull.
  - by case/orP=> [/eqP->|//]; rewrite ltn_Pmull.
  by rewrite -orbA => /or3P[/eqP->|/eqP->|//]; rewrite ltn_Pmull.
have hsSa : subseq [:: h; i] (alphal n).
  rewrite (_ : alphal n =  h :: behead (alphal n)).
    rewrite (@cat_subseq _ [::h] _ [::h]) //.
    by rewrite sub1seq.
  by rewrite /h; case: (alphal n) (alphal_neq_nil n).
rewrite ltn_neqAle.
have /= := subseq_sorted leq_trans hsSa (sorted_alphal n).
rewrite andbT => ->.
have /= := subseq_uniq hsSa (uniq_alphal n).
by rewrite inE.
Qed.

Lemma alpha_mono m n : m < n -> alpha m < alpha n.
Proof.
elim: n => // n IH.
have F := alpha_ltn n.
by rewrite ltnS leq_eqVlt => /orP[/eqP->| /IH /ltn_trans-> //].
Qed.

Lemma alpha_inj : injective alpha.
Proof.
move=> m n amEan; apply/eqP.
by case: ltngtP => // /alpha_mono; rewrite amEan ltnn.
Qed.

Lemma alpha_gt0 n : 0 < alpha n.
Proof. by case: n => // n; apply: leq_ltn_trans (alpha_ltn _). Qed.

Lemma alpha_gtn_n n : n < alpha n.
Proof. by elim: n => // n IH; apply: leq_trans (alpha_ltn _). Qed.

Definition isAB i := exists m, i = a ^ m.1 * b ^ m.2.

Lemma isAB_aexp i : isAB (a ^ i).
Proof. by exists (i, 0); rewrite muln1. Qed.

Lemma isAB_bexp i : isAB (b ^ i).
Proof. by exists (0, i); rewrite mul1n. Qed.

Lemma isAB_amul i : isAB i -> isAB (a * i).
Proof.
case=> [] [m1 m2 /= ->]; exists (m1.+1, m2).
by rewrite !mulnA expnS.
Qed.

Lemma isAB_bmul i : isAB  i-> isAB (b * i).
Proof.
case=> [] [m1 m2 /= ->]; exists (m1, m2.+1).
by rewrite mulnCA expnS.
Qed.

Lemma isAB_alphal n i : i \in alphal n -> isAB i.
Proof.
elim: n i => /= [i|n IH i]; rewrite ?mem_merge ?inE.
  case/or3P => /eqP->; first by exists (0, 0).
    by apply: (isAB_aexp 1).
  by apply: (isAB_bexp 1).
have F : i \in behead (alphal n) -> exists m, i = a ^ m.1 * b ^ m.2.
  by move=> U; apply: IH (mem_behead _).
have [[m1 m2 Hm]] : exists m, head 1 (alphal n) = a ^ m.1 * b ^ m.2.
  case: (alphal n) IH => /= [_|c l F1]; first by exists (0, 0).
  by apply: F1; rewrite inE eqxx.
(do 2 case: (_ \in alphal _)); rewrite /= ?inE.
- by apply: F.
rewrite /=.
- case/orP=> [/eqP->|/F//]; exists (m1, m2.+1).
  by rewrite /= Hm mulnCA expnS.
- case/orP=> [/eqP->|/F//]; exists (m1.+1, m2).
  by rewrite Hm expnS !mulnA.
case/or3P=> [/eqP->|/eqP->|//].
  by exists (m1.+1, m2); rewrite Hm expnS !mulnA.
by exists (m1, m2.+1); rewrite /= Hm mulnCA expnS.
Qed.

Lemma isAB_alpha n : isAB (alpha n).
Proof.
rewrite /alpha.
case: (alphal n) (alphal_neq_nil n)
      (@isAB_alphal n (head 1 (alphal n))) => //= c l _.
by apply; rewrite inE eqxx.
Qed.

Lemma in_alphal n i :
 i \in alphal n -> i != alpha n -> i \in alphal n.+1.
Proof.
have := alpha_gt0 n.
rewrite  /alpha /= mem_merge mem_cat orbC.
case: (alphal n) => //= c l cP.
by rewrite inE => /orP[/eqP->|->//]; rewrite eqxx.
Qed.

Lemma alpha_in_alphal n : alpha n \in alphal n.
Proof.
have /= := alphal_neq_nil n.
rewrite /alpha; case: alphal => //= c l.
by rewrite inE eqxx.
Qed.

Lemma in_alphalS n i :
 i \in alphal n.+1 ->
 i != a * alpha n ->  i != b * alpha n ->
 i \in alphal n.
Proof.
rewrite /alpha /=.
set h := head _ _.
rewrite mem_merge mem_cat => /orP[]; last first.
  by case: alphal => //= c l; rewrite inE orbC => ->.
by (do 2 case: (_ \in alphal _); rewrite //= ?inE) =>
   [/eqP->|/eqP->|/orP[/eqP->|/eqP->]]; rewrite eqxx.
Qed.

Lemma a_in_alphalS n : a * alpha n \in alphal n.+1.
Proof.
have := alpha_gt0 n.
have := @in_alphal n (a * alpha n).
rewrite /alpha /= mem_merge.
set h := head _ _.
have [H H1 H2|] := boolP (_ \in alphal n).
  apply: H1 => //.
  by rewrite -{2}[h]mul1n eqn_mul2r negb_or !neq_ltn H2 aL1 !orbT.
by rewrite mem_cat inE eqxx.
Qed.

Lemma b_in_alphalS n : b * alpha n \in alphal n.+1.
Proof.
have := alpha_gt0 n.
have := @in_alphal n (b * alpha n).
rewrite /alpha /= mem_merge.
set h := head _ _.
have [H H1 H2|] := boolP (b * _ \in alphal n).
  apply: H1 => //.
  by rewrite -{2}[h]mul1n eqn_mul2r negb_or !neq_ltn H2 bL1 !orbT.
by have [] := boolP (a * _ \in alphal n); rewrite mem_cat !inE eqxx // orbT.
Qed.

Lemma alpha_surjective m n : {k | alpha k = a ^ m * b ^ n}.
Proof.
pose P p := has (fun i => i %| a ^ m * b ^ n) (alphal p).
have F1 : exists n, P n.
  by exists 0; apply/hasP; exists 1.
have F2 : 0 < a ^ m *  b ^ n.
  rewrite muln_gt0 !expn_gt0 ?(ltn_trans _ aLb) (ltn_trans _ aL1) //.
have F3 p : P p -> p <= alpha (a ^ m * b ^ n).
  move=> /hasP[q] qIa.
  suff F : alpha p <= q.
     move=> /(dvdn_leq F2) H.
     rewrite ltnW // (leq_trans (alpha_gtn_n _)) //.
     by rewrite (leq_trans F) // (leq_trans H) // ltnW // alpha_gtn_n.
  have /= := sorted_alphal p; rewrite /alpha.
  case: (alphal _) qIa => //= a1 l.
  by rewrite inE => /orP[/eqP->//|qIl /(order_path_min leq_trans) /allP/(_ _ qIl)].
exists (ex_maxn F1 F3).
case: ex_maxnP => i /hasP[x xIa] Hx Fx.
have : ~~ P i.+1 by apply/negP=> /Fx; rewrite ltnn.
move/hasPn => FF.
have F4 : x = alpha i.
  by apply/eqP; case: eqP=> // /eqP /(in_alphal xIa) /FF/negP[].
case: (isAB_alpha i) => [] [m1 n1 F5].
have Cabe m2 n2 : coprime (a ^ m2) (b ^ n2).
  case: m2 => [|m2]; first by rewrite coprime1n.
  case: n2 => [|n2]; first by rewrite coprimen1.
  by rewrite coprime_pexpl // coprime_pexpr.
move: Hx.
rewrite F4 F5 Gauss_dvd //=.
rewrite Gauss_dvdl // Gauss_dvdr 1?coprime_sym // .
rewrite !dvdn_Pexp2l //.
rewrite leq_eqVlt => /andP[/orP[/eqP mEm1|H1 H2]]; last first.
  case/negP: (FF _ (a_in_alphalS _)).
  rewrite F5 /= mulnA -expnS.
  by apply: dvdn_mul; apply: dvdn_exp2l.
rewrite leq_eqVlt => /orP[/eqP nEn1 //|H1]; first by rewrite mEm1 nEn1.
case/negP: (FF _ (b_in_alphalS _)).
rewrite mulnC F5 mEm1 /= -mulnA -expnSr.
by apply: dvdn_mul; apply: dvdn_exp2l.
Qed.

Lemma isAB_leq_alphaSn i v : isAB v -> alpha i < v -> alpha i.+1 <= v.
Proof.
case=> [] [m1 m2 ->].
case: (alpha_surjective m1 m2) => j <- iLj.
case: (leqP i.+1 j) => [|H].
  by rewrite leq_eqVlt => /orP[/eqP->//|/alpha_mono/ltnW].
move: H iLj; rewrite [alpha _ < _]ltnNge.
rewrite ltnS leq_eqVlt => /orP[/eqP->//|/alpha_mono/ltnW->//].
by rewrite leqnn.
Qed.

Lemma alpha_leq_double i : alpha i.+1 <= a * alpha i.
Proof.
apply: isAB_leq_alphaSn; first by apply/isAB_amul/isAB_alpha.
by rewrite -[X in X < _]mul1n ltn_mul2r alpha_gt0.
Qed.

Lemma isAB_geq_alphaSn i v : isAB v -> v < alpha i.+1 -> v <= alpha i.
Proof.
move => isAB; have := @isAB_leq_alphaSn i _ isAB.
by do 2 case: leqP => // _.
Qed.

Lemma sum_alpha_leq n i :
  i <= n ->
 \sum_(j < n) alpha j <= (a * \sum_(j < (n - i)) alpha j) + \sum_(j < i) b ^ j.
Proof.
move=> iLn.
rewrite -!(big_mkord xpredT) big_distrr /=.
suff aux : forall u v w n n0 n1 : nat,
           u = v + w ->
          (v != 0) * alpha n <= a * alpha n0 ->
          (w != 0) * alpha n <= b ^ n1 ->
          \sum_(n <= i0 < n + u) alpha i0 <=
          \sum_(n0 <= i < n0 + v) a * alpha i +
          \sum_(n1 <= i0 < n1 + w) b ^ i0.
  rewrite -{1}[n]add0n -{1}[n - i]add0n -{2}[i]add0n.
  apply: aux => //.
  - by rewrite subnK.
  - by rewrite !muln1; apply: leq_trans aL1; case: eqP.
  by rewrite muln1; case: eqP.
elim => {i iLn}[[] [] // i j k _ _|
                     u IH [|v] [|w] // i j k uvw aM1 aM2].
- by rewrite !addn0 big_geq.
- rewrite big_ltn; last by rewrite addnS leq_addr.
  rewrite [X in _ <= _ + X]big_ltn; last by rewrite addnS leq_addr.
  rewrite addnCA.
  apply: leq_add; first by rewrite mul1n in aM2.
  rewrite -!addSnnS.
  apply: IH => //; first by case: uvw.
  case: (w) => // w1 //.
  rewrite !mul1n in aM2 |- *.
  suff /leq_trans-> : alpha i.+1 <= a * alpha i => //.
    by rewrite expnS; apply: leq_mul => //; apply: ltnW.
  by apply: alpha_leq_double.
- rewrite big_ltn; last by rewrite addnS leq_addr.
  rewrite [X in _ <= X + _]big_ltn; last by rewrite addnS leq_addr.
  rewrite -addnA.
  apply: leq_add; first by rewrite mul1n in aM1.
  rewrite -!addSnnS.
  apply: IH => //; first by case: uvw.
  case: (v) => // v1 //.
  rewrite !mul1n in aM1 |- *.
  apply: isAB_leq_alphaSn; first by apply/isAB_amul/isAB_alpha.
  apply: leq_ltn_trans aM1 _.
  by rewrite ltn_mul2l ltnW // alpha_ltn.
have aM3 : alpha i.+1 <= a * alpha j.+1.
  rewrite !mul1n in aM1.
  apply: isAB_leq_alphaSn; first by apply/isAB_amul/isAB_alpha.
  apply: leq_ltn_trans aM1 _.
  by rewrite ltn_mul2l ltnW // alpha_ltn.
case: (leqP (a * alpha j) (b ^ k)) => [|bLaa].
- rewrite leq_eqVlt => /orP[/eqP aaEb |aaLb].
  have : a %| b ^ k by rewrite -aaEb dvdn_mulr.
  move/gcdn_idPl.
  have /eqP-> := coprimeXr k aCb.
  by case: a aL1 => // [] [].
- rewrite big_ltn; last by rewrite addnS leq_addr.
  rewrite [X in _ <= X + _]big_ltn; last by rewrite addnS leq_addr.
  rewrite -addnA.
  apply: leq_add; first by rewrite mul1n in aM1.
  rewrite -2!addSnnS.
  apply: IH => //; first by case: uvw.
    case: (v) => // v1 //.
    by rewrite !mul1n.
  rewrite !mul1n in aM1, aM2 |- *.
  apply: isAB_leq_alphaSn (isAB_bexp _) _.
  by apply: leq_ltn_trans aaLb.
rewrite big_ltn; last by rewrite addnS leq_addr.
rewrite [X in _ <= _ + X]big_ltn; last by rewrite addnS leq_addr.
rewrite addnCA.
apply: leq_add; first by rewrite mul1n in aM2.
rewrite -addSnnS -(addSnnS k).
apply: IH => //; first by move: uvw; rewrite addnS => [[]].
  rewrite !mul1n in aM1, aM2 |- *.
  apply: isAB_leq_alphaSn.
    by apply: isAB_amul; apply: isAB_alpha.
  by apply: leq_ltn_trans bLaa.
case: (w) => // w1.
rewrite !mul1n in aM1, aM2 |- *.
apply: isAB_leq_alphaSn (isAB_bexp _) _.
apply: leq_ltn_trans aM2 _.
by rewrite ltn_exp2l.
Qed.

Lemma alpha0 : alpha 0 = 1.
Proof. by []. Qed.

Lemma alpha1 : alpha 1 = a.
Proof.
by rewrite /alpha /= !ifT //= muln1 !inE eqxx ?orbT.
Qed.

Lemma b_exp_leq k n : b ^ k <= alpha n -> k <= n.
Proof.
elim: n k => [k|n IH [|k Hk]//].
  by rewrite -[alpha 0]/(b ^ 0) leq_exp2l.
apply/IH/(isAB_geq_alphaSn (isAB_bexp _)).
by apply: leq_trans Hk; rewrite ltn_exp2l.
Qed.

Lemma alpha_exp_bound n : alpha n < b ^ n.+1.
Proof. by rewrite ltnNge; apply/negP => /b_exp_leq; rewrite ltnn. Qed.

Lemma b_exp_ltn k n : b ^ k < alpha n -> k < n.
Proof.
case: n => [|n H]; first by rewrite ltnNge expn_gt0 (leq_trans _ bL1).
by rewrite ltnS; apply/b_exp_leq/(isAB_geq_alphaSn (isAB_bexp _)).
Qed.

Lemma alpha_b_eq n i :
   b ^ i < alpha n.+1 < b ^ i.+1 -> alpha n.+1 = a * alpha (n - i).
Proof.
move=> /andP[beLa aLbe].
have iLm : i <= n.
  apply/b_exp_leq/isAB_geq_alphaSn => //.
  by exists (0, i); rewrite mul1n.
have [[[|x] y] Hxy] : isAB (alpha n.+1) by apply: isAB_alpha.
  move: beLa aLbe; rewrite Hxy.
  rewrite mul1n !(ltn_exp2l _ _ bL1) ltnS.
  by case: leqP.
case: (alpha_surjective x y) => k Hk.
pose la := [seq alpha (j : 'I_n.+2) | j <- enum 'I_n.+2].
pose lb := [seq b ^ (j : 'I_ i.+1) | j <- enum 'I_i.+1].
pose lc := [seq a * alpha (j : 'I_(n - i)) | j <- enum 'I_(n- i)].
have Ula : uniq la.
  rewrite map_inj_uniq; first by apply: enum_uniq.
  move=> k1 k2 H.
  case: (leqP k1 k2)=> [|/alpha_mono]; last by rewrite H ltnn.
  by rewrite leq_eqVlt => /orP[/val_eqP//|/alpha_mono]; rewrite H ltnn.
have Sla : size la = n.+2 by rewrite size_map size_enum_ord.
pose la1:= [seq x <- la | a %| x].
pose la2 := [seq x <- la | ~~ (a %| x)].
pose lk := [seq a * alpha (j : 'I_k.+1) | j <- enum 'I_k.+1].
have Slk : size lk = k.+1 by rewrite size_map size_enum_ord.
have lkEla1 : lk =i la1.
  move=> u; rewrite mem_filter.
  apply/mapP/idP.
    case => z Hz ->; rewrite dvdn_mulr //=.
    have [[x1 y1] Hx1y1] : isAB (alpha z) by apply: isAB_alpha.
    case: (alpha_surjective x1.+1 y1) => t Ht.
    suff H1t : t < n.+2.
      apply/mapP; exists (Ordinal H1t); first by rewrite mem_enum.
      by rewrite Ht expnS -mulnA -Hx1y1.
    case: leqP => // /alpha_mono.
    rewrite ltnNge Hxy Ht /= !expnS -!mulnA -Hx1y1 -Hk.
    rewrite  (leq_pmul2l (ltnW aL1)).
    have : z < k.+1 by [].
    by rewrite ltnS leq_eqVlt => /orP[/eqP->|/alpha_mono/ltnW->]; rewrite // leqnn.
  rewrite andbC => /andP[/mapP[v Hv ->] Ha].
  have [[[|x1] y1] Hx1y1] : isAB (alpha v) by apply: isAB_alpha.
    move: Ha; rewrite Hx1y1 mul1n /= => /gcdn_idPl.
    have /eqP-> : coprime a (b ^ y1) by rewrite coprimeXr.
    by move=> H; move: aL1; rewrite H ltnn.
  case: (alpha_surjective x1 y1) => j1 Hj1.
  suff H1j1 : j1 < k.+1.
    exists (Ordinal H1j1); first by rewrite mem_enum.
    by rewrite Hx1y1 expnS -mulnA Hj1.
  case: leqP => // /alpha_mono.
  rewrite  -(ltn_pmul2l (ltnW aL1)) Hk Hj1 !mulnA -!expnS -Hxy -Hx1y1.
  rewrite ltnNge isAB_geq_alphaSn //; first by apply: isAB_alpha.
  by apply: alpha_mono.
have lbEla2 : lb =i la2.
  move=> u; apply/idP/idP; last first.
    rewrite mem_filter andbC => /andP[/mapP[v Hx ->]].
    have /alpha_mono : v < n.+2 by [].
      case: (isAB_alpha v) => [] [[|u1] v1]->/=; last first.
      by rewrite expnS -mulnA dvdn_mulr.
    rewrite mul1n => H _.
    have /(ltn_pexp2l (ltnW bL1)) v1Li : b ^ v1 < b ^ i.+1.
      apply: leq_ltn_trans aLbe.
      by apply: isAB_geq_alphaSn (isAB_bexp _) _.
    by apply/mapP; exists (Ordinal v1Li); rewrite // mem_enum.
  move=> /mapP[u1 _ ->].
  rewrite mem_filter; apply/andP; split.
    apply/negP=> /gcdn_idPl.
    have /eqP-> : coprime a (b ^ u1) by rewrite coprimeXr.
    by move=> H; move: aL1; rewrite H ltnn.
   case: (alpha_surjective 0 u1) => j1; rewrite mul1n => Hj1.
  suff j1Ln : j1 < n.+2.
    by apply/mapP; exists (Ordinal j1Ln); rewrite ?mem_enum.
  case: leqP => // /alpha_mono; rewrite ltnNge => /negP[].
  apply: leq_trans (ltnW beLa).
  by rewrite Hj1 leq_exp2l // -ltnS.
rewrite Hxy expnS -mulnA -Hk.
congr (_ * alpha _).
rewrite -subSS -subSS -Sla (_ : size la = size la1 + size la2); last first.
  by rewrite !size_filter count_predC.
have : uniq la1.
  apply: filter_uniq.
  rewrite map_inj_uniq; first by apply: enum_uniq.
  move=> k1 k2 H.
  case: (leqP k1 k2)=> [|/alpha_mono]; last by rewrite H ltnn.
  by rewrite leq_eqVlt => /orP[/val_eqP//|/alpha_mono]; rewrite H ltnn.
rewrite (uniq_size_uniq _ lkEla1) => [/eqP->|]; last first.
  rewrite map_inj_uniq; first by apply: enum_uniq.
  move=> k1 k2 H.
  case: (leqP k1 k2)=> [|/alpha_mono]; last first.
    by rewrite -(ltn_pmul2l (ltnW aL1)) H ltnn.
  rewrite leq_eqVlt => /orP[/val_eqP//|/alpha_mono].
  by rewrite -(ltn_pmul2l (ltnW aL1)) H ltnn.
rewrite Slk.
have : uniq la2.
  apply: filter_uniq.
  rewrite map_inj_uniq; first by apply: enum_uniq.
  move=> k1 k2 H.
  case: (leqP k1 k2)=> [|/alpha_mono]; last by rewrite H ltnn.
  by rewrite leq_eqVlt => /orP[/val_eqP//|/alpha_mono]; rewrite H ltnn.
rewrite (uniq_size_uniq _ lbEla2) => [/eqP->|]; last first.
  rewrite map_inj_uniq; first by apply: enum_uniq.
  by move=> k1 k2 /eqP; rewrite eqn_exp2l => // /val_eqP.
rewrite size_map size_enum_ord.
by rewrite subSS addnK.
Qed.

Lemma sum_alpha_eq n i :
 b ^ i <= alpha n < b ^ i.+1 ->
 \sum_(i0 < n.+1) alpha i0 =
  (a * \sum_(i0 < (n - i)) alpha i0) + \sum_(i0 < i.+1) b ^ i0.
Proof.
elim: n i => [i|n IH i].
  case: i => [_|i]; last by rewrite leqNgt alpha0 (ltn_exp2l 0).
  by rewrite !big_ord_recr !big_ord0 muln0.
rewrite leq_eqVlt => /andP[/orP[/eqP Ha Hb| Ha Hb]].
  case: i Ha Hb => [H|i Ha Hb].
    have : alpha 0 < alpha n.+1 by apply: alpha_mono.
    by rewrite [alpha 0]H ltnn.
  rewrite big_ord_recr [X in _ = _ + X]big_ord_recr /= Ha.
  rewrite addnA; congr (_ + _).
  rewrite subSS.
  apply: IH => //.
  rewrite Ha alpha_ltn andbT.
  apply: isAB_geq_alphaSn (isAB_bexp _) _.
  by rewrite -Ha ltn_exp2l.
rewrite subSn; last exact: b_exp_ltn Ha.
rewrite big_ord_recr [X in _ = _  * X + _]big_ord_recr.
rewrite mulnDr addnAC.
congr (_ + _); last first.
  by apply: alpha_b_eq; rewrite ?Ha.
apply: IH.
rewrite (isAB_geq_alphaSn (isAB_bexp _)) //.
apply: leq_trans Hb.
by rewrite ltnS ltnW // alpha_ltn.
Qed.

End Main.

Section S23.

Local Notation α := (alpha 2 3).

(* First 60 element of the list *)
Compute map α (iota 0 60).

Definition dsum_alpha n := \sum_(i < n) α i.

Local Notation S1 := dsum_alpha.

Lemma dsum_alpha_0 : S1 0 = 0.
Proof. by rewrite /S1 big_ord0 // =>  [] []. Qed.

Lemma dsum_alpha_1 : S1 1 = 1.
Proof. by rewrite /S1 big_ord_recr /= big_ord0. Qed.

Lemma div2K n : ~~ odd n -> n./2.*2 = n.
Proof. by move=> nO; rewrite -{2}(odd_double_half n) (negPf nO). Qed.

Lemma S1_leq n i : i <= n -> S1 n <= (S1 (n - i)).*2 + (3 ^ i).-1./2.
Proof.
move=> iLn.
rewrite -leq_double doubleD div2K; last first.
  by rewrite -subn1 oddB ?expn_gt0 //= oddX orbT.
rewrite -!mul2n predn_exp.
rewrite -mulnDr leq_mul2l /=.
by apply: sum_alpha_leq.
Qed.

Lemma log3_proof n : exists i, n  < 3 ^ i.
Proof. by exists n; apply: ltn_expl. Qed.

Definition log3 k := (ex_minn (log3_proof k)).-1.

Lemma log30 : log3 0 = 0.
Proof.
by rewrite /log3; case: ex_minnP => [] [|m] //= _ /(_ 0 isT); case: m.
Qed.

Lemma log31 : log3 1 = 0.
Proof.
by rewrite /log3; case: ex_minnP => [] [|m] //= _  /(_ 1 isT); case: m.
Qed.

Lemma gtn_log3 n : n < 3 ^ (log3 n).+1.
Proof.
rewrite /log3; case: ex_minnP => [] [|m] //= nLm H.
by apply: leq_trans nLm _.
Qed.

Lemma leq_log3 n : 0 < n -> 3 ^ (log3 n) <= n.
Proof.
rewrite /log3; case: ex_minnP => [] [|m] //= nLm H nL.
by rewrite leqNgt; apply/negP => /H; rewrite ltnn.
Qed.

Lemma leq_log3_alpha n : log3 (α n) < n.+1.
Proof.
rewrite -(ltn_exp2l _ _ (_ : 1 < 3)) //.
apply: leq_ltn_trans (leq_log3 _) _; first by apply: alpha_gt0.
by apply: alpha_exp_bound.
Qed.

Lemma S1_eq n : 0 < n ->
  S1 n = (S1 (n - (log3 (α n.-1)).+1)).*2 + (3 ^ (log3 (α n.-1)).+1).-1./2.
Proof.
case: n => // n _.
apply: double_inj.
rewrite doubleD div2K; last first.
  by rewrite -subn1 oddB ?expn_gt0 //= oddX orbT.
rewrite -!mul2n predn_exp -mulnDr; congr (2 * _).
have iLn : 3 ^ (log3 (α n)) <= α n < 3 ^ (log3 (α n)).+1.
  rewrite gtn_log3  leq_log3 //.
  by apply: alpha_gt0.
by apply: sum_alpha_eq.
Qed.

Lemma S1_bigmin n :
  S1 n.+1 = \min_(i <= n) ((S1 i).*2 + (3 ^ (n.+1 - i)).-1./2).
Proof.
apply/eqP; rewrite eqn_leq; apply/andP; split; last first.
  rewrite S1_eq // -{2}(subKn (leq_log3_alpha n)).
  apply: bigmin_inf (leqnn _) => //.
  by rewrite leq_subLR addSnnS leq_addl.
apply/bigmin_leqP => i iLn.
rewrite -{1}(subKn (_ : i <= n.+1)); last by apply: ltnW.
by apply/S1_leq/leq_subr.
Qed.

Lemma delta_S1 n : delta S1 n = α n.
Proof. by rewrite /S1 /delta big_ord_recr /= addnC addnK. Qed.

Definition dsum_alphaL l :=
 conv (fun i => (S1 i).*2) (fun i => l * (3 ^ i).-1./2).

Notation " 'S_[' l ']' " := (dsum_alphaL l)
 (format "S_[ l ]").

Definition alphaL l n := delta S_[l] n.

Notation " 'α_[' l ']' " := (alphaL l)
 (format "α_[ l ]").

Lemma leq_bigmin f g n :
 (forall i, i <= n -> f i <= g i) ->
 \min_(i <= n) f i <= \min_(i <= n) g i.
Proof.
elim: n => /= [->//|n IH H].
rewrite leq_min !geq_min H //= orbC IH // => i iLn.
by rewrite H // (leq_trans iLn).
Qed.

Lemma increasing_dsum_alphaL_l n : increasing (fun l => S_[l] n).
Proof.
move=> l; rewrite /increasing /dsum_alphaL /conv.
apply: leq_bigmin => i _.
by rewrite leq_add2l leq_mul2r leqnSn orbT.
Qed.

Lemma concave_dsum_alphaL_l n : concave (fun l => S_[l] n).
Proof.
apply: concaveE (increasing_dsum_alphaL_l _) _ => i.
rewrite {3}/dsum_alphaL /conv.
pose f i x := (S1 x).*2 + i * ((3 ^ (n - x)).-1)./2.
case: (eq_bigmin (f i.+1) n) => j ->.
have -> : (f i.+1 j).*2 = f i j + f (i.+2) j.
  rewrite /f; set x := (S1 _).*2; set y := _./2.
  rewrite addnCA 2![in RHS]addnA addnn -[in RHS]addnA -mulnDl.
  by rewrite -addSnnS addnn -doubleMl -doubleD.
apply: leq_add.
  by apply: bigmin_inf (leqnn _); rewrite -ltnS.
by apply: bigmin_inf (leqnn _); rewrite -ltnS.
Qed.

Lemma lim_dsum_alphaL_l l n : (S1 n).*2 <= l -> S_[l] n = (S1 n).*2.
Proof.
move=> S1Ll; apply/eqP.
rewrite /dsum_alphaL /conv eqn_leq; apply/andP; split.
  apply: bigmin_inf (_ : _ n <= _) => //.
  by rewrite subnn muln0 addn0.
apply/bigmin_leqP => i.
case: ltngtP => // [iLn _|-> _]; last apply: leq_addr.
apply: leq_trans S1Ll _.
apply: leq_trans (leq_addl _ _).
rewrite -{1}[l]muln1 leq_mul2l (half_leq (_ : 2 <= _)) ?orbT //.
by rewrite -ltnS prednK ?expn_gt0 // (@leq_exp2l _ 1) // subn_gt0.
Qed.

Lemma delta_2S1 i : delta (fun i : nat => (S1 i).*2) i = (α i).*2.
Proof. by rewrite /delta -doubleB [_ - _]delta_S1. Qed.

Lemma convex_2S1 : convex (fun i : nat => (S1 i).*2).
Proof.
split => [] i.
  by rewrite leq_double /dsum_alpha [X in _ <= X]big_ord_recr leq_addr.
by rewrite !delta_2S1 leq_double; apply/ltnW/alpha_ltn.
Qed.

Lemma delta_3l l i : delta (fun i : nat => l * ((3 ^ i).-1)./2) i = l * 3 ^ i.
Proof.
rewrite /delta -mulnBr -even_halfB //;
  try by rewrite -subn1 oddB ?expn_gt0 //= oddX orbT.
rewrite -predn_sub -subnS prednK ?expn_gt0 //.
by rewrite expnS -[X in _ * ((_ - X))./2]mul1n -mulnBl mul2n doubleK.
Qed.

Lemma convex_3l l : convex (fun i : nat => l * ((3 ^ i).-1)./2).
Proof.
split => [] i.
  rewrite leq_mul2l half_leq ?orbT //.
  by apply: leq_pred2; rewrite leq_exp2l.
by rewrite !delta_3l leq_mul2l leq_exp2l // leqnSn orbT.
Qed.

Lemma convex_dsum_alphaL l : convex (S_[l]).
Proof.
apply: convex_conv; first by apply: convex_2S1.
by apply: convex_3l.
Qed.

Lemma alphaLE l n :
  α_[l] n = fmerge (fun i : nat => (α i).*2) (fun i : nat => l * 3 ^ i) n.
Proof.
rewrite [LHS]delta_conv; last by apply: convex_3l.
  apply: fmerge_ext => i; first by rewrite delta_2S1.
  by rewrite delta_3l.
by apply: convex_2S1.
Qed.

Lemma increasing_alphaL l : increasing α_[l].
Proof.
apply: increasing_ext; first by move=> i; apply/sym_equal/alphaLE.
apply: increasing_fmerge.
  by move=> n; rewrite leq_double; apply/ltnW/alpha_mono.
by move=> n; rewrite leq_mul2l leq_exp2l ?leqnSn ?orbT.
Qed.

Lemma increasing_alphaL_l n : increasing (fun l => α_[l] n).
Proof.
move=> l; rewrite !alphaLE !fmergeE //; last 4 first.
- by move=> k; rewrite leq_double; apply/ltnW/alpha_mono.
- by move=> k; rewrite leq_mul2l leq_exp2l ?leqnSn ?orbT.
- by move=> k; rewrite leq_double; apply/ltnW/alpha_mono.
- by move=> k; rewrite leq_mul2l leq_exp2l ?leqnSn ?orbT.
apply/bigmax_leqP => i _.
apply: leq_trans (_ : minn (α i).*2 (l.+1 * 3 ^ (n - i)) <= _).
  by rewrite leq_min !geq_min leqnn /= leq_mul2r leqnSn !orbT.
by apply: leq_bigmax.
Qed.

Lemma submodular_dsum_alphaL l n :
  S_[l] n.+1 + S_[l.+1] n <= S_[l] n + S_[l.+1] n.+1.
Proof.
rewrite -leq_subLR -addnBAC; last first.
  by have [daI _] := convex_dsum_alphaL l.
rewrite -[_ - _]/(α_[l] _) addnC -leq_subRL; last first.
  by have [daI _] := convex_dsum_alphaL l.+1.
 rewrite -[_ - _]/(α_[l.+1] _).
by apply: increasing_alphaL_l.
Qed.

Lemma alphaL_0 l : α_[l] 0 = minn 2 l.
Proof.
rewrite /alphaL /delta /dsum_alphaL /conv /= dsum_alpha_1 dsum_alpha_0.
by rewrite muln0 addn0 add0n subn0 muln1.
Qed.

Lemma S0E n : S_[0] n = 0.
Proof.
rewrite /dsum_alphaL /conv.
elim: n => /= [|n ->]; first by rewrite dsum_alpha_0.
by rewrite minn0.
Qed.

Lemma S1E : S_[1] =1 S1.
Proof.
case => [|i].
  by rewrite /dsum_alphaL /conv /= dsum_alpha_0.
rewrite S1_bigmin /dsum_alphaL /conv /= subnn addn0 -S1_bigmin.
rewrite (_ : \min_(_ <= _) _ = S1 i.+1).
  by rewrite (minn_idPr _) // -addnn leq_addr.
by rewrite S1_bigmin; apply: bigmin_ext => i1 i1H; rewrite mul1n.
Qed.

Lemma bound_dsum_alphaL l n : S_[l] n <= (S_[1] n).*2.
Proof.
rewrite S1E.
have [SLl|lLS] := leqP (S1 n).*2 l; first by rewrite lim_dsum_alphaL_l.
rewrite -(lim_dsum_alphaL_l (leqnn _)).
have [/increasingE H _] := concave_dsum_alphaL_l n.
by apply/H/ltnW.
Qed.

Lemma alphaL1E k : α_[1] k = α k.
Proof. by rewrite /alphaL /delta !S1E -delta_S1. Qed.

Lemma bound_alphaL l n : α_[l] n <= (α_[1] n).*2.
Proof.
rewrite alphaL1E.
have [SLl|lLS] := leqP (S1 n.+1).*2 l.
 rewrite /alphaL /delta !lim_dsum_alphaL_l //.
   by rewrite -delta_S1 doubleB.
 by apply: leq_trans SLl; case: convex_2S1.
rewrite -delta_S1 /delta doubleB.
rewrite -(lim_dsum_alphaL_l (leqnn _)).
rewrite -[(S1 n).*2](@lim_dsum_alphaL_l (S1 n.+1).*2).
  rewrite -[_ - _]/(α_[_] _).
  by apply: increasingE (increasing_alphaL_l n) _; apply: ltnW.
by case: convex_2S1.
Qed.

Lemma iotaS m n : iota m n.+1 = m :: iota m.+1 n.
Proof. by []. Qed.

Lemma count_cons (T : Type) a b (l : seq T) : count a (b :: l) = a b + count a l.
Proof. by []. Qed.

Lemma increasing_alpha : increasing α.
Proof. by move=> n; apply/ltnW/alpha_mono. Qed.

(* THis is 3.3 *)
Lemma alpha_min_exp3 m k : α m + minn (3 ^ k) (α m) <= α (m + k.+1).
Proof.
case: (leqP (α m).*2 (α (m + k.+1))) => [/(leq_trans _)-> //|amkLam].
  by rewrite -addnn leq_add2l geq_minr.
apply: leq_trans (leq_add (leqnn _) (geq_minl _ _)) _.
move: m amkLam => n; rewrite [_ + 3 ^ _]addnC.
set m := n + k.+1.
have : k + n < m by rewrite /m addnS addnC.
move: m => m.
elim: k m n => [m n | k IH m n nkLm aL2a].
  by rewrite add0n add1n => nLm _; apply: alpha_mono.
pose l := [seq (α i) | i <- iota n (m - n).+1 & 3 %| (α i)].
have Il i : i \in l -> exists j, i = 3 * α j.
  case/mapP => j; rewrite mem_filter => /andP[ajD3 _] ->.
  have [[i1 [|j1]] /= ajE]: isAB 2 3 (α j) by apply: isAB_alpha.
    by move: ajD3; rewrite ajE muln1 Euclid_dvdX //.
  have [k1 ak1E] : {k : nat | α k = 2 ^ i1 * 3 ^ j1} by apply: alpha_surjective.
  by exists k1; rewrite ak1E ajE expnS mulnCA.
have nLm : n <= m by rewrite (leq_trans _ nkLm) // -addSn leq_addl.
have iS : k.+3 <= size (iota n (m - n).+1).
  by rewrite size_iota ltnS leq_subRL // addnC addSn.
have kLsl : k.+2 <= size l.
  rewrite size_map size_filter -ltnS -[X in _ < X]add1n.
  move: iS; rewrite -(count_predC (fun i => 3 %| (α i))) -/l => iS.
  apply: leq_trans iS _; rewrite addnC leq_add2r.
  move: aL2a; rewrite -{1}(subnK nLm) addnC.
  move: (m - n) => u.
  elim: u {k IH Il l nLm nkLm}n => [n _ /=|k IH n H]; first by case: negb.
  have /IH : α (n.+1 + k) < (α n.+1).*2.
    by rewrite addSnnS (leq_trans H) // leq_double ltnW // alpha_mono.
  rewrite (iotaS _ _.+1) count_cons.
  case: ltngtP => // [|H1 _].
    by case: count => //=; case: (~~ _).
  have /hasP[i iH1 iH2] : has (predC (fun i => 3 %| α i)) (iota n.+1 k.+1).
    by rewrite has_count H1.
  move: iH1; rewrite mem_iota => /andP[nLi iLn].
  rewrite H1; case: (boolP (predC _ _)) => //= iH3.
  have [[i1 [|j1]] /= aiE] : isAB 2 3 (α i) by apply: isAB_alpha.
    have [[i2 [|j2]] /= anE] : isAB 2 3 (α n) by apply: isAB_alpha.
      rewrite !muln1 in aiE anE.
      have : α n < α i by apply: alpha_mono.
      rewrite aiE anE ltn_exp2l // => i2Li1.
      have : (α i) < (α n).*2.
        apply: leq_trans H; rewrite ltnS -addSnnS //.
        move: iLn;rewrite addnS ltnS; case: ltngtP => // [iLS _|<-//].
        by apply/ltnW/alpha_mono.
      by rewrite aiE anE -mul2n -expnS ltn_exp2l // ltnS leqNgt i2Li1.
    by case/negP : iH3; rewrite anE expnS mulnCA dvdn_mulr.
  by case/negP : iH2; rewrite aiE expnS mulnCA dvdn_mulr.
pose n1 := head 0 l.
pose m1 := last 0 l.
have lS : sorted ltn l.
  rewrite sorted_map.
  apply: sorted_filter.
    by move=> a b c H1 H2; apply: ltn_trans H2.
  move: (_ - _).+1 => u; elim: u (n) => //= k1 IH1 n0.
  by case: (k1) (IH1 n0.+1) => //= k2 -; rewrite alpha_mono.
have uS : uniq l by move: lS; rewrite ltn_sorted_uniq_leq; case/andP.
have n1Il : n1 \in l.
  by rewrite /n1; case: (l) kLsl => [|a l1]; rewrite /= ?inE ?eqxx.
case: (Il _ n1Il) => n2 n2E.
have m1Il : m1 \in l.
  by rewrite /m1; case: (l) kLsl => [|a l1]; rewrite //= mem_last.
case: (Il _ m1Il) => m2 m2E.
have n1Lm1 : n1 < m1.
  rewrite /n1 /m1; case: (l) kLsl lS => [|a [|b l1 _]] //= /andP[].
  elim: l1 a b => //= c l1 IH1 a b aLb /andP[bLc pH].
  by apply: ltn_trans aLb (IH1 _ _ _ _).
have n2Lm2 : n2 < m2.
  move: n1Lm1; rewrite n2E m2E ltn_mul2l /=.
  case: (ltngtP n2 m2) => // [m2Ln2|->]; last by rewrite ltnn.
  by rewrite ltnNge ltnW // alpha_mono.
pose l1 := [seq 3 * α i | i <- iota n2 (m2 - n2).+1].
have l1size : size l1 = (m2 - n2).+1 by rewrite size_map size_iota.
have H : {subset l <= l1}.
  move=> i iIl; case: (Il _ iIl) => j jE.
  apply/mapP; exists j; rewrite // mem_iota addnS addnC subnK //; last first.
    by rewrite ltnW.
  rewrite ltnS; apply/andP; split.
    have: n1 <= i.
      rewrite /n1; case: (l) kLsl iIl lS => //= a l2 _.
      rewrite inE => /orP[/eqP->//|].
      elim: l2 a => //= b l2 IH1 a.
      rewrite inE => /orP[/eqP->//|bIl2] /andP[aLb pH]; first by apply: ltnW.
      apply: leq_trans (ltnW aLb) _.
      by apply: IH1.
    rewrite n2E jE leq_mul2l /=; case: (ltngtP n2 j) => // jLn2.
    by rewrite leqNgt alpha_mono.
  have: i <= m1.
    rewrite /m1; case: (l) kLsl iIl lS => //= a l2 _.
    elim: l2 a (i) => /= [a i1|b l2 IH1 a i1]; first by rewrite inE => /eqP->.
    rewrite inE => /orP[/eqP->//|bIl2] /andP[aLb pH].
      apply: leq_trans (ltnW aLb) (IH1 _ _ _ _) => //.
      by rewrite inE eqxx.
    by apply: IH1.
  rewrite m2E jE leq_mul2l /=; case: (ltngtP m2 j) => // jLn2.
  by rewrite leqNgt alpha_mono.
have kn2Lm2 : k + n2 < m2.
  rewrite -addSn addnC -leq_subRL; last by apply: ltnW.
  by rewrite -ltnS -l1size (leq_trans kLsl) // uniq_leq_size.
have anLan2 : α n <= 3 * α n2.
  rewrite -n2E.
  case/mapP : n1Il => i1.
  rewrite mem_filter mem_iota => /andP[_ /andP[nLi1 _] ->].
  by apply: (increasingE increasing_alpha).
have am2Lam : 3 * α m2 <= α m.
  rewrite -m2E.
  case/mapP : m1Il => i1.
  rewrite mem_filter mem_iota => /andP[_ /andP[_ i1Lm] ->].
  rewrite addnS ltnS addnC subnK // in i1Lm.
  by apply: (increasingE increasing_alpha).
have am2Lan2 : α m2 < (α n2).*2.
  rewrite -[_ < _]andTb -(ltn_mul2l 3) -doubleMr.
  apply: leq_ltn_trans am2Lam _.
  apply: leq_trans aL2a _.
  by rewrite leq_double.
apply: leq_trans am2Lam.
apply: leq_trans (leq_add (leqnn _) anLan2) _.
rewrite expnS -mulnDr leq_mul2l /=.
by apply: IH kn2Lm2 am2Lan2.
Qed.

Lemma alpha_min_exp3_cor m k : 3 ^k <= α m -> α m + 3 ^ k <= α (m + k.+1).
Proof.
move=> kLam.
have := alpha_min_exp3 m k.
by rewrite (minn_idPl _).
Qed.

Lemma eq_dsum_alphaL l n :
  {i : 'I_n.+1 | S_[l] n = (S1 i).*2 + l * ((3 ^ (n - i)).-1)./2}.
Proof. by apply: eq_bigmin. Qed.

Lemma increasing_dsum_alpha : increasing S1.
Proof.
by move=> n; rewrite -leq_double; case: convex_2S1.
Qed.

Lemma even_expn3_pred n : ~~ odd (3 ^ n).-1.
Proof.
by rewrite -subn1 oddB ?expn_gt0 // oddX orbT.
Qed.

(* This is 3.4 *)
Lemma dsum_alphaL_alpha l n : 1 < l -> S_[l.+1] n.+1 <= S_[l] n + (α_[1] n).*2.
Proof.
rewrite alphaL1E => l_gt1.
case: (eq_dsum_alphaL l n) => [] [/= m mLn] mH.
rewrite mH; rewrite ltnS in mLn.
apply: leq_trans (_ : (S1 m.+1).*2 + l.+1 * ((3 ^ (n - m)).-1)./2 <= _).
  by rewrite -subSS; apply: bigmin_inf (leqnn _).
rewrite addnAC mulSn addnA leq_add2r.
rewrite -leq_subLR -addnBAC ?leq_double ?increasing_dsum_alpha //.
rewrite [_ - _]delta_2S1.
case: ltngtP mLn => // [mLn _ |-> _]; last by rewrite subnn addn0.
apply: leq_trans (_ : (α m).*2 + (3 ^ (n - m).-1).*2 <= _).
  rewrite leq_add2l -leq_double.
  apply: leq_trans (_ : (3 ^ (n - m)).-1 <= _).
    by rewrite -[X in _ <= X]odd_double_half leq_addl.
  apply: leq_trans (ssrnat.leq_pred _) _.
  by rewrite -[n -m]prednK ?subn_gt0 // expnSr -!muln2 -mulnA leq_mul.
rewrite -doubleD leq_double.
have := @alpha_min_exp3_cor m (n - m).-1.
rewrite prednK ?subn_gt0 // [_ + (_ - _)]addnC subnK; last by apply: ltnW.
apply.
have : S_[l] n <= (S1 m.+1).*2 + l * (3 ^ (n - m.+1)).-1./2.
  by apply: bigmin_inf mLn (leqnn _).
rewrite mH (_ : S1 m.+1 = S1 m + α m); last first.
  by rewrite addnC -delta_S1 subnK // increasing_dsum_alpha.
rewrite doubleD -!addnA leq_add2l.
rewrite addnC -leq_subLR -mulnBr -[_ <= α m]leq_double.
rewrite -even_halfB ?even_expn3_pred //.
have ->: (3 ^ (n - m)).-1 - (3 ^ (n - m.+1)).-1 = (3 ^ (n - m).-1).*2.
  rewrite subnS -{1}predn_sub -subnS prednK ?expn_gt0 //.
  rewrite -{1}[(n - m)]prednK ?subn_gt0 // expnS.
  by rewrite -mul2n -{4}[2]/(3 - 1) mulnBl mul1n.
by move=> /(leq_trans _)-> //; rewrite doubleK -mul2n leq_mul2r l_gt1 orbT.
Qed.

Lemma dsum_alphal_min_3  l n :
  S_[l] n.+1 = minn (S1 n.+1).*2 (S_[3 * l] n + l).
Proof.
rewrite {1}/dsum_alphaL /conv /= subnn muln0 addn0.
congr (minn _ _).
rewrite /dsum_alphaL /conv -bigmin_constD.
apply: bigmin_ext => i iH; rewrite -addnA; congr (_ + _).
rewrite -mulnAC -{3}[l]mul1n -mulnDl mulnC; congr (_ * _).
rewrite -even_halfMl ?even_expn3_pred // -{4}[1]/(2./2).
rewrite -even_halfD ?oddM ?even_expn3_pred //; congr (_./2).
rewrite subSn // expnS -!subn1 mulnBr muln1 addn2 -!subSn ?subSS //.
  by rewrite ltnS -expnS (ltn_exp2l 0).
by rewrite -expnS (leq_exp2l 1).
Qed.

(* This is first part of 3.5 *)
Lemma dsum_alpha3_S n : S_[1] n.+1 = (S_[3] n).+1.
Proof.
rewrite S1E.
have := dsum_alphal_min_3 1 n.
rewrite S1E addn1 /minn; case: leqP => // _ /eqP.
rewrite -addnn -{1}[S1 _]add0n eqn_add2r.
suff : 0 < S1 n.+1 by case: S1.
rewrite -dsum_alpha_1 increasingE //.
by apply: increasing_dsum_alpha.
Qed.

Lemma alphaL_3E n : α_[3] n = α_[1] n.+1.
Proof.
by rewrite /alphaL /delta -subSS -!dsum_alpha3_S.
Qed.

(* This is second part of 3.5 *)
Lemma dsum_alpha3l l n : S_[l] n.+1 <= S_[3 * l] n + l.
Proof.
rewrite dsum_alphal_min_3.
by apply: geq_minr.
Qed.

Lemma leq_dsum_alpha_2l_l l n : S_[l] n + S_[l] n.+1 <= (S_[l.*2] n).*2 + l.
Proof.
have H := concaveEk (concave_dsum_alphaL_l n) (leq_addr l l).
rewrite addnK addnn -{1}mul2n -{3}[l]mul1n -mulnDl in H.
apply: leq_trans (leq_add H (leqnn _)).
by rewrite -addnA leq_add2l dsum_alpha3l.
Qed.

Lemma leq_dsum_alpha_2l_1 n : S_[1] n + S_[1] n.+1 <= (S_[2] n).*2.+1.
Proof. by have := leq_dsum_alpha_2l_l 1 n; rewrite addn1. Qed.

(* This is 3.7 *)
Lemma alpha_4_3 n : 3 < n -> 3 * α_[1] n.+1 <= 4 * α_[1] n.
Proof.
rewrite !alphaL1E.
move=> n_gt_3.
have an_gt_5 : 5 < α n by apply: increasingE (increasing_alpha) n_gt_3.
have [[i [|j]] /= anE] : isAB 2 3 (α n) by apply: isAB_alpha.
  rewrite muln1 in anE.
  case: i anE an_gt_5 => [|[|[|i anE an_gt_5]]]; try by move=> ->.
  suff H1 : 8 * α n.+1 <= 9 * α n.
    rewrite -3!leq_double -!mul2n !mulnA -[_ * 3]/(3 * 8).
    apply: leq_trans (_ : (3 * 9) * α n <= _).
      by rewrite -!mulnA leq_mul2l //.
    by rewrite leq_mul2r orbT.
  pose m := 2 ^ i * 3 ^ 2.
  case: (alpha_surjective (isT : 1 < 2) (isT : 2 < 3) (isT : coprime 2 3) i 2)
    => m1 m1H.
  have H2 : α n < α m1.
    by rewrite anE m1H !expnSr -!mulnA ltn_mul2l ?expn_gt0.
  have H3 : α n.+1 <= α m1.
    case: (leqP m1 n) => /(increasingE increasing_alpha) //.
    by rewrite leqNgt H2.
  rewrite anE !expnS [X in _ <= X]mulnC !mulnA -[2 * 2 * 2]/8 -mulnA leq_mul2l.
  by rewrite  -m1H.
pose m := 2 ^ i.+2 * 3 ^ j.
case: (alpha_surjective (isT : 1 < 2) (isT : 2 < 3) (isT : coprime 2 3) i.+2 j)
    => m1 m1H.
have H2 : α n < α m1.
  rewrite anE m1H !expnSr -!mulnA ltn_mul2l ?expn_gt0 //=.
  by rewrite mulnC !mulnA ltn_mul2r ?expn_gt0.
have H3 : α n.+1 <= α m1.
  case: (leqP m1 n) => /(increasingE increasing_alpha) //.
  by rewrite leqNgt H2.
by rewrite anE !expnSr -[4]/(2 ^ 2) !mulnA -expnD add2n -m1H mulnC leq_mul2r.
Qed.

Lemma alphaL_1_2 n : α_[1] (n.+1) <= (α_[1] n).*2.
Proof.
rewrite !alphaL1E.
case: n => // [] [|[|[|]]] // k.
rewrite -(leq_pmul2l (_ : 0 < 3)) //.
rewrite -!alphaL1E.
apply: leq_trans (alpha_4_3 _) _ => //.
by rewrite -mul2n mulnA leq_mul2r orbT.
Qed.

Lemma alphaL_4_5 n : α_[1] (n.+2) <= (α_[1] n).*2.+1.
Proof.
rewrite !alphaL1E.
case: n => // [] [|[|[|]]] // k.
rewrite -!alphaL1E.
apply: leq_trans (leqnSn _).
rewrite -(leq_pmul2l (_ : 0 < 3)) //.
apply: leq_trans (alpha_4_3 _) _ => //.
rewrite -(leq_pmul2l (_ : 0 < 3)) //.
rewrite mulnCA (leq_trans (_ : _ <= 4 * (4 *  α_[1] k.+4))) //.
  by rewrite leq_mul2l /= alpha_4_3.
by rewrite -mul2n !mulnA leq_mul2r orbT.
Qed.

Lemma dsum_alphaL_S l n : S_[l] n.+1 = S_[l] n + α_[l] n.
Proof. by rewrite addnC subnK //; case: (convex_dsum_alphaL l). Qed.

Lemma dsum_alphaLE l n : S_[l] n = \sum_(i < n) α_[l] i.
Proof.
elim: n => [|n IH].
  by rewrite /dsum_alphaL /conv /= dsum_alpha_0 muln0 big_ord0.
by rewrite dsum_alphaL_S IH big_ord_recr.
Qed.

(* Table *)

Lemma S1_small :
  ((S_[1] 0 = 0) * (S_[1] 1 = 1) * (S_[1] 2 = 3) * (S_[1] 3 = 6) *
  (S_[1] 4 = 10) * (S_[1] 5 = 16) * (S_[1] 6 = 24))%type.
Proof.
by rewrite /dsum_alphaL /conv /= /dsum_alpha
              -!(big_mkord xpredT) unlock /=; compute.
Qed.

Lemma S2_small :
  ((S_[2] 0 = 0 ) * (S_[2] 1 = 2) * (S_[2] 2 = 4) * (S_[2] 3 = 8) * (
  S_[2] 4 = 14) * (S_[2] 5 = 20) * (S_[2] 6 = 28))%type.
Proof.
by rewrite /dsum_alphaL /conv /= /dsum_alpha
              -!(big_mkord xpredT) unlock /=; compute.
Qed.

Lemma S3_small :
  ((S_[3] 0 = 0) * (S_[3] 1 = 2) * (S_[3] 2 = 5) * (S_[3] 3 = 9) * (
  S_[3] 4 = 15) * (S_[3] 5 = 23) * (S_[3] 6 = 32))%type.
Proof.
by rewrite /dsum_alphaL /conv /= /dsum_alpha
              -!(big_mkord xpredT) unlock /=; compute.
Qed.

Lemma S4_small :
  ((S_[4] 0 = 0) * (S_[4] 1 = 2) * (S_[4] 2 = 6) * (S_[4] 3 = 10) * (
  S_[4] 4 = 16) * (S_[4] 5 = 24) * (S_[4] 6 = 36))%type.
Proof.
by rewrite /dsum_alphaL /conv /= /dsum_alpha
              -!(big_mkord xpredT) unlock /=; compute.
Qed.

Lemma S5_small :
  ((S_[5] 0 = 0) * (S_[5] 1 = 2) * (S_[5] 2 = 6) * (S_[5] 3 = 11) * (
  S_[5] 4 = 17) * (S_[5] 5 = 25) * (S_[5] 6 = 37))%type.
Proof.
by rewrite /dsum_alphaL /conv /= /dsum_alpha
              -!(big_mkord xpredT) unlock /=; compute.
Qed.

Lemma alpha1_small :
  ((α_[1] 0 = 1) * (α_[1] 1 = 2) * (α_[1] 2 = 3) * (α_[1] 3 = 4) *
  (α_[1] 4 = 6) * (α_[1] 5 = 8))%type.
Proof.
by rewrite /alphaL /delta !S1_small; compute.
Qed.

Lemma alpha2_small :
  ((α_[2] 0 = 2) * (α_[2] 1 = 2) * (α_[2] 2 = 4) * (α_[2] 3 = 6) * (
  α_[2] 4 = 6) * (α_[2] 5 = 8))%type.
Proof.
by rewrite /alphaL /delta !S2_small; compute.
Qed.

Lemma alpha3_small :
  ((α_[3] 0 = 2) * (α_[3] 1 = 3) * (α_[3] 2 = 4) * (α_[3] 3 = 6) * (
  α_[3] 4 = 8) * (α_[3] 5 = 9))%type.
Proof.
by rewrite /alphaL /delta !S3_small; compute.
Qed.

Lemma alpha4_small :
  ((α_[4] 0 = 2) * (α_[4] 1 = 4) * (α_[4] 2 = 4) * (α_[4] 3 = 6) * (
  α_[4] 4 = 8) * (α_[4] 5 = 12))%type.
Proof.
by rewrite /alphaL /delta !S4_small; compute.
Qed.

Lemma alpha5_small :
  ((α_[5] 0 = 2) * (α_[5] 1 = 4) * (α_[5] 2 = 5) * (α_[5] 3 = 6) * (
  α_[5] 4 = 8) * (α_[5] 5 = 12))%type.
Proof.
by rewrite /alphaL /delta !S5_small; compute.
Qed.

Definition alphaS_small :=
   (S1_small, S2_small, S3_small, S4_small, S5_small).

Definition alpha_small :=
   (alpha1_small, alpha2_small, alpha3_small, alpha4_small, alpha5_small).

End S23.

Notation α := (alpha 2 3).

Notation "\min_ ( i <= n ) F" := (bigmin (fun i => F) n)
 (at level 41, F at level 41, i, n at level 50,
  format "\min_ ( i  <=  n )  F").

Notation " 'S_[' l ']' " := (dsum_alphaL l)
 (format "S_[ l ]").

Notation " 'α_[' l ']' " := (alphaL l)
 (format "α_[ l ]").

Notation S1 := dsum_alpha.


Require Export List.
Set Implicit Arguments.
Inductive nat_tree : Set :=
| NNode' : nat -> list nat_tree -> nat_tree.

Section All.
  Variable T : Set.
  Variable P : T -> Prop.

  Fixpoint All (ls : list T) : Prop :=
    match ls with
      | nil => True
      | cons h t => P h /\ All t
    end.
End All.

Print Forall.
Print All.

Section nat_tree_ind'.
  Variable P : nat_tree -> Prop.

  Hypothesis NNode'_case : forall (n : nat) (ls : list nat_tree),
    Forall P ls -> P (NNode' n ls).

  Fixpoint nat_tree_ind' (tr : nat_tree) : P tr :=
    match tr with
      | NNode' n ls => NNode'_case n
        ((fix list_nat_tree_ind (ls : list nat_tree) : Forall P ls :=
          match ls with
            | nil => Forall_nil P
            | cons tr' rest => Forall_cons tr' (nat_tree_ind' tr') (list_nat_tree_ind rest)
          end) ls)
    end.