Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import String Lists.List.
Import ListNotations.
Open Scope string.
Open Scope list.
From Utils Require Import Utils.
From Pyrosome Require Import Theory.Core Compilers.Compilers Elab.Elab Elab.ElabCompilers Tools.Matches.
From Pyrosome.Lang Require Import SimpleVSubst SimpleVCC SimpleVFixCC SimpleVCPSHeap SimpleUnit SimpleVCCHeap SimpleVCPS NatHeap.
Import Core.Notations.
Import CompilerDefs.Notations.
Require Coq.derive.Derive.

Definition ch8_def : lang :=
  {[l
      [s|
      -----------------------------------------------
        #"exp" srt
      ];
    [:| "n" : #"natural"
      -----------------------------------------------
      #"value" "n" : #"exp"
    ];
    [:| "n" : #"natural"
      -----------------------------------------------
      #"hvar" "n" : #"exp"
    ];
    [s|
      -----------------------------------------------
      #"cmd" srt
      ];
    [:|
       -----------------------------------------------
      #"skip" : #"cmd"
   ];
    [:|
        "x" : #"natural",
        "e" : #"exp"
        -----------------------------------------------
      #"assign" "x" "e" : #"cmd"
    ];
    [:|
        "cmd1" : #"cmd",
        "cmd2" : #"cmd"
      -----------------------------------------------
      #"seq" "cmd1" "cmd2" : #"cmd"
   ];
    [:| "e" : #"exp",
        "z" : #"cmd",
        "nz" : #"cmd"
      -----------------------------------------------
      #"if0" "e" "z" "nz" : #"cmd"
    ];
    [:| "e" : #"exp",
        "c" : #"cmd"
      -----------------------------------------------
      #"while" "e" "c" : #"cmd"
    ]
    ]}.

Derive ch8
       SuchThat (elab_lang_ext (heap++nat_lang) ch8_def ch8)
       As ch8_wf.
Proof. auto_elab. Qed.
#[export] Hint Resolve ch8_wf : elab_pfs.

