Require Import Coq.Sets.Ensembles.
Require Import Coq.Sets.Finite_sets.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import CertiGraph.Coqlib.
Require Import CertiGraph.msl_ext.abs_addr.
Require Import CertiGraph.msl_ext.seplog.
Require Import CertiGraph.msl_ext.log_normalize.
Require Import CertiGraph.msl_ext.iter_sepcon.
Require Import CertiGraph.graph.graph.
Require Import CertiGraph.graph.graph_reachable.
Require Import Coq.Logic.Classical.
Import CertiGraph.msl_ext.seplog.OconNotation.

Definition gamma {Vertex Data} {EV: EqDec Vertex} {PG : PreGraph Vertex Data} (BG: BiGraph PG) (v: Vertex) : Data * Vertex * Vertex := let (v1, v2) := biEdge BG v in (node_label v, v1, v2).

Lemma update_bigraph_gamma {A D: Type} {EV: EqDec A} {PG : PreGraph A D}:
  forall (g: BiGraph PG) (v: A) (d: D) (l r: A), gamma (update_BiGraph g v d l r) v = (d, l, r).
Proof.
  intros. unfold gamma, biEdge. destruct (@only_two_neighbours A D EV _ (@update_BiGraph A D EV PG g v d l r) v) as [v1 [v2 ?]].
  simpl in *. unfold change_edge_func, change_node_label in *. destruct (t_eq_dec v v).
  + inversion e. subst; auto.
  + exfalso; auto.
Qed.

Class PointwiseGraphSetting: Type := {
  Data: Type;
  addr: Type;
  null: addr;
  addr_eq_dec: forall x y: addr, {x = y} + {x <> y};
  addr_eqb: addr -> addr -> bool := fun x y => if addr_eq_dec x y then true else false
}.

Instance AV_SGraph `{PointwiseGraphSetting} : AbsAddr.
  apply (mkAbsAddr addr (Data * addr * addr) (fun x y => addr_eqb x y)); simpl; intros.
  + unfold addr_eqb.
    destruct (addr_eq_dec p1 p2), (addr_eq_dec p2 p1); try congruence.
  + unfold addr_eqb in H0.
    destruct (addr_eq_dec p1 p1); congruence.
Defined.

Instance AddrDec `{PointwiseGraphSetting}: EqDec Addr. apply Build_EqDec. intros. apply (addr_eq_dec t1 t2). Defined.
Opaque AddrDec.

Definition Null {SGS: PointwiseGraphSetting} : (@Addr AV_SGraph) := null.

Class Graph {SGS: PointwiseGraphSetting} : Type := {
  pg: PreGraph Addr Data;
  bi: BiGraph pg;
  ma: MathGraph pg Null
}.

Coercion pg : Graph >-> PreGraph.

Coercion bi : Graph >-> BiGraph.

Coercion ma : Graph >-> MathGraph.

Instance single_graph_double {SGS: PointwiseGraphSetting} v d (Hn: v <> Null): Graph := {
  pg := single_PreGraph _ v d v v;
  bi := single_BiGraph _ v d v v;
  ma := single_MathGraph_double _ _ v d Hn
}.

Instance single_graph_left {SGS: PointwiseGraphSetting} v d (Hn: v <> Null): Graph := {
  pg := single_PreGraph _ v d v Null;
  bi := single_BiGraph _ v d v Null;
  ma := single_MathGraph_left _ _ v d Hn
}.

Instance single_graph_right {SGS: PointwiseGraphSetting} v d (Hn: v <> Null): Graph := {
  pg := single_PreGraph _ v d Null v;
  bi := single_BiGraph _ v d Null v;
  ma := single_MathGraph_right _ _ v d Hn
}.

Class PointwiseGraphAssum: Type := {
  SGA_Pred: Type;
  SGA_ND: NatDed SGA_Pred;
  SGA_SL : SepLog SGA_Pred;
  SGA_ClSL: ClassicalSep SGA_Pred;
  SGA_PSL : PreciseSepLog SGA_Pred;
  SGA_CoSL: CorableSepLog SGA_Pred;
  SGA_OSL: OverlapSepLog SGA_Pred;
  SGA_DSL : DisjointedSepLog SGA_Pred;
  SGA_COSL: CorableOverlapSepLog SGA_Pred;

  SG_Setting: PointwiseGraphSetting;
  trinode : Addr -> Val -> SGA_Pred;
  SGA_MSL: MapstoSepLog AV_SGraph trinode;
  SGA_sMSL: StaticMapstoSepLog AV_SGraph trinode(* ; *)
  (* SGA_nMSL: NormalMapstoSepLog AV_SGraph trinode *)
}.

Global Existing Instances SGA_ND SGA_SL SGA_ClSL SGA_PSL SGA_CoSL SGA_OSL SGA_DSL SGA_COSL SG_Setting SGA_MSL SGA_sMSL (* SGA_nMSL *).

Hint Resolve SGA_ND SGA_SL SGA_ClSL SGA_PSL SGA_CoSL SGA_OSL SGA_DSL SGA_COSL SG_Setting SGA_MSL SGA_sMSL (* SGA_nMSL *).

Local Open Scope logic.

Section PointwiseGraph.

  Context {SGA : PointwiseGraphAssum}.

  Definition graph_cell (g: Graph) (v : Addr) : SGA_Pred := trinode v (gamma g v).

  Lemma precise_graph_cell: forall g v, precise (graph_cell g v).
  Proof. intros. unfold graph_cell. destruct (gamma bi v) as [[? ?] ?]. apply mapsto_precise. Qed.

  Lemma sepcon_unique_graph_cell: forall g, sepcon_unique (graph_cell g).
  Proof.
    repeat intro. unfold graph_cell. destruct (gamma bi x) as [[? ?] ?]. apply mapsto_conflict.
    simpl. unfold addr_eqb. destruct (addr_eq_dec x x); auto.
  Qed.

  Lemma joinable_graph_cell : forall g, joinable (graph_cell g).
  Proof.
    intros. unfold joinable; intros. unfold graph_cell. apply disj_mapsto.
    simpl. unfold addr_eqb. destruct (addr_eq_dec x y); tauto.
  Qed.

  Existing Instances pg bi ma.

  Definition graph (x : Addr) (g: Graph) : SGA_Pred :=
    !!(x = Null \/ valid x) && EX l : list Addr, !!reachable_list pg x l && iter_sepcon l (graph_cell g).

  Lemma graph_unfold_Null: forall (g: Graph), graph Null g = emp.
  Proof.
    intros. apply pred_ext; unfold graph.
    + apply andp_left2, exp_left. intros. apply derives_extract_prop. intro. destruct x.
      - simpl. apply derives_refl.
      - exfalso. assert (In a (a :: x)). apply in_eq. rewrite (H a) in H0. apply reachable_head_valid in H0.
        apply valid_not_null in H0. auto.
    + apply andp_right.
      - apply prop_right. left; auto.
      - apply (exp_right nil). simpl. apply andp_right.
        * apply prop_right. intro. split; intro. inversion H. apply reachable_head_valid in H.
          apply valid_not_null in H. exfalso; auto.
        * apply derives_refl.
  Qed.

  Lemma graph_unfold_valid:
    forall x (g: Graph) d l r, valid x -> gamma g x = (d, l, r) ->
                         graph x g = trinode x (d, l, r) ⊗ graph l g ⊗ graph r g.
  Proof.
    intros. assert (TRI: trinode x (d, l, r) = iter_sepcon (x :: nil) (graph_cell g)). {
      unfold iter_sepcon. rewrite sepcon_comm, emp_sepcon. unfold graph_cell. rewrite H0. auto.
    } apply pred_ext.
    + unfold graph. apply andp_left2, exp_left. intro li.
      rewrite (add_andp _ _ (iter_sepcon_unique_nodup li (sepcon_unique_graph_cell g))). normalize_overlap.
      rename H2 into NODUPLi.
      unfold gamma in H0. unfold biEdge in H0. destruct (only_two_neighbours x) as [v1 [v2 ?]].
      inversion H0; subst. clear H0.
      assert (In l (edge_func x)). rewrite e. apply in_eq.
      destruct (compute_neighbor g x li H H1 l H0) as [leftL [? ?]].
      assert (In r (edge_func x)). rewrite e. apply in_cons, in_eq.
      destruct (compute_neighbor g x li H H1 r H4) as [rightL [? ?]].
      apply (exp_right rightL). normalize_overlap. apply (exp_right leftL). normalize_overlap. apply andp_right.
      - rewrite <- !prop_and. apply prop_right. do 2 (split; auto).
        split.
        * destruct (weak_valid_complete _ (valid_graph x H r H4)); auto.
        * destruct (weak_valid_complete _ (valid_graph x H l H0)); auto.
      - rewrite TRI, ocon_assoc.
        rewrite !(iter_sepcon_ocon t_eq_dec); auto.
        2: repeat constructor; simpl; tauto.
        2: apply remove_dup_nodup.
        2: apply precise_graph_cell.
        2: apply joinable_graph_cell.
        2: apply precise_graph_cell.
        2: apply joinable_graph_cell.
        rewrite iter_sepcon_permutation with (l2 := remove_dup t_eq_dec ((x :: nil) ++ remove_dup t_eq_dec (leftL ++ rightL))).
        * apply derives_refl.
        * apply (eq_as_set_permutation t_eq_dec); auto.
          apply remove_dup_nodup. apply eq_as_set_spec. intro y.
          rewrite <- remove_dup_in_inv. simpl.
          rewrite <- remove_dup_in_inv.
          rewrite in_app_iff. rewrite (H1 y).
          apply (reachable_list_bigraph_in l r); auto.
    + unfold graph. normalize_overlap. intro rightL. normalize_overlap. intro leftL. normalize_overlap.
      apply (exp_right (remove_dup t_eq_dec ((x :: nil) ++ remove_dup t_eq_dec (leftL ++ rightL)))). rewrite <- andp_assoc.
      rewrite <- prop_and. rewrite TRI.
      rewrite (add_andp _ _ (iter_sepcon_unique_nodup leftL (sepcon_unique_graph_cell g))).
      rewrite (add_andp _ _ (iter_sepcon_unique_nodup rightL (sepcon_unique_graph_cell g))).
      normalize_overlap. apply andp_right.
      - apply prop_right. split. right; auto. intro.
        rewrite <- remove_dup_in_inv. simpl. rewrite <- remove_dup_in_inv.
        rewrite in_app_iff. symmetry. apply (reachable_list_bigraph_in l r); auto.
        unfold gamma in H0. unfold biEdge in H0. destruct (only_two_neighbours x) as [? [? ?]]. inversion H0. subst. auto.
      - rewrite ocon_assoc. rewrite !(iter_sepcon_ocon t_eq_dec); auto.
        * repeat constructor; simpl; tauto.
        * apply remove_dup_nodup.
        * apply precise_graph_cell.
        * apply joinable_graph_cell.
        * apply precise_graph_cell.
        * apply joinable_graph_cell.
  Qed.

  Lemma graph_root_nv: forall x g, graph x g |-- !!(x = Null \/ valid x).
  Proof. intros. unfold graph. apply andp_left1, prop_left. intros. apply TT_prop_right; auto. Qed.

  Lemma graph_unfold':
    forall x g,
      graph x g = (!!(x = Null) && emp) ||
          EX d:Data, EX l:Addr, EX r:Addr, !!(gamma g x = (d, l, r) /\ valid x) &&
                                                        (trinode x (d, l, r) ⊗ graph l g ⊗ graph r g).
  Proof.
    intros. apply pred_ext.
    + destruct (t_eq_dec x Null).
      - subst. apply orp_right1. rewrite graph_unfold_Null. normalize.
      - apply orp_right2. destruct (gamma g x) as [[dd ll] rr] eqn:? .
        apply (exp_right dd), (exp_right ll), (exp_right rr).
        rewrite (add_andp _ _ (graph_root_nv x g)). apply andp_right.
        * apply andp_left2, prop_left; intros. apply TT_prop_right. destruct H. tauto. split; auto.
        * normalize. destruct H; [tauto | rewrite (graph_unfold_valid _ _ dd ll rr); auto].
    + apply orp_left.
      - normalize. rewrite graph_unfold_Null. auto.
      - normalize. intros d l r [? ?]. rewrite <- (graph_unfold_valid _ _ d l r); auto.
  Qed.

  Lemma graph_unfold:
    forall x (g: Graph) d l r, gamma g x = (d, l, r) ->
                         graph x g = !!(x = Null) && emp ||
                                        !!(valid x) && (trinode x (d, l, r) ⊗ graph l g ⊗ graph r g).
  Proof.
    intros. apply pred_ext.
    + rewrite (add_andp _ _ (graph_root_nv x g)). normalize. destruct H0.
      - subst. rewrite graph_unfold_Null. apply orp_right1. normalize.
      - apply orp_right2. rewrite (graph_unfold_valid _ _ d l r H0 H). normalize.
    + apply orp_left.
      - normalize. rewrite graph_unfold_Null. auto.
      - normalize. rewrite (graph_unfold_valid _ _ d l r H0 H). auto.
  Qed.

  Lemma precise_graph: forall x g, precise (graph x g).
  Proof.
    intros. apply precise_andp_right. apply precise_exp_iter_sepcon.
    + apply sepcon_unique_graph_cell.
    + apply classic.
    + apply precise_graph_cell.
    + apply reachable_list_permutation.
  Qed.

  Fixpoint graphs (l : list Addr) g :=
    match l with
      | nil => emp
      | v :: l' => graph v g ⊗ graphs l' g
    end.

  Lemma precise_graphs: forall S g, precise (graphs S g).
  Proof. intros; induction S; simpl. apply precise_emp. apply precise_ocon. apply precise_graph. apply IHS. Qed.

  Lemma graphs_list_well_defined: forall S g, graphs S g |-- !!well_defined_list g S.
  Proof.
    induction S; intros; unfold well_defined_list in *; simpl.
    + apply prop_right. intros; tauto.
    + unfold graph.
      rewrite (add_andp _ _ (IHS _)).
      normalize_overlap.
      apply prop_right.
      intro y; intros. destruct H1.
      - subst. auto.
      - specialize (H0 _ H1). apply H0.
  Qed.

  Lemma graphs_unfold: forall S g, graphs S g =
                                      !!(well_defined_list g S) &&
                                      EX l: list Addr, !!reachable_set_list pg S l &&
                                                       iter_sepcon l (graph_cell g).
  Proof.
    induction S; intros.
    + unfold graphs. apply pred_ext.
      - apply andp_right.
        * apply prop_right. hnf. intros. inversion H.
        * apply (exp_right nil). simpl. apply andp_right; auto. apply prop_right. hnf.
          intros. split; intros. unfold reachable_through_set in H. destruct H as [s [? _]]. inversion H. inversion H.
      - normalize. destruct l. simpl; auto. hnf in H0. specialize (H0 a).
        assert (In a (a :: l)) by apply in_eq.
        rewrite <- H0 in H1. unfold reachable_through_set in H1. destruct H1 as [? [? _]]. inversion H1.
    + unfold graphs. fold graphs. rewrite IHS. unfold graph. apply pred_ext. clear IHS.
      - normalize_overlap. rename x into la.
        normalize_overlap. rename x into lS.
        normalize_overlap.
        rewrite (add_andp _ _ (iter_sepcon_unique_nodup la (sepcon_unique_graph_cell g))).
        rewrite (add_andp _ _ (iter_sepcon_unique_nodup lS (sepcon_unique_graph_cell g))).
        normalize_overlap.
        rewrite (iter_sepcon_ocon t_eq_dec); auto. apply (exp_right (remove_dup t_eq_dec (la ++ lS))).
        rewrite <- andp_assoc, <- prop_and. apply andp_right.
        * apply prop_right. split.
          1: {
            unfold well_defined_list in *. intros. simpl in H5.
            destruct H5; [subst | apply H0]; auto. }
          1: {
            unfold reachable_set_list in *.
            unfold reachable_list in *. intros.
            rewrite <- remove_dup_in_inv.
            rewrite reachable_through_set_eq.
            specialize (H1 x). specialize (H2 x).
            split; intro; [apply in_or_app | apply in_app_or in H5];
            destruct H5; [left | right | left | right]; tauto.
          }
        * auto.
        * apply precise_graph_cell.
        * apply joinable_graph_cell.
      - normalize.
        assert (In a (a :: S)) by apply in_eq.
        assert (weak_valid a). 1: {
          unfold well_defined_list in H.
          specialize (H a).
          destruct (H H1); apply weak_valid_spec; [left | right]; auto.
        }
        destruct (reachable_through_single_reachable g _ _ H0 a H1 H2) as [la [? ?]].
        normalize_overlap. apply (exp_right la).
        assert (Sublist S (a :: S)) by (intro s; intros; apply in_cons; auto).
        assert (well_defined_list g S) by (unfold well_defined_list in *; intros; apply H; apply in_cons; auto).
        destruct (reachable_through_sublist_reachable _ _ _ H0 _ H5 H6) as [lS [? ?]].
        normalize_overlap. apply (exp_right lS). normalize_overlap.
        rewrite <- !prop_and. apply andp_right.
        * apply prop_right. auto.
        * rewrite (add_andp _ _ (iter_sepcon_unique_nodup l (sepcon_unique_graph_cell g))).
          normalize.
          rewrite (iter_sepcon_ocon t_eq_dec); auto.
          2: apply precise_graph_cell.
          2: apply joinable_graph_cell.
          rewrite iter_sepcon_permutation with (l2 := remove_dup t_eq_dec (la ++ lS)); auto.
          apply NoDup_Permutation; auto. apply remove_dup_nodup.
          intros. rewrite <- remove_dup_in_inv. clear -H7 H3 H0.
          specialize (H0 x). specialize (H7 x). specialize (H3 x). rewrite <- H0.
          rewrite reachable_through_set_eq. rewrite in_app_iff. tauto.
  Qed.

  Lemma reachable_eq_graphs_eq:
    forall S S' (g: Graph), Same_set (reachable_through_set pg S) (reachable_through_set pg S') ->
                      well_defined_list g S -> well_defined_list g S' ->  graphs S g = graphs S' g.
  Proof.
    intros; apply pred_ext; rewrite !graphs_unfold; normalize; apply (exp_right l);
    normalize; apply andp_right; auto; apply prop_right; unfold reachable_set_list in *;
    destruct H; unfold Included in * |- ; intros; rewrite <- H2; split; unfold Ensembles.In in *; auto.
  Qed.

  Lemma single_graph_growth_double:
    forall x d (H: x <> Null), trinode x (d, x, x) |-- graph x (single_graph_double x d H).
  Proof.
    intros. unfold graph. apply andp_right.
    + apply prop_right. right. hnf; auto.
    + apply (exp_right (x :: nil)). apply andp_right.
      - apply prop_right. hnf. intros. split; intros.
        * simpl in H0. destruct H0; try tauto. subst.
          apply reachable_by_reflexive. split; hnf; auto.
        * apply reachable_foot_valid in H0. hnf in H0. subst. apply in_eq.
      - unfold iter_sepcon. unfold graph_cell. rewrite sepcon_emp.
        unfold gamma. unfold biEdge. unfold only_two_neighbours. simpl. auto.
  Qed.

  Lemma single_graph_growth_left:
    forall x d (H: x <> Null), trinode x (d, x, Null) |-- graph x (single_graph_left x d H).
  Proof.
    intros. unfold graph. apply andp_right.
    + apply prop_right. right. hnf; auto.
    + apply (exp_right (x :: nil)). apply andp_right.
      - apply prop_right. hnf. intros. split; intros.
        * simpl in H0. destruct H0; try tauto. subst.
          apply reachable_by_reflexive. split; hnf; auto.
        * apply reachable_foot_valid in H0. hnf in H0. subst. apply in_eq.
      - unfold iter_sepcon. unfold graph_cell. rewrite sepcon_emp.
        unfold gamma. unfold biEdge. unfold only_two_neighbours. simpl. auto.
  Qed.

  Lemma single_graph_growth_right:
    forall x d (H: x <> Null), trinode x (d, Null, x) |-- graph x (single_graph_right x d H).
  Proof.
    intros. unfold graph. apply andp_right.
    + apply prop_right. right. hnf; auto.
    + apply (exp_right (x :: nil)). apply andp_right.
      - apply prop_right. hnf. intros. split; intros.
        * simpl in H0. destruct H0; try tauto. subst.
          apply reachable_by_reflexive. split; hnf; auto.
        * apply reachable_foot_valid in H0. hnf in H0. subst. apply in_eq.
      - unfold iter_sepcon. unfold graph_cell. rewrite sepcon_emp.
        unfold gamma. unfold biEdge. unfold only_two_neighbours. simpl. auto.
  Qed.

  Lemma trinode_iter_sepcon_not_in:
    forall x d l r li g, trinode x (d, l, r) * iter_sepcon li (graph_cell g) |-- !!(~ In x li).
  Proof.
    intros; induction li.
    + apply prop_right. auto.
    + unfold iter_sepcon. fold (iter_sepcon li (graph_cell g)).
      rewrite <- sepcon_assoc. rewrite (sepcon_comm (trinode x (d, l, r))). rewrite sepcon_assoc.
      rewrite (add_andp _ _ IHli). normalize. rewrite <- sepcon_assoc. unfold graph_cell at 1.
      destruct (t_eq_dec a x).
      - subst.
        assert (trinode x (gamma g x) * trinode x (d, l, r) |-- FF). {
          apply mapsto_conflict. simpl. unfold addr_eqb. destruct (addr_eq_dec x x); auto.
        } rewrite (add_andp _ _ H0). normalize.
      - apply prop_right. simpl. intro. destruct H0; auto.
  Qed.

  Lemma trinode_graphs_unreachable:
    forall x d l r S g, x <> Null ->
                        trinode x (d, l, r) * graphs S g |-- !!(forall s, In s S -> ~ reachable g s x /\ s <> x).
  Proof.
    intros. rewrite graphs_unfold. normalize. intro li; intros.
    rewrite (add_andp _ _ (trinode_iter_sepcon_not_in _ _ _ _ _ _)).
    normalize. apply prop_right. intros. split.
    + intro; apply H2. clear H2. specialize (H1 x). rewrite <- H1. exists s. split; auto.
    + intro. subst. unfold reachable_set_list in H1. unfold reachable_through_set in H1.
      apply H2. rewrite <- H1. exists x. split; auto.
      apply reachable_by_reflexive. specialize (H0 x). apply H0 in H3. split.
      - destruct H3. tauto. auto.
      - hnf; auto.
  Qed.

  Lemma reachable_subgraph_derives:
    forall (g1 g2: Graph) x,
      ((reachable_subgraph g1 (x :: nil)) -=- (reachable_subgraph g2 (x :: nil))) ->
      graph x g1 |-- graph x g2.
  Proof.
    Implicit Arguments valid [[Vertex] [Data] [EV]].
    Implicit Arguments only_two_neighbours [[Vertex] [Data] [EV]].
    intros. destruct H as [? [? ?]]. rewrite (add_andp _ _ (graph_root_nv _ _)).
    normalize. destruct H2.
    + subst. rewrite !graph_unfold_Null; auto.
    + unfold graph. normalize. apply (exp_right l).
      rewrite <- andp_assoc, <- prop_and. apply andp_right.
      - apply prop_right. simpl in H. unfold reachable_valid in H. split.
        * right. specialize (H x).
          assert (valid g1 x /\ reachable_through_set g1 (x :: nil) x). {
            split. auto. exists x. split.
            + apply in_eq.
            + apply reachable_by_reflexive. split; auto. hnf; auto.
          } rewrite H in H4. tauto.
        * unfold reachable_list in *. intros. specialize (H3 y).
          specialize (H y). rewrite H3. split; intros.
          1: {
            apply reachable_valid_and_through_single in H4.
            rewrite H in H4. destruct H4. destruct H5 as [s [? ?]].
            simpl in H5. destruct H5. subst; auto. tauto.
          }
          1: {
            apply reachable_valid_and_through_single in H4.
            rewrite <- H in H4. destruct H4. destruct H5 as [s [? ?]].
            simpl in H5. destruct H5. subst; auto. tauto.
          }
      - assert (forall z, In z l -> valid (reachable_subgraph g1 (x :: nil)) z). {
          intros. simpl. hnf. hnf in H3. rewrite H3 in H4. split.
          + apply reachable_foot_valid in H4; auto.
          + exists x. split. apply in_eq. auto.
        } clear H3. induction l. simpl. auto.
        unfold iter_sepcon.
        fold (iter_sepcon l (graph_cell g1)).
        fold (iter_sepcon l (graph_cell g2)).
        apply derives_trans with (graph_cell g1 a * iter_sepcon l (graph_cell g2));
          apply sepcon_derives; auto.
        * apply IHl. intros. apply H4. apply in_cons; auto.
        * unfold graph_cell. unfold gamma. unfold biEdge.
          destruct (only_two_neighbours g1 g1 a) as [? [? ?]].
          destruct (only_two_neighbours g2 g2 a) as [? [? ?]].
          assert (In a (a :: l)) by apply in_eq. specialize (H4 a H3).
          specialize (H0 a H4). specialize (H1 a H4).
          simpl in *. simpl. rewrite H0. rewrite H1 in e.
          rewrite e in e0. inversion e0. subst. auto.
    Implicit Arguments valid [[Vertex] [Data] [EV] [PreGraph]].
    Implicit Arguments only_two_neighbours [[Vertex] [Data] [EV] [BiGraph]].
  Qed.

  Lemma reachable_subgraph_eq:
    forall (g1 g2 : Graph) x,
      ((reachable_subgraph g1 (x :: nil)) -=- (reachable_subgraph g2 (x :: nil))) -> graph x g1 = graph x g2.
  Proof.
    intros. apply pred_ext.
    + apply reachable_subgraph_derives; auto.
    + apply reachable_subgraph_derives; apply vi_sym; auto.
  Qed.

Instance update_graph (g: Graph) v d l r (Hi: in_math g v l r) (Hn: v <> Null): Graph := {
  pg := update_PreGraph _ v d l r;
  bi := update_BiGraph g v d l r;
  ma := update_MathGraph g v d l r Hi Hn
}.

  Lemma graphs_growth: forall x d l r (Hn: x <> Null) (g: Graph) (Hi: in_math g x l r),
                         trinode x (d, l, r) * graphs (l :: r :: nil) g |-- graph x (update_graph g x d l r Hi Hn).
  Proof.
    intros. rewrite (graph_unfold _ _ d l r).
    2 : apply update_bigraph_gamma.
    apply orp_right2, andp_right. apply prop_right; hnf; tauto.
    rewrite (add_andp _ _ (trinode_graphs_unreachable _ _ _ _ _ _ Hn)). normalize.
    apply derives_trans with (trinode x (d, l, r) *
                              (graph l (update_graph g x d l r Hi Hn) ⊗ graph r (update_graph g x d l r Hi Hn))).
    2: rewrite ocon_assoc; apply sepcon_ocon.
    apply sepcon_derives; auto. unfold graphs. rewrite ocon_emp.
    apply ocon_derives; apply reachable_subgraph_derives.
    + assert (In l (l :: r :: nil)) by apply in_eq. destruct (H l H0).
      apply unreachable_node_add_graph_eq with g; eauto. exact g.
    + assert (In r (l :: r :: nil)) by apply in_cons, in_eq. destruct (H r H0).
      apply unreachable_node_add_graph_eq with g; auto. exact g.
  Qed.

  Lemma update_graph_single: forall x d l r (Hn: x <> Null) (g: Graph) (Hi: in_math g x l r),
                               trinode x (d, l, r) |-- graph_cell (update_graph g x d l r Hi Hn) x.
  Proof.
    Implicit Arguments only_two_neighbours [[Vertex] [Data] [EV]].
    intros. unfold graph_cell. unfold gamma. unfold biEdge.
    destruct (only_two_neighbours _ (update_graph g x d l r Hi Hn) x) as [v1 [v2 ?]].
    simpl in e. unfold change_edge_func in e. simpl. unfold change_node_label.
    destruct (@t_eq_dec (@addr (@SG_Setting SGA)) (@AddrDec (@SG_Setting SGA)) x x). 2: tauto.
    inversion e. subst. auto.
    Implicit Arguments only_two_neighbours [[Vertex] [Data] [EV] [BiGraph]].
  Qed.

  Lemma update_graph_iter_sepcon:
    forall x d l r li (Hn: x <> Null) (g: Graph) (Hi: in_math g x l r),
      ~ In x li -> iter_sepcon li (graph_cell g) |-- iter_sepcon li (graph_cell (update_graph g x d l r Hi Hn)).
  Proof.
    Implicit Arguments only_two_neighbours [[Vertex] [Data] [EV]].
    intros.
    induction li. simpl. auto.
    unfold iter_sepcon.
    fold (iter_sepcon li (graph_cell g)).
    fold (iter_sepcon li (graph_cell (update_graph g x d l r Hi Hn))).
    apply sepcon_derives.
    + unfold graph_cell. unfold gamma. unfold biEdge.
      destruct (only_two_neighbours _ (update_graph g x d l r Hi Hn) a) as [v1 [v2 ?]].
      destruct (only_two_neighbours _ g a) as [v3 [v4 ?]].
      assert (x <> a) by (intro; apply H; subst; apply in_eq). simpl in e. simpl. change addr with Addr in *.
      unfold change_node_label. unfold change_edge_func in e.
      destruct (t_eq_dec a x). exfalso; auto. rewrite e in e0. inversion e0. subst. auto.
    + apply IHli. intro. apply H. apply in_cons; auto.
    Implicit Arguments only_two_neighbours [[Vertex] [Data] [EV] [BiGraph]].
  Qed.

  Lemma graph_growth_right: forall x d r (Hn: x <> Null)
                                   (g: Graph) (Hi: in_math g x x r),
                              trinode x (d, x, r) * graph r g |-- graph x (update_graph g x d x r Hi Hn).
  Proof.
    Implicit Arguments only_two_neighbours [[Vertex] [Data] [EV]].
    intros. unfold graph. normalize.
    rewrite (add_andp _ _ (trinode_iter_sepcon_not_in _ _ _ _ _ _)). normalize.
    apply (exp_right (x :: l)). rewrite <- andp_assoc, <- prop_and. apply andp_right.
    + apply prop_right. split.
      - simpl. unfold change_valid. right; right; auto.
      - apply (reachable_list_update_graph_right g x d r Hn Hi l); auto.
    + unfold iter_sepcon at 2. fold (iter_sepcon l (graph_cell (update_graph g x d x r Hi Hn))).
      apply sepcon_derives.
      - apply (update_graph_single x d x r Hn g Hi).
      - apply (update_graph_iter_sepcon x d x r l Hn g Hi H1).
    Implicit Arguments only_two_neighbours [[Vertex] [Data] [EV] [BiGraph]].
  Qed.

  Lemma graph_growth_left: forall x d l (Hn: x <> Null)
                                 (g: Graph) (Hi: in_math g x l x),
                             trinode x (d, l, x) * graph l g |-- graph x (update_graph g x d l x Hi Hn).
  Proof.
    Implicit Arguments only_two_neighbours [[Vertex] [Data] [EV]].
    intros. unfold graph. normalize. intro li; intros.
    rewrite (add_andp _ _ (trinode_iter_sepcon_not_in _ _ _ _ _ _)). normalize.
    apply (exp_right (x :: li)). rewrite <- andp_assoc, <- prop_and. apply andp_right.
    + apply prop_right. split.
      - simpl. unfold change_valid. right; right; auto.
      - apply (reachable_list_update_graph_left g x d l Hn Hi li); auto.
    + unfold iter_sepcon at 2. fold (iter_sepcon li (graph_cell (update_graph g x d l x Hi Hn))).
      apply sepcon_derives.
      - apply (update_graph_single x d l x Hn g Hi).
      - apply (update_graph_iter_sepcon x d l x li Hn g Hi H1).
    Implicit Arguments only_two_neighbours [[Vertex] [Data] [EV] [BiGraph]].
  Qed.

End PointwiseGraph.


(* ***************************************************************** *)
(* Types.v                                                           *)
(*                                                                   *)
(* 2019 Xuan Huang                                                   *)
(* ***************************************************************** *)

(* ################################################################# *)
(** * Types *)

(* It's interesting that if we use

     Require Export Int.
     Require Export Float.

   Here, we will later hit errors in [Execution.v] saying:

     (cannot unify "I32.t" and "Values.I32.t").

   This might be a bug or intentional of Coq.
   Issue posted: https://github.com/coq/coq/issues/10869
 *)

From Wasm Require Import Int.
From Wasm Require Import Float.
From Wasm Require Export Commons.

(* ----------------------------------------------------------------- *)
(** *** Value Types *)

Inductive valtype :=
  | T_i32
  | T_i64
  | T_f32
  | T_f64.

Definition eqb_valtype (ty1 ty2: valtype) : bool :=
  match ty1, ty2 with
  | T_i32, T_i32 => true
  | T_i64, T_i64 => true
  | T_f32, T_f32 => true
  | T_f64, T_f64 => true
  | _, _ => false
  end.

Definition all_valtype (ts: list valtype) (t': valtype) :=
  forallb (fun t => eqb_valtype t t') ts.

Lemma eqb_valtype_refl : forall (ty: valtype),
  eqb_valtype ty ty = true.
Proof.
  destruct ty; auto.
Qed.

Lemma eqb_valtype_eq : forall (ty1 ty2: valtype),
  eqb_valtype ty1 ty2 = true -> ty1 = ty2.
Proof with eauto.
  intro ty1.
  destruct ty1;
    intros ty2 Heqb;
    destruct ty2; inversion Heqb...
Qed.

(** Having eq_dec is equivalent to having eqb and its spec
    How? https://coq.inria.fr/library/Coq.Structures.Equalities.html
  *)
Lemma valtype_eq_dec: forall (ty1 ty2: valtype), {ty1 = ty2} + {ty1 <> ty2}.
Proof.
  decide equality.
Qed.

Module TestValtypeEq.

  Example ex1 : all_valtype [T_i32] T_i32 = true. auto. Qed.

End TestValtypeEq.

(* ----------------------------------------------------------------- *)
(** *** Result Types *)

(** the current spec use optional occurence such as

      Definition resulttype : Type := option valtype.

    while we moved to the "multi-value" proposal where

      resulttype ::= [vec(valtype)]

    See option valtype section below.
 *)

Notation resulttype := (list valtype).

(* ----------------------------------------------------------------- *)
(** *** Function Types *)

Inductive functype := FT (_ _: resulttype).
(*
Record functype :=
  {
    FT_ins  : resulttype;
    FT_outs : resulttype;
  }.
*)

Module FunctypeNotations.

  (* Notation "ts1 --> ts2" := *)
  (*   ({| FT_ins := ts1; FT_outs := ts2|}) *)

  Notation "ts1 --> ts2" := (FT ts1 ts2)
    (at level 30, right associativity) : wasm_scope.
  Open Scope wasm_scope.

End FunctypeNotations.

(** Testing *)

Module TypesTest.

  Example ex_res1: resulttype := [].
  Example ex_res2: resulttype := [T_i32].
  Example ex_fun: functype := FT [T_i32] [T_i32].

  (* Func Notation Testing *)

  Import FunctypeNotations.

  Example ex_fun_nu : functype := [] --> [T_i32].

  Example ex_fun_un : functype := [T_i32] --> [T_i32].

  Example ex_fun_bin : functype := [T_i32; T_i32] --> [T_i32].

  (* cannot looser than ++ *)
  Example ex_fun_loose : functype := ([T_i32] ++ [T_i32]) --> [T_i32].

End TypesTest.

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

(* techinically the spec use [u32], which mean we should interpter
   this [I32.t] as unsigned integers. *)

Record limits :=
  {
    L_min: Int.I32.t;
    L_max: option Int.I32.t;
  }.

(* ----------------------------------------------------------------- *)
(** *** Memory Types *)

Definition memtype := limits.

(* ----------------------------------------------------------------- *)
(** *** Table Types *)

(* according to spec:

   > The element type [funcref] is the infinite union of all function types.
     A table of that type thus contains references to functions of
     heterogeneous type.

   the [Call_indirect] will fetch index into this table,
   and the type of function is **checked dynamically**

   combined it can represent *function pointer* and dynamic linking.
 *)

(* We don't need ET since [funcref] is a unique name. *)
Inductive elemtype := funcref.

Definition tabletype : Type := limits * elemtype.

(* ----------------------------------------------------------------- *)
(** *** Global Types *)

Inductive mut :=
  | GT_const
  | GT_var.

Definition globaltype : Type := mut * valtype.

(* ----------------------------------------------------------------- *)
(** *** External Types *)

Inductive externtype :=
  | ET_func (ft: functype)
  | ET_table (tt: tabletype)
  | ET_mem (mt: memtype)
  | ET_global (gt: globaltype).

(* ----------------------------------------------------------------- *)
(** *** Option ValType Occurence *)

(* Not currently used in favor of plain [option value]
   Potential uses would be [blocktype] and module [M_return].
 *)

Definition opt_valtype := (option valtype).

Definition opt_to_rt (opt : opt_valtype) : resulttype :=
  match opt with
  | Some valtype => [valtype]
  | None => []
  end.

Coercion opt_to_rt : opt_valtype >-> resulttype.

Module OptionValTyTest.

  Import FunctypeNotations.

  Example valtype1 : opt_valtype := Some T_i32.
  Example valtype2 : opt_valtype := None.

  Example ft_some := [] --> opt_to_rt valtype1.
  Example ft_some2 := [] --> valtype1.

End OptionValTyTest.


From coqutil Require Import sanity.
From coqutil Require Import HList.
From coqutil Require List.
From coqutil Require Import Datatypes.PropSet.

Module map.
  Class map {key value} := mk {
    rep : Type;

    (* fundamental operation, all others are axiomatized in terms of this one *)
    get: rep -> key -> option value;

    empty : rep;
    put : rep -> key -> value -> rep;
    remove : rep -> key -> rep;
    fold{R: Type}: (R -> key -> value -> R) -> R -> rep -> R;
  }.
  Arguments map : clear implicits.
  Global Coercion rep : map >-> Sortclass.
  Global Hint Mode map + + : typeclass_instances.
  Local Hint Mode map - - : typeclass_instances.

  Class ok {key value : Type} {map : map key value}: Prop := {
    map_ext : forall m1 m2, (forall k, get m1 k = get m2 k) -> m1 = m2;
    get_empty : forall k, get empty k = None;
    get_put_same : forall m k v, get (put m k v) k = Some v;
    get_put_diff : forall m k v k', k <> k' -> get (put m k' v) k = get m k;
    get_remove_same : forall m k, get (remove m k) k = None;
    get_remove_diff : forall m k k', k <> k' -> get (remove m k') k = get m k;
    fold_spec{R: Type} : forall (P: rep -> R -> Prop) (f: R -> key -> value -> R) r0,
        P empty r0 ->
        (forall k v m r, get m k = None -> P m r -> P (put m k v) (f r k v)) ->
        forall m, P m (fold f r0 m);
    (* Folding over a map preserves relations: *)
    fold_parametricity: forall {A B : Type} (R : A -> B -> Prop)
                               (fa: A -> key -> value -> A) (fb: B -> key -> value -> B),
        (forall a b k v, R a b -> R (fa a k v) (fb b k v)) ->
        forall a0 b0, R a0 b0 -> forall m, R (fold fa a0 m) (fold fb b0 m);

  }.
  Arguments ok {_ _} _.

  Section WithMap. Local Set Default Proof Using "All".
    Context {key value : Type} {map : map key value} {map_ok : ok map}.

    Definition update (m : map) (k : key) (ov : option value) :=
      match ov with
      | None => remove m k
      | Some v => put m k v
      end.
    Definition putmany: map -> map -> map := fold put.
    Definition extends (m1 m2 : map) := forall x w, get m2 x = Some w -> get m1 x = Some w.
    Definition agree_on (P : set key) m1 m2 := forall k, elem_of k P -> get m1 k = get m2 k.
    Definition only_differ(m1: map)(ks: set key)(s2: map) :=
      forall x, elem_of x ks \/ get m1 x = get s2 x.
    Definition undef_on m P := agree_on P m empty.
    Definition injective(m: map): Prop :=
      forall k1 k2 v,
        map.get m k1 = Some v -> map.get m k2 = Some v -> k1 = k2.
    Definition not_in_range(m: map)(l: list value): Prop :=
      List.Forall (fun v => forall k, map.get m k <> Some v) l.
    Definition disjoint (a b : map) :=
      forall k v1 v2, get a k = Some v1 -> get b k = Some v2 -> False.
    Definition sub_domain(m1 m2: map): Prop :=
      forall k v1, map.get m1 k = Some v1 -> exists v2, map.get m2 k = Some v2.
    Definition same_domain(m1 m2: map): Prop := sub_domain m1 m2 /\ sub_domain m2 m1.
    Definition forall_keys(P : key -> Prop)(m : map): Prop :=
      forall k v, map.get m k = Some v -> P k.
    Definition forall_values(P: value -> Prop)(m: map): Prop :=
      forall k v, map.get m k = Some v -> P v.
    Definition forallb(f: key -> value -> bool): map -> bool :=
      map.fold (fun res k v => andb res (f k v)) true.
    Definition singleton(k: key)(v: value): map := map.put map.empty k v.

    Definition split m m1 m2 := m = (putmany m1 m2) /\ disjoint m1 m2.

    Definition getmany_of_list (m : map) (keys : list key) : option (list value) :=
      List.option_all (List.map (get m) keys).

    Fixpoint putmany_of_list (l : list (key*value)) (init : rep) {struct l} : map :=
      match l with
      | nil => init
      | cons (k,v) l =>
        putmany_of_list l (put init k v)
      end.
    Fixpoint of_list (l : list (key * value)) : rep :=
      match l with
      | nil => map.empty
      | cons (k,v) l => put (of_list l) k v
      end.

    Definition keys(m : map): list key := fold (fun acc k v => cons k acc) nil m.

    Definition tuples(m: map): list (key * value) := fold (fun l k v => cons (k, v) l) nil m.

    Fixpoint putmany_of_list_zip (keys : list key) (values : list value) (init : rep) {struct keys} : option map :=
      match keys, values with
      | nil, nil => Some init
      | cons k keys, cons v values =>
        putmany_of_list_zip keys values (put init k v)
      | _, _ => None
      end.
    Definition of_list_zip keys values := putmany_of_list_zip keys values empty.

    Fixpoint putmany_of_disjoint_list_zip (keys : list key) (values : list value) (init : rep)
             {struct keys} : option map :=
      match keys, values with
      | nil, nil => Some init
      | cons k keys, cons v values =>
        match putmany_of_disjoint_list_zip keys values init with
        | Some m => match get m k with
                    | Some _ => None
                    | None => Some (put m k v)
                    end
        | None => None
        end
      | _, _ => None
      end.
    Definition of_disjoint_list_zip keys values := putmany_of_disjoint_list_zip keys values empty.

    Import PrimitivePair.

    Definition getmany_of_tuple(m: map){sz: nat}(keys: tuple key sz): option (tuple value sz) :=
      tuple.option_all (tuple.map (get m) keys).

    Fixpoint putmany_of_tuple {sz : nat} : tuple key sz -> tuple value sz -> map -> map :=
      match sz with
      | O => fun keys values init => init
      | S sz' => fun '(pair.mk k ks) '(pair.mk v vs) init =>
                   put (putmany_of_tuple ks vs init) k v
      end.
    Definition of_tuple {sz : nat} (keys: tuple key sz) (values: tuple value sz) :=
      putmany_of_tuple keys values empty.
  End WithMap.
End map. Local Notation map := map.map.
Global Coercion map.rep : map >-> Sortclass.


(************************************************************************)
(*  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        *)
(************************************************************************)

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

Require Import Rbase.
Require Import Rfunctions.
Require Import Ranalysis1.
Open Local Scope R_scope.

(**********)
Lemma formule :
  forall (x h l1 l2:R) (f1 f2:R -> R),
    h <> 0 ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (f1 (x + h) / f2 (x + h) - f1 x / f2 x) / h -
    (l1 * f2 x - l2 * f1 x) / Rsqr (f2 x) =
    / f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1) +
    l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h)) -
    f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2) +
    l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x).
Proof.
  intros; unfold Rdiv, Rminus, Rsqr in |- *.
  repeat rewrite Rmult_plus_distr_r; repeat rewrite Rmult_plus_distr_l;
    repeat rewrite Rinv_mult_distr; try assumption.
  replace (l1 * f2 x * (/ f2 x * / f2 x)) with (l1 * / f2 x * (f2 x * / f2 x));
  [ idtac | ring ].
  replace (l1 * (/ f2 x * / f2 (x + h)) * f2 x) with
  (l1 * / f2 (x + h) * (f2 x * / f2 x)); [ idtac | ring ].
  replace (l1 * (/ f2 x * / f2 (x + h)) * - f2 (x + h)) with
  (- (l1 * / f2 x * (f2 (x + h) * / f2 (x + h)))); [ idtac | ring ].
  replace (f1 x * (/ f2 x * / f2 (x + h)) * (f2 (x + h) * / h)) with
  (f1 x * / f2 x * / h * (f2 (x + h) * / f2 (x + h)));
  [ idtac | ring ].
  replace (f1 x * (/ f2 x * / f2 (x + h)) * (- f2 x * / h)) with
  (- (f1 x * / f2 (x + h) * / h * (f2 x * / f2 x)));
  [ idtac | ring ].
  replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * f2 (x + h)) with
  (l2 * f1 x * / f2 x * / f2 x * (f2 (x + h) * / f2 (x + h)));
  [ idtac | ring ].
  replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * - f2 x) with
  (- (l2 * f1 x * / f2 x * / f2 (x + h) * (f2 x * / f2 x)));
  [ idtac | ring ].
  repeat rewrite <- Rinv_r_sym; try assumption || ring.
  apply prod_neq_R0; assumption.
Qed.

(* begin hide *)
Notation Rmin_pos := Rmin_pos (only parsing). (* compat *)
(* end hide *)

Lemma maj_term1 :
  forall (x h eps l1 alp_f2:R) (eps_f2 alp_f1d:posreal)
    (f1 f2:R -> R),
    0 < eps ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (forall h:R,
      h <> 0 ->
      Rabs h < alp_f1d ->
      Rabs ((f1 (x + h) - f1 x) / h - l1) < Rabs (eps * f2 x / 8)) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
    h <> 0 ->
    Rabs h < alp_f1d ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) < eps / 4.
Proof.
  intros.
  assert (H7 := H3 h H6).
  assert (H8 := H2 h H4 H5).
  apply Rle_lt_trans with
    (2 / Rabs (f2 x) * Rabs ((f1 (x + h) - f1 x) / h - l1)).
  rewrite Rabs_mult.
  apply Rmult_le_compat_r.
  apply Rabs_pos.
  rewrite Rabs_Rinv; [ left; exact H7 | assumption ].
  apply Rlt_le_trans with (2 / Rabs (f2 x) * Rabs (eps * f2 x / 8)).
  apply Rmult_lt_compat_l.
  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
    [ prove_sup0 | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ].
  exact H8.
  right; unfold Rdiv in |- *.
  repeat rewrite Rabs_mult.
  rewrite Rabs_Rinv; discrR.
  replace (Rabs 8) with 8.
  replace 8 with 8; [ idtac | ring ].
  rewrite Rinv_mult_distr; [ idtac | discrR | discrR ].
  replace (2 * / Rabs (f2 x) * (Rabs eps * Rabs (f2 x) * (/ 2 * / 4))) with
  (Rabs eps * / 4 * (2 * / 2) * (Rabs (f2 x) * / Rabs (f2 x)));
  [ idtac | ring ].
  replace (Rabs eps) with eps.
  repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
  ring.
  symmetry  in |- *; apply Rabs_right; left; assumption.
  symmetry  in |- *; apply Rabs_right; left; prove_sup.
Qed.

Lemma maj_term2 :
  forall (x h eps l1 alp_f2 alp_f2t2:R) (eps_f2:posreal)
    (f2:R -> R),
    0 < eps ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (forall a:R,
      Rabs a < alp_f2t2 ->
      Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
    h <> 0 ->
    Rabs h < alp_f2t2 ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    l1 <> 0 -> Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) < eps / 4.
Proof.
  intros.
  assert (H8 := H3 h H6).
  assert (H9 := H2 h H5).
  apply Rle_lt_trans with
    (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (eps * Rsqr (f2 x) / (8 * l1))).
  rewrite Rabs_mult; apply Rmult_le_compat_l.
  apply Rabs_pos.
  rewrite <- (Rabs_Ropp (f2 x - f2 (x + h))); rewrite Ropp_minus_distr.
  left; apply H9.
  apply Rlt_le_trans with
    (Rabs (2 * (l1 / (f2 x * f2 x))) * Rabs (eps * Rsqr (f2 x) / (8 * l1))).
  apply Rmult_lt_compat_r.
  apply Rabs_pos_lt.
  unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
    try assumption || discrR.
  red in |- *; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
  apply Rinv_neq_0_compat; apply prod_neq_R0; try assumption || discrR.
  unfold Rdiv in |- *.
  repeat rewrite Rinv_mult_distr; try assumption.
  repeat rewrite Rabs_mult.
  replace (Rabs 2) with 2.
  rewrite (Rmult_comm 2).
  replace (Rabs l1 * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with
  (Rabs l1 * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2)));
  [ idtac | ring ].
  repeat apply Rmult_lt_compat_l.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; apply Rinv_neq_0_compat; assumption.
  repeat rewrite Rabs_Rinv; try assumption.
  rewrite <- (Rmult_comm 2).
  unfold Rdiv in H8; exact H8.
  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
  right.
  unfold Rsqr, Rdiv in |- *.
  do 1 rewrite Rinv_mult_distr; try assumption || discrR.
  do 1 rewrite Rinv_mult_distr; try assumption || discrR.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_Rinv; try assumption || discrR.
  replace (Rabs eps) with eps.
  replace (Rabs 8) with 8.
  replace (Rabs 2) with 2.
  replace 8 with (4 * 2); [ idtac | ring ].
  rewrite Rinv_mult_distr; discrR.
  replace
  (2 * (Rabs l1 * (/ Rabs (f2 x) * / Rabs (f2 x))) *
    (eps * (Rabs (f2 x) * Rabs (f2 x)) * (/ 4 * / 2 * / Rabs l1))) with
  (eps * / 4 * (Rabs l1 * / Rabs l1) * (Rabs (f2 x) * / Rabs (f2 x)) *
    (Rabs (f2 x) * / Rabs (f2 x)) * (2 * / 2)); [ idtac | ring ].
  repeat rewrite <- Rinv_r_sym; try (apply Rabs_no_R0; assumption) || discrR.
  ring.
  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
  symmetry  in |- *; apply Rabs_right; left; prove_sup.
  symmetry  in |- *; apply Rabs_right; left; assumption.
Qed.

Lemma maj_term3 :
  forall (x h eps l2 alp_f2:R) (eps_f2 alp_f2d:posreal)
    (f1 f2:R -> R),
    0 < eps ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (forall h:R,
      h <> 0 ->
      Rabs h < alp_f2d ->
      Rabs ((f2 (x + h) - f2 x) / h - l2) <
      Rabs (Rsqr (f2 x) * eps / (8 * f1 x))) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
    h <> 0 ->
    Rabs h < alp_f2d ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    f1 x <> 0 ->
    Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) <
    eps / 4.
Proof.
  intros.
  assert (H8 := H2 h H4 H5).
  assert (H9 := H3 h H6).
  apply Rle_lt_trans with
    (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs (Rsqr (f2 x) * eps / (8 * f1 x))).
  rewrite Rabs_mult.
  apply Rmult_le_compat_l.
  apply Rabs_pos.
  left; apply H8.
  apply Rlt_le_trans with
    (Rabs (2 * (f1 x / (f2 x * f2 x))) * Rabs (Rsqr (f2 x) * eps / (8 * f1 x))).
  apply Rmult_lt_compat_r.
  apply Rabs_pos_lt.
  unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
    try assumption.
  red in |- *; intro H10; rewrite H10 in H; elim (Rlt_irrefl _ H).
  apply Rinv_neq_0_compat; apply prod_neq_R0; discrR || assumption.
  unfold Rdiv in |- *.
  repeat rewrite Rinv_mult_distr; try assumption.
  repeat rewrite Rabs_mult.
  replace (Rabs 2) with 2.
  rewrite (Rmult_comm 2).
  replace (Rabs (f1 x) * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with
  (Rabs (f1 x) * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2)));
  [ idtac | ring ].
  repeat apply Rmult_lt_compat_l.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; apply Rinv_neq_0_compat; assumption.
  repeat rewrite Rabs_Rinv; assumption || idtac.
  rewrite <- (Rmult_comm 2).
  unfold Rdiv in H9; exact H9.
  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
  right.
  unfold Rsqr, Rdiv in |- *.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_Rinv; try assumption || discrR.
  replace (Rabs eps) with eps.
  replace (Rabs 8) with 8.
  replace (Rabs 2) with 2.
  replace 8 with (4 * 2); [ idtac | ring ].
  rewrite Rinv_mult_distr; discrR.
  replace
  (2 * (Rabs (f1 x) * (/ Rabs (f2 x) * / Rabs (f2 x))) *
    (Rabs (f2 x) * Rabs (f2 x) * eps * (/ 4 * / 2 * / Rabs (f1 x)))) with
  (eps * / 4 * (Rabs (f2 x) * / Rabs (f2 x)) * (Rabs (f2 x) * / Rabs (f2 x)) *
    (Rabs (f1 x) * / Rabs (f1 x)) * (2 * / 2)); [ idtac | ring ].
  repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
  ring.
  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
  symmetry  in |- *; apply Rabs_right; left; prove_sup.
  symmetry  in |- *; apply Rabs_right; left; assumption.
Qed.

Lemma maj_term4 :
  forall (x h eps l2 alp_f2 alp_f2c:R) (eps_f2:posreal)
    (f1 f2:R -> R),
    0 < eps ->
    f2 x <> 0 ->
    f2 (x + h) <> 0 ->
    (forall a:R,
      Rabs a < alp_f2c ->
      Rabs (f2 (x + a) - f2 x) <
      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))) ->
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)) ->
    h <> 0 ->
    Rabs h < alp_f2c ->
    Rabs h < Rmin eps_f2 alp_f2 ->
    f1 x <> 0 ->
    l2 <> 0 ->
    Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x)) <
    eps / 4.
Proof.
  intros.
  assert (H9 := H2 h H5).
  assert (H10 := H3 h H6).
  apply Rle_lt_trans with
    (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) *
      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
  rewrite Rabs_mult.
  apply Rmult_le_compat_l.
  apply Rabs_pos.
  left; apply H9.
  apply Rlt_le_trans with
    (Rabs (2 * l2 * (f1 x / (Rsqr (f2 x) * f2 x))) *
      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
  apply Rmult_lt_compat_r.
  apply Rabs_pos_lt.
  unfold Rdiv in |- *; unfold Rsqr in |- *; repeat apply prod_neq_R0;
    assumption || idtac.
  red in |- *; intro H11; rewrite H11 in H; elim (Rlt_irrefl _ H).
  apply Rinv_neq_0_compat; apply prod_neq_R0.
  apply prod_neq_R0.
  discrR.
  assumption.
  assumption.
  unfold Rdiv in |- *.
  repeat rewrite Rinv_mult_distr;
    try assumption || (unfold Rsqr in |- *; apply prod_neq_R0; assumption).
  repeat rewrite Rabs_mult.
  replace (Rabs 2) with 2.
  replace
  (2 * Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 x)))) with
  (Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * (Rabs (/ f2 x) * 2))));
  [ idtac | ring ].
  replace
  (Rabs l2 * Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 (x + h)))) with
  (Rabs l2 * (Rabs (f1 x) * (Rabs (/ Rsqr (f2 x)) * Rabs (/ f2 (x + h)))));
  [ idtac | ring ].
  repeat apply Rmult_lt_compat_l.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; assumption.
  apply Rabs_pos_lt; apply Rinv_neq_0_compat; unfold Rsqr in |- *;
    apply prod_neq_R0; assumption.
  repeat rewrite Rabs_Rinv; [ idtac | assumption | assumption ].
  rewrite <- (Rmult_comm 2).
  unfold Rdiv in H10; exact H10.
  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
  right; unfold Rsqr, Rdiv in |- *.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  rewrite Rinv_mult_distr; try assumption || discrR.
  repeat rewrite Rabs_mult.
  repeat rewrite Rabs_Rinv; try assumption || discrR.
  replace (Rabs eps) with eps.
  replace (Rabs 8) with 8.
  replace (Rabs 2) with 2.
  replace 8 with (4 * 2); [ idtac | ring ].
  rewrite Rinv_mult_distr; discrR.
  replace
  (2 * Rabs l2 *
    (Rabs (f1 x) * (/ Rabs (f2 x) * / Rabs (f2 x) * / Rabs (f2 x))) *
    (Rabs (f2 x) * Rabs (f2 x) * Rabs (f2 x) * eps *
      (/ 4 * / 2 * / Rabs (f1 x) * / Rabs l2))) with
  (eps * / 4 * (Rabs l2 * / Rabs l2) * (Rabs (f1 x) * / Rabs (f1 x)) *
    (Rabs (f2 x) * / Rabs (f2 x)) * (Rabs (f2 x) * / Rabs (f2 x)) *
    (Rabs (f2 x) * / Rabs (f2 x)) * (2 * / 2)); [ idtac | ring ].
  repeat rewrite <- Rinv_r_sym; try discrR || (apply Rabs_no_R0; assumption).
  ring.
  symmetry  in |- *; apply Rabs_right; left; prove_sup0.
  symmetry  in |- *; apply Rabs_right; left; prove_sup.
  symmetry  in |- *; apply Rabs_right; left; assumption.
  apply prod_neq_R0; assumption || discrR.
  apply prod_neq_R0; assumption.
Qed.

Lemma D_x_no_cond : forall x a:R, a <> 0 -> D_x no_cond x (x + a).
Proof.
  intros.
  unfold D_x, no_cond in |- *.
  split.
  trivial.
  apply Rminus_not_eq.
  unfold Rminus in |- *.
  rewrite Ropp_plus_distr.
  rewrite <- Rplus_assoc.
  rewrite Rplus_opp_r.
  rewrite Rplus_0_l.
  apply Ropp_neq_0_compat; assumption.
Qed.

Lemma Rabs_4 :
  forall a b c d:R, Rabs (a + b + c + d) <= Rabs a + Rabs b + Rabs c + Rabs d.
Proof.
  intros.
  apply Rle_trans with (Rabs (a + b) + Rabs (c + d)).
  replace (a + b + c + d) with (a + b + (c + d)); [ apply Rabs_triang | ring ].
  apply Rle_trans with (Rabs a + Rabs b + Rabs (c + d)).
  apply Rplus_le_compat_r.
  apply Rabs_triang.
  repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l.
  apply Rabs_triang.
Qed.

Lemma Rlt_4 :
  forall a b c d e f g h:R,
    a < b -> c < d -> e < f -> g < h -> a + c + e + g < b + d + f + h.
Proof.
  intros; apply Rlt_trans with (b + c + e + g).
  repeat apply Rplus_lt_compat_r; assumption.
  repeat rewrite Rplus_assoc; apply Rplus_lt_compat_l.
  apply Rlt_trans with (d + e + g).
  rewrite Rplus_assoc; apply Rplus_lt_compat_r; assumption.
  rewrite Rplus_assoc; apply Rplus_lt_compat_l; apply Rlt_trans with (f + g).
  apply Rplus_lt_compat_r; assumption.
  apply Rplus_lt_compat_l; assumption.
Qed.

(* begin hide *)
Notation Rmin_2 := Rmin_glb_lt (only parsing).
(* end hide *)

Lemma quadruple : forall x:R, 4 * x = x + x + x + x.
Proof.
  intro; ring.
Qed.

Lemma quadruple_var : forall x:R, x = x / 4 + x / 4 + x / 4 + x / 4.
Proof.
  intro; rewrite <- quadruple.
  unfold Rdiv in |- *; rewrite <- Rmult_assoc; rewrite Rinv_r_simpl_m; discrR.
  reflexivity.
Qed.

(**********)
Lemma continuous_neq_0 :
  forall (f:R -> R) (x0:R),
    continuity_pt f x0 ->
    f x0 <> 0 ->
    exists eps : posreal, (forall h:R, Rabs h < eps -> f (x0 + h) <> 0).
Proof.
  intros; unfold continuity_pt in H; unfold continue_in in H;
    unfold limit1_in in H; unfold limit_in in H; elim (H (Rabs (f x0 / 2))).
  intros; elim H1; intros.
  exists (mkposreal x H2).
  intros; assert (H5 := H3 (x0 + h)).
  cut
    (dist R_met (x0 + h) x0 < x ->
      dist R_met (f (x0 + h)) (f x0) < Rabs (f x0 / 2)).
  unfold dist in |- *; simpl in |- *; unfold R_dist in |- *;
    replace (x0 + h - x0) with h.
  intros; assert (H7 := H6 H4).
  red in |- *; intro.
  rewrite H8 in H7; unfold Rminus in H7; rewrite Rplus_0_l in H7;
    rewrite Rabs_Ropp in H7; unfold Rdiv in H7; rewrite Rabs_mult in H7;
      pattern (Rabs (f x0)) at 1 in H7; rewrite <- Rmult_1_r in H7.
  cut (0 < Rabs (f x0)).
  intro; assert (H10 := Rmult_lt_reg_l _ _ _ H9 H7).
  cut (Rabs (/ 2) = / 2).
  assert (Hyp : 0 < 2).
  prove_sup0.
  intro; rewrite H11 in H10; assert (H12 := Rmult_lt_compat_l 2 _ _ Hyp H10);
    rewrite Rmult_1_r in H12; rewrite <- Rinv_r_sym in H12;
      [ idtac | discrR ].
  cut (IZR 1 < IZR 2).
  unfold IZR in |- *; unfold INR, nat_of_P in |- *; simpl in |- *; intro;
    elim (Rlt_irrefl 1 (Rlt_trans _ _ _ H13 H12)).
  apply IZR_lt; omega.
  unfold Rabs in |- *; case (Rcase_abs (/ 2)); intro.
  assert (Hyp : 0 < 2).
  prove_sup0.
  assert (H11 := Rmult_lt_compat_l 2 _ _ Hyp r); rewrite Rmult_0_r in H11;
    rewrite <- Rinv_r_sym in H11; [ idtac | discrR ].
  elim (Rlt_irrefl 0 (Rlt_trans _ _ _ Rlt_0_1 H11)).
  reflexivity.
  apply (Rabs_pos_lt _ H0).
  ring.
  assert (H6 := Req_dec x0 (x0 + h)); elim H6; intro.
  intro; rewrite <- H7; unfold dist, R_met in |- *; unfold R_dist in |- *;
    unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
      apply Rabs_pos_lt.
  unfold Rdiv in |- *; apply prod_neq_R0;
    [ assumption | apply Rinv_neq_0_compat; discrR ].
  intro; apply H5.
  split.
  unfold D_x, no_cond in |- *.
  split; trivial || assumption.
  assumption.
  change (0 < Rabs (f x0 / 2)) in |- *.
  apply Rabs_pos_lt; unfold Rdiv in |- *; apply prod_neq_R0.
  assumption.
  apply Rinv_neq_0_compat; discrR.
Qed.


(***********************************************************************)
(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
(*                                                                     *)
(***********************************************************************)
(***********************************************************************)
(*                                                                     *)
(*  Frobenius theorem                                                  *)
(*                                                                     *)
(***********************************************************************)
(***********************************************************************)

Require Import ssreflect ssrbool ssrfun ssrnat.
Require Import eqtype fintype div ssralg bigops prime finset.
Require Import groups morphisms action normal cyclic center pgroups.

(* Require Import seq paths connect zp. *)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Import GroupScope.

Definition Ldiv (gT : finGroupType) n := [set z : gT | z ^+ n == 1].

Notation "''Ldiv_' n ()" := (Ldiv _ n)
  (at level 8, n at level 2, format "''Ldiv_' n ()") : group_scope.

Notation "''Ldiv_' n ( G )" := (G :&: 'Ldiv_n())
  (at level 8, n at level 2, format "''Ldiv_' n ( G )") : group_scope.

Theorem Frobenius_Ldiv : forall (gT : finGroupType) (G : {group gT}) n,
  n %| #|G| -> n %| #|'Ldiv_n(G)|.
Proof.
move=> gT G n nG; move: {2}_.+1 (ltnSn (#|G| %/ n)) => mq.
elim: mq => // mq IHm in gT G n nG *; case/dvdnP: nG => q oG.
have [q_pos n_pos] : 0 < q /\ 0 < n by apply/andP; rewrite -ltn_0mul -oG.
rewrite ltnS oG mulnK // => leqm.
have:= q_pos; rewrite leq_eqVlt; case/predU1P=> [q1 | lt1q].
  rewrite -(mul1n n) q1 -oG (setIidPl _) //.
  by apply/subsetP=> x Gx; rewrite inE -order_dvd order_dvd_g.
pose p := pdiv q; have pr_p: prime p by exact: prime_pdiv.
have lt1p: 1 < p := prime_gt1 pr_p; have p_pos := ltnW lt1p.
have{leqm} lt_qp_mq: q %/ p < mq by apply: leq_trans leqm; rewrite ltn_Pdiv.
have: n %| #|'Ldiv_(p * n)(G)|.
  have: p * n %| #|G| by rewrite oG dvdn_pmul2r ?dvdn_pdiv.
  move/IHm=> IH; apply: dvdn_trans (IH _); first exact: dvdn_mull.
  by rewrite oG divn_pmul2r.
rewrite -(cardsID 'Ldiv_n()) dvdn_addl.
  rewrite -setIA ['Ldiv_n(_)](setIidPr _) //.
  apply/subsetP=> x; rewrite !inE -!order_dvd; exact: dvdn_mull.
rewrite setDE -setIA -setDE; set A := _ :\: _.
have pA: forall x, x \in A -> #[x]`_p = (n`_p * p)%N.
  move=> x; rewrite !inE -!order_dvd; case/andP=> xn xnp.
  rewrite !p_part // -expnSr; congr (p ^ _)%N; apply/eqP.
  rewrite eqn_leq -{1}addn1 -(pfactorK 1 pr_p) -logn_mul ?expn1 // mulnC.
  rewrite dvdn_leq_log ?ltn_0mul ?p_pos //= ltnNge; apply: contra xn => xn.
  move: xnp; rewrite -[#[x]](partnC p) //.
  rewrite !gauss_inv ?coprime_partC //; case/andP=> _.
  rewrite p_part ?pfactor_dvdn // xn gauss // coprime_sym.
  exact: pnat_coprime (pnat_id _) (pnat_part _ _).
rewrite -(partnC p n_pos) gauss_inv ?coprime_partC //; apply/andP; split.
  rewrite -sum1_card (partition_big_imset (@cycle _)) /=.
  apply: dvdn_sum => X; case/imsetP=> x; case/setIP=> Gx Ax ->{X}.
  rewrite (eq_bigl (generator <[x]>)) => [|y].
    rewrite sum1_card -phi_gen -[#[x]](partnC p) // phi_mult ?coprime_partC //.
    rewrite dvdn_mulr // (pA x Ax) p_part // -expnSr.
    by rewrite phi_prime_k // expnS dvdn_sub ?dvdn_mull.
  rewrite /generator eq_sym andbC; case xy: {+}(_ == _) => //.
  rewrite !inE -!order_dvd in Ax *.
  by rewrite -cycle_subG /order -(eqP xy) cycle_subG Gx.
rewrite -sum1_card (partition_big_imset (fun x => x.`_p ^: G)) /=.
apply: dvdn_sum => X; case/imsetP=> x; case/setIP=> Gx Ax ->{X}.
set y := x.`_p; have oy: #[y] = (n`_p * p)%N by rewrite order_constt pA.
rewrite (partition_big (fun x => x.`_p) (mem (y ^: G))) /= => [|z]; last first.
  by case/andP=> _; move/eqP <-; rewrite /= class_refl.
pose G' := ('C_G[y] / <[y]>)%G; pose n' := gcdn #|G'| n`_p^'.
have n'_pos: 0 < n' by rewrite ltn_0gcd ltn_0group.
rewrite (eq_bigr (fun _ => #|'Ldiv_n'(G')|)) => [|ya].
  rewrite sum_nat_const -index_cent1 indexgI.
  rewrite -(dvdn_pmul2l (ltn_0group 'C_G[y])) mulnA LaGrangeI.
  have oCy: #|'C_G[y]| = (#[y] * #|G'|)%N.
    rewrite card_quotient ?subcent1_cycle_norm // LaGrange //.
    by rewrite subcent1_cycle_sub ?groupX.
  rewrite oCy -mulnA -(muln_lcm_gcd #|G'|) -/n' mulnA dvdn_mul //.
    rewrite muln_lcmr -oCy order_constt pA // mulnAC partnC // dvdn_lcm.
    by rewrite cardSg ?subsetIl // mulnC oG dvdn_pmul2r ?dvdn_pdiv.
  apply: IHm; [exact: dvdn_gcdl | apply: leq_ltn_trans lt_qp_mq].
  rewrite -(@divn_pmul2r n`_p^') // -muln_lcm_gcd mulnC divn_pmul2l //.
  rewrite leq_divr // divn_mulAC ?leq_divl ?dvdn_mulr ?dvdn_lcmr //.
  rewrite dvdn_leq ?ltn_0mul ?q_pos //= mulnC muln_lcmr dvdn_lcm.
  rewrite -(@dvdn_pmul2l n`_p) // mulnA -oy -oCy mulnCA partnC // -oG.
  by rewrite cardSg ?subsetIl // dvdn_mul ?dvdn_pdiv.
case/imsetP=> a Ga ->{ya}.
pose h := [fun z => coset <[y]> (z ^ a^-1)].
pose h' := [fun Z : coset_of <[y]> => (y * (repr Z).`_p^') ^ a].
rewrite -sum1_card (reindex_onto h h') /= => [|Z]; last first.
  rewrite conjgK coset_kerl ?cycle_id ?morph_constt ?repr_coset_norm //.
  rewrite /= coset_reprK 2!inE -order_dvd dvdn_gcd; case/and3P=> _ _ p'Z.
  apply: constt_p_elt (pnat_dvd p'Z _); exact: pnat_part.
apply: eq_bigl => z; apply/andP/andP=> [[]|[]].
  rewrite inE -andbA; case/and3P=> Gz Az _; move/eqP=> zp_ya.
  have czy: z ^ a^-1 \in 'C[y].
    rewrite -mem_conjg -normJ conjg_set1 -zp_ya.
    by apply/cent1P; exact: commuteX.
  have Nz:  z ^ a^-1 \in 'N(<[y]>) by apply: subsetP czy; exact: norm_gen.
  have G'z: h z \in G' by rewrite mem_morphim //= inE groupJ // groupV.
  rewrite inE G'z inE -order_dvd dvdn_gcd order_dvd_g //=.
  rewrite /order -morphim_cycle // -quotientE card_quotient ?cycle_subG //.
  rewrite -(@dvdn_pmul2l #[y]) // LaGrange; last first.
    by rewrite /= cycleJ cycle_subG mem_conjgV -zp_ya mem_cycle.
  rewrite oy mulnAC partnC // [#|_|]orderJ; split.
    by rewrite !inE -!order_dvd mulnC in Az; case/andP: Az.
  set Z := coset _ _; have NZ := repr_coset_norm Z; have:= coset_reprK Z.
  case/kercoset_rcoset=> {NZ}// yi; case/cycleP=> i <- -> {yi Z}.
  rewrite consttM; last by apply commute_sym; apply: commuteX; apply/cent1P.
  rewrite (constt1P _) ?p_eltNK 1?p_eltX ?p_elt_constt // mul1g.
  by rewrite conjMg consttJ conjgKV -zp_ya consttC.
rewrite 2!inE -order_dvd; set Z := coset _ _.
case/andP=> Cz n'Z; move/eqP=> def_z.
have Nz: z ^ a^-1 \in 'N(<[y]>).
  rewrite -def_z conjgK groupMr; first by rewrite -(cycle_subG y) normG.
  by rewrite groupX ?repr_coset_norm.
have{Cz}: z ^ a^-1 \in 'C_G[y]; last case/setIP=> Gz Cz.
  case/morphimP: Cz => u Nu Cu.
  case/kercoset_rcoset=> // yi; case/cycleP=> i <-{yi} ->.
  by rewrite groupMr // groupX // inE groupX //; exact/cent1P.
have{def_z} zp_ya: z.`_p = y ^ a.
  rewrite -def_z consttJ consttM.
    rewrite constt_p_elt ?p_elt_constt //.
    by rewrite (constt1P _) ?p_eltNK ?p_elt_constt ?mulg1.
  apply: commute_sym; apply/cent1P.
  rewrite -def_z conjgK groupMl // in Cz; exact/cent1P.
have ozp: #[z ^ a^-1]`_p = #[y].
  by rewrite -order_constt consttJ zp_ya conjgK.
split; rewrite zp_ya // -class_lcoset lcoset_id // eqxx andbT.
rewrite -(conjgKV a z) !inE groupJ //= -!order_dvd orderJ; apply/andP; split.
  apply/negP; move/(partn_dvd p n_pos); apply/negP.
  by rewrite ozp -(muln1 n`_p) oy dvdn_pmul2l // dvdn1 neq_ltn lt1p orbT.
rewrite -(partnC p n_pos) mulnCA mulnA -oy -(@partnC p #[_]) // ozp.
apply dvdn_mul => //; apply: dvdn_trans (dvdn_trans n'Z (dvdn_gcdr _ _)).
rewrite {2}/order -morphim_cycle // -quotientE card_quotient ?cycle_subG //.
rewrite -(@dvdn_pmul2l #|<[z ^ a^-1]> :&: <[y]>|) ?ltn_0group // LaGrangeI.
rewrite -[#|<[_]>|](partnC p) ?ltn_0order // dvdn_pmul2r // ozp.
by rewrite cardSg ?subsetIr.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(********************************************************)
(* Une  axiomatisation en coq de la norme IEEE 754 	*)
(* Module Diadic.v 				   	*)
(* un plan d'ensemble se trouve dans le fichier README 	*)
(* Patrick Loiseleur, avril 1997			*)
(********************************************************)

Require Import Omega.
Require Import Zcomplements.
Require Import Zpower.
Require Import Zlogarithm.
Require Import ZArithRing.

Section definitions.

(* The type diadic represents the set of numbers who can be written:  	*)
(* x = n*2^p with  n and p in Z. (diadic numbers)			*)
(* n = Dnum and p = Dexp 						*)

Record diadic : Set := Diadic {Dnum : Z; Dexp : Z}.

Definition Dshift (n : Z) (x : diadic) := Diadic (Dnum x) (Dexp x + n).

Definition Dzero (x : Z) := Diadic 0 x.

Definition is_Dzero (x : diadic) := Dnum x = 0%Z.

(**
Fixpoint Dnormalize[x:diadic] : diadic :=
  Cases (Dnum x) of
    (POS (xO y)) => (Dnormalize (Diadic (POS y) `(Dexp x)+1`))
  | (NEG (xO y)) => (Dnormalize (Diadic (NEG y) `(Dexp x)+1`))
  | _ => x
  end.
**)
Inductive rounding_mode : Set :=
  | Rounding_sup : rounding_mode
  | Rounding_inf : rounding_mode
  | Rounding_nearest : rounding_mode
  | Rounding_zero : rounding_mode.

Definition Rounding_mode_opp (m : rounding_mode) :=
  match m with
  | Rounding_sup => Rounding_inf
  | Rounding_inf => Rounding_sup
  | Rounding_nearest => Rounding_nearest
  | Rounding_zero => Rounding_zero
  end.

(* This inductive set, equal to {-infty}+Z+Z (disjoint union) is
  the set of results of function DLog. *)

(****
Inductive DLog_result : Set :=
  M_infty : DLog_result
| Log_of_pos : Z -> DLog_result
| Log_of_neg : Z -> DLog_result.
****)

End definitions.

Section comparisons.

(* Fist a function Qcompare is defined, who takes two diadic numbers	*)
(* and answers SUPERIEUR, EGAL or INFERIEUR.				*)
(* Qcompare is similary to Zcompare from the omega library		*)
(* Then the usual predicates "less or equal", "less than", "greater	*)
(* or equal" and "greater than" are defined. Since these predicates	*)
(* are deterministic, the boolean equivalents are also defined	*)
(* Be careful ! Two diadic numbers x, y are equal iff the predicate	*)
(* (Deq x y) is true, that is (Dcompare x y)=EGAL			*)
(* That's not equivalent to : (eq D x y)				*)

Definition Dcompare (x y : diadic) : Datatypes.comparison :=
  let nx := Dnum x in
  let ny := Dnum y in
  let ex := Dexp x in
  let ey := Dexp y in
  (two_p (ex - Zmin ex ey) * nx ?= two_p (ey - Zmin ex ey) * ny)%Z.

(* Inductive relation := EGAL | INFERIEUR | SUPERIEUR *)
Definition Deq (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => True
  | Datatypes.Lt => False
  | Datatypes.Gt => False
  end.
Definition Dneq (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => False
  | Datatypes.Lt => True
  | Datatypes.Gt => True
  end.
Definition Dle (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => True
  | Datatypes.Lt => True
  | Datatypes.Gt => False
  end.
Definition Dlt (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => False
  | Datatypes.Lt => True
  | Datatypes.Gt => False
  end.
Definition Dge (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => True
  | Datatypes.Lt => False
  | Datatypes.Gt => True
  end.
Definition Dgt (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => False
  | Datatypes.Lt => False
  | Datatypes.Gt => True
  end.

Definition Deq_bool (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => true
  | Datatypes.Lt => false
  | Datatypes.Gt => false
  end.
Definition Dneq_bool (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => false
  | Datatypes.Lt => true
  | Datatypes.Gt => true
  end.
Definition Dle_bool (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => true
  | Datatypes.Lt => true
  | Datatypes.Gt => false
  end.
Definition Dlt_bool (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => false
  | Datatypes.Lt => true
  | Datatypes.Gt => false
  end.
Definition Dge_bool (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => true
  | Datatypes.Lt => false
  | Datatypes.Gt => true
  end.
Definition Dgt_bool (x y : diadic) :=
  match Dcompare x y with
  | Datatypes.Eq => false
  | Datatypes.Lt => false
  | Datatypes.Gt => true
  end.

Lemma Dcompare_shift :
 forall (x y : diadic) (n : Z),
 Dcompare (Dshift n x) (Dshift n y) = Dcompare x y.
unfold Dcompare in |- *; simpl in |- *; intros;
 rewrite (Zmin.Zmin_plus (Dexp x) (Dexp y) n).
do 2 rewrite BinInt.Zminus_plus_simpl_r.
reflexivity.
Qed.

Lemma eq_Deq : forall x y : diadic, x = y -> Deq x y.
intros; rewrite H; unfold Deq in |- *; unfold Dcompare in |- *;
 apply Zcompare.Zcompare_eq_case; trivial.
Qed.

(* Links between Zcompare and Dcompare, Zle and Dle *)

Lemma Dcompare_zero :
 forall (x : diadic) (n : Z), Dcompare x (Dzero n) = (Dnum x ?= 0)%Z.
intros (nx, ex) n.
unfold Dcompare in |- *; simpl in |- *.
symmetry  in |- *.
replace (two_p (n - Zmin ex n) * 0)%Z with (two_p (ex - Zmin ex n) * 0)%Z.
apply Zmult_compare_compat_l.
apply two_p_gt_ZERO.
generalize (Zle_min_l ex n); generalize (Zmin ex n); intro; omega.
do 2 rewrite Zmult_0_r; reflexivity.
Qed.

Lemma Deq_shift :
 forall (x y : diadic) (n : Z), Deq x y -> Deq (Dshift n x) (Dshift n y).
unfold Deq in |- *; intros; rewrite (Dcompare_shift x y n); trivial.
Qed.

Lemma Deq_x_shift_x :
 forall (x : diadic) (n : Z),
 (0 <= n)%Z -> Deq x (Diadic (Dnum x * two_p n) (Dexp x - n)).
intros (nx, ex) n Hn; unfold Deq in |- *; unfold Dcompare in |- *;
 simpl in |- *.
cut
 ((two_p (ex - Zmin ex (ex - n)) * nx)%Z =
  (two_p (ex - n - Zmin ex (ex - n)) * (nx * two_p n))%Z).
intro H; rewrite H.
generalize (two_p (ex - n - Zmin ex (ex - n)) * (nx * two_p n))%Z.
intros. generalize (Zcompare.Zcompare_refl z).
elim (z ?= z)%Z; discriminate || trivial.
rewrite (Zmult_comm nx (two_p n)).
rewrite <- Zmult_assoc_reverse.
rewrite <- two_p_is_exp.
ring_simplify (ex - n - Zmin ex (ex - n) + n)%Z (ex - Zmin ex (ex - n))%Z.
reflexivity.
generalize (Zle_min_l ex (ex - n)) (Zle_min_r ex (ex - n)).
omega.
assumption.
Qed.

Lemma Dle_Zle :
 forall n1 n2 d : Z, (n1 <= n2)%Z -> Dle (Diadic n1 d) (Diadic n2 d).
intros; unfold Dle in |- *; unfold Dcompare in |- *; simpl in |- *.
rewrite (Zmin_n_n d).
rewrite <- (Zminus_diag_reverse d).
unfold two_p in |- *.
rewrite (Zcompare_mult_compat 1 n1 n2).
apply Zcompare.Zle_compare; assumption.
Qed.

Lemma Dlt_Zlt :
 forall n1 n2 d : Z, (n1 < n2)%Z -> Dlt (Diadic n1 d) (Diadic n2 d).
intros; unfold Dlt in |- *; unfold Dcompare in |- *; simpl in |- *.
rewrite (Zmin_n_n d).
rewrite <- (Zminus_diag_reverse d).
unfold two_p in |- *.
rewrite (Zcompare_mult_compat 1 n1 n2).
apply Zcompare.Zlt_compare; assumption.
Qed.

Lemma Dge_Zge :
 forall n1 n2 d : Z, (n1 >= n2)%Z -> Dge (Diadic n1 d) (Diadic n2 d).
intros; unfold Dge in |- *; unfold Dcompare in |- *; simpl in |- *.
rewrite (Zmin_n_n d).
rewrite <- (Zminus_diag_reverse d).
unfold two_p in |- *.
rewrite (Zcompare_mult_compat 1 n1 n2).
apply Zcompare.Zge_compare; assumption.
Qed.

Lemma Dgt_Zgt :
 forall n1 n2 d : Z, (n1 > n2)%Z -> Dgt (Diadic n1 d) (Diadic n2 d).
intros; unfold Dgt in |- *; unfold Dcompare in |- *; simpl in |- *.
rewrite (Zmin_n_n d).
rewrite <- (Zminus_diag_reverse d).
unfold two_p in |- *.
rewrite (Zcompare_mult_compat 1 n1 n2).
apply Zcompare.Zgt_compare; assumption.
Qed.

(* Arithmetic properties on D : Dle is reflexive, transitive, antisymmetric *)
Lemma Dle_refl : forall x y : diadic, Deq x y -> Dle x y.
unfold Deq in |- *; unfold Dle in |- *; intros x y; elim (Dcompare x y);
 trivial.
Qed.

(***
Lemma Dle_trans : (x,y,z:diadic) (Dle x y)->(Dle y z)->(Dle x z).
Intros x y z; Unfold Dle;

Lemma Dle_antisym :

Lemma Dle_lt_or_eq : (Dle x y) -> (Dlt x y)\/(Deq x y)
Lemma Dlt_not_refl :
Lemma Dlt_trans :
Lemma Dle_lt_trans : x<=y -> y<z -> x < z
Lemma Dlt_le_trans :

Lemma Dgt_lt :
Lemma Dge_le :
***)

End comparisons.

Section operations.

(* Now the 4 arithmetic operations and the square root 			*)
(* can be defined on D.				 			*)
(* Addition, negation, difference and multiplication are exact.		*)
(* Since D is non closed by inverse and square root, these operations	*)
(* are defined with a precision 2^p for a given p > 0.			*)
(* So, there is at this step of the work no function Dinv, but a	*)
(* predicates Dinv who takes 4 arguments : rounding mode, x, y, p.	*)
(* (Dinv MODE x y p) says that y is an approximation of 1/x with	*)
(* p digits, according to the rounding mode MODE			*)
(* That means (in the field R of real numbers):				*)
(*  (Dnum y) has p digits and : 					*)
(*									*)
(* -For MODE=Roundig_sup :  y <= 1/x < Dsucc y				*)
(* -For MODE=Roundig_inf :  Dpred y < 1/x <= y				*)
(* -For MODE=Rounding_nearest : 					*)
(*  	as Rounding_sup if nearer than Rounding_inf			*)
(*      as Rounding_inf in the other case				*)
(* -For MODE=Roundig_zero : as Rounding_sup if x>0,			*)
(*   	       	       	      as Rounding_inf if x<=0.			*)
(*	 					          __		*)
(* (Dsqr MODE x y p) says that y is an approximation of \/ x 		*)
(*   with p digits, according to the rounding mode MODE.		*)
(* That means : 							*)
(* -For MODE=Roundig_sup :  y^2 <= x < (Dsucc y)^2			*)
(* -For MODE=Roundig_inf :  (Dpred y)^2 < x <= y^2			*)
(* -For MODE=Rounding_nearest : 					*)
(*  	as Rounding_sup if nearer than Rounding_inf			*)
(*      as Rounding_inf in the other case				*)
(* -For MODE=Roundig_zero : as Rounding_sup since x>0			*)
(*									*)
(* The square root of a negative number does not exist : 		*)
(* (Dsrq MODE x y p) is alwas false when x <= 0				*)

Definition Dsucc (x : diadic) := Diadic (Dnum x + 1) (Dexp x).
Definition Dpred (x : diadic) := Diadic (Dnum x - 1) (Dexp x).

Definition Dadd (x y : diadic) :=
  let nx := Dnum x in
  let ny := Dnum y in
  let ex := Dexp x in
  let ey := Dexp y in
  Diadic (two_p (ex - Zmin ex ey) * nx + two_p (ey - Zmin ex ey) * ny)
    (Zmin ex ey).

Definition Dopp (x : diadic) := Diadic (- Dnum x) (Dexp x).

Definition Dabs (x : diadic) := Diadic (Zabs (Dnum x)) (Dexp x).

Definition Dminus (x y : diadic) := Dadd x (Dopp y).

Definition Dmult (x y : diadic) := Diadic (Dnum x * Dnum y) (Dexp x + Dexp y).

(* DLog 0 is -infty.
   When n<>0,
     (DLog n)= (Log_of_pos m) iff +2^m is the nearest power of two
   of n, according to the choosen rounding mode.
     (DLog n) = (Log_of_neg m) iff -2^m is the nearest power of two
   of n, according to the choosen rounding mode.
*)
(*** ON S'en FOUT
Definition DLog :=
  [m:rounding_mode][x:diadic]Cases (Dnum x) of
    (POS n) => (Log_of_pos (Cases m of
      	       	  Rounding_sup => `(Log_sup_pos n)-(Dexp x)`
      	       	| Rounding_inf => `(Log_inf_pos n)-(Dexp x)`
      	        | Rounding_nearest => `(Log_nearest n)-(Dexp x)`
      	        | Rounding_zero => `(Log_inf n)-(Dexp x)) end)`
  | (NEG n) =>  (Log_of_neg (Cases m of
      	       	  Rounding_sup => `(Log_inf n)-(Dexp x)`
      	       	| Rounding_inf => `(Log_sup n)-(Dexp x)`
      	        | Rounding_nearest => `(Log_nearest n)-(Dexp x)`
      	        | Rounding_zero => `(Log_inf n)-(Dexp x)) end)`
  | ZERO => M_infty
  end.
*****************)

(* (Dproj m x P y) is true when y is the projection of x onto the subset
  of integers who satisfy P, acording to the rounding mode m *)

Definition Dproj (m : rounding_mode) (x : diadic) (P : diadic -> Prop)
  (y : diadic) :=
  P y /\
  match m with
  | Rounding_sup => forall z : diadic, P z -> Dle x z -> Dle y z
  | Rounding_inf => forall z : diadic, P z -> Dle z x -> Dle z y
  | Rounding_nearest =>
      forall z : diadic, P z -> Dle (Dabs (Dminus x y)) (Dabs (Dminus x z))
  | Rounding_zero =>
      forall z : diadic,
      P z ->
      IF Dle (Dzero 0) x then Dle z x -> Dle z y else Dle z x -> Dle z y
  end.

(* ZROUND "forgets" p digits of n, but with respect to the rounding
  mode m.
  In few cases, ZROUND may have one digit more than (N_digits n)-p.
  Examples :

  (ZROUND inf 4 #1111111) = #111 but (ZROUND sup 4 #1111111) = #1000
  (ZROUND inf 4 #-1111111) = #-1000 but (ZROUND sup 4 #-1111111) = #-111

*)

Lemma ZROUND_inf_spec :
 forall (p : positive) (x : Z),
 {y : Z | (y * two_power_pos p <= x < Zsucc y * two_power_pos p)%Z}.
intros; elim (Zdiv_rest_correct x p); intros q r Hx Hr1 Hr2; exists q;
 rewrite (Zplus_0_r_reverse (q * two_power_pos p));
 rewrite Hx; split;
 [ apply Zplus_le_compat_l; assumption
 | unfold Zsucc in |- *; rewrite Zmult_plus_distr_l; apply Zplus_lt_compat_l;
    rewrite Zmult_1_l; assumption ].
Qed.

Definition ZROUND_inf (p : positive) (x : Z) :=
  let (x', p) := ZROUND_inf_spec p x in x'.

Lemma ZROUND_sup_spec :
 forall (p : positive) (x : Z),
 {y : Z | (Zpred y * two_power_pos p < x <= y * two_power_pos p)%Z}.
intros; elim (Zdiv_rest_correct x p); intros q r; elim r;
 [ intros Hx Hr; exists q; rewrite Hx; rewrite <- Zplus_0_r_reverse; split;
    [ apply Zmult_gt_0_lt_compat_r;
       [ compute in |- *; reflexivity | apply Zlt_pred ]
    | apply Zle_refl ]
 | intros p0 Hx Hr1 Hr2; exists (Zsucc q); rewrite Hx; split;
    [ replace (Zpred (Zsucc q) * two_power_pos p)%Z with
       (q * two_power_pos p + 0)%Z;
       [ apply Zplus_lt_compat_l; compute in |- *; reflexivity
       | rewrite <- Zpred_succ; rewrite <- Zplus_0_r_reverse; reflexivity ]
    | unfold Zsucc in |- *; rewrite Zmult_plus_distr_l;
       apply Zplus_le_compat_l; rewrite Zmult_1_l;
       apply Zlt_le_weak; assumption ]
 | intros p0 Hx Hr1 Hr2; absurd (Datatypes.Gt = Datatypes.Gt);
    [ exact Hr1 | reflexivity ] ].
Qed.

Definition ZROUND_sup (p : positive) (x : Z) :=
  let (x', p) := ZROUND_sup_spec p x in x'.

Lemma ZROUND_correct :
 forall (m : rounding_mode) (p : positive) (x : Z),
 {y : Z |
 match m with
 | Rounding_inf => (y * two_power_pos p <= x < Zsucc y * two_power_pos p)%Z
 | Rounding_sup => (Zpred y * two_power_pos p < x <= y * two_power_pos p)%Z
 | Rounding_nearest =>
     match (x - ZROUND_inf p x ?= ZROUND_sup p x - x)%Z with
     | Datatypes.Eq =>
         if Zeven.Zeven_bool (ZROUND_inf p x)
         then (y * two_power_pos p <= x < Zsucc y * two_power_pos p)%Z
         else (Zpred y * two_power_pos p < x <= y * two_power_pos p)%Z
     | Datatypes.Gt =>
         (Zpred y * two_power_pos p < x <= y * two_power_pos p)%Z
     | Datatypes.Lt =>
         (y * two_power_pos p <= x < Zsucc y * two_power_pos p)%Z
     end
 | Rounding_zero =>
     match x with
     | Zpos _ => (y * two_power_pos p <= x < Zsucc y * two_power_pos p)%Z
     | Z0 => y = 0%Z
     | Zneg _ => (Zpred y * two_power_pos p < x <= y * two_power_pos p)%Z
     end
 end}.
simple destruct m;
 [ exact ZROUND_sup_spec
 | exact ZROUND_inf_spec
 | intros p x; elim (x - ZROUND_inf p x ?= ZROUND_sup p x - x)%Z;
    [ elim (Zeven.Zeven_bool (ZROUND_inf p x));
       [ apply ZROUND_inf_spec | apply ZROUND_sup_spec ]
    | apply ZROUND_inf_spec
    | apply ZROUND_sup_spec ]
 | simple induction x;
    [  (* ZERO *) exists 0%Z; reflexivity
    |  (* POS *) intro; apply ZROUND_inf_spec
    |  (* NEG *) intro; apply ZROUND_sup_spec ] ].
Qed.

Definition ZROUND (m : rounding_mode) (p : positive)
  (x : Z) := let (x', p) := ZROUND_correct m p x in x'.

Definition POS_ROUND (m : rounding_mode) (p n : positive) :=
  BinInt.Zabs_N (ZROUND m p (Zpos n)).

Definition NEG_ROUND (m : rounding_mode) (p n : positive) :=
  BinInt.Zabs_N (- ZROUND m p (Zneg n)).

(* (ROUND m p x) does verify :
   (Dproj m x {y:Z | (N_digits (Dexp x))=p \/ (Dexp x)=`0`} (ROUND m p x))

  (At least, I hope so). *)

(* If p < 0 then (ROUND m p x)=(ROUND m -p x) *)
(* p is choosen of type Z (and not positive) only to avoid some
  further conversions *)

(* The case when (ZROUND m q nx) has p+1 digits occurs only when
  (ZROUND m q nx) = 1000...000. It is correctly matched *)
Definition Ddouble (d : diadic) := Dshift 1 d.

Axiom
  ROUND_spec :
    forall (m : rounding_mode) (p : Z) (x : diadic),
    {y : diadic |
    N_digits (Dexp y) = p /\
    match m with
    | Rounding_inf => Dle y x /\ Dlt x (Dsucc y)
    | Rounding_sup => Dlt (Dpred y) x /\ Dle x y
    | Rounding_nearest =>
        Dle (Dpred (Ddouble y)) (Ddouble x) /\
        Dle (Ddouble x) (Dsucc (Ddouble y))
    | Rounding_zero =>
        IF Dlt (Dzero 0) x then Dle y x /\ Dlt x (Dsucc y)
        else Dlt (Dpred y) x /\ Dle x y
    end}.

Definition ROUND (m : rounding_mode) (p : Z) (d : diadic) :=
  let (x, _) := ROUND_spec m p d in x.

(* Le jeu inverse : on fixe l'exposant, et on ajuste la mantisse    *)
(* (ANTIROUND m p x) rend l'entier k tel que la projection de x
   (selon le mode m) sur l'ensemble des diadiques dont l'exposant
    vaut p (cad l'ensemble des multiples entiers de 2^p) est k.2^p *)

Definition ANTIROUND (m : rounding_mode) (p : Z) (x : diadic) :=
  let nx := Dnum x in
  let ex := Dexp x in
  match (p - ex)%Z with
  | Zpos q => ZROUND m q nx
  | Zneg q => (nx * two_power_pos q)%Z
  | Z0 => nx
  end.

(********
Definition Dinv :=
  [x,y:diadic m:rounding_mode; p:positive]
  [nx=(POS px)][ny=(POS py)][ex=(Dexp x)][ey=(Dexp y)]
  Cases nx ny m  of
    (POS px) (POS py) Rounding_sup =>
      	`(Log_inf nx) - ex = -(Log_sup ny) + ey`
	/\`(Log_inf ny) >= p`
        /\` nx*ny <= (two_power_Z (ex+ey)) < nx*(ny+1)`
    (POS px) (POS py) Rounding_inf =>
      	`(Log_sup nx) - ex = -(Log_inf ny) + ey`
	/\`(Log_inf ny) >= p`
        /\` nx*(ny-1) <= (two_power_Z (ex+ey)) <= nx*ny`
    (POS px) (POS py) Rounding_nearest =>
      	`(Log_nearest nx) - ex = -(Log_nearest ny) + ey`
	/\`(Log_inf ny) >= p`
        /\` nx*ny <= (two_power_Z (ex+ey)) < (nx+1)*ny`

  | Rounding_sup (Log_of_neg e) =>
  | Rounding_inf =>
  | Rounding_nearest =>
  | Rounding_zero =>
  end.
************)

(* (Ddiv m p x y) is the correct approximation with p digits of the
  division (in the field R of real numebers) x/y
  Unspecified if p <= 0 *)

Parameter Ddiv : rounding_mode -> Z -> diadic -> diadic -> diadic.

(* Dsqrt m p n e) is the correct approximation with p digits of the
  division (in the field R of real numebers) sqrt(n*2^e) *)

Parameter Dsqrt : rounding_mode -> Z -> positive -> Z -> diadic.

End operations.


Require Import Bool Arith List Query.
Set Implicit Arguments.

(**
  IMP syntax
**)

(*
    Nameholders for variables.
    Currently, there are two types:
    1. Result: a special variable to initialize/update the return value of the program.
    (Note: at this point, the result cannot be read. Only new tuples can be added to the current result)
    2. Heap variables: special indexed variables that initialize/update global data. Currently, there are 2 heap variables:
        a. 0 => Special index reserved for the tuple bound to each iteration of the outer ForAll loop (alternatively the only ForAll loop in the program, if applicable).
        b. 1 => Special index reserved for the tuple bound to each iteration of the inner ForAll loop. Only valid for programs with multiple loops (e.g., Jo)
*)
Inductive VarName : Set :=
  | ResultName : VarName
  | IndexedVarName : nat -> VarName.

(*
    Boolean expressions.
    Currenty, there are two ways to construct a boolean expression:
    1. BoolBExp: For the predicates true and false
    2. Pred1Exp: true if the first attribute == 1
*)
Inductive BExp : Set :=
  | BoolBExp : Bool -> BExp
  | Pred1Exp : BExp.

(*
    Expressions. Current values are:
    1. InputRelation1: First input relation to the program. This is also the relation for one-relation programs (e.g., SELECT)
    2. InputRelation2: Second input relation to the program. Only valid for programs that need a second relation (e.g., JOIN)
    3. RelationExp: Constructor to wrap the input relation to an expression.
    4. NatExp: Constructor to wrap the input natural number to an expression.
    5. BoolExp: Constructor to wrap the input boolean expression to an expression.
*)
Inductive Exp : Set :=
  | InputRelation1 : Exp
  | InputRelation2 : Exp
  | RelationExp : relation -> Exp
  | NatExp : nat -> Exp
  | BoolExp : BExp -> Exp.

(*
    Statements. Current values are:
    1. Assign: Execute the statement and assign the result to the input expression.
    2. ForAll: Iterate over the relation specified by the input expression, bind each tuple in this relation to the input variable name and execute the input statement for each of these tuples.
        Simulates the following loop.
        for (Tuple tuple: relation.getTuples()) {
            runStatement(statement, tuple);
        }
    3. ProjectTuple: For each tuple of the input relation, projects the element located at the specified index (NatExp) of the input expression, wraps it into a new tuple, and appends it to the result.
        Note: The second argument (IndexedVarName) is not used at this point but is kept for extensibility.
        Previously ProjectTuple was an expression (instead of statement) where the result of this projection needed to be stored in the heap. In future, this IndexedVarName will represent this heap variable.
    4. SelectTuple: Retrieves the tuple located at the specified index (NatExp) of the input relation and appends it to the result.
        Note: The second argument (IndexedVarName) is not used at this point but is kept for extensibility.
        Previously ProjectTuple was an expression (instead of statement) where the result of this projection needed to be stored in the heap. In future, this IndexedVarName will represent this heap variable.
    5. MatchTuples: Matches two tuples by an attribute (attribute hardcoded, so no syntax for specifying which)
*)
Inductive Statement : Set :=
  | Assign : VarName -> Exp -> Statement
  | ForAll : VarName -> Exp -> Statement -> Statement
  | ProjectTuple : Exp -> VarName -> Statement
  | SelectTuple : Exp -> VarName -> Statement
  | MatchTuples : VarName -> VarName -> Statement.

(*
    Imperative program representation.
    We decided to differentiate Seq from other statements, so that Coq can immediately know that imperative programs nest Sequence over the second argument.
    An imperative program is basically a list (Seq) of statements that end with a special program called Skip.
*)
Inductive ImpProgram : Set :=
  | Seq : Statement -> ImpProgram -> ImpProgram
  | Skip.

(**
   end (IMP syntx
**)

(* Converts the input query to an imperative program. *)
Definition queryToImp (q : Query) : option ImpProgram :=
  (* All imperative programs begin by assigning the result to nil (e.g., Result = nil;). This method reduces that clutter. *)
  let structure (inner : Statement) :=
    Some (Seq
      (Assign ResultName (RelationExp nil))
      (Seq
        (ForAll (IndexedVarName 0) InputRelation1 inner)
        Skip))
  in match q with
     | Select b => match b with
                   (* Select True => Result = Input; *)
                   | BTrue => Some (Seq (Assign ResultName InputRelation1) Skip)
                   (* Select False => Result = Nil; *)
                   | BFalse => Some (Seq (Assign ResultName (RelationExp nil)) Skip)
                   end
     | Project index => structure (ProjectTuple (NatExp index) (IndexedVarName 0))
     | SelectIf pr => match pr with
                      | PredBool b => structure (SelectTuple (BoolExp (BoolBExp b)) (IndexedVarName 0))
                      | PredFirst1 => structure (SelectTuple (BoolExp Pred1Exp) (IndexedVarName 0))
                      end
     | JoinFirst => structure (ForAll (IndexedVarName 1) InputRelation2
                              (MatchTuples (IndexedVarName 0) (IndexedVarName 1)))
     end.

(*
    Runs the input statement on input relations, updating the heap and producing a relation (actually a tuple), if necessary.
    Note that to simplify representation, the heap is represented as a pair of tuples. These tuples represent the tuples bound to the
    outer and inner loops in the program. The second tuple (of the heap) and the second input relation (input2) are only used by Join.
*)
Fixpoint runStatement (s: Statement) (input1: relation) (input2: relation) (heap: tuple * tuple) (nested: bool) : option relation :=
  match s with
  | Assign ResultName e => match e with
                           | InputRelation1 => Some input1
                           | RelationExp rexp => Some rexp
                           | _ => None
                           end
  | Assign _ _ => None
  | ProjectTuple (NatExp index) (IndexedVarName vnIndex) =>
          match projectTuple (fst heap) index with
          | Some tup => Some (tup :: nil)
          | None => None
          end
  | ProjectTuple _ _ => None
  | SelectTuple (BoolExp bexp) (IndexedVarName vnIndex) =>
      match bexp with
        | BoolBExp b => match b with
                          | BTrue => Some ((fst heap) :: nil)
                          | BFalse => Some nil
                        end
        | Pred1Exp => match (fst heap) with
                        | 1 :: _ => Some ((fst heap) :: nil)
                        | _ => Some nil
                      end
      end
  | SelectTuple _ _ => None
  | ForAll (IndexedVarName index) _ s' =>
      let fix helper (rel: relation) (nested' : bool) :=
        match rel with
        | nil => Some nil
        | t :: rem =>
          let heap' := if nested' then pair (fst heap) t else pair t nil in
          match (runStatement s' input1 input2 heap' true) with
          | None => None
          | Some res => match (helper rem nested') with
                        | Some rem' => Some (res ++ rem')
                        | None => None
                        end
          end
        end
      in if nested then helper input2 true else helper input1 false
  | ForAll _ _ _ => None
  | MatchTuples (IndexedVarName vn1) (IndexedVarName vn2) =>
       let (t1, t2) := ((fst heap), (snd heap)) in
       if joineq t1 t2 then Some ((t1 ++ t2) :: nil) else Some nil
  | MatchTuples _ _ => None
  end.

(*
    Runs the input imperative program on the input relations and returns the result.
    It turns out that we do not (and should not) have runImpSmall (small step semantics). Otherwise Coq cannot
    figure out that our function is structurally recursive. Special thanks go to Eric Mullen and Zach Tatlock.
*)
Definition runImp (p : ImpProgram) (input1 : relation) (input2 : relation) : option relation :=
  let fix helper (p : ImpProgram) (result: relation) : option relation :=
    match p with
    | Skip => Some result
    | Seq s p' => match (runStatement s input1 input2 (pair nil nil) false) with
                    | Some res => helper p' (result ++ res)
                    | None => None
                  end
    end
  in helper p nil.

(*
    Runs the input imperative program on the input relations and returns the result.
    Non-tail recursive version.
*)
Fixpoint runImp' (p: ImpProgram) (input1: relation) (input2 : relation) : option relation :=
  match p with
    | Skip => Some nil
    | Seq s p' => match (runStatement s input1 input2 (pair nil nil) false) with
                    | Some res => match runImp' p' input1 input2 with
                                    | Some remres => Some (res ++ remres)
                                    | None => None
                                      end
                    | None => None
                      end
end.

(**
  Test cases
**)
Eval compute in let p := queryToImp (Project 0) in
                        match p with
                          | None => None
                          | Some p' => runImp' p' ((1 :: 2 :: nil) :: (3 :: 4 :: nil) :: nil) nil
end.
(* = Some [(1),(3)] *)

Eval compute in let p := queryToImp (Project 2) in
                        match p with
                          | None => None
                          | Some p' => runImp' p' ((1 :: 2 :: nil) :: (3::4::nil) :: nil) nil
end.
(* = None *)

Eval compute in let p := queryToImp (Project 1) in
                        match p with
                          | None => None
                          | Some p' => runImp' p' ((1 :: 2 :: nil) :: (3::4::nil) :: nil) nil
end.
(* = Some [(2),(4)] *)

Eval compute in let p := queryToImp (SelectIf (PredBool BTrue)) in
                          match p with
                            | None => None
                            | Some p' => runImp' p' ((1 :: 2 :: nil) :: (3::4::nil) :: nil) nil
end.
(* = Some [(1,2),(3,4)] *)

Eval compute in let p := queryToImp (SelectIf (PredBool BFalse)) in
                          match p with
                            | None => None
                            | Some p' => runImp' p' ((1 :: 2 :: nil) :: (3::4::nil) :: nil) nil
end.
(* = Some [] *)

Eval compute in let p := queryToImp (SelectIf PredFirst1) in
                        match p with
                          | None => None
                          | Some p' => runImp' p' ((1::2::nil) :: (3::4::nil) :: (0::1::nil) :: (1::6::nil) :: nil) nil
end.
(* = Some [(1,2),(1,6)] *)

Eval compute in let p := queryToImp JoinFirst in
  match p with
    | None => None
    | Some p' => runImp' p' ((1::2::nil) :: (2::3::nil) :: nil) ((3::4::nil) :: (1::10::nil) :: (1::12::nil) :: nil)
end.
(* = Some [(1,2,1,10), (1,2,1,12)] *)

(**
   end (Test cases)
**)