(* TD9 - Sémantique petit pas                *)
(* Structural Operational Semantics (SOS)    *)
(*
Constitution du groupe :
Louise GUERIN
Mathis Courant
Jérémy PUCCI
William ISABELLE

|-------+--------------+--------------+--------------+--------------|
	William	Jérémy Mathis Louise
|-------+--------------+--------------+--------------+--------------|
| 1.1.1 | | | | |	x	x	x	x
| 1.1.2 | | | | |	x	x	x	x
| 1.1.3 | | | | |	x	x	x	x
| 1.1.4 | | | | |	x	x	x	x
| 1.2.1 | | | | |	x	x	x	x
|-------+--------------+--------------+--------------+--------------|
| 2.1.1 | | | | |	x	x	x	x
| 2.1.2 | | | | |	x	x	x	x
| 2.1.3 | | | | |	x	x	x	x
| 2.1.4 | | | | |
| 2.2.1 | | | | |	x	x	x	x
| 2.2.2 | | | | |	x	x	x	x
| 2.3.1 | | | | |				x
| 2.3.2 | | | | |				x
| 2.3.3 | | | | |
| 2.4.1 | | | | |	x	x	x	x
| 2.4.2 | | | | |	x	x	x	x
| 2.4.3 | | | | |	x	x	x	x
| 2.4.4 | | | | |
|-------+--------------+--------------+--------------+--------------|
| 3.1 | | | | |
| 3.2 | | | | |
| 3.3.1 | | | | |
| 3.3.2 | | | | |
| 3.3.3 | | | | |
| 3.4 | | | | |
| 3.5 | | | | |
| 3.6 | | | | |
| 3.7.1 | | | | |
| 3.7.2 | | | | |
| 3.7.3 | | | | |
| 3.7.4 | | | | |
| 3.7.5 | | | | |
| 3.8 | | | | |
| 3.9 | | | | |
|-------+--------------+--------------+--------------+--------------|
*)

(* On importe les bibliothèques de Coq utiles pour le TD   *)

Require Import Bool Arith List.
Import List.ListNotations.

(* ========================================================================== *)
(** * Préliminaires *)
(** ** Syntaxe des expressions arithétiques *)

Inductive aexp :=
| Aco : nat -> aexp (** constantes *)
| Ava : nat -> aexp (** variables *)
| Apl : aexp -> aexp -> aexp
| Amu : aexp -> aexp -> aexp
| Amo : aexp -> aexp -> aexp
.

(** ** Syntaxe des expressions booléennes *)

Inductive bexp :=
| Btrue : bexp
| Bfalse : bexp
| Bnot : bexp -> bexp
| Band : bexp -> bexp -> bexp
| Bor : bexp -> bexp -> bexp
| Beq : bexp -> bexp -> bexp    (* test égalité de bexp *)
| Beqnat : aexp -> aexp -> bexp (* test égalité de aexp *)
.

(** ** Syntaxe du langage impératif WHILE *)

Inductive winstr :=
| Skip   : winstr
| Assign : nat -> aexp -> winstr
| Seq    : winstr -> winstr -> winstr
| If     : bexp -> winstr -> winstr -> winstr
| While  : bexp -> winstr -> winstr
.

(* -------------------------------------------------- *)
(** ** États *)

Definition state := list nat.

Fixpoint get (x:nat) (s:state) : nat :=
  match x,s with
  | 0   , v::_      => v
  | S x1, _::l1 => get x1 l1
  | _   , _         => 0
  end.

Fixpoint update (s:state) (v:nat) (n:nat): state :=
  match v,s with
  | 0   , a :: l1 => n :: l1
  | 0   , nil     => n :: nil
  | S v1, a :: l1 => a :: (update l1 v1 n)
  | S v1, nil     => 0 :: (update nil v1 n)
  end.

(* ----------------------------------------------- *)
(** ** Sémantique fonctionnelle de aexp et de bexp *)

Fixpoint evalA (a: aexp) (s: state) : nat :=
  match a with
  | Aco n => n
  | Ava x => get x s
  | Apl a1 a2 =>  evalA a1 s + evalA a2 s
  | Amu a1 a2 =>  evalA a1 s * evalA a2 s
  | Amo a1 a2 =>  evalA a1 s - evalA a2 s
  end.

Definition eqboolb b1 b2 : bool :=
  match b1, b2  with
  | true , true  => true
  | false, false => true
  | _    , _     => false
  end.

Fixpoint eqnatb n1 n2 : bool :=
  match n1, n2 with
  | O    , O     => true
  | S n1', S n2' => eqnatb n1' n2'
  | _    , _     => false
  end.

Fixpoint evalB (b : bexp) (s : state) : bool :=
  match b with
  | Btrue => true
  | Bfalse => false
  | Bnot b => negb (evalB b s)
  | Band e1 e2 => (evalB e1 s) && (evalB e2 s)
  | Bor e1 e2 => (evalB e1 s) || (evalB e2 s)
  | Beq e1 e2 => eqboolb (evalB e1 s) (evalB e2 s)
  | Beqnat n1 n2 => eqnatb (evalA n1 s) (evalA n2 s)
  end.

(* ========================================================================== *)

(** * SOS (Sémantique opérationnelle à petits pas) du langage While *)

Inductive config :=
| Inter : winstr -> state -> config
| Final : state -> config.

(* La relation pour un pas de SOS *)

Inductive SOS_1: winstr -> state -> config -> Prop :=
| SOS_Skip     : forall s,
    SOS_1 Skip s (Final s)

| SOS_Assign   : forall x a s,
    SOS_1 (Assign x a) s (Final (update s x (evalA a s)))

| SOS_Seqf     : forall i1 i2 s s1,
    SOS_1 i1 s (Final s1) ->
    SOS_1 (Seq i1 i2) s (Inter i2 s1)