(* Definition nat_eq_def : lang := *)
(*   {[l *)
(*     [s| "n" : #"natural", *)
(*         "m" : #"natural" *)
(*       ----------------------------------------------- *)
(*       #"eq" "n" "m" srt *)
(*     ]; *)
(*     [:| "n": #"natural" *)
(*       ----------------------------------------------- *)
(*       #"eq_0_0" : #"eq" #"0" #"0" *)
(*     ]; *)
(*     [:| "n": #"natural", "m": #"natural", *)
(*         "p" : #"eq" "n" "m" *)
(*       ----------------------------------------------- *)
(*       #"eq_1+" "p" : #"eq" (#"1+" "n") (#"1+" "m") *)
(*     ] *)
(*   ]}. *)

(* Derive nat_eq *)
(*        SuchThat (elab_lang_ext (nat_lang) nat_eq_def nat_eq) *)
(*        As nat_eq_wf. *)
(* Proof. auto_elab. Qed. *)
(* #[export] Hint Resolve nat_eq_wf : elab_pfs. *)

Definition ch8_config_def : lang :=
  {[l
    [s|
      -----------------------------------------------
      #"configuration" srt
    ];
    [:| "H" : #"heap",
        "c" : #"cmd"
      -----------------------------------------------
      #"config" "H" "c" : #"configuration"
    ];
    [:= "c" : #"cmd"
      ----------------------------------------------- ("ss_seq_skip")
      #"seq" #"skip" "c" ="c" : #"cmd"
    ];
    [:= "c" : #"cmd"
      ----------------------------------------------- ("ss_skip_seq")
      #"seq" "c" #"skip" = "c" : #"cmd"
    ];
    [:= "H" : #"heap",
        "v" : #"natural",
        "x" : #"natural",
        "c" : #"cmd"
      ----------------------------------------------- ("ss_seq_assign")
      #"config" "H" (#"seq" (#"assign" "x" (#"value" "v")) "c")
      = #"config" (#"hset" "H" "x" "v") "c" : #"configuration"
    ];
    [:= "e" : #"exp",
        "z" : #"cmd",
        "nz" : #"cmd",
        "c" : #"cmd",
        "n" : #"natural"
      ----------------------------------------------- ("ss_seq_if_nonzero")
      #"seq" (#"if0" (#"value" (#"1+" "n"))"z" "nz") "c"
      = #"seq" "nz" "c" : #"cmd"
    ];
    [:= "e" : #"exp",
        "z" : #"cmd",
        "nz" : #"cmd",
        "c" : #"cmd"
      ----------------------------------------------- ("ss_seq_if_zero")
      #"seq" (#"if0" (#"value" #"0") "z" "nz") "c"
      = #"seq" "z" "c" : #"cmd"
    ];
    [:= "e" : #"exp",
        "c1" : #"cmd",
        "c2" : #"cmd",
        "n" : #"natural"
      ----------------------------------------------- ("ss_seq_while_true")
      #"seq" (#"while" "e" "c1") "c2"
      = #"seq" (#"if0" "e" #"skip" (#"seq" "c1" (#"while" "e" "c1") )) "c2"
      : #"cmd"
    ];
    [:= "c1" : #"cmd",
        "c2" : #"cmd",
        "c3" : #"cmd"
      ----------------------------------------------- ("ss_seq_seq")
      #"seq" (#"seq" "c1" "c2") "c3"
      = #"seq" "c1" (#"seq" "c2" "c3") : #"cmd"
    ]
  ]}.

Derive ch8_config
       SuchThat (elab_lang_ext (ch8 ++ heap++nat_lang) ch8_config_def ch8_config)
       As ch8_config_wf.
Proof.  auto_elab. Qed.
#[export] Hint Resolve ch8_config_wf : elab_pfs.

Definition ch8_ectx_def : lang :=
  {[l
    [s|
      -----------------------------------------------
      #"Ectx" srt
    ];
    [:|
       -----------------------------------------------
      #"[ ]" : #"Ectx"
    ];
    [s|
      -----------------------------------------------
      #"Cctx" srt
    ];
    [:| "x" : #"natural",
        "E" : #"Ectx"
        -----------------------------------------------
        #"Eassign" "x" "E" : #"Cctx"
    ];
    [:| "E" : #"Ectx",
        "z" : #"cmd",
        "nz" : #"cmd"
      -----------------------------------------------
      #"Eif0" "E" "z" "nz" : #"Cctx"
    ];
    (* Note: including this is incorrect
    [:| "E" : #"Ectx",
        "c" : #"cmd"
      -----------------------------------------------
      #"Ewhile" "E" "c" : #"Cctx"
    ];*)
    [:| "C" : #"Cctx",
        "c" : #"cmd"
      -----------------------------------------------
      #"Eseq" "C" "c" : #"Cctx"
    ];
    [:| "C" : #"Cctx",
        "e" : #"exp"
      -----------------------------------------------
      #"Cplug" "C" "e" : #"cmd"
    ];
    [:| "E" : #"Ectx",
        "e" : #"exp"
      -----------------------------------------------
      #"Eplug" "E" "e" : #"exp"
    ];
    [:= "e" : #"exp"
      ----------------------------------------------- ("Eplug hole")
      #"Eplug" #"[ ]" "e" = "e" : #"exp"
    ];
    [:= "x" : #"natural",
        "E" : #"Ectx",
        "e" : #"exp"
      ----------------------------------------------- ("Cplug assign")
      #"Cplug" (#"Eassign" "x" "E") "e" = #"assign" "x" (#"Eplug" "E" "e") : #"cmd"
    ];
    [:= "E" : #"Ectx",
        "z" : #"cmd",
        "nz" : #"cmd",
        "e" : #"exp"
      ----------------------------------------------- ("Cplug if0")
      #"Cplug" (#"Eif0" "E" "z" "nz") "e" = #"if0" (#"Eplug" "E" "e") "z" "nz" : #"cmd"
    ];(*
    [:= "E" : #"Ectx",
        "c" : #"cmd",
        "e" : #"exp"
      ----------------------------------------------- ("Cplug while")
      #"Cplug" (#"Ewhile" "E" "c") "e" = #"while" (#"Eplug" "E" "e") "c" : #"cmd"
    ];*)
    [:= "C" : #"Cctx",
        "c" : #"cmd",
        "e" : #"exp"
      ----------------------------------------------- ("Cplug seq")
      #"Cplug" (#"Eseq" "C" "c") "e" = #"seq" (#"Cplug" "C" "e") "c" : #"cmd"
    ];
    [:= "H" : #"heap",
        "C" : #"Cctx",
        "n" : #"natural"
      ----------------------------------------------- ("plug hvar lookup")
      #"config" "H" (#"Cplug" "C" (#"hvar" "n")) =
           #"config" "H" (#"Cplug" "C" (#"value" (#"lookup" "H" "n"))) : #"configuration"
    ]
  ]}.

Derive ch8_ectx
       SuchThat (elab_lang_ext (ch8_config ++ ch8 ++ heap++nat_lang) ch8_ectx_def ch8_ectx)
       As ch8_ectx_wf.
Proof.  auto_elab. Qed.
#[export] Hint Resolve ch8_ectx_wf : elab_pfs.

(* blk [... ; ~unit] *)
Definition jmp_hd :=
  {{e #"jmp" #"hd" #"tt" }}.

(*
 c2 : blk [~unit]
 c1 : blk [... ; ~unit]
 blk [... ; ~unit] *)
Definition seq c1 c2 :=
  {{e #"blk_subst" (#"snoc" #"wkn" (#"closure" #"unit" (#"blk_subst" (#"snoc" #"wkn" (#".1" #"hd")) {c2}) #"hd")) {c1} }}.

(* env ([~unit]) *)
Definition cmd_env :=
  {{e #"ext" #"emp" (#"neg" #"unit")}}.

(* env ([~nat]) *)
Definition exp_env :=
  {{e #"ext" #"emp" (#"neg" #"nat")}}.

(* e : blk [... ; ~nat]
   c : blk [(A ; nat)]
   blk [... ; A] *)
Definition plug_exp e c :=
  {{e #"blk_subst"
      (#"snoc" #"wkn" (#"closure" #"nat" {c} #"hd"))
      {e} }}.

(* x : natural
   e : blk [... ; ~nat]
   blk [... ; ~unit] *)
Definition assign x e :=
  plug_exp e {{e #"set" (#"nv" {x}) (#".2" #"hd") (#"jmp" (#".1" #"hd") #"tt")}}.

(* e : blk [~nat]
   z : blk [~unit]
   nz : blk[~unit]
   blk [... ; ~unit] *)
Definition if0 e z nz :=
  plug_exp e {{e #"if0" (#".2" #"hd") (#"blk_subst" (#"snoc" #"wkn" (#".1" #"hd")) {z}) (#"blk_subst" (#"snoc" #"wkn" (#".1" #"hd")) {nz}) }}.

(* e : blk [... ; ~nat]
   c : blk [... ; ~unit]
   blk [... ; ~unit] *)
Definition while e c :=
  {{e #"jmp" (#"fix"
               (#"closure"
                 (#"prod" (#"neg" #"unit") #"unit")
                 {plug_exp (* blk [(~unit, (~unit, unit))] *)
                    e
                    {{e #"if0" (#".2" #"hd") (* blk [((~unit, (~unit, unit)), nat)] *)
                        (#"jmp" (#".1" (#".1" #"hd")) #"tt")
                        (#"blk_subst" (#"snoc" #"wkn" (#".1" (#".2" (#".1" #"hd")))) {c})
                    }}
                 }
                 #"hd"))
      #"tt"
  }}.

(* b : blk [... ; ~nat]
   val [...] ~~nat *)
Definition blk_to_val b :=
  {{e #"closure" (#"neg" #"nat") (#"blk_subst" (#"snoc" #"wkn" (#".2" #"hd")) {b}) #"tt"}}.

(* E : blk [A x nat]
   e : blk [~nat]
   blk [A]

E[e] = e[/g/]
where g : [A] => [~nat]
g = snoc id v
where v : val [A] ~nat
v = clo <b,hd>
where b : [A x nat]
b = E[(0,1)/0]

E[e] = e[/<id,clo<E[(0,1)/0],hd>>/]
 *)
Definition plug E e :=
  {{e #"blk_subst" (#"snoc" #"wkn" (#"closure" #"nat" {E} #"hd"))
      {e} }}.

Definition plug_Ectx e c :=
  {{e #"blk_subst"
      (#"snoc" #"wkn" (#"pair" (#"closure" #"nat" {c} (#".1" #"hd")) (#".2" #"hd")))
      {e} }}.

(* e : blk [A x ~nat]
   z : blk [~unit]
   nz : blk[~unit]
   blk [... ; ~unit] *)
Definition Eif0 E z nz :=
  plug_Ectx E {{e #"if0" (#".2" #"hd") (#"blk_subst" (#"snoc" #"wkn" (#".1" #"hd")) {z}) (#"blk_subst" (#"snoc" #"wkn" (#".1" #"hd")) {nz}) }}.

(*
(* E : blk [ ~nat x nat]
   c : blk [... ; ~unit]
   blk [... ; ~unit x nat] *)
Definition Ewhile E c :=
  {{e #"jmp" (#"fix"
                (#"closure"
                   (#"prod" (#"neg" #"unit") #"unit")
                   (*
                     [(~unit * nat) * (~unit * unit)]
                    *)
                   (#"blk_subst"
                      (#"snoc" #"wkn"
                         (#"pair" (#"closure" #"nat"
                                     (*
                                        [(k : ~unit * loop : ~unit ) * nat]
                                      *)
                                     (#"if0" (#".2" #"hd") (* blk [((~unit, (~unit, unit)), nat)] *)
                                        (#"jmp" (#".1" (#".1" #"hd")) #"tt")
                                        (#"blk_subst" (#"snoc" #"wkn" (#".2" (#".1" #"hd"))) {c}))
                                     (#"pair" (#".1" (#".1" #"hd")) (#".1" (#".2" #"hd"))))
                            (#".2" (#".1" #"hd")) ))
                      {E})
                   #"hd"))
      #"tt"
  }}.
*)
   (*   {{e #"jmp" (#"fix"
                   (#"closure"
                     (#"prod" (#"neg" #"unit") #"unit")
                     (#"blk_subst" (* [((~nat, ~~nat), (~unit, unit))] *)
                       (#"snoc"
                         (#"snoc" #"forget"
                           (#"closure" #"nat"
                             (#"if0" (#".2" #"hd")
                               (#"jmp" (#".1" (#".1" (#".1" #"hd"))) #"tt")
                               (#"blk_subst" (#"snoc" #"wkn" (#".1" (#".2" (#".1" #"hd")))) "c")
                             )
                             #"hd"
                           )
                         )
                         (#".2" (#".1" #"hd"))
                       )
                       "E"
                     )
                     (#"pair" (#"val_subst" #"wkn" #"hd") #"hd")
                   )
                 )
          #"tt"
  }}*)

(* x : natural
   e : blk [... ; ~nat]
   blk [... ; ~unit] *)
Definition Eassign x e :=
  plug_Ectx e {{e #"set" (#"nv" {x}) (#".2" #"hd") (#"jmp" (#".1" #"hd") #"tt")}}.

Definition ch8_cc_def : compiler :=
  match # from (ch8_ectx ++ ch8_config ++ ch8 ++ heap ++ nat_lang) with
  | {{s #"exp"}} => {{s #"blk" {exp_env} }}
  | {{s #"cmd"}} => {{s #"blk" {cmd_env} }}
  | {{s #"configuration"}} => {{s #"configuration" {cmd_env} }}
  | {{s #"Ectx"}} => {{s #"blk" (#"ext" #"emp" (#"prod" (#"neg" #"nat") #"nat")) }}
  | {{s #"Cctx"}} => {{s #"blk" (#"ext" #"emp" (#"prod" (#"neg" #"unit") #"nat")) }}
  | {{e #"value" "n"}} => {{e #"jmp" #"hd" (#"nv" "n")}}
  | {{e #"hvar" "n"}} => {{e  #"get" (#"nv" "n") (#"jmp" (#"val_subst" #"wkn" #"hd") #"hd")}}
  | {{e #"skip"}} => jmp_hd
  | {{e #"assign" "x" "e" }} => assign {{e "x"}} {{e "e"}}
  | {{e #"seq" "cmd1" "cmd2"}} => seq {{e "cmd1"}} {{e "cmd2"}}
  | {{e #"if0" "e" "z" "nz"}} => if0 {{e "e"}} {{e "z"}} {{e "nz"}}
  | {{e #"while" "e" "c"}} => while {{e "e"}} {{e "c"}}
  | {{e #"config" "H" "c"}} => {{e #"config" "H" "c"}}
  | {{e #"[ ]"}} => {{e #"jmp" (#".1" #"hd") (#".2" #"hd") }}
  | {{e #"Eassign" "x" "E"}} => Eassign {{e "x"}} {{e "E"}}
  | {{e #"Eif0" "E" "z" "nz"}} => Eif0 {{e "E"}} {{e "z"}} {{e "nz"}}
  (*| {{e #"Ewhile" "E" "c"}} => Ewhile {{e "E"}} {{e "c"}}*)
  | {{e #"Eseq" "E" "cmd2"}} =>
      {{e #"blk_subst" (#"snoc" #"wkn"
                          (#"pair" (#"closure" #"unit"
                                      (#"blk_subst" (#"snoc" #"wkn" (#".1" #"hd")) "cmd2") (#".1" #"hd"))
                             (#".2" #"hd")))
          "E" }}
  | {{e #"Cplug" "C" "e"}} => plug {{e "C"}} {{e "e"}}
  | {{e #"Eplug" "E" "e"}} => plug {{e "E"}} {{e "e"}}
  end.

Notation target_lang :=
(fix_cc_lang ++ heap_cps_ops ++cc_lang ++ forget_eq_wkn ++ unit_eta ++ unit_lang
                                ++ heap ++ nat_exp ++ nat_lang ++ prod_cc ++
                                forget_eq_wkn'++
                                cps_prod_lang ++ block_subst ++ value_subst).

Ltac try_term_cong :=
  repeat (try (term_cong; repeat (try apply eq_args_cons); try apply eq_args_nil; simpl; try term_refl; let n := numgoals in guard n <= 1)).

Ltac step_backward lang name :=
  eapply eq_term_trans;
  eapply eq_term_sym;
  try eredex_steps_with lang name;
  try_term_cong;
  eapply eq_term_sym.

Ltac reduce :=
  repeat (
      eapply eq_term_trans;
      (try cleanup_elab_after step_if_concrete);
      try_term_cong).

(*Use: `hide_implicits` shows the pre-elaboration terms,
  and `wysiwyg` shows the actual goal again.
 *)

Derive ch8_cc

       SuchThat (elab_preserving_compiler
                   []
                   target_lang
                   ch8_cc_def
                   ch8_cc
                   (ch8_ectx++ch8_config++ch8++heap++nat_lang))
       As ch8_cc_preserving.
Proof.
  auto_elab_compiler.

  Ltac clo_eta_cong :=
    eapply eq_term_trans;
    [ eapply eq_term_sym; now eredex_steps_with cc_lang "clo_eta"|];
    compute_eq_compilation;
    reduce_lhs;
    eapply eq_term_trans; cycle 1;
    [ now eredex_steps_with cc_lang "clo_eta"|];
    reduce_rhs;
    repeat (term_cong;
            unfold Model.eq_term;
            try term_refl;[]).

  - cleanup_elab_after eredex_steps_with heap "heap_comm".
  - cleanup_elab_after eredex_steps_with heap "lookup_miss".
  - cleanup_elab_after eredex_steps_with heap "lookup_empty".
  - compute_eq_compilation.
    reduce.
    eapply eq_term_sym.
    step_backward block_subst "blk_subst_id".
    step_backward value_subst "snoc_wkn_hd".
    step_backward cc_lang "clo_eta".
    reduce.
    eredex_steps_with unit_eta "unit eta".
  - compute_eq_compilation.
    Matches.reduce.
    repeat (term_cong; try term_refl;[]).
    (*TODO: expensive*)
    repeat clo_eta_cong.
    compute_eq_compilation.
    (*TODO: why aren't all unit terms reduced to tt?
    Matches.reduce.*)
    eredex_steps_with unit_eta "unit eta".
  - compute_eq_compilation.
    reduce.
    step_backward cc_lang "clo_eta".
    by_reduction.
  - compute_eq_compilation.
    Matches.reduce.
    repeat (term_cong; try term_refl;[]).
    repeat clo_eta_cong.
    eapply eq_term_trans.
    {
      term_cong;unfold Model.eq_term.
      - right; compute; reflexivity.
      - term_refl.
      - term_refl.
      - term_cong.
        + right; compute; reflexivity.
        + term_refl.
        + term_refl.
        + term_refl.
        + term_refl.
        + instantiate (1:= {{e #"hd" #"emp" (#"neg" #"nat") }}).
          unfold Model.eq_term.
          eapply eq_term_trans; cycle 1.
          {
            compute_eq_compilation.
            eredex_steps_with cc_lang "clo_eta".
          }
          compute_eq_compilation.
          term_cong.
          *term_refl.
          *term_refl.
          *term_refl.
          * unfold Model.eq_term.
            compute_eq_compilation.
            Matches.reduce.
            term_refl.
          * unfold Model.eq_term.
            compute_eq_compilation.
            Matches.reduce.
            term_refl.
      - term_refl.
    }
    Matches.by_reduction.
  - compute_eq_compilation.
    Matches.reduce.
    repeat (term_cong; try term_refl;[]).
    repeat clo_eta_cong.
    unfold Model.eq_term.
    compute_eq_compilation.
    term_refl.
  - compute_eq_compilation.
    Matches.reduce.
    repeat (term_cong; try term_refl;[]).
    repeat clo_eta_cong.
    term_refl.
    (*
  - compute_eq_compilation.
    Matches.reduce.
    admit Matches.reduce.
    repeat (term_cong; try term_refl;[]).
    repeat clo_eta_cong.
    unfold Model.eq_term.
    compute_eq_compilation.
    hide_implicits.
    term_refl.*)
  - compute_eq_compilation.
    Matches.reduce.
    repeat (term_cong; try term_refl;[]).
    repeat clo_eta_cong.
    term_refl.
  - compute_eq_compilation.
    Matches.reduce.
    unfold Model.eq_term.
    compute_eq_compilation.
    eapply eq_term_trans.
    {
      eredex_steps_with heap_cps_ops "eval get".
    }

    Matches.by_reduction.

    Unshelve.
    all: repeat Matches.t'.
Qed.
#[export] Hint Resolve ch8_cc_preserving : elab_pfs.


Require Import VST.msl.Extensionality.

Class NatDed (A: Type) := mkNatDed {
  andp: A -> A -> A;
  orp: A -> A -> A;
  exp: forall {T:Type}, (T -> A) -> A;
  allp: forall {T:Type}, (T -> A) -> A;
  imp: A -> A -> A;
  prop: Prop -> A;
  derives: A -> A -> Prop;
  pred_ext: forall P Q, derives P Q -> derives Q P -> P=Q;
  derives_refl: forall P, derives P P;
  derives_trans: forall P Q R, derives P Q -> derives Q R -> derives P R;
  TT := prop True;
  FF := prop False;
  andp_right:  forall X P Q:A, derives X P -> derives X Q -> derives X (andp P Q);
  andp_left1:  forall P Q R:A, derives P R -> derives (andp P Q) R;
  andp_left2:  forall P Q R:A, derives Q R -> derives (andp P Q) R;
  orp_left: forall P Q R, derives P R -> derives Q R -> derives (orp P Q) R;
  orp_right1: forall P Q R, derives P Q -> derives P (orp Q R);
  orp_right2: forall P Q R, derives P R -> derives P (orp Q R);
  exp_right: forall {B: Type} (x:B) (P: A) (Q: B -> A),
                        derives P (Q x) -> derives P (exp Q);
  exp_left: forall {B: Type} (P: B -> A) (Q: A),
                      (forall x, derives (P x) Q) -> derives (exp P) Q;
  allp_left: forall {B}(P: B -> A) x Q, derives (P x) Q -> derives (allp P) Q;
  allp_right: forall {B}(P: A) (Q: B -> A),  (forall v, derives P (Q v)) -> derives P (allp Q);
  imp_andp_adjoint: forall P Q R, derives (andp P Q) R <-> derives P (imp Q R);
  prop_left: forall (P: Prop) Q, (P -> derives TT Q) -> derives (prop P) Q;
  prop_right: forall (P: Prop) Q, P -> derives Q (prop P);
  prop_imp_prop_left: forall (P Q: Prop), derives (imp (prop P) (prop Q)) (prop (P -> Q));
  allp_prop_left: forall {B: Type} (P: B -> Prop), derives (allp (fun b => prop (P b))) (prop (forall b, P b))
(* not_prop_right: forall (P: A) (Q: Prop), (Q -> derives P FF) -> derives P (prop (not Q)) *)
}.

Instance LiftNatDed (A B: Type) {ND: NatDed B} : NatDed (A -> B) :=
 mkNatDed (A -> B)
    (*andp*) (fun P Q x => andp (P x) (Q x))
    (*orp*) (fun P Q x => orp (P x) (Q x))
    (*exp*) (fun {T} (F: T -> A -> B) (a: A) => exp (fun x => F x a))
    (*allp*) (fun {T} (F: T -> A -> B) (a: A) => allp (fun x => F x a))
    (*imp*) (fun P Q x => imp (P x) (Q x))
    (*prop*) (fun P x => prop P)
    (*derives*) (fun P Q => forall x, derives (P x) (Q x))
     _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _.
 intros; extensionality x; apply pred_ext; auto.
 intros; apply derives_refl.
 intros; eapply derives_trans; eauto.
 intros; eapply andp_right; eauto.
 intros; eapply andp_left1; eauto.
 intros; eapply andp_left2; eauto.
 intros; eapply orp_left; eauto.
 intros; eapply orp_right1; eauto.
 intros; eapply orp_right2; eauto.
 intros; eapply exp_right; eauto.
 intros; eapply exp_left; eauto.
 intros; eapply allp_left; eauto.
 intros; eapply allp_right; eauto.
 intros; split; intros;  eapply imp_andp_adjoint; eauto.
 intros; eapply prop_left; eauto.
 intros; eapply prop_right; eauto.
 intros; eapply prop_imp_prop_left; eauto.
 intros; eapply allp_prop_left; eauto.
Defined.

Delimit Scope logic with logic.
Local Open Scope logic.
Notation "P '|--' Q" := (derives P Q) (at level 80, no associativity).
Notation "'EX'  x ':' T ',' P " := (exp (fun x:T => P%logic)) (at level 65, x at level 99) : logic.
Notation "'ALL'  x ':' T  ',' P " := (allp (fun x:T => P%logic)) (at level 65, x at level 99) : logic.
Infix "||" := orp (at level 50, left associativity) : logic.
Infix "&&" := andp (at level 40, left associativity) : logic.
Notation "P '-->' Q" := (imp P Q) (at level 55, right associativity) : logic.
Notation "P '<-->' Q" := (andp (imp P Q) (imp Q P)) (at level 57, no associativity) : logic.
Notation "'!!' e" := (prop e) (at level 25) : logic.

Class SepLog (A: Type) {ND: NatDed A} := mkSepLog {
  emp: A;
  sepcon: A -> A -> A;
  wand: A -> A -> A;
  ewand: A -> A -> A;
  sepcon_assoc: forall P Q R, sepcon (sepcon P Q) R = sepcon P (sepcon Q R);
  sepcon_comm:  forall P Q, sepcon P Q = sepcon Q P;
  wand_sepcon_adjoint: forall (P Q R: A),  (sepcon P Q |-- R) <-> (P |-- wand Q R);
  sepcon_andp_prop: forall P Q R, sepcon P (!!Q && R) = !!Q && (sepcon P R);
  sepcon_derives: forall P P' Q Q' : A, P |-- P' -> Q |-- Q' -> sepcon P Q |-- sepcon P' Q';
  ewand_sepcon: forall (P Q R : A),  ewand (sepcon P Q) R = ewand P (ewand Q R);
  ewand_TT_sepcon: forall (P Q R: A),
                         andp (sepcon P Q) (ewand R TT) |--
                               sepcon (andp P (ewand R TT)) (andp Q (ewand R TT));
  exclude_elsewhere: forall P Q: A, sepcon P Q |-- sepcon (andp P (ewand Q TT)) Q;
  ewand_conflict: forall P Q R, sepcon P Q |-- FF -> andp P (ewand Q R) |-- FF
}.

Notation "P '*' Q" := (sepcon P Q) : logic.
Notation "P '-*' Q" := (wand P Q) (at level 60, right associativity) : logic.

Instance LiftSepLog (A B: Type) {NB: NatDed B}{SB: SepLog B} : SepLog (A -> B).
 apply (mkSepLog (A -> B) _ (fun rho => emp)
            (fun P Q rho => P rho * Q rho) (fun P Q rho => P rho -* Q rho)
            (fun P Q rho => ewand (P rho) (Q rho))).
 (* sepcon_assoc *) intros; extensionality rho; apply sepcon_assoc.
 (* sepcon_comm *) intros; extensionality rho; apply sepcon_comm.
 intros.  split. simpl. intuition.
    apply wand_sepcon_adjoint. auto.
    intro. intro rho.     apply <- wand_sepcon_adjoint; auto.
 simpl; intros. extensionality x. apply sepcon_andp_prop.
 simpl; intros; apply sepcon_derives; auto.
 simpl; intros; extensionality x; apply ewand_sepcon.
 simpl; intros; eapply ewand_TT_sepcon.
 simpl; intros; eapply exclude_elsewhere.
 simpl; intros; eapply ewand_conflict; eauto.
Defined.

Class ClassicalSep  (A: Type) {ND: NatDed A}{SL: SepLog A} := mkCS {
   sepcon_emp: forall P, P * emp = P
}.

Instance LiftClassicalSep (A B: Type)  {NB: NatDed B}{SB: SepLog B}{CB: ClassicalSep B} :
        ClassicalSep (A -> B).
 apply mkCS.
 intros. extensionality x. simpl. apply sepcon_emp.
Qed.

Definition  extensible {A}{ND: NatDed A}{SL: SepLog A}(P:A) := sepcon P TT |-- P.

Class IntuitionisticSep (A: Type) {ND: NatDed A}{SL: SepLog A} := mkIS {
   all_extensible: forall P, extensible P
}.

Instance LiftIntuitionisticSep (A B: Type)  {NB: NatDed B}{SB: SepLog B}{IB: IntuitionisticSep B} :
        IntuitionisticSep (A -> B).
 apply mkIS.
 intros. intro. simpl. apply all_extensible.
Qed.

Class Indir (A: Type) {ND: NatDed A} := mkIndir {
  later: A -> A;
  now_later: forall P: A, P |-- later P;
  later_K: forall P Q, later (P --> Q) |-- later P --> later Q;
  later_allp: forall T (F: T -> A),  later (allp F) = ALL x:T, later (F x);
  later_exp: forall T (F: T-> A), EX x:T, later (F x) |-- later (exp F);
  later_exp': forall T (any:T) F, later (exp F) = EX x:T, later (F x);
  later_imp: forall P Q,  later(P --> Q) = later P --> later Q;
  loeb: forall P,   later P |-- P ->  TT |-- P
}.

Notation "'|>' e" := (later e) (at level 30, right associativity): logic.

Instance LiftIndir (A: Type) (B: Type)  {NB: NatDed B}{IXB: Indir B} :
         @Indir (A -> B) (LiftNatDed A B).
 apply (mkIndir _ _ (fun P rho => later (P rho))); intros; simpl in *; intros.
 apply now_later.
 apply later_K.
 simpl; intros. extensionality rho. apply later_allp.
 simpl; intros. apply later_exp.
 simpl; intros. extensionality rho. apply later_exp'; auto.
 simpl; intros. extensionality rho. apply later_imp.
 simpl; intros. apply loeb; auto.
Defined.

Class SepIndir (A: Type) {NA: NatDed A}{SA: SepLog A}{IA: Indir A} := mkSepIndir {
  later_sepcon: forall P Q, |> (P * Q) = |>P * |>Q;
  later_wand: forall P Q, |> (P -* Q) = |>P -* |>Q;
  later_ewand: forall P Q, |> (ewand P Q) = ewand (|>P) (|>Q)
}.

Instance LiftSepIndir  (A: Type) (B: Type)  {NB: NatDed B} {SB: SepLog B}{IB: Indir B}{SIB: SepIndir B} :
     @SepIndir (A -> B) (LiftNatDed A B) (LiftSepLog A B) (LiftIndir A B).
 constructor.
 intros; simpl. extensionality rho.  apply later_sepcon.
 intros; simpl. extensionality rho.  apply later_wand.
 intros; simpl. extensionality rho.  apply later_ewand.
Defined.

Class CorableSepLog (A: Type) {ND: NatDed A}{SL: SepLog A}:= mkCorableSepLog {
  corable: A -> Prop;
  corable_prop: forall P, corable (!! P);
  corable_andp: forall P Q, corable P -> corable Q -> corable (P && Q);
  corable_orp: forall P Q, corable P -> corable Q -> corable (P || Q);
  corable_imp: forall P Q, corable P -> corable Q -> corable (P --> Q);
  corable_allp: forall {B: Type} (P:  B -> A), (forall b, corable (P b)) -> corable (allp P);
  corable_exp: forall {B: Type} (P:  B -> A), (forall b, corable (P b)) -> corable (exp P);
  corable_sepcon: forall P Q, corable P -> corable Q -> corable (P * Q);
  corable_wand: forall P Q, corable P -> corable Q -> corable (P -* Q);
  corable_andp_sepcon1: forall P Q R, corable P ->  (P && Q) * R = P && (Q * R)
}.

Instance LiftCorableSepLog (A: Type) (B: Type) {NB: NatDed B} {SB: SepLog B} {CSL: CorableSepLog B} : @CorableSepLog (A -> B) (LiftNatDed A B) (LiftSepLog A B).
  apply (@mkCorableSepLog _ _ _ (fun P => forall b, corable (P b))); intros; simpl in *; intros.
  + apply corable_prop.
  + apply corable_andp; auto.
  + apply corable_orp; auto.
  + apply corable_imp; auto.
  + apply corable_allp; auto.
  + apply corable_exp; auto.
  + apply corable_sepcon; auto.
  + apply corable_wand; auto.
  + extensionality b.
    apply corable_andp_sepcon1; auto.
Defined.

Class CorableIndir (A: Type) {ND: NatDed A}{SL: SepLog A}{CSL: CorableSepLog A}{ID: Indir A} :=
  corable_later: forall P, corable P -> corable (|> P).

Instance LiftCorableIndir (A: Type) (B: Type) {NB: NatDed B} {SB: SepLog B} {CSL: CorableSepLog B} {ID: Indir B} {CI: CorableIndir B}: @CorableIndir (A -> B) (LiftNatDed A B) (LiftSepLog A B) (LiftCorableSepLog A B) (LiftIndir A B).
  unfold CorableIndir; simpl; intros.
  apply corable_later; auto.
Defined.


(**
  Ciro Iván García López
  Tesis de Maestría
  Session Type Systems Verification
  Unam - 2021 set-reglas

  This file contains the tactis and Hint Db for the proofs.
*)

From Tmcod Require Import  Defs_Proposition.
From Tmcod Require Import  Defs_Process.
From Tmcod Require Import  Defs_Tactics.
From Tmcod Require Import  Defs_Context.

(**
*)
Inductive Disjoint_Sets : Context -> Context -> Prop := are_disjoint_lists :
forall (D F : Context),
  (forall (x : nat)(A B: Proposition), ~ ( ( (FName x:A) ∈ D )  /\ ( (FName x:B) ∈ F) ) ) -> (Disjoint_Sets D F).
#[global]
Hint Constructors Disjoint_Sets : Piull.

(**
*)
Inductive Good_Contexts : Context -> Context -> Context -> Process -> Prop := is_well_collected :
forall (D F G : Context)(P : Process),
  ( forall (x : nat), ( (x ∈ FVars P) -> ( exists (A : Proposition), (FName x:A) ∈ (D ∪ F ∪ G) ) )) /\
  ( (Disjoint_Sets D F) /\ (Disjoint_Sets D G) /\ (Disjoint_Sets F G) /\ (Injective D) /\ (Injective F) /\ (Injective G))
   -> (Good_Contexts D F G P).
#[global]
Hint Constructors Good_Contexts : Piull.

(**
*)
Reserved Notation "D ';;;'  F '!-' P ':::' G" (at level 60).
Inductive Inference : Process -> Context -> Context -> Context -> Prop :=

  | idr : forall ( D : Context )( x y : nat )( A : Proposition ),
    Collect D -> x <> y ->
    Good_Contexts D (Bld x A) (Bld y A) ([FName x ←→ FName y]) ->
    ( D ;;; (Bld x A) !- ([FName x ←→ FName y]) ::: (Bld y A) )

  | idl : forall ( D : Context )( x y : nat )( A : Proposition ),
    Collect D -> x <> y ->
    Good_Contexts D ( (Bld x A) ∪ (Bld y (A^⊥)) ) ø ([FName x ←→ FName y]) ->
    ( D ;;; ( (Bld x A) ∪ (Bld y (A^⊥)) ) !-  ([FName x ←→ FName y]) ::: ø  )

  | repr : forall ( D : Context )( x y : nat )( A : Proposition )( P : Process ),
    Collect D -> lc P -> x <> y ->
    Good_Contexts D ø (Bld y A) P ->
    Good_Contexts D ø (Bld x (!A)) (FName x !· (Close y P)) ->
    Fresh x D ->
    ( D ;;; ø !- P ::: (Bld y A) ) ->
    ( D ;;; ø !- (FName x !· (Close y P)) ::: (Bld x (!A)) )

  | repl : forall ( D F G : Context )( u x : nat )( A : Proposition )( P : Process ),
    IsClosing P u ->
    Collect D -> Collect F -> Collect G -> lc P -> u <> x ->
    ~( x ∈ (FVars P) ) -> ( u ∈ (FVars P) ) -> ( ( (FName u):A ) ∈ D ) ->
    Good_Contexts D F G P ->
    Good_Contexts (SMA D u A) ( (Bld x (!A)) ∪ F ) G ({x \ u }P) ->
    Fresh x (D ∪ F ∪ G) ->
    ( D ;;; F !- P ::: G ) ->
    ( (SMA D u A) ;;; ( (Bld x (!A)) ∪ F ) !- ({x \ u }P) ::: G )

  | wnotr : forall ( D F G : Context )( u x : nat )( A : Proposition )( P : Process ),
    IsClosing P u ->
    Collect D -> Collect G -> Collect F -> lc P -> u <> x ->
    ~( x ∈ (FVars P) ) -> ( u ∈ (FVars P) ) -> ( ( (FName u):A ) ∈ D ) ->
    Good_Contexts D F G P ->
    Good_Contexts (SMA D u A) F ( (Bld x (?(A ^⊥))) ∪ G ) ({x \ u }P) ->
    Fresh x (D ∪ F ∪ G) ->
    ( D ;;; F !- P ::: G ) ->
    ( (SMA D u A) ;;; F !- ({x \ u }P) ::: ( (Bld x (?(A ^⊥))) ∪ G ) )

  | wnotl : forall ( D : Context )( x y : nat )( A : Proposition )( P : Process ),
    Collect D -> lc P -> x <> y ->
    Good_Contexts D (Bld y A) ø P ->
    Good_Contexts D (Bld x (? A)) ø ( FName x !· (Close y P))  ->
    Fresh x D ->
    ( D ;;; (Bld y A) !- P ::: ø ) ->
    ( D ;;; (Bld x (? A)) !- ( FName x !· (Close y P)) ::: ø )

(*   | limpr : forall ( D F G: Context )( x y : nat )( A B : Proposition )( P : Process ),
    Collect D -> Collect F -> Collect G -> x <> y ->
    lc P ->
    Good_Contexts D ( (Bld y A) ∪ F ) ( (Bld x B) ∪ G )  P ->
    Good_Contexts D F ( (Bld x (A−∘B)) ∪ G ) (FName x · (Close y P)) ->
    ( D ;;; ( (Bld y A) ∪ F ) !- P ::: ( (Bld x B) ∪ G ) ) ->
    ( D ;;; F !- (FName x · (Close y P)) ::: ( (Bld x (A−∘B)) ∪ G ) )

  | limpl : forall ( D F G F' G': Context )( x y : nat )( A B : Proposition )( P Q: Process ),
    Collect D -> Collect F -> Collect G -> Collect F' -> Collect G' ->
    lc P  -> lc Q ->
    Good_Contexts D F ( (Bld y A) ∪ G )  P ->
    Good_Contexts D ( (Bld x B) ∪ F' ) G' Q ->
    Good_Contexts D ( (Bld x (A−∘B)) ∪ F ∪ F' ) ( G ∪ G') (ν Close y (FName x « FName y »· (P↓Q))) ->
    ( D ;;; F !- P ::: ( (Bld y A) ∪ G ) ) ->
    ( D ;;; ( (Bld x B) ∪ F' ) !- Q ::: G' ) ->
    ( D ;;; ( (Bld x (A−∘B)) ∪ F ∪ F' ) !- (ν Close y (FName x « FName y »· (P↓Q))) ::: ( G ∪ G') ) *)

  | rampr : forall ( D F G: Context )( x y : nat )( A B : Proposition )( P : Process ),
    Collect D -> Collect F -> Collect G -> lc P ->
    Good_Contexts D F ( (Bld x B) ∪ (Bld y A) ∪ G )  P ->
    Good_Contexts D F ( (Bld x (A⅋B)) ∪ G )  (FName x · (Close y P)) ->
    ( D ;;; F !- P ::: ( (Bld x B) ∪ (Bld y A) ∪ G ) ) ->
    ( D ;;; F !- (FName x · (Close y P)) ::: ( (Bld x (A⅋B)) ∪ G ) )

  | rampl  : forall ( D F G F' G': Context )( x y : nat )( A B : Proposition )( P Q: Process ),
    Collect D -> Collect F -> Collect G -> Collect F' ->
    Collect G' -> lc P  -> lc Q ->
    Good_Contexts D ( (Bld y A) ∪ F ) G  P ->
    Good_Contexts D ( (Bld x B) ∪ F') G' Q ->
    Good_Contexts D ( (Bld x (A⅋B)) ∪ F ∪ F' ) ( G ∪ G')  (ν Close y (FName x « FName y »· (P↓Q)) ) ->
    ( D ;;; ( (Bld y A) ∪ F ) !- P ::: G ) ->
    ( D ;;; ( (Bld x B) ∪ F' ) !- Q ::: G') ->
    ( D ;;; ( (Bld x (A⅋B)) ∪ F ∪ F' ) !-  (ν Close y (FName x « FName y »· (P↓Q)) ) ::: ( G ∪ G') )

  | otiml : forall ( D F G: Context )( x y : nat )( y : nat )( A B : Proposition )( P : Process ),
    Collect D -> Collect F -> Collect G -> lc P -> x <> y ->
    Good_Contexts D ( (Bld x B) ∪ (Bld y A) ∪ F ) G  P ->
    Good_Contexts D ( (Bld x (A⊗B)) ∪ F ) G  (FName x · Close y P) ->
    ( D ;;; ( (Bld x B) ∪ (Bld y A) ∪ F ) !- P ::: G ) ->
    ( D ;;; ( (Bld x (A⊗B)) ∪ F ) !- (FName x · Close y P) ::: G )

  | otimr  : forall ( D F G F' G': Context )( x y : nat )( A B : Proposition )( P Q: Process ),
    Collect D -> Collect F -> Collect G -> Collect F' ->
    Collect G' -> lc P  -> lc Q -> x <> y ->
    Good_Contexts D F ( (Bld y A) ∪ G ) P ->
    Good_Contexts D F' ((Bld x B) ∪ G')  Q ->
    Good_Contexts D (F ∪ F') ( (Bld x (A⊗B)) ∪ G ∪ G' )  (ν Close y ( FName x « FName y »· (P↓Q))) ->
    ( D ;;; F !- P ::: ( (Bld y A) ∪ G ) ) ->
    ( D ;;; F' !- Q ::: ( (Bld x B) ∪ G' ) ) ->
    ( D ;;; (F ∪ F') !- ν Close y ( FName x « FName y »· (P↓Q)) ::: ( (Bld x (A⊗B)) ∪ G ∪ G' ) )

  | perpr : forall ( D F G: Context )( x : nat )( P : Process ),
    Collect D -> Collect F -> Collect G -> lc P ->
    Good_Contexts D F G P ->
    Good_Contexts D F ( (Bld x ⊥) ∪ G ) (FName x ()· P) ->
    ( D ;;; F !- P ::: G ) ->
    ( D ;;; F !- (FName x ()· P) ::: ( (Bld x ⊥) ∪ G ) )

  | perpl : forall ( D : Context )( x : nat ),
    Collect D ->
    Good_Contexts D (Bld x ⊥) ø (FName x ·θ ) ->
    ( D ;;; (Bld x ⊥) !- (FName x ·θ ) ::: ø )

  | onel : forall ( D F G : Context )( x : nat )( P : Process ),
    Collect D -> Collect F -> Collect G -> lc P ->
    Good_Contexts D F G P ->
    Good_Contexts D ( (Bld x ¶) ∪ F ) G (FName x ()· P ) ->
    ( D ;;; F !- P ::: G ) ->
    ( D ;;; ( (Bld x ¶) ∪ F ) !- (FName x ()· P ) ::: G )

  | oner : forall ( D : Context)( x : nat ),
    Collect D ->
    Good_Contexts D ø (Bld x ¶)  (FName x ·θ ) ->
    ( D ;;; ø !- (FName x ·θ ) ::: (Bld x ¶) )

  | copyl : forall ( D F G : Context )( x u : nat )( P : Process )( A : Proposition ),
    Collect D -> Collect F -> Collect G -> lc P -> x <> u ->
    Good_Contexts ( (Bld u A) ∪ D ) ( (Bld x A) ∪ F ) G P ->
    Good_Contexts ( (Bld u A) ∪ D ) F G (ν Close x ( FName u « FName x »· P )) ->
    ( ( (Bld u A) ∪ D ) ;;; ( (Bld x A) ∪ F ) !- P ::: G ) ->
    ( ( (Bld u A) ∪ D ) ;;; F !- ν Close x ( FName u « FName x »· P ) ::: G )

  | copyr : forall ( D F G : Context )( x u : nat )( P : Process )( A : Proposition ),
    Collect D -> Collect F -> Collect G -> lc P -> x <> u ->
    Good_Contexts ( (Bld u A) ∪ D ) F ( (Bld x (A^⊥)) ∪ G ) P ->
    Good_Contexts ( (Bld u A) ∪ D ) F G (ν Close x ( FName u « FName x »· P )) ->
    ( ( (Bld u A) ∪ D ) ;;; F !- P ::: ( (Bld x (A^⊥)) ∪ G ) ) ->
    ( ( (Bld u A) ∪ D ) ;;; F !- ν Close x ( FName u « FName x »· P ) ::: G )

  | cutrep : forall ( D F G : Context )( P Q : Process )( A : Proposition )( x u : nat ),
    Collect D -> Collect F -> Collect G ->
    lc P -> lc Q -> x <> u ->
    Good_Contexts D ø (Bld x A) P ->
    Good_Contexts ( (Bld u A) ∪ D ) F G Q ->
    ( D ;;; ø !- P ::: (Bld x A) ) ->
    ( ( (Bld u A) ∪ D ) ;;; F !- Q ::: G )  ->
    ( D ;;; F !- ν Close u ((FName u !· Close x P) ↓ Q) ::: G )

  | cutwnot : forall ( D F G : Context )( P Q : Process )( A : Proposition )( x u : nat ),
    Collect D -> Collect F -> Collect G ->
    lc P -> lc Q ->  x <> u ->
    Good_Contexts D (Bld x (A^⊥)) ø P ->
    Good_Contexts ((Bld u A) ∪ D) F G Q ->
    Good_Contexts D F G (ν Close u ( ((FName u) !· Close x P) ↓ Q)) ->
    ( D ;;; (Bld x (A^⊥)) !- P ::: ø ) ->
    ( ((Bld u A) ∪ D) ;;; F !- Q ::: G ) ->
    ( D ;;; F !- (ν Close u ( ((FName u) !· Close x P) ↓ Q)) ::: G )

  | cutr : forall ( D F G F' G' : Context )( P Q : Process )( A : Proposition )( x : nat ),
    Collect D -> Collect F -> Collect G ->
    Collect F' -> Collect G' ->
    Good_Contexts D F ( (Bld x A) ∪ G ) P ->
    Good_Contexts D ( (Bld x A) ∪ F' ) G' Q ->
    lc P -> lc Q ->
    ( D ;;; F !- P ::: ( (Bld x A) ∪ G ) ) ->
    ( D ;;; ( (Bld x A) ∪ F' ) !- Q ::: G' ) ->
    ( D ;;; ( F ∪ F' ) !- ( ν Close x (P↓Q) ) ::: ( G ∪ G' ) )

  | cutl : forall ( D F G F' G' : Context )( P Q : Process )( A : Proposition )( x : nat ),
    Collect D -> Collect F -> Collect G ->
    Collect F' -> Collect G' ->
    Good_Contexts D ((Bld x A) ∪ F) G P ->
    Good_Contexts D ((Bld x (A^⊥)) ∪ F') G' Q ->
    lc P -> lc Q ->
    ( D ;;; ((Bld x A) ∪ F) !- P ::: G ) ->
    ( D ;;; ((Bld x (A^⊥)) ∪ F') !- Q ::: G' ) ->
    ( D ;;; (F ∪ F') !- ( ν Close x (P↓Q) ) ::: (G ∪ G') )

where "D ';;;'  F '!-' P ':::' G" := (Inference P D F G).
#[global]
Hint Constructors Inference : Piull.


(* -------------------------------------------------------------------- *)
(* This file content originates from the CoqEAL library.                *)
(*                                                                      *)
(*   https://github.com/coq-community/coqeal                            *)
(*                                                                      *)
(* The MIT License (MIT)                                                *)
(*                                                                      *)
(* Copyright (c) 2014  Guillaume Cano                                   *)
(* Copyright (c) 2014  Cyril Cohen                                      *)
(* Copyright (c) 2014  Maxime Dénès                                     *)
(* Copyright (c) 2014  Anders Mörtberg                                  *)
(* Copyright (c) 2014  Vincent Siles                                    *)
(* -------------------------------------------------------------------- *)

From mathcomp Require Import all_ssreflect all_algebra finmap.
From Bignums Require Import BigQ.
From Coq Require Import Uint63 PArray PArith PeanoNat.
From Polyhedra Require Import extra_misc inner_product vector_order.
Require Import extra_array extra_int refinement.

Import Order.Theory.

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

(* Code CoqEAL *)

Section Z2Int.

Definition Z2int (z : BinNums.Z) : ssrint.int :=
  match z with
  | Z0 => 0
  | Zpos p => ((Pos.to_nat p)%:Z)%R
  | Zneg n => (- (Pos.to_nat n)%:Z)%R
  end.

Definition int2Z (n : ssrint.int) : BinNums.Z :=
match n with
| Posz O => Z0
| Posz n => Zpos (Pos.of_nat n)
| Negz n => Zneg (Pos.of_nat n.+1)
end.

Lemma Z2int_inj x y : Z2int x = Z2int y -> x = y.
Proof.
rewrite /Z2int.
case x, y=>//.
{ move=>[] H.
  by rewrite -[Z0]/(BinInt.Z.of_nat 0%N) H Znat.positive_nat_Z. }
{ rewrite /GRing.opp /= /intZmod.oppz /=.
  case E: (Pos.to_nat _)=>//=; move: (Pos2Nat.is_pos p).
  by rewrite E => /ssrnat.ltP. }
{ by case; move/(congr1 BinInt.Z.of_nat); rewrite Znat.positive_nat_Z. }
{ by case; move/(congr1 BinInt.Z.of_nat); rewrite !Znat.positive_nat_Z. }
{ case E: (Pos.to_nat _)=>//=; case E': (Pos.to_nat _)=> //=.
  by move: (Pos2Nat.is_pos p); rewrite E; move/ssrnat.ltP. }
{ move/eqP; rewrite GRing.oppr_eq0=> /eqP; case=> E.
  by move/ssrnat.ltP: (Pos2Nat.is_pos p); rewrite E. }
{ case E: (Pos.to_nat _)=> //=.
  by move/ssrnat.ltP: (Pos2Nat.is_pos p); rewrite E.  }
{ move/GRing.oppr_inj; case=> /(congr1 BinInt.Z.of_nat).
  by rewrite !Znat.positive_nat_Z; case=> ->. }
Qed.

Lemma Z2int_opp n : Z2int (BinInt.Z.opp n) = (- (Z2int n))%R.
Proof. by case n=>// p /=; rewrite GRing.opprK. Qed.

Lemma Z2int_abs x : Z2int (BinInt.Z.abs x) = `|Z2int x|%nat.
Proof. by case: x => // p /=; rewrite abszN. Qed.

Lemma Z2int_add x y : Z2int (BinInt.Z.add x y) = (Z2int x + Z2int y)%R.
Proof.
case: x; case: y=> //=.
- by move=> ?; rewrite GRing.add0r.
- by move=> ?; rewrite GRing.addr0.
- by move=> ??; rewrite Pnat.Pos2Nat.inj_add.
- move=> q p; rewrite BinInt.Z.pos_sub_spec.
  case: BinPos.Pos.compare_spec=> /=.
  + move=> ->; by rewrite GRing.addrN.
  + move=> /[dup] /Pnat.Pos2Nat.inj_lt + /Pnat.Pos2Nat.inj_sub ->.
    rewrite !minusE=> /ssrnat.ltP pq.
    rewrite -subzn; last exact: ltnW.
    by rewrite GRing.opprB.
  + move=> /[dup] /Pnat.Pos2Nat.inj_lt + /Pnat.Pos2Nat.inj_sub ->.
    rewrite !minusE=> /ssrnat.ltP pq.
    by rewrite -subzn; last exact: ltnW.
- by move=> ?; rewrite GRing.addr0.
- move=> q p; rewrite BinInt.Z.pos_sub_spec.
  case: BinPos.Pos.compare_spec=> /=.
  + by move=> ->; rewrite GRing.addNr //.
  + move=> /[dup] /Pnat.Pos2Nat.inj_lt + /Pnat.Pos2Nat.inj_sub ->.
    rewrite !minusE=> /ssrnat.ltP pq.
    rewrite -subzn ?GRing.opprB; last exact: ltnW.
    by rewrite GRing.addrC.
  + move=> /[dup] /Pnat.Pos2Nat.inj_lt /ssrnat.ltP pq /Pnat.Pos2Nat.inj_sub ->.
    rewrite -subzn; last exact: ltnW.
    by rewrite GRing.addrC.
- move=> p q; rewrite Pnat.Pos2Nat.inj_add plusE PoszD.
  by rewrite -GRing.opprB GRing.opprK GRing.addrC.
Qed.

Lemma Z2int_mul_nat_of_pos (x : BinNums.Z) (y : positive) :
  (Z2int x * Pos.to_nat y)%R = Z2int (BinInt.Z.mul x (BinNums.Zpos y)).
Proof.
rewrite /Z2int; case Ex: x.
{ by rewrite GRing.mul0r BinInt.Z.mul_0_l. }
{ by rewrite /= Pos2Nat.inj_mul multE . }
by rewrite /= GRing.mulNr Pos2Nat.inj_mul multE.
Qed.

Lemma Z2int_mul x y : Z2int (BinInt.Z.mul x y) = (Z2int x * Z2int y)%R.
Proof.
case y=>/=.
{ by rewrite GRing.mulr0 BinInt.Z.mul_0_r. }
{ by move=> p; rewrite Z2int_mul_nat_of_pos. }
move=> p.
rewrite GRing.mulrN Z2int_mul_nat_of_pos -Z2int_opp.
by rewrite BinInt.Z.opp_eq_mul_m1 -BinInt.Z.mul_assoc -BinInt.Z.opp_eq_mul_m1 /=.
Qed.

Lemma divE x y : Nat.div x y = divn x y.
Proof.
case: y => [//|y].
rewrite /Nat.div.
move: (Nat.divmod_spec x y 0 y).
case: Nat.divmod => q r /(_ (le_n _)) [].
rewrite Nat.mul_0_r Nat.sub_diag !Nat.add_0_r Nat.mul_comm => + Hr /=.
rewrite multE minusE plusE => /(f_equal (fun x => divn x y.+1)) ->.
rewrite divnMDl // divn_small ?addn0 //.
rewrite ltn_subLR; [|exact/ssrnat.leP].
  by rewrite -addSnnS addnC addnS ltnS leq_addr.
Qed.

Lemma Z2int_div x y : BinInt.Z.le Z0 x -> BinInt.Z.le Z0 y ->
  Z2int (BinInt.Z.div x y) = divz (Z2int x) (Z2int y).
Proof.
Admitted.
(* case: x => [|x|//] _; [by rewrite intdiv.div0z|].
case: y => [|y|//] _; [by rewrite intdiv.divz0|].
rewrite -!Znat.positive_nat_Z -Znat.Nat2Z.inj_div.
rewrite !Znat.positive_nat_Z /= /divz gtr0_sgz ?mul1r; last first.
{ by move/ssrnat.ltP: (Pos2Nat.is_pos y). }
rewrite divE absz_nat /Z2int.
move: (Zorder.Zle_0_nat (Pos.to_nat x %/ Pos.to_nat y)).
rewrite -[X in _ = Posz X]Znat.Nat2Z.id mul1n.
by case: BinInt.Z.of_nat => //=.
Qed. *)

Lemma Z2int_le x y : (Z2int x <= Z2int y)%R <-> BinInt.Z.le x y.
Proof.
rewrite /Z2int; case Ex: x; case Ey: y=> //.
{ rewrite Num.Theory.oppr_ge0; split; move=> H; exfalso; move: H; [|by rewrite /BinInt.Z.le].
  apply/negP; rewrite -ltNge; exact/ssrnat.ltP/Pos2Nat.is_pos. }
{ split; move=> H; exfalso; move: H; [|by rewrite /BinInt.Z.le].
  apply/negP; rewrite -ltNge; exact/ssrnat.ltP/Pos2Nat.is_pos. }
{ rewrite /Num.Def.ler /=.
  by rewrite -!Znat.positive_nat_Z -Znat.Nat2Z.inj_le; split => /ssrnat.leP. }
{ split; move=> H; exfalso; move: H; [|by rewrite /BinInt.Z.le].
  apply /negP; rewrite -ltNge.
  apply: (@lt_trans _ _ 0%R); rewrite ?Num.Theory.oppr_lt0;
    apply/ssrnat.ltP/Pos2Nat.is_pos. }
{ rewrite Num.Theory.oppr_le0; split; by rewrite /BinInt.Z.le. }
{ split=>_; [by rewrite /BinInt.Z.le|].
  apply: (@le_trans _ _ 0%R); [apply Num.Theory.oppr_le0|apply ltW].
  exact/ssrnat.ltP/Pos2Nat.is_pos. }
rewrite Num.Theory.ler_opp2; split.
{ rewrite /BinInt.Z.le /BinInt.Z.compare /Num.Def.ler /= => /ssrnat.leP.
  by rewrite -Pos.compare_antisym -Pos2Nat.inj_le -Pos.compare_le_iff. }
rewrite /BinInt.Z.le /BinInt.Z.compare /Num.Def.ler /=.
rewrite -Pos.compare_antisym => H; apply/ssrnat.leP.
by rewrite -Pos2Nat.inj_le -Pos.compare_le_iff.
Qed.

Lemma Z2int_lt x y : (Z2int x < Z2int y)%R <-> BinInt.Z.lt x y.
Proof.
rewrite -lez_addr1 -[GRing.one _]/(Z2int BinInt.Z.one) -Z2int_add Z2int_le.
rewrite /BinInt.Z.one BinInt.Z.add_1_r; exact: BinInt.Z.le_succ_l.
Qed.

Lemma nat_of_pos_Z_to_pos x : Pos.to_nat x = `|Z2int (Zpos x)|%N.
Proof. by rewrite /absz /Z2int. Qed.

Lemma Zabs_natE n : BinInt.Z.abs_nat n = `|Z2int n|%N.
Proof.
case: n => //= p.
by rewrite abszN absz_nat.
Qed.

Lemma Z2int_Z_of_nat n : Z2int (BinInt.Z.of_nat n) = n.
Proof.
by case: n => //= n; rewrite Pos.of_nat_succ Nat2Pos.id.
Qed.

Lemma dvdnP m n : reflect
  (BinInt.Z.divide (BinInt.Z.of_nat m) (BinInt.Z.of_nat n)) (m %| n).
Proof.
apply: (iffP idP) => H.
{ rewrite dvdn_eq in H; rewrite -(eqP H) /BinInt.Z.divide; exists (BinInt.Z.of_nat (n %/ m)).
  by rewrite Znat.Nat2Z.inj_mul. }
{ have [q Hq] := H; apply/dvdnP; exists `|Z2int q|%N; apply/Znat.Nat2Z.inj.
  have [Zq|NZq] := ZArith_dec.Z_zerop q.
  { by rewrite Zq /= in Hq *. }
  case: m Hq H => [|m] Hq H.
  { by rewrite BinInt.Zmult_comm /= in Hq; rewrite mulnC /=. }
  rewrite Znat.Nat2Z.inj_mul -Zabs_natE Znat.Zabs2Nat.id_abs BinInt.Z.abs_eq //.
  (* have H0 : (0 <= BinInt.Z.mul q (BinInt.Z.of_nat m.+1)). by rewrite -Hq; apply Zorder.Zle_0_nat. *)
  apply: (Zorder.Zmult_le_0_reg_r (BinInt.Z.of_nat m.+1)).
  - apply/BinInt.Z.lt_gt; rewrite -/(BinInt.Z.of_nat 0).
    exact/Znat.inj_lt/ssrnat.ltP.
  - rewrite -Hq; exact: Zorder.Zle_0_nat. }
Qed.

Lemma ZgcdE n d : BinInt.Z.gcd n (Zpos d) =
  BinInt.Z.of_nat (div.gcdn `|Z2int n| (Pos.to_nat d)).
Proof.
apply: BinInt.Z.gcd_unique.
{ exact: Zorder.Zle_0_nat. }
{ apply/BinInt.Z.divide_abs_r; rewrite -Znat.Zabs2Nat.id_abs; apply/dvdnP.
  by rewrite Zabs_natE dvdn_gcdl. }
{ apply/BinInt.Z.divide_abs_r; rewrite -Znat.Zabs2Nat.id_abs; apply/dvdnP.
  by rewrite Zabs_natE /= dvdn_gcdr. }
move=> q Hn Hd; apply/BinInt.Z.divide_abs_l; rewrite -Znat.Zabs2Nat.id_abs; apply/dvdnP.
rewrite Zabs_natE dvdn_gcd.
apply/andP; split; apply/dvdnP; rewrite -!Zabs_natE !Znat.Zabs2Nat.id_abs.
{ by apply/BinInt.Z.divide_abs_l/BinInt.Z.divide_abs_r. }
{ by apply/BinInt.Z.divide_abs_l; rewrite Znat.positive_nat_Z. }
Qed.

Lemma ZgcdE' n m : BinInt.Z.gcd n m = BinInt.Z.of_nat (gcdn `|Z2int n| `|Z2int m|).
Proof.
case m.
{ rewrite BinInt.Z.gcd_0_r {2}/absz {2}/Z2int /= gcdn0 -Znat.Zabs2Nat.id_abs; f_equal.
  rewrite /BinInt.Z.abs_nat /absz /Z2int.
  case n=>// p; rewrite //.
  case (Pos.to_nat _); [by rewrite GRing.oppr0|move=> n'].
  by rewrite /GRing.opp /=. }
{ by move=> p; rewrite ZgcdE nat_of_pos_Z_to_pos. }
by move=> p; rewrite -BinInt.Z.gcd_opp_r /= ZgcdE abszN /absz.
Qed.

Lemma Z_ggcd_1_r n : BinInt.Z.ggcd n (Zpos 1) = (Zpos 1, (n, Zpos 1)).
Proof.
move: (BinInt.Z.ggcd_gcd n (Zpos 1)) (BinInt.Z.ggcd_correct_divisors n (Zpos 1)).
rewrite BinInt.Z.gcd_1_r.
case (BinInt.Z.ggcd _ _)=> g ab /= ->; case ab=> a b [].
by rewrite !BinInt.Z.mul_1_l => <- <-.
Qed.

Lemma Z_ggcd_coprime a b :
  let '(g, (a', b')) := BinInt.Z.ggcd a b in
  g <> Z0 -> coprime `|Z2int a'| `|Z2int b'|.
Proof.
move: (BinInt.Z.ggcd_gcd a b) (BinInt.Z.ggcd_correct_divisors a b).
case (BinInt.Z.ggcd _ _)=> g ab; case ab=> a' b' /= Hg [] Ha Hb Pg.
rewrite /coprime; apply/eqP /Znat.Nat2Z.inj; rewrite -ZgcdE' /=.
suff ->: a' = (BinInt.Z.div a g).
{ suff ->: b' = (BinInt.Z.div b g); [by apply BinInt.Z.gcd_div_gcd|].
  by rewrite Hb BinInt.Z.mul_comm Zdiv.Z_div_mult_full. }
by rewrite Ha BinInt.Z.mul_comm Zdiv.Z_div_mult_full.
Qed.

Lemma Z2int_lcm x y : BinInt.Z.le Z0 x -> BinInt.Z.le Z0 y ->
  Z2int (BinInt.Z.lcm x y) = lcmn `|Z2int x| `|Z2int y|.
Proof.
case: x => [|x|//] _; [by rewrite /= lcm0n|].
case: y => [|y|//] _; [by rewrite /= lcmn0|].
rewrite /BinInt.Z.lcm Z2int_abs Z2int_mul Z2int_div //.
rewrite ZgcdE' abszM; apply: f_equal; apply/eqP.
rewrite -(@eqn_pmul2r (gcdn `|Z2int (Zpos x)| `|Z2int (Zpos y)|)); last first.
{ rewrite gcdn_gt0; apply/orP; left; rewrite absz_gt0 /= eqz_nat.
  exact/lt0n_neq0/ssrnat.ltP/Pos2Nat.is_pos. }
rewrite muln_lcm_gcd.
rewrite -(absz_nat (gcdn _ _)) -mulnA -abszM.
rewrite Z2int_Z_of_nat /=.
  by rewrite intdiv.divzK // /mem /in_mem /intdiv.dvdz /= dvdn_gcdr.
Qed.

Lemma Z2int_Zpos_neq0 x: Z2int (Zpos x) != 0%R.
Proof.
rewrite /=; apply/negP=> /eqP; case=> E.
by move/ssrnat.ltP: (Pos2Nat.is_pos x); rewrite E.
Qed.

End Z2Int.

Section BigQRat.

Definition bigQ2rat_def (bq : bigQ) :=
  let q := Qreduction.Qred [bq]%bigQ in
  ((Z2int (QArith_base.Qnum q))%:Q / (Z2int (Zpos (QArith_base.Qden q)))%:Q)%R.

Definition rat_bigQ (b : bigQ) (r : rat) := bigQ2rat_def b = r.

Lemma rat_bigQ0: rat_bigQ 0%bigQ 0%R.
Proof. exact: val_inj. Qed.

Lemma rat_bigQ1: rat_bigQ 1%bigQ 1%R.
Proof. exact: val_inj. Qed.

Lemma rat_bigQ_opp : (rat_bigQ =~> rat_bigQ) BigQ.opp (@GRing.opp _).
Proof.
rewrite /rat_bigQ /bigQ2rat_def => b r.
rewrite BigQ.strong_spec_opp Qreduction.Qred_opp [in LHS]/QArith_base.Qnum /=.
rewrite Z2int_opp mulrNz GRing.mulNr.
by move=> <-.
Qed.

Lemma Z2int_Qred n d :
  ((Z2int (QArith_base.Qnum (Qreduction.Qred (QArith_base.Qmake n d))))%:Q /
    (Pos.to_nat (QArith_base.Qden (Qreduction.Qred (QArith_base.Qmake n d))))%:Q
   = (Z2int n)%:Q / (Z2int (Zpos d))%:Q)%R.
Proof.
rewrite -(fracqE (Z2int n, Z2int (Zpos d))) -[RHS]divq_num_den.
rewrite /Qreduction.Qred.
move: (BinInt.Z.ggcd_gcd n (Zpos d)) (BinInt.Z.ggcd_correct_divisors n (Zpos d)).
move: (Z_ggcd_coprime n (Zpos d)).
case: BinInt.Z.ggcd => g [n' d'] /=.
case: g => [|g|g].
{ by move=> _ _ [_]; rewrite BinInt.Z.mul_0_l. }
{ move=> coprime_n'_d' => _ [->].
  rewrite (nat_of_pos_Z_to_pos d) => /[dup] posd' ->.
  have d'n0 : (`|Z2int d'| != 0)%R.
  { rewrite Num.Theory.normr_eq0.
    case: d' posd' {coprime_n'_d'} => // d' _.
    exact: Z2int_Zpos_neq0. }
  rewrite !Z2int_mul abszM PoszM gez0_abs; [|by rewrite -[0%R]/(Z2int Z0) Z2int_le].
  rewrite fracqMM ?Posz_nat_of_pos_neq0 ?abszE; last exact: Z2int_Zpos_neq0.
  move: (@valq_frac (Z2int n', `|Z2int d'|%R) d'n0).
  rewrite scalqE // GRing.mul1r => [[neq deq]].
  have -> : Pos.to_nat (BinInt.Z.to_pos d') = `|Z2int d'|%R :> ssrint.int.
  { rewrite nat_of_pos_Z_to_pos BinInt.Z2Pos.id ?abszE //.
    by case: d' posd' {coprime_n'_d' d'n0 neq deq}. }
  rewrite [X in (X%:~R / _)%R]neq [X in (_ / X%:~R)%R]deq.
  rewrite (_ : gcdn _ _ = 1%nat) ?GRing.mul1r //; exact/eqP/coprime_n'_d'. }
by move: (BinInt.Z.gcd_nonneg n (Zpos d)) => + _ => /[swap] <-.
Qed.

Lemma BigQ_red_den_nonzero q :
  match BigQ.red q with BigQ.Qz _ => True | BigQ.Qq _ d => [d]%bigN <> Z0 end.
Proof.
case: q => [//|n d] /=.
rewrite /BigQ.norm.
rewrite BigN.spec_compare.
case: BinInt.Z.compare_spec => [| |//] Hgcd.
{ rewrite /BigQ.check_int BigN.spec_compare.
  case BinInt.Z.compare_spec => [//| |//] Hd.
  apply: BigNumPrelude.Zlt0_not_eq.
  move: Hd; exact: BinInt.Z.lt_trans. }
rewrite /BigQ.check_int BigN.spec_compare.
case BinInt.Z.compare_spec => [//| |//] Hd.
apply: BigNumPrelude.Zlt0_not_eq.
move: Hd; exact: BinInt.Z.lt_trans.
Qed.

Lemma ratBigQ_red x y : rat_bigQ y x ->
  match BigQ.red y with
  | BigQ.Qz n => numq x = Z2int [n]%bigZ /\ denq x = 1%R
  | BigQ.Qq n d => numq x = Z2int [n]%bigZ /\ denq x = Z2int [d]%bigN
  end.
Proof.
case: (ratP x) => nx dx nx_dx_coprime {x}.
rewrite /rat_bigQ /bigQ2rat_def -BigQ.strong_spec_red.
have ry_red : Qreduction.Qred [BigQ.red y]%bigQ = [BigQ.red y]%bigQ.
{ by rewrite BigQ.strong_spec_red Qcanon.Qred_involutive. }
have ry_dneq0 := BigQ_red_den_nonzero y.
case: (BigQ.red y) ry_dneq0 ry_red => [ny _ _|ny dy dy_neq0].
{ rewrite /BigQ.to_Q /QArith_base.Qnum /QArith_base.Qden GRing.mulr1.
  move=> /(f_equal ( *%R^~ dx.+1%:~R)%R).
  rewrite GRing.mulfVK ?mulrz_neq0 // -intrM => /intr_inj nx_eq.
  have dx_1 : (dx.+1 = 1)%nat.
  { by move: nx_dx_coprime => /eqP <-; rewrite -nx_eq abszM /= gcdnC gcdnMl. }
    by rewrite -nx_eq dx_1 GRing.mulr1. }
rewrite /BigQ.to_Q ifF ?BigN.spec_eqb ?BinInt.Z.eqb_neq //.
rewrite Qcanon.Qred_iff ZgcdE -[Zpos 1]/(BinInt.Z.of_nat 1%nat) => /Znat.Nat2Z.inj.
rewrite /QArith_base.Qnum /QArith_base.Qden nat_of_pos_Z_to_pos => /eqP ny_dy_coprime.
move=> /eqP; rewrite rat_eqE !coprimeq_num // !coprimeq_den //=.
rewrite !Num.Theory.gtr0_sg //; last exact/ssrnat.ltP/Pos2Nat.is_pos.
rewrite !GRing.mul1r => /andP[/eqP <-].
rewrite ifF; [|exact/eqP/eqP/Num.Theory.lt0r_neq0/ssrnat.ltP/Pos2Nat.is_pos].
rewrite -!abszE !absz_nat => /eqP[<-]; split=> [//|].
rewrite -[LHS]/(Z2int (Zpos (BinInt.Z.to_pos [dy]%bigN))) BinInt.Z2Pos.id //.
exact: BigQ.N_to_Z_pos.
Qed.

Lemma rat_bigQ_add: (rat_bigQ =~> rat_bigQ =~> rat_bigQ) BigQ.add (@GRing.add _).
Proof.
move=> p x + q y.
rewrite /rat_bigQ /bigQ2rat_def; move=> <- <-.
rewrite (Qreduction.Qred_complete _ _ (BigQ.spec_add _ _)).
case: (BigQ.to_Q p) => np dp {p}.
case: (BigQ.to_Q q) => nq dq {q}.
rewrite /QArith_base.Qplus !Z2int_Qred.
rewrite Z2int_add !Z2int_mul /= Pos2Nat.inj_mul multE.
rewrite intrD PoszM !intrM.
rewrite [RHS]GRing.addf_div // intq_eq0;
  exact/lt0n_neq0/ssrnat.ltP/Pos2Nat.is_pos.
Qed.

Lemma rat_bigQ_mul: (rat_bigQ =~> rat_bigQ =~> rat_bigQ) BigQ.mul (@GRing.mul _).
Proof.
move=> p x + q y.
rewrite /rat_bigQ /bigQ2rat_def; move=> <- <-.
rewrite (Qreduction.Qred_complete _ _ (BigQ.spec_mul _ _)).
case: (BigQ.to_Q p) => np dp {p}.
case: (BigQ.to_Q q) => nq dq {q}.
rewrite /QArith_base.Qmult !Z2int_Qred /=.
rewrite Z2int_mul Pos2Nat.inj_mul multE.
rewrite PoszM !intrM.
by rewrite [RHS]GRing.mulf_div.
Qed.

Lemma rat_bigQ_lt: (rat_bigQ =~> rat_bigQ =~> iff) BigQ.lt (@Order.lt _ _).
Proof.
move=> p x + q y.
rewrite /rat_bigQ /bigQ2rat_def; move=> <- <-.
rewrite /BigQ.lt.
case: (BigQ.to_Q p) => np dp {p}.
case: (BigQ.to_Q q) => nq dq {q}.
rewrite !Z2int_Qred.
rewrite Num.Theory.ltr_pdivr_mulr ?ltr0z /=;
  last exact/ssrnat.ltP/Pos2Nat.is_pos.
rewrite GRing.mulrAC Num.Theory.ltr_pdivl_mulr ?ltr0z;
  last exact/ssrnat.ltP/Pos2Nat.is_pos.
rewrite !nat_of_pos_Z_to_pos.
rewrite !gez0_abs /=; try apply/ltnW/ssrnat.ltP/Pos2Nat.is_pos.
rewrite -!intrM ltr_int.
rewrite /QArith_base.Qlt /= -/(Z2int (Zpos dp)) -/(Z2int (Zpos dq)).
rewrite -!Z2int_mul.
case: ltP.
{ move=> /(proj1 (Z2int_lt _ _)); rewrite /BinInt.Z.lt=> ->; split=> //. }
move=> /(proj1 (Z2int_le _ _)) /BinInt.Z.le_ngt h.
by split=> //.
Qed.

Lemma rat_bigQ_eq:
  (rat_bigQ =~> rat_bigQ =~> eq) BigQ.eqb eq_op.
Proof.
move=> x X <- y Y <-; rewrite /bigQ2rat_def.
rewrite /BigQ.eqb BigQ.spec_eq_bool.
apply/idP/idP.
- by move/QArith_base.Qeq_bool_iff/Qreduction.Qred_complete=> ->.
- move/eqP; case: [x]%bigQ=> xn xd.
  case: [y]%bigQ=> yn yd /=; rewrite !Z2int_Qred /=.
  move/eqP; rewrite GRing.eqr_div.
  + move/eqP=> h; apply/QArith_base.Qeq_bool_iff.
    rewrite /QArith_base.Qeq /=.
    apply/Z2int_inj; rewrite !Z2int_mul /=.
    by move:h; rewrite -!intrM; move/intr_inj.
  + apply/negP=> /eqP; rewrite -rat0.
    move/intr_inj; move: (Pos2Nat.is_pos xd).
    by elim: (Pos.to_nat xd)=> // /Nat.lt_irrefl.
  + apply/negP=> /eqP; rewrite -rat0.
    move/intr_inj; move: (Pos2Nat.is_pos yd).
    by elim: (Pos.to_nat yd)=> // /Nat.lt_irrefl.
Qed.

Lemma rat_bigQ_injr: rel_spec rat_bigQ eq.
Proof. by move=> ??? <- <-. Qed.

(* Lemma rat_bigQEl b b' r:
  rat_bigQ b r -> (b == b')%bigQ -> rat_bigQ b' r.
Proof.
rewrite /rat_bigQ /bigQ2rat_def /BigQ.eq.
case: [b]%bigQ=> n d.
case: [b']%bigQ=> n' d'.
by move=> h /Qreduction.Qred_complete <-.
Qed. *)

(* Lemma rat_bigQEr b r r':
  rat_bigQ b r -> r = r' -> rat_bigQ b r'.
Proof. by move=> ? <-. Qed. *)

End BigQRat.

Module BigQUtils.

Definition delta_line (n k : Uint63.int) (x : bigQ):= (make n 0%bigQ).[k <- x].

Definition perturbed_line (n k : Uint63.int) (b x : bigQ):=
  (make (Uint63.succ n) 0%bigQ).[0%uint63 <- b].[Uint63.succ k <- x].

Definition bigQ_dot (x y : array bigQ) : bigQ :=
  PArrayUtils.array_dot BigQ.add BigQ.mul 0%bigQ x y.

Definition bigQ_mul_row_mx (a : array bigQ) (x : array (array bigQ)) :=
  PArrayUtils.array_mul_row_mx BigQ.add BigQ.mul 0%bigQ a x.

Definition bigQ_mulmx (m n : array (array bigQ)):=
  PArrayUtils.array_mulmx BigQ.add BigQ.mul 0%bigQ m n.

Definition BQlex_order (x y : array bigQ) :=
  PArrayUtils.lex_array_rel BigQ.compare x y.

Definition BQltx_order (x y : array bigQ) :=
  PArrayUtils.ltx_array_rel BigQ.compare x y.

Definition eq_array_bigQ (a b : array bigQ) :=
  PArrayUtils.eq_array_rel (BigQ.eqb) a b.

Definition bigQ_scal_rV (lambda : bigQ) (x : array bigQ):=
  PArrayUtils.map (fun v=> BigQ.mul lambda v) x.

Definition bigQ_add_rV (x y : array bigQ):=
  PArrayUtils.mk_fun (fun i=> (x.[i] + y.[i])%bigQ) (length x) (0%bigQ).

Definition bigQ_ge0 (x : bigQ):= match (0 ?= x)%bigQ with
  |Gt => false
  |_ => true
end.

Definition weighted_lines (v : array bigQ) (A : array (array bigQ)):=
  PArrayUtils.fold_pair
    (fun v_i A_i acc => bigQ_add_rV acc (bigQ_scal_rV v_i A_i))
  v A (make (length A.[0%uint63]) 0%bigQ).

End BigQUtils.

Section BigQComputations.

Definition bigQ_dot (x y : array bigQ) : bigQ :=
  array_dot BigQ.add BigQ.mul 0%bigQ x y.

Definition bigQ_mul_row_mx (a : array bigQ) (x : array (array bigQ)) :=
  array_mul_row_mx BigQ.add BigQ.mul 0%bigQ a x.

Definition bigQ_mulmx (m n : array (array bigQ)):=
  array_mulmx BigQ.add BigQ.mul 0%bigQ m n.

Definition BQlex_order (x y : array bigQ) :=
  lex_array_rel BigQ.compare x y.

Definition BQltx_order (x y : array bigQ) :=
  ltx_array_rel x y BigQ.compare.

Definition eq_array_bigQ (a b : array bigQ) :=
  eq_array_rel (BigQ.eqb) a b.

Definition bigQ_scal_rV (lambda : bigQ) (x : array bigQ):=
  arr_map (fun v=> BigQ.mul lambda v) x.

Definition bigQ_add_rV (x y : array bigQ):=
  arr_mk_fun (fun i=> (x.[i] + y.[i])%bigQ) (length x) (0%bigQ).

Definition weighted_lines (v : array bigQ) (A : array (array bigQ)):=
  arr_fold_pair
    (fun v_i A_i acc => bigQ_add_rV acc (bigQ_scal_rV v_i A_i))
    v A (make (length A.[0%uint63]) 0%bigQ).

Section Equiv.

Lemma bigQ_dotE (x y : array bigQ):
  BigQUtils.bigQ_dot x y = bigQ_dot x y.
Proof. exact: array_dotE. Qed.

Lemma bigQ_mul_row_mxE (a : array bigQ) (x : array (array bigQ)):
  BigQUtils.bigQ_mul_row_mx a x = bigQ_mul_row_mx a x.
Proof. exact: array_mul_row_mxE. Qed.

Lemma bigQ_mulmxE (m n : array (array bigQ)):
  BigQUtils.bigQ_mulmx m n = bigQ_mulmx m n.
Proof. exact: array_mulmxE. Qed.

Lemma BQlex_orderE (x y : array bigQ):
  BigQUtils.BQlex_order x y = BQlex_order x y.
Proof. exact: lex_array_relE. Qed.

Lemma BQltx_orderE (x y : array bigQ):
  BigQUtils.BQltx_order x y = BQltx_order x y.
Proof. exact: ltx_array_relE. Qed.

Lemma eq_array_bigQE (a b : array bigQ):
  BigQUtils.eq_array_bigQ a b = eq_array_bigQ a b.
Proof. exact: eq_array_relE. Qed.

Lemma bigQ_scal_rVE (lambda : bigQ) (x : array bigQ):
  BigQUtils.bigQ_scal_rV lambda x = bigQ_scal_rV lambda x.
Proof. by rewrite /BigQUtils.bigQ_scal_rV arr_mapE. Qed.

Lemma bigQ_add_rVE (x y : array bigQ):
  BigQUtils.bigQ_add_rV x y = bigQ_add_rV x y.
Proof. by rewrite /BigQUtils.bigQ_add_rV arr_mk_funE. Qed.

Lemma weighted_linesE (v : array bigQ) (A : array (array bigQ)):
  BigQUtils.weighted_lines v A = weighted_lines v A.
Proof.
rewrite /BigQUtils.weighted_lines arr_fold_pairE; apply/eq_foldl=> ??.
by rewrite bigQ_add_rVE bigQ_scal_rVE.
Qed.

End Equiv.
Section Proofs.

Lemma BQltx_order_trans: transitive BQltx_order.
Proof.
move=> y x z /ltx_array_relP [len_xy +] /ltx_array_relP [len_yz +].
case=> j [j_lenx xy_i_eq xy_j_lt] [j'] [j'_leny yz_i_eq yz_j_lt].
apply/ltx_array_relP; split; rewrite ?len_xy //.
exists (Order.min j j'); split; rewrite ?lt_minl ?j'_leny ?orbT //.
- move=> i; rewrite lt_minr=> /andP [/xy_i_eq + /yz_i_eq].
  by case: BigQ.compare_spec=> // ->.
- case: ltgtP.
  + by move/yz_i_eq; case: BigQ.compare_spec=> // <-.
  + by move/xy_i_eq; case: BigQ.compare_spec=> // ->.
  + move=> j_eq; move: xy_j_lt yz_j_lt; rewrite j_eq.
    do 2! case: BigQ.compare_spec=> //.
    move/[swap]/QArith_base.Qlt_trans=> /[apply] + _ _.
    by rewrite BigQ.spec_compare=> /QArith_base.Qlt_alt.
Qed.

Lemma BQltx_order_neq x y: BQltx_order x y -> ~~ eq_array_bigQ x y.
Proof.
case/ltx_array_relP=> len_xy [k [k_len k_eq k_lt]].
apply/negP=> /eq_array_relP [_] /(_ k k_len).
move: k_lt=> /[swap] /BigQ.eqb_eq xy_k.
case: BigQ.compare_spec=> //; rewrite xy_k.
by case: BigQ.lt_strorder=> + _; move=> /[apply].
Qed.

Lemma eq_array_bigQC x y: eq_array_bigQ x y = eq_array_bigQ y x.
Proof.
apply/eq_array_rel_sym=> a b. rewrite /BigQ.eqb !BigQ.spec_eq_bool.
by apply/idP/idP; apply/QArith_base.Qeq_bool_sym.
Qed.

End Proofs.
End BigQComputations.

Section BQR.

Lemma rat_bigQ_ge0 x X: rat_bigQ x X ->
  BigQUtils.bigQ_ge0 x = (0 <= X)%R.
Proof.
move=> xX; rewrite /BigQUtils.bigQ_ge0.
case: BigQ.compare_spec.
- move/BigQ.eqb_eq. move: (rat_bigQ_eq rat_bigQ0 xX).
  by rewrite /BigQ.eqb=> -> /eqP ->; rewrite lexx.
- by move/rat_bigQ_lt=> /(_ _ _ rat_bigQ0 xX)/ltW ->.
- move/rat_bigQ_lt=> /(_ _ _ xX rat_bigQ0).
  by rewrite ltNge=> /negPf ->.
Qed.

End BQR.

Section RelArrayBQR.

Definition rat_dot := @array_dot [realFieldType of rat] +%R *%R 0%R.
Definition rat_mul_row_mx :=
  @array_mul_row_mx [realFieldType of rat] +%R *%R 0%R.
Definition rat_mulmx :=
  @array_mulmx [realFieldType of rat] +%R *%R 0%R.

Lemma BQR_array_dot:
  (rel_array rat_bigQ =~> rel_array rat_bigQ =~> rat_bigQ)
    bigQ_dot rat_dot.
Proof.
rewrite /array_dot /bigQ_dot.
move=> a A aA b B bB.
apply: (rel_array_fold_pair)=> //; [ |exact:aA|exact:bB].
move=> ?????????; apply/rat_bigQ_add=> //; exact/rat_bigQ_mul.
Qed.

Definition rat_compare (x y : rat):=
  if (x < y)%R then Lt else if (x == y) then Eq else Gt.

Lemma BQR_array_lex: (rel_array rat_bigQ =~> rel_array rat_bigQ =~> eq)
  BQlex_order (lex_array_rel rat_compare).
Proof.
apply/rel_array_lex=> x X xX y Y yY.
case: BigQ.compare_spec.
- move/BigQ.eqb_eq; rewrite -/BigQ.eqb (rat_bigQ_eq xX yY).
  by move/eqP=> ->; rewrite /rat_compare ltxx eqxx.
- move/rat_bigQ_lt=> /(_ _ _ xX yY); rewrite /rat_compare.
  by move=> ->.
- move/rat_bigQ_lt=> /(_ _ _ yY xX); rewrite /rat_compare.
  by rewrite ltNge le_eqVlt negb_or=> /andP [/negPf -> /negPf ->].
Qed.

Lemma BQR_array_eq: (rel_array rat_bigQ =~> rel_array rat_bigQ =~> eq)
  eq_array_bigQ (eq_array_rel eq_op).
Proof. exact/rel_array_eq/rat_bigQ_eq. Qed.

Lemma BQR_array_mul_rV_mx:
  (rel_array rat_bigQ =~> rel_array (rel_array rat_bigQ)
    =~> rel_array rat_bigQ)
    bigQ_mul_row_mx rat_mul_row_mx.
Proof. by apply:rel_array_mul_row_mx; [exact:rat_bigQ_add|exact:rat_bigQ_mul|]. Qed.

Definition rat_add_rV (X Y : array rat):=
  (arr_mk_fun (fun i=> (get X i + get Y i)%R) (length X) (0%R)).

Lemma BQR_array_add x X y Y:
  (length X = length Y) ->
  rel_array rat_bigQ x X -> rel_array rat_bigQ y Y ->
  rel_array rat_bigQ (bigQ_add_rV x y) (rat_add_rV X Y).
Proof.
move=> len_eq xX yY; rewrite /bigQ_add_rV.
rewrite (rel_array_length xX); apply/rel_array_arr_mk_fun=> //.
  by rewrite leEint leb_length.
move=> i i_len; apply/rat_bigQ_add.
- move: (rel_array_r xX)=> /(_ i); rewrite (rel_array_length xX) i_len.
  exact.
- move: (rel_array_r yY)=> /(_ i); rewrite (rel_array_length yY).
  rewrite -len_eq i_len; exact.
Qed.

Definition rat_scal_rV (lambda : rat) (X : array rat):=
  arr_map (fun v=> (lambda * v)%R) X.

Lemma BQR_array_scal:
  (rat_bigQ =~> rel_array rat_bigQ =~> rel_array rat_bigQ)
  bigQ_scal_rV rat_scal_rV.
Proof.
move=> l L lL x X xX; apply/rel_array_map; [|exact:xX].
exact:rat_bigQ_mul.
Qed.

Definition rat_weighted_lines v A:=
  arr_fold_pair
  (fun v_i A_i acc => rat_add_rV acc (rat_scal_rV v_i A_i))
  v A (make (length A.[0%uint63]) 0%R).

Lemma BQR_array_weighted_lines v V a A:
  (0%uint63 < length A)%O ->
  length V = length A ->
  (forall i, (i < length A)%O -> length A.[i] = length A.[0])->
  rel_array rat_bigQ v V ->
  rel_array (rel_array rat_bigQ) a A ->
  rel_array rat_bigQ
  (weighted_lines v a) (rat_weighted_lines V A).
Proof.
move=> len_A_gt0 len_eq len_ai vV aA.
set r' := fun (x : array bigQ) (X : array rat) =>
  (forall i, (i < length A)%O -> length X = length A.[i]) /\
  rel_array rat_bigQ x X.
suff: r' (weighted_lines v a) (rat_weighted_lines V A) by case.
apply: (rel_array_fold_pair_in (r':=r')); [exact:len_eq| |exact:vV|exact:aA| ].
- move=> i i_len z Z [len_z zZ].
  move: (rel_array_r vV)=> /(_ i); rewrite (rel_array_length vV).
  move=> /(_ i_len) viVI.
  move: (rel_array_r aA)=> /(_ i); rewrite (rel_array_length aA) -len_eq.
  move=> /(_ i_len) aiAI; move: (BQR_array_scal viVI aiAI)=> avAV.
  have:= (BQR_array_add _ zZ avAV); rewrite length_arr_map (len_z i); last
    by rewrite -len_eq.
  move=> /(_ (erefl _))=> rel_res; split=> //.
  by move=> k k_len; rewrite length_arr_mk_fun; [exact/len_z|rewrite leEint leb_length].
- split; first by (move=> i i_len; rewrite length_make leb_length len_ai).
  move: (rel_array_r aA); rewrite (rel_array_length aA).
  move=> /(_ _ len_A_gt0)=> /rel_array_length -> /=.
  apply/(rel_array_make (length A.[0%uint63]) rat_bigQ0).
Qed.

Lemma BQR_array_mulmx:
  (rel_array (rel_array rat_bigQ) =~> rel_array (rel_array rat_bigQ) =~>
  rel_array (rel_array rat_bigQ))
  bigQ_mulmx rat_mulmx.
Proof. by apply:rel_array_mulmx; [exact:rat_bigQ_add|exact:rat_bigQ_mul|]. Qed.

End RelArrayBQR.

Section RatVector.

Context {n : nat}.

Local Notation rel_cV_rat := (@rel_cV [realFieldType of rat] n).
Local Notation rel_rV_rat := (@rel_rV [realFieldType of rat] n).

Lemma rel_cV_rat_eq:
  (rel_cV_rat =~> rel_cV_rat =~> eq) (eq_array_rel (@eq_op _)) (@eq_op _).
Proof.
move=> x X xX y Y yY; apply/idP/idP.
- case/eq_array_relP=> len_xy xy_i; apply/eqP/matrixP=> p q.
  rewrite ord1 -(rel_cV_nth xX p) -(rel_cV_nth yY p).
  apply/eqP/xy_i=> [:len_x]; rewrite ltEint_nat nat_to_intK;
    first by (abstract:len_x; rewrite -(rel_cV_length xX)).
  rewrite inE; exact/(ltn_trans len_x)/int_thresholdP.
- move/eqP/matrixP=> XY; apply/eq_array_relP=> [:len_xy]; split.
  + abstract:len_xy; apply/int_to_nat_inj.
    by rewrite -(rel_cV_length xX) -(rel_cV_length yY).
  + move=> i; rewrite ltEint_nat -(rel_cV_length xX)=> i_n.
    move:(rel_cV_nth xX (Ordinal i_n)) (rel_cV_nth yY (Ordinal i_n)).
    rewrite /= int_to_natK => -> ->; exact/eqP/XY.
Qed.

Lemma rel_cV_rat_dot:
  (rel_cV_rat =~> rel_cV_rat =~> eq) rat_dot (fun x y=> vdot x y).
Proof. move=> /= x X xX y Y yY; exact/rel_cV_big. Qed.

Lemma rel_rV_rat_lex:
  (rel_rV_rat =~> rel_rV_rat =~> eq)
    (lex_array_rel rat_compare) (fun x y=> (x <=lex y)%R).
Proof.
apply/rel_rV_lex=> x y; rewrite /rat_compare /CompSpec.
case: ltgtP=> [_|_|->]; [exact:CompLt|exact:CompGt|exact:CompEq].
Qed.

Lemma rel_rV_rat_add:
  (rel_rV_rat =~> rel_rV_rat =~> rel_rV_rat)
  (fun x y=> rat_add_rV x y)
  (fun X Y=> (X + Y)%R).
Proof.
move=> x X xX y Y yY; split; rewrite ?length_arr_mk_fun ?leEint ?leb_length ?(rel_cV_length xX) //.
move=> i; rewrite !mxE nth_arr_mk_fun ?leEint ?leb_length // ?ltEint_nat.
- by move:(rel_rV_nth xX) (rel_rV_nth yY)=> /(_ i) -> /(_ i) ->.
- rewrite -(rel_cV_length xX); rewrite nat_to_intK //.
  rewrite !inE; apply/(ltn_trans (ltn_ord _)).
  rewrite {1}(rel_cV_length xX); exact/int_thresholdP.
Qed.

Lemma rel_rV_rat_scal lambda:
  (rel_rV_rat =~> rel_rV_rat)
  (rat_scal_rV lambda) (fun X=> (lambda *: X)%R).
Proof.
move=> x X xX; split; rewrite ?length_arr_map ?(rel_cV_length xX) //.
by move=> i; rewrite !mxE arr_map_nth (rel_rV_nth xX).
Qed.

End RatVector.

Section RatMatrix.
Context {m n : nat}.

Local Notation rel_mx_rat_col := (@rel_mx_col [realFieldType of rat] m n).
Local Notation rel_mx_rat_row := (@rel_mx_row [realFieldType of rat] m n).

Lemma rel_rV_rat_mul_col:
  (@rel_rV [realFieldType of rat] m =~> rel_mx_rat_col =~>
    @rel_rV [realFieldType of rat] n)
    (fun x y=> arr_map (fun col=> rat_dot x col) y)
    (fun X Y=> (X *m Y)%R).
Proof.
move=> x X xX y Y yY.
have ->: (X *m Y)%R = ((\col_(i < n.+1) '[X^T, col i Y])^T)%R.
- apply/matrixP=> i j; rewrite (ord1_eq0 i) !mxE /vdot.
  by under [RHS]eq_bigr=> k _ do rewrite !mxE.
by apply/rel_mx_col_map=> //; apply/rel_cV_rat_dot.
Qed.

Lemma rel_rV_rat_weighted_lines:
  (@rel_rV [realFieldType of rat] m =~> rel_mx_rat_row =~> @rel_rV [realFieldType of rat] n)
  rat_weighted_lines (fun V A=> (V *m A)%R).
Proof.
move=> v V vV a A aA; rewrite /rat_weighted_lines mulmx_sum_row.
apply: rel_mx_row_bigsum=> //.
- move=> ?? ->; exact/rel_rV_rat_scal.
- exact/rel_rV_rat_add.
Qed.

End RatMatrix.
Section BQRVector.

Definition rel_cV_bqr {n : nat} :=
  @rel_point_cV _ _ rat_bigQ n.
Definition rel_rV_bqr {n : nat} :=
  @rel_point_rV _ _ rat_bigQ n.

Lemma rel_cV_bqr_eq {n : nat}:
  (@rel_cV_bqr n =~> @rel_cV_bqr n =~> eq)
    (eq_array_bigQ) (@eq_op _).
Proof.
apply/rel_equiv_func2;
  [exact:rel_equiv_refl|exact:rel_equiv_refl|exact:rel_comp_eqL|].
apply/rel_comp_func2; [exact:BQR_array_eq|exact:rel_cV_rat_eq].
Qed.

Lemma rel_rV_bqr_lex {n : nat}:
  (@rel_rV_bqr n =~> @rel_rV_bqr n =~> eq)
  BQlex_order (fun x y=> (x <=lex y)%R).
Proof.
apply/rel_equiv_func2;
  [exact:rel_equiv_refl|exact:rel_equiv_refl|exact:rel_comp_eqL|].
apply/rel_comp_func2; [exact:BQR_array_lex|exact:rel_rV_rat_lex].
Qed.

Lemma rel_rV_bqr_pertline {n : Uint63.int} {N : nat}:
  (n < max_length)%O ->
  rel_int n N.+1 ->
  (@rel_int_ord N =~> rat_bigQ =~> rat_bigQ =~> @rel_rV_bqr N.+1)
  (BigQUtils.perturbed_line n)
  (fun K B M1=> row_mx B%:M (row K (M1%:M))).
Proof.
move=> n_max nN k K kK b B bB x X xX.
exists (make (Uint63.succ n) 0%R).[0%uint63 <- B].[succ k <- X].
- move: (rel_array_make (succ n) rat_bigQ0).
  by move/(rel_array_write 0%uint63 bB)/(rel_array_write (succ k) xX).
- move=> [: n_len]; split.
  + rewrite !length_set; abstract: n_len; rewrite length_make.
    rewrite -leEint leEint_nat !succ_intE; last exact/lt_trans/max_length_lt.
    rewrite -ltEint_nat n_max succ_intE; last exact/lt_trans/max_length_lt.
    by rewrite nN.
  + move=> i; case/boolP: (nat_to_int i == (succ k)).
    * move/eqP=> i_k [: k_len]; rewrite i_k get_set_same.
      {
        rewrite !mxE; case: splitP.
        - move=> j /(congr1 nat_to_int); rewrite i_k (ord1_eq0 j).
          move/(congr1 int_to_nat); rewrite succ_intE //.
          abstract: k_len.
          rewrite ltEint_nat -kK; apply/(ltn_trans (ltn_ord K)).
          rewrite nN; apply/(@ltn_trans max_length); rewrite -ltEint_nat //.
          exact:max_length_lt.
        -  move=> k' /(congr1 nat_to_int); rewrite i_k.
          rewrite add1n -nat_to_intS=> /(congr1 pred); rewrite !pred_succ.
          move/(congr1 int_to_nat); rewrite nat_to_intK.
          + by rewrite -kK=> /val_inj <-; rewrite !mxE eqxx.
          + rewrite inE; apply/(ltn_trans (ltn_ord k')).
            rewrite nN; exact:int_thresholdP.
      }
      {
        rewrite length_set -ltEint ltEint_nat -n_len succ_intE //.
        by rewrite -kK ltnS ltn_ord.
      }
    * rewrite eq_sym; move/eqP=> ?; rewrite get_set_other //.
      case/boolP: (i == ord0).
      {
        move/eqP=> i_0; rewrite i_0 get_set_same -?ltEint ?ltEint_nat -?n_len //.
        rewrite !mxE; case: splitP=> // j _; rewrite (ord1_eq0 j).
        by rewrite !mxE eqxx.
      }
      {
        move=> in0; rewrite get_set_other ?get_make ?mxE.
        - case: splitP.
          + move=> j; rewrite (ord1_eq0 j) /= => ?.
            by move/eqP: in0; case; apply/val_inj.
          + move=> j i_j; rewrite !mxE.
            suff ->: (K == j) = false by [].
            apply/negbTE/eqP=> /(congr1 val)/(congr1 succn).
            rewrite kK -[in RHS]add1n -i_j=> /(congr1 nat_to_int).
            by rewrite -(nat_to_intS) int_to_natK.
        - move/(congr1 int_to_nat)=> /esym.
          rewrite nat_to_intK; first (move=> i0; move/eqP: in0; case; exact/val_inj).
          apply/(ltn_trans (ltn_ord _)); rewrite nN.
          apply/(@leq_ltn_trans max_length); rewrite -?ltEint_nat //.
          apply/(@ltn_trans max_int_); rewrite -?ltEint_nat ?max_length_lt //.
          exact/int_thresholdP.
          }
Qed.

Lemma rel_rV_bqr_delta n N:
  (n <= max_length)%O ->
  rel_int n N.+1->
  (@rel_int_ord N =~> rat_bigQ =~> rel_rV_bqr)
  (fun i x=> BigQUtils.delta_line n i x) (fun I X=> row I X%:M).
Proof.
move=> n_max nN i I iI x X xX.
exists (make n 0%R).[i <- X].
- split; rewrite ?length_set ?length_make //.
  move=> k; rewrite -leEint n_max=> k_n.
  case/boolP: (i == k)=> /eqP; [move=> ->|].
  + by rewrite !get_set_same ?length_make -?leEint ?n_max -?ltEint ?k_n.
  + by move=> i_k; rewrite !get_set_other // !get_make.
- split; rewrite ?length_set ?length_make -?leEint ?n_max ?nN //.
  move=> K; rewrite !mxE.
  case/boolP: (I == K).
  + move/eqP=> <-; rewrite iI int_to_natK get_set_same //=.
    rewrite length_make -leEint n_max -ltEint ltEint_nat.
    rewrite -nN -iI; exact/ltn_ord.
  + move=> IK; rewrite /= GRing.mulr0n get_set_other ?get_make //.
    move/(congr1 int_to_nat); rewrite -iI nat_to_intK ?inE.
    * by move/val_inj/eqP; rewrite /= (negPf IK).
    * apply/(ltn_trans (ltn_ord _)); rewrite nN.
      apply/(@leq_ltn_trans max_length); first rewrite -?leEint_nat ?n_max //.
      exact/int_thresholdP.
Qed.

Lemma rel_rV_bqr_delta_bis n N i:
  (n <= max_length)%O ->
  rel_int n N.+1 ->
  (rat_bigQ =~> @rel_rV_bqr N) (fun x=> BigQUtils.delta_line n i x)
  (fun X=> (\row_j (X*+(int_to_nat i == j)))%R).
Proof.
move=> n_max nN x X xX.
exists (make n 0%R).[i <- X].
- split; rewrite ?length_set ?length_make //.
  move=> k; rewrite -leEint n_max=> k_n.
  case/boolP: (i == k)=> /eqP; [move=> ->|].
  + by rewrite !get_set_same ?length_make -?leEint ?n_max -?ltEint ?k_n.
  + by move=> i_k; rewrite !get_set_other // !get_make.
- split; rewrite ?length_set ?length_make -?leEint ?n_max ?nN //.
  move=> k; rewrite !mxE; case/boolP: (int_to_nat i == val k).
  + move=> /eqP /[dup] i_k <-; rewrite int_to_natK get_set_same //.
    rewrite -ltEint length_make -leEint n_max ltEint_nat.
    by rewrite i_k ltn_ord.
  + move=> i_n_k; rewrite /= GRing.mulr0n get_set_other ?get_make //.
    move: i_n_k=> /[swap] ->; rewrite nat_to_intK /= ?eqxx //.
    rewrite !inE; apply/(ltn_trans (ltn_ord _))/int_thresholdP.
Qed.

Lemma rel_rV_bqr_add (n : nat):
  (@rel_rV_bqr n =~> @rel_rV_bqr n =~> @rel_rV_bqr n)
  bigQ_add_rV (fun v w=> (v + w)%R).
Proof.
move=> x X' [X xX XX'] y Y' [Y yY YY'].
move: (rel_rV_rat_add XX' YY').
exists (rat_add_rV X Y)=> //; apply/BQR_array_add=> //.
by apply/int_to_nat_inj; rewrite -(rel_cV_length XX') -(rel_cV_length YY').
Qed.

Lemma rel_rV_bqr_scal (n : nat):
  (rat_bigQ =~> @rel_rV_bqr n =~> @rel_rV_bqr n)
  bigQ_scal_rV (fun L X=> (L *: X)%R).
Proof.
move=> l L lL; apply/rel_comp_func; [exact/BQR_array_scal/lL|].
exact/rel_rV_rat_scal.
Qed.

End BQRVector.

Section BQRMatrix.

Context {m n : nat}.

Definition rel_mx_bqr_col := @rel_point_mx_col _ _ rat_bigQ m n.
Definition rel_mx_bqr_row := @rel_point_mx_row _ _ rat_bigQ m n.

Lemma rel_mx_bqr_mul_col:
  (@rel_rV_bqr m =~> rel_mx_bqr_col =~> @rel_rV_bqr n)
    bigQ_mul_row_mx (fun X Y=> (X *m Y)%R).
Proof.
apply/rel_comp_func2;
  [exact:BQR_array_mul_rV_mx|exact:rel_rV_rat_mul_col].
Qed.

Lemma rel_mx_bqr_row_weighted_lines:
  (@rel_rV_bqr m =~> rel_mx_bqr_row =~> @rel_rV_bqr n)
  weighted_lines (fun v A=> (v *m A)%R).
Proof.
move=> v V' [V vV VV'] a A' [A aA AA']; exists (rat_weighted_lines V A).
- apply/BQR_array_weighted_lines=> //.
+ by rewrite ltEint_nat -(rel_mx_row_length AA').
+ by apply/int_to_nat_inj; rewrite -(rel_cV_length VV') -(rel_mx_row_length AA').
+ move=> i iA; apply/int_to_nat_inj.
  by rewrite -(rel_mx_row_length_row AA') -(rel_mx_row_length_row_i AA' iA).
- exact/rel_rV_rat_weighted_lines.
Qed.

End BQRMatrix.

(* Section BigQ2Rat_Vector.
Section Def.

Context {n : nat}.

Definition rat_bigQ_rV (a : array bigQ) (v : 'rV[rat]_n):=
  (n == length a) && [forall i : 'I_n, a.[nat_to_int i] -bQr- (v ord0 i)].

Definition rat_bigQ_cV (a : array bigQ) (v : 'cV[rat]_n):=
  (n == length a) && [forall i : 'I_n, a.[nat_to_int i] -bQr- (v i ord0)].

Definition bigQ_arr_to_rat_cV {n : nat} (a : array bigQ) :=
  (\col_(j < n) (bigQ2rat_def (get a (nat_to_int j))))%R.

End Def.

Section Proofs.

Lemma rat_bigQ_rVP {n : nat} (a : array bigQ) (v : 'rV[rat]_n):
  reflect
    ((n = length a) /\ (forall i : 'I_n, a.[nat_to_int i] -bQr- (v ord0 i)))
    (rat_bigQ_rV a v).
Proof.
apply/(iffP idP).
- case/andP=> /eqP eq_len /forallP h; split=> //.
- case=> len_eq h; apply/andP; split; rewrite ?len_eq //.
  exact/forallP.
Qed.

Lemma rat_bigQ_cVP {n : nat} (a : array bigQ) (v : 'cV[rat]_n):
  reflect
    ((n = length a) /\ (forall i : 'I_n, a.[nat_to_int i] -bQr- (v i ord0)))
    (rat_bigQ_cV a v).
Proof.
apply/(iffP idP).
- case/andP=> /eqP eq_len /forallP h; split=> //.
- case=> len_eq h; apply/andP; split; rewrite ?len_eq //.
  exact/forallP.
Qed.

Lemma BQ2R_cVP (a : array bigQ):
  rat_bigQ_cV a (@bigQ_arr_to_rat_cV (length a) a).
Proof. by apply/rat_bigQ_cVP; split=> // i; rewrite mxE. Qed.

Lemma BQ2R_cVP_cast (a : array bigQ) (n : nat):
  n = length a ->
  rat_bigQ_cV a (@bigQ_arr_to_rat_cV n a).
Proof.
move=> n_eq; apply/rat_bigQ_cVP; split=> //.
by move=> i; rewrite !mxE.
Qed.

Lemma BQR_rV_injl {n : nat} (a b : array bigQ) (v w : 'rV[rat]_n):
  rat_bigQ_rV a v -> rat_bigQ_rV b w -> reflect (v = w) (eq_array_bigQ a b).
Proof.
move/rat_bigQ_rVP => + /rat_bigQ_rVP.
move=> bqr_av bqr_bw; apply/(iffP idP).
- case/eq_array_relP=> len_eq eqb_i.
  apply/rowP=> i.
  case: bqr_bw=> len_b /(_ i).
  case: bqr_av=> len_a /(_ i).
  move: (eqb_i (nat_to_int i)).
  rewrite ltEint_nat nat_to_intK ?inE; last (apply/(@ltn_trans n)=> //; rewrite len_a; exact/int_thresholdP).
  rewrite -len_a ltn_ord=> /(_ isT) /BigQ.eqb_eq /[swap] /eqP/rat_bigQEl /[apply] + /eqP.
  exact/rat_bigQ_injr.
- move=> vw; move: bqr_av bqr_bw; rewrite vw.
  case=> len_a bqr_ai [len_b bqr_bi]; apply/eq_array_relP.
  split; first by (apply: int_to_nat_inj; rewrite -len_a -len_b).
  move=> i; rewrite ltEint_nat -len_a => i_n; apply/BigQ.eqb_eq.
  move: (bqr_ai (Ordinal i_n)) (bqr_bi (Ordinal i_n)).
  by move/eqP/rat_bigQ_injl=> + /eqP;move=> /[apply]; rewrite /= int_to_natK.
Qed.

Lemma BQR_rV_tr {n : nat} (a : array bigQ) (v : 'rV[rat]_n):
  rat_bigQ_cV a (v^T) <-> rat_bigQ_rV a v.
Proof.
split.
- move/rat_bigQ_cVP; case=> ? h.
  apply/rat_bigQ_rVP; split=> // i; rewrite -[v]trmxK mxE; exact: h.
- move/rat_bigQ_rVP; case=> ? h.
  apply/rat_bigQ_cVP; split=> // i; rewrite mxE; exact: h.
Qed.

Lemma BQR_cV_tr {n : nat} (a : array bigQ) (v : 'cV[rat]_n):
  rat_bigQ_rV a (v^T) <-> rat_bigQ_cV a v.
Proof.
split.
- move/rat_bigQ_rVP; case=> ? h.
  apply/rat_bigQ_cVP; split=> // i; rewrite -[v]trmxK mxE; exact: h.
- move/rat_bigQ_cVP; case=> ? h.
  apply/rat_bigQ_rVP; split=> // i; rewrite mxE; exact: h.
Qed.

Lemma BQR_scal_rV {n : nat} (lambda : bigQ) (lambda' : rat)
  (a : array bigQ) (v : 'rV[rat]_n):
  rat_bigQ lambda' lambda -> rat_bigQ_rV a v ->
  rat_bigQ_rV (bigQ_scal_rV lambda a) (lambda' *: v).
Proof.
move=> bqr_lambda bqr_av.
apply/rat_bigQ_rVP; split.
- by rewrite length_arr_map; case/rat_bigQ_rVP: bqr_av.
- move=> i; rewrite !mxE arr_map_nth.
  apply/eqP/rat_bigQ_mul=> //; apply/eqP; case/rat_bigQ_rVP: bqr_av.
  by move=> _ /(_ i).
Qed.

Lemma BQR_arr_rV {n : nat} (a b : array bigQ) (v w : 'rV[rat]_n):
  rat_bigQ_rV a v -> rat_bigQ_rV b w ->
  rat_bigQ_rV (bigQ_add_rV a b) (v + w).
Proof.
case/rat_bigQ_rVP=> len_a a_eq /rat_bigQ_rVP [len_b b_eq].
apply/rat_bigQ_rVP; rewrite length_arr_mk_fun ?leEint ?leb_length //; split=> //.
move=> i; rewrite /bigQ_add_rV nth_arr_mk_fun ?mxE ?leEint ?leb_length //.
- apply/eqP/rat_bigQ_add; apply/eqP; [exact: a_eq|exact: b_eq].
- rewrite ltEint_nat -len_a nat_to_intK ?ltn_ord //.
  rewrite inE; apply/(ltn_trans (ltn_ord _)); rewrite len_a; exact/int_thresholdP.
Qed.

Lemma BQR_dot {n : nat} (a b : array bigQ) (v w : 'cV[rat]_n):
  rat_bigQ_cV a v -> rat_bigQ_cV b w -> rat_bigQ '[v,w] (bigQ_dot a b).
Proof.
case/rat_bigQ_cVP=> + bqr_a_v /rat_bigQ_cVP [+ bqr_b_w].
move=> /[dup] n_int /(congr1 nat_to_int) + /(congr1 nat_to_int).
rewrite !int_to_natK=> len_a len_b.
rewrite /bigQ_dot /arr_fold_pair  zip_arr_to_seq -?len_a //.
rewrite irange0_iota nat_to_intK; rewrite ?n_int ?inE; last exact/int_thresholdP.
rewrite /vdot (eq_bigl (fun k => (val k < n)%nat)); last by (move=> k; rewrite ltn_ord).
move: {1 16 19}n (leqnn n); elim=> [|k IH]; first by rewrite big_pred0_eq.
move=> k_n; rewrite iotaS_rcons add0n !map_rcons foldl_rcons /=.
rewrite big_ord_narrow big_ord_recr /=.
apply/rat_bigQ_add; last (apply/rat_bigQ_mul; apply/eqP).
- move: (IH (ltnW k_n)); rewrite (big_ord_narrow (ltnW k_n)).
  set S := BigOp.bigop _ _ _; set S' := BigOp.bigop _ _ _.
  suff ->: S = S' by [].
  apply/eq_bigr=> i _; set wid := widen_ord _ _; set wid' := widen_ord _ _.
  suff ->: wid = wid' by []; exact/val_inj.
- exact: (bqr_a_v (widen_ord k_n ord_max)).
- exact: (bqr_b_w (widen_ord k_n ord_max)).
Qed.

Lemma BQR_ltx_order {n : nat} (a b : array bigQ) (v w : 'rV[rat]_n):
  rat_bigQ_rV a v -> rat_bigQ_rV b w -> BQltx_order a b = (v <lex w)%R.
Proof.
move=> /rat_bigQ_rVP + /rat_bigQ_rVP.
case=> len_a bqr_av [len_b bqr_bw]; apply/idP/idP.
- case/ltx_array_relP=> len_eq /= [j] [j_len j_lt_eq j_eq].
  apply/lex_lev_strictP; move: (j_len).
  rewrite ltEint_nat -len_a=> j_n; exists (Ordinal j_n).
  split.
  + move=> i /= i_j; move/(_ (nat_to_int i)): j_lt_eq bqr_av bqr_bw.
    rewrite ltEint_nat nat_to_intK ?i_j ?inE;
      last (apply/(ltn_trans i_j)/(@ltn_trans (length a)); [by rewrite -?ltEint_nat //|exact/int_thresholdP]).
    move/(_ isT); case: BigQ.compare_spec=> // + _ /(_ i) /eqP + /(_ i) /eqP.
    move=> /[swap] /rat_bigQEl /[apply]; exact: rat_bigQ_injr.
  + move: (bqr_av (Ordinal j_n)) (bqr_bw (Ordinal j_n))=> /= /eqP + /eqP.
    move/rat_bigQ_lt=> /[apply] <-; rewrite int_to_natK.
    by case: BigQ.compare_spec j_eq.
- case/lex_lev_strictP=> j [j_lt_eq j_eq].
  apply/ltx_array_relP; split; first apply/int_to_nat_inj; rewrite -?len_a -?len_b //.
  have j_int: j < int_threshold by apply/(ltn_trans (ltn_ord _)); rewrite len_a; exact/int_thresholdP.
  exists (nat_to_int j); split.
  + rewrite ltEint_nat -len_a nat_to_intK ?inE //.
  + move=> i; rewrite ltEint_nat nat_to_intK ?inE // => i_j.
    move: (i_j) (ltn_ord j)=> /ltn_trans /[apply] => i_n.
    move: (j_lt_eq (Ordinal i_n))=> /= /(_ i_j) vw_i_eq.
    move: (bqr_av (Ordinal i_n)) (bqr_bw (Ordinal i_n)); rewrite vw_i_eq.
    move=> /eqP + /eqP.
    move/rat_bigQ_injl=> /[apply] /=; rewrite int_to_natK => ->.
    case: BigQ.compare_spec=> //; by move/QOrderedType.QOrder.lt_irrefl.
  + move: (bqr_av j) (bqr_bw j)=> /eqP + /eqP.
    move/rat_bigQ_lt /[apply]; rewrite j_eq.
    case: BigQ.compare_spec=> //.
    * move=> /[swap] /=; rewrite /BigQ.lt /BigQ.eq => h.
      by move: QArith_base.Qlt_not_eq=> /[apply]; rewrite h=> /(_ isT).
    * move=> /[swap] /=; rewrite /BigQ.lt => h.
      move/QArith_base.Qlt_trans => /(_ [b.[nat_to_int j]]%bigQ).
      by rewrite h=> /(_ isT)/QArith_base.Qlt_irrefl.
Qed.

Lemma BQR_lex_order {n : nat} (a b : array bigQ) (v w : 'rV[rat]_n):
  rat_bigQ_rV a v -> rat_bigQ_rV b w -> BQlex_order a b = (v <=lex w)%R.
Proof.
move=> bqr_av bqr_bw; rewrite /BQlex_order lex_arr_eqVlt lex_eqOlt.
rewrite -(BQR_ltx_order bqr_av bqr_bw); congr orb.
apply/idP/idP.
- case/eq_array_relP=> len_eq nth_h; apply/eqP/(BQR_rV_injl bqr_av bqr_bw).
  by apply/eq_array_relP; split.
- case/eqP/(BQR_rV_injl bqr_av bqr_bw)/eq_array_relP=> len_eq nth_h.
  by apply/eq_array_relP; split.
Qed.

Lemma BQltx_order_irr: irreflexive BQltx_order.
Proof.
move=> x; apply/idP/idP.
apply/negP=> /ltx_array_relP.
rewrite /ltx_array_rel; case=> _ [j] [_ _].
by case: BigQ.compare_spec=> // /QArith_base.Qlt_irrefl.
Qed.

Lemma BQltx_inj (a : array (array bigQ)):
  rel_sorted BQltx_order a ->
  (forall i j, (i < length a)%O -> (j < length a)%O ->
  eq_array_bigQ a.[i] a.[j] -> i = j).
Proof.
move/(sorted_rel_inj_rel BQltx_order_trans); apply.
move=> x y; rewrite /eq_array_bigQ /BQltx_order.
case/eq_array_relP=> len_eq xy_i_eq; split.
- rewrite /ltx_array_rel len_eq eqxx /=.
  case E: (lex_array_rel_ _ _)=> //=.
  case: (lex_array_rel_Lt len_eq E)=> j []; rewrite -ltEint_nat=> /xy_i_eq.
  move/BigQ.eqb_correct ->; rewrite BigQ.spec_compare.
  by case: QArith_base.Qcompare_spec=> // /QOrderedType.QOrder.lt_irrefl.
- rewrite /ltx_array_rel len_eq eqxx /=.
  case E: (lex_array_rel_ _ _)=> //=.
  case: (lex_array_rel_Lt (esym len_eq) E)=> [j] []; rewrite -ltEint_nat -len_eq.
  move=> /xy_i_eq /BigQ.eqb_correct ->; rewrite BigQ.spec_compare.
  by case: QArith_base.Qcompare_spec=> // /QOrderedType.QOrder.lt_irrefl.
Qed.

End Proofs.

End BigQ2Rat_Vector.

Section BigQ2Rat_Matrix.
Section Def.

Definition rat_bigQ_mx_col {m n : nat} (a : array (array bigQ)) (M : 'M_(m,n)):=
  n = length a /\
  (forall j : 'I_n, rat_bigQ_cV a.[nat_to_int j] (col j M)).

Definition bigQ_mat_to_rat_mat {m n : nat} (a : array (array bigQ)):=
  ((\matrix_(j < n) (@bigQ_arr_to_rat_cV m (get a (nat_to_int j)))^T )^T)%R.

End Def.

Section Proofs.

Lemma BQ2R_matP (a : array (array bigQ)):
  (forall j, (j < length a)%O -> length a.[j] = length a.[0]) ->
  @rat_bigQ_mx_col (length a.[0]) (length a) a (bigQ_mat_to_rat_mat a).
Proof.
move=> len_0; split; first by [].
move=> j; rewrite /bigQ_mat_to_rat_mat.
apply/rat_bigQ_cVP; split.
- rewrite -(len_0 (nat_to_int j)) //.
  rewrite ltEint_nat nat_to_intK // inE.
  apply/(ltn_trans (ltn_ord _))/int_thresholdP.
- by move=> i; rewrite !mxE.
Qed.

Lemma BQ2R_matP_cast (a : array (array bigQ)) (m n : nat):
  m = length a -> (forall i, (i < length a)%O -> n = length a.[i]) ->
  @rat_bigQ_mx_col n m a (bigQ_mat_to_rat_mat a).
Proof.
move=> m_eq n_eq; split=> // j.
apply/rat_bigQ_cVP; split.
- apply/n_eq; rewrite ltEint_nat -m_eq nat_to_intK //.
  rewrite inE; apply/(ltn_trans (ltn_ord _)); rewrite m_eq.
  exact/int_thresholdP.
- by move=> i; rewrite !mxE.
Qed.

Lemma BQR_rV_M_mul {m n : nat} (a : array bigQ) (x : array (array bigQ))
  (v : 'rV[rat]_m) (M : 'M_(m,n)):
  rat_bigQ_rV a v -> rat_bigQ_mx_col x M ->
  rat_bigQ_rV (bigQ_mul_row_mx a x) (v *m M).
Proof.
move=> bqr_a_v bqr_x_M; apply/rat_bigQ_rVP; split.
- rewrite /bigQ_mul_row_mx /= /PArrayUtils.map length_arr_map.
  by case: bqr_x_M.
- move=> i; rewrite /bigQ_mul_row_mx arr_map_nth -matrix_vdot.
  apply/eqP/BQR_dot.
  + by apply/BQR_rV_tr; rewrite row_id.
  + by case: bqr_x_M=> _ /(_ i).
Qed.

End Proofs.
End BigQ2Rat_Matrix.
 *)


Require Import String Ascii List ZArith.
Import ListNotations.
Require Import VST.floyd.proofauto.

Fixpoint string_to_Z (s : string) :=
  match s with
  | EmptyString => []
  | String a s' => Byte.signed (Byte.repr (Z.of_nat (nat_of_ascii a))) :: string_to_Z s'
  end.

Lemma string_to_Z_app : forall s1 s2, string_to_Z (append s1 s2) = string_to_Z s1 ++ string_to_Z s2.
Proof.
  induction s1; auto; intros; simpl.
  rewrite IHs1; auto.
Qed.

Lemma append_empty : forall s, append s EmptyString = s.
Proof.
  induction s; auto; simpl.
  rewrite IHs; auto.
Qed.

Definition repable_char i := Byte.min_signed <= i <= Byte.max_signed.

Lemma repable_char_0 : repable_char 0.
Proof.
  split.
  - pose proof Byte.min_signed_neg; omega.
  - pose proof Byte.max_signed_pos; omega.
Qed.

Lemma repable_char_int : forall i, repable_char i -> repable_signed i.
Proof.
  unfold repable_char, repable_signed, Byte.min_signed, Byte.max_signed,
    Int.min_signed, Int.max_signed; simpl; intros; omega.
Qed.

Lemma repable_byte : forall a, repable_char (Byte.signed a).
Proof.
  apply Byte.signed_range.
Qed.

Hint Resolve repable_char_0 repable_byte repable_char_int.

Lemma repable_string : forall s, Forall repable_char (string_to_Z s).
Proof.
  induction s; constructor; auto.
Qed.

Lemma repable_string_i : forall s i, repable_char (Znth i (string_to_Z s ++ [0]) 0).
Proof.
  intros.
  destruct (zlt i 0).
  { rewrite Znth_underflow; auto. }
  destruct (zlt i (Zlength (string_to_Z s))).
  { rewrite app_Znth1 by auto.
    apply Forall_Znth, repable_string; omega. }
  rewrite app_Znth2 by auto.
  destruct (eq_dec (i - Zlength (string_to_Z s)) 0).
  { rewrite e, Znth_0_cons; auto. }
  { rewrite Znth_overflow; auto.
    rewrite Zlength_cons, Zlength_nil; omega. }
Qed.

Lemma sign_ext_char : forall c, repable_char c ->
  Int.sign_ext 8 (Int.repr c) = Int.repr c.
Proof.
  intros; apply sign_ext_inrange.
  rewrite Int.signed_repr; auto.
  apply repable_char_int; auto.
Qed.

Opaque N.mul.

Lemma N_of_digits_inj : forall l1 l2, length l1 = length l2 ->
  N_of_digits l1 = N_of_digits l2 -> l1 = l2.
Proof.
  induction l1; destruct l2; auto; try discriminate; simpl; intros.
  rewrite <- N2Z.id in H0.
  rewrite <- (N2Z.id (_ + _)) in H0.
  apply Z2N.inj in H0; try apply N2Z.is_nonneg.
  rewrite !N2Z.inj_add, !N2Z.inj_mul in H0.
  destruct a, b; simpl in *; try (apply f_equal, IHl1; auto; apply N2Z.inj; omega).
  - assert (Z.odd (1 + 2 * Z.of_N (N_of_digits l1)) = true) as Hodd.
    { rewrite Z.odd_add_mul_2; auto. }
    rewrite H0, Z.odd_add_mul_2 in Hodd; discriminate.
  - assert (Z.odd (1 + 2 * Z.of_N (N_of_digits l2)) = true) as Hodd.
    { rewrite Z.odd_add_mul_2; auto. }
    rewrite <- H0, Z.odd_add_mul_2 in Hodd; discriminate.
Qed.

Corollary nat_of_ascii_inj : forall a1 a2, nat_of_ascii a1 = nat_of_ascii a2 -> a1 = a2.
Proof.
  destruct a1 as (?, ?, ?, ?, ?, ?, ?, ?), a2 as (?, ?, ?, ?, ?, ?, ?, ?).
  unfold nat_of_ascii; intro X.
  apply Nnat.N2Nat.inj, N_of_digits_inj in X; auto; congruence.
Qed.

Lemma N_of_digits_range : forall l, 0 <= Z.of_N (N_of_digits l) < 2 ^ (Zlength l).
Proof.
  induction l; simpl; [omega|].
  rewrite Zlength_cons, N2Z.inj_add, N2Z.inj_mul.
  unfold Z.succ; rewrite Z.pow_add_r by (pose proof Zlength_nonneg l; omega); simpl.
  unfold Z.pow_pos; simpl.
  if_tac; simpl; omega.
Qed.

Corollary nat_of_ascii_range : forall a, 0 <= Z.of_nat (nat_of_ascii a) < Byte.modulus.
Proof.
  destruct a.
  unfold nat_of_ascii.
  rewrite N_nat_Z; apply N_of_digits_range.
Qed.

Lemma string_to_Z_inj : forall s1 s2, string_to_Z s1 = string_to_Z s2 -> s1 = s2.
Proof.
  induction s1; destruct s2; auto; try discriminate; simpl; intro X; inv X.
  rewrite !Byte.signed_repr_eq in *.
  erewrite (nat_of_ascii_inj _ a0), IHs1; eauto.
  apply Nat2Z.inj.
  pose proof (nat_of_ascii_range a); pose proof (nat_of_ascii_range a0).
  rewrite !Zmod_small in * by auto.
  destruct (zlt _ _), (zlt _ _); auto; omega.
Qed.

Section CS.
  Context {CS : compspecs}.

Definition cstring s p := let ls := string_to_Z s in
  !!(~In 0 ls) &&
  data_at Tsh (tarray tschar (Zlength ls + 1)) (map Vint (map Int.repr (ls ++ [0]))) p.

Lemma cstring_local_facts: forall s p, cstring s p |-- !! (isptr p).
Proof.
  intros; unfold cstring; entailer!.
Qed.

Hint Resolve cstring_local_facts : saturate_local.

Lemma cstring_valid_pointer: forall s p, cstring s p |-- valid_pointer p.
Proof.
  intros; unfold cstring; Intros.
  apply data_at_valid_ptr; auto.
  unfold tarray; simpl.
  pose proof (Zlength_nonneg (string_to_Z s)).
  rewrite Z.max_r; omega.
Qed.

Hint Resolve cstring_valid_pointer : valid_pointer.

Definition cstringn s n p := let ls := string_to_Z s in
  !!(~In 0 ls) &&
  data_at Tsh (tarray tschar n) (map Vint (map Int.repr (ls ++ [0])) ++
    list_repeat (Z.to_nat (n - (Zlength ls + 1))) Vundef) p.

Lemma cstringn_equiv : forall s p, cstring s p = cstringn s (Zlength (string_to_Z s) + 1) p.
Proof.
  intros; unfold cstring, cstringn.
  rewrite Zminus_diag, app_nil_r; auto.
Qed.

Lemma cstringn_local_facts: forall s n p, cstringn s n p |-- !! (isptr p /\ Zlength (string_to_Z s) + 1 <= n).
Proof.
  intros; unfold cstringn; entailer!.
  autorewrite with sublist in H1.
  pose proof (Zlength_nonneg (string_to_Z s)).
  pose proof (Zlength_nonneg (list_repeat (Z.to_nat (n - (Zlength (string_to_Z s) + 1))) Vundef)).
  destruct (Z.max_spec 0 n) as [[? Hn] | [? Hn]]; rewrite Hn in *; omega.
Qed.

Hint Resolve cstring_local_facts : saturate_local.

Lemma cstringn_valid_pointer: forall s n p, cstringn s n p |-- valid_pointer p.
Proof.
  intros.
  entailer!. (* Why doesn't this bring in the local facts? *)
  eapply saturate_aux21.
  { apply cstringn_local_facts. }
  { auto. }
  unfold cstringn; Intros.
  apply data_at_valid_ptr; auto.
  unfold tarray; simpl.
  pose proof (Zlength_nonneg (string_to_Z s)).
  rewrite Z.max_r; omega.
Qed.

Hint Resolve cstring_valid_pointer : valid_pointer.

End CS.