Require Import vellvm.
Require Import sflib.
Require Import memory_props.
Require Import TODO.
Import Opsem.
Require Import Classical.

Set Implicit Arguments.

Ltac des_outest_ifsG :=
  match goal with
  | |- context[ match ?x with _ => _ end ] =>
    match (type of x) with
    | { _ } + { _ } => destruct x; clarify
    | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify
    end
  end
.

Ltac hide_goal :=
  match goal with
  | [ |- ?G ] => let name := fresh "HIDDEN_GOAL" in
                 set (name := G); replace G with name by reflexivity; move name at top
  end.

(* TODO: Is it replacable by some lemma in stdlib? or tactic? *)
Lemma dependent_split
      (A B: Prop)
      (HYPA: A)
      (HYPB: <<HYPA: A>> -> B)
  :
    <<GOAL: A /\ B>>
.
Proof.
  split; ss.
  apply HYPB; ss.
Qed.

Lemma Pos_lt_le_irrefl
      a b
      (LE: (a <= b)%positive)
      (LT: (b < a)%positive)
  :
    False
.
Proof. eapply Pos.lt_irrefl. eapply Pos.lt_le_trans; eauto. Qed.

Lemma Forall_harder
      A
      (P Q: A -> Prop)
      l
      (FORALL: List.Forall P l)
      (HARDER: forall a, P a -> Q a)
  :
    <<FORALL: List.Forall Q l>>
.
Proof.
  ginduction l; ii; ss.
  inv FORALL. econs; eauto.
  eapply IHl; eauto.
Qed.

Ltac reductio_ad_absurdum :=
  match goal with
  | [ |- ?G ] => destruct (classic G) as [tmp | REDUCTIO_AD_ABSURDUM];
                 [assumption|exfalso]
  end
.

Ltac exists_prop PROP :=
  tryif
    (repeat multimatch goal with
            | [H: PROP |- _ ] => (* idtac "Found!"; idtac H; *) fail 2
            end)
  then fail
  else idtac
.