| SOS_Seqi     : forall i1 i1' i2 s s1,
    SOS_1 i1 s (Inter i1' s1) ->
    SOS_1 (Seq i1 i2) s (Inter (Seq i1' i2) s1)

| SOS_If_true  : forall b i1 i2 s,
    evalB b s = true  ->
    SOS_1 (If b i1 i2) s (Inter i1 s)
| SOS_If_false : forall b i1 i2 s,
    evalB b s = false ->
    SOS_1 (If b i1 i2) s (Inter i2 s)

| SOS_While    : forall b i s,
    SOS_1 (While b i) s (Inter (If b (Seq i (While b i)) Skip) s)
.

(** Fermeture réflexive-transitive de SOS_1 *)
(** Cette sémantique donne toutes les configurations atteignables par un (AST de) programme en partant d'un état initial.
 *)

Inductive SOS : config -> config -> Prop :=
| SOS_stop  : forall c, SOS c c
| SOS_again : forall i1 s1 c2 c3,
    SOS_1 i1 s1 c2 -> SOS c2 c3 ->
    SOS (Inter i1 s1) c3.

(* ========================================================================== *)

Definition N0 := Aco 0.
Definition N1 := Aco 1.
Definition N2 := Aco 2.
Definition N3 := Aco 3.
Definition N4 := Aco 4.

(** * I *)

(** *** Calcul du carré avec des additions *)
(** On code dans While un programme Pcarre correspondant à
    while not (i=n) do {i:= 1+i; x:= y+x ; y:= 2+y} *)
Definition Il := 0.
Definition Ir := Ava Il.
Definition Xl := 1.
Definition Xr := Ava Xl.
Definition Yl := 2.
Definition Yr := Ava Yl.

Definition incrI := Assign Il (Apl N1 Ir).
Definition incrX := Assign Xl (Apl Yr Xr).
Definition incrY := Assign Yl (Apl N2 Yr).
Definition corps_carre := Seq incrI (Seq incrX incrY).
Definition Pcarre_2 := While (Bnot (Beqnat Ir (Aco 2))) corps_carre.
Definition Pcarre n := While (Bnot (Beqnat Ir (Aco n))) corps_carre.
(** Nouveau : on peut jouer avec des programmes qui bouclent *)
Definition Pcarre_inf := While Btrue corps_carre.

Lemma SOS_Pcarre_2_1er_tour : SOS (Inter Pcarre_2 [0;0;1]) (Inter Pcarre_2 [1; 1; 3]).
Proof.
  eapply SOS_again.
  { apply SOS_While. }
  eapply SOS_again.
  {apply SOS_If_true. cbn. reflexivity. }
  eapply SOS_again.
  {cbv[corps_carre]. apply SOS_Seqi. apply SOS_Seqf. cbv[incrI]. apply SOS_Assign. }
  eapply SOS_again.
  { apply SOS_Seqi. apply SOS_Seqf. cbv[incrX]. apply SOS_Assign. }
  eapply SOS_again.
  { apply SOS_Seqf. cbn. cbv[incrY]. apply SOS_Assign. }
  eapply SOS_stop.
Qed.

(****************************************************************************
Ce théorème montre que Pcarre_inf mène d’un état avec i = 0, x = 0 et y = 1 à une configuration intermédiaire
où Pcarre_inf peut être exécuté en partant d’un état avec i = 1, x = 1 et y = 3.
 ****************************************************************************)
Theorem SOS_Pcarre_inf_1er_tour : SOS (Inter Pcarre_inf [0;0;1]) (Inter Pcarre_inf [1; 1; 3]).
Proof.
  eapply SOS_again.
  {apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_true. cbn. reflexivity. }
  eapply SOS_again.
  {apply SOS_Seqi. cbv[corps_carre]. apply SOS_Seqf. cbv[incrI]. apply SOS_Assign. }
  eapply SOS_again.
  {apply SOS_Seqi. cbn. apply SOS_Seqf. cbv[incrX]. apply SOS_Assign. }
  eapply SOS_again.
  { cbn. apply SOS_Seqf. cbv[incrY]. apply SOS_Assign. }
  eapply SOS_stop.
Qed.

Theorem SOS_Pcarre_2_V0 : SOS (Inter Pcarre_2 [0;0;1]) (Final [2;4;5]).
Proof.
  eapply SOS_again.
  { apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_true. cbn. reflexivity. }
  eapply SOS_again.
  { cbv[corps_carre]. apply SOS_Seqi. apply SOS_Seqf. cbv[incrI]. apply SOS_Assign. }
  eapply SOS_again.
  { apply SOS_Seqi. cbn. apply SOS_Seqf. cbv[incrX]. apply SOS_Assign.  }
  eapply SOS_again.
  { cbn. apply SOS_Seqf. cbv[incrY].  apply SOS_Assign. }
  eapply SOS_again.
  { apply SOS_While. }
  eapply SOS_again.
  {apply SOS_If_true. cbn. reflexivity. }
  eapply SOS_again.
  { apply SOS_Seqi. apply SOS_Seqf. cbn. cbv[incrI]. apply SOS_Assign. }
  eapply SOS_again.
  { apply SOS_Seqi. apply SOS_Seqf. cbn. cbv[incrX]. apply SOS_Assign. }
  eapply SOS_again.
  { apply SOS_Seqf. cbn. cbv[incrY]. apply SOS_Assign. }
  eapply SOS_again.
  { apply SOS_While. }
  eapply SOS_again.
  { apply SOS_If_false. cbn. reflexivity. }
  eapply SOS_again.
  { apply SOS_Skip. }
  eapply SOS_stop.
Qed.

(** Le but de la suite est d'éviter les redites, puis éventuellement
    de considérer le cas général Pcarre. *)

(** Propriété essentielle de SOS, qui a un intérêt pratique. *)
Theorem SOS_trans : forall c1 c2 c3, SOS c1 c2 -> SOS c2 c3 -> SOS c1 c3.
Proof.
  intros.
  induction H.
  - apply H0.
  - eapply SOS_again.
    + apply H.
    + apply IHSOS. apply H0.
Qed.

(** Il n'est pas demandé de faire celui-ci
    (bien qu'un copié-collé d'un lemme précédent fonctionne). *)
(****************************************************************************
Ce lemme montre que Pcarre_2 mène d’un état avec i = 1, x = 1 et y = 3 à une configuration intermédiaire
où Pcarre_2 peut être exécuté en partant d’un état avec i = 2, x = 4 et y = 5.
 ****************************************************************************)
Lemma SOS_Pcarre_2_2e_tour : SOS (Inter Pcarre_2 [1; 1; 3]) (Inter Pcarre_2 [2; 4; 5]).
Proof.
    eapply SOS_again.
  { apply SOS_While. }
  eapply SOS_again.
  {apply SOS_If_true. cbn. reflexivity. }
  eapply SOS_again.
  {cbv[corps_carre]. apply SOS_Seqi. apply SOS_Seqf. cbv[incrI]. apply SOS_Assign. }
  eapply SOS_again.
  { apply SOS_Seqi. apply SOS_Seqf. cbv[incrX]. apply SOS_Assign. }
  eapply SOS_again.
  { apply SOS_Seqf. cbn. cbv[incrY]. apply SOS_Assign. }
  eapply SOS_stop.
Qed.

(****************************************************************************
Ce théorème montre que Pcarre_2 mène d’un état avec i = 2, x = 4 et y = 5 à un état final avec i = 2, x = 4 et y = 5
 ****************************************************************************)
Theorem SOS_Pcarre_2_fini : SOS (Inter Pcarre_2 [2; 4; 5]) (Final [2; 4; 5]).
Proof.
  eapply SOS_again.
  { cbv[Pcarre_2]. cbv[corps_carre]. apply SOS_While.
  }
  eapply SOS_again.
  { apply SOS_If_false. cbn. reflexivity. }
  eapply SOS_again.
  { apply SOS_Skip. }
  eapply SOS_stop.
Qed.

(** Même énoncé que SOS_Pcarre_2_V0. Utiliser SOS_trans *)
Theorem SOS_Pcarre_2_fin_V1 : SOS (Inter Pcarre_2 [0;0;1]) (Final [2;4;5]).
Proof.
  apply SOS_trans with (Inter Pcarre_2 [1; 1; 3]).
  - apply SOS_Pcarre_2_1er_tour.
  - apply SOS_trans with (Inter Pcarre_2 [2; 4; 5] ).
    + apply SOS_Pcarre_2_2e_tour.
    + apply SOS_Pcarre_2_fini.
Qed.

(** Généralisation à Pcarre *)

(** On a besoin de deux lemmes arithmétiques, démontrables avec la tactique ring. *)
Lemma Sn_2 n : S n + S n = S (S (n + n)).
Proof. ring. Qed.

Lemma Sn_carre n : S n * S n = S (n + n + n * n).
Proof. ring. Qed.

Definition invar_cc n := [n; n*n; S (n+n)].

(*********************************************************************
Ce théorème montre que corps_carre avec i = n, x = n*n et y = n + n + 1 mène à
l'état final avec i = n+1, x = (n+1)*(n+1) et y = (n+1) + (n+1) + 1
 *********************************************************************)
Theorem SOS_corps_carre n : SOS (Inter corps_carre (invar_cc n)) (Final (invar_cc (S n))).
Proof.
  eapply SOS_again.
  { cbv[corps_carre]. apply SOS_Seqf. cbv[incrI]. apply SOS_Assign. }
  eapply SOS_again.
  { cbn. apply SOS_Seqf. cbv[incrX]. apply SOS_Assign. }
  eapply SOS_again.
  { cbn. cbv[incrY]. apply SOS_Assign. }
  cbn. rewrite <- Sn_carre. rewrite <- Sn_2. cbv[invar_cc].
  eapply SOS_stop.
Qed.

(** Celui-ci est court mais difficile. Laisser Admitted au début. *)
(*
 *************************************************************************************************
Pour toutes instructions i1, i2 et états s1, s2,
tels que l'instruction intermédiare i1 avec l'état s1 mène à l'état final s2,

La séquence intermédiare d'instructions i1 i2 à l'état s1 mène à une configuration où i2 peut être exécuté avec l'état s2

*************************************************************************************************
*)
Fixpoint SOS_seq i1 i2 s1 s2 (so : SOS (Inter i1 s1) (Final s2)) :
  SOS (Inter (Seq i1 i2) s1) (Inter i2 s2).
Proof.
Admitted.

(************************************************************************************************
Pour toute instruction I et entier n, la séquence des instructions corps_carre et I avec l'état i = n, x = n*n et y = n + n + 1 mène à la configuration intermédaire de où I peut être exécuté avec i = n+1, x = (n+1)*(n+1) et y = (n+1) + (n+1) + 1
 ************************************************************************************************)
(** Réutiliser les lemmes précédents (facile et très court). *)
Lemma SOS_corps_carre_inter n i :
  SOS (Inter (Seq corps_carre i) (invar_cc n)) (Inter i (invar_cc (S n))).
Proof.
  apply SOS_seq.
  apply SOS_corps_carre.
Qed.

Lemma eqnatb_refl : forall n, eqnatb n n = true.
Proof.
  intros.
  induction n.
  - cbn. reflexivity.
  - apply IHn.
Qed.

(*******************************************************************
Pour tout entiers n m,
(Pcarre n) mène d’un état avec i = m, x = m*m et y = m+m+1 à une configuration intermédiaire
où (Pcarre n) peut être exécuté en partant d’un état avec i = m+1, x = (m+1)*(m+1) et y = (m+1)+(m+1)+1.
 *******************************************************************)
(** Réutiliser les lemmes précédents (facile). *)
Lemma SOS_Pcarre_tour :
  forall n i, eqnatb i n = false ->
              SOS (Inter (Pcarre n) (invar_cc i)) (Inter (Pcarre n) (invar_cc (S i))).
Proof.
  intros. cbv[Pcarre]. eapply SOS_again.
  { eapply SOS_While. }
  eapply SOS_again.
  { eapply SOS_If_true. cbn. rewrite H. cbn. reflexivity. }
  apply SOS_corps_carre_inter.
Qed.

(*******************************************************************
Pour tout entier n,
(Pcarre n) mène d’un état avec i = n, x = n*n et y = n+n+1 à une configuration intermédiaire
où (Pcarre n) peut être exécuté en partant d’un état avec i = n, x = n*n et y = n+n+1.
 *******************************************************************)
(** Facile *)
Theorem SOS_Pcarre_n_fini :
  forall n, SOS (Inter (Pcarre n) (invar_cc n)) (Final (invar_cc n)).
Proof.
  intros.
  cbv[Pcarre]. eapply SOS_again.
  { eapply SOS_While. }
  eapply SOS_again.
  { eapply SOS_If_false. cbn. rewrite eqnatb_refl. cbn. reflexivity. }
  eapply SOS_again.
  { eapply SOS_Skip. }
  eapply SOS_stop.
Qed.

(********************************************************************
On a :
SOS (Inter Pcarre_2 [0; 0; 1]) (Inter Pcarre_2 [1; 1; 3])
,
SOS (Inter Pcarre_2 [1; 1; 3]) (Inter Pcarre_2 [2; 4; 5])
et
SOS (Inter Pcarre_2 [2; 4; 5]) (Final Pcarre_2 [2; 4; 5])

Donc, par transitivités successives :
SOS (Inter Pcarre_2 [0; 0; 1]) (Final Pcarre_2 [2; 4; 5])
 ********************************************************************)
Theorem SOS_Pcarre_2_fin_V2 : SOS (Inter Pcarre_2 [0;0;1]) (Final [2;4;5]).
Proof.
  eapply SOS_trans.
  { apply SOS_Pcarre_tour. reflexivity. }
  eapply SOS_trans.
  { apply SOS_Pcarre_tour. reflexivity. }
  eapply SOS_trans.
  { apply SOS_Pcarre_n_fini. }
  apply SOS_stop.
Qed.

(*******************************************************************
Pour tout entier n,
Pcarre_inf mène d’un état avec i = n, x = n*n et y = n+n+1 à une configuration intermédiaire
où Pcarre_inf peut être exécuté en partant d’un état avec i = n+1, x = (n+1)*(n+1) et y = (n+1)+(n+1)+1.
 *******************************************************************)
(** On peut dire des choses sur la version qui boucle. *)
Lemma SOS_Pcarre_inf_tour :
  forall i,
    SOS (Inter Pcarre_inf (invar_cc i)) (Inter Pcarre_inf (invar_cc (S i))).
Proof.
  intros.
  cbv[Pcarre_inf]. eapply SOS_again.
  { eapply SOS_While. }
  eapply SOS_again.
  { eapply SOS_If_true. cbn. reflexivity. }
  apply SOS_corps_carre_inter.
Qed.

(*******************************************************************
Pour tout entier n,
Pcarre_inf mène d’un état avec i = 0, x = 0 et y = 1 à une configuration intermédiaire
où Pcarre_inf peut être exécuté en partant d’un état avec i = n, x = n*n et y = n+n+1.
 *******************************************************************)
Theorem SOS_Pcarre_inf_n :
  forall i,
    SOS (Inter Pcarre_inf [0; 0; 1]) (Inter Pcarre_inf (invar_cc i)).
Proof.
  induction i.
  apply SOS_stop.
  eapply SOS_trans.
  + apply IHi.
  + apply SOS_Pcarre_inf_tour.
Qed.

(** Énoncer et démontrer le théorème général pour Pcarre *)

(* ========================================================================== *)

(** * II *)

(** ** Définir une version fonctionnelle de SOS_1 *)
Fixpoint f_SOS_1 (i : winstr) (s : state) : config :=
  match i with
  | Skip => Final s
  | Assign x a => Final (update s x (evalA a s))
  | Seq i1 i2 => let c1:=f_SOS_1 i1 s in
                 match c1 with
                 | Inter i1' s' => Inter (Seq i1' i2) s'
                 | Final s' => Inter i2 s'
                 end
  | If b i1 i2 => if evalB b s then Inter i1 s else Inter i2 s
  | While b i => Inter (If b (Seq i (While b i)) Skip) s
end.

(** ** Utilisation de f_SOS_1 pour éviter les eapply SOS_again *)

(** PC = pt de contrôle *)
Definition PC0 := Pcarre_2.
Eval cbn in (f_SOS_1 PC0 [0;0;1]).

(** Il faut un peu désosser le code pour y retrouver les points de contrôle *)

Definition PC2 := Seq corps_carre PC0.
Definition PC1 := If (Bnot (Beqnat Ir (Aco 2))) PC2 Skip.
Definition PC3 := Seq (Seq incrX incrY) PC0.
Definition PC4 := Seq incrY PC0.

(** On vérifie la progression *)
Fact fa1 : f_SOS_1 PC0 [0;0;1] = Inter PC1 [0;0;1]. reflexivity. Qed.
Eval cbn in (f_SOS_1 PC1 [0;0;1]).
(** Continuer, on retombe sur PC0 après quelques étapes. *)

(** Utilisation sur un lemme SOS *)
Lemma SOS_Pcarre_2_1er_tour_V1 :
  SOS (Inter Pcarre_2 [0;0;1]) (Inter Pcarre_2 [1; 1; 3]).
Proof.
  change Pcarre_2 with PC0.
  apply SOS_again with (f_SOS_1 PC0 [0; 0; 1]).
  { apply SOS_While. }
  apply SOS_again with (f_SOS_1 PC1 [0;0;1]).
  { apply SOS_If_true. reflexivity. }
  cbn.
  apply SOS_again with (f_SOS_1 PC2 [0;0;1]).
  { apply SOS_Seqi. apply SOS_Seqf. apply SOS_Assign. }
  cbn.
  apply SOS_again with (f_SOS_1 PC3 [1;0;1]).
  { apply SOS_Seqi. apply SOS_Seqf. apply SOS_Assign. }
  cbn.
  apply SOS_again with (f_SOS_1 PC4 [1;1;1]).
  { apply SOS_Seqf. apply SOS_Assign. }
  apply SOS_stop.
Qed.

(** ** Théorèmes généraux reliant SOS_1 et f_SOS_1 *)

(** Court mais non trivial. *)
Lemma f_SOS_1_corr : forall i s, SOS_1 i s (f_SOS_1 i s).
Proof.
Admitted.

(** Court. Attention : utiliser la tactique injection. *)
Lemma f_SOS_1_compl : forall i s c, SOS_1 i s c -> c = f_SOS_1 i s.
Proof.
Admitted.


Require Import GHC.Char.
Require GHC.Unicode.
Require Coq.Lists.List.
Require Import Omega.
Import Ascii.AsciiSyntax.
Import String.StringSyntax.

Fixpoint ascending {a0} (arg_48__: a0 -> a0 -> comparison) (a:a0) (as_:list a0 -> list a0) (bs: list a0)
         {struct bs} : list (list a0)
        := let j_53__ : list (list a0) :=
             match arg_48__ , a , as_ , bs with
               | cmp , a , as_ , bs => cons (as_ (cons a nil))
                                           (match bs with
                                           | cons a (cons b xs) =>  if GHC.Base.eq_comparison (cmp a b) Gt : bool
                                                                   then descending cmp b (cons a nil) xs
                                                                   else ascending cmp b (fun y => cons a y) xs
                                           | xs => cons xs nil
                                           end)
             end in
           match arg_48__ , a , as_ , bs with
             | cmp , a , as_ , cons b bs => if negb (GHC.Base.eq_comparison (cmp a b) Gt)
                                            then ascending cmp b (fun arg_54__ =>
                                                                   match arg_54__ with
                                                                     | ys => as_ (cons a ys)
                                                                   end) bs
                                            else j_53__
             | _ , _ , _ , _ => j_53__
           end
with descending {a0} (arg_40__: a0 -> a0 -> comparison) (a:a0) (arg_42__:list a0) arg_43__
     {struct arg_43__} :=
       let j_45__  : list (list a0) :=
           match arg_40__ , a , arg_42__ , arg_43__ with
           | cmp , a , as_ , bs => cons (cons a as_)
                                       (match bs with
                                        | cons a (cons b xs) =>  if GHC.Base.eq_comparison (cmp a b) Gt : bool
                                                                then descending cmp b (cons a nil) xs
                                                                else ascending cmp b (fun y => cons a y) xs
                                        | xs => cons xs nil
                                        end)
           end in
       match arg_40__ , a , arg_42__ , arg_43__ with
       | cmp , a , as_ , cons b bs => if GHC.Base.eq_comparison (cmp a b) Gt : bool
                                     then descending cmp b (cons a as_) bs
                                     else j_45__
       | _ , _ , _ , _ => j_45__
       end.

Definition sequences {a0} (cmp : a0 -> a0 -> comparison) (ys:list a0) : list (list a0)  :=
    match ys with
      | cons a (cons b xs) =>  if GHC.Base.eq_comparison (cmp a b) Gt : bool
                              then descending cmp b (cons a nil) xs
                              else ascending cmp b (fun y => cons a y) xs
      | xs => cons xs nil
    end.

Fixpoint merge {a0} (cmp: a0 -> a0 -> comparison) (l1:list a0) (l2: list a0) : list a0 :=
  let fix merge_aux l2 :=
      match l1 , l2 with
      | (cons a as' as as_) , (cons b bs' as bs) =>
        if GHC.Base.eq_comparison (cmp a b) Gt : bool
        then cons b (merge_aux bs')
        else cons a (merge cmp as' bs)
      | nil , bs => bs
      | as_ , nil => as_
      end in
  merge_aux l2.

Fixpoint mergePairs {a0} (cmp: a0 -> a0 -> comparison) xs
        := match xs with
             | cons a (cons b xs) => cons (merge cmp a b) (mergePairs cmp xs)
             | xs => xs
           end.

Lemma mergePairs_length : forall n, forall a cmp (xs : list (list a)) x y,
      le (length xs) n ->
      lt (length (mergePairs cmp (cons x (cons y xs)))) (2 + n).
induction n. intros; simpl. destruct xs; inversion H. simpl. auto.
intros.
destruct xs.
simpl in *. omega.
destruct xs.
simpl in *. omega.
assert (L : le (length xs) n).
simpl in H. omega.
specialize (IHn a cmp xs l l0 L).
simpl in *. omega.
Qed.

Program Fixpoint mergeAll {a0} (cmp: a0 -> a0 -> comparison)
        (xs : list (list a0)) {measure (length xs) } : list a0 :=
  match xs with
  | nil        => nil
  | cons x nil => x
  | cons x (cons y xs) => mergeAll cmp (mergePairs cmp (cons x (cons y xs)))
  end.
Next Obligation.
simpl.
destruct xs. simpl. auto.
destruct xs. simpl. auto.
apply lt_n_S.
pose (MP := mergePairs_length (length xs) a0 cmp xs l l0 ltac:(auto)). clearbody MP.
simpl in *.
omega.
Defined.

Definition sortBy {a} (cmp : a -> a -> comparison) (xs : list a): list a :=
     mergeAll cmp (sequences cmp xs).

(* -------------------------------------------- *)

Lemma dropWhile_cons_prop : forall {A} (c:A) s p s',
  cons c s' = GHC.List.dropWhile p s ->
  p c = false.
Proof.
  induction s.
  + intros. simpl in *. discriminate.
  + intros p s' H. simpl in H.
    destruct (p a) eqn:Hp.
    ++ eapply IHs. eauto.
    ++ inversion H. subst. auto.
Qed.

Lemma dropWhile_cons_length : forall {A} (c:A) s p s',
  cons c s' = GHC.List.dropWhile p s ->
  lt (length s') (length s).
Proof.
  induction s.
  + intros. simpl in *. discriminate.
  + intros p s' H. simpl in *.
    destruct (p a) eqn:Hp.
    pose (K := IHs p s' H). clearbody K.
    omega.
    inversion H. subst.
    auto.
Qed.

Lemma break_length {A} {p} {s:list A} : forall {w} {s''},
  pair w s'' = List.break p s ->  le (length s'') (length s).
Proof.
  induction s.
  + simpl. intros w s'' h. inversion h. subst. simpl. auto.
  + simpl. intros w s'' h1.
    destruct (p a) eqn:Hp.
    ++ inversion h1. subst. simpl. auto.
    ++ destruct (List.break p s) as [ys zs] eqn:B.
       inversion h1. subst.
       pose (K := IHs ys zs eq_refl). clearbody K.
       auto.
Qed.

Program Fixpoint words (s : GHC.Base.String) { measure (length s) }
  : list GHC.Base.String :=
  match (GHC.List.dropWhile GHC.Unicode.isSpace s) with
    | nil => nil
    | s'  =>
     let 'pair w s'' := GHC.List.break GHC.Unicode.isSpace s' in
     cons w (words s'')
  end.
Next Obligation.
  destruct (List.dropWhile Unicode.isSpace s) eqn:D. contradiction.
  symmetry in D.
  pose (h0 := dropWhile_cons_prop _ _ _ _ D). clearbody h0.
  pose (h1 := dropWhile_cons_length _ _ _ _ D). clearbody h1.
  simpl in Heq_anonymous.
  rewrite h0 in Heq_anonymous.
  destruct (List.break Unicode.isSpace l) as [ys zs] eqn:B.
  inversion Heq_anonymous. subst.
  symmetry in B.
  pose (h2 := break_length B).
  omega.
Defined.

Program Fixpoint lines (s : GHC.Base.String) { measure (length s) }
  : list GHC.Base.String :=
  if (List.null s) then nil else
  let cons_ := fun '(pair h t) => cons h t in
  cons_ (let 'pair l s' := GHC.List.break
                             (fun arg_4__ =>
                                arg_4__ == newline) s in
         pair l (match s' with | nil => nil | cons _ s'' => lines s'' end)).
Next Obligation.
  pose (h0 := break_length Heq_anonymous). clearbody h0. simpl in h0.
  omega.
Defined.


From Coq Require Import ZArith Reals Psatz.
From Flocq Require Import Binary.
From mathcomp Require Import all_ssreflect ssralg ssrnat all_algebra seq matrix.
From mathcomp.analysis Require Import Rstruct.
Import List ListNotations.

From vcfloat Require Import FPLang FPLangOpt RAux Rounding Reify
                            Float_notations Automate FPLib.

Require Import fma_floating_point_model inf_norm_properties.

Require Import common fma_dot_acc float_acc_lems dotprod_model.

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Require Import lemmas fma_is_finite finite_lemmas_additional.
Require Import Coq.ZArith.BinInt.

Open Scope ring_scope.

Delimit Scope ring_scope with Ri.
Delimit Scope R_scope with Re.

Import Order.TTheory GRing.Theory Num.Def Num.Theory.

Section WITHNANS.
Context {NANS: Nans}.

Notation "A +f B" := (addmx_float A B) (at level 80).
Notation "-f A" := (opp_mat A) (at level 50).
Notation "A *f B" := (mulmx_float A B) (at level 70).
Notation "A -f B" := (sub_mat A B) (at level 80).

Definition F' (t: type) :=
    (fmax t * (1 -  2 * default_rel t))%Re.

Lemma F_p_ge_0 {ty}:
  (0 <= F' ty)%Re.
Proof.
unfold F'.
apply Rmult_le_pos.
+ unfold fmax. apply bpow_ge_0.
+  apply Rge_le. apply Rge_minus. apply Rle_ge.
   unfold default_rel.
   assert ((2 * (/ 2 * bpow Zaux.radix2 (- fprec ty + 1)))%Re =
            bpow Zaux.radix2 (- fprec ty + 1)).
   { nra. } rewrite H.
   assert ((- fprec ty + 1)%Z = (- (fprec ty - 1))%Z).
   {  rewrite Z.opp_add_distr Z.opp_involutive. reflexivity. }
   rewrite H0 bpow_opp.
   replace 1%Re with (/1)%Re by nra.
   apply Rlt_le. apply Rinv_lt_contravar.
   - apply Rmult_lt_0_compat. nra.
     apply bpow_gt_0.
   - assert (1%Re = bpow Zaux.radix2 0).
     { by unfold bpow. } rewrite H1.
     apply bpow_lt. apply Z.lt_0_sub, fprec_gt_one.
Qed.

Lemma finite_bminus {ty} {n:nat} (v1 v2 : 'cV[ftype ty]_n.+1) i:
  let xy := (v1 (inord i) ord0, v2 (inord i) ord0) in
  In xy
      (combine
         (vec_to_list_float n.+1 v1)
         (vec_to_list_float n.+1 v2)) ->
   (finite xy.1 /\finite xy.2 /\
    (Rabs (FT2R (fst (xy))) <= (F' ty /2) / (INR n.+1 * (1 + default_rel ty)^n.+1))%Re /\
     (Rabs (FT2R (snd (xy))) <= (F' ty /2) / (INR n.+1 * (1 + default_rel ty)^n.+1))%Re) ->
  finite (BPLUS (v1 (inord i) 0) (BOPP (v2 (inord i) 0))).
Proof.
intros ? Hin Hfin.
apply Bplus_no_ov_finite .
  - apply Hfin.
  - rewrite finite_BOPP. apply Hfin.
  - unfold Bplus_no_overflow.
    pose proof (generic_round_property ty (FT2R (v1 (inord i) 0) +  FT2R (BOPP  (v2 (inord i) 0)))).
    destruct H as [d [e [Hpr [Hdf [Hde H]]]]].
    rewrite H.
    destruct Hfin as [Hf1 [Hf2 [Ha1 Ha2]]].
    apply Rle_lt_trans with
    (Rabs ((FT2R (v1 (inord i) ord0) +
              FT2R (BOPP (v2 (inord i) ord0))) *  (1 + d)) +
    (Rabs e))%Re.
    * apply Rabs_triang.
    * rewrite Rabs_mult.
      eapply Rle_lt_trans.
      ++ apply Rplus_le_compat_r. apply Rmult_le_compat_r.
          apply Rabs_pos. apply Rabs_triang.
      ++ apply Rle_lt_trans with
         ((2 * ((F' ty/2) / (INR n.+1 * (1 + default_rel ty) ^ n.+1))) *
          (1 + default_rel ty) + default_abs ty)%Re.
         -- apply Rplus_le_compat.
            ** apply Rmult_le_compat.
               +++ apply Rplus_le_le_0_compat; apply Rabs_pos.
               +++ apply Rabs_pos.
               +++ rewrite double. apply Rplus_le_compat.
                   --- apply Ha1.
                   --- unfold FT2R in *. rewrite B2R_Bopp. rewrite Rabs_Ropp.
                       apply Ha2.
               +++ apply Rle_trans with (Rabs 1 + Rabs d)%Re.
                   apply Rabs_triang. rewrite Rabs_R1. by apply Rplus_le_compat_l.
            ** apply Hde.
         --  assert ((F' ty + default_abs ty < bpow Zaux.radix2 (femax ty))%Re)%Re.
             { unfold F'. unfold fmax.
               assert ((bpow Zaux.radix2 (femax ty) *
                          (1 - 2 * default_rel ty) + default_abs ty)%Re =
                        (bpow Zaux.radix2 (femax ty) -
                          (2 * bpow Zaux.radix2 (femax ty) * default_rel ty - default_abs ty))%Re).
               { nra. } rewrite H0.
               assert (forall x y:R, (0 < y)%Re -> (x - y < x)%Re).
               { intros. nra. } apply H1.
               apply Rgt_lt. apply Rgt_minus. apply Rlt_gt.
               unfold default_abs, default_rel.
               assert ((2 * bpow Zaux.radix2 (femax ty) *
                          (/ 2 * bpow Zaux.radix2 (- fprec ty + 1)))%Re =
                       (1 * (bpow Zaux.radix2 (femax ty) * bpow Zaux.radix2 (- fprec ty + 1)))%Re).
               { nra. } rewrite H2. clear H2.
               apply Rmult_lt_compat. nra. apply bpow_ge_0. nra.
               rewrite Z.add_comm. rewrite Rmult_comm.
               rewrite -bpow_plus. apply bpow_lt. rewrite Z.add_shuffle0.
               apply Z.add_lt_mono_r.
               apply Z.lt_sub_lt_add. simpl.
               unfold Z.sub. rewrite Z.opp_involutive.
               assert (2%Z = (1+1)%Z). { by simpl. }
               rewrite H2.
               apply Z.add_lt_mono;
               apply Z.lt_trans with (fprec ty); try apply fprec_gt_one;
               try apply fprec_lt_femax.
             } apply Rle_lt_trans with (F' ty + default_abs ty)%Re.
             ** apply Rplus_le_compat_r.
                assert ((2 *
                           (F' ty / 2 /
                            (INR n.+1 * (1 + default_rel ty) ^ n.+1)) *
                           (1 + default_rel ty))%Re =
                        ((F' ty * / (INR n.+1 * (1 + default_rel ty) ^ n.+1)) * (1 + default_rel ty))%Re).
                { nra. } rewrite H1. clear H1.
                rewrite Rinv_mult_distr.
                +++ replace (F' ty) with (F' ty * 1)%Re by nra.
                    assert (((F' ty * 1) *
                               (/ INR n.+1 * / (1 + default_rel ty) ^ n.+1) *
                               (1 + default_rel ty))%Re =
                             ((F' ty * / INR n.+1) * (/ (1 + default_rel ty) ^ n.+1 * (1 + default_rel ty)))%Re).
                    { nra. } rewrite H1. clear H1.
                    apply Rmult_le_compat.
                    --- apply Rmult_le_pos.  apply F_p_ge_0.
                        apply Rlt_le. apply Rinv_0_lt_compat. apply lt_0_INR.
                        lia.
                    --- apply Rmult_le_pos. apply Rlt_le. apply Rinv_0_lt_compat.
                        apply pow_lt. apply Rplus_lt_0_compat. nra. apply default_rel_gt_0.
                        apply Rlt_le. apply Rplus_lt_0_compat. nra. apply default_rel_gt_0.
                    --- replace (F' ty) with (F' ty * 1)%Re by nra.
                        replace (F' ty * 1 * / INR n.+1)%Re with (F' ty * / INR n.+1)%Re by nra.
                        apply Rmult_le_compat_l.
                        *** apply F_p_ge_0.
                        *** replace 1%Re with (/1)%Re by nra.
                            assert ((0 <= n)%nat ). { by []. }
                            rewrite leq_eqVlt in H1.
                            assert ((0%nat == n) \/ (0 < n)%nat).
                            { by apply /orP. } destruct H2.
                            ++++ rewrite eq_sym in H2.
                                 assert (n = 0%nat). { by apply /eqP. }
                                 rewrite H3. simpl;nra.
                            ++++ apply /Rlt_le. apply  Rinv_lt_contravar.
                                 apply Rmult_lt_0_compat. nra. apply lt_0_INR. lia.
                                 apply lt_1_INR. apply /ssrnat.ltP. by [].
                    --- simpl.
                        assert ((/ ((1 + default_rel ty) * (1 + default_rel ty) ^ n) *
                                    (1 + default_rel ty))%Re =
                                (((1 + default_rel ty) * / (1 + default_rel ty)) * /(1 + default_rel ty) ^ n)%Re).
                        { rewrite Rinv_mult_distr. nra.
                          assert ((0 < 1 + default_rel ty)%Re -> (1 + default_rel ty)%Re <> 0%Re).
                          { nra. } apply H1.
                          apply Rplus_lt_0_compat. nra. apply default_rel_gt_0.
                          apply pow_nonzero.
                          assert ((0 < 1 + default_rel ty)%Re -> (1 + default_rel ty)%Re <> 0%Re).
                          { nra. } apply H1.
                          apply Rplus_lt_0_compat. nra. apply default_rel_gt_0.
                        } rewrite H1. rewrite Rinv_r.
                        assert (( / (1 + default_rel ty) ^ n <= / 1)%Re ->
                                (1 * / (1 + default_rel ty) ^ n <= 1)%Re).
                        { nra. } apply H2. destruct n.
                        *** simpl. nra.
                        *** apply Rlt_le.
                            apply Rinv_lt_contravar. apply Rmult_lt_0_compat.
                            nra. apply pow_lt. apply Rplus_lt_0_compat. nra.
                            apply default_rel_gt_0.
                            apply Rlt_pow_R1.
                            assert (forall x, (0 < x)%Re -> (1 < 1 + x)%Re).
                            { intros. nra. } apply H3. apply default_rel_gt_0.
                            lia.
                        *** assert ((0 < 1 + default_rel ty)%Re -> (1 + default_rel ty)%Re <> 0%Re).
                            { nra. } apply H2.
                            apply Rplus_lt_0_compat. nra. apply default_rel_gt_0.
                +++ apply not_0_INR. lia.
                +++ apply pow_nonzero .
                    assert ((0 < 1 + default_rel ty)%Re -> (1 + default_rel ty)%Re <> 0%Re).
                    { nra. } apply H1.
                    apply Rplus_lt_0_compat. nra. apply default_rel_gt_0.
             ** apply H0.
Qed.

Lemma vec_float_sub {ty} {n:nat} (v1 v2 : 'cV[ftype ty]_n.+1):
  (forall (xy : ftype ty * ftype ty),
    In xy
      (combine
         (vec_to_list_float n.+1 v1)
         (vec_to_list_float n.+1 v2)) ->
         finite xy.1 /\finite xy.2 /\ finite (BPLUS xy.1 (BOPP xy.2))) ->
  vec_inf_norm (FT2R_mat (v1 -f v2) - (FT2R_mat v1 - FT2R_mat v2)) <=
  (vec_inf_norm (FT2R_mat v1) + vec_inf_norm (FT2R_mat v2)) * (default_rel ty) .
Proof.
intros Hfin.
unfold vec_inf_norm.
apply /RleP. apply bigmax_le; first by rewrite size_map size_enum_ord.
intros. rewrite seq_equiv.
rewrite nth_mkseq; last by rewrite size_map size_enum_ord in H.
rewrite !mxE. rewrite -!RminusE -RmultE -!RplusE.
specialize (Hfin ((v1 (inord i) ord0), (v2 (inord i) ord0))).
assert (Hin: In (v1 (inord i) ord0, v2 (inord i) ord0)
           (combine (vec_to_list_float n.+1 v1)
              (vec_to_list_float n.+1 v2))).
{ apply in_rev. rewrite -combine_rev; last by rewrite !length_veclist.
  assert ((v1 (inord i) ord0, v2 (inord i) ord0) =
           nth i (combine (rev (vec_to_list_float n.+1 v1))
                    (rev (vec_to_list_float n.+1 v2))) (Zconst ty 0, Zconst ty 0)).
  { rewrite combine_nth. rewrite !rev_nth !length_veclist.
    assert ((n.+1 - i.+1)%coq_nat = (n.+1.-1 - i)%coq_nat).
    { lia. } rewrite H0. rewrite !nth_vec_to_list_float; try by [].
    by rewrite size_map size_enum_ord in H.
    by rewrite size_map size_enum_ord in H.
    apply /ssrnat.ltP. by rewrite size_map size_enum_ord in H.
    apply /ssrnat.ltP. by rewrite size_map size_enum_ord in H.
    by rewrite !rev_length !length_veclist.
 } rewrite H0. apply nth_In. rewrite combine_length.
 rewrite !rev_length !length_veclist Nat.min_id.
 rewrite size_map size_enum_ord in H. by apply /ssrnat.ltP.
} specialize (Hfin Hin).
rewrite Bminus_bplus_opp_equiv.
+ assert ((FT2R (v1 (inord i) ord0) -  FT2R (v2 (inord i) ord0))%Re =
          (FT2R (v1 (inord i) ord0) +  FT2R (BOPP (v2 (inord i) ord0)))%Re ).
  { unfold FT2R. rewrite B2R_Bopp. nra. }
  rewrite H0.
  apply Rle_trans with
  ((Rabs (FT2R (v1 (inord i) ord0)) + Rabs (FT2R (BOPP (v2 (inord i) ord0)))) * (default_rel ty))%Re.
  - apply BPLUS_error_le_rel.
    apply Hfin.
  - apply Rle_trans with
    ((bigmaxr 0%Re
          [seq Rabs (FT2R_mat v1 i0 ord0)
             | i0 <- enum 'I_n.+1] +
        bigmaxr 0%Re
          [seq Rabs (FT2R_mat v2 i0 ord0)
             | i0 <- enum 'I_n.+1]) * default_rel ty)%Re.
    * apply Rmult_le_compat_r.
      ++ apply default_rel_ge_0.
      ++ apply Rplus_le_compat.
         -- apply Rle_trans with
            [seq Rabs (FT2R_mat v1 i0 ord0)
                 | i0 <- enum 'I_n.+1]`_i.
            ** rewrite seq_equiv. rewrite nth_mkseq;
               last by rewrite size_map size_enum_ord in H.
               rewrite !mxE. nra.
            ** apply /RleP.
               apply (@bigmaxr_ler _ 0%Re [seq Rabs (FT2R_mat v1 i0 ord0)
                                              | i0 <- enum 'I_n.+1] i).
               rewrite size_map size_enum_ord.
               by rewrite size_map size_enum_ord in H.
         -- apply Rle_trans with
            [seq Rabs (FT2R_mat v2 i0 ord0)
                 | i0 <- enum 'I_n.+1]`_i.
            ** rewrite seq_equiv. rewrite nth_mkseq;
               last by rewrite size_map size_enum_ord in H.
               rewrite !mxE. unfold FT2R. rewrite B2R_Bopp Rabs_Ropp. nra.
            ** apply /RleP.
               apply (@bigmaxr_ler _ 0%Re [seq Rabs (FT2R_mat v2 i0 ord0)
                                              | i0 <- enum 'I_n.+1] i).
               rewrite size_map size_enum_ord.
               by rewrite size_map size_enum_ord in H.
    * apply Rle_refl.
+ apply Hfin.
Qed.

Lemma vec_float_sub_1 {ty} {n:nat} (v1 v2 : 'cV[ftype ty]_n.+1):
  (forall (xy : ftype ty * ftype ty),
    In xy
      (combine
         (vec_to_list_float n.+1 v1)
         (vec_to_list_float n.+1 v2)) ->
    finite xy.1 /\ finite xy.2 /\ finite (BPLUS xy.1 (BOPP xy.2))) ->
  vec_inf_norm (FT2R_mat (v1 -f v2) - (FT2R_mat v1 - FT2R_mat v2)) <=
  (vec_inf_norm (FT2R_mat v1 - FT2R_mat v2)) * (default_rel ty) .
Proof.
intros Hfin.
unfold vec_inf_norm.
apply /RleP. apply bigmax_le; first by rewrite size_map size_enum_ord.
intros. rewrite seq_equiv.
rewrite nth_mkseq; last by rewrite size_map size_enum_ord in H.
rewrite !mxE. rewrite -!RminusE -RmultE.
specialize (Hfin ((v1 (inord i) ord0), (v2 (inord i) ord0))).
assert (Hin: In (v1 (inord i) ord0, v2 (inord i) ord0)
           (combine (vec_to_list_float n.+1 v1)
              (vec_to_list_float n.+1 v2))).
{ apply in_rev. rewrite -combine_rev; last by rewrite !length_veclist.
  assert ((v1 (inord i) ord0, v2 (inord i) ord0) =
           nth i (combine (rev (vec_to_list_float n.+1 v1))
                    (rev (vec_to_list_float n.+1 v2))) (Zconst ty 0, Zconst ty 0)).
  { rewrite combine_nth. rewrite !rev_nth !length_veclist.
    assert ((n.+1 - i.+1)%coq_nat = (n.+1.-1 - i)%coq_nat).
    { lia. } rewrite H0. rewrite !nth_vec_to_list_float; try by [].
    by rewrite size_map size_enum_ord in H.
    by rewrite size_map size_enum_ord in H.
    apply /ssrnat.ltP. by rewrite size_map size_enum_ord in H.
    apply /ssrnat.ltP. by rewrite size_map size_enum_ord in H.
    by rewrite !rev_length !length_veclist.
 } rewrite H0. apply nth_In. rewrite combine_length.
 rewrite !rev_length !length_veclist Nat.min_id.
 rewrite size_map size_enum_ord in H. by apply /ssrnat.ltP.
} specialize (Hfin Hin).
rewrite Bminus_bplus_opp_equiv.
+ assert ((FT2R (v1 (inord i) ord0) -  FT2R (v2 (inord i) ord0))%Re =
          (FT2R (v1 (inord i) ord0) +  FT2R (BOPP (v2 (inord i) ord0)))%Re ).
  { unfold FT2R. rewrite B2R_Bopp. nra. }
  rewrite H0.
  apply Rle_trans with
  (Rabs (FT2R (v1 (inord i) ord0) + (FT2R (BOPP (v2 (inord i) ord0)))) * (default_rel ty))%Re.
  - apply BPLUS_error_le_rel'.
    apply Hfin.
  - apply Rmult_le_compat_r.
    * apply default_rel_ge_0.
    * apply Rle_trans with
      [seq Rabs
          ((FT2R_mat v1 - FT2R_mat v2)%Ri i0
             0)
      | i0 <- enum 'I_n.+1]`_i.
      ++ rewrite seq_equiv. rewrite nth_mkseq;
         last by rewrite size_map size_enum_ord in H.
         rewrite !mxE. rewrite -RminusE.
         assert (FT2R (BOPP (v2 (inord i) ord0)) =
                  (- (FT2R (v2 (inord i) ord0)))%Re).
         { unfold FT2R. rewrite B2R_Bopp. nra. }
         rewrite H1. apply Rle_refl.
      ++ apply /RleP.
         apply (@bigmaxr_ler _ 0%Re [seq Rabs
                                           ((FT2R_mat v1 - FT2R_mat v2)%Ri i0
                                              0)
                                       | i0 <- enum 'I_n.+1] i).
         rewrite size_map size_enum_ord.
         by rewrite size_map size_enum_ord in H.
+ apply Hfin.
Qed.

End WITHNANS.


Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.ZArith.ZArith.
Require Import Bool.

Require Import util_fun_ind_equiv.
Require Import variables.
Require Import variables_fun_rules.
Require Import variables_fun_ind_equiv.
Require Import states.
Require Import states_fun_rules.
Require Import states_fun_ind_equiv.
Require Import functions.
Require Import functions_fun_rules.
Require Import functions_fun_ind_equiv.
Require Import trans_rel.
Require Import trans_rel_fun_rules.

Theorem lemm_well_typed_function_transition:
  forall (label : TRANS_LABEL) (O T : list (VNAME * TYPE)),
    well_typed_function_transition label O T <->
    bwell_typed_function_transition label O T = true.
Proof.
  intros. unfold well_typed_function_transition,
  bwell_typed_function_transition. split.
  - intros. rewrite lemm_list_in_list in H.
    + rewrite H. reflexivity.
    + intros. split.
      * intro. rewrite theo_string_dec in H0. apply H0.
      * intro. rewrite theo_string_dec. apply H0.
  - intros. destruct (blist_in_list (dom_fun [label])
        (map (fun x : VNAME * TYPE => fst x) O ++
         map (fun x : VNAME * TYPE => fst x) T)
        (fun v v' : VNAME => bstring_dec (vname v) (vname v'))) eqn:H1.
    + rewrite lemm_list_in_list.
      * apply H1.
      * intros. split.
        { intro. rewrite theo_string_dec in H0. apply H0. }
        { intro. rewrite theo_string_dec. apply H0. }
    + inversion H.
Qed.

Theorem theo_n_n:
  forall (n : nat),
    n =? n = true.
Proof.
  intros. rewrite Nat.eqb_eq. reflexivity.
Qed.

Theorem lemm_well_typed_delay_transition:
  forall (label : TRANS_LABEL) (I : list (VNAME * TYPE)),
    well_typed_delay_transition label I <->
    bwell_typed_delay_transition label I = true.
Proof.
  intros. unfold well_typed_delay_transition,
  bwell_typed_delay_transition. split.
  - intros. destruct H. rewrite lemm_list_in_list in H0.
    + rewrite H0. rewrite H. simpl.
      destruct (length (dom_del label)) eqn:H1.
      * rewrite <- H. simpl. reflexivity.
      * rewrite <- H. simpl. induction n.
        { simpl. reflexivity. }
        { simpl. rewrite theo_n_n. simpl. reflexivity. }
    + intros. split.
      * intro. rewrite theo_string_dec in H1. apply H1.
      * intro. rewrite theo_string_dec. apply H1.
  - intros. split.
    + destruct ((length (dom_del label) =?
       length (map (fun x : VNAME * TYPE => vname (fst x)) I)) &&
      blist_in_list (dom_del label)
        (map (fun x : VNAME * TYPE => vname (fst x)) I)
        (fun v v' : NAME => bstring_dec v v')) eqn:H1.
      * rewrite andb_true_iff in H1. destruct H1.
        rewrite Nat.eqb_eq in H0. apply H0.
      * inversion H.
    + destruct ((length (dom_del label) =?
       length (map (fun x : VNAME * TYPE => vname (fst x)) I)) &&
      blist_in_list (dom_del label)
        (map (fun x : VNAME * TYPE => vname (fst x)) I)
        (fun v v' : NAME => bstring_dec v v')) eqn:H1.
      * rewrite andb_true_iff in H1. destruct H1.
        rewrite lemm_list_in_list.
        { apply H1. }
        { intros. split.
          - intro. rewrite <- theo_string_dec. apply H2.
          - intro. rewrite theo_string_dec. apply H2. }
      * inversion H.
Qed.

Theorem lemm_ranDiscrete:
  forall (label : TRANS_LABEL),
    ranDiscrete label <->
    branDiscrete label = true.
Proof.
  intros. split.
  - induction label.
    + intro. simpl in H. inversion H.
    + intro. simpl. destruct (fst p). reflexivity.
  - induction label.
    + intro. simpl in H. inversion H.
    + intro. simpl. destruct (fst p). reflexivity.
Qed.

Theorem lemm_clock_compatible_transition:
  forall (label : TRANS_LABEL) (gcvar : (NAME * TYPE)),
    clock_compatible_transition label gcvar <->
    bclock_compatible_transition label gcvar = true.
Proof.
  intros. unfold clock_compatible_transition,
  bclock_compatible_transition. split.
  - intro. destruct (branDiscrete label) eqn:H1.
    + rewrite <- lemm_eq_type. apply H. rewrite lemm_ranDiscrete.
      apply H1.
    + reflexivity.
  - intros. destruct (branDiscrete label) eqn:H1.
    + rewrite lemm_eq_type. apply H.
    + rewrite lemm_ranDiscrete in H0. rewrite H0 in H1. inversion H1.
Qed.

Theorem lemm_ranDel:
  forall (label : TRANS_LABEL),
    ranDel label <->
    branDel label = true.
Proof.
  intros. split.
  - induction label.
    + intro. simpl in H. inversion H.
    + intro. simpl. reflexivity.
  - induction label.
    + intro. simpl in H. inversion H.
    + intro. simpl. reflexivity.
Qed.

Theorem lemm_ranFun:
  forall (label : TRANS_LABEL),
    ranFun label <->
    branFun label = true.
Proof.
  intros. split.
  - induction label.
    + intro. simpl. reflexivity.
    + intro. simpl in H. inversion H.
  - induction label.
    + intro. simpl. reflexivity.
    + intro. simpl in H. inversion H.
Qed.

Theorem lemm_well_typed_transition:
  forall (label : TRANS_LABEL) (I O T : list (VNAME * TYPE))
  (gcvar : (NAME * TYPE)),
    well_typed_transition label I O T gcvar <->
    bwell_typed_transition label I O T gcvar = true.
Proof.
  intros. unfold well_typed_transition,
  bwell_typed_transition. split.
  - intros. destruct H. destruct H0.
    rewrite lemm_ranFun in H. rewrite andb_true_iff.
    rewrite andb_true_iff. split.
    + split.
      * destruct (branFun label).
        { rewrite <- lemm_well_typed_function_transition.
          apply H. reflexivity. }
        { reflexivity. }
      * rewrite lemm_ranDel in H0. destruct (branDel label).
        { rewrite <- lemm_well_typed_delay_transition.
          apply H0. reflexivity. }
        { reflexivity. }
    + rewrite lemm_clock_compatible_transition in H1.
      apply H1.
  - intros. rewrite andb_true_iff in H. rewrite andb_true_iff in H.
    destruct H. destruct H. split.
    + intro. destruct (branFun label) eqn:H3.
      * rewrite lemm_well_typed_function_transition. apply H.
      * rewrite lemm_ranFun in H2. rewrite H3 in H2. inversion H2.
    + split.
      * intro. destruct (branDel label) eqn:H3.
        { rewrite lemm_well_typed_delay_transition. apply H1. }
        { rewrite lemm_ranDel in H2. rewrite H3 in H2. inversion H2. }
      * rewrite lemm_clock_compatible_transition.
        apply H0.
Qed.

Theorem lemm_check_same_state_start:
  forall (trans : list TRANS) (tr : TRANS),
    check_same_state_start trans tr <->
    bcheck_same_state_start trans tr = true.
Proof.
  intros. split.
  - induction trans.
    + simpl. reflexivity.
    + simpl. intro. destruct (beq_state (fst3 (STS a)) (fst3 (STS tr))).
      * destruct H.
        { destruct H. rewrite orb_true_iff. left.
          rewrite andb_true_iff. split.
          - rewrite lemm_ranFun in H. apply H.
          - rewrite lemm_ranFun in H0. apply H0. }
        { destruct H. rewrite orb_true_iff. right.
          rewrite andb_true_iff. split.
          - rewrite lemm_ranDel in H. apply H.
          - rewrite lemm_ranDel in H0. apply H0. }
      * apply IHtrans. apply H.
  - induction trans.
    + simpl. reflexivity.
    + simpl. intro. destruct (beq_state (fst3 (STS a)) (fst3 (STS tr))).
      * rewrite orb_true_iff in H. destruct H.
        rewrite andb_true_iff in H. destruct H.
        left. split.
        { rewrite lemm_ranFun. apply H. }
        { rewrite lemm_ranFun. apply H0. }
        { right. split.
          - rewrite andb_true_iff in H. destruct H.
            rewrite lemm_ranDel. apply H.
          - rewrite andb_true_iff in H. destruct H.
            rewrite lemm_ranDel. apply H0. }
      * apply IHtrans. apply H.
Qed.

Theorem lemm_is_valid_trans:
  forall (trans : list TRANS),
    is_valid_trans trans <->
    bis_valid_trans trans = true.
Proof.
  intros. split.
  - induction trans.
    + simpl. reflexivity.
    + simpl. intro. destruct H. destruct H.
      destruct H1. destruct H2.
      rewrite lemm_eq_state in H. apply not_true_is_false in H.
      rewrite H. simpl. rewrite theo_rules_state in H1.
      rewrite theo_rules_state in H2.
      rewrite lemm_check_same_state_start in H3.
      rewrite H1; rewrite H2; rewrite H3; simpl.
      apply IHtrans. apply H0.
  - induction trans.
    + simpl. reflexivity.
    + simpl. intro. destruct ((beq_state (fst3 (STS a)) (trd3 (STS a)))) eqn:H0.
      * simpl in H. inversion H.
      * simpl in H. destruct (fun_rules_state (state (fst3 (STS a))) &&
      fun_rules_state (state (trd3 (STS a))) &&
      bcheck_same_state_start trans a) eqn:H1.
        { split.
          - split.
            + unfold not. rewrite lemm_eq_state. rewrite H0. intro. inversion H2.
            + split.
              * rewrite andb_true_iff in H1. rewrite andb_true_iff in H1.
                destruct H1. destruct H1. rewrite theo_rules_state. apply H1.
              * split.
                { rewrite andb_true_iff in H1. rewrite andb_true_iff in H1.
                destruct H1. destruct H1. rewrite theo_rules_state. apply H3. }
                { rewrite andb_true_iff in H1. rewrite andb_true_iff in H1.
                destruct H1. rewrite lemm_check_same_state_start. apply H2. }
          - apply IHtrans. apply H. }
        { inversion H. }
Qed.

(* DFRS_TRANSITION_RELATION *)
Theorem theo_rules_dfrs_trans_rel :
  forall (tr : TRANSREL),
    ind_rules_dfrs_trans_rel tr
    <-> fun_rules_dfrs_trans_rel tr = true.
Proof.
  intros. unfold ind_rules_dfrs_trans_rel, fun_rules_dfrs_trans_rel. split.
  - intro. rewrite lemm_is_valid_trans in H. apply H.
  - intro. rewrite lemm_is_valid_trans. apply H.
Qed.


From Bremen.theories.structure Require Import Song.
From Bremen.theories.physics Require Import SoundingObject Time.
Require Import QArith PArith.
Require Import List.
Import ListNotations.

Inductive transcription : Type :=
  transcript : sounding_object -> song -> transcription.

Definition is_right (t : transcription) : bool :=
  match t with | transcript so song =>
  andb
  (is_music so)
  (*nagyjából megegyezik a hossz *)
  (andb (Nat.leb (N.to_nat (song_duration_in_sec song) * 800) (length_in_msec so))
        (Nat.leb ((length_in_msec so) * 800) (N.to_nat (song_duration_in_sec song))))
  (*az egyek hangsúlyosak*)
  (*ugyanazok a dolgok szólnak időben ugyanott*)
  end.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.HoareLogic.ImperativeLanguage.
Require Import Logic.HoareLogic.ProgramState.
Require Import Logic.HoareLogic.BigStepSemantics.
Require Import Logic.HoareLogic.HoareTriple_BigStepSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelSingleNotation.
Import KripkeModelNotation_Intuitionistic.

Section soundness.

Existing Instance unit_kMD.

Context {P: ProgrammingLanguage}
        {MD: Model}
        {BSS: BigStepSemantics P model}
        {J: Join model}
        {R: Relation model}
        {po_R: PreOrder Krelation}
        {SA_BSS: SABigStepSemantics P model BSS}.

Context {L: Language} {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {SL: SeparationLanguage L} {SM: Semantics L MD} {kiSM: KripkeIntuitionisticSemantics L MD tt SM} {fsSM: FlatSemantics.SeparatingSemantics L MD tt SM}.

Lemma hoare_frame_partial_sound: forall c P Q F,
  triple_partial_valid P c Q ->
  triple_partial_valid (P * F) c (Q * F).
Proof.
  intros.
  unfold triple_partial_valid in *.
  intros m' _n' ? ?.
  rewrite FlatSemantics.sat_sepcon in H0.
  destruct H0 as [m [mf [? [? ?]]]].
  assert (SAFE: safe m c) by exact (H m Error H2).
  destruct (frame_property _ _ _ _ _ H0 H1) as [_n [nf [? [? ?]]]].
  destruct _n' as [| | n'].
  + inversion H5; subst.
    revert H6; apply SAFE.
  + auto.
  + rewrite FlatSemantics.sat_sepcon.
    inversion H5; subst.
    - exfalso; revert H6; apply SAFE.
    - rename x into n.
      exists n, nf.
      split; [| split]; auto.
      * apply (H m _ H2 H6).
      * eapply sat_mono; eauto.
Qed.

Lemma hoare_frame_total_sound: forall c P Q F,
  triple_total_valid P c Q ->
  triple_total_valid (P * F) c (Q * F).
Proof.
  intros.
  unfold triple_partial_valid in *.
  intros m' _n' ? ?.
  rewrite FlatSemantics.sat_sepcon in H0.
  destruct H0 as [m [mf [? [? ?]]]].
  assert (SAFE: safe m c) by exact (H m Error H2).
  assert (TERM: term_norm m c) by exact (conj (H m Error H2) (H m NonTerminating H2)).
  destruct (frame_property _ _ _ _ _ H0 H1) as [_n [nf [? [? ?]]]].
  destruct _n' as [| | n'].
  + inversion H5; subst.
    revert H6; apply SAFE.
  + inversion H5; subst.
    - revert H6; apply SAFE.
    - revert H6; apply TERM.
  + rewrite FlatSemantics.sat_sepcon.
    inversion H5; subst.
    - exfalso; revert H6; apply SAFE.
    - rename x into n.
      exists n, nf.
      split; [| split]; auto.
      * apply (H m _ H2 H6).
      * eapply sat_mono; eauto.
Qed.

End soundness.


Require Import TestSuite.admit.
Set Implicit Arguments.
Generalizable All Variables.

Polymorphic Record SpecializedCategory (obj : Type) := Build_SpecializedCategory' {
  Object :> _ := obj;
  Morphism' : obj -> obj -> Type;

  Identity' : forall o, Morphism' o o;
  Compose' : forall s d d', Morphism' d d' -> Morphism' s d -> Morphism' s d'
}.

Polymorphic Definition TypeCat : @SpecializedCategory Type
  := (@Build_SpecializedCategory' Type
                                  (fun s d => s -> d)
                                  (fun _ => (fun x => x))
                                  (fun _ _ _ f g => (fun x => f (g x)))).

Inductive GraphIndex := GraphIndexSource | GraphIndexTarget.
Polymorphic Definition GraphIndexingCategory : @SpecializedCategory GraphIndex.
Admitted.

Module success.
  Section SpecializedFunctor.
    Set Universe Polymorphism.
    Context `(C : @SpecializedCategory objC).
    Context `(D : @SpecializedCategory objD).
    Unset Universe Polymorphism.

    Polymorphic Record SpecializedFunctor
      := {
          ObjectOf' : objC -> objD;
          MorphismOf' : forall s d, C.(Morphism') s d -> D.(Morphism') (ObjectOf' s) (ObjectOf' d)
        }.
  End SpecializedFunctor.

  Polymorphic Definition UnderlyingGraph : SpecializedFunctor GraphIndexingCategory TypeCat.
  Admitted.
End success.

Module success2.
  Section SpecializedFunctor.
    Polymorphic Context `(C : @SpecializedCategory objC).
    Polymorphic Context `(D : @SpecializedCategory objD).

    Polymorphic Record SpecializedFunctor
      := {
          ObjectOf' : objC -> objD;
          MorphismOf' : forall s d, C.(Morphism') s d -> D.(Morphism') (ObjectOf' s) (ObjectOf' d)
        }.
  End SpecializedFunctor.

  Set Printing Universes.
  Polymorphic Definition UnderlyingGraph : SpecializedFunctor GraphIndexingCategory TypeCat.
  (* Toplevel input, characters 73-94:
Error:
The term "GraphIndexingCategory (* Top.563 *)" has type
 "SpecializedCategory (* Top.563 Set *) GraphIndex"
while it is expected to have type
 "SpecializedCategory (* Top.550 Top.551 *) ?7"
(Universe inconsistency: Cannot enforce Set = Top.551)). *)
  admit.
  Defined.
End success2.