Require Import Real.
Require Import Nabla.
Require Import Reals.
Require Export Relator.

Section RealCoqReal.
  Generalizable Variables K M Real.

  Context `{klb : LazyBool K} `{M_Monad : Monad M}
          {MultivalueMonad_description : Monoid_hom M_Monad NPset_Monad}
          {M_MultivalueMonad : MultivalueMonad}
          {Real : Type}
          {SemiDecOrderedField_Real : SemiDecOrderedField Real}
          {ComplArchiSemiDecOrderedField_Real : ComplArchiSemiDecOrderedField}.

  (* ring structure on Real *)
  Ltac IZReal_tac t :=
    match t with
    | real_0 => constr:(0%Z)
    | real_1 => constr:(1%Z)
    | IZreal ?u =>
      match isZcst u with
      | true => u
      | _ => constr:(InitialRing.NotConstant)
      end
    | _ => constr:(InitialRing.NotConstant)
    end.

  Add Ring realRing : (realTheory ) (constants [IZReal_tac]).

  Definition relate : Real -> R -> Prop.
  Proof.
    intros x y.
    destruct (relator x).
    exact (exists l : is_total y, x0 (exist _ y l)).
  Defined.

  Lemma relate_total : forall x y, relate x y -> is_total y.
  Proof.
    intros.
    unfold relate in H.
    destruct (relator x ).
    destruct H.
    exact x1.
  Defined.

  (* relator homomorphism *)
  Lemma relate_constant0 : relate real_0 R0.
  Proof.
    pose proof relator_constant0.
    unfold relate.
    rewrite H.
    exists is_total_constant0.
    apply (sigma_eqP _ _ _ _ _ _ (eq_refl _)).
    apply irrl.
  Qed.

  Lemma relate_constant1 : relate real_1 R1.
  Proof.
    pose proof relator_constant1.
    unfold relate.
    rewrite H.
    exists is_total_constant1.
    apply (sigma_eqP _ _ _ _ _ _ (eq_refl _)).
    apply irrl.
  Qed.

  Lemma relate_addition : forall x y a b, relate x a -> relate y b -> relate (x + y) (a + b)%R.
  Proof.

    intros.

    unfold relate.

    case_eq (relator (x + y)).
    intros.

    exists (is_total_addition a b (relate_total x a H) (relate_total y b H0)).

    pose proof (relator_addition x y).
    rewrite H2 in H1.
    clear H2.

    unfold Nabla.lift_binary in H1.
    case_eq (relator x); intros.
    case_eq (relator y); intros.
    rewrite H2 in H1.
    rewrite H3 in H1.
    pose proof (sigma_eqP_pr1 _ _ _ _ _ _  H1).
    rewrite<- H4.

    clear H1.
    unfold totalRadd.

    destruct e0.
    destruct e1.
    exists x3.
    exists x4.
    destruct u, u0.
    repeat split; auto.

    destruct x3, x4.
    assert (a + b = x3 + x4)%R.
    assert (a = x3).
    clear H3 H4.
    unfold relate in H.
    destruct (relator x).
    destruct H.
    pose proof (sigma_eqP_pr1 _ _ _ _ _ _ H2).
    induction H1.
    destruct e2.
    destruct u.
    pose proof (e2 _ H).
    pose proof (e2 _ x5).
    rewrite H1 in H3.
    exact (sigma_eqP_pr1 _ _ _ _ _ _ H3).
    assert (b = x4).
    clear H2 H4.
    unfold relate in H0.
    destruct (relator y).
    destruct H0.
    pose proof (sigma_eqP_pr1 _ _ _ _ _ _ H3).
    induction H2.
    destruct e2.
    destruct u.
    pose proof (e2 _ x6).
    pose proof (e2 _ H0).
    rewrite H4 in H2.
    exact (sigma_eqP_pr1 _ _ _ _ _ _ H2).
    rewrite H1; rewrite H5; apply eq_refl.
    apply (sigma_eqP _ _ _ _ _ _ H1).
    apply irrl.
  Qed.

  Lemma relate_multiplication : forall x y a b, relate x a -> relate y b -> relate (x * y) (a * b)%R.
  Proof.
    intros.
    unfold relate.
    case_eq (relator (x * y)).
    intros.
    exists (is_total_multiplication a b (relate_total x a H) (relate_total y b H0)).

    pose proof (relator_multiplication x y).
    rewrite H2 in H1.
    clear H2.

    unfold Nabla.lift_binary in H1.
    case_eq (relator x); intros.
    case_eq (relator y); intros.
    rewrite H2 in H1.
    rewrite H3 in H1.
    pose proof (sigma_eqP_pr1 _ _ _ _ _ _  H1).
    rewrite<- H4.

    clear H1.
    unfold totalRadd.

    destruct e0.
    destruct e1.
    exists x3.
    exists x4.
    destruct u, u0.
    repeat split; auto.

    destruct x3, x4.
    assert (a * b = x3 * x4)%R.
    assert (a = x3).
    clear H3 H4.
    unfold relate in H.
    destruct (relator x).
    destruct H.
    pose proof (sigma_eqP_pr1 _ _ _ _ _ _ H2).
    induction H1.
    destruct e2.
    destruct u.
    pose proof (e2 _ H).
    pose proof (e2 _ x5).
    rewrite H1 in H3.
    exact (sigma_eqP_pr1 _ _ _ _ _ _ H3).
    assert (b = x4).
    clear H2 H4.
    unfold relate in H0.
    destruct (relator y).
    destruct H0.
    pose proof (sigma_eqP_pr1 _ _ _ _ _ _ H3).
    induction H2.
    destruct e2.
    destruct u.
    pose proof (e2 _ x6).
    pose proof (e2 _ H0).
    rewrite H4 in H2.
    exact (sigma_eqP_pr1 _ _ _ _ _ _ H2).
    rewrite H1; rewrite H5; apply eq_refl.
    apply (sigma_eqP _ _ _ _ _ _ H1).
    apply irrl.
  Qed.

  Lemma relate_subtraction : forall x a, relate x a ->  relate (-x) (-a)%R.
  Proof.
    intros.
    unfold relate.
    case_eq (relator (- x)).
    intros.
    exists (is_total_subtraction a (relate_total x a H) ).

    pose proof (relator_subtraction x ).
    rewrite H1 in H0.
    clear H1.

    unfold Nabla.lift_binary in H0.
    case_eq (relator x); intros.
    rewrite H1 in H0.
    pose proof (sigma_eqP_pr1 _ _ _ _ _ _  H0).
    rewrite<- H2.

    unfold totalRsub.

    destruct e0.
    exists x2.
    destruct u.
    repeat split; auto.

    destruct x2.
    assert (-a = -x2)%R.
    assert (a = x2).
    unfold relate in H.
    destruct (relator x).
    destruct H.
    pose proof (sigma_eqP_pr1 _ _ _ _ _ _ H1).
    induction H3.

    destruct e1.
    destruct u.
    pose proof (e1 _ H).
    pose proof (e1 _ x3).
    rewrite H4 in H3.
    pose proof (sigma_eqP_pr1 _ _ _ _ _ _ H3).
    rewrite H5; auto.
    rewrite H3; auto.
    apply (sigma_eqP _ _ _ _ _ _ H3).
    apply irrl.
  Qed.

  Lemma relate_divison : forall x (p : x <> real_0) a, relate x a -> relate (/ p) (/a)%R.
  Proof.
    intros.
    unfold relate.
    case_eq (relator (/p)).
    intros.
    assert (a <> R0).
    pose proof (relator_mono_neg _ _ p).
    unfold relate in H.
    destruct (relator x).
    intro.
    induction (eq_sym H2).
    contradict H1.
    apply Nabla.nabla_eq_at.
    simpl.
    pose proof (relator_constant0).
    rewrite H1.
    simpl.
    apply fun_ext.
    intro.
    apply Prop_ext; intro.
    destruct H.
    destruct e0.
    destruct H4.
    pose proof (H5 _ H).
    pose proof (H5 _ H3).
    rewrite H6 in H7.
    rewrite <- H7.
    apply (sigma_eqP _ _ _ _ _ _ (eq_refl R0)).
    apply irrl.
    rewrite H3.
    destruct H.
    assert ((exist (fun x : R => is_total x) R0 x3) = totalR0).
    apply (sigma_eqP _ _ _ _ _ _ (eq_refl R0)).
    apply irrl.
    rewrite <- H4; auto.
    pose proof (relate_total _ _ H).

    exists (is_total_division _ H2 H1).

    pose proof (relator_division x p).

    rewrite H0 in H3.

    unfold relator_div_tmp in H3.
    unfold Nabla.lift_unary in H3.
    unfold Nabla.transport_ex in H3.
    unfold Nabla.lift_domain_unary in H3.
    unfold Nabla.lift_unary in H3.
    unfold Nabla.nabla_is_modal in H3.
    unfold Nabla.fancy_lift_unary in H3.
    unfold Nabla.nabla_mult in H3.

    pose proof (sigma_eqP_pr1 _ _ _ _ _ _ H3).
    clear H3.
    rewrite H4.

    clear H4.
    assert (exist _ a H2 <> totalR0).
    intro.
    apply sigma_eqP_pr1 in H3.
    exact (H1 H3).
    exists (exist _ (exist _ a H2) H3).
    assert (forall x2 : totalR, Nabla.nabla_unit totalR x2 = Nabla.nabla_unit _ (exist _ a H2) -> x2 <> totalR0).
    intros.
    intro.

    induction (eq_sym H5).
    contradict H1.
    apply Nabla.nabla_mono in H4.
    apply sigma_eqP_pr1 in H4.
    rewrite H4; auto.

    split.
    exists (exist _ ( Nabla.nabla_unit _ (exist _ a H2)) H4).
    split.
    intros.

    unfold Nabla.transport_fiber.
    assert ( (Nabla.nabla_unit {x1 : R | is_total x1} (exist (fun x1 : R => is_total x1) a H2))
             = (Nabla.nabla_unit totalR a0)).
    apply Nabla.nabla_eq_at.
    simpl.
    apply fun_ext.
    intro.
    apply Prop_ext; intro.
    rewrite H5.
    unfold relate in H.
    destruct (relator x).
    destruct e0.
    destruct u.
    apply sigma_eqP_pr1 in p0.
    apply (lp _ _ (fun k => k a0)) in p0.
    assert (x2 a0) by (rewrite p0; auto).
    pose proof (e0 _ H6).
    destruct H.
    pose proof (e0 _ H).
    rewrite <- H7, H8.
    apply (sigma_eqP _ _ _ _ _ _ (eq_refl _)).
    apply irrl.
    induction (eq_sym H5).

    unfold relate in H.
    destruct (relator x).
    destruct e0.
    destruct u.
    apply sigma_eqP_pr1 in p0.
    apply (lp _ _ (fun k => k a0)) in p0.
    assert (x1 a0) by (rewrite p0; auto).
    pose proof (e0 _ H6).
    destruct H.
    pose proof (e0 _ H).
    rewrite <- H7, H8.
    apply (sigma_eqP _ _ _ _ _ _ (eq_refl _)).
    apply irrl.

    apply (sigma_eqP _ _ _ _ _ _ H5).
    apply irrl.

    apply Nabla.nabla_eq_at.
    simpl.
    apply fun_ext.
    intro.
    apply Prop_ext; intros.
    rewrite H5.
    assert (
        (exist (fun x2 : R => is_total x2) a H2)
        =
        a0).
    apply sigma_eqP_pr1 in p0.
    apply (lp _ _ (fun k => k a0)) in p0.
    apply eq_sym; rewrite p0.
    apply eq_refl.
    apply (sigma_eqP _ _ _ _ _ _ H6).
    apply irrl.
    pose proof (H5 (exist _ a H2) (eq_refl _)).
    rewrite H6.
    apply (sigma_eqP _ _ _ _ _ _ (eq_refl _)).
    apply irrl.

    unfold totalRdiv.
    apply (sigma_eqP _ _ _ _ _ _ (eq_refl _)).
    apply irrl.

  Defined.

  (* relator is an anafunction *)

  Lemma ana1 : forall x : Real, exists! y : R, relate x y.
  Proof.
    intros.
    unfold relate.
    destruct (relator x).
    destruct e.
    destruct x1.
    exists x1.
    split.
    exists i.
    destruct H.
    exact H.
    intro.
    intro.
    destruct H.
    destruct H0.
    pose proof (H1 _ H0).
    pose proof (sigma_eqP_pr1 _ _ _ _ _ _ H2).
    exact H3.
  Defined.

  Lemma ana2 : forall x : R, is_total x -> exists! y : Real, relate y x.
  Proof.
    intros.
    unfold relate.
    pose proof (@relator_epi Real (Nabla.nabla_unit _ (exist _ x H))).
    destruct H0.
    exists x0.
    split; auto.
    destruct (relator x0).
    pose proof (sigma_eqP_pr1 _ _ _ _ _ _ H0).
    rewrite <- H1.
    exists H.
    auto.
    intro.

    pose proof (relator_mono x0 x').
    intro.
    apply H1.
    clear H1.

    rewrite <- H0.
    destruct (relator x').
    unfold Nabla.nabla_unit.
    assert ( (fun a : {x2 : R | is_total x2} => a = exist (fun x2 : R => is_total x2) x H)
             =
             x1).
    apply fun_ext.
    intro.
    apply Prop_ext.
    intro.
    rewrite H1.
    destruct e.
    destruct H2.
    destruct H3.
    pose proof (H4 _ H2).
    assert (x4 = H) by apply irrl.
    induction H6.
    rewrite H5 in H3.
    exact H3.
    intro.
    destruct e.

    destruct H3.

    destruct H2.
    destruct x2.
    pose proof (H4 _ H2).
    pose proof (H4 _ H1).
    rewrite H6 in H5.
    pose proof (sigma_eqP_pr1 _ _ _ _ _ _ H5).
    apply (sigma_eqP _ _ _ _ _ _ H7).
    apply irrl.
    apply (sigma_eqP _ _ _ _ _ _ H1).
    apply irrl.
  Defined.

  Lemma relate_unique_R : forall x y a b, relate x a -> relate y b -> x = y -> a = b.
  Proof.
    intros.
    rewrite H1 in H.
    destruct (ana1 y).
    destruct H2.
    rewrite <- (H3 _ H).
    rewrite <- (H3 _ H0).
    exact (eq_refl _).
  Qed.

  Lemma relate_unique_Real : forall x y a b, relate x a -> relate y b -> a = b -> x = y.
  Proof.
    intros.
    rewrite H1 in H.
    pose proof (ana2 _ (relate_total _ _ H)).
    pose proof (ana2 _ (relate_total _ _ H0)).
    destruct H2 as [i1 [j1 k1]].
    destruct H3 as [i2 [j2 k2]].
    rewrite<- (k1 _ H).
    rewrite<- (k1 _ H0).
    exact (eq_refl _).
  Qed.

  Ltac total :=
    auto;
    match goal with
    | H : (relate ?x ?y) |- is_total ?y => exact (relate_total _ _ H)
    | |- is_total R0 => exact is_total_constant0
    | |- is_total R1 => exact is_total_constant1
    | |- is_total (?x + ?y) => apply is_total_addition; [total | total]
    | |- is_total (?x * ?y) => apply is_total_multiplication; [total | total]
    | |- is_total (-?x) => apply is_total_subtraction; total
    | |- is_total (?x - ?y) => apply is_total_minus; [total | total]
    | |- is_total (/?x) => apply is_total_division; [total | auto]
    | |- is_total (?x / ?y) => apply is_total_division2; [total | total |auto]
    end.

  Lemma transport_eq : forall a b : Real, (forall x y, relate a x -> relate b y -> x = y) -> a = b.
  Proof.
    intros.
    pose proof (relator_mono a b).
    apply H0.
    clear H0.
    unfold relate in H.
    destruct (relator a).
    destruct (relator b).
    destruct e, e0.
    destruct x1, x2.
    pose proof (H x1 x2).
    assert  (exists l : is_total x1, x (exist (fun x : R => is_total x) x1 l)).
    exists i.
    destruct u; auto.
    assert ((exists l : is_total x2, x0 (exist (fun x : R => is_total x) x2 l))).
    exists i0.
    destruct u0; auto.

    pose proof (H0 H1 H2).
    induction H3.
    assert (x = x0).
    apply fun_ext.
    intro.
    apply Prop_ext.
    intro.
    destruct u, u0.
    pose proof (H5 _ H3).
    assert (i = i0) by apply irrl.
    induction H9.
    rewrite H8 in H6.
    exact H6.
    intro.
    destruct u, u0.
    pose proof (H7 _ H3).
    assert (i = i0) by apply irrl.
    induction H9.
    rewrite H8 in H4.
    exact H4.
    apply (sigma_eqP _ _ _ _ _ _ H3).
    apply irrl.
  Defined.

  Lemma transport_eq_inv : forall a b x y, relate a x -> relate b y -> a = b -> x = y.
  Proof.
    intros.
    induction H1.
    unfold relate in H, H0.
    destruct (relator a).
    destruct e, H, H0.
    destruct H1.
    pose proof (H2 _ H).
    pose proof (H2 _ H0).
    rewrite H3 in H4.
    apply (sigma_eqP_pr1 _ _ _ _ _ _ ) in H4.
    exact H4.
  Defined.

  Lemma transport_lt : forall a b : Real, (forall x y, relate a x -> relate b y -> (x < y)%R) -> a < b.
  Proof.
    intros.
    pose proof (relator_lt a b).
    rewrite H0.
    clear H0.
    unfold relate in H.
    destruct (relator a), (relator b).
    destruct e, e0.
    destruct x1, x2.
    pose proof (H x1 x2).
    assert ( (exists l : is_total x1, x (exist (fun x : R => is_total x) x1 l))).
    exists i.
    destruct u.
    exact H1.
    assert ((exists l : is_total x2, x0 (exist (fun x : R => is_total x) x2 l))).
    exists i0.
    destruct u0.
    exact H2.
    pose proof (H0 H1 H2).
    clear H0 H1 H2.
    unfold Nabla.lift_domain_binary.
    destruct (Nabla.Prop_is_nabla_modal).

    assert (  (exist (fun P : totalR -> Prop => exists ! a1 : totalR, P a1) x
                     (ex_intro (unique (fun a1 : totalR => x a1)) (exist (fun x4 : R => is_total x4) x1 i) u))
              = Nabla.nabla_unit _ (exist _ x1 i)).
    unfold Nabla.nabla_unit.
    assert (x =
            (fun a1 : {x4 : R | is_total x4} => a1 = exist (fun x4 : R => is_total x4) x1 i)).
    apply fun_ext.
    intros.
    apply Prop_ext.
    intros.
    destruct u.
    pose proof (H2 _ H0).
    rewrite H4; auto.
    intro.
    rewrite H0.
    destruct u.
    exact H1.
    apply (sigma_eqP _ _ _ _ _ _ H0).
    apply irrl.
    rewrite H0.
    clear H0.

    assert ( (exist (fun P : totalR -> Prop => exists ! a1 : totalR, P a1) x0
                    (ex_intro (unique (fun a1 : totalR => x0 a1)) (exist (fun x4 : R => is_total x4) x2 i0) u0))
             = Nabla.nabla_unit _ (exist _ x2 i0)).
    unfold Nabla.nabla_unit.
    assert (x0 =
            (fun a1 : {x4 : R | is_total x4} => a1 = exist (fun x4 : R => is_total x4) x2 i0)).
    apply fun_ext.
    intros.
    apply Prop_ext.
    intros.
    destruct u0.
    pose proof (H2 _ H0).
    rewrite H4; auto.
    intro.
    rewrite H0.
    destruct u0.
    exact H1.
    apply (sigma_eqP _ _ _ _ _ _ H0).
    apply irrl.
    rewrite H0.
    clear H0.
    pose proof  (Nabla.lift_binary_commute totalR totalR Prop totalRlt (exist _ x1 i) (exist _ x2 i0) ).

    replace
      (Nabla.lift_binary totalR totalR Prop totalRlt
                         (Nabla.nabla_unit {x4 : R | is_total x4} (exist (fun x4 : R => is_total x4) x1 i))
                         (Nabla.nabla_unit {x4 : R | is_total x4} (exist (fun x4 : R => is_total x4) x2 i0)))
      with
        (Nabla.lift_binary totalR totalR Prop totalRlt
                           (Nabla.nabla_unit totalR (exist (fun x : R => is_total x) x1 i))
                           (Nabla.nabla_unit totalR (exist (fun x : R => is_total x) x2 i0)))
      by auto.
    rewrite<- H0.

    clear H0.

    unfold fc, id in a0.
    destruct a0.
    unfold totalRlt.
    assert (x1 < x2 = True)%R.
    apply Prop_ext; auto.
    rewrite H2.
    pose proof (lp _ _ (fun f => f True) _ _  H0).
    simpl in H4.
    rewrite H4.
    unfold Base.id.
    auto.
  Qed.

  Lemma transport_lt_inv : forall a b x y, relate a x -> relate b y -> (a < b) -> (x < y)%R.
  Proof.
    intros.
    intros.
    pose proof (relator_lt a b).
    rewrite H2 in H1.
    clear H2.
    pose proof (relate_total _ _ H).
    pose proof (relate_total _ _ H0).
    assert (relator a = Nabla.nabla_unit _ (exist _ x H2)).
    unfold relate in H.
    destruct (relator a).
    unfold Nabla.nabla_unit.
    assert (x0 = (fun a0 : {x1 : R | is_total x1} => a0 = exist (fun x1 : R => is_total x1) x H2)).
    apply fun_ext.
    intro.
    apply Prop_ext.
    intro.
    destruct e.
    destruct u.
    pose proof (e _ H4).
    destruct H.
    pose proof (e _ H).
    assert (x4 = H2) by apply irrl.
    rewrite H7 in H6.
    rewrite <- H5.
    exact H6.
    intro.
    rewrite H4.
    destruct H.
    assert (x2 = H2) by apply irrl.
    rewrite H5 in H.
    exact H.
    apply (sigma_eqP _ _ _ _ _ _ H4).
    apply irrl.
    rewrite H4 in H1.
    clear H4.

    assert (relator b = Nabla.nabla_unit _ (exist _ y H3)).
    unfold relate in H0.
    destruct (relator b).
    unfold Nabla.nabla_unit.
    assert (x0 =  (fun a0 : {x1 : R | is_total x1} => a0 = exist (fun x1 : R => is_total x1) y H3)).
    apply fun_ext.
    intro.
    apply Prop_ext.
    intro.
    destruct e.
    destruct u.
    pose proof (e _ H4).
    destruct H0.
    pose proof (e _ H0).
    assert (x4 = H3) by apply irrl.
    rewrite H7 in H6.
    rewrite <- H5.
    exact H6.
    intro.
    rewrite H4.
    destruct H0.
    assert (x2 = H3) by apply irrl.
    rewrite H5 in H0.
    exact H0.
    apply (sigma_eqP _ _ _ _ _ _ H4).
    apply irrl.
    rewrite H4 in H1.
    clear H4.

    unfold Nabla.lift_domain_binary in H1.
    destruct (Nabla.Prop_is_nabla_modal).

    pose proof (Nabla.lift_binary_commute totalR totalR Prop totalRlt
                                          (exist _ x H2) (exist _ y H3)).
    replace
      ((Nabla.lift_binary totalR totalR Prop totalRlt
                          (Nabla.nabla_unit {x : R | is_total x} (exist (fun x : R => is_total x) x H2))
                          (Nabla.nabla_unit {x : R | is_total x} (exist (fun x : R => is_total x) y H3))))

      with

        ( Nabla.lift_binary totalR totalR Prop totalRlt
                            (Nabla.nabla_unit totalR (exist (fun x : R => is_total x) x H2))
                            (Nabla.nabla_unit totalR (exist (fun x : R => is_total x) y H3)))
      in H1

      by auto.

    rewrite <- H4 in H1.

    clear H4.
    unfold totalRlt in H1.
    unfold fc, Base.id in a0;  destruct a0.
    apply (lp _ _ (fun f => f (x< y)%R)) in H4.
    rewrite <- H4.
    exact H1.
  Defined.

  Lemma transport_eq2 : forall a b x y, relate a x -> relate b y -> x = y -> a = b.
  Proof.
    apply relate_unique_Real.
  Defined.

  Lemma transport_lt2 : forall a b x y, relate a x -> relate b y -> (x < y)%R -> a < b.
  Proof.
    intros.
    apply transport_lt.
    intros.
    induction (relate_unique_R _ _ _ _ H H2).
    induction (relate_unique_R _ _ _ _ H0 H3).
    exact H1.
    apply eq_refl.
    apply eq_refl.
  Defined.

  Definition transport_fiber : (Real -> Prop) -> (R -> Prop).
  Proof.
    intros.
    exact (forall x, relate x H -> X x).
  Defined.

  Definition transport_leq : forall a b : Real, (forall x y, relate a x -> relate b y -> (x <= y)%R) -> a <= b.
  Proof.
    intros.
    destruct (ana1 a) as [aa [hh _]].
    destruct (ana1 b) as [bb [jj _]].
    pose proof (H _ _ hh jj).
    destruct H0.
    left.
    apply (transport_lt2 _ _ _ _ hh jj H0).
    right; apply (transport_eq2 _ _ _ _ hh jj H0).
  Qed.

  Definition transport_geq : forall a b : Real, (forall x y, relate a x -> relate b y -> (x >= y)%R) -> a >= b.
  Proof.
    intros.
    destruct (ana1 a) as [aa [hh _]].
    destruct (ana1 b) as [bb [jj _]].
    pose proof (H _ _ hh jj).
    destruct H0.
    left.
    apply (transport_lt2 _ _ _ _ jj hh H0).
    right; apply (transport_eq2 _ _ _ _ hh jj H0).
  Qed.

  Definition transport_neq : forall a b : Real, (forall x y, relate a x -> relate b y -> (x <> y)%R) -> a <> b.
  Proof.
    intros.
    destruct (ana1 a) as [aa [hh _]].
    destruct (ana1 b) as [bb [jj _]].
    pose proof (H _ _ hh jj).
    intro.

    destruct H0.
    induction H1.
    apply (relate_unique_R _ _ _ _ hh jj).
    apply eq_refl.
  Qed.

  Definition transport_forall : forall P : Real -> Prop, (forall x : R, (transport_fiber P) x) -> (forall x : Real, P x).
    intros.
    unfold transport_fiber in H.
    destruct (ana1 x).
    destruct H0.
    exact (H x0 x H0).
  Defined.

  (* Definition transport_exists : forall P : Real -> Prop, (exists x : R, (transport_fiber P) x) -> (exists x : Real, P x). *)
  (* Proof. *)
  (*   intros. *)
  (*   destruct H. *)
  (*   unfold transport_fiber in H. *)
  (*   destruct (ana2 x). *)
  (*   destruct H0. *)
  (*   exists x0. *)
  (*   exact (H _ H0). *)
  (* Defined. *)

  Definition transport_leq_inv : forall a b x y, relate a x -> relate b y -> (a <= b) -> (x <= y)%R.
  Proof.
    intros.
    destruct H1.
    left.
    apply (transport_lt_inv a b x y H H0).
    exact H1.
    right.
    induction H1.
    apply (relate_unique_R _ _ _ _ H H0 (eq_refl _)).
  Qed.

  Definition transport_geq_inv : forall a b x y, relate a x -> relate b y -> (a >= b) -> (x >= y)%R.
  Proof.
    intros.
    destruct H1.
    left.
    apply (transport_lt_inv b a y x  H0 H).
    exact H1.
    right.
    induction H1.
    apply (relate_unique_R _ _ _ _ H H0 (eq_refl _)).
  Qed.

  Definition transport_neq_inv : forall a b x y, relate a x -> relate b y -> (a <> b) -> (x <> y)%R.
  Proof.
    intros.
    intro.
    induction H2.
    exact (H1 (relate_unique_Real _ _ _ _ H H0 (eq_refl _))).
  Defined.

  Definition skip : forall A,A -> A.
  Proof.
    intros.
    exact X.
  Defined.

  Definition Holber0: forall x, relate real_0 x -> x = R0.
  Proof.
    intros.
    rewrite (relate_unique_R _ _ _ _ relate_constant0 H (eq_refl _)).
    apply eq_refl.
  Qed.

  Definition Holber1: forall x, relate real_1 x -> x = R1.
  Proof.
    intros.
    rewrite (relate_unique_R _ _ _ _ relate_constant1 H (eq_refl _)).
    apply eq_refl.
  Qed.

  Definition Holber2 : forall a b x y z, relate x a -> relate y b -> relate (x + y) z ->
                                         z = (a + b)%R.
  Proof.
    intros.
    pose proof (relate_addition x y a b H H0).
    exact (relate_unique_R _ _ _ _ H1 H2 (eq_refl _)).
  Defined.

  Definition Holber3 : forall a b x y z, relate x a -> relate y b -> relate (x * y) z ->
                                         z = (a * b)%R.
  Proof.
    intros.
    pose proof (relate_multiplication x y a b H H0).
    exact (relate_unique_R _ _ _ _ H1 H2 (eq_refl _)).
  Defined.

  Definition Holber4 : forall a  x  z, relate x a -> relate (-x) z ->
                                       z = (-a)%R.
  Proof.
    intros.
    pose proof (relate_subtraction x a H).
    exact (relate_unique_R _ _ _ _ H0 H1 (eq_refl _)).
  Defined.

  Definition Holber6 : forall a  x  z (p : x <> real_0), relate x a -> relate (/p) z ->
                                                        z = (/a)%R.
  Proof.
    intros.
    pose proof (relate_divison x p a H).
    exact (relate_unique_R _ _ _ _ H0 H1 (eq_refl _)).
  Defined.

  Definition Holber7 : forall a b x y z (p : y <> real_0), relate x a -> relate y b -> relate (x / p) z -> z = (a/b)%R.
  Proof.
    intros.
    replace (a / b)%R with (a * / b)%R by auto.
    replace (x / p) with (x */ p) in H1 by auto.
    pose proof (relate_divison y p b H0).
    apply (Holber3 _ _ _ _ _ H H2).
    exact H1.
  Defined.

  Definition Holber5 : forall a b x y z, relate x a -> relate y b -> relate (x - y) z ->
                                         z = (a - b)%R.
  Proof.
    intros.
    replace (a - b)%R with (a + - b)%R by ring.
    replace (x - y) with (x + - y) in H1 by ring.
    pose proof (relate_subtraction y b H0).
    apply (Holber2 _ _ _ _ _ H H2 H1).
  Defined.

  Lemma eq_symm : forall {T} {x y : T}, x = y -> y = x.
  Proof.
    intros.
    rewrite H.
    apply eq_refl.
  Defined.

End RealCoqReal.

Ltac Holger s :=
  match type of s with
  | ?x = ?y =>
    let xx := fresh "x" in
    let yy := fresh "y" in
    let Hx := fresh "Hx" in
    let Hy := fresh "Hy" in
    let H := fresh "H" in

    destruct (ana1 x) as [xx [Hx _ ]];
    destruct (ana1 y) as [yy [Hy _ ]];
    pose proof (transport_eq_inv _ _ _ _ Hx Hy s) as H;
    clear s

  | ?x < ?y =>
    let xx := fresh "x" in
    let yy := fresh "y" in
    let Hx := fresh "Hx" in
    let Hy := fresh "Hy" in
    let H := fresh "H" in

    destruct (ana1 x) as [xx [Hx _ ]];
    destruct (ana1 y) as [yy [Hy _ ]];
    pose proof (transport_lt_inv _ _ _ _ Hx Hy s) as H;
    clear s

  | ?x <= ?y =>
    let xx := fresh "x" in
    let yy := fresh "y" in
    let Hx := fresh "Hx" in
    let Hy := fresh "Hy" in
    let H := fresh "H" in

    destruct (ana1 x) as [xx [Hx _ ]];
    destruct (ana1 y) as [yy [Hy _ ]];
    pose proof (transport_leq_inv _ _ _ _ Hx Hy s) as H;
    clear s

  | ?x >= ?y =>
    let xx := fresh "x" in
    let yy := fresh "y" in
    let Hx := fresh "Hx" in
    let Hy := fresh "Hy" in
    let H := fresh "H" in

    destruct (ana1 x) as [xx [Hx _ ]];
    destruct (ana1 y) as [yy [Hy _ ]];
    pose proof (transport_geq_inv _ _ _ _ Hx Hy s) as H;
    clear s

  | ?x <> ?y =>
    let xx := fresh "x" in
    let yy := fresh "y" in
    let Hx := fresh "Hx" in
    let Hy := fresh "Hy" in
    let H := fresh "H" in

    destruct (ana1 x) as [xx [Hx _ ]];
    destruct (ana1 y) as [yy [Hy _ ]];
    pose proof (transport_neq_inv _ _ _ _ Hx Hy s) as H;
    clear s

  end.

Ltac classical :=
  match goal with
  | |- eq ?x ?y => apply transport_eq;   intro; intro; intro; intro; classical (* (fail "not implemented yet") *)
  | |- ?x < ?y => apply transport_lt; intro; intro; intro; intro; classical
  | |- ?x > ?y => apply transport_lt; intro; intro; intro; intro; classical
  | |- ?x >= ?y => apply transport_geq; intro; intro; intro; intro; classical
  | |- ?x <= ?y => apply transport_leq; intro; intro; intro; intro; classical
  | |- ?x <> ?y => apply transport_neq; intro; intro; intro; intro; classical
  (* | |- exists x : Real, ?A => apply transport_exists;  intro; intro; intro; classical *)
  | |- forall x , ?A => apply (transport_forall (fun x => A));   intro; intro; intro; classical
  (* | |- forall x : Real, ?A => apply (transport_forall (fun x => A));   intro; intro; intro; classical *)

  | |- ?A => apply skip
                   (* | |- ?A => match A with *)
                   (*          | ?a = ?b => fail "haha" *)
                   (*          | _ => fail "FAIL" A *)
                   (*          end  *)

  end.

Ltac classical2 :=
  match goal with
  | |- eq ?x ?y => apply transport_eq;   intros  (* (fail "not implemented yet") *)
  | |- ?x < ?y => apply transport_lt; intros
  | |- ?x > ?y => apply transport_lt; intros
  | |- ?x >= ?y => apply transport_geq; intros
  | |- ?x <= ?y => apply transport_leq; intros
  | |- ?x <> ?y => apply transport_neq; intros
  (* | |- exists x : Real, ?A => apply transport_exists;  intro; intro; intro; classical *)
  | |- forall x , ?A => apply (transport_forall (fun x => A));   intros
  (* | |- forall x : Real, ?A => apply (transport_forall (fun x => A));   intro; intro; intro; classical *)

  | |- ?A => apply skip
                   (* | |- ?A => match A with *)
                   (*          | ?a = ?b => fail "haha" *)
                   (*          | _ => fail "FAIL" A *)
                   (*          end  *)

  end.

Ltac relate :=

  match goal with
  | H : (relate real_0 ?x) |- _ => (apply Holber0 in H; try induction (eq_symm H); clear H; relate)
  | H : (relate real_1 ?x) |- _ => (apply Holber1 in H; try induction (eq_symm H); clear H; relate)
  | H : (relate (?x + ?y) (?z)) |- _ =>
    (
      let a := fresh "x" in
      let b := fresh "y" in
      let Ha := fresh "Ha" in
      let Hb := fresh "Hb" in
      let Hc := fresh H in
      (destruct (ana1 x) as [a [Ha _]];
       destruct (ana1 y) as [b [Hb _]];
       pose proof (eq_symm (Holber2 _ _ _ _ _ Ha Hb H)) as Hc;
       induction ( Hc);
       clear Hc;
       clear H;
       relate
    ))

  | H : (relate (?x - ?y) (?z)) |- _ =>
    (
      let a := fresh "x" in
      let b := fresh "y" in
      let Ha := fresh "Ha" in
      let Hb := fresh "Hb" in
      let Hc := fresh H in
      (destruct (ana1 x) as [a [Ha _]];
       destruct (ana1 y) as [b [Hb _]];
       pose proof (eq_symm (Holber5 _ _ _ _ _ Ha Hb H)) as Hc;
       induction ( Hc);
       clear Hc;
       clear H;
       relate
    ))

  | H : (relate (?x / ?p) (?z)) |- _ =>
    match type of  p with
    | ?y <> real_0 =>
      (
        let a := fresh "x" in
        let b := fresh "y" in
        let Ha := fresh "Ha" in
        let Hb := fresh "Hb" in
        let Hc := fresh H in
        (destruct (ana1 x) as [a [Ha _]];
         destruct (ana1 y) as [b [Hb _]];
         pose proof (eq_symm (Holber7 _ _ _ _ _ p Ha Hb H)) as Hc;
         induction ( Hc);
         clear Hc;
         clear H;
         relate
      ))

    | _ => idtac "hello"
    end

  | H : (relate (?x * ?y) (?z)) |- _ =>
    (
      let a := fresh "x" in
      let b := fresh "y" in
      let Ha := fresh "Ha" in
      let Hb := fresh "Hb" in
      let Hc := fresh H in
      (destruct (ana1 x) as [a [Ha _]];
       destruct (ana1 y) as [b [Hb _]];
       pose proof (eq_symm (Holber3 _ _ _ _ _ Ha Hb H)) as Hc;
       induction ( Hc);
       clear Hc;
       clear H;
       relate
    ))

  | H : (relate (- ?x) (?y)) |- _ =>
    (
      let a := fresh "x" in
      let Ha := fresh "Ha" in
      let Hc := fresh H in
      (destruct (ana1 x) as [a [Ha _]];
       pose proof (eq_symm (Holber3 _ _ _  Ha  H)) as Hc;
       induction ( Hc);
       clear Hc;
       clear H;
       relate
      )
    )
  (* | H : (relate (@real_div ?x ?p) (?y)) |- _ =>
    (idtac "Fifth"
    (* ;  *)
    (* let a := fresh "x" in *)
    (* let Ha := fresh "Ha" in *)
    (* let Hc := fresh H in *)
    (* (destruct (ana1 x) as [a [Ha _]]; *)
    (*  pose proof (eq_symm (Holber6 _ _ _ p  Ha  H)) as Hc; *)
    (*  induction ( Hc); *)
    (*  clear Hc; *)
    (*  clear H; *)
    (*  relate *)
    (* ) *)
    ) *)
  | H : (relate (/ ?p) (?y)) |- _ =>
    match type of p with
    | ?x <> real_0 =>
      let a := fresh "x" in
      let Ha := fresh "Ha" in
      let Hc := fresh H in
      (destruct (ana1 x) as [a [Ha _]];
       pose proof (eq_symm (Holber6 _ _ _ p  Ha  H)) as Hc;
       induction ( Hc);
       clear Hc;
       clear H;
       relate
      )

    | _ => apply skip
    end

  | H1 : (relate (?x) (?y)), H2 : (relate (?x) (?z))  |- _ =>
    (
      induction (relate_unique_R _ _ _ _ H1 H2 (eq_refl _));
      clear H1;
      relate
    )

  | H1 : (relate (?x) (?z)), H2 : (relate (?y) (?z))  |- _ =>
    (
      induction (relate_unique_Real _ _ _ _ H1 H2 (eq_refl _));
      clear H1;
      relate
    )

  | _ => apply skip
  end.


Require Import Ynot Basis.
Require Import List Ascii String.
Require Import RSep.
Require Import HttpParser.
Require Import Packrat Stream.

Open Local Scope stsepi_scope.
Open Local Scope hprop_scope.

Ltac s := unfold HTTP_correct,Packrat.ans_correct in *; rsep fail auto.

Definition parse_test : forall (str : string),
  STsep (__)
        (fun _ : option (nat * ((method * string * (nat * nat)) * (list (string * string)) * string)) => __).
  intros; refine (
     is <- STRING_INSTREAM.instream_of_list_ascii (str2la str) ;
     parse <- http_parse is 0 ;
     INSTREAM.close is ;;
     {{Return parse}});
  solve [ s | destruct parse; sep fail auto ].
Qed.


From mwp.prelude Require Import reduction.
From mwp Require Import mwp.
From iris.base_logic.lib Require Import wsat.
From iris.proofmode Require Import tactics.
Import uPred.

Section adequacy.
Context {Λ Σ} (mwpd : mwpData Λ Σ) `{!mwpC mwpd}.
Implicit Types e : expr Λ.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val Λ → nat → mwpC_Extra → iProp Σ.
Implicit Types Ψ : val Λ → nat → Prop.

Record Reds e σ :=
{
  nstps : nat;
  end_val : val Λ;
  end_state : state Λ;
  reds : relations.nsteps pstep nstps (e, σ) (of_val end_val, end_state)
}.

Global Arguments nstps {_ _} _.
Global Arguments end_val {_ _} _.
Global Arguments end_state {_ _} _.
Global Arguments reds {_ _} _.

Lemma Reds_val_end_val {v σ} (rd : Reds (of_val v) σ) :
  nstps rd = 0 ∧ end_val rd = v ∧ end_state rd = σ.
Proof.
  destruct rd as [n w σ' Hstps]; simpl.
  by apply nsteps_val in Hstps as [? [?%of_val_inj ?]].
Qed.

Lemma mwp_adequacy_basic idx E e σ Φ :
  mwpC_state_interp mwpd σ ∗ MWP@{mwpd, idx} e @ E {{ Φ }} -∗
    ∀ (rd : Reds e σ),
      mwpC_modality mwpd idx E (nstps rd)
        (λ x, mwpC_state_interp mwpd (end_state rd) ∗ Φ (end_val rd) (nstps rd) x).
Proof.
  iIntros "[HPh Hic]" (rd).
  rewrite mwp_eq /mwp_def.
  iSpecialize("Hic" $! _ _ _ (nstps rd) with "[] HPh");
    first by (iPureIntro; eapply (reds rd)).
  iApply mwpC_modality_mono; last done; auto.
  iIntros (?) "[$ $]".
Qed.

End adequacy.

Class Initialization {Λ Σ} {InitCondition : Type} (Ex : Type)
      (f : InitCondition → mwpData Λ Σ)
      (mwpC : ∀ x : InitCondition, mwpC (f x))
      (idx : ∀ x : InitCondition, mwpC_modality_index) :=
{
  initialization_modality : InitCondition → iProp Σ → iProp Σ;
  initialization_seed_for_modality : InitCondition → iProp Σ;
  initialization_seed_for_state_interp : InitCondition → iProp Σ;
  initialization_residue : InitCondition → iProp Σ;
  initialization_alloc_seed :
    ⊢ |==> ∃ x : InitCondition, initialization_seed_for_modality x ∗
                               initialization_seed_for_state_interp x;
  initialization_elim_laters : nat;
  initialization_elim P Hcnd :
    ⊢ initialization_seed_for_modality Hcnd
       -∗ initialization_modality Hcnd P ==∗
       ▷^(initialization_elim_laters) P ∗ initialization_residue Hcnd;
  initialization_mwpCM_soundness_arg : Type;
  initialization_mwpCM_soundness_laters :
    nat → initialization_mwpCM_soundness_arg → nat;
  initialization_modality_initializer :
    InitCondition →
    initialization_mwpCM_soundness_arg → iProp Σ;
  initialization_mwpCM_soundness_fun : initialization_mwpCM_soundness_arg → Ex;
  initialization_Ex_conv : ∀ {x : InitCondition}, @mwpC_Extra _ _ _ (mwpC x) → Ex;
  initialization_mwpCM_soundness Hcnd (P : Ex → Prop) E n arg:
    initialization_residue Hcnd ∗ initialization_modality_initializer Hcnd arg ∗
      mwpC_modality (f Hcnd) (idx Hcnd) E n (λ x, ⌜P (initialization_Ex_conv x)⌝)
      ⊢ ▷^(initialization_mwpCM_soundness_laters n arg)
            ⌜P (initialization_mwpCM_soundness_fun arg)⌝
}.

Coercion initialization_modality : Initialization >-> Funclass.

Lemma mwp_adequacy {Λ Σ} {Condition : Type} Ex (f : Condition → mwpData Λ Σ)
      (mwpC : ∀ x : Condition, mwpC (f x))
      (idx : ∀ x : Condition, mwpC_modality_index)
      (SM : Initialization Ex f mwpC idx) E e σ
      (Ψ : val Λ → nat → Ex → Prop)
      (arg : initialization_mwpCM_soundness_arg):
  (∀ (Hcnd : Condition),
      initialization_seed_for_state_interp Hcnd ⊢
        SM Hcnd (mwpC_state_interp (f Hcnd) σ ∗
                 initialization_modality_initializer Hcnd arg ∗
                 MWP@{f Hcnd, idx Hcnd} e @ E {{ v ; n | [x],
                   ⌜Ψ v n (initialization_Ex_conv x)⌝ }}))
  → ∀ (rd : Reds e σ),
      Ψ (end_val rd) (@nstps Λ _ _ rd) (initialization_mwpCM_soundness_fun arg).
Proof.
  intros Hic rd.
  apply (@soundness (iResUR Σ) _
                    (initialization_elim_laters +
                     (initialization_mwpCM_soundness_laters (nstps rd) arg)));
    simpl.
  iMod initialization_alloc_seed as (Hcnd) "[HseedM HseedSI]".
  iPoseProof (Hic Hcnd with "[HseedSI]") as "Hic"; first done.
  iMod (initialization_elim with "HseedM Hic") as "[HP Hres]".
  rewrite laterN_plus. iNext.
  iDestruct "HP" as "[Hsi [Hinit Hic']]".
  iDestruct (mwp_adequacy_basic with "[$Hsi $Hic']") as "Hic'".
  iSpecialize ("Hic'" $! rd).
  iApply initialization_mwpCM_soundness; iFrame.
  iApply mwpC_modality_mono; last done; eauto.
  by iIntros (x) "[_ ?]".
Qed.


(**
Rainbow, a termination proof certification tool

See the COPYRIGHTS and LICENSE files.

- Kim Quyen LY, 2011-04-06

* CPF correctness checker

*)

Set Implicit Arguments.

Require Import ATrs SN ZArith EqUtil String List ListDec ListForall
  ListUtil ZUtil LogicUtil BoolUtil VecUtil cpf2color cpf ListExtras
  cpf_util RelUtil AVarCond ALoop APosition rainbow_full_termin
  AFilterPerm AReverse AUnary cpf2color AModLoop.

(***********************************************************************)
(** Non Termination proof. *)

Section Non_Termination.

  (** [nat_of_string]: convert variable map to natural number *)

  Variable nat_of_string : string  -> nat.

  (***********************************************************************)
  (** ** Check that [R] is a violation of variable condition, it
     means there is a rule where the [lhs] is a variable, or the [rhs]
     contains variables not occuring in the [lhs] (it is in the
     definition of rewrite rule).

     Definition: A pair [(l,r)] of terms is a rewrite rule if [l] is
     not a variable and [var(l) \subseteq var(r)]. *)

  Definition trsNonTerminationProof_variableConditionViolated a (R : arules a)  :=
    if brules_preserve_vars R then Ko _ ErNotVariableConditionViolated else OK.

  (***********************************************************************)
  (** ** Check that [p] is a valid non-termination proof for [red
     R]. Checking that there is a loop in a TRS. *)

  (* - [is_loop] is a boolean function testing non-termination in the
     case if there is a loop in TRS. It takes three arguments
      + t : term
      + ds: [list data] type [list (position * arule)]
      + pos: position ([list nat])

      CPF loop in coq type:
       [(term * list rewriteStep) * substitution * context]

     Use [color_term] to transform a [t: term] in CPF type
     into a [t: term] in CoLoR type.

     Use [positionInTerm] return [list position].

     Use [color_rewriteSequence] to return an CoLoR type
     [list data] where [ds: data] has type [position * rule].

     - Using [color_rewriteSequence] to return an CoLoR type
     [position = list nat].

     [rewriteStep : (positionInTerm x rule x option boolean x term)]
     [rewriteSequence := term x list rewriteStep]

   *)

  (* Define a function taking an argument of type [positionInTerm] and
       return a list of position. *)

  Fixpoint color_rewriteStep (a: symbol -> nat)
           (rs: list cpf.position * rule * option boolean * term ) :=
    let '(ps, r, _, _) := rs in
    Match color_list_position ps With ps ===>
          Match color_rule a nat_of_string r With r ===> Ok (ps, r).

  (* Define function return [list data]. *)

  Definition color_rewriteSequence a
             (ls:list (list cpf.position * rule * option boolean * term  )):
    result (list (list nat * arule a)) :=
    map (color_rewriteStep a) ls.

  (* Define function translate [context -> list position] *)

  Fixpoint color_position_of_context (c: context) : list nat :=
    match c with
      | Context_box => nil
      | Context_funContext _ l c _ =>
        List.length l :: color_position_of_context c
    end.

  (* FIXME *)
  (* loop = (term * list rewriteStep) * substitution * context *)

  Definition trsNonTerminationProof_loop a (R: arules a) (lo: cpf.loop)
  : result unit :=
    let '((t, ls), _, c) := lo in
    Match color_term a nat_of_string t With t ===>
          Match color_rewriteSequence a ls With ds ===>
          let pos := color_position_of_context c in
          if is_loop R t ds pos
          then OK else Ko _ ErtrsNonTerminationProof_loop. (* FIXME *)

  (***********************************************************************)
  (** ** Check that [p] is a valid non-termination proof for [red R].

     - [variableConditionViolated]: There is a rule where the lhs is a
     variable, or the rhs contains variables not occuring in the lhs.

     - [loop]: a loop is given by a (non-empty) rewrite-sequence t0 ->+
     tn where additional tn = C[t0 sigma]. *)

  (* FIXME *)

  Definition trsNonTerminationProof a (R: arules a) p : result unit :=
    match p with
      | TrsNonterminationProof_variableConditionViolated =>
        trsNonTerminationProof_variableConditionViolated R
      | TrsNonterminationProof_ruleRemoval _ _ =>
        Ko _ TTrsNonterminationProof_ruleRemoval
      | TrsNonterminationProof_stringReversal _ _ =>
        Ko _ TTrsNonterminationProof_stringReversal
      | TrsNonterminationProof_loop (((_, nil), _), _) =>
        Ko _ TTrsNonterminationProof_loop_nil
      | TrsNonterminationProof_loop lo => (* FIXME *)
        trsNonTerminationProof_loop R lo
      | TrsNonterminationProof_dpTrans _ _ _ =>
        Ko _ TTrsNonterminationProof_dpTrans
      | TrsNonterminationProof_nonterminationAssumption _ =>
        Ko _ TTrsNonterminationProof_nonterminationAssumption
      (*| TrsNonterminationProof_nonLoop _ =>
        Ko _ TTrsNonterminationProof_nonLoop
      | TrsNonterminationProof_nonterminationAssumption _ =>
        Ko _ TTrsNonterminationProof_nonterminationAssumption
      | TrsNonterminationProof_innermostLhssIncrease _ _ =>
        Ko _ TTrsNonterminationProof_innermostLhssIncrease*)
    end.

End Non_Termination.

(***********************************************************************)
(** ** Check that [R] is a violation of variable condition for
     [red_mod R D] *)

(* TODO *)
(*
Section Non_Rel_Termination.

  Variable nat_of_string : string  -> nat.

  Definition relativeNonTerminationProof_variableConditionViolated a (R D: arules a) :=
    if brules_preserve_vars D then Ko _ ErNotVariableConditionViolated else OK.

  (***********************************************************************)
  (** ** Check that [p] is a valid non-termination proof for [red_mod
     R D]. Checking that there is a loop in a TRS. *)

  (* Define function return [mod_data = (list data * data)]. *)

  Definition color_mod_data a (ls: list rewriteStep):
    result ((list (list nat * arule a)) * (list nat * arule a)) :=
    match ls with
      | nil => (*Ko _ Tmod_data_nil (* TODO ? *)*) Ko _ Todo
      | l :: ls' =>
        Match color_rewriteStep nat_of_string a l With ds ===>
              Match color_rewriteSequence nat_of_string a ls' With mds ===>
              Ok (mds, ds)
    end.

  (* Define a type [list mod_data]. *)

  Definition color_list_mod_data a (ls: list (list rewriteStep)):
    result (list ((list (list nat * arule a)) * (list nat * arule a))) :=
    map (color_mod_data a) ls.

  Definition relativeNonTerminationProof_loop a (R D: arules a) (lo: cpf.loop) :
    result unit :=
    let '((t, ls), _, c) := lo in
    Match color_term a nat_of_string t With t ===>
          (* FIXME: (ls: nil) == list (list rewriteSequence) *)
          Match color_list_mod_data a (ls::nil) With mds ===>
          Match color_rewriteSequence nat_of_string a ls With ds ===>
          let pos := color_position_of_context c in
          if is_mod_loop R D t mds ds pos
          then OK else Ko _ ErrelativeNonTerminationProof_loop.

  (***********************************************************************)
  (** ** Check that [p] is a valid termination proof for [red_mod R D]

     [variableConditionViolated]: There is a rule where the lhs is a
     variable, or the rhs contains variables not occuring in the lhs.

     [loop]: a loop is given by a (non-empty) rewrite-sequence t0 ->+
     tn where additional tn = C[t0 sigma]. *)

  Definition relativeNonterminationProof a (R D: arules a)
             (p: relativeNonterminationProof) : result unit :=
    match p with
      | RelativeNonterminationProof_loop lo =>
        relativeNonTerminationProof_loop R D lo
      | RelativeNonterminationProof_trsNonterminationProof _ =>
        Ko _ TRelativeNonterminationProof_trsNonterminationProof
      | RelativeNonterminationProof_variableConditionViolated =>
        relativeNonTerminationProof_variableConditionViolated R D
      | RelativeNonterminationProof_ruleRemoval _ _ _ =>
        Ko _ TRelativeNonterminationProof_ruleRemoval
      | RelativeNonterminationProof_nonterminationAssumption _ =>
        Ko _ TRelativeNonterminationProof_nonterminationAssumption
    end.

End Non_Rel_Termination.*)

(* FIXME *)

 (* Definition color_rewriteStep a (rstep: rewriteStep)
  : result ((list nat) * arule a) :=
    let '(ps, r, _, _) := rstep in
    Match color_list_position ps With ps ===>
          Match color_rule a nat_of_string r With r ===> Ok (ps, r).

  (* Define function return [list data]. *)

  Definition color_rewriteSequence a (ls: list rewriteStep):
    result (list (list nat * arule a)) :=
    map (color_rewriteStep a) ls.

  (* Define function translate [context -> list position] *)

  Fixpoint color_position_of_context (c: context) : list nat :=
    match c with
      | Context_box => nil
      | Context_funContext _ l c _ =>
        List.length l :: color_position_of_context c
    end.

  (* FIXME *)
  (* loop = (term * list rewriteStep) * substitution * context *)

  Definition trsNonTerminationProof_loop a (R: arules a) (lo: cpf.loop)
  : result unit :=
    let '((t, ls), _, c) := lo in
    Match color_term a nat_of_string t With t ===>
          Match color_rewriteSequence a ls With ds ===>
          let pos := color_position_of_context c in
          if is_loop R t ds pos
          then OK else Ko _ ErtrsNonTerminationProof_loop. (* FIXME *)

  (***********************************************************************)
  (** ** Check that [p] is a valid non-termination proof for [red R].

     - [variableConditionViolated]: There is a rule where the lhs is a
     variable, or the rhs contains variables not occuring in the lhs.

     - [loop]: a loop is given by a (non-empty) rewrite-sequence t0 ->+
     tn where additional tn = C[t0 sigma]. *)

  (* FIXME *)

  Definition trsNonTerminationProof a (R: arules a) p : result unit :=
    match p with
      | TrsNonterminationProof_variableConditionViolated =>
        trsNonTerminationProof_variableConditionViolated R
      | TrsNonterminationProof_ruleRemoval _ _ =>
        Ko _ TTrsNonterminationProof_ruleRemoval
      | TrsNonterminationProof_stringReversal _ _ =>
        Ko _ TTrsNonterminationProof_stringReversal
      | TrsNonterminationProof_loop (((_, nil), _), _) =>
        Ko _ TTrsNonterminationProof_loop_nil
      | TrsNonterminationProof_loop lo => (* FIXME *)
        trsNonTerminationProof_loop R lo
      | TrsNonterminationProof_dpTrans _ _ _ =>
        Ko _ TTrsNonterminationProof_dpTrans
      | TrsNonterminationProof_nonLoop _ =>
        Ko _ TTrsNonterminationProof_nonLoop
      | TrsNonterminationProof_nonterminationAssumption _ =>
        Ko _ TTrsNonterminationProof_nonterminationAssumption
      | TrsNonterminationProof_innermostLhssIncrease _ _ =>
        Ko _ TTrsNonterminationProof_innermostLhssIncrease
    end.

End Non_Termination.

(***********************************************************************)
(** ** Check that [R] is a violation of variable condition for
     [red_mod R D] *)

Section Non_Rel_Termination.

  Variable nat_of_string : string  -> nat.

  Definition relativeNonTerminationProof_variableConditionViolated a (R D: arules a) :=
    if brules_preserve_vars D then Ko _ ErNotVariableConditionViolated else OK.

  (***********************************************************************)
  (** ** Check that [p] is a valid non-termination proof for [red_mod
     R D]. Checking that there is a loop in a TRS. *)

  (* Define function return [mod_data = (list data * data)]. *)

  Definition color_mod_data a (ls: list rewriteStep):
    result ((list (list nat * arule a)) * (list nat * arule a)) :=
    match ls with
      | nil => (*Ko _ Tmod_data_nil (* TODO ? *)*) Ko _ Todo
      | l :: ls' =>
        Match color_rewriteStep nat_of_string a l With ds ===>
              Match color_rewriteSequence nat_of_string a ls' With mds ===>
              Ok (mds, ds)
    end.

  (* Define a type [list mod_data]. *)

  Definition color_list_mod_data a (ls: list (list rewriteStep)):
    result (list ((list (list nat * arule a)) * (list nat * arule a))) :=
    map (color_mod_data a) ls.

  Definition relativeNonTerminationProof_loop a (R D: arules a) (lo: cpf.loop) :
    result unit :=
    let '((t, ls), _, c) := lo in
    Match color_term a nat_of_string t With t ===>
          (* FIXME: (ls: nil) == list (list rewriteSequence) *)
          Match color_list_mod_data a (ls::nil) With mds ===>
          Match color_rewriteSequence nat_of_string a ls With ds ===>
          let pos := color_position_of_context c in
          if is_mod_loop R D t mds ds pos
          then OK else Ko _ ErrelativeNonTerminationProof_loop.

  (***********************************************************************)
  (** ** Check that [p] is a valid termination proof for [red_mod R D]

     [variableConditionViolated]: There is a rule where the lhs is a
     variable, or the rhs contains variables not occuring in the lhs.

     [loop]: a loop is given by a (non-empty) rewrite-sequence t0 ->+
     tn where additional tn = C[t0 sigma]. *)

  Definition relativeNonterminationProof a (R D: arules a)
             (p: relativeNonterminationProof) : result unit :=
    match p with
      | RelativeNonterminationProof_loop lo =>
        relativeNonTerminationProof_loop R D lo
      | RelativeNonterminationProof_trsNonterminationProof _ =>
        Ko _ TRelativeNonterminationProof_trsNonterminationProof
      | RelativeNonterminationProof_variableConditionViolated =>
        relativeNonTerminationProof_variableConditionViolated R D
      | RelativeNonterminationProof_ruleRemoval _ _ _ =>
        Ko _ TRelativeNonterminationProof_ruleRemoval
      | RelativeNonterminationProof_nonterminationAssumption _ =>
        Ko _ TRelativeNonterminationProof_nonterminationAssumption
    end.

End Non_Rel_Termination. *)


From iris.prelude Require Import options.
Require Import cpdt.CpdtTactics.
Require Import coq_tricks.Deex.
Require Import Burrow.trees.
Require Import Burrow.indexing.
Require Import Burrow.gmap_utils.
Require Import Burrow.tactics.

From stdpp Require Import countable.
From stdpp Require Import gmap.

Section MaxLTUnit.

Context {M} `{!EqDecision M} `{!TPCM M}.

Definition listset_max `{EqDecision A} (se : listset A) (fn: A -> nat)
 := (set_fold (λ r k, k `max` fn r) 0 se).

Lemma elem_le_listset_max `{EqDecision A} (se : listset A) (fn: A -> nat) (a: A)
  (in_set : a ∈ se)
  : fn a ≤ listset_max se fn.
Proof.
  unfold listset_max.
  unfold set_fold, "∘".
  assert (a ∈ elements se).
  - rewrite elem_of_elements. trivial.
  - full_generalize (elements se) as l. generalize H. clear H. induction l.
    + intros. inversion H.
    + intros. inversion H.
      * subst. cbn [foldr]. lia.
      * subst. cbn [foldr]. have ih := IHl H2. lia.
Qed.

Definition rmaxltfn := (λ ent : (Lifetime * M) , match ent with (lt, _) => max_ltunit_in_lt lt end).

Definition max_ltunit_in_cell (c: Cell M) : nat :=
  match c with
  | CellCon _ rset => listset_max rset rmaxltfn
  end.

Fixpoint max_ltunit_in_branch (b: Branch M) : nat :=
  match b with
  | BranchCons n b => max_ltunit_in_node n `max` max_ltunit_in_branch b
  | BranchNil => 0
  end
with max_ltunit_in_node (n: Node M) : nat :=
  match n with
  | CellNode c b => max_ltunit_in_cell c `max` max_ltunit_in_branch b
  end
.

Lemma lt_singleton_not_eq_to_cell_lt ltunit b pl
  (isgreater: ltunit > max_ltunit_in_branch b)
  : match cell_of_pl b pl with CellCon _ rset =>
    ∀ r , r ∈ rset -> match r with (lt, _) => ¬(multiset_in lt ltunit) end
    end.
Proof.
  apply (pl_reverse_induction1_node
    (b)
    (λ pl b , ltunit > max_ltunit_in_branch b)
    (λ pl n ,
      match cell_of_node n with CellCon _ rset =>
        ∀ r , r ∈ rset -> match r with (lt, _) => ¬(multiset_in lt ltunit) end
      end
      /\ ltunit > max_ltunit_in_node n
    )).
  - trivial.
  - intros. destruct_ands. cbn [max_ltunit_in_node] in H0. lia.
  - intros. repeat split.
    + cbn [max_ltunit_in_branch] in H. lia.
    + destruct node. unfold cell_of_node. destruct c.
        cbn [max_ltunit_in_branch] in H.
        cbn [max_ltunit_in_node] in H.
        intro. destruct r. intro.
        unfold max_ltunit_in_cell in H.
        assert (rmaxltfn (m0, m1) ≤ listset_max l rmaxltfn) as r.
        * apply elem_le_listset_max. trivial.
        * unfold rmaxltfn in r at 1.
          intro mi.
          have mlilg := max_ltunit_in_lt_ge m0 ltunit mi.
          lia.
    + cbn [max_ltunit_in_branch] in H. lia.
  - intros. simpl. lia.
  - intros. unfold max_ltunit_in_node, triv_node.
      unfold max_ltunit_in_cell, triv_cell.
      unfold listset_max. rewrite set_fold_empty.
      split.
      + unfold cell_of_node. intro. rewrite elem_of_empty. intuition.
      + lia.
Qed.

End MaxLTUnit.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Machine- and ABI-dependent layout information for activation records. *)

Require Import Coqlib.
Require Import Bounds.

(** The general shape of activation records is as follows,
  from bottom (lowest offsets) to top:
- Space for outgoing arguments to function calls.
- Back link to parent frame
- Local stack slots of integer type.
- Saved values of integer callee-save registers used by the function.
- Local stack slots of float type.
- Saved values of float callee-save registers used by the function.
- Space for the stack-allocated data declared in Cminor
- Return address.

The [frame_env] compilation environment records the positions of
the boundaries between these areas of the activation record.
*)

Definition fe_ofs_arg := 0.

Record frame_env : Type := mk_frame_env {
  fe_size: Z;
  fe_ofs_link: Z;
  fe_ofs_retaddr: Z;
  fe_ofs_int_local: Z;
  fe_ofs_int_callee_save: Z;
  fe_num_int_callee_save: Z;
  fe_ofs_float_local: Z;
  fe_ofs_float_callee_save: Z;
  fe_num_float_callee_save: Z;
  fe_stack_data: Z
}.

(** Computation of the frame environment from the bounds of the current
  function. *)

Definition make_env (b: bounds) :=
  let olink := 4 * b.(bound_outgoing) in  (* back link *)
  let oil := olink + 4 in              (* integer locals *)
  let oics := oil + 4 * b.(bound_int_local) in (* integer callee-saves *)
  let oendi := oics + 4 * b.(bound_int_callee_save) in
  let ofl := align oendi 8 in             (* float locals *)
  let ofcs := ofl + 8 * b.(bound_float_local) in (* float callee-saves *)
  let ostkdata := ofcs + 8 * b.(bound_float_callee_save) in (* stack data *)
  let oretaddr := align (ostkdata + b.(bound_stack_data)) 4 in (* return address *)
  let sz := oretaddr + 4 in (* total size *)
  mk_frame_env sz olink oretaddr
                  oil oics b.(bound_int_callee_save)
                  ofl ofcs b.(bound_float_callee_save)
                  ostkdata.

(** Separation property *)

Remark frame_env_separated:
  forall b,
  let fe := make_env b in
  0 <= fe_ofs_arg
  /\ fe_ofs_arg + 4 * b.(bound_outgoing) <= fe.(fe_ofs_link)
  /\ fe.(fe_ofs_link) + 4 <= fe.(fe_ofs_int_local)
  /\ fe.(fe_ofs_int_local) + 4 * b.(bound_int_local) <= fe.(fe_ofs_int_callee_save)
  /\ fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save) <= fe.(fe_ofs_float_local)
  /\ fe.(fe_ofs_float_local) + 8 * b.(bound_float_local) <= fe.(fe_ofs_float_callee_save)
  /\ fe.(fe_ofs_float_callee_save) + 8 * b.(bound_float_callee_save) <= fe.(fe_stack_data)
  /\ fe.(fe_stack_data) + b.(bound_stack_data) <= fe.(fe_ofs_retaddr)
  /\ fe.(fe_ofs_retaddr) + 4 <= fe.(fe_size).
Proof.
  intros.
  generalize (align_le (fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save)) 8 (refl_equal _)).
  generalize (align_le (fe.(fe_stack_data) + b.(bound_stack_data)) 4 (refl_equal _)).
  unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr,
    fe_ofs_int_local, fe_ofs_int_callee_save,
    fe_num_int_callee_save,
    fe_ofs_float_local, fe_ofs_float_callee_save, fe_num_float_callee_save,
    fe_stack_data, fe_ofs_arg.
  intros.
  generalize (bound_int_local_pos b); intro;
  generalize (bound_float_local_pos b); intro;
  generalize (bound_int_callee_save_pos b); intro;
  generalize (bound_float_callee_save_pos b); intro;
  generalize (bound_outgoing_pos b); intro;
  generalize (bound_stack_data_pos b); intro.
  omega.
Qed.

(** Alignment property *)

Remark frame_env_aligned:
  forall b,
  let fe := make_env b in
  (4 | fe.(fe_ofs_link))
  /\ (4 | fe.(fe_ofs_int_local))
  /\ (4 | fe.(fe_ofs_int_callee_save))
  /\ (8 | fe.(fe_ofs_float_local))
  /\ (8 | fe.(fe_ofs_float_callee_save))
  /\ (4 | fe.(fe_ofs_retaddr))
  /\ (8 | fe.(fe_stack_data))
  /\ (4 | fe.(fe_size)).
Proof.
  intros.
  unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr,
    fe_ofs_int_local, fe_ofs_int_callee_save,
    fe_num_int_callee_save,
    fe_ofs_float_local, fe_ofs_float_callee_save, fe_num_float_callee_save,
    fe_stack_data.
  set (x1 := 4 * bound_outgoing b).
  assert (4 | x1). unfold x1; exists (bound_outgoing b); ring.
  set (x2 := x1 + 4).
  assert (4 | x2). unfold x2; apply Zdivide_plus_r; auto. exists 1; auto.
  set (x3 := x2 + 4 * bound_int_local b).
  assert (4 | x3). unfold x2; apply Zdivide_plus_r; auto. exists (bound_int_local b); ring.
  set (x4 := x3 + 4 * bound_int_callee_save b).
  set (x5 := align x4 8).
  assert (8 | x5). unfold x5. apply align_divides. omega.
  set (x6 := x5 + 8 * bound_float_local b).
  assert (8 | x6). unfold x6. apply Zdivide_plus_r; auto. exists (bound_float_local b); ring.
  set (x7 := x6 + 8 * bound_float_callee_save b).
  assert (8 | x7).
    unfold x7. apply Zdivide_plus_r; auto. exists (bound_float_callee_save b); ring.
  set (x8 := align (x7 + bound_stack_data b) 4).
  assert (4 | x8). apply align_divides. omega.
  set (x9 := x8 + 4).
  assert (4 | x9). unfold x8; apply Zdivide_plus_r; auto. exists 1; auto.
  tauto.
Qed.


Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Floats.
Require Import compcert.common.Values.
Require Import compcert.common.Memory.
Require Import Coq.micromega.Lia.
Require Import VST.msl.eq_dec.

Definition address : Type := (block * Z)%type.

#[export] Instance EqDec_block: EqDec block := eq_block.

#[export] Instance EqDec_address: EqDec address.
Proof.
 intros [b1 z1] [b2 z2].
 destruct (eq_dec b1 b2).
 destruct (Z.eq_dec z1 z2).
 left; congruence.
 right; congruence.
 right; congruence.
Qed.

#[export] Instance EqDec_Z : EqDec Z := zeq.
#[export] Instance EqDec_int: EqDec int := Int.eq_dec.
#[export] Instance EqDec_float: EqDec float := Float.eq_dec.
#[export] Instance EqDec_float32: EqDec float32 := Float32.eq_dec.
#[export] Instance EqDec_int64: EqDec int64 := Int64.eq_dec.
#[export] Instance EqDec_ptr : EqDec ptrofs := Ptrofs.eq_dec.

#[export] Instance EqDec_val: EqDec val.
Proof.
hnf. decide equality; apply eq_dec.
Defined.

Definition adr_range (base: address) (size: Z) (loc: address) : Prop :=
 match base, loc with
 | (b, ofs) , (b', ofs') => b=b' /\ (ofs <= ofs' < ofs + size)
 end.

Lemma adr_range_dec: forall base n loc, {adr_range base n loc} + {~adr_range base n loc}.
Proof.
unfold adr_range; intros.
destruct base as [b z]; destruct loc as [b' z'].
destruct (eq_block b b').
subst b'.
destruct (zle z z').
destruct (zlt z' (z+n)).
left; auto.
right; intros [? ?]; lia.
right; intros [? ?]; lia.
right; intros [? ?]; lia.
Qed.

(*
Definition size_chunk (chunk: memory_chunk) : Z :=
  match chunk with
  | Mint8signed => 1
  | Mint8unsigned => 1
  | Mint16signed => 2
  | Mint16unsigned => 2
  | Mint32 => 4
  | Mfloat32 => 4
  | Mfloat64 => 8
  | Mfloat64al32 => 4
  end.
*)

Remark size_chunk_pos:
  forall chunk1, size_chunk chunk1 > 0.
Proof.
  destruct chunk1; simpl; lia.
Qed.

Lemma zero_in_chunk: forall ch, 0 <= 0 < size_chunk ch.
Proof.
  intros; generalize (size_chunk_pos ch); lia.
Qed.

#[export] Hint Resolve zero_in_chunk : mem.

Definition range_overlap (base1: address) (sz1: Z) (base2: address) (sz2: Z) : Prop :=
  exists loc, adr_range base1 sz1 loc /\ adr_range base2 sz2 loc.

Definition adr_add (loc: address) (ofs: Z) : address := (fst loc, snd loc + ofs).

Definition val2adr (v: val) (l: address) : Prop :=
(*     match v with Vptr b ofs => l = (b, Int.unsigned ofs) | _ => False end.*)
     match v with Vptr b ofs => l = (b, Ptrofs.unsigned ofs) | _ => False end.

Lemma adr_range_non_zero: forall l1 n l2, adr_range l1 n l2 -> n > 0.
Proof.
  intros.
  unfold adr_range in H.
  destruct l1, l2.
  destruct (zlt 0 n); lia.
Qed.

Lemma adr_range_shift_1: forall bl ofs n l, adr_range (bl, ofs + 1) (Z.of_nat n) l -> adr_range (bl, ofs) (Z.of_nat (S n)) l.
Proof.
  intros.
  destruct l.
  unfold adr_range in *.
  rewrite Nat2Z.inj_succ.
  destruct H.
  repeat split; auto; lia.
Qed.

Lemma adr_range_S_split: forall bl ofs n l, adr_range (bl, ofs) (Z.of_nat (S n)) l -> adr_range (bl, ofs + 1) (Z.of_nat n) l \/ l = (bl, ofs).
Proof.
  intros.
  destruct l.
  unfold adr_range in *.
  rewrite Nat2Z.inj_succ in H.
  destruct H.
  subst bl.
  destruct (zlt ofs z); [left | right].
  + split; auto; lia.
  + f_equal; lia.
Qed.


Require Import Kami.AllNotations.

Section Definitions.
  Variable expWidthMinus2 sigWidthMinus2: nat.

  Local Notation expWidthMinus1 := (expWidthMinus2 + 1).
  Local Notation expWidth := (expWidthMinus1 + 1).

  Local Notation sigWidthMinus1 := (sigWidthMinus2 + 1).
  Local Notation sigWidth := (sigWidthMinus1 + 1).

  Definition FN :=
    STRUCT_TYPE {
        "sign" :: Bool;
        "exp" :: Bit expWidth;
        "frac" :: Bit sigWidthMinus1
      }.

  Definition RawFloat :=
    STRUCT_TYPE {
        "isNaN" :: Bool;
        "isInf" :: Bool;
        "isZero" :: Bool;
        "sign" :: Bool;
        "sExp" :: Bit (expWidth + 1);
        "sig" :: Bit sigWidthMinus1
      }.

  Definition RecFN :=
    STRUCT_TYPE {
        "sign" :: Bool;
        "isZeroNaNInf0" :: Bit 1;
        "isZeroNaNInf1" :: Bit 1;
        "isZeroNaNInf2" :: Bit 1;
        "exp" :: Bit expWidthMinus2;
        "fract" :: Bit sigWidthMinus1
      }.

  Definition NF :=
    STRUCT_TYPE {
        "isNaN" :: Bool;
        "isInf" :: Bool;
        "isZero" :: Bool;
        "sign" :: Bool;
        "sExp" :: Bit (expWidth + 1);
        "sig" :: Bit sigWidthMinus1
      }.

  Definition ExceptionFlags :=
    STRUCT_TYPE {
        "invalid" :: Bool;
        "infinite" :: Bool;
        "overflow" :: Bool;
        "underflow" :: Bool;
        "inexact" :: Bool
      }.

  Definition OpOutput :=
    STRUCT_TYPE {
        "out" :: NF;
        "exceptionFlags" :: ExceptionFlags
      }.

  Section Ty.
    Open Scope kami_expr.

    Variable ty: Kind -> Type.

    Section FromFN.
      Variable fn: FN @# ty.

      Definition sign := fn @% "sign".
      Let expIn := fn @% "exp".
      Let fractIn := fn @% "frac".

      Definition infOrNaN := expIn == $$ (wones expWidth).
      Definition isZeroExpIn := expIn == $ 0.
      Definition isZeroFractIn := fractIn == $ 0.

      Definition isNaN := infOrNaN && ! isZeroFractIn.

      Definition normDist :=
        IF fractIn == $0
      then $sigWidthMinus2
      else countLeadingZeros (expWidth + 1) fractIn.

      Definition subnormFract := fractIn << (normDist + $ 1).

      Definition normalizedExp: Bit (expWidth + 1) @# ty :=
        (IF isZeroExpIn
         then $ 2 - $ (2 ^ expWidthMinus1) - (normDist + $ 1)
         else ZeroExtend 1 expIn - $ (2 ^ expWidthMinus1 - 1)).

      Definition normalizedFrac: Bit sigWidthMinus1 @# ty := IF isZeroExpIn then subnormFract else fractIn.
      Definition isZero := isZeroExpIn && isZeroFractIn.

      Definition getNF_from_FN: NF @# ty :=
        STRUCT {
            "isNaN" ::= isNaN;
            "isInf" ::= infOrNaN && isZeroFractIn;
            "isZero" ::= isZero;
            "sign" ::= sign;
            "sExp" ::= normalizedExp;
            "sig" ::= normalizedFrac
          }.

      Definition fracMsb := UniBit (TruncMsb _ 1) fractIn.
      Definition isSNaN := isNaN && fracMsb == $$ WO~0.

      Definition adjustedExp: Bit (expWidth + 1) @# ty :=
        (IF isZeroExpIn
         then ~ normDist
         else ZeroExtend 1 expIn) + ZeroExtend 1 ({<$$ WO~1, IF isZeroExpIn then $ 2 else $ 1 >}).

      Definition isSpecialMsb := UniBit (TruncMsb expWidth 1) adjustedExp == $ 1.
      Definition isSpecialLsb := ConstExtract expWidthMinus1 1 1 adjustedExp == $ 1.
      Definition isSpecial := isSpecialMsb && isSpecialLsb.

      Definition getRawFloat_from_FN: RawFloat @# ty :=
        STRUCT {
            "isNaN" ::= isSpecial && !isZeroFractIn;
            "isInf" ::= isSpecial && isZeroFractIn;
            "isZero" ::= isZero;
            "sign" ::= sign;
            "sExp" ::= adjustedExp;
            "sig" ::= IF isZeroExpIn then subnormFract else fractIn
          }.

    End FromFN.

    Section getRecFN_from_RawFloat.
      Variable rawFloat: RawFloat @# ty.
      Let sExp := rawFloat @% "sExp".

      Definition sExp_expWidth := UniBit (TruncMsb _ 1) sExp.
      Definition sExp_expWidthMinus1 := UniBit (TruncMsb _ 1)
                                               (UniBit (TruncLsb _ 1) sExp).
      Definition sExp_expWidthMinus2 := UniBit (TruncMsb _ 1)
                                               (UniBit (TruncLsb _ 1)
                                                       (UniBit (TruncLsb _ 1) sExp)).

      Definition getRecFN_from_RawFloat: RecFN @# ty :=
        STRUCT {
            "sign" ::= rawFloat @% "sign";
            "isZeroNaNInf0" ::= (IF rawFloat @% "isZero" then $$ WO~0 else
                                   sExp_expWidth);
            "isZeroNaNInf1" ::= (IF rawFloat @% "isZero" then $$ WO~0 else
                                   sExp_expWidthMinus1);
            "isZeroNaNInf2" ::= ((IF rawFloat @% "isZero" then $$ WO~0 else
                                    sExp_expWidthMinus2) .| (IF rawFloat @% "isNaN" then
                                                              $$ WO~1 else $$ WO~0));
            "exp" ::= UniBit (TruncLsb _ 1)
                             (UniBit (TruncLsb _ 1)
                                     (UniBit (TruncLsb _ 1) sExp));
            "fract" ::= rawFloat @% "sig"
          }.

    End getRecFN_from_RawFloat.

    Section getRawFloat_from_RecFN.
      Variable recFN: RecFN @# ty.

      Let exp := recFN @% "exp".

      Definition isZeroNaNInf0 := recFN @% "isZeroNaNInf0".
      Definition isZeroNaNInf1 := recFN @% "isZeroNaNInf1".
      Definition isZeroNaNInf2 := recFN @% "isZeroNaNInf2".

      Definition isZeroRecFN := isZeroNaNInf0 == $0 && isZeroNaNInf1 == $0 && isZeroNaNInf2 == $0.
      Definition isNaN_or_Inf := isZeroNaNInf0 == $1 && isZeroNaNInf1 == $1.

      Definition get_exp_from_RecFN: Bit (expWidth + 1) @# ty :=
        {< isZeroNaNInf0, isZeroNaNInf1, isZeroNaNInf2, exp >}.

      Definition getRawFloat_from_RecFN: RawFloat @# ty :=
        STRUCT {
            "isNaN" ::= isNaN_or_Inf && isZeroNaNInf2 == $ 1;
            "isInf" ::= isNaN_or_Inf && isZeroNaNInf2 == $ 0;
            "isZero" ::= isZeroRecFN;
            "sign" ::= recFN @% "sign";
            "sExp" ::= get_exp_from_RecFN;
            "sig" ::= recFN @% "fract"
            }.

    End getRawFloat_from_RecFN.

    Section getFN_from_NF.
      Variable nf: NF @# ty.

      Let exp := nf @% "sExp".
      Let frac := nf @% "sig".
      Let isZeroNF := nf @% "isZero".
      Let isNaNNF := nf @% "isNaN".
      Let isInfNF := nf @% "isInf".

      Definition isSubnormalExp := exp <s ($ 2 - $(2 ^ expWidthMinus1)).
      Definition subnormDist := $1 - $(2 ^ expWidthMinus1) - exp.
      Definition truncFrac : Expr ty (SyntaxKind (Bit (sigWidthMinus2))).
        refine (UniBit (TruncMsb 1 sigWidthMinus2)
                       (castBits _ frac)).
        rewrite Nat.add_comm; reflexivity.
      Defined.
      Definition subnormFrac := {< $$(WO~1), truncFrac >} >> subnormDist.

      Definition nonSpecializedFrac := IF isSubnormalExp then subnormFrac else frac.
      Definition nonSpecializedExp: Bit expWidth @# ty :=
        IF isSubnormalExp
      then $0
      else UniBit (TruncLsb _ 1) (exp + $(2 ^ expWidthMinus1 - 1)).

      Definition specializedExp :=
        (IF isZeroNF
         then $0
         else IF (isNaNNF || isInfNF)
         then $$(wones expWidth)
         else nonSpecializedExp).

      Definition specializedFrac :=
        (IF (isZeroNF || isInfNF)
         then $0
         else (IF isNaNNF
               then (IF frac == $0
                     then {< $$ WO~1, $ 0 >}
                     else frac) (* {< $$ WO~1, $ 0 >} *)
               else nonSpecializedFrac)).

      Definition getFN_from_NF: FN @# ty :=
        STRUCT {
            "sign" ::= nf @% "sign" (* && !(nf @% "isNaN") *);
            "exp" ::= specializedExp;
            "frac" ::= specializedFrac
          }.

    End getFN_from_NF.

    Section getRawFloat_from_NF.
      Variable nf: NF @# ty.

      Definition getRawFloat_from_NF: RawFloat @# ty :=
        STRUCT {
            "isNaN" ::= (nf @% "isNaN");
            "isInf" ::= (nf @% "isInf");
            "isZero" ::= (nf @% "isZero");
            "sign" ::= (nf @% "sign");
            "sExp" ::= (nf @% "sExp" - $(2 ^ expWidth));
            "sig" ::= (nf @% "sig")
          }.

    End getRawFloat_from_NF.

    Section getNF_from_RawFloat.
      Variable rf: RawFloat @# ty.

      Definition getNF_from_RawFloat: NF @# ty :=
        STRUCT {
            "isNaN" ::= (rf @% "isNaN");
            "isInf" ::= (rf @% "isInf");
            "isZero" ::= (rf @% "isZero");
            "sign" ::= (rf @% "sign");
            "sExp" ::= (rf @% "sExp" + $(2 ^ expWidth));
            "sig" ::= (rf @% "sig")
          }.

    End getNF_from_RawFloat.

    Definition getRecFN_from_FN fn := getRecFN_from_RawFloat (getRawFloat_from_FN fn).
    Definition getFN_from_RawFloat rf := getFN_from_NF (getNF_from_RawFloat rf).

    Definition getNF_from_RecFN rfn := getNF_from_RawFloat (getRawFloat_from_RecFN rfn).

    Definition getFN_from_RecFN rfn := getFN_from_NF (getNF_from_RecFN rfn).

    Definition getRecFN_from_NF nf := getRecFN_from_FN (getFN_from_NF nf).

 End Ty.

End Definitions.

Notation round_near_even   := (natToWord 3 0).
Notation round_minMag      := (natToWord 3 1).
Notation round_min         := (natToWord 3 2).
Notation round_max         := (natToWord 3 3).
Notation round_near_maxMag := (natToWord 3 4).
Notation round_odd         := (natToWord 3 6).


Require Import Coq.Strings.String.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Ascii.
Require Import Omega.
From Equations Require Import Equations.

Set Implicit Arguments.

From PlutusCert Require Import
  Language.PlutusIR
  Analysis.BoundVars
  Util
.

(* Parametrized for _named_ binders (not de Bruijn) *)
Section FreeVars.
  Context
    {var tyvar : Set}
    (var_eqb : var -> var -> bool)
    .

Notation term'    := (term var tyvar var tyvar).
Notation binding' := (binding var tyvar var tyvar).

Section fvbs.

Definition delete_all : var -> list var -> list var :=
  fun x xs => filter (fun y => negb (var_eqb x y)) xs.

Fixpoint delete (x : var) (xs : list var) : list var :=
  match xs with
    | nil => nil
    | cons y ys => if var_eqb x y then ys else y :: delete x ys
  end.

Definition elem x xs := existsb (var_eqb x) xs.

Definition delete_all_many : list var -> list var -> list var :=
  fun ds xs => filter (fun x => negb (elem x ds)) xs.
(*
  Workaround for: Cannot guess decreasing argument of fix (in free_vars/free_vars_binding)
*)
Context (free_vars_binding : Recursivity -> binding' -> list var).

Fixpoint free_vars_bindings  rec (bs : list binding') : list var :=
  match rec with
    | Rec    =>
        delete_all_many (bound_vars_bindings bs) (concat (map (free_vars_binding Rec) bs))
    | NonRec =>
        match bs with
          | nil     => []
          | b :: bs => free_vars_binding NonRec b
                       ++ delete_all_many (bound_vars_binding b) (free_vars_bindings NonRec bs)
        end
  end.
End fvbs.

Fixpoint free_vars (t : term var tyvar var tyvar) : list var :=
 match t with
   | Let rec bs t => free_vars_bindings free_vars_binding rec bs ++ delete_all_many (bound_vars_bindings bs) (free_vars t)
   | (LamAbs n ty t)   => delete_all n (free_vars t)
   | (Var n)           => [n]
   | (TyAbs n k t)     => free_vars t
   | (Apply s t)       => free_vars s ++ free_vars t
   | (TyInst t ty)     => free_vars t
   | (IWrap ty1 ty2 t) => free_vars t
   | (Unwrap t)        => free_vars t
   | (Error ty)        => []
   | (Constant v)      => []
   | (Builtin f)       => []
   end

with free_vars_binding rec (b : binding') : list var :=
  match b with
    | TermBind _ (VarDecl v _) t => match rec with
      | Rec    => delete_all v (free_vars t)
      | NonRec => free_vars t
      end
    | _        => []
  end
  .

End FreeVars.


Require Import Extensionality.

(** Implementation of the List monad transformer in Coq. *)

Set Implicit Arguments.

(** We use Mersenne induction to ensure that even if T may not be positive, that
    does not impede the writing of such a type. *)

Inductive listT (T : Type -> Type) A :=
| NodeT : forall S, (S -> nodeT T A) -> T S -> listT T A

with nodeT (T : Type -> Type) A :=
| Nil : nodeT T A
| Cons : A -> listT T A -> nodeT T A.

Arguments Nil [_ _].

Fixpoint map {T A B} (f : A -> B) (l : listT T A) : listT T B
with map_node {T A B} (f : A -> B) (n : nodeT T A) : nodeT T B.
Proof.
+ destruct l as [S k n]; exists S.
  - intros s.
    apply (map_node T A B f (k s)).
  - exact n.
+ destruct n as [|x l].
  - apply Nil.
  - apply Cons; [exact (f x)|].
    apply (map _ _ _ f l).
Defined.

(* Fixpoint map {R T A B} (f : A -> B) (l : listT R T A) : listT R T B
with map_node {R T A B} (f : A -> B) (n : nodeT R T A) : nodeT R T B.
Proof.
+ destruct l as [S k n]; exists S.
  - intros s; destruct (k s) as [r|N].
    { left; exact r. }
    { right; apply (map_node _ _ A B f N). }
  - exact n.
+ destruct n as [|x l].
  - apply Nil.
  - apply Cons; [exact (f x)|].
    apply (map _ _ _ _ f l).
Defined.*)

Section Ops.

Context (T : Type -> Type).
Variable lift : forall {A}, A -> T A.
Variable bind : forall {A B}, (A -> T B) -> (T A -> T B).

Fixpoint fold_right {A B} (f : B -> A -> T A) (accu : T A) (l : listT T B) : T A
with fold_right_node {A B} (f : B -> A -> T A) (accu : T A) (n : nodeT T B) : T A.
Proof.
+ destruct l as [S k s].
  apply (@bind S); [clear s|exact s].
  intros s; apply (fold_right_node _ _ f accu (k s)).
+ destruct n as [|x l].
  - exact accu.
  - pose (ans := fold_right _ _ f accu l).
    refine (bind _ ans); clear ans accu; intros accu.
    apply (f x accu).
Defined.

(* Definition collapse {A} (m : T (listT T A)) : listT T A.
Proof.
exists (T unit).
exists (nodeT T A); [intros n; exact n|].
refine (bind _ m).
intros [S k s].
refine (bind _ s); clear s; intros s.
apply lift, (k s).
Defined. *)

Fixpoint app {A} (l1 l2 : listT T A) {struct l1} : listT T A
with app_node {A} (n1 : nodeT T A) (l2 : listT T A) {struct n1} : listT T A.
Proof.
+ destruct l1 as [S k s].

  apply app_node.
  apply (app_node _ (k s) l2).
+ destruct n1 as [|x l1].

(* Fixpoint fold_right {A B} (f : B -> A -> T A) (accu : T A) (l : listT R T B) : T (R + A)
with fold_right_node {A B} (f : B -> A -> T A) (accu : T A) (n : nodeT R T B) : T (R + A).
Proof.
+ destruct l as [S k s].
  apply (@bind S); [clear s|exact s].
  intros s; destruct (k s) as [r|n].
  - apply lift; exact (inl r).
  - apply (fold_right_node _ _ f accu n).
+ destruct n as [|x l].
  - exact (bind (fun x => lift (inr x)) accu).
  - pose (ans := fold_right _ _ f accu l).
    refine (bind _ ans); clear ans accu; intros [r|accu].
    { apply lift, inl, r. }
    { refine (bind _ (f x accu)); intros ans; apply lift, inr, ans. }
Defined.*)

(*Definition collapse {A} (m : T (listT T A)) : listT T A.
Proof.
exists (PnodeT False T A); [exact inr|].
refine (bind _ m).
intros [S k s].
refine (bind _ s); clear s; intros s.
destruct (k s) as [[]|n]; apply lift, n.
Defined. *)

Definition nil {A} : (listT T A) := NodeT (fun _ => inr Nil) (lift tt).
Definition cons {A} (x : A) (l : listT T A) := NodeT (fun _ => inr (Cons x l)) (lift tt).

Lemma toto : forall A B (f : A -> B) l,
  lift (map f l) ≅ fold_right (fun x accu => lift (cons (f x) accu)) (lift nil) l.
Proof.
intros A B f [S k s] Hext; simpl.

End Ops.


(* Boolean maps *)

Lemma bools_errand:
  forall (f: bool -> bool) (b: bool), f (f (f b)) = f b.
Proof.

Qed.

Fixpoint iterate (n: nat) (f: bool -> bool) (x: bool): bool :=
  match n with
    | O => x
    | S p => f (iterate p f x)
  end.

Definition twice := iterate 2.

Lemma bools_iterated:
  forall (f: bool -> bool) (b: bool) (n: nat), iterate n (twice f) (f b) = f b.
Proof.

Qed.