(* get equality's transitive closure *)
(* TODO: it checks equal to strictly; "(0, 1).fst != 0" here. *)
Ltac eq_closure_tac :=
  repeat
    (repeat multimatch goal with
            | [H1: ?A = ?B, H2: ?B = ?C |- _ ] =>
              (* idtac "------------------------"; *)
              (* idtac H1; idtac H2; *)
              tryif (check_equal A C)
              then (* idtac "FAILREFL1"; *) fail
              else
                tryif (exists_prop (A = C) + exists_prop (C = A))
                then (* idtac "FAILREFL2" *) idtac
                else
                  let name := fresh "EQ_CLOSURE_TAC" in
                  exploit eq_trans; [exact H1|exact H2|]; intro name
            | [H1: ?B = ?A, H2: ?B = ?C |- _ ] =>
              tryif (check_equal A C)
              then (* idtac "FAILREFL1"; *) fail
              else
                tryif (exists_prop (A = C) + exists_prop (C = A))
                then (* idtac "FAILREFL2" *) idtac
                else
                  let name := fresh "EQ_CLOSURE_TAC" in
                  exploit eq_trans; [exact (eq_sym H1)|exact H2|]; intro name
            end)
.

(* COPIED FROM https://www.cis.upenn.edu/~bcpierce/sf/current/LibTactics.html *)
(* TODO: is it OK? *)
(* TODO: move to proper position; I think sflib should be OK *)
(* TODO: also import some other good things, e.g. gens *)
Tactic Notation "clears" ident(X1) :=
  let rec doit _ :=
      match goal with
      | H:context[X1] |- _ => clear H; try (doit tt)
      | _ => clear X1
      end in doit tt.
Tactic Notation "clears" ident(X1) ident(X2) :=
  clears X1; clears X2.
Tactic Notation "clears" ident(X1) ident(X2) ident(X3) :=
  clears X1; clears X2; clears X3.
Tactic Notation "clears" ident(X1) ident(X2) ident(X3) ident(X4) :=
  clears X1; clears X2; clears X3; clears X4.
Tactic Notation "clears" ident(X1) ident(X2) ident(X3) ident(X4)
       ident(X5) :=
  clears X1; clears X2; clears X3; clears X4; clears X5.
Tactic Notation "clears" ident(X1) ident(X2) ident(X3) ident(X4)
       ident(X5) ident(X6) :=
  clears X1; clears X2; clears X3; clears X4; clears X5; clears X6.
(* TODO: This should fail when ident appears in the goal! *)
(* It currently succeeds, only removing preemises *)

Ltac rewrite_everywhere H := rewrite H in *.
Ltac all_with_term TAC TERM :=
  repeat multimatch goal with
         | H: context[TERM] |- _ => TAC H
         end
.

Ltac clear_unused :=
  repeat multimatch goal with
         | [H: ?T |- _] =>
           match (type of T) with
           | Prop => idtac
           | _ => try clear H
           end
         end
.
Ltac clear_tautology :=
  repeat match goal with
         | [H: ?A = ?B, H2: ?B = ?A |- _] => clear H2
         | [H: True |- _] => clear H
         | [H: ?X, H2: ?X |- _] => clear H2
         | [H: ?A = ?A |- _] => clear H
         end
.
Ltac clear_tac := repeat (clear_unused; clear_tautology).

Ltac des_outest_ifs H :=
  match goal with
  | H': context[ match ?x with _ => _ end ] |- _ =>
    check_equal H' H;
    match (type of x) with
    | { _ } + { _ } => destruct x; clarify
    | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify
    end
  end.

Ltac des_ifs_safe_aux TAC :=
  TAC;
  repeat
    multimatch goal with
    | |- context[match ?x with _ => _ end] =>
      match (type of x) with
      | { _ } + { _ } => destruct x; TAC; []
      | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; TAC; []
      end
    | H: context[ match ?x with _ => _ end ] |- _ =>
      match (type of x) with
      | { _ } + { _ } => destruct x; TAC; []
      | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; TAC; []
      end
    end.
Tactic Notation "des_ifs_safe" := des_ifs_safe_aux clarify.
Tactic Notation "des_ifs_safe" tactic(TAC) := des_ifs_safe_aux TAC.

Ltac abstr_aux x var_name :=
  let hyp_name := fresh "abstr_hyp_name" in
  remember x as var_name eqn:hyp_name; clear hyp_name
.

Tactic Notation "abstr" constr(H) := let var_name := fresh "abstr_var_name" in abstr_aux H var_name.
Tactic Notation "abstr" constr(H) ident(var_name) := abstr_aux H var_name.

Example abstr_demo: (1 + 2 = 3) -> False.
  i.
  abstr_aux (1 + 2) my_name. Undo 1.
  abstr (1 + 2).
Abort.

Ltac des_ifsH H :=
  clarify;
  repeat
    match goal with
    | H': context[ match ?x with _ => _ end ] |- _ =>
      check_equal H' H;
      match (type of x) with
      | { _ } + { _ } => destruct x; clarify
      | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify
      end
    end.

Ltac des_ifsG :=
  clarify;
  repeat
    match goal with
    | |- context[match ?x with _ => _ end] =>
      match (type of x) with
      | { _ } + { _ } => destruct x; clarify
      | _ => let Heq := fresh "Heq" in destruct x as [] eqn: Heq; clarify
      end
    end.

Ltac expl_aux H TAC :=
  let n := fresh H in
  (* one goal or zero goal *)
  first[exploit H; TAC; []; repeat intro n; des|
        exploit H; TAC; fail]
.

Tactic Notation "expl" constr(H) := expl_aux H eauto.

Tactic Notation "expl" constr(H) tactic(TAC) := expl_aux H TAC.

(* multimatch is needed for "solve [all inv]" *)
Ltac all TAC :=
  repeat multimatch goal with
         | H: _ |- _ => TAC H
         end
.

Ltac apply_all x := all (ltac:(apply_in) x).

Lemma list_disjoint_cons_inv
      X (hd: X) tl xs
      (DISJOINT: list_disjoint (hd :: tl) xs)
  :
    <<DISJOINT: list_disjoint [hd] xs /\ list_disjoint tl xs>>
.
Proof.
  splits.
  - ii. clarify. ss. des; ss. clarify. expl DISJOINT. left. ss.
  - eapply list_disjoint_cons_left; eauto.
Qed.

Lemma f_equal6 (A1 A2 A3 A4 A5 A6 B: Type) (f: A1 -> A2 -> A3 -> A4 -> A5 -> A6 -> B)
      (x1 y1: A1) (EQ1: x1 = y1)
      (x2 y2: A2) (EQ2: x2 = y2)
      (x3 y3: A3) (EQ3: x3 = y3)
      (x4 y4: A4) (EQ4: x4 = y4)
      (x5 y5: A5) (EQ5: x5 = y5)
      (x6 y6: A6) (EQ6: x6 = y6)
  :
    <<EQ: f x1 x2 x3 x4 x5 x6 = f y1 y2 y3 y4 y5 y6>>
.
Proof. subst. reflexivity. Qed.

Lemma f_equal7 (A1 A2 A3 A4 A5 A6 A7 B: Type) (f: A1 -> A2 -> A3 -> A4 -> A5 -> A6 -> A7 -> B)
      (x1 y1: A1) (EQ1: x1 = y1)
      (x2 y2: A2) (EQ2: x2 = y2)
      (x3 y3: A3) (EQ3: x3 = y3)
      (x4 y4: A4) (EQ4: x4 = y4)
      (x5 y5: A5) (EQ5: x5 = y5)
      (x6 y6: A6) (EQ6: x6 = y6)
      (x7 y7: A7) (EQ7: x7 = y7)
  :
    <<EQ: f x1 x2 x3 x4 x5 x6 x7 = f y1 y2 y3 y4 y5 y6 y7>>
.
Proof. subst. reflexivity. Qed.

Lemma f_equal8 (A1 A2 A3 A4 A5 A6 A7 A8 B: Type) (f: A1 -> A2 -> A3 -> A4 -> A5 -> A6 -> A7 -> A8 -> B)
      (x1 y1: A1) (EQ1: x1 = y1)
      (x2 y2: A2) (EQ2: x2 = y2)
      (x3 y3: A3) (EQ3: x3 = y3)
      (x4 y4: A4) (EQ4: x4 = y4)
      (x5 y5: A5) (EQ5: x5 = y5)
      (x6 y6: A6) (EQ6: x6 = y6)
      (x7 y7: A7) (EQ7: x7 = y7)
      (x8 y8: A8) (EQ8: x8 = y8)
  :
    <<EQ: f x1 x2 x3 x4 x5 x6 x7 x8 = f y1 y2 y3 y4 y5 y6 y7 y8>>
.
Proof. subst. reflexivity. Qed.

Ltac rpapply_raw H :=
  first[erewrite f_equal8 | erewrite f_equal7 | erewrite f_equal6 | erewrite f_equal5 |
        erewrite f_equal4 | erewrite f_equal3 | erewrite f_equal2 | erewrite f_equal];
  [eapply H|..]; try reflexivity.

Ltac is_applied_function TARGET :=
  match TARGET with
  | ?f ?x =>
    idtac
  | _ => fail
  end
.

Ltac has_inside_strict A B :=
  match A with
  | context[B] => tryif (check_equal A B) then fail else idtac
  | _ => fail
  end
.

Ltac is_inside_others_body TARGET :=
  tryif (repeat multimatch goal with
                | [ |- context[?f ?x] ] =>
                  (* idtac f; idtac x; *)
                  tryif (has_inside_strict x TARGET)
                  then fail 2
                  else fail
                end)
  then fail
  else idtac
.

Ltac on_leftest_function TAC :=
  (* repeat *)
  multimatch goal with
  | [ |- context[?f ?x] ] =>
    tryif (is_applied_function f)
    then fail
    else
      tryif (is_inside_others_body f)
      then fail
      else TAC f
  (* else TAC constr:(f) *)
  (* TODO: What is the difference? *)
  end
.
(* TODO: more cannonical way to get leftest function? *)
(* I tried match reverse but it was not good *)
(* TODO: I want to define "get_leftest_function" *)
(* TODO: try tactic notation ? *)

Ltac leftest_rpapply H :=
  on_leftest_function ltac:(fun f =>
     (idtac f; first
                 (* TODO: why rewrite "with" doesn't work? *)
                 [ erewrite (f_equal8 f)
                 | erewrite (f_equal7 f)
                 | erewrite (f_equal6 f)
                 | erewrite (f_equal5 f)
                 | erewrite (f_equal4 f)
                 | erewrite (f_equal3 f)
                 | erewrite (f_equal2 f)
                 | erewrite (f_equal  f) | fail]); [ eapply H | .. ]; try reflexivity)
.

Ltac is_type x :=
     match type of x with
     | Type => idtac
     | Set => idtac
     | Prop => idtac (* TODO: needed? *)
     | _ => fail
     end.

Ltac is_term_applied_function TARGET :=
  match TARGET with
  | ?f ?x =>
    tryif (is_type x) then fail else idtac
  | _ => fail
  end
.

Ltac on_leftest_function_with_type TAC :=
  (* repeat *)
  multimatch goal with
  | [ |- context[?f ?x] ] =>
    tryif (is_term_applied_function f)
    then fail
    else
      tryif (is_inside_others_body f)
      then fail
      else TAC f
  end
.

Ltac rpapply H :=
  on_leftest_function_with_type ltac:(fun f =>
     (idtac f; first
                 (* TODO: why rewrite "with" doesn't work? *)
                 [ erewrite (f_equal8 f)
                 | erewrite (f_equal7 f)
                 | erewrite (f_equal6 f)
                 | erewrite (f_equal5 f)
                 | erewrite (f_equal4 f)
                 | erewrite (f_equal3 f)
                 | erewrite (f_equal2 f)
                 | erewrite (f_equal  f) | fail]); [ eapply H | .. ]; try reflexivity)
.

Goal forall a b,
    let weird_func1 x y z w := (x + y + z + w) in
    let weird_func2 x y := (x * y) > 0 in
    (weird_func2 (weird_func1 1 1 1 1) (b+a)) ->
    (weird_func2 (weird_func1 1 1 1 1) (a+b))
.
Proof.
  i. subst weird_func1. subst weird_func2.
  abstr (fun x y : Z => x * y > 0) weird_func1.
  Fail rpapply_raw H.
  erewrite f_equal4. Undo 1. (* rpapply_raw tries in decreasing order. *)
  (* f_equal4 and then f_equal3 *)
  erewrite f_equal3. Undo 1. (* Anyhow, that doesn't matter now . . . *)
  on_leftest_function ltac:(fun x => idtac x).
  leftest_rpapply H. Undo 1.
  rpapply H. Undo 1.
  Undo 3.
  Fail erewrite (f_equal2 (fun x y : Z => x * y > 0)).
  Fail erewrite f_equal2 with (f:= (fun x y : Z => x * y > 0)).
  (* TODO: without "abstr", below two also fails... *)
  (* It seems some kind of Coqs default reduction mechanism is always on, even in rewriting *)
  (* It may make sense to assume, our proof status has already undergone that reduction. *)
  (* For example, simpl in * will do reduction here, more than needed *)
  simpl in *. Undo 1.
  (* If this becomes problem in actual proof, we may add "remember" & "subst" in rpapply *)
Abort.

Goal (Forall (fun x => x > 0)%nat [1 ; 2]%nat) ->
        (Forall (fun x => x+1 > 1)%nat [1+0 ; 0+2]%nat)
.
Proof.
  i.
  Fail leftest_rpapply.
  on_leftest_function ltac:(fun x => idtac x).
  Fail erewrite (f_equal3 Forall). (* dependent type *)
  rpapply_raw H. Undo 1.
  on_leftest_function_with_type ltac:(fun x => idtac x).
  rpapply H.
Abort.

Goal (Forall2 (fun x y => x+y > 0)%nat [1 ; 2]%nat [3 ; 4]%nat) ->
        (Forall2 (fun x y => x+y+1 > 1)%nat [1+0 ; 0+2]%nat [3 ; 4]%nat)
.
Proof.
  i.
  Fail leftest_rpapply.
  on_leftest_function ltac:(fun x => idtac x).
  Fail erewrite (f_equal3 Forall). (* dependent type *)
  rpapply_raw H. Undo 1.
  on_leftest_function_with_type ltac:(fun x => idtac x).
  (* not "Forall2" or "Forall2 (A:=nat)". it is fed with types at maximum *)
  rpapply H.
Abort.

(* Motivation: I want to distinguish excused ad-mits from normal ad-mits, *)
(* and further, I do not want to "grep" excused ones, so I give them different name. *)
(* Tactic Notation "AD-MIT" string(excuse) := idtac excuse; ad-mit. *)
(* above definition requires "Adm-itted" at the end of the proof, and I consider that not good *)
Definition ADMIT (excuse: String.string) {T: Type} : T.  Admitted.
Tactic Notation "ADMIT" constr(excuse) := idtac excuse; exact (ADMIT excuse).

(* Clarify purpose of this file more clearly? *)
(* Should prevent circular dependency *)

Lemma mstore_aux_implies_vm_matches
      Mem chunks gvs blck ofs Mem'
      (MSTORE: mstore_aux Mem chunks gvs blck ofs = Some Mem')
  :
      <<VM_MATCHES: Forall2 vm_matches_typ gvs chunks>>
.
Proof.
  red.
  generalize dependent gvs.
  revert_until chunks.
  revert Mem.
  induction chunks; ii; ss; des_ifs.
  econs; [|eapply IHchunks; eauto].
  unfold vm_matches_typ. ss.
  des_bool; des.
  apply memory_chunk_eq_prop in Heq. subst.
  split; [ss|apply has_chunk_eq_prop; apply Heq1].
Qed.

Lemma mstore_implies_gv_chunks_match
      TD Mem mpt t gvs algn Mem'
      (MSTORE: mstore TD Mem mpt t gvs algn = Some Mem')
  :
    <<CHUNKS_MATCH: gv_chunks_match_typ TD gvs t>>
.
Proof.
  red.
  unfold mstore in *.
  des_ifs.
  unfold gv_chunks_match_typ.
  rewrite Heq0.
  eapply mstore_aux_implies_vm_matches; eauto.
Qed.

Lemma filter_map_spec
      X Y
      a b (f:X -> option Y) l
      (IN: In a l)
      (APP: f a = Some b)
  : In b (filter_map f l).
Proof.
  induction l; ss.
  des.
  - subst. rewrite APP.
    econs. eauto.
  - des_ifs; eauto.
    constructor 2. eauto.
Qed.

Lemma filter_map_inv
      X Y
      b (f:X -> option Y) l
      (IN: In b (filter_map f l))
  : exists a, In a l /\ f a = Some b.
Proof.
  revert IN.
  induction l; ss.
  des_ifs; i.
  - ss. des.
    + subst. esplits; eauto.
    + apply IHl in IN. des.
      esplits; eauto.
  - apply IHl in IN. des.
    esplits; eauto.
Qed.

Lemma list_prj2_inv
      X Y (l:list (X * Y)) y
      (IN: In y (list_prj2 X Y l))
  : exists x, In (x, y) l.
Proof.
  induction l; ss; i.
  destruct a. ss. des.
  - subst. esplits; eauto.
  - apply IHl in IN. des.
    esplits; eauto.
Qed.

Lemma wf_globals_eq maxb gl
  :
    <<EQ: genericvalues_inject.wf_globals maxb gl <-> memory_props.MemProps.wf_globals maxb gl>>
.
Proof.
  split.
  - econs; eauto. apply Pos.le_1_l.
  - eapply memory_props.MemProps.redundant__wf_globals.
Qed.

Lemma int_add_0
      (ofs : int32)
  :
    <<INT_ARITH: Int.signed 31 ofs =
                 Int.signed 31 (Int.add 31 ofs (Int.repr 31 0))>>
.
Proof.
  unfold Int.add. ss.
  replace (Int.repr 31 (Int.unsigned 31 ofs + 0)) with ofs; ss.
  remember (Int.unsigned 31 ofs) as Z_ofs eqn:DEF_Z_ofs.
  destruct ofs.
  rewrite Z.add_0_r.
  symmetry.
  rewrite -> DEF_Z_ofs.
  apply Int.repr_unsigned.
Qed.

(* TODO: can we do this with setoid? *)
Lemma InA_iff_In
      A
      (myeq: A -> A -> Prop)
      (MYEQ_EQ: forall x y, myeq x y <-> x = y)
  :
    forall x xs, InA myeq x xs <-> In x xs.
Proof.
  i.
  split; i.
  - ginduction xs; ii; ss.
    { inv H. }
    inv H; ss.
    + apply MYEQ_EQ in H1. subst. left; ss.
    + right. eauto.
  - ginduction xs; ii; ss.
    des; ss.
    + subst. econs; eauto.
      eapply MYEQ_EQ; eauto.
    + eapply InA_cons_tl; eauto.
Qed.


Require Import Coq.Logic.Eqdep.
Require Import Coq.Logic.FunctionalExtensionality.

Require Export CatSem.COMP.TLC_rep_comp.

Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

Obligation Tactic := idtac.

Program Instance REP_s :
     Cat_struct (obj := TLC_rep) TLC_rep_Hom := {
  mor_oid P R := eq_Rep_oid P R ;
  id R := Rep_id R ;
  comp a b c f g := Rep_comp f g
}.
Next Obligation.
Proof.
  intros a b c.
  unfold Proper; do 2 red.
  intros M N H.
  induction H.
  simpl in *.
  intros S T H'.
  induction H'.
  simpl in *.

  assert (He : (forall t, tcomp (Rep_comp c0 c1) t =
                          tcomp (Rep_comp a0 a1) t)).
    simpl.
    intro t.
    rewrite H;
    rewrite H1; auto.
  apply (eq_rep (H:=He)).

  destruct c1.
  destruct a1.
  destruct c0.
  destruct a0.

  simpl in *.
  intros V t y.
  assert (K1 : tcomp = tcomp0).
    apply functional_extensionality. auto.
  assert (K2 : tcomp1 = tcomp2).
    apply functional_extensionality. auto.

  generalize dependent He.
  subst.

  intro He.

  assert (Hl := lift_transp_id).
  assert (Hl':= Hl _ _ _ c He).
  assert (Hll := Hl' _ _
  (comp_rep_car (f:=tcomp2) (f':=tcomp0)
          rep_Hom_monad2 rep_Hom_monad0 (c:=V)
     (t:=t) y)).
  simpl in *.
  rewrite Hll.
  simpl.

  assert (Hk := transp_id He).
  simpl in Hk.
  rewrite Hk.
  simpl.

  clear Hk Hll Hl' Hl.

  destruct y as [t y].
  simpl in *.
  apply f_equal.

  assert (H0spec := H0 _ _ (ctype _ y)).
  assert (H0r := lift_transp_id (Q:=b) H
               (rep_Hom_monad2 V (tcomp2 t)
        (ctype (fun t : type_type a => tcomp2 t)
                (V:=a V) (t:=t) y))).
  simpl in *.

  rewrite H0r in H0spec. simpl in *.
  rewrite (UIP_refl _ _ (H t)) in H0spec.
  simpl in *.
  rewrite H0spec.
  simpl.

  clear H0r.
  clear H0spec.
  clear H0.

  assert (H2spec := H2 _ _
  ((ctype (fun t0 : type_type b => tcomp0 t0)
   (V:=b (retype (fun t0 : type_type a => tcomp2 t0) V))
          (t:=tcomp2 t)
     (rep_Hom_monad1 V (tcomp2 t)
        (ctype (fun t0 : type_type a => tcomp2 t0)
   (V:=a V) (t:=t) y))))).
   simpl.

  assert (H2r := lift_transp_id (Q:=c) H1).
  simpl in H2r.
  rewrite H2r in H2spec.
  simpl in *.
  rewrite H2spec.

  apply f_equal.
  rewrite (UIP_refl _ _ (H1 (tcomp2 t))).
  simpl.
  auto.
Qed.

Next Obligation.
Proof.
  simpl.
  intros a b f.
  assert (H : forall t, tcomp f t =
    tcomp (Rep_comp f (Rep_id b)) t)
    by (simpl; auto).

  apply (eq_rep (H:=H)); simpl.

  intros V t y.
  destruct y as [t y].
  simpl.

  destruct f.
  simpl in *.

  rewrite (UIP_refl _ _ (H t)).
  simpl.

  assert (HH:=lift_transp_id (Q:=b) H).
  simpl in *.
  rewrite HH.
  simpl.

  assert (Hl := lift_lift b).
  simpl in Hl.
  rewrite Hl.
  simpl.
  assert (He := lift_eq_id b).
  simpl in He.
  apply He.

  clear t y.
  intros t y.
  destruct y as [t y];
  simpl; auto.
Qed.
Next Obligation.
  simpl.
  intros a b f.
  assert (H : forall t, tcomp f t =
    tcomp (Rep_comp (Rep_id a) f) t)
    by (simpl; auto).

  apply (eq_rep (H:=H)); simpl.

  intros V t y.
  destruct y as [t y].
  simpl.

  destruct f.
  simpl in *.
  rewrite (UIP_refl _ _ (H t)).
  simpl.

  assert (HH:=lift_transp_id (Q:=b) H).
  simpl in *.
  rewrite HH.
  simpl.

  rewrite <- (MonadHomLift rep_Hom_monad).

  assert (Hl := lift_lift b).
  simpl in Hl.
  rewrite Hl.
  simpl.
  assert (He := lift_eq_id b).
  simpl in He.
  apply He.

  clear t y.
  intros t y.
  destruct y as [t y];
  simpl; auto.
Qed.
Next Obligation.
Proof.
  intros a b c c' f g h.
  assert (H : forall t,
    tcomp (Rep_comp f (Rep_comp g h)) t =
    tcomp (Rep_comp (Rep_comp f g) h) t) by
          (simpl; auto).
  apply (eq_rep (H:=H)).
  simpl.
  intros V t y.
  destruct h.
  destruct g.
  destruct f.
  simpl in *.

  assert (Hl:=lift_transp_id (Q:=c') H).
  simpl in Hl.
  rewrite Hl.

  assert (Ht := transp_id H).
  simpl in Ht.
  rewrite Ht.

  destruct y as [t y].
  simpl in *.

  assert (Hc' := lift_lift c').
  simpl in Hc'.
  rewrite Hc'.

  rewrite <- (MonadHomLift rep_Hom_monad).
  rewrite Hc'.

  apply (lift_eq c').
  simpl.

  clear t y.
  intros t y.
  destruct y as [t y].
  simpl.
  destruct y as [t y].
  simpl.
  destruct y as [t y].
  simpl;
  auto.
Qed.

Canonical Structure REP : Cat := Build_Cat REP_s.


Require Import Coq.NArith.BinNat.
Require Export Lib.Monads.
Require Import Coq.Strings.String.
Require Import FunctionalExtensionality.
Require Import Common.Either.
Require Import Common.CoqMaps.

Require Import I2SFI.AbstractMachine.
Require Import CompilerError.

Module CompStateMonad.
  Section Def.
    Variable st: Type.

    Definition t (res: Type) := st -> (@Either res CompilerError) * st.

    Definition ret (A:Type) (x:A) : (t A)
      := fun (s:st) => (Right x,s).

    Definition bind A B (s: t A) (f: A -> t B) :=
      fun x => match s x with
            | (Right x',s') => (f x') s'
            | (Left msg err, s') => (Left msg err, s')
            end.

    Definition get : t st :=
      fun s => (Right s, s).

    Definition put (s: st) : t unit :=
      fun _ =>  (Right tt, s).

    Definition modify (f: st -> st) : t unit :=
      fun s => (Right tt, f s).

    Definition lift {A} (x: option A) (msg : string) (err : CompilerError) : t A :=
      fun s => match x with
            | None  => (Left msg NoInfo, s)
            | Some v => (Right v, s)
            end.

    Definition fail {A} (msg : string) (err : CompilerError): t A :=
      fun s => (Left msg err, s).

    Definition run {A} (s: st) (m: t A) : Either :=
      match m s with
      | (Left msg err,_) => Left msg err
      | (Right v,s') => Right v
      end.

  End Def.
End CompStateMonad.

Instance state_monad {st} : Monad (CompStateMonad.t st) := {
  ret := CompStateMonad.ret st;
  bind := CompStateMonad.bind st
}.

Section CompStateMonadLaws.
  Variable st: Type.

  Lemma state_monad_left_id:
    forall res1 res2 (e: res1) (f: res1 -> CompStateMonad.t st res2),
      bind (ret e) f = f e.
  Proof.
    auto.
  Qed.

  Lemma state_monad_right_id:
    forall res (m: CompStateMonad.t st res),
      bind m ret = m.
  Proof.
    intros.
    unfold ret, bind. simpl.
    unfold CompStateMonad.ret, CompStateMonad.bind.
    extensionality x.
    destruct (m x); auto.
    destruct e. auto. reflexivity.
  Qed.

  Lemma state_monad_associativity:
    forall res1 res2 res3 (m: CompStateMonad.t st res1)
      (f: res1 -> CompStateMonad.t st res2) (g: res2 -> CompStateMonad.t st res3),
      bind (bind m f) g = bind m (fun x => bind (f x) g).
  Proof.
    intros.
    unfold ret, bind. simpl.
    unfold CompStateMonad.ret, CompStateMonad.bind.
    extensionality x.
    destruct m; auto.
    destruct e. destruct (f r s); auto. reflexivity.
  Qed.
End CompStateMonadLaws.

Instance state_monad_laws {st} : MonadLaws (CompStateMonad.t st) := {
  m_left_identity := state_monad_left_id st;
  m_right_identity := state_monad_right_id st;
  m_associativity := state_monad_associativity st
}.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                                                                      *)
(* Micromega: A reflexive tactic using the Positivstellensatz           *)
(*                                                                      *)
(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
(*                                                                      *)
(************************************************************************)

(* FK: scheduled for deletion *)
(*
Require Import Setoid.
Require Import Decidable.
Require Import List.
Require Import Refl.

Set Implicit Arguments.

Section CheckerMaker.

(* 'Formula' is a syntactic representation of a certain kind of propositions. *)
Variable Formula : Type.

Variable Env : Type.

Variable eval : Env -> Formula -> Prop.

Variable Formula' : Type.

Variable eval' : Env -> Formula' -> Prop.

Variable normalise : Formula -> Formula'.

Variable negate : Formula -> Formula'.

Hypothesis normalise_sound :
  forall (env : Env) (t : Formula), eval env t -> eval' env (normalise t).

Hypothesis negate_correct :
  forall (env : Env) (t : Formula), eval env t <-> ~ (eval' env (negate t)).

Variable Witness : Type.

Variable check_formulas' : list Formula' -> Witness -> bool.

Hypothesis check_formulas'_sound :
  forall (l : list Formula') (w : Witness),
    check_formulas' l w = true ->
      forall env : Env, make_impl (eval' env) l False.

Definition normalise_list : list Formula -> list Formula' := map normalise.
Definition negate_list : list Formula -> list Formula' := map negate.

Definition check_formulas (l : list Formula) (w : Witness) : bool :=
  check_formulas' (map normalise l) w.

(* Contraposition of normalise_sound for lists *)
Lemma normalise_sound_contr : forall (env : Env) (l : list Formula),
  make_impl (eval' env) (map normalise l) False -> make_impl (eval env) l False.
Proof.
intros env l; induction l as [| t l IH]; simpl in *.
trivial.
intros H1 H2. apply IH. apply H1. now apply normalise_sound.
Qed.

Theorem check_formulas_sound :
  forall (l : list Formula) (w : Witness),
    check_formulas l w = true -> forall env : Env, make_impl (eval env) l False.
Proof.
unfold check_formulas; intros l w H env. destruct l as [| t l]; simpl in *.
pose proof (check_formulas'_sound H env) as H1; now simpl in H1.
intro H1. apply normalise_sound in H1.
pose proof (check_formulas'_sound H env) as H2; simpl in H2.
apply H2 in H1. now apply normalise_sound_contr.
Qed.

(* In check_conj_formulas', t2 is supposed to be a list of negations of
formulas. If, for example, t1 = [A1, A2] and t2 = [~ B1, ~ B2], then
check_conj_formulas' checks that each of [~ B1, A1, A2] and [~ B2, A1, A2] is
inconsistent. This means that A1 /\ A2 -> B1 and A1 /\ A2 -> B1, i.e., that
A1 /\ A2 -> B1 /\ B2. *)

Fixpoint check_conj_formulas'
  (t1 : list Formula') (wits : list Witness) (t2 : list Formula') {struct wits} : bool :=
match t2 with
| nil => true
| t':: rt2 =>
  match wits with
  | nil => false
  | w :: rwits =>
    match check_formulas' (t':: t1) w with
    | true => check_conj_formulas' t1 rwits rt2
    | false => false
    end
  end
end.

(* checks whether the conjunction of t1 implies the conjunction of t2 *)

Definition check_conj_formulas
  (t1 : list Formula) (wits : list Witness) (t2 : list Formula) : bool :=
    check_conj_formulas' (normalise_list t1) wits (negate_list t2).

Theorem check_conj_formulas_sound :
  forall (t1 : list Formula) (t2 : list Formula) (wits : list Witness),
    check_conj_formulas t1 wits t2 = true ->
      forall env : Env, make_impl (eval env) t1 (make_conj (eval env) t2).
Proof.
intro t1; induction t2 as [| a2 t2' IH].
intros; apply make_impl_true.
intros wits H env.
unfold check_conj_formulas in H; simpl in H.
destruct wits as [| w ws]; simpl in H. discriminate.
case_eq (check_formulas' (negate a2 :: normalise_list t1) w);
intro H1; rewrite H1 in H; [| discriminate].
assert (H2 : make_impl (eval' env) (negate a2 :: normalise_list t1) False) by
now apply check_formulas'_sound with (w := w). clear H1.
pose proof (IH ws H env) as H1. simpl in H2.
assert (H3 : eval' env (negate a2) -> make_impl (eval env) t1 False)
by auto using normalise_sound_contr. clear H2.
rewrite <- make_conj_impl in *.
rewrite make_conj_cons. intro H2. split.
apply <- negate_correct. intro; now elim H3. exact (H1 H2).
Qed.

End CheckerMaker.
*)


Require Export XR_R.
Require Export XR_Rplus.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rplus_eq_compat_l : forall r r1 r2, r1 = r2 -> r + r1 = r + r2.
Proof.
  intros x y z.
  intro heq.
  subst z.
  reflexivity.
Qed.


(* -------------------------------------------------------------------- *)
(* Copyright (c) - 2015--2016 - IMDEA Software Institute                *)
(* Copyright (c) - 2015--2018 - Inria                                   *)
(* Copyright (c) - 2016--2018 - Polytechnique                           *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp Require Export finmap.

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

Import Order.TTheory GRing.Theory Num.Theory.

Local Open Scope ring_scope.
Local Open Scope fset_scope.

(* -------------------------------------------------------------------- *)
Lemma uniq_fset_keys {K : choiceType} (J : {fset K}) : uniq (enum_fset J).
Proof. by case: J => J /= /canonical_uniq. Qed.

#[global] Hint Resolve uniq_fset_keys : core.

(* -------------------------------------------------------------------- *)
Lemma enum_fset0 (T : choiceType) :
  enum [finType of fset0] = [::] :> seq (@fset0 T).
Proof. by rewrite enumT unlock. Qed.

Lemma enum_fset1 (T : choiceType) (x : T) :
  enum [finType of [fset x]] = [:: [`fset11 x]].
Proof.
apply/perm_small_eq=> //; apply/uniq_perm => //.
  by apply/enum_uniq.
case=> [y hy]; rewrite mem_seq1 mem_enum /in_mem /=.
by rewrite eqE /=; rewrite in_fset1 in hy.
Qed.

(* -------------------------------------------------------------------- *)
Section BigFSet.
Variable (R : Type) (idx : R) (op : Monoid.law idx).
Variable (I : choiceType).

Lemma big_fset0_cond (P : pred _) (F : _ -> R) :
  \big[op/idx]_(i : @fset0 I | P i) F i = idx :> R.
Proof. by apply: big_pred0 => -[j hj]; have := hj; rewrite in_fset0. Qed.

Lemma big_fset0 (F : @fset0 I -> R) :
  \big[op/idx]_(i : fset0) F i = idx.
Proof. by rewrite /index_enum -enumT /= enum_fset0 big_nil. Qed.

Lemma big_fset1 (a : I) (F : [fset a] -> R) :
  \big[op/idx]_(i : [fset a]) F i = F (FSetSub (fset11 a)).
Proof. by rewrite /index_enum -enumT enum_fset1 big_seq1. Qed.
End BigFSet.

(* -------------------------------------------------------------------- *)
Section BigFSetCom.
Variable (R : Type) (idx : R).

Local Notation "1" := idx.

Variable op : Monoid.com_law 1.

Local Notation "'*%M'" := op (at level 0).
Local Notation "x * y" := (op x y).

Lemma big_fset_seq_cond (T : choiceType) (J : {fset T}) P F :
    \big[*%M/1]_(x : J | P (val x)) F (val x)
  = \big[*%M/1]_(x <- enum_fset J | P x) F x.
Proof.
case: J=> J c; rewrite -(big_map val) /index_enum.
by rewrite !unlock val_fset_sub_enum ?canonical_uniq.
Qed.

Lemma big_fset_seq (T : choiceType) (J : {fset T}) F :
    \big[*%M/1]_(x : J) F (val x)
  = \big[*%M/1]_(x <- enum_fset J) F x.
Proof. by apply/big_fset_seq_cond. Qed.

Lemma big_seq_fset_cond (T : choiceType) (s : seq T) P F : uniq s ->
    \big[*%M/1]_(x : [fset x in s] | P (val x)) F (val x)
  = \big[*%M/1]_(x <- s | P x) F x.
Proof.
move=> eq_s; rewrite big_fset_seq_cond; apply/perm_big.
by apply/uniq_perm=> //= x; rewrite in_fset.
Qed.

Lemma big_seq_fset (T : choiceType) (s : seq T) F : uniq s ->
    \big[*%M/1]_(x : [fset x in s]) F (val x)
  = \big[*%M/1]_(x <- s) F x.
Proof. by apply/big_seq_fset_cond. Qed.
End BigFSetCom.

Arguments big_fset_seq_cond [R idx op T J] P F.
Arguments big_fset_seq [R idx op T J] F.
Arguments big_seq_fset_cond [R idx op T s] P F _.
Arguments big_seq_fset [R idx op T s] F _.

(* -------------------------------------------------------------------- *)
Section BigFSetU.
Context {R : Type} {T : choiceType} (idx : R) (op : Monoid.com_law idx).

Lemma big_fsetU (A B : {fset T}) F : [disjoint A & B] ->
  \big[op/idx]_(j : A `|` B) F (val j) =
    op (\big[op/idx]_(j : A) F (val j))
       (\big[op/idx]_(j : B) F (val j)).
Proof.
move=> dj_AB; rewrite !big_fset_seq -big_cat; apply/perm_big.
apply/uniq_perm=> //.
+ rewrite cat_uniq ?uniq_fset_keys !(andbT, andTb); apply/hasPn => x /=.
  by apply/fdisjointP; rewrite fdisjoint_sym.
+ by move=> x; rewrite mem_cat in_fsetE.
Qed.
End BigFSetU.

(* -------------------------------------------------------------------- *)
Section BigFSetOrder.
Variable (R : realDomainType) (T : choiceType).

Lemma big_fset_subset (I J : {fset T}) (F : T -> R) :
  (forall x, 0 <= F x) -> {subset I <= J} ->
    \sum_(i : I) F (val i) <= \sum_(j : J) F (val j).
Proof.
move=> ge0_F le_IJ; rewrite !big_fset_seq /=.
rewrite [X in _<=X](bigID [pred j : T | j \in I]) /=.
rewrite ler_paddr ?sumr_ge0 // -[X in _<=X]big_filter.
rewrite le_eqVlt; apply/orP; left; apply/eqP/perm_big.
apply/uniq_perm; rewrite ?filter_uniq //; last move=> i.
rewrite mem_filter; case/boolP: (_ \in _) => //=.
by move/le_IJ => ->.
Qed.

Lemma big_nat_mkfset (F : nat -> R) n :
  \sum_(0 <= i < n) F i =
    \sum_(i : [fset x in (iota 0 n)]) F (val i).
Proof.
rewrite -(big_map val xpredT) /=; apply/perm_big.
apply/uniq_perm; rewrite ?iota_uniq //.
  rewrite map_inj_uniq /=; last apply/val_inj.
  by rewrite /index_enum -enumT enum_uniq.
by move=> i; rewrite /index_enum -enumT -enum_fsetE in_fset /index_iota subn0.
Qed.

Lemma big_ord_mkfset (F : nat -> R) n :
  \sum_(i < n) F i =
    \sum_(i : [fset x in (iota 0 n)]) F (val i).
Proof. by rewrite -(big_mkord xpredT) big_nat_mkfset. Qed.
End BigFSetOrder.

(* -------------------------------------------------------------------- *)
Lemma enum_fsetT {I : finType} :
  perm_eq (enum [fset i | i in I]) (enum I).
Proof.
apply/uniq_perm; rewrite ?enum_uniq //.
by move=> i /=; rewrite !mem_enum in_imfset.
Qed.

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


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)
Require Export CoRN.reals.Series.

Section SeqProperties.

Definition seq_pos (x : nat -> IR) := forall n : nat, [0] [<] x n.
Definition seq_inf_sum (x : nat -> IR) :=
forall M : IR, {N : nat | forall m : nat, N <= m -> M [<] seq_part_sum x m}.

Lemma One_part_sum : forall (m : nat),  seq_part_sum (fun n : nat => [1]) m [=] nring m.
Proof.
 intros.
 induction m; simpl; algebra.
Qed.

Lemma One_seq_is_pos : seq_pos (fun n : nat => [1]).
Proof.
 unfold seq_pos.
 intros. apply pos_one.
Qed.

Lemma One_seq_is_inf_sum : seq_inf_sum (fun n : nat => [1]).
Proof.
 unfold seq_inf_sum.
 intros.
 assert ({N : nat | M [<] nring N}).
  apply Archimedes'.
 destruct X as [N H].
 exists N. intros.
 apply less_leEq_trans with (nring (R:=IR) N); auto.
 assert (seq_part_sum (fun n : nat => [1]) m [=] nring m).
  apply One_part_sum.
 astepr (nring (R:=IR) m).
 apply nring_leEq.
 auto.
Qed.

Lemma seq_pos_imp_sum_pos : forall (x : nat -> IR), seq_pos x -> forall n, [0] [<] seq_part_sum x (S n).
Proof.
 intros.
 induction n.
  simpl.
  astepl ([0][+][0]:IR).
  apply plus_resp_less_lft. apply X.
  simpl.
 simpl in |- *.
 apply plus_resp_pos.
  apply IHn.
 apply X.
Qed.

Lemma seq_pos_imp_sum_pos' :
    forall (x : nat -> IR) (H1 : seq_pos x) (n m : nat) (H2 : m < n),
    [0] [<] Sum m n x.
Proof.
 unfold seq_pos.
 intros.
 induction n.
  assert (~ m < 0). auto with arith. contradiction.
   elim (le_lt_eq_dec _ _ H2); intros H3.
  astepr (Sum m n x [+] x (S n)).
  apply plus_resp_pos.
   apply IHn; auto with arith.
  apply H1.
 replace n with m; auto.
 astepr (Sum m m x [+]x (S m)).
 apply plus_resp_pos.
  astepr (x m).
  apply H1.
 apply H1.
Qed.

Lemma seq_pos_imp_ap_zero : forall (x : nat -> IR), seq_pos x -> forall n, seq_part_sum x (S n) [#] [0].
Proof.
 unfold seq_pos.
 intros.
 apply ap_symmetric_unfolded.
 apply less_imp_ap.
 apply seq_pos_imp_sum_pos; auto.
Qed.

Lemma seq_inf_sum_imp_div_small :
forall (x : nat -> IR) (H1 :  seq_inf_sum x) (H2:  seq_pos x) (C e : IR)
(H4 : [0] [<] e), { N : nat |
  forall m : nat, N <= m -> AbsSmall e (C [/](seq_part_sum x (S m)) [//] (seq_pos_imp_ap_zero x H2 m))}.
Proof.
 unfold seq_inf_sum. unfold seq_pos.
 intros.
 assert ({N : nat | forall m : nat,
   N <= m -> ((AbsIR C)[/]e[//]pos_ap_zero IR e H4)[<]seq_part_sum x m}).
  apply (H1 ((AbsIR C) [/] e [//] (pos_ap_zero IR e H4))).
 destruct X as [N H].
 exists N.
 intros.
 assert (H3 : ((AbsIR C)[/]e[//]pos_ap_zero IR e H4)[<]seq_part_sum x (S m)).
  apply H; auto.
 astepr ((C [/] seq_part_sum x (S m)[//] (seq_pos_imp_ap_zero x H2 m))).
 assert (AbsSmall ((seq_part_sum x (S m))[*]e) C).
  apply AbsIR_imp_AbsSmall.
  apply less_leEq.
  apply (shift_less_mult IR (AbsIR C) (seq_part_sum x (S m)) e (pos_ap_zero IR e H4)); auto.
 rstepl ((seq_part_sum x (S m))[*]e [/] (seq_part_sum x (S m))[//]
   pos_ap_zero IR (seq_part_sum x (S m)) (seq_pos_imp_sum_pos x H2 m)).
 rstepr (C [/] (seq_part_sum x (S m))[//]
   pos_ap_zero IR (seq_part_sum x (S m)) (seq_pos_imp_sum_pos x H2 m)).
 apply div_resp_AbsSmall.
 auto.
Qed.

Lemma seq_inf_sum_ratio_bound :
forall  (y : nat->IR) (H2 : seq_pos y) (m N1: nat) (H3: S N1 < m),
AbsSmall [1] (Sum (G:=IR) (S N1) m (fun k : nat => y k)[/]
	          seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m).
Proof.
 intros.
 apply leEq_imp_AbsSmall.
  apply shift_leEq_div.
   apply seq_pos_imp_sum_pos; auto.
  astepl ([0]:IR).
  apply less_leEq.
  apply seq_pos_imp_sum_pos'; auto.
 apply shift_div_leEq.
  apply seq_pos_imp_sum_pos; auto.
 astepl (Sum (G:=IR) (S N1) m y).
 astepr (seq_part_sum y (S m)).
 unfold Sum. unfold Sum1. unfold seq_part_sum.
 apply shift_zero_leEq_minus'.
 rstepr (Sum0 (G:=IR) (S N1) y).
 apply less_leEq.
 astepr (seq_part_sum y (S N1)).
 apply seq_pos_imp_sum_pos; auto.
Qed.

End SeqProperties.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

(*i $Id: NAxioms.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Export NZAxioms.

Set Implicit Arguments.

Module Type NAxioms (Import NZ : NZDomainSig').

Axiom pred_0 : P 0 == 0.

Parameter Inline recursion : forall A : Type, A -> (t -> A -> A) -> t -> A.
Implicit Arguments recursion [A].

Declare Instance recursion_wd (A : Type) (Aeq : relation A) :
 Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) (@recursion A).

Axiom recursion_0 :
  forall (A : Type) (a : A) (f : t -> A -> A), recursion a f 0 = a.

Axiom recursion_succ :
  forall (A : Type) (Aeq : relation A) (a : A) (f : t -> A -> A),
    Aeq a a -> Proper (eq==>Aeq==>Aeq) f ->
      forall n, Aeq (recursion a f (S n)) (f n (recursion a f n)).

End NAxioms.

Module Type NAxiomsSig := NZOrdAxiomsSig <+ NAxioms.
Module Type NAxiomsSig' := NZOrdAxiomsSig' <+ NAxioms.


Load GradVer22Galois.
Import Semantics.

(* intuition about funny condition *)
Definition gPhiApp (p : phi) (gp1 gp2 : gphi) : Prop :=
  fst gp2 = fst gp1 /\
  snd gp2 = snd gp1 ++ p /\
  (forall p'',(good p'' /\ phiImplies p'' (snd gp1 ++ p)) ->
   exists p' , good p'  /\ phiImplies p'  (snd gp1) /\ phiImplies p'' (p' ++ p)).

Definition gPhiAppWorksFor (pAdd : phi) (pBase : phi) :=
  gPhiApp pAdd (true, pBase) (true, pBase ++ pAdd).

Open Scope string.
Definition t_ea : e := ex (xUserDef "a").
Definition t_eb : e := ex (xUserDef "b").
Definition t_ec : e := ex (xUserDef "c").
Definition t_ed : e := ex (xUserDef "d").

Lemma gPhiApp1 : gPhiAppWorksFor [phiAcc t_ea "f"] [phiAcc t_eb "f"].
Proof.
  unfold gPhiAppWorksFor, gPhiApp. simpl.
  splau. splau.
  intros. unf.
  exists [phiAcc t_eb "f"].
  split. admit.
  splau.
Admitted.

Lemma gPhiApp2 : ~ gPhiAppWorksFor [phiAcc t_ea "f"] [phiEq (edot t_ea "f") t_eb].
Proof.
  unfold gPhiAppWorksFor, gPhiApp. simpl.
  intro. unf.
  specialize (H2 [phiAcc t_ea "f"; phiEq (edot t_ea "f") t_eb]).
  lapply H2; intros.
  - unf.
    admit.
  - split. admit.
    cut.
Admitted.

Lemma gPhiApp3 : gPhiAppWorksFor [phiEq (edot t_ea "f") t_eb] [phiAcc t_ea "f"].
Proof.
  unfold gPhiAppWorksFor, gPhiApp. simpl.
  splau. splau.
  intros. unf.
  exists [phiAcc t_ea "f"].
  split. admit.
  splau.
Admitted.

Close Scope string.

(* partial galois connection *)
Theorem GLIFT_concat : forall (p : phi),
  GLIFTmp1 (fun p' => p' ++ p) (gPhiApp p).
Proof.
  unfold gPhiApp.
  unfold GLIFTmp1.
  unfold PLIFTm1.
  intros. inv H1. inv H3.

  destruct gp1, gp2'. simpl in *. subst.
  rename H4 into ass.

  inv H.
  inv H0.
  inv H.

  assert (gGood (b, p1 ++ p0)) as gg.
    unf.
    assert (good x). eapp H5. subst.
    unfold gGamma' in H.
    eca; simpl in *.
      unfold gphiSatisfiable. simpl.
      destruct b; simpl in *.
        inv H0.
        invE H6 h.
        invE H6 r.
        invE H6 a.
        exists h.
        exists r.
        exists a.
        apply evalphiSymm in H6.
        apply evalphiSymm.
        apply evalphiApp in H6. unf.
        eapp evalphiAppRev.
      subst.
      apply H0.
    unfold sfrmgphi.
    destruct b. eca.
    subst.
    apply or_intror.
    simpl.
    apply H0.

  unf.
  assert (good x). eapp H5. subst.

  simpl.
  unfold gphiEquals.
  eexists.
  eexists.
  split. eca.
  split. eca.
  split.
  - destruct b.
    * repeat intro.
      inv H6. simpl in *.
      destruct gp2.
      destruct b.
      + inv H1. inv H2. inv gg. unfold gphiSatisfiable in *.
        clear H9 H10 H11.
        clear H4 H5.

        unfold gGamma' in *. simpl in *. unf.
        splau.
        assert (∀ p2 : phi, (good p2 ∧ phiImplies p2 p1) → good (p2 ++ p0) ∧ phiImplies (p2 ++ p0) p3).
          intros.
          apply H3. eex; apply H.
        clear H3.

(*         specialize (H (p2 WO p0)). *)
        specialize (ass p2).
        intuition. unf.
        specialize (H x).
        intuition.
        apply (phiImpliesTrans p2 (x ++ p0) p3); auto.
      + assert (x0 ++ p0 = p3).
          apply H3.
          exists (x0).
          cut.
        assert (phiTrue :: x0 ++ p0 = p3).
          apply H3.
          exists (phiTrue :: x0).
          splau.
          inv H0.
          eca.
            eca.
              eappIn phiImpliesSatisfiable H9.
              repeat intro. eca. apply inclEmpty. eca. common. eapp phiImpliesPrefix.
            repeat eca. eapp sfrmphiApp.
          inv H.
          eappIn phiImpliesTrans H6.
          rewrite cons2app. eapp phiImpliesSuffix.
        subst.
        apply infRecList in H9.
        tauto.
    * repeat intro.
      apply H3.
      inv H6.
      exists p1.
      splau.
      eca.
  - apply H4. assumption.
    unfold pincl. intros.
    unf. assert (good p2). eapp H5.
    subst.
    destruct b; inv H6; cut.
    unfold gGamma'.
    simpl in *.
    splau.
    repeat intro.
    apply evalphiSymm in H6.
    apply evalphiSymm.
    apply evalphiApp in H6. unf.
    eapp evalphiAppRev.
Qed.

Definition nPhiWithout (x : x) (p1 p2 : phi) :=
  phiSatisfiable p1 /\
  minWith (fun p => phiImplies p1 p /\ ~ In x (FV p)) phiImplies p2.

Lemma nPhiWithoutGoodSat : forall x p1 p2,
  nPhiWithout x p1 p2 ->
  phiSatisfiable p1 ->
  phiSatisfiable p2.
Proof.
  intros.
  eapp (phiImpliesSatisfiable p1 p2).
  apply H.
Qed.
Lemma nPhiWithoutGoodSfrm : forall x p1 p2,
  nPhiWithout x p1 p2 ->
  sfrmphi [] p1 ->
  sfrmphi [] p2.
Proof.
  intros.
  admit.
Admitted.
Lemma nPhiWithoutGood : forall x p1 p2,
  nPhiWithout x p1 p2 ->
  good p1 ->
  good p2.
Proof.
  intros.
  inv H0.
  eca.
  - eapply nPhiWithoutGoodSat; eauto.
  - eapply nPhiWithoutGoodSfrm; eauto.
Qed.

Definition gPhiWithout (x : x) (gp1 gp2 : gphi) : Prop :=
  fst gp2 = fst gp1 /\
  nPhiWithout x (snd gp1) (snd gp2).

Lemma gPhiWithoutGood : forall x p1 p2,
  gPhiWithout x p1 p2 ->
  gGood p1 ->
  gGood p2.
Proof.
  intros.
  destruct p1, p2.
  inv H.
  inv H0.
  unfold gGood, gphiSatisfiable, sfrmgphi in *.
  simpl in *. subst.
  destruct b.
  - splau.
    eapply nPhiWithoutGoodSat; eauto.
  - split.
    * eapply nPhiWithoutGoodSat; eauto.
    * apply or_intror.
      inv H3; cut.
      eapply nPhiWithoutGoodSfrm; eauto.
Qed.

(* Lemma phiImpliesNarrowWithout : forall p1 p2 x,
  sfrmphi [] p2 ->
  ~ In x (FV p2) ->
  phiImplies p1 p2 ->
  exists p',
  sfrmphi [] p' /\
  ~ In x (FV p') /\
  phiImplies p1 p' /\ phiImplies p' p2.
Proof.
Admitted. *)

Theorem GLIFT_Without : forall (x : x),
  GLIFTpp1 (nPhiWithout x) (gPhiWithout x).
Proof.
  unfold GLIFTpp1.
  unfold PLIFTp1.
  intros.
  inv H.
  unfold gphiEquals.
  eexists. eexists.
  split. eca. apply gPhiWithoutGood in H1; auto.
  split. inv H0. eca.
  unfold pphiEquals.
  unfold gPhiWithout in *.
  destruct gp1, gp2, gp2'. simpl in *. unf. subst.
  destruct b, b0.
  - inv H0.

    split.
    * repeat intro.
      unfold pincl in H4.
      assert (∀ p p', gGamma' (true, p0) p' ∧ nPhiWithout x p' p → gGamma' (true, p1) p)
      as ass1.
        intros.
        apply H4.
        exists p'.
        assumption.
      clear H4.
      unfold gGamma' in *. simpl in *. unf.
      splau.
      eapp phiImpliesTrans.
      assert (∀ p p', good p' -> phiImplies p' p0 -> nPhiWithout x p' p → phiImplies p p1)
      as ass2.
        intros.
        lapply (ass1 p4 p'); intros; cut.
      clear ass1.
      specialize (ass2 p2).
      admit. (*OK*)
(*       eapply ass2; auto. *)
    * apply H5; clear H5.
      + inv H3. inv H5. unf.
        eca; cut.
        eapp phiImpliesSatisfiable.
      + repeat intro.
        unf.
        admit.
  - (* CONTRADICT: a(MUCH) != static *)
    exfalso.
    inv H0.
    clear H5.
    unfold pincl in *.
    pose proof (H4 (p2)) as ap1.
    pose proof (H4 (phiTrue :: p2)) as ap2.
    clear H4.

    apply imply_to_or in ap1.
    apply imply_to_or in ap2.
    inv ap1.
      contradict H0.
      admit.
    inv ap2.
      contradict H4.
      admit.

    inv H0. inv H4.
    apply infRecList in H0.
    auto.
  - (* CONTRADICT: a(SINGLE) != gradual *)
    exfalso.
    unfold gGamma' in *. simpl in *.
    inv H0.
    unfold pincl in *.
    specialize (H4 p2). lapply H4; intros. Focus 2. exists p0. cut. clear H4.
    assert (∀ gp' : gphi,
     gGood gp'
     → (∀ p : phi, nPhiWithout x p0 p → gGamma' gp' p)
     → ∀ p : phi, good p -> phiImplies p p1 → gGamma' gp' p)
    as ass.
      intros.
      apply H5; auto.
        intros.
        apply H6. unf. subst. assumption.
      eca.
    clear H5.
    inv H0. simpl in *.

    specialize (ass (false, p0)).
    admit.
  - inv H0.
    clear H5.
    unfold pincl in H4.
    unfold gGamma' in *. simpl in *.
    assert (p2 = p1).
      apply H4. exists p0. cut.
    subst.
    split; cut.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C D U Xu : Universe, ((wd_ U O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ D O /\ (wd_ O Eprime /\ (wd_ U Eprime /\ (wd_ B Xu /\ (wd_ U Eprime /\ (wd_ O E /\ (wd_ A Eprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O E U /\ (col_ B U Eprime /\ (col_ Xu U Eprime /\ (col_ O Eprime Xu /\ col_ O E Xu)))))))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C AB ABC Cprime Bprime BCprime : Universe, ((wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Bprime O /\ (wd_ Cprime O /\ (wd_ C Cprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E AB /\ (col_ O E C /\ (col_ O E Cprime /\ (col_ O E ABC /\ (col_ O Eprime Cprime /\ (col_ O Eprime Bprime /\ col_ O Eprime BCprime))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Bprime Cprime P Q : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ P Q /\ (wd_ B Bprime /\ (wd_ A Cprime /\ (wd_ Bprime Cprime /\ (wd_ A Bprime /\ (wd_ B Cprime /\ (col_ A P Q /\ (col_ Bprime P Q /\ (col_ Cprime P Q /\ (col_ A B C /\ (col_ C B Bprime /\ col_ A Bprime Cprime)))))))))))))) -> col_ A B Bprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Util CSet IL Annotation AnnP MapSep InfiniteSubset InfinitePartition.

Set Implicit Arguments.

(** * BoundedIn *)
Definition bounded_in (X : Type) `{OrderedType X} (D : ⦃X⦄) (k : nat)
  : ⦃X⦄ -> Prop
  := fun a => cardinal (D ∩ a) <= k.

Lemma filter_meet_idem X `{OrderedType X} (p:X -> bool) `{Proper _ (_eq ==> eq) p} s
  : SetInterface.filter p s ∩ s [=] SetInterface.filter p s.
Proof.
  split; cset_tac.
Qed.

Lemma bounded_in_part_bounded X `{OrderedType X} (p:inf_subset X) (VD:set X) k lv
      (BND:bounded_in VD k lv)
      (AP : For_all (fun x => p x) VD)
      (Incl : lv ⊆ VD)
  : part_bounded X p k lv.
Proof.
  unfold part_bounded, bounded_in in *.
  rewrite <- (@filter_incl _ _ p) in Incl; eauto.
  rewrite <- Incl in BND. rewrite filter_meet_idem in BND; eauto.
Qed.

Lemma ann_P_bounded_in_part_bounded X `{OrderedType X}
      (p :inf_subset X) k lv (VD:set X)
      (AN:ann_P (bounded_in VD k) lv)
      (AP:For_all (inf_subset_P p) VD)
      (Incl:ann_P (fun x => x ⊆ VD) lv)
  : ann_P (part_bounded X p k) lv.
Proof.
  general induction AN; inv Incl; simpl in *;
    econstructor; eauto using bounded_in_part_bounded.
Qed.


Require Export XR_R.
Require Export XR_Rmult.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rmult_eq_compat_l : forall r r1 r2, r1 = r2 -> r * r1 = r * r2.
Proof.
  intros x y z.
  intro heq.
  subst z.
  reflexivity.
Qed.


(* -------------------------------------------------------------------- *)
(* 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 Bignums Require Import BigQ.
From Coq Require Import PArith PeanoNat.
From mathcomp Require Import all_ssreflect all_algebra.
From Trakt Require Import Trakt.

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

Import Order.Theory.
(* -------------------------------------------------------------------- *)

Section Misc.

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 int2ZK : cancel int2Z Z2int.
Proof.
case=> n; rewrite /Z2int /int2Z.
- by case: n=> // n; rewrite Nat2Pos.id //.
- by rewrite Nat2Pos.id.
Qed.

Lemma Z2intK : cancel Z2int int2Z.
Proof.
case=> [|p|p] //; rewrite /int2Z /Z2int.
- elim:p=> // p; rewrite !Pos2Nat.id //= Pos2Nat.inj_xO.
  by case: (Pos.to_nat p).
- move:(Pos2Nat.is_pos p); case E: (Pos.to_nat p)=> [|n].
  + by move/Nat.lt_irrefl.
  + by move=> _; rewrite -NegzE -E Pos2Nat.id.
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; first exact: ltnW.
    by rewrite GRing.opprB.
  + move=> /[dup] /Pnat.Pos2Nat.inj_lt + /Pnat.Pos2Nat.inj_sub ->.
    rewrite !minusE=> /ssrnat.ltP pq.
    by rewrite -subzn; first 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; first exact: ltnW.
    by rewrite GRing.addrC.
  + move=> /[dup] /Pnat.Pos2Nat.inj_lt /ssrnat.ltP pq /Pnat.Pos2Nat.inj_sub ->.
    rewrite -subzn; first 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.
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 ?GRing.mul1r.
{ 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.
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)|)).
{ 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.

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; first 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.

End Misc.

Section BigQRat.

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

Lemma ratBigQ_red x y : bigQ_to_rat 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 /bigQ_to_rat -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 //; first 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 bigQ_to_rat_red (q : bigQ):
  match BigQ.red q with
  | BigQ.Qz n => numq (bigQ_to_rat q) = Z2int [n]%bigZ /\ denq (bigQ_to_rat q) = 1%R
  | BigQ.Qq n d => numq (bigQ_to_rat q) = Z2int [n]%bigZ /\ denq (bigQ_to_rat q) = Z2int [d]%bigN
  end.
Proof. exact/ratBigQ_red. Qed.

Definition int_to_bigQ (q : int) : bigQ :=
  BigQ.Qz (BigZ.of_Z (int2Z q)).

Lemma int_to_bigQK (x : int): bigQ_to_rat (int_to_bigQ x) = ratz x.
Proof.
rewrite /bigQ_to_rat /= Z_ggcd_1_r /=.
rewrite Pos2Nat.inj_1 GRing.divr1 BigZ.spec_of_Z int2ZK.
by rewrite ratzE.
Qed.

Lemma bigQ_to_rat_opp (x : bigQ): bigQ_to_rat (BigQ.opp x) = (- (bigQ_to_rat x))%R.
Proof.
rewrite /bigQ_to_rat.
rewrite BigQ.strong_spec_opp Qreduction.Qred_opp [in LHS]/QArith_base.Qnum /=.
by rewrite Z2int_opp mulrNz GRing.mulNr.
Qed.

Lemma int_to_bigQ_opp (x : int): bigQ_to_rat (BigQ.opp (int_to_bigQ x)) = (- (ratz x))%R.
Proof.
by rewrite bigQ_to_rat_opp int_to_bigQK.
Qed.

Lemma bigQ_red_inv (x : bigQ):
  (BigQ.inv (BigQ.red x) == BigQ.red (BigQ.inv x))%bigQ.
Proof.
Admitted.

Lemma bigQ_to_rat_red_always (x : bigQ):
  bigQ_to_rat x = bigQ_to_rat (BigQ.red x).
Proof.
by rewrite /bigQ_to_rat BigQ.strong_spec_red Qcanon.Qred_involutive.
Qed.

(* Lemma foo (x : bigQ):
  bigQ_to_rat (BigQ.inv x) = bigQ_to_rat (BigQ.inv (BigQ.red x)).
Proof.
rewrite bigQ_to_rat_red_always /bigQ_to_rat.
by move/Qreduction.Qred_complete: (bigQ_red_inv x)=> <-.
Qed. *)

Lemma bigQ_to_rat_inv (x : bigQ):
  bigQ_to_rat (BigQ.inv x) = ((bigQ_to_rat x)^-1)%R.
Proof.
Admitted.

(* rewrite foo -[bigQ_to_rat x]divq_num_den.
move: (bigQ_to_rat_red x).
case: (BigQ.red x)=> [z|n d] [-> ->].
- rewrite /bigQ_to_rat.
  move/Qreduction.Qred_complete: (BigQ.spec_inv (BigQ.Qz z))=> ->.
  rewrite /BigQ.to_Q /= /QArith_base.Qinv /=.
  case: [z]%bigZ=> /=; first by rewrite Pos2Nat.inj_1 GRing.divr1 rat0 GRing.invr0.
  + by move=> p; rewrite GRing.invf_div Pos2Nat.inj_1.
  + by move=> p; rewrite GRing.invf_div Pos2Nat.inj_1 /= !mulrNz GRing.invrN GRing.mulrN GRing.mulNr.
- rewrite /bigQ_to_rat.
  move/Qreduction.Qred_complete: (BigQ.spec_inv (n # d))=> ->.
  rewrite /QArith_base.Qinv.
  case: (QArith_base.Qnum [n # d]%bigQ).
  + rewrite /=. *)

Lemma int_to_bigQ_inv (x : int):
  bigQ_to_rat (BigQ.inv (int_to_bigQ x)) = fracq (1%R, x).
Proof. by rewrite bigQ_to_rat_inv int_to_bigQK. Qed.

Lemma bigQ_to_rat_mul (x y : bigQ): bigQ_to_rat (BigQ.mul x y) = (bigQ_to_rat x * bigQ_to_rat y)%R.
Proof.
rewrite /bigQ_to_rat.
rewrite (Qreduction.Qred_complete _ _ (BigQ.spec_mul _ _)).
case: (BigQ.to_Q x) => nx dx {x}.
case: (BigQ.to_Q y) => ny dy {y}.
rewrite /QArith_base.Qmult !Z2int_Qred /=.
rewrite Z2int_mul Pos2Nat.inj_mul multE.
rewrite PoszM !intrM.
by rewrite [RHS]GRing.mulf_div.
Qed.

Lemma int_to_bigQ_mul (x y : int):
  bigQ_to_rat (BigQ.mul (int_to_bigQ x) (int_to_bigQ y)) = (ratz x * ratz y)%R.
Proof. by rewrite bigQ_to_rat_mul !int_to_bigQK. Qed.

Inductive formula : Type :=
  |Int: int -> formula
  |Opp: formula -> formula
  |Inv: formula -> formula
  |Mul: formula -> formula -> formula.

Fixpoint form_to_bigQ (x : formula):=
  match x with
  |Int n => int_to_bigQ n
  |Opp x' => BigQ.opp (form_to_bigQ x')
  |Inv x' => BigQ.inv (form_to_bigQ x')
  |Mul x' y' => BigQ.mul (form_to_bigQ x') (form_to_bigQ y')
  end.

Fixpoint form_to_rat (x : formula):=
  match x with
  |Int n => ratz n
  |Opp x' => (- (form_to_rat x'))%R
  |Inv x' => ((form_to_rat x')^-1)%R
  |Mul x' y' => ((form_to_rat x') * (form_to_rat y'))%R
  end.

Lemma foo (x : formula):
  bigQ_to_rat (form_to_bigQ x) = form_to_rat x.
Proof.
elim: x.
- by move=> n /=; rewrite int_to_bigQK.
- by move=> f /=; rewrite bigQ_to_rat_opp => ->.
- by move=> f /= <-; rewrite bigQ_to_rat_inv.
- by move=> f /= <- f' <-; rewrite bigQ_to_rat_mul.
Qed.

End BigQRat. *)