From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Morphisms.
Require Export Category.Theory.Isomorphism.
Require Export Category.Theory.Functor.
Require Export Category.Functor.Bifunctor.
Require Export Category.Structure.Monoidal.
Require Export Category.Structure.Monoidal.Proofs.
Require Export Category.Structure.Monoidal.Semicartesian.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section SemicartesianProofs.

Context `{@Monoidal C}.
Context `{@SemicartesianMonoidal C _}.

Lemma proj_left_tensor_id {x y z} :
proj_left ⨂ id ≈ id[x] ⨂ @proj_right _ _ _ y z ∘ tensor_assoc.
Proof. hammer_hook "Proofs" "Proofs.proj_left_tensor_id".
unfold proj_left, proj_right.
rewrite bimap_comp_id_right.
rewrite triangle_identity.
rewrite <- comp_assoc.
rewrite <- to_tensor_assoc_natural.
normal; reflexivity.
Qed.

Lemma proj_right_tensor_id {x y z} :
id ⨂ proj_right ≈ @proj_left _ _ _ x y ⨂ id[z] ∘ tensor_assoc⁻¹.
Proof. hammer_hook "Proofs" "Proofs.proj_right_tensor_id".
unfold proj_left, proj_right.
rewrite bimap_comp_id_left.
rewrite inverse_triangle_identity.
rewrite <- comp_assoc.
rewrite <- from_tensor_assoc_natural.
normal; reflexivity.
Qed.

Lemma proj_left_left {x y z} :
proj_left ∘ proj_left ≈ @proj_left _ _ _ x (y ⨂ z) ∘ tensor_assoc.
Proof. hammer_hook "Proofs" "Proofs.proj_left_left".
unfold proj_left; normal.
rewrite <- !comp_assoc.
rewrite (comp_assoc _ unit_right).
rewrite to_unit_right_natural; normal.
rewrite <- !comp_assoc.
apply compose_respects; [reflexivity|].
rewrite bimap_triangle_right.
rewrite <- comp_assoc.
rewrite <- to_tensor_assoc_natural.
rewrite comp_assoc.
apply compose_respects; [|reflexivity].
normal.
apply bimap_respects; [reflexivity|].
apply unit_terminal.
Qed.

Lemma proj_right_right {x y z} :
proj_right ∘ proj_right ≈ @proj_right _ _ _ (x ⨂ y) z ∘ tensor_assoc⁻¹.
Proof. hammer_hook "Proofs" "Proofs.proj_right_right".
unfold proj_right; normal.
rewrite <- !comp_assoc.
rewrite (comp_assoc _ unit_left).
rewrite to_unit_left_natural; normal.
rewrite <- !comp_assoc.
apply compose_respects; [reflexivity|].
rewrite bimap_triangle_left.
rewrite <- comp_assoc.
rewrite <- from_tensor_assoc_natural.
rewrite comp_assoc.
apply compose_respects; [|reflexivity].
normal.
apply bimap_respects; [|reflexivity].
apply unit_terminal.
Qed.

Corollary proj_left_natural {x y z w} (f : x ~> y) (g : z ~> w) :
proj_left ∘ f ⨂ g ≈ f ∘ proj_left.
Proof. hammer_hook "Proofs" "Proofs.proj_left_natural".
unfold proj_left.
rewrite comp_assoc.
rewrite to_unit_right_natural.
normal.
rewrite eliminate_comp.
reflexivity.
Qed.

Corollary proj_right_natural {x y z w} (f : x ~> y) (g : z ~> w) :
proj_right ∘ f ⨂ g ≈ g ∘ proj_right.
Proof. hammer_hook "Proofs" "Proofs.proj_right_natural".
unfold proj_right.
rewrite comp_assoc.
rewrite to_unit_left_natural.
normal.
rewrite eliminate_comp.
reflexivity.
Qed.

End SemicartesianProofs.


Require Import Omega.
Require Import Bool.
Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.
From PromisingLib Require Import Loc.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Cover.
Require Import Pred.
Require Import Trace.

Require Import MemoryProps.
Require Import Mapping.

Set Implicit Arguments.

Section GOODFUTURE.

  Record good_future (tm: TimeMap.t) (mem0 mem1: Memory.t): Prop :=
    {
      good_future_future: Memory.future_weak mem0 mem1;
      good_future_cover:
        forall loc ts (COVERED: covered loc ts mem1),
          (<<COVERED: covered loc ts mem0>>) \/
          (<<TS: Time.lt (tm loc) ts>>);
    }.

  Lemma good_future_mon tm0 tm1
        (TM: TimeMap.le tm0 tm1)
    :
      good_future tm1 <2= good_future tm0.
  Proof.
    ii. econs.
    { eapply PR. }
    { i. eapply PR in COVERED. des; auto.
      right. eapply TimeFacts.le_lt_lt; eauto.
    }
  Qed.

  Global Program Instance good_future_PreOrder tm: PreOrder (good_future tm).
  Next Obligation.
    ii. econs; eauto. refl.
  Qed.
  Next Obligation.
    ii. econs.
    { etrans.
      { eapply H. }
      { eapply H0. }
    }
    { i. eapply H0 in COVERED. des; auto.
      eapply H in COVERED0. auto. }
  Qed.

  Record good_future_map (max tm: TimeMap.t)
         (times: Loc.t -> list Time.t)
         (f: Loc.t -> Time.t -> Time.t -> Prop): Prop :=
    {
      good_future_map_map_lt:
        mapping_map_lt f;
      good_future_map_map_bot:
        mapping_map_bot f;
      good_future_map_ident:
        forall loc ts (TS: Time.le ts (max loc)),
          f loc ts ts;
      good_future_map_bound:
        forall loc ts fts
               (MAP: f loc ts fts),
          Time.lt fts (tm loc);
      good_future_map_complete:
        forall loc ts (IN: List.In ts (times loc)),
          mappable_time f loc ts;
    }.

  Lemma good_future_map_exists max tm times
        (TM: forall loc, Time.lt (max loc) (tm loc))
    :
      exists f,
        (<<MAP: good_future_map max tm times f>>).
  Proof.
    hexploit (@choice
                Loc.t (Time.t -> Time.t -> Prop)
                (fun loc f =>
                   (<<MAPLT: mapping_map_lt_loc f>>) /\
                   (<<IDENT: forall ts (TS: Time.le ts (max loc)),
                       f ts ts>>) /\
                   (<<MAX: forall ts fts
                                  (MAP: f ts fts),
                       Time.lt fts (tm loc)>>) /\
                   (<<COMPLETE: forall ts (IN: List.In ts (times loc)),
                       exists fts, (<<MAP: f ts fts>>)>>))).
    { intros loc.
      hexploit (@shift_map_exists
                  (max loc) (max loc) (tm loc)
                  (times loc)); ss.
      { refl. } intros [f SPEC]. exists f. des. splits; auto.
      { i. destruct (Time.le_lt_dec ts (max loc)).
        { exploit mapping_map_lt_loc_map_eq.
          { eapply MAPLT. }
          { eapply MAP. }
          { eapply SAME; eauto. }
          i. subst. eapply TimeFacts.le_lt_lt; eauto.
        }
        { eapply BOUND in MAP; auto. des. auto. }
      }
    }
    intros [f SPEC]. exists f. econs.
    { eapply mapping_map_lt_locwise.
      i. specialize (SPEC loc). des. auto. }
    { ii. specialize (SPEC loc). des.
      eapply IDENT. eapply Time.bot_spec. }
    { i. specialize (SPEC loc). des. auto. }
    { i. specialize (SPEC loc). des. eauto. }
    { i. specialize (SPEC loc). des.
      exploit COMPLETE; eauto. }
  Qed.

  Lemma good_future_memory_map mem0 mem1 tm times f
        (FUTURE: good_future tm mem0 mem1)
        (MEM: Memory.closed mem0)
        (TM: forall loc, Time.lt (Memory.max_ts loc mem0) (tm loc))
        (MAP: good_future_map (Memory.max_timemap mem0) tm times f)
    :
      memory_map f mem0 mem1.
  Proof.
    econs.
    { i. destruct msg as [val released|]; auto. right.
      exploit Memory.future_weak_get1.
      { eapply FUTURE. }
      { eapply GET. }
      i. des.
      exists to, from', (Message.concrete val released), msg'. splits; auto.
      { eapply good_future_map_ident; eauto.
        eapply Memory.max_ts_spec in GET. des. eauto. }
      { eapply map_ident_in_memory_closed_message.
        { ii. eapply (good_future_map_ident MAP). eapply TS. }
        { eapply MEM in GET. des. auto. }
      }
    }
    { i. destruct (Time.le_lt_dec fto (Memory.max_ts loc mem0)).
      { left. exists fto, ffrom, fto, ffrom. splits; auto.
        { eapply (good_future_map_ident MAP); eauto. }
        { refl. }
        { refl. }
        { eapply (good_future_map_ident MAP); eauto.
          eapply memory_get_ts_le in GET. etrans; eauto.
        }
        { i. exploit (good_future_cover FUTURE).
          { econs; eauto. }
          i. des; auto.
          exfalso. inv ITV. ss.
          eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt.
          { eapply TS. } etrans.
          { eapply TO. } etrans.
          { eapply l. }
          { left. auto. }
        }
      }
      { right. destruct (Time.le_lt_dec (tm loc) ffrom).
        { ii. eapply (good_future_map_bound MAP) in MAP0.
          eapply TimeFacts.lt_le_lt; eauto. }
        { exfalso. exploit (good_future_cover FUTURE).
          { econs; try apply GET.
            instantiate (1:=Time.meet (tm loc) fto). econs; ss.
            { unfold Time.meet. des_ifs.
              apply memory_get_ts_strong in GET. des; auto.
              subst. inv l. }
            { eapply Time.meet_r. }
          }
          { i. des.
            { inv COVERED. inv ITV; ss.
              apply Memory.max_ts_spec in GET0. des.
              eapply Time.lt_strorder. eapply TimeFacts.le_lt_lt.
              { eapply TO. } eapply TimeFacts.le_lt_lt.
              { eapply MAX. }
              unfold Time.meet. des_ifs.
            }
            { eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt.
              { eapply TS. }
              { eapply Time.meet_l. }
            }
          }
        }
      }
    }
  Qed.

  Lemma step_write_not_in_good_future P lang (th0 th1: Thread.t lang) tm e
        (TM: forall loc, Time.lt (Memory.max_ts loc (Thread.memory th0)) (tm loc))
        (STEPS: pred_step P e th0 th1)
        (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
        (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
        (CLOSED: Memory.closed (Thread.memory th0))
        (NOTIN: P <1= write_not_in (fun loc ts =>
                                      (<<TS: Time.le ts (tm loc)>>) /\
                                      (<<PROM: ~ covered loc ts (Thread.memory th0)>>)))
    :
      good_future tm (Thread.memory th0) (Thread.memory th1).
  Proof.
    econs; auto.
    { eapply Memory.future_future_weak.
      inv STEPS. inv STEP.
      exploit Thread.step_future; eauto. i. des. auto. }
    { i. inv STEPS. inv STEP.
      eapply step_write_not_in_covered in COVERED; eauto. des; auto.
      apply not_and_or in COVERED. des.
      { right. destruct (Time.le_lt_dec ts (tm loc)); ss. }
      { left. apply NNPP; eauto. }
    }
  Qed.

  Lemma steps_write_not_in_good_future P lang (th0 th1: Thread.t lang) tm
        (TM: forall loc, Time.lt (Memory.max_ts loc (Thread.memory th0)) (tm loc))
        (STEPS: rtc (tau (@pred_step P lang)) th0 th1)
        (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
        (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
        (CLOSED: Memory.closed (Thread.memory th0))
        (NOTIN: P <1= write_not_in (fun loc ts =>
                                      (<<TS: Time.le ts (tm loc)>>) /\
                                      (<<PROM: ~ covered loc ts (Thread.memory th0)>>)))
    :
      good_future tm (Thread.memory th0) (Thread.memory th1).
  Proof.
    econs; auto.
    { eapply Memory.future_future_weak.
      eapply thread_steps_pred_steps in STEPS.
      exploit Thread.rtc_tau_step_future; eauto. i. des. auto. }
    { i. eapply steps_write_not_in_covered in COVERED; eauto. des; auto.
      apply not_and_or in COVERED. des.
      { right. destruct (Time.le_lt_dec ts (tm loc)); ss. }
      { left. apply NNPP; eauto. }
    }
  Qed.

  Lemma write_not_in_good_future_traced lang (th0 th1: Thread.t lang) tr tm
        (TM: forall loc, Time.lt (Memory.max_ts loc (Thread.memory th0)) (tm loc))
        (STEPS: Trace.steps tr th0 th1)
        (LOCAL: Local.wf (Thread.local th0) (Thread.memory th0))
        (SC: Memory.closed_timemap (Thread.sc th0) (Thread.memory th0))
        (CLOSED: Memory.closed (Thread.memory th0))
        (NOTIN: List.Forall (fun em =>
                               write_not_in (fun loc ts =>
                                               (<<TS: Time.le ts (tm loc)>>) /\
                                               (<<PROM: ~ covered loc ts (Thread.memory th0)>>)) (snd em)) tr)
    :
      good_future tm (Thread.memory th0) (Thread.memory th1).
  Proof.
    econs; auto.
    { eapply Memory.future_future_weak.
      eapply Trace.steps_future; eauto. }
    { i. eapply write_not_in_covered_traced in COVERED; eauto. des; auto.
      apply not_and_or in COVERED. des.
      { right. destruct (Time.le_lt_dec ts (tm loc)); ss. }
      { left. apply NNPP; eauto. }
    }
  Qed.

  Lemma max_good_future_map (mem mem_good: Memory.t) (tm: TimeMap.t)
        (FUTURE: good_future tm mem mem_good)
        (CLOSED: Memory.closed mem)
        (TM: forall loc, Time.lt (Memory.max_ts loc mem) (tm loc))
    :
      memory_map
        (fun loc ts fts => ts = fts /\ Time.lt ts (tm loc))
        mem
        mem_good.
  Proof.
    assert (IDENT: map_ident_in_memory (fun loc ts fts => ts = fts /\ Time.lt ts (tm loc)) mem).
    { ii. split; auto. eapply TimeFacts.le_lt_lt; eauto. }
    econs.
    { i. destruct msg as [val released|]; auto.
      exploit Memory.max_ts_spec; try apply GET. i. des. dup GET.
      eapply (good_future_future FUTURE) in GET.
      destruct GET as [from' [released' [GET [FROM RELEASED]]]]. guardH RELEASED.
      right. esplits.
      { ss. }
      { eapply TimeFacts.le_lt_lt; eauto. }
      { eapply map_ident_in_memory_closed_message; eauto.
        eapply CLOSED; eauto. }
      { econs 1. instantiate (1:=released'). unguard. des; auto. subst. refl. }
      { eauto. }
    }
    { i. destruct (Time.le_lt_dec (tm loc) ffrom).
      { right. ii. des. subst. eapply TimeFacts.lt_le_lt; eauto.  }
      { assert (TS: Time.lt fto (tm loc)).
        { destruct (Time.le_lt_dec (tm loc) fto); auto. exfalso.
          exploit (good_future_cover FUTURE).
          { instantiate (1:=Time.middle (Time.join (Memory.max_ts loc mem) ffrom) (tm loc)).
            instantiate (1:=loc).
            econs; eauto. econs; ss.
            { eapply TimeFacts.le_lt_lt.
              { eapply Time.join_r. }
              { eapply Time.middle_spec. unfold Time.join. des_ifs. }
            }
            { transitivity (tm loc); auto. left. eapply Time.middle_spec.
              unfold Time.join. des_ifs. }
          }
          { i. des.
            { inv COVERED. inv ITV. ss.
              eapply Memory.max_ts_spec in GET0. des.
              exfalso. eapply Time.lt_strorder. eapply TimeFacts.le_lt_lt.
              { eapply TO. } eapply TimeFacts.le_lt_lt.
              { eapply MAX. } eapply TimeFacts.le_lt_lt.
              { eapply Time.join_l. }
              { eapply Time.middle_spec. unfold Time.join. des_ifs. }
            }
            { exfalso. eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt.
              { eapply TS. } left.
              { eapply Time.middle_spec. unfold Time.join. des_ifs. }
            }
          }
        }
        left. exists fto, ffrom, fto, ffrom. splits; auto; try refl.
        i. exploit (good_future_cover FUTURE).
        { econs; eauto. }
        i. des; auto. inv ITV. ss.
        exfalso. eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt.
        { eapply TS. } etrans.
        { left. eapply TS0. }
        auto.
      }
    }
  Qed.

End GOODFUTURE.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e511m481_24limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e511m187_22limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


(** an implementation of Wasm memory based on a list *)
(* (C) J. Pichon - see LICENSE.txt *)

From mathcomp Require Import ssreflect ssrbool eqtype seq.
Require Import BinNat Lia.
From Wasm Require Import numerics bytes memory.

Record memory_list : Type := {
  ml_init : byte;
  ml_data : list byte;
}.

Definition mem_make : Memory.mem_make_t memory_list :=
  fun v len => {| ml_init := v; ml_data := List.repeat v (N.to_nat len) |}.

Definition mem_length : Memory.mem_length_t memory_list :=
    fun ml => N.of_nat (List.length ml.(ml_data)).

Definition mem_grow : Memory.mem_grow_t memory_list :=
  fun len_delta ml =>
    {|
      ml_init := ml.(ml_init);
      ml_data := ml.(ml_data) ++ List.repeat ml.(ml_init) (N.to_nat len_delta)
    |}.

Definition mem_lookup : Memory.mem_lookup_t memory_list :=
  fun i ml => List.nth_error ml.(ml_data) (N.to_nat i).

Definition mem_update : Memory.mem_update_t memory_list :=
  fun i v ml =>
    if N.ltb i (N.of_nat (List.length ml.(ml_data)))
    then Some {| ml_init := ml.(ml_init);
                ml_data := take (N.to_nat i) ml.(ml_data) ++ [::v] ++ drop (N.to_nat i+1) ml.(ml_data) |}
    else None.

Lemma memory_list_ax_lookup_out_of_bounds :
  Memory.mem_ax_lookup_out_of_bounds memory_list mem_make mem_length mem_grow mem_lookup mem_update.
Proof.
move => mem i.
rewrite /mem_length /mem_lookup.
move => H.
apply (List.nth_error_None mem.(ml_data) (N.to_nat i)).
apply N.ge_le in H.
move: H.
set x := (length (ml_data mem)).
move => H.
lia.
Qed.

Lemma nth_repeat :
forall A b i len, i < len ->
@List.nth_error A (List.repeat b len) i = Some b.
Proof.
move => A b.
elim => [|i].
{ case => [|len]; first by lia.
  by move => _. }
{ move => IH len.
  case: len => [|len'].
  { move => Hctr.
    exfalso.
    lia. }
  { move => Hlen /=.
    apply: IH.
    lia. } }
Qed.

Lemma lookup_split : forall A (l : list A) i b,
  i < List.length l ->
  List.nth_error (take i l ++ b :: drop (i+1) l) i = Some b.
Proof.
move => A.
elim => [|x l].
{ move => i b /= Hlen.
  exfalso.
  lia. }
{ move => IH.
  case => [|i]; first by reflexivity.
  move => b /= Hlen.
  have Hlen': i < length l by lia.
  by apply: IH. }
Qed.

Lemma bar : forall A n n' (l : list A) v,
  n <> n' -> n' < List.length l ->
  List.nth_error (take n' l ++ v :: drop (n' + 1) l) n =
  List.nth_error l n.
Proof.
(* TODO *)
Admitted.

Lemma split_preserves_length : forall A i b (l : list A),
  i < List.length l ->
  List.length (take i l ++ b :: drop (i + 1) l) = List.length l.
Proof.
Admitted.

Lemma memory_list_ax_lookup_make : Memory.mem_ax_lookup_make memory_list mem_make mem_length mem_grow mem_lookup mem_update.
Proof.
move => i len b mem.
apply: nth_repeat.
lia.
Qed.

Lemma memory_list_ax_lookup_update :
  Memory.mem_ax_lookup_update memory_list mem_make mem_length mem_grow mem_lookup mem_update.
Proof.
move => mem mem' i b H H0.
rewrite /mem_update in H0.
apply N.ltb_lt in H.
rewrite /mem_length in H.
rewrite H in H0.
case: mem' H0 => init_ data_ [Hinit Hdata].
rewrite Hinit Hdata /= {init_ data_ Hinit Hdata}.
set nn := N.to_nat i.
have Hx: nn < length (ml_data mem).
apply N.ltb_lt in H.
lia.
by apply: lookup_split.
Qed.

Lemma memory_list_ax_lookup_skip :
  Memory.mem_ax_lookup_skip memory_list mem_make mem_length mem_grow mem_lookup mem_update.
Proof.
move => mem mem' i i' b Hii' H0.
case: mem' H0 => init_ data_.
rewrite /mem_update /mem_lookup.
case_eq (N.ltb i' (N.of_nat (length (ml_data mem)))); last by discriminate.
move => Hlen [Hinit Hdata] /=.
rewrite Hdata => {Hdata}.
apply: bar.
lia.
apply N.ltb_lt in Hlen.
lia.
Qed.

Lemma memory_list_ax_length_constant_update :
  Memory.mem_ax_length_constant_update memory_list mem_make mem_length mem_grow mem_lookup mem_update.
Proof.
move => i b [dv_init1 dv_list1] [dv_init2 dv_list2].
rewrite /mem_update /mem_length /=.
case_eq (N.ltb i (N.of_nat (length dv_list1))); last by discriminate.
move => Hlen [Hinit Hlist].
apply N.ltb_lt in Hlen.
rewrite Hlist.
f_equal.
apply: (split_preserves_length _ (N.to_nat i) b dv_list1).
lia.
Qed.

Require Import bytes common.

Definition memory_list_eq_dec : forall (i1 i2 : memory_list), {i1 = i2} + {i1 <> i2}.
Proof. decidable_equality. Defined.

Definition memory_list_eqb i1 i2 : bool := memory_list_eq_dec i1 i2.

Definition eqmemory_listP : Equality.axiom memory_list_eqb :=
  eq_dec_Equality_axiom memory_list_eq_dec.

Canonical Structure memory_list_eqMixin := EqMixin eqmemory_listP.
Canonical Structure memory_list_eqType := Eval hnf in EqType memory_list memory_list_eqMixin.

Definition list_memoryMixin :=
  Memory.Mixin
    memory_list_ax_lookup_out_of_bounds
    memory_list_ax_lookup_make
    memory_list_ax_lookup_update
    memory_list_ax_lookup_skip
    memory_list_ax_length_constant_update.
Definition list_memoryClass := Memory.Class memory_list_eqMixin list_memoryMixin.
Canonical list_memoryType := @Memory.Pack memory_list list_memoryClass.


(** Congruence closure *)
Require Import Arith.
Require Import Omega.
Require Import String.
Require Import List.
Require Import OrderedType.
Require Import FSetAVL.
Require Import Cybele.Cybele.
Require Import Cybele.Map.
Require Import Cybele.DataStructures.
Require Import Definitions.

Set Implicit Arguments.
Set Transparent Obligation.
Import Monad ListNotations.

(** Example with only constants *)
Module ExampleNoFun.
  Require Import Algo.

  Module P <: Parameters.
    Definition T := nat.
    Definition Values :=
      let values := [3; 5; 5; 6; 3; 0; 5] in
      List.map (fun n => Value.Make 0 (fun _ => n)) values.
  End P.
  Module CC := CongruenceClosure P.
  Import CC.

  Definition IndexOfNat (i: nat): Index.t :=
    Index.Make i nil.

  Coercion IndexOfNat: nat >-> Index.t.

  Definition eq_proofs: list T.
    refine (
      EqProof.Make (i := 0) (j := 4) _ ::
      EqProof.Make (i := 1) (j := 2) _ ::
      EqProof.Make (i := 2) (j := 1) _ ::
      EqProof.Make (i := 2) (j := 6) _ ::
      nil);
    now unfold Values.AreEqual.
  Defined.

  Lemma Eq1: Values.AreEqual P.Values 0 4.
    now apply (proof_by_reflection (ProveEqual eq_proofs 0 4)
      (Prophecy.of_nat Sig 100)).
  Defined.

  Lemma Eq2: Values.AreEqual P.Values 1 6.
    now apply (proof_by_reflection (ProveEqual eq_proofs 1 6)
      (Prophecy.of_nat Sig 100)).
  Defined.
End ExampleNoFun.

(** Small example relying on congruence *)
Module ExampleCongruence.
  Require Import Algo.

  Module P <: Parameters.
    Definition T := nat.

    Definition Values: list (Value.t T) :=
      Value.Make 0 (fun _ => 3) ::
      Value.Make 1 (fun v =>
        match v with
        | x :: nil => 6 - x
        | _ => 0
        end) ::
      nil.
  End P.

  Module CC := CongruenceClosure P.
  Import CC.

  Definition a := Index.Make 0 nil.
  Definition fa := Index.Make 1 (a :: nil).
  Definition ffa := Index.Make 1 (fa :: nil).

  Fixpoint fn n :=
    match n with
      | O => a
      | S k => Index.Make 1 (fn k :: nil)
    end.

  Definition fbig : Index.t.
  let f := eval compute in (fn 50) in exact f.
  Defined.

  Definition eq_proofs: list T.
    refine (
      EqProof.Make (i := a) (j := fa) _ ::
      nil); now unfold Values.AreEqual.
  Defined.

  Definition eval (x y: Index.t) (nb_steps: nat) :=
    if fst (ProveEqual eq_proofs x y
      (State.of_prophecy (Prophecy.of_nat Sig nb_steps)))
    then true else false.

  Time Compute eval a a 1.
  Time Compute eval fa a 100.
  Time Compute eval fa ffa 100.
  Time Compute eval a fa 100.
  Time Compute eval fa fbig 100.

  Definition Equal (i j: Index.t) :=
    proof_by_reflection (ProveEqual eq_proofs i j) (Prophecy.of_nat Sig 100).

  Check Equal a a eq_refl.
  Check Equal a fa eq_refl.
  Check Equal a ffa eq_refl.
End ExampleCongruence.

(** Example from the Pierre Corbineau's master thesis *)
Module ExampleBig.
  Module P <: Parameters.
    Definition T := nat.

    Definition Values: list (Value.t T) :=
      Value.Make 0 (fun _ => 3) ::
      Value.Make 0 (fun _ => 1) ::
      Value.Make 1 (fun v =>
        match v with
        | x :: nil => 6 - x
        | _ => 0
        end) ::
      Value.Make 2 (fun v =>
        match v with
        | x :: y :: nil => x + y - 1
        | _ => 0
        end) ::
      nil.
  End P.

  Definition a := Index.Make 0 nil.
  Definition b := Index.Make 1 nil.
  Definition fa := Index.Make 2 (a :: nil).
  Definition gab := Index.Make 3 (a :: b :: nil).
  Definition fgba := Index.Make 2 (Index.Make 3 (b :: a :: nil) :: nil).
  Definition gbfa := Index.Make 3 (b :: fa :: nil).
  Definition ffa := Index.Make 2 (fa :: nil).

  Fixpoint f_n_a (n: nat) :=
    match n with
    | O => a
    | S n' => Index.Make 2 [f_n_a n']
    end.

  Check eq_refl: Values.NthIndex P.Values a = Some 3.
  Check eq_refl: Values.NthIndex P.Values fa = Some 3.
  Check eq_refl: Values.NthIndex P.Values ffa = Some 3.
  Check eq_refl: Values.NthIndex P.Values fgba = Some 3.

  Module GenerateProofs.
    Require Import Algo.
    Module CC := CongruenceClosure P.
    Import CC.

    Definition eq_proofs: list T.
      refine (
        EqProof.Make (i := a) (j := fa) _ ::
        EqProof.Make (i := gab) (j := fgba) _ ::
        EqProof.Make (i := gbfa) (j := ffa) _ ::
        EqProof.Make (i := gab) (j := a) _ ::
        nil); now unfold Values.AreEqual.
    Defined.

    Definition compute (i j: Index.t): bool :=
      is_computable (ProveEqual eq_proofs i j) (Prophecy.of_nat Sig 100).

    Time Compute compute a fa.
    Time Compute compute gab a.
    Time Compute compute (f_n_a 200) a.

    Definition equal (i j: Index.t) :=
      proof_by_reflection (ProveEqual eq_proofs i j) (Prophecy.of_nat Sig 100).

    Time Check equal a a eq_refl.
    Time Check equal a fa eq_refl.
    Time Check equal a ffa eq_refl.
    Time Fail Check equal a b eq_refl.
    Time Check equal gab a eq_refl.

    Lemma Eq1: Values.AreEqual P.Values a ffa.
      apply (proof_by_reflection (ProveEqual eq_proofs a ffa)
        (Prophecy.of_nat Sig 100)).
      now vm_compute.
    Defined.

    Lemma Eq2: Values.AreEqual P.Values gab a.
      apply (proof_by_reflection (ProveEqual eq_proofs gab a)
        (Prophecy.of_nat Sig 100)).
      now vm_compute.
    Defined.
  End GenerateProofs.

  Module JustDecide.
    Require Import AlgoBool.
    Module CC := CongruenceClosureBool P.
    Import CC.

    Definition eq_proofs: list T.
      refine (
        EqProof.Make (i := a) (j := fa) _ ::
        EqProof.Make (i := gab) (j := fgba) _ ::
        EqProof.Make (i := gbfa) (j := ffa) _ ::
        EqProof.Make (i := gab) (j := a) _ ::
        nil); now unfold Values.AreEqual.
    Defined.

    Definition compute (i j: Index.t): bool :=
      is_computable (ProveEqual eq_proofs i j) (Prophecy.of_nat Sig 100).

    Time Compute compute a fa.
    Time Compute compute gab a.
    Time Compute compute (f_n_a 200) a.

    Definition equal (i j: Index.t) :=
      proof_by_reflection (ProveEqual eq_proofs i j) (Prophecy.of_nat Sig 100).

    Time Check equal a a eq_refl.
    Time Check equal a fa eq_refl.
    Time Check equal a ffa eq_refl.
    Time Fail Check equal a b eq_refl.
    Time Check equal gab a eq_refl.
  End JustDecide.
End ExampleBig.


(* Distributed under the terms of the MIT license. *)
From MetaCoq.Template Require Import utils.
From MetaCoq.PCUIC Require Import PCUICAst PCUICLiftSubst PCUICTyping.

Require Import Equations.Prop.DepElim.
From Equations Require Import Equations.

Section Generation.
  Context `{cf : config.checker_flags}.

  Inductive typing_spine (Σ : global_env_ext) (Γ : context) :
    term -> list term -> term -> Type :=
  | type_spine_nil ty ty' :
      isType Σ Γ ty' ->
      Σ ;;; Γ |- ty <=s ty' ->
      typing_spine Σ Γ ty [] ty'

  | type_spine_cons hd tl na A B T B' :
      isType Σ Γ (tProd na A B) ->
      Σ ;;; Γ |- T <=s tProd na A B ->
      Σ ;;; Γ |- hd : A ->
      typing_spine Σ Γ (subst10 hd B) tl B' ->
      typing_spine Σ Γ T (hd :: tl) B'.

  Lemma type_mkApps Σ Γ t u T t_ty :
    Σ ;;; Γ |- t : t_ty ->
    typing_spine Σ Γ t_ty u T ->
    Σ ;;; Γ |- mkApps t u : T.
  Proof using Type.
    intros Ht Hsp.
    revert t Ht. induction Hsp; simpl; auto.
    intros t Ht. eapply type_Cumul; eauto. eapply i.π2.

    intros.
    specialize (IHHsp (tApp t0 hd)). apply IHHsp.
    destruct i as [s Hs].
    eapply type_App; eauto.
    eapply type_Cumul; eauto.
  Qed.

  Lemma type_it_mkLambda_or_LetIn :
    forall Σ Γ Δ t A,
      Σ ;;; Γ ,,, Δ |- t : A ->
      Σ ;;; Γ |- it_mkLambda_or_LetIn Δ t : it_mkProd_or_LetIn Δ A.
  Proof using Type.
    intros Σ Γ Δ t A h.
    induction Δ as [| [na [b|] B] Δ ih ] in t, A, h |- *.
    - assumption.
    - simpl. cbn. eapply ih.
      simpl in h. pose proof (typing_wf_local h) as hc.
      dependent induction hc.
      econstructor; try eassumption. exact t0.π2.
    - simpl. cbn. eapply ih.
      pose proof (typing_wf_local h) as hc. cbn in hc.
      dependent induction hc;
      econstructor; try eassumption. exact t0.π2.
  Qed.

End Generation.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.

(* Why3 assumption *)
Definition unit  := unit.

Parameter qtmark : Type.

Parameter at1: forall (a:Type), a -> qtmark -> a.
Implicit Arguments at1.

Parameter old: forall (a:Type), a -> a.
Implicit Arguments old.

(* Why3 assumption *)
Definition implb(x:bool) (y:bool): bool := match (x,
  y) with
  | (true, false) => false
  | (_, _) => true
  end.

(* Why3 assumption *)
Inductive term  :=
  | S : term
  | K : term
  | App : term -> term -> term .

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint is_value(t:term) {struct t}: Prop :=
  match t with
  | (K|S) => True
  | ((App K v)|(App S v)) => (is_value v)
  | (App (App S v1) v2) => (is_value v1) /\ (is_value v2)
  | _ => False
  end.
Unset Implicit Arguments.

(* Why3 assumption *)
Inductive context  :=
  | Hole : context
  | Left : context -> term -> context
  | Right : term -> context -> context .

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint is_context(c:context) {struct c}: Prop :=
  match c with
  | Hole => True
  | (Left c1 _) => (is_context c1)
  | (Right v c1) => (is_value v) /\ (is_context c1)
  end.
Unset Implicit Arguments.

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint subst(c:context) (t:term) {struct c}: term :=
  match c with
  | Hole => t
  | (Left c1 t2) => (App (subst c1 t) t2)
  | (Right v1 c2) => (App v1 (subst c2 t))
  end.
Unset Implicit Arguments.

(* Why3 assumption *)
Inductive infix_mnmngt : term -> term -> Prop :=
  | red_K : forall (c:context), (is_context c) -> forall (v1:term) (v2:term),
      (is_value v1) -> ((is_value v2) -> (infix_mnmngt (subst c (App (App K
      v1) v2)) (subst c v1)))
  | red_S : forall (c:context), (is_context c) -> forall (v1:term) (v2:term)
      (v3:term), (is_value v1) -> ((is_value v2) -> ((is_value v3) ->
      (infix_mnmngt (subst c (App (App (App S v1) v2) v3)) (subst c
      (App (App v1 v3) (App v2 v3)))))).

Axiom red_left : forall (t1:term) (t2:term) (t:term), (infix_mnmngt t1 t2) ->
  (infix_mnmngt (App t1 t) (App t2 t)).

Axiom red_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((infix_mnmngt t1 t2) -> (infix_mnmngt (App v t1) (App v t2))).

(* Why3 assumption *)
Inductive relTR : term -> term -> Prop :=
  | BaseTransRefl : forall (x:term), (relTR x x)
  | StepTransRefl : forall (x:term) (y:term) (z:term), (relTR x y) ->
      ((infix_mnmngt y z) -> (relTR x z)).

Axiom relTR_transitive : forall (x:term) (y:term) (z:term), (relTR x y) ->
  ((relTR y z) -> (relTR x z)).

Axiom red_star_left : forall (t1:term) (t2:term) (t:term), (relTR t1 t2) ->
  (relTR (App t1 t) (App t2 t)).

Axiom red_star_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((relTR t1 t2) -> (relTR (App v t1) (App v t2))).

Axiom reducible_or_value : forall (t:term), (exists tqt:term, (infix_mnmngt t
  tqt)) \/ (is_value t).

(* Why3 assumption *)
Definition irreducible(t:term): Prop := forall (tqt:term), ~ (infix_mnmngt t
  tqt).

Axiom irreducible_is_value : forall (t:term), (irreducible t) <->
  (is_value t).

(* Why3 assumption *)
Inductive only_K : term -> Prop :=
  | only_K_K : (only_K K)
  | only_K_App : forall (t1:term) (t2:term), (only_K t1) -> ((only_K t2) ->
      (only_K (App t1 t2))).

Axiom only_K_reduces : forall (t:term), (only_K t) -> exists v:term, (relTR t
  v) /\ ((is_value v) /\ (only_K v)).

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint size(t:term) {struct t}: Z :=
  match t with
  | (K|S) => 0%Z
  | (App t1 t2) => ((1%Z + (size t1))%Z + (size t2))%Z
  end.
Unset Implicit Arguments.

Axiom size_nonneg : forall (t:term), (0%Z <= (size t))%Z.

Parameter ks: Z -> term.

Axiom ksO : ((ks 0%Z) = K).

Axiom ksS : forall (n:Z), (0%Z <= n)%Z -> ((ks (n + 1%Z)%Z) = (App (ks n)
  K)).

Axiom ks1 : ((ks 1%Z) = (App K K)).

Axiom only_K_ks : forall (n:Z), (0%Z <= n)%Z -> (only_K (ks n)).

Axiom ks_inversion : forall (n:Z), (0%Z <= n)%Z -> ((n = 0%Z) \/
  ((0%Z <  n)%Z /\ ((ks n) = (App (ks (n - 1%Z)%Z) K)))).

Axiom ks_injective : forall (n1:Z) (n2:Z), (0%Z <= n1)%Z -> ((0%Z <= n2)%Z ->
  (((ks n1) = (ks n2)) -> (n1 = n2))).

Require Import Why3. Ltac ae := why3 "alt-ergo".

(* Why3 goal *)
Theorem WP_parameter_reduction3 : forall (t:term), (exists n:Z,
  (0%Z <= n)%Z /\ (t = (ks n))) ->
  match t with
  | S => True
  | K => True
  | (App t1 t2) => (exists n:Z, (0%Z <= n)%Z /\ (t1 = (ks n))) ->
      forall (result:term), ((is_value result) /\ forall (n:Z),
      (0%Z <= n)%Z -> (((t1 = (ks (2%Z * n)%Z)) -> (result = K)) /\
      ((t1 = (ks ((2%Z * n)%Z + 1%Z)%Z)) -> (result = (App K K))))) ->
      match result with
      | K => (exists n:Z, (0%Z <= n)%Z /\ (t2 = (ks n))) ->
          forall (result1:term), ((is_value result1) /\ forall (n:Z),
          (0%Z <= n)%Z -> (((t2 = (ks (2%Z * n)%Z)) -> (result1 = K)) /\
          ((t2 = (ks ((2%Z * n)%Z + 1%Z)%Z)) -> (result1 = (App K K))))) ->
          forall (n:Z), (0%Z <= n)%Z -> ((t = (ks (2%Z * n)%Z)) -> ((App K
          result1) = K))
      | S => True
      | (App K v1) => True
      | (App S v1) => True
      | (App (App S v1) v2) => True
      | _ => True
      end
  end.
intros t (n, (h1, h2)).
destruct t; auto.
intros (n1, (h3, h4)).
destruct result as [] _eqn.
intuition.
intros (h5, h6) (n2, (h7, h8)).
intros res1 (h9, h10).
intros n0 hn0 eq0.
generalize (h10 n2 h7); clear h10; intros ht2.
assert (n2 = 0)%Z.
  generalize (ks_inversion n2 h7).
  intuition.
  generalize (ks_inversion n h1). ae.
assert (h: (0 <= 2*n0)%Z) by ae.
generalize (ks_inversion (2*n0)%Z h).
intuition.
ae.
assert (t1 = ks (2*(n0-1)+1))%Z by ae.
assert (n1 = 2 * (n0 - 1) + 1)%Z by ae.
ae.
destruct t3; auto.
destruct t3_1; auto.
Qed.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
Copyright (C) 2009-2018 Guillaume Melquiond

This library 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 3 of the License, or (at your option) any later version.

This library 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
COPYING file for more details.
*)

(** * Floating-point format without underflow *)

From Coq Require Import ZArith Reals Psatz.

Require Import Zaux Raux Defs Round_pred Generic_fmt Float_prop FIX Ulp Round_NE.

Section RND_FLX.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable prec : Z.

Class Prec_gt_0 :=
  prec_gt_0 : (0 < prec)%Z.

Context { prec_gt_0_ : Prec_gt_0 }.

Inductive FLX_format (x : R) : Prop :=
  FLX_spec (f : float beta) :
    x = F2R f -> (Z.abs (Fnum f) < Zpower beta prec)%Z -> FLX_format x.

Definition FLX_exp (e : Z) := (e - prec)%Z.

(** Properties of the FLX format *)

Global Instance FLX_exp_valid : Valid_exp FLX_exp.
Proof.
intros k.
unfold FLX_exp.
generalize prec_gt_0.
repeat split ; intros ; lia.
Qed.

Theorem FIX_format_FLX :
  forall x e,
  (bpow (e - 1) <= Rabs x <= bpow e)%R ->
  FLX_format x ->
  FIX_format beta (e - prec) x.
Proof.
clear prec_gt_0_.
intros x e Hx [[xm xe] H1 H2].
rewrite H1, (F2R_prec_normalize beta xm xe e prec).
now eexists.
exact H2.
now rewrite <- H1.
Qed.

Theorem FLX_format_generic :
  forall x, generic_format beta FLX_exp x -> FLX_format x.
Proof.
intros x H.
rewrite H.
eexists ; repeat split.
simpl.
apply lt_IZR.
rewrite abs_IZR.
rewrite <- scaled_mantissa_generic with (1 := H).
rewrite <- scaled_mantissa_abs.
apply Rmult_lt_reg_r with (bpow (cexp beta FLX_exp (Rabs x))).
apply bpow_gt_0.
rewrite scaled_mantissa_mult_bpow.
rewrite IZR_Zpower, <- bpow_plus.
2: now apply Zlt_le_weak.
unfold cexp, FLX_exp.
ring_simplify (prec + (mag beta (Rabs x) - prec))%Z.
rewrite mag_abs.
destruct (Req_dec x 0) as [Hx|Hx].
rewrite Hx, Rabs_R0.
apply bpow_gt_0.
destruct (mag beta x) as (ex, Ex).
now apply Ex.
Qed.

Theorem generic_format_FLX :
  forall x, FLX_format x -> generic_format beta FLX_exp x.
Proof.
clear prec_gt_0_.
intros x [[mx ex] H1 H2].
simpl in H2.
rewrite H1.
apply generic_format_F2R.
intros Zmx.
unfold cexp, FLX_exp.
rewrite mag_F2R with (1 := Zmx).
apply Zplus_le_reg_r with (prec - ex)%Z.
ring_simplify.
now apply mag_le_Zpower.
Qed.

Theorem FLX_format_satisfies_any :
  satisfies_any FLX_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)).
intros x.
split.
apply FLX_format_generic.
apply generic_format_FLX.
Qed.

Theorem FLX_format_FIX :
  forall x e,
  (bpow (e - 1) <= Rabs x <= bpow e)%R ->
  FIX_format beta (e - prec) x ->
  FLX_format x.
Proof with auto with typeclass_instances.
intros x e Hx Fx.
apply FLX_format_generic.
apply generic_format_FIX in Fx.
revert Fx.
apply generic_inclusion with (e := e)...
apply Z.le_refl.
Qed.

(** unbounded floating-point format with normal mantissas *)
Inductive FLXN_format (x : R) : Prop :=
  FLXN_spec (f : float beta) :
    x = F2R f ->
    (x <> 0%R -> Zpower beta (prec - 1) <= Z.abs (Fnum f) < Zpower beta prec)%Z ->
    FLXN_format x.

Theorem generic_format_FLXN :
  forall x, FLXN_format x -> generic_format beta FLX_exp x.
Proof.
intros x [[xm ex] H1 H2].
destruct (Req_dec x 0) as [Zx|Zx].
rewrite Zx.
apply generic_format_0.
specialize (H2 Zx).
apply generic_format_FLX.
rewrite H1.
eexists ; repeat split.
apply H2.
Qed.

Theorem FLXN_format_generic :
  forall x, generic_format beta FLX_exp x -> FLXN_format x.
Proof.
intros x Hx.
rewrite Hx.
simpl.
eexists. easy.
rewrite <- Hx.
intros Zx.
simpl.
split.
(* *)
apply le_IZR.
rewrite IZR_Zpower.
2: now apply Zlt_0_le_0_pred.
rewrite abs_IZR, <- scaled_mantissa_generic with (1 := Hx).
apply Rmult_le_reg_r with (bpow (cexp beta FLX_exp x)).
apply bpow_gt_0.
rewrite <- bpow_plus.
rewrite <- scaled_mantissa_abs.
rewrite <- cexp_abs.
rewrite scaled_mantissa_mult_bpow.
unfold cexp, FLX_exp.
rewrite mag_abs.
ring_simplify (prec - 1 + (mag beta x - prec))%Z.
destruct (mag beta x) as (ex,Ex).
now apply Ex.
(* *)
apply lt_IZR.
rewrite IZR_Zpower.
2: now apply Zlt_le_weak.
rewrite abs_IZR, <- scaled_mantissa_generic with (1 := Hx).
apply Rmult_lt_reg_r with (bpow (cexp beta FLX_exp x)).
apply bpow_gt_0.
rewrite <- bpow_plus.
rewrite <- scaled_mantissa_abs.
rewrite <- cexp_abs.
rewrite scaled_mantissa_mult_bpow.
unfold cexp, FLX_exp.
rewrite mag_abs.
ring_simplify (prec + (mag beta x - prec))%Z.
destruct (mag beta x) as (ex,Ex).
now apply Ex.
Qed.

Theorem FLXN_format_satisfies_any :
  satisfies_any FLXN_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)).
split ; intros H.
now apply FLXN_format_generic.
now apply generic_format_FLXN.
Qed.

Lemma negligible_exp_FLX :
   negligible_exp FLX_exp = None.
Proof.
case (negligible_exp_spec FLX_exp).
intros _; reflexivity.
intros n H2; contradict H2.
unfold FLX_exp; unfold Prec_gt_0 in prec_gt_0_; lia.
Qed.

Theorem generic_format_FLX_1 :
  generic_format beta FLX_exp 1.
Proof.
unfold generic_format, scaled_mantissa, cexp, F2R; simpl.
rewrite Rmult_1_l, (mag_unique beta 1 1).
{ unfold FLX_exp.
  rewrite <- IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; lia].
  rewrite Ztrunc_IZR, IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; lia].
  rewrite <- bpow_plus.
  now replace (_ + _)%Z with Z0 by ring. }
rewrite Rabs_R1; simpl; split; [now right|].
unfold Z.pow_pos; simpl; rewrite Zmult_1_r; apply IZR_lt.
assert (H := Zle_bool_imp_le _ _ (radix_prop beta)); lia.
Qed.

Theorem ulp_FLX_0: (ulp beta FLX_exp 0 = 0)%R.
Proof.
unfold ulp; rewrite Req_bool_true; trivial.
rewrite negligible_exp_FLX; easy.
Qed.

Lemma ulp_FLX_1 : ulp beta FLX_exp 1 = bpow (-prec + 1).
Proof.
unfold ulp, FLX_exp, cexp; rewrite Req_bool_false; [|apply R1_neq_R0].
rewrite mag_1; f_equal; ring.
Qed.

Lemma succ_FLX_1 : (succ beta FLX_exp 1 = 1 + bpow (-prec + 1))%R.
Proof.
now unfold succ; rewrite Rle_bool_true; [|apply Rle_0_1]; rewrite ulp_FLX_1.
Qed.

Theorem eq_0_round_0_FLX :
   forall rnd {Vr: Valid_rnd rnd} x,
     round beta FLX_exp rnd x = 0%R -> x = 0%R.
Proof.
intros rnd Hr x.
apply eq_0_round_0_negligible_exp; try assumption.
apply FLX_exp_valid.
apply negligible_exp_FLX.
Qed.

Theorem gt_0_round_gt_0_FLX :
   forall rnd {Vr: Valid_rnd rnd} x,
     (0 < x)%R -> (0 < round beta FLX_exp rnd x)%R.
Proof with auto with typeclass_instances.
intros rnd Hr x Hx.
assert (K: (0 <= round beta FLX_exp rnd x)%R).
rewrite <- (round_0 beta FLX_exp rnd).
apply round_le... now apply Rlt_le.
destruct K; try easy.
absurd (x = 0)%R.
now apply Rgt_not_eq.
apply eq_0_round_0_FLX with rnd...
Qed.

Theorem ulp_FLX_le :
  forall x, (ulp beta FLX_exp x <= Rabs x * bpow (1-prec))%R.
Proof.
intros x; case (Req_dec x 0); intros Hx.
rewrite Hx, ulp_FLX_0, Rabs_R0.
right; ring.
rewrite ulp_neq_0; try exact Hx.
unfold cexp, FLX_exp.
replace (mag beta x - prec)%Z with ((mag beta x - 1) + (1-prec))%Z by ring.
rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
now apply bpow_mag_le.
Qed.

Theorem ulp_FLX_ge :
  forall x, (Rabs x * bpow (-prec) <= ulp beta FLX_exp x)%R.
Proof.
intros x; case (Req_dec x 0); intros Hx.
rewrite Hx, ulp_FLX_0, Rabs_R0.
right; ring.
rewrite ulp_neq_0; try exact Hx.
unfold cexp, FLX_exp.
unfold Zminus; rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
left; now apply bpow_mag_gt.
Qed.

Lemma ulp_FLX_exact_shift :
  forall x e,
  (ulp beta FLX_exp (x * bpow e) = ulp beta FLX_exp x * bpow e)%R.
Proof.
intros x e.
destruct (Req_dec x 0) as [Hx|Hx].
{ unfold ulp.
  now rewrite !Req_bool_true, negligible_exp_FLX; rewrite ?Hx, ?Rmult_0_l. }
unfold ulp; rewrite Req_bool_false;
  [|now intro H; apply Hx, (Rmult_eq_reg_r (bpow e));
    [rewrite Rmult_0_l|apply Rgt_not_eq, Rlt_gt, bpow_gt_0]].
rewrite (Req_bool_false _ _ Hx), <- bpow_plus; f_equal; unfold cexp, FLX_exp.
now rewrite mag_mult_bpow; [ring|].
Qed.

Lemma succ_FLX_exact_shift :
  forall x e,
  (succ beta FLX_exp (x * bpow e) = succ beta FLX_exp x * bpow e)%R.
Proof.
intros x e.
destruct (Rle_or_lt 0 x) as [Px|Nx].
{ rewrite succ_eq_pos; [|now apply Rmult_le_pos, bpow_ge_0].
  rewrite (succ_eq_pos _ _ _ Px).
  now rewrite Rmult_plus_distr_r; f_equal; apply ulp_FLX_exact_shift. }
unfold succ.
rewrite Rle_bool_false; [|assert (H := bpow_gt_0 beta e); nra].
rewrite Rle_bool_false; [|now simpl].
rewrite Ropp_mult_distr_l_reverse, <-Ropp_mult_distr_l_reverse; f_equal.
unfold pred_pos.
rewrite mag_mult_bpow; [|lra].
replace (_ - 1)%Z with (mag beta (- x) - 1 + e)%Z; [|ring]; rewrite bpow_plus.
unfold Req_bool; rewrite Rcompare_mult_r; [|now apply bpow_gt_0].
fold (Req_bool (-x) (bpow (mag beta (-x) - 1))); case Req_bool.
{ unfold FLX_exp.
  replace (_ - _)%Z with (mag beta (- x) - 1 - prec + e)%Z; [|ring].
  rewrite bpow_plus; ring. }
rewrite ulp_FLX_exact_shift; ring.
Qed.

(** FLX is a nice format: it has a monotone exponent... *)
Global Instance FLX_exp_monotone : Monotone_exp FLX_exp.
Proof.
intros ex ey Hxy.
now apply Zplus_le_compat_r.
Qed.

(** and it allows a rounding to nearest, ties to even. *)
Hypothesis NE_prop : Z.even beta = false \/ (1 < prec)%Z.

Global Instance exists_NE_FLX : Exists_NE beta FLX_exp.
Proof.
destruct NE_prop as [H|H].
now left.
right.
unfold FLX_exp.
split ; lia.
Qed.

End RND_FLX.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli & Mark Bickford

*)

Require Export rules_useful.
Require Export subst_tacs.
Require Export cequiv_tacs.
Require Export per_props_equality.
Require Export sequents_equality.

Definition rule_tyfam_equality {p}
           C
           (a1 a2 b1 b2 : NTerm)
           (x1 x2 y : NVar)
           (i   : nat)
           (H   : @barehypotheses p) :=
  mk_rule
    (mk_baresequent
       H
       (mk_conclax (mk_equality (C a1 x1 b1) (C a2 x2 b2) (mk_uni i))))
    [ mk_baresequent
        H
        (mk_conclax (mk_equality a1 a2 (mk_uni i))),
      mk_baresequent
        (snoc H (mk_hyp y a1))
        (mk_conclax (mk_equality
                       (subst b1 x1 (mk_var y))
                       (subst b2 x2 (mk_var y))
                       (mk_uni i)))
    ]
    [ sarg_var y ].

Lemma rule_tyfam_equality_true {pp} :
  forall lib C Cc (a1 a2 b1 b2 : NTerm),
  forall x1 x2 y : NVar,
  forall i   : nat,
  forall H   : @barehypotheses pp,
  forall bc1 : !LIn y (bound_vars b1),
  forall bc2 : !LIn y (bound_vars b2),
  forall fvsC : forall a x b, free_vars (C a x b) = free_vars a ++ remove_nvars [x] (free_vars b),
  forall pd  : (forall a x b w s c,
                  {wa : wf_term a
                   & {wb : wf_term b
                   & {ca : cover_vars a s
                   & {cb : cover_vars_upto b (csub_filter s [x]) [x]
                   & lsubstc (C a x b) w s c
                     = Cc (lsubstc a wa s ca) x (lsubstc_vars b wb (csub_filter s [x]) [x] cb)
               }}}}),
  forall eqC : (forall a1 a2 v1 v2 b1 b2 i,
                  equality lib (Cc a1 v1 b1) (Cc a2 v2 b2) (mkc_uni i)
                  <=> (equality lib a1 a2 (mkc_uni i)
                       # (forall a a',
                            equality lib a a' a1
                            -> equality lib (substc a v1 b1) (substc a' v2 b2) (mkc_uni i)))),
    rule_true lib (rule_tyfam_equality
                     C a1 a2 b1 b2
                     x1 x2 y
                     i
                     H).
Proof.
  unfold rule_tyfam_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  destruct Hyp as [ ws1 hyp1 ].
  destruct Hyp0 as [ ws2 hyp2 ].
  destseq; allsimpl; proof_irr; GC.

  exists (@covered_axiom pp (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  assert ((y <> x1 -> !LIn y (free_vars b1))
          # (y <> x2 -> !LIn y (free_vars b2))
          # !LIn y (free_vars a1)
          # !LIn y (free_vars a2)
          # !LIn y (vars_hyps H)) as vhyps.

  {
    clear hyp1 hyp2.
    dwfseq.
    allrw fvsC.
    sp;
      try (complete (generalize (cg0 y); intro p;
                     allrw in_app_iff;
                     allrw in_remove_nvars; allsimpl;
                     autodimp p hyp; tcsp;
                     right; tcsp));
      try (complete (generalize (cg y); intro p;
                     allrw in_app_iff;
                     allrw in_remove_nvars; allsimpl;
                     autodimp p hyp; tcsp;
                     right; tcsp)).
  }

  destruct vhyps as [ nyb1 vhyps ].
  destruct vhyps as [ nyb2 vhyps ].
  destruct vhyps as [ nyA1 vhyps ].
  destruct vhyps as [ nyA2 nyH ].
  (* done with proving these simple facts *)

  vr_seq_true.

  lsubst_tac.
  rewrite @member_eq.
  rw <- @member_equality_iff.

  teq_and_eq (@mk_uni pp i) (C a1 x1 b1) (C a2 x2 b2) s1 s2 H;
    [apply tequality_mkc_uni|].

  pose proof (pd a1 x1 b1 w1 s1 ca1) as e; exrepnd; rw e1; clear e1.
  pose proof (pd a2 x2 b2 w2 s2 cb2) as e; exrepnd; rw e1; clear e1.
  apply eqC.
  dands.

  { (* First, we prove that the a's are types *)
    vr_seq_true in hyp1.
    pose proof (hyp1 s1 s2) as hyp; clear hyp1.
    repeat (autodimp hyp hh).
    exrepnd.
    lsubst_tac.
    rw @member_eq in hyp1.
    rw <- @member_equality_iff in hyp1; auto.
    apply equality_commutes4 in hyp0; auto.
  }

  { (* Then we prove that the b's are type families *)
    intros a a' eqaa'.
    vr_seq_true in hyp2.
    repeat substc_lsubstc_vars3.

    pose proof (hyp2 (snoc s1 (y, a)) (snoc s2 (y, a'))) as h; clear hyp2.
    repeat (autodimp h hyp).

    { (* we have to prove the functionality of our hypotheses *)
      intros s3 sim2.
      inversion sim2; cpx; allsimpl; cpx.
      rw @eq_hyps_snoc; simpl.
      assert (cover_vars a1 s4)
        as cv4
          by (apply (similarity_cover_vars lib) with (hs := H) (s1 := s1); auto).
      exists s1 s4 a t2 w p cv4; sp.
      (* while proving that functionality result, we have to prove that
       * a1 is functional, which we prove using our 1st hyp *)
      vr_seq_true in hyp1.
      generalize (hyp1 s1 s4); thin hyp1; intro hyp1.
      autodimp hyp1 hyp1'.
      autodimp hyp1 hyp1'; exrepnd; clear_irr.
      lift_lsubst in hyp0; lift_lsubst in hyp1.
      rw @member_eq in hyp1.
      rw <- @member_equality_iff in hyp1.
      apply @equality_commutes2 in hyp0; auto.
      allapply @equality_in_uni; auto. }

    { rw @similarity_snoc; simpl.
      exists s1 s2 a a' wa ca; dands; tcsp. }

    exrepnd; clear_irr.
    lsubst_tac.
    rw @member_eq in h1.
    rw <- @member_equality_iff in h1.

    assert (!LIn y (dom_csub s1)) as nys1.
    { allapply @similarity_dom; exrepd; allrw; sp. }

    assert (!LIn y (dom_csub s2)) as nys2.
    { allapply @similarity_dom; exrepd; allrw; sp. }

    assert (cover_vars_upto b1 (csub_filter s2 [x1]) [x1]) as cb12.
    { eapply cover_vars_upto_eq_dom_csub; eauto.
      allapply @similarity_dom; repnd; allrw; auto. }

    assert (cover_vars_upto b2 (csub_filter s1 [x2]) [x2]) as cb21.
    { eapply cover_vars_upto_eq_dom_csub; eauto.
      allapply @similarity_dom; repnd; allrw; auto. }

    repeat (rw_lsubstc_subst_snoc_eq;[]).
    repeat (substc_lsubstc_vars3;[]).
    clear_irr.
    apply equality_commutes4 in h0; auto.
  }
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2013 Sylvie Boldo
#<br />#
Copyright (C) 2010-2013 Guillaume Melquiond

This library 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 3 of the License, or (at your option) any later version.

This library 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
COPYING file for more details.
*)

(** * Error of the rounded-to-nearest addition is representable. *)

Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_float_prop.
Require Import Fcore_generic_fmt.
Require Import Fcore_FIX.
Require Import Fcore_FLX.
Require Import Fcore_FLT.
Require Import Fcalc_ops.

Section Fprop_plus_error.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.

Section round_repr_same_exp.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem round_repr_same_exp :
  forall m e,
  exists m',
  round beta fexp rnd (F2R (Float beta m e)) = F2R (Float beta m' e).
Proof with auto with typeclass_instances.
intros m e.
set (e' := canonic_exp beta fexp (F2R (Float beta m e))).
unfold round, scaled_mantissa. fold e'.
destruct (Zle_or_lt e' e) as [He|He].
exists m.
unfold F2R at 2. simpl.
rewrite Rmult_assoc, <- bpow_plus.
rewrite <- Z2R_Zpower. 2: omega.
rewrite <- Z2R_mult, Zrnd_Z2R...
unfold F2R. simpl.
rewrite Z2R_mult.
rewrite Rmult_assoc.
rewrite Z2R_Zpower. 2: omega.
rewrite <- bpow_plus.
apply (f_equal (fun v => Z2R m * bpow v)%R).
ring.
exists ((rnd (Z2R m * bpow (e - e'))) * Zpower beta (e' - e))%Z.
unfold F2R. simpl.
rewrite Z2R_mult.
rewrite Z2R_Zpower. 2: omega.
rewrite 2!Rmult_assoc.
rewrite <- 2!bpow_plus.
apply (f_equal (fun v => _ * bpow v)%R).
ring.
Qed.

End round_repr_same_exp.

Context { monotone_exp : Monotone_exp fexp }.
Notation format := (generic_format beta fexp).

Variable choice : Z -> bool.

Lemma plus_error_aux :
  forall x y,
  (canonic_exp beta fexp x <= canonic_exp beta fexp y)%Z ->
  format x -> format y ->
  format (round beta fexp (Znearest choice) (x + y) - (x + y))%R.
Proof.
intros x y.
set (ex := canonic_exp beta fexp x).
set (ey := canonic_exp beta fexp y).
intros He Hx Hy.
destruct (Req_dec (round beta fexp (Znearest choice) (x + y) - (x + y)) R0) as [H0|H0].
rewrite H0.
apply generic_format_0.
set (mx := Ztrunc (scaled_mantissa beta fexp x)).
set (my := Ztrunc (scaled_mantissa beta fexp y)).
(* *)
assert (Hxy: (x + y)%R = F2R (Float beta (mx + my * beta ^ (ey - ex)) ex)).
rewrite Hx, Hy.
fold mx my ex ey.
rewrite <- F2R_plus.
unfold Fplus. simpl.
now rewrite Zle_imp_le_bool with (1 := He).
(* *)
rewrite Hxy.
destruct (round_repr_same_exp (Znearest choice) (mx + my * beta ^ (ey - ex)) ex) as (mxy, Hxy').
rewrite Hxy'.
assert (H: (F2R (Float beta mxy ex) - F2R (Float beta (mx + my * beta ^ (ey - ex)) ex))%R =
  F2R (Float beta (mxy - (mx + my * beta ^ (ey - ex))) ex)).
now rewrite <- F2R_minus, Fminus_same_exp.
rewrite H.
apply generic_format_F2R.
intros _.
apply monotone_exp.
rewrite <- H, <- Hxy', <- Hxy.
apply ln_beta_le_abs.
exact H0.
pattern x at 3 ; replace x with (-(y - (x + y)))%R by ring.
rewrite Rabs_Ropp.
now apply (round_N_pt beta _ choice (x + y)).
Qed.

(** Error of the addition *)
Theorem plus_error :
  forall x y,
  format x -> format y ->
  format (round beta fexp (Znearest choice) (x + y) - (x + y))%R.
Proof.
intros x y Hx Hy.
destruct (Zle_or_lt (canonic_exp beta fexp x) (canonic_exp beta fexp y)).
now apply plus_error_aux.
rewrite Rplus_comm.
apply plus_error_aux ; try easy.
now apply Zlt_le_weak.
Qed.

End Fprop_plus_error.

Section Fprop_plus_zero.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Context { exp_not_FTZ : Exp_not_FTZ fexp }.
Notation format := (generic_format beta fexp).

Section round_plus_eq_zero_aux.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Lemma round_plus_eq_zero_aux :
  forall x y,
  (canonic_exp beta fexp x <= canonic_exp beta fexp y)%Z ->
  format x -> format y ->
  (0 <= x + y)%R ->
  round beta fexp rnd (x + y) = R0 ->
  (x + y = 0)%R.
Proof with auto with typeclass_instances.
intros x y He Hx Hy Hp Hxy.
destruct (Req_dec (x + y) 0) as [H0|H0].
exact H0.
destruct (ln_beta beta (x + y)) as (exy, Hexy).
simpl.
specialize (Hexy H0).
destruct (Zle_or_lt exy (fexp exy)) as [He'|He'].
(* . *)
assert (H: (x + y)%R = F2R (Float beta (Ztrunc (x * bpow (- fexp exy)) +
  Ztrunc (y * bpow (- fexp exy))) (fexp exy))).
rewrite (subnormal_exponent beta fexp exy x He' Hx) at 1.
rewrite (subnormal_exponent beta fexp exy y He' Hy) at 1.
now rewrite <- F2R_plus, Fplus_same_exp.
rewrite H in Hxy.
rewrite round_generic in Hxy...
now rewrite <- H in Hxy.
apply generic_format_F2R.
intros _.
rewrite <- H.
unfold canonic_exp.
rewrite ln_beta_unique with (1 := Hexy).
apply Zle_refl.
(* . *)
elim Rle_not_lt with (1 := round_le beta _ rnd _ _ (proj1 Hexy)).
rewrite (Rabs_pos_eq _ Hp).
rewrite Hxy.
rewrite round_generic...
apply bpow_gt_0.
apply generic_format_bpow.
apply Zlt_succ_le.
now rewrite (Zsucc_pred exy) in He'.
Qed.

End round_plus_eq_zero_aux.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

(** rnd(x+y)=0 -> x+y = 0 provided this is not a FTZ format *)
Theorem round_plus_eq_zero :
  forall x y,
  format x -> format y ->
  round beta fexp rnd (x + y) = R0 ->
  (x + y = 0)%R.
Proof with auto with typeclass_instances.
intros x y Hx Hy.
destruct (Rle_or_lt R0 (x + y)) as [H1|H1].
(* . *)
revert H1.
destruct (Zle_or_lt (canonic_exp beta fexp x) (canonic_exp beta fexp y)) as [H2|H2].
now apply round_plus_eq_zero_aux.
rewrite Rplus_comm.
apply round_plus_eq_zero_aux ; try easy.
now apply Zlt_le_weak.
(* . *)
revert H1.
rewrite <- (Ropp_involutive (x + y)), Ropp_plus_distr, <- Ropp_0.
intros H1.
rewrite round_opp.
intros Hxy.
apply f_equal.
cut (round beta fexp (Zrnd_opp rnd) (- x + - y) = 0)%R.
cut (0 <= -x + -y)%R.
destruct (Zle_or_lt (canonic_exp beta fexp (-x)) (canonic_exp beta fexp (-y))) as [H2|H2].
apply round_plus_eq_zero_aux ; try apply generic_format_opp...
rewrite Rplus_comm.
apply round_plus_eq_zero_aux ; try apply generic_format_opp...
now apply Zlt_le_weak.
apply Rlt_le.
now apply Ropp_lt_cancel.
rewrite <- (Ropp_involutive (round _ _ _ _)).
rewrite Hxy.
apply Ropp_involutive.
Qed.

End Fprop_plus_zero.

Section Fprop_plus_FLT.
Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.

Theorem FLT_format_plus_small: forall x y,
  generic_format beta (FLT_exp emin prec) x ->
  generic_format beta (FLT_exp emin prec) y ->
   (Rabs (x+y) <= bpow (prec+emin))%R ->
    generic_format beta (FLT_exp emin prec) (x+y).
Proof with auto with typeclass_instances.
intros x y Fx Fy H.
apply generic_format_FLT_FIX...
rewrite Zplus_comm; assumption.
apply generic_format_FIX_FLT, FIX_format_generic in Fx.
apply generic_format_FIX_FLT, FIX_format_generic in Fy.
destruct Fx as (nx,(H1x,H2x)).
destruct Fy as (ny,(H1y,H2y)).
apply generic_format_FIX.
exists (Float beta (Fnum nx+Fnum ny)%Z emin).
split;[idtac|reflexivity].
rewrite H1x,H1y; unfold F2R; simpl.
rewrite H2x, H2y.
rewrite Z2R_plus; ring.
Qed.

End Fprop_plus_FLT.


(* Here we consider pivals which are sets of ivals that can be interpreted as distributions *)

From discprob.basic Require Import base sval order monad bigop_ext nify.
Require Import Reals Psatz Omega.

Require ClassicalEpsilon.
From mathcomp Require Import ssrfun ssreflect eqtype ssrbool seq fintype choice.
Global Set Bullet Behavior "Strict Subproofs".
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype finset finfun bigop.

Local Open Scope R_scope.
From discprob.idxval Require Import ival pival ival_dist.
From discprob.prob Require Import prob countable finite stochastic_order.

(*
Record pidist (X: Type) := { choices :> list (ivdist X); nonempty : ∃ I, In I choices }.
*)
Record pidist (X: Type) := { pidist_pival :> pival X;
                             all_sum1: ∀ I, In I pidist_pival →
                                            is_series (countable_sum (val I)) 1
                           }.

Arguments pidist_pival {_}.
Arguments all_sum1 {_}.

Definition lift_In_pidist {X} {Is: pidist X} (I: ival X)  (Pf: In I Is) : ivdist X :=
  {| ivd_ival := I; val_sum1 := (all_sum1 Is I Pf) |}.

Definition eq_pidist {X} (Is1 Is2: pidist X) :=
  eq_pival Is1 Is2.
Definition le_pidist {X} (Is1 Is2: pidist X) :=
  le_pival Is1 Is2.

Global Instance eq_pidist_Transitivite {X}: Transitive (@eq_pidist X).
Proof. intros ???. apply eq_pival_trans. Qed.
Global Instance eq_pidist_Reflexive {X}: Reflexive (@eq_pidist X).
Proof. intros ?. apply eq_pival_refl. Qed.
Global Instance eq_pidist_Symmetry {X}: Symmetric (@eq_pidist X).
Proof. intros ??. apply eq_pival_sym. Qed.
Global Instance eq_pidist_Equivalence {X}: Equivalence (@eq_pidist X).
Proof. split; apply _. Qed.

Global Instance le_pidist_Transitivite {X}: Transitive (@le_pidist X).
Proof. intros ???. apply le_pival_trans. Qed.
Global Instance le_pidist_Reflexive {X}: Reflexive (@le_pidist X).
Proof. intros ?. apply le_pival_refl. Qed.
Global Instance le_pidist_proper {X}: Proper (@eq_pidist X ==> @eq_pidist X ==> iff) (@le_pidist X).
Proof. rewrite /eq_pidist/le_pidist//= => ?? Heq1 ?? Heq2.
       setoid_rewrite Heq1. setoid_rewrite Heq2.
       done.
Qed.

Definition eq_pidist_prob {X} (Is1 Is2: pidist X) :=
  eq_pival_prob Is1 Is2.
Definition le_pidist_prob {X} (Is1 Is2: pidist X) :=
  le_pival_prob Is1 Is2.

Global Instance eq_pidist_prob_Transitivite {X}: Transitive (@eq_pidist_prob X).
Proof. intros ???. apply eq_pival_prob_trans. Qed.
Global Instance eq_pidist_prob_Reflexive {X}: Reflexive (@eq_pidist_prob X).
Proof. intros ?. apply eq_pival_prob_refl. Qed.
Global Instance eq_pidist_prob_Symmetry {X}: Symmetric (@eq_pidist_prob X).
Proof. intros ??. apply eq_pival_prob_sym. Qed.
Global Instance eq_pidist_prob_Equivalence {X}: Equivalence (@eq_pidist_prob X).
Proof. split; apply _. Qed.

Global Instance le_pidist_prob_Transitivite {X}: Transitive (@le_pidist_prob X).
Proof. intros ???. apply le_pival_prob_trans. Qed.
Global Instance le_pidist_prob_Reflexive {X}: Reflexive (@le_pidist_prob X).
Proof. intros ?. apply le_pival_prob_refl. Qed.

Global Instance le_pidist_prob_proper {X}: Proper (@eq_pidist_prob X ==> @eq_pidist_prob X ==> iff) (@le_pidist_prob X).
Proof.
  rewrite /eq_pidist_prob/le_pidist_prob//= => ?? Heq1 ?? Heq2.
  setoid_rewrite Heq1. setoid_rewrite Heq2. done.
Qed.

Global Instance pidist_ret: MRet pidist.
refine(λ A x, {| pidist_pival := mret x;
                 all_sum1 := _ |}).
{ abstract (intros I Hin;
            rewrite Hin; apply: is_seriesC_bump; exact tt). }
Defined.

Lemma pidist_bind_aux {A B: Type} (f: A → pidist B) (Is: pidist A) :
  ∀ I : ival B, In I ((x ← pidist_pival Is; pidist_pival (f x)) : pival B)
                → is_series (countable_sum (val I)) 1.
Proof.
  intros I Hin.
  apply pival_mbind_in_inv in Hin as (Ix&h&Hpf&Hin&Hhspec&Heq).
  eapply eq_ival_series; eauto.
  rewrite //=.
  apply all_sum1 in Hin.
  eapply (ivd_bind_sum1' h (idxOf Ix)).
  - rewrite //=.
  - rewrite //=. intros. eapply all_sum1; eapply Hhspec; eauto.
Qed.

Global Instance pidist_bind: MBind pidist :=
 (λ A B f Is, {| pidist_pival := mbind (λ x, pidist_pival (f x)) (pidist_pival Is);
                     all_sum1 := pidist_bind_aux f Is |}).

Lemma pidist_assoc {A B C} (m: pidist A) (f: A → pidist B) (g: B → pidist C) :
  eq_pidist (mbind g (mbind f m)) (mbind (λ x, mbind g (f x)) m).
Proof.
  rewrite /eq_pidist. setoid_rewrite pival_assoc. reflexivity.
Qed.

Lemma pidist_left_id {A B: Type} (x: A) (f: A → pidist B):
  eq_pidist (mbind f (mret x)) (f x).
Proof.
  rewrite /eq_pidist. setoid_rewrite pival_left_id. reflexivity.
Qed.

Lemma pidist_right_id {A: Type} (m: pidist A):
  eq_pidist (mbind mret m) m.
Proof.
  rewrite /eq_pidist. setoid_rewrite pival_right_id. reflexivity.
Qed.

Lemma pidist_plus_aux {X} (p: R) (Hrange: 0 <= p <= 1) (Is1 Is2: pidist X) :
  ∀ I : ival X, In I (pplus (pscale p Is1) (pscale (1 - p) Is2)) →
                is_series (countable_sum (val I)) 1.
Proof.
  intros I Hin.
  destruct Hin as (I1&I2&Hin1&Hin2&Heq).
  rewrite Heq.
  destruct Hin1 as (I1'&Hin1%all_sum1&Heq1').
  destruct Hin2 as (I2'&Hin2%all_sum1&Heq2').
  subst.
  unshelve (eapply (ivdplus_sum1 p Hrange {| ivd_ival := I1' |} {| ivd_ival := I2' |})); eauto.
Qed.

Definition pidist_plus {X} (p: R) (Hrange: 0 <= p <= 1) (Is1 Is2: pidist X) : pidist X :=
  {| pidist_pival := pplus (pscale p Is1) (pscale (1 - p) Is2);
     all_sum1 := pidist_plus_aux p Hrange _ _ |}.

Definition pidist_union {X} (Is1 Is2: pidist X) : pidist X.
  refine {| pidist_pival := punion Is1 Is2;
            all_sum1 := _ |}.
  abstract (intros I [Hin|Hin]; by eapply all_sum1; eauto).
Defined.

Global Instance pidist_plus_mono:
  ∀ (X : Type) r Hpf, Proper (@le_pidist X ==> @le_pidist X ==> @le_pidist X) (pidist_plus r Hpf).
Proof.
  intros X r Hpf Is1 Is1' Hle1 Is2 Is2' Hle2.
  rewrite /le_pidist/pidist_plus//=.
  rewrite /le_pidist in Hle1, Hle2.
  setoid_rewrite Hle1. setoid_rewrite Hle2.
  reflexivity.
Qed.

Lemma pidist_plus_proper:
  ∀ (X : Type) r Hpf Hpf' (I1 I1' I2 I2': pidist X),
    eq_pidist I1 I1' →
    eq_pidist I2 I2' →
    eq_pidist (pidist_plus r Hpf I1 I2) (pidist_plus r Hpf' I1' I2').
Proof.
  intros X r Hpf Hpf' Is1 Is1' Is2 Is2' Hle1 Hle2.
  rewrite /eq_pidist/pidist_plus//=.
  rewrite /eq_pidist in Hle1, Hle2.
  setoid_rewrite Hle1. setoid_rewrite Hle2.
  reflexivity.
Qed.

Global Instance pidist_plus_proper_instance:
  ∀ (X : Type) r Hpf, Proper (@eq_pidist X ==> @eq_pidist X ==> @eq_pidist X) (pidist_plus r Hpf).
Proof.
  intros X r Hpf Is1 Is1' Heq1 Is2 Is2' Heq2.
  eapply pidist_plus_proper; eauto.
Qed.

Global Instance pidist_union_mono:
  ∀ (X : Type), Proper (@le_pidist X ==> @le_pidist X ==> @le_pidist X) (pidist_union).
Proof.
  intros X Is1 Is1' Hle1 Is2 Is2' Hle2.
  rewrite /pidist_union/le_pidist//=.
  rewrite /le_pidist in Hle1, Hle2.
  setoid_rewrite Hle1. setoid_rewrite Hle2.
  reflexivity.
Qed.

Global Instance pidist_union_proper:
  ∀ (X : Type), Proper (@eq_pidist X ==> @eq_pidist X ==> @eq_pidist X) (pidist_union).
Proof.
  intros X Is1 Is1' Hle1 Is2 Is2' Hle2.
  rewrite /pidist_union/eq_pidist//=.
  rewrite /eq_pidist in Hle1, Hle2.
  setoid_rewrite Hle1. setoid_rewrite Hle2.
  reflexivity.
Qed.

Global Instance pidist_bind_mono X Y :
  Proper (pointwise_relation X (@le_pidist Y) ==> @le_pidist X ==> @le_pidist Y) (pidist_bind X Y).
Proof. intros ?? ? ?? ?. eapply pival_bind_mono; eauto. Qed.

Global Instance pidist_bind_proper X Y :
  Proper (pointwise_relation X (@eq_pidist Y) ==> @eq_pidist X ==> @eq_pidist Y) (pidist_bind X Y).
Proof. intros ?? ? ?? ?. eapply pival_bind_proper; eauto. Qed.

Lemma pidist_union_comm:
  ∀ (X : Type) (Is1 Is2 : pidist X), eq_pidist (pidist_union Is1 Is2) (pidist_union Is2 Is1).
Proof. intros. rewrite /eq_pidist/pidist_union//=. apply punion_comm. Qed.

Lemma pidist_union_assoc:
  ∀ (X : Type) (Is1 Is2 Is3 : pidist X),
    eq_pidist (pidist_union Is1 (pidist_union Is2 Is3)) (pidist_union (pidist_union Is1 Is2) Is3).
Proof. intros. rewrite /eq_pidist/pidist_union//=. apply punion_assoc. Qed.

Lemma pidist_union_le: ∀ (X : Type) (Is Is' : pidist X), le_pidist Is (pidist_union Is Is').
Proof. intros. rewrite /eq_pidist/pidist_union//=. apply punion_le. Qed.

Lemma pidist_union_le_l:
  ∀ (X : Type) (Is Is1 Is2 : pidist X),
    le_pidist Is Is1 →
    le_pidist Is (pidist_union Is1 Is2).
Proof. intros. rewrite /eq_pidist/pidist_union//=. by apply punion_le_l. Qed.

Lemma pidist_union_le_r:
  ∀ (X : Type) (Is Is1 Is2 : pidist X),
    le_pidist Is Is2 →
    le_pidist Is (pidist_union Is1 Is2).
Proof. intros. rewrite /eq_pidist/pidist_union//=. by apply punion_le_r. Qed.

Lemma pidist_union_le_id:
  ∀ (X : Type) (Is1 Is2 : pidist X),
    le_pidist Is1 Is2 → eq_pidist (pidist_union Is1 Is2) Is2.
Proof. intros. rewrite /eq_pidist/pidist_union//=. by apply punion_le_id. Qed.

Lemma pidist_union_idemp: ∀ (X : Type) (Is : pidist X), eq_pidist (pidist_union Is Is) Is.
Proof. intros. rewrite /eq_pidist/pidist_union//=. by apply punion_idemp. Qed.

Lemma pidist_plus_union_distrib (X : Type) r Hpf (Is Is1 Is2 : pidist X):
    eq_pidist (pidist_plus r Hpf Is (pidist_union Is1 Is2))
              (pidist_union (pidist_plus r Hpf Is Is1) (pidist_plus r Hpf Is Is2)).
Proof.
  rewrite /eq_pidist/pidist_union/pidist_plus//=.
  setoid_rewrite pscale_punion_distrib.
  setoid_rewrite <-pplus_punion_distrib.
  reflexivity.
Qed.

Lemma pidist_union_bind:
  ∀ (A B : Type) (m1 m2 : pidist A) (f : A → pidist B),
    eq_pidist (x ← pidist_union m1 m2; f x) (pidist_union (x ← m1; f x) (x ← m2; f x)).
Proof.
  intros A B m1 m2 f. rewrite /eq_pidist/pidist_union/pidist_bind//=.
  apply pival_union_bind.
Qed.

Lemma pidist_plus_bind:
  ∀ (A B : Type) p Hpf (m1 m2 : pidist A) (f : A → pidist B),
    eq_pidist (x ← pidist_plus p Hpf m1 m2; f x) (pidist_plus p Hpf (x ← m1; f x) (x ← m2; f x)).
Proof.
  intros A B p Hpf m1 m2 f.
  rewrite /eq_pidist. rewrite /pidist_plus/pidist_bind.
  setoid_rewrite pival_plus_bind.
  setoid_rewrite pival_scale_bind.
  reflexivity.
Qed.

Lemma pidist_bind_congr_le_supp {A B} (m1 m2: pidist A) (f1 f2: A → pidist B) :
  le_pidist m1 m2 →
  (∀ a, In_psupport a m1 → le_pidist (f1 a) (f2 a)) →
  le_pidist (x ← m1; f1 x) (x ← m2; f2 x).
Proof.
  intros Hlem Hlef.
  rewrite /le_pidist.
  apply pival_bind_congr_le_supp; eauto.
Qed.

Lemma pidist_bind_congr_le {A B} (m1 m2: pidist A) (f1 f2: A → pidist B) :
  le_pidist m1 m2 →
  (∀ a, le_pidist (f1 a) (f2 a)) →
  le_pidist (x ← m1; f1 x) (x ← m2; f2 x).
Proof.
  intros Hlem Hlef.
  rewrite /le_pidist.
  apply pival_bind_congr_le; eauto.
Qed.

Lemma pidist_bind_congr {A B} (m1 m2: pidist A) (f1 f2: A → pidist B) :
  eq_pidist m1 m2 →
  (∀ a, eq_pidist (f1 a) (f2 a)) →
  eq_pidist (x ← m1; f1 x) (x ← m2; f2 x).
Proof.
  intros Hlem Hlef.
  rewrite /le_pidist.
  apply pival_bind_congr; eauto.
Qed.

Definition dist_of_pidist {X} (I: ival X) (Is: pidist X) (Hin: In I Is) : distrib (idx I) :=
  dist_of_ivdist {| ivd_ival := I; val_sum1 := (all_sum1 Is I Hin) |}.

Definition rvar_of_pidist {X: eqType} (I: ival X) (Is: pidist X) (Hin: In I Is) : rvar _ X :=
  rvar_of_ivdist {| ivd_ival := I; val_sum1 := (all_sum1 Is I Hin) |}.

Lemma pidist_plus_in_inv {A} p Hpf (Is1 Is2: pidist A) I:
  In I (pidist_plus p Hpf Is1 Is2) →
  ∃ (I1 I2: ivdist A), In (ivd_ival I1) Is1 ∧ In (ivd_ival I2) Is2
                       ∧ I = (ivdplus p Hpf I1 I2).
Proof.
  intros Hin. rewrite /ivdplus //=.
  destruct Hin as (I1a&I2a&Hin1a&Hin2a&Heq). subst.
  destruct Hin1a as (I1b&Hin1b&Heq). subst.
  destruct Hin2a as (I2b&Hin2b&Heq). subst.
  exists {| ivd_ival := I1b; val_sum1 := all_sum1 _ _ Hin1b |}.
  exists {| ivd_ival := I2b; val_sum1 := all_sum1 _ _ Hin2b |}.
  repeat split => //=.
Qed.

Lemma rvar_of_pidist_ivd {X: eqType} (I: ivdist X) (Is: pidist X) Hpf:
  eq_dist (rvar_of_pidist (ivd_ival I) Is Hpf) (rvar_of_ivdist I).
Proof.
  rewrite /rvar_of_pidist//=.
Qed.

Lemma pidist_plus_comm {X} (p: R) Hpf Hpf' (I1 I2: pidist X):
  eq_pidist (pidist_plus p Hpf I1 I2) (pidist_plus (1 - p) Hpf' I2 I1).
Proof.
  rewrite /eq_pidist/pidist_union/pidist_plus//=.
  replace (1 - (1 - p)) with p by nra.
  apply pplus_comm.
Qed.

Lemma pidist_plus_choice1 {X} Hpf (I1 I2: pidist X):
  eq_pidist (pidist_plus 1 Hpf I1 I2) I1.
Proof.
  rewrite /eq_pidist/pidist_union/pidist_plus//=.
  replace (1 - 1) with 0 by nra.
  setoid_rewrite pscale_1.
  setoid_rewrite pscale_0.
  apply pplus_0.
Qed.

(* The case where p = 0 or q = 0 can be simplified by other means *)
Lemma pidist_plus_plus {X} (Is1 Is2 Is3: pidist X) (p q: R) Hpf1 Hpf2 Hpf3 Hpf4 :
  0 < p →
  0 < q →
  le_pidist (pidist_plus p Hpf1 Is1 (pidist_plus q Hpf2 Is2 Is3))
            (pidist_plus (1 - (1 - p) * (1 - q)) Hpf3
                         (pidist_plus (p / (1 - (1 - p) * (1 - q))) Hpf4 Is1 Is2)
                         Is3).
Proof.
  intros.
  rewrite /pidist_plus/le_pidist//=.
  setoid_rewrite pscale_distrib.
  setoid_rewrite pplus_assoc.
  setoid_rewrite pscale_assoc.
  eapply pplus_proper.
  * eapply pplus_proper.
    ** eapply pscale_proper; try reflexivity.
       field. nra.
    ** eapply pscale_proper; try reflexivity.
       field. nra.
  * eapply pscale_proper; try reflexivity.
    field.
Qed.

Global Opaque pidist_ret.
Global Opaque pidist_bind.

Lemma eq_ival_support_coerce_aux {X} (I1 I2: ival X) :
  eq_ival I1 I2 →
  ∀ x, (∃ i2, ind I2 i2 = x ∧ val I2 i2 > 0) → (∃ i1, ind I1 i1 = x ∧ val I1 i1 > 0).
Proof.
  intros Hequiv x (i2&Hind&Hval).
  symmetry in Hequiv.
  destruct Hequiv as (h1&h2&?&?&Hind'&Hval').
  destruct (h1 (coerce_supp _ _ Hval)) as (i1&Hgt).
  exists (sval (h1 (coerce_supp _ _ Hval))).
  split.
  * rewrite Hind' => //=.
  * destruct (h1 _) => //=; repeat destruct Rgt_dec => //=.
Qed.

Lemma eq_ival_support_coerce {X} (I1 I2: ivdist X) :
  eq_ival I1 I2 →
  ∀ x, (∃ i2, ind I2 i2 = x ∧ val I2 i2 > 0) ↔ (∃ i1, ind I1 i1 = x ∧ val I1 i1 > 0).
Proof.
  intros; split; eapply eq_ival_support_coerce_aux; eauto; by symmetry.
Qed.

Lemma In_psupport_alt {X: Type} (x: X) (Is : pival X) :
  (∃ I, In I Is ∧ In_isupport x I) → In_psupport x Is.
Proof.
  intros (I&Hin&i&?&?).
  exists I, i; repeat split => //=.
Qed.

Lemma le_pidist_support_coerce_aux {X} (Is1 Is2: pidist X) :
  le_pidist Is2 Is1 →
  ∀ x, In_psupport x Is2 → In_psupport x Is1.
Proof.
  intros Hle x (I2&i2&Hin2&?&Hval).
  destruct (Hle I2 Hin2) as (I1&Heq&Hin1).
  symmetry in Heq.
  exists I1. edestruct (eq_ival_support_coerce_aux _ _ Heq) as (i1&?&?).
  { exists i2. split; eauto. }
  exists i1; repeat split; eauto.
Qed.

Lemma In_psupport_mret {X} (x : X) : In_psupport x (mret x).
Proof.
  eexists. unshelve (eexists); repeat split; try (by left).
  * rewrite //=.
  * rewrite //=. nra.
Qed.

Lemma In_psupport_mret_inv {X} (x y : X) : In_psupport x (mret y) → x = y.
Proof.
  intros (?&?&Hin&?&?). subst. rewrite //=.
  rewrite /mret//= in Hin. subst => //=.
Qed.

Lemma In_psupport_bind {X Y: Type} (Is: pival X) (f: X → pival Y) (x: X) (y: Y):
  In_psupport x Is →
  In_psupport y (f x) →
  In_psupport y (mbind f Is).
Proof.
  intros (I1&i1&Hin&Hind&Hval) (If&ifx&Hinf&Hindf&Hvalf).
    unshelve (edestruct (pival_mbind_in Is f I1) as (Ix&?&Heq&HIn); auto).
    { intros i2.
      destruct (eqVneq i1 i2).
      - exact If.
      - destruct (f (ind I1 i2)) as [Is' Hne].
        apply ClassicalEpsilon.constructive_indefinite_description in Hne as (I'&?).
       exact I'.
    }
    {
    intros i2.
    rewrite //=.
    destruct (eqVneq).
    * subst; auto.
    * intros. destruct (f (ind I1 i2)) as [Is' Hne] => //=.
      destruct ClassicalEpsilon.constructive_indefinite_description => //=.
    }
    apply In_psupport_alt.
    exists Ix; split; first done.
    rewrite /In_isupport.
    symmetry in Heq.
    rewrite //= in Heq.
    eapply (eq_ival_support_coerce_aux _ _ Heq).
    unshelve (eexists).
    { rewrite //=.
      exists i1. destruct eqVneq as [?|Hneq]; last first.
      { rewrite eq_refl in Hneq. exfalso; auto. }
      eauto.
    }
    split.
    * rewrite //=.
      subst. destruct eqVneq as [?|Hneq] => //=; last first.
      { exfalso. rewrite eq_refl in Hneq. auto. }
    * rewrite //=.
      subst. destruct eqVneq as [?|Hneq] => //=; last first.
      { exfalso. rewrite eq_refl in Hneq. auto. }
      clear -Hval Hvalf. nra.
Qed.

Lemma pidist_union_foldleft_proper {X} l (m1 m2: pidist X):
  eq_pidist m1 m2 →
  eq_pidist (fold_left pidist_union l m1)
            (fold_left pidist_union l m2).
Proof.
  revert m1 m2; induction l => m1 m2 //=.
  intros Hequiv. eapply IHl.
  setoid_rewrite Hequiv.
  reflexivity.
Qed.

Lemma pidist_union_foldright_proper {X} l (m1 m2: pidist X):
  eq_pidist m1 m2 →
  eq_pidist (fold_right pidist_union m1 l)
            (fold_right pidist_union m2 l).
Proof.
  revert m1 m2; induction l => m1 m2 //=.
  intros Hequiv. setoid_rewrite IHl; first reflexivity; eauto.
  reflexivity.
Qed.

Lemma pidist_union_foldleft_hd {X} (l: list (pidist X)) (m1 m2: pidist X):
  eq_pidist (pidist_union m2 (fold_left pidist_union l m1))
            (fold_left pidist_union l (pidist_union m2 m1)).
Proof.
  revert m1 m2; induction l => m1 m2 //=; try reflexivity.
  setoid_rewrite IHl.
  eapply pidist_union_foldleft_proper.
  setoid_rewrite pidist_union_assoc.
  reflexivity.
Qed.

Lemma pidist_union_foldright_hd {X} (l: list (pidist X)) (m1 m2: pidist X):
  eq_pidist (pidist_union m2 (fold_right pidist_union m1 l))
            (fold_right pidist_union (pidist_union m2 m1) l).
Proof.
  revert m1 m2; induction l => m1 m2 //=; try reflexivity.
  setoid_rewrite IHl.
  setoid_rewrite IHl.
  eapply pidist_union_foldright_proper.
  setoid_rewrite pidist_union_assoc.
  setoid_rewrite (pidist_union_comm _ a m2).
  reflexivity.
Qed.

Lemma fold_left_right_pidist_union {X} (l: list (pidist X)) (m: pidist X):
  eq_pidist (fold_left pidist_union l m)
            (fold_right pidist_union m l).
Proof.
  revert m.
  induction l => m //=; try reflexivity.
  setoid_rewrite <-IHl.
  setoid_rewrite pidist_union_foldleft_hd.
  apply pidist_union_foldleft_proper.
  setoid_rewrite pidist_union_comm at 1.
  reflexivity.
Qed.

Lemma pidist_union_foldleft_bind (A B: Type) (l: list (pidist A)) (m: pidist A)
      (f: A → pidist B) :
  eq_pidist (x ← fold_left pidist_union l m; f x)
            (fold_left pidist_union (map (mbind f) l) (mbind f m)).
Proof.
  revert m.
  induction l => m //=; first reflexivity.
  setoid_rewrite <-pidist_union_foldleft_hd.
  setoid_rewrite pidist_union_bind.
  setoid_rewrite IHl. setoid_rewrite pidist_union_foldleft_hd. reflexivity.
Qed.

Lemma pidist_join {X A: Type} (INH: X) (Iss: X → pidist A) : pidist A.
  unshelve econstructor.
  - exact (pival_join INH Iss).
  - abstract (intros I (Is&?); eapply all_sum1; eauto).
Defined.

Lemma pidist_join_bind {X A B: Type} (INH: X) Iss (f: A → pidist B) :
  eq_pidist (a ← pidist_join INH Iss; f a)
           (pidist_join INH (λ x, a ← Iss x; f a)).
Proof. apply pival_join_bind. Qed.

Lemma pidist_join_ext {X A: Type} (INH INH': X) (Iss Iss': X → pidist A):
  (∀ x : X, eq_pidist (Iss x) (Iss' x)) →
  eq_pidist (pidist_join INH Iss) (pidist_join INH' Iss').
Proof. apply pival_join_ext. Qed.

Global Instance pidist_join_Proper {X A: Type} :
  Proper (eq ==> pointwise_relation X (eq_pidist) ==> @eq_pidist A) pidist_join.
Proof.
  intros ?? Heq ?? Heq'.
  eapply pidist_join_ext; eauto.
Qed.

Lemma easy_fix_eq:
  ∀ (A : Type) (R : A → A → Prop) (Rwf : well_founded R) (P : A → Type)
    (F : ∀ x : A, (∀ y : A, R y x → P y) → P x),
    ∀ x : A, Fix Rwf P F x = F x (λ (y : A) (_ : R y x), Fix Rwf P F y).
Proof.
  intros. apply Init.Wf.Fix_eq.
  intros. assert (f = g) as ->; last done.
  apply FunctionalExtensionality.functional_extensionality_dep => ?.
  apply FunctionalExtensionality.functional_extensionality_dep => ?. done.
Qed.

Inductive Ord :=
  | OrdO : Ord
  | OrdS : Ord → Ord
  | OrdLim : (nat → Ord) → Ord.

Inductive Ord_lt_gen : Ord → Ord → Prop :=
  | Ord_lt_gen_S O: Ord_lt_gen O (OrdS O)
  | Ord_lt_gen_Lim f i: Ord_lt_gen (f i) (OrdLim f).

Definition Ord_lt := Relation_Operators.clos_trans _ Ord_lt_gen.

Require Import Program.Wf Wellfounded Wellfounded.Transitive_Closure.

Lemma wf_Ord_lt: well_founded Ord_lt.
Proof.
  apply wf_clos_trans.
  intros O.
  induction O.
  - econstructor. intros y Hlt. remember OrdO as x eqn:Heq. revert Heq.
    induction Hlt; try congruence.
  - econstructor. intros y Hlt. inversion Hlt. subst. eauto.
  - econstructor. intros y Hlt. inversion Hlt. subst. eauto.
Qed.

Lemma Ord_lt_O o: o ≠ OrdO → { x: Ord | Ord_lt x o }.
Proof.
  induction o.
  - congruence.
  - intros. exists o. do 2 econstructor.
  - intros. exists (o O). do 2 econstructor.
Qed.

Lemma Ord_lt_lim o: { x: Ord | Ord_lt x (OrdLim o) }.
Proof.
  eapply Ord_lt_O; eauto.
Qed.

Lemma Ord_lt_S o: { x: Ord | Ord_lt x (OrdS o) }.
Proof.
  eapply Ord_lt_O; eauto.
Qed.

Definition pidist_iter_aux {A: Type} (m: A → pidist A) : Ord → A → pidist A.
  refine(Fix wf_Ord_lt (fun _ => A → pidist A)
             (fun o rec =>
               λ a,
               match o as o' return (o = o' → pidist A) with
               | OrdO => λ eq, mret a
               | _ => λ eq,
                  x ← m a;
                  @pidist_join { o'' : Ord | Ord_lt o'' o } _ _
                               (λ n', rec (proj1_sig n') (proj2_sig n') x)
               end Init.Logic.eq_refl)).
  { subst; apply Ord_lt_S. }
  { subst; apply Ord_lt_lim. }
Defined.

Definition pidist_iter {A: Type} (m: A → pidist A) : A → pidist A.
  intros a. eapply (@pidist_join Ord _ OrdO (λ n, pidist_iter_aux m n a)).
Defined.

Lemma pidist_iter_aux_unfold_lim {A: Type} (m: A → pidist A) o a:
  pidist_iter_aux m (OrdLim o) a =
  x ← m a;
  @pidist_join { o'' : Ord | Ord_lt o'' (OrdLim o) } _ (Ord_lt_lim o)
               (λ n', pidist_iter_aux m (proj1_sig n') x).
Proof.
  rewrite /pidist_iter_aux//= easy_fix_eq //=; eauto.
Qed.

Lemma pidist_iter_aux_unfold_S {A: Type} (m: A → pidist A) o a:
  pidist_iter_aux m (OrdS o) a =
  x ← m a;
  @pidist_join { o'' : Ord | Ord_lt o'' (OrdS o) } _ (Ord_lt_S o)
               (λ n', pidist_iter_aux m (proj1_sig n') x).
Proof.
  rewrite /pidist_iter_aux//= easy_fix_eq //=; eauto.
Qed.

Lemma pidist_iter_unfold_l {A: Type} (m: A → pidist A) (a: A):
    le_pidist (mret a)
              (pidist_iter m a).
Proof.
  intros I Hin. exists I. split; first done. exists OrdO => //=.
  rewrite /pidist_iter_aux//= easy_fix_eq //=.
Qed.

Lemma pidist_iter_unfold_r {A: Type} (m: A → pidist A) (a: A):
    le_pidist (x ← m a; pidist_iter m x)
              (pidist_iter m a).
Proof.
  intros I Hin.
  edestruct (pival_mbind_in_inv_idxOf (m a) (pidist_iter m))
    as (I'&h&?&Hhspec&Heq); eauto.
  assert (∃ fn, ∀ i, ival.val I' i > 0 →
                    In (h i) (pidist_iter_aux m (fn (choice.pickle i)) (ival.ind I' i))) as (fn&Hn).
  { unshelve (eexists).
    { intros n.
      * destruct (@choice.pickle_inv (ival.idx I') n) as [i|].
        ** destruct (ClassicalEpsilon.excluded_middle_informative (ival.val I' i > 0)) as [Hgt|].
           *** specialize (Hhspec i Hgt) as Hhspec; eauto.
               apply ClassicalEpsilon.constructive_indefinite_description in Hhspec
                 as (o&?).
               exact o.
           *** exact OrdO.
        ** exact OrdO.
    }
    intros i. rewrite //= pickleK_inv.
    intros Hgt.
    destruct ClassicalEpsilon.excluded_middle_informative; last (exfalso; eauto).
    destruct ClassicalEpsilon.constructive_indefinite_description.
    eauto.
  }
  edestruct (pival_mbind_in_alt2_idxOf
               (m a)
               (λ x, @pidist_join { o'' : Ord | Ord_lt o'' (OrdLim fn) } _ (Ord_lt_lim _)
                               (λ n', pidist_iter_aux m (proj1_sig n') x)) _ h)
    as (I''&?&Hin2).
    { eexists; split; eauto.  }
    { intros. rewrite //=.
      unshelve (eexists).
      { exists (fn (pickle i)). do 2 econstructor. }
      rewrite //=.
      eapply Hn. eauto.
    }
    eexists. split; last first.
    { exists (OrdLim fn).
      rewrite pidist_iter_aux_unfold_lim. eapply Hin2.
    }
    rewrite -Heq. eauto.
Qed.

Lemma pidist_iter_unfold {A: Type} (m: A → pidist A) (a: A):
  eq_pidist (pidist_iter m a)
            (pidist_union (mret a) (x ← m a; pidist_iter m x)).
Proof.
  split.
  - intros I Hin.
    destruct Hin as (o&Hin).
    destruct o.
    * exists I. split; first done.
      left. rewrite /pidist_iter_aux easy_fix_eq in Hin. done.
    * rewrite pidist_iter_aux_unfold_S in Hin.
      eapply pidist_bind_congr_le in Hin as (I'&Heq&Hin).
      { exists I'; split; first done. right. eapply Hin. }
      { reflexivity. }
      intros a' I' (o'&Hin').
      exists I'; split; eauto. exists (sval o'). eauto.
    * rewrite pidist_iter_aux_unfold_lim in Hin.
      eapply pidist_bind_congr_le in Hin as (I'&Heq&Hin).
      { exists I'; split; first done. right. eapply Hin. }
      { reflexivity. }
      intros a' I' (o'&Hin').
      exists I'; split; eauto. exists (sval o'). eauto.
  - intros I [Hin1|Hin2].
    * eapply pidist_iter_unfold_l; eauto.
    * eapply pidist_iter_unfold_r; eauto.
Qed.

Lemma pidist_union_fold_left_join {X: Type} (l: list (pidist X)) (m: pidist X):
  eq_pidist (fold_left pidist_union l m)
            (@pidist_join { x | List.In x (m :: l) } X (exist _ m (or_introl Logic.eq_refl)) sval).
Proof.
  revert m.
  induction l as [| a l] => m.
  - rewrite //=. split.
    * intros I Hin. exists I; split; first done. unshelve eexists.
      { exists m. by left. }
      rewrite //=.
    * intros I ((m'&[|[]])&Hin). subst.
      exists I. split; auto.
  - rewrite //= -pidist_union_foldleft_hd.
    split.
    * intros I [Hin|Hin].
      ** exists I; split; first done. unshelve eexists.
         { exists m. by left. }
         rewrite //=.
      ** destruct (IHl a) as [Hle1 Hle2].
         specialize (Hle1 _ Hin). edestruct Hle1 as (I'&Heq&Hin').
         exists I'; split; auto.
         destruct Hin' as ((m'&Hinl)&Hin').
         unshelve eexists.
         { exists m'. right. auto. }
         rewrite //=.
    * intros I ((m'&Hinl)&Hin).
      destruct Hinl as [Hhd|Hinl'].
      ** subst.  exists I; split; auto. left. auto.
      ** edestruct (IHl a) as [Hle1 Hle2].
         rewrite //= in Hin.
         edestruct (Hle2 I) as (I'&?&?).
         { unshelve (eexists).
           { exists m'. auto. }
           rewrite //=.
         }
         exists I'; split; auto.
         right. eauto.
Qed.


Require Import timel_listupto_spec.

Definition type_LF_155 :=  PLAN ->  nat ->  nat ->  nat -> (Prop * (List.list term)).

Definition F_155 : type_LF_155:= (fun   u1 u2 _ _ => ((timel (listUpTo u1 u2)) = (timel u1), (Term id_timel ((Term id_listUpTo ((model_PLAN u1):: (model_nat u2)::nil))::nil))::(Term id_timel ((model_PLAN u1)::nil))::nil)).
Definition F_167 : type_LF_155:= (fun    _  _ _ _ => ((timel Nil) = (timel Nil), (Term id_timel ((Term id_Nil nil)::nil))::(Term id_timel ((Term id_Nil nil)::nil))::nil)).
Definition F_173 : type_LF_155:= (fun   u6 u2 u3 u5 => ((le u3 u2) = true -> (timel (Cons (C u3 u5) Nil)) = (timel (Cons (C u3 u5) u6)), (Term id_le ((model_nat u3):: (model_nat u2)::nil))::(Term id_true nil)::(Term id_timel ((Term id_Cons ((Term id_C ((model_nat u3):: (model_nat u5)::nil)):: (Term id_Nil nil)::nil))::nil))::(Term id_timel ((Term id_Cons ((Term id_C ((model_nat u3):: (model_nat u5)::nil)):: (model_PLAN u6)::nil))::nil))::nil)).
Definition F_179 : type_LF_155:= (fun   u6 u2 u3 u5 => ((le u3 u2) = false -> (timel (Cons (C u3 u5) (listUpTo u6 u2))) = (timel (Cons (C u3 u5) u6)), (Term id_le ((model_nat u3):: (model_nat u2)::nil))::(Term id_false nil)::(Term id_timel ((Term id_Cons ((Term id_C ((model_nat u3):: (model_nat u5)::nil)):: (Term id_listUpTo ((model_PLAN u6):: (model_nat u2)::nil))::nil))::nil))::(Term id_timel ((Term id_Cons ((Term id_C ((model_nat u3):: (model_nat u5)::nil)):: (model_PLAN u6)::nil))::nil))::nil)).
Definition F_182 : type_LF_155:= (fun   u6 u2 u3 u5 => ((le u3 u2) = true -> (time (C u3 u5)) = (timel (Cons (C u3 u5) u6)), (Term id_le ((model_nat u3):: (model_nat u2)::nil))::(Term id_true nil)::(Term id_time ((Term id_C ((model_nat u3):: (model_nat u5)::nil))::nil))::(Term id_timel ((Term id_Cons ((Term id_C ((model_nat u3):: (model_nat u5)::nil)):: (model_PLAN u6)::nil))::nil))::nil)).
Definition F_188 : type_LF_155:= (fun    _ u2 u3 u5 => ((le u3 u2) = true -> (time (C u3 u5)) = (time (C u3 u5)), (Term id_le ((model_nat u3):: (model_nat u2)::nil))::(Term id_true nil)::(Term id_time ((Term id_C ((model_nat u3):: (model_nat u5)::nil))::nil))::(Term id_time ((Term id_C ((model_nat u3):: (model_nat u5)::nil))::nil))::nil)).
Definition F_185 : type_LF_155:= (fun   u6 u2 u3 u5 => ((le u3 u2) = false -> (time (C u3 u5)) = (timel (Cons (C u3 u5) u6)), (Term id_le ((model_nat u3):: (model_nat u2)::nil))::(Term id_false nil)::(Term id_time ((Term id_C ((model_nat u3):: (model_nat u5)::nil))::nil))::(Term id_timel ((Term id_Cons ((Term id_C ((model_nat u3):: (model_nat u5)::nil)):: (model_PLAN u6)::nil))::nil))::nil)).
Definition F_191 : type_LF_155:= (fun    _ u2 u3 u5 => ((le u3 u2) = false -> (time (C u3 u5)) = (time (C u3 u5)), (Term id_le ((model_nat u3):: (model_nat u2)::nil))::(Term id_false nil)::(Term id_time ((Term id_C ((model_nat u3):: (model_nat u5)::nil))::nil))::(Term id_time ((Term id_C ((model_nat u3):: (model_nat u5)::nil))::nil))::nil)).

Definition LF_155 := [F_155, F_167, F_173, F_179, F_182, F_188, F_185, F_191].

Function f_155 (u1: PLAN) (u2: nat) {struct u1} : PLAN :=
 match u1, u2 with
| Nil, _ => Nil
| (Cons (C u3 u5) u6), _ => Nil
end.

Lemma main_155 : forall F, In F LF_155 -> forall u1, forall u2, forall u3, forall u4, (forall F', In F' LF_155 -> forall e1, forall e2, forall e3, forall e4, less (snd (F' e1 e2 e3 e4)) (snd (F u1 u2 u3 u4)) -> fst (F' e1 e2 e3 e4)) -> fst (F u1 u2 u3 u4).
Proof.
intros F HF u1 u2 u3 u4; case_In HF; intro Hind.

	(* GENERATE on [ 155 ] *)

rename u1 into _u1. rename u2 into _u2. rename u3 into d_u3. rename u4 into d_u4.
rename _u1 into u1. rename _u2 into u2.

revert Hind.

pattern u1, u2, (f_155 u1 u2). apply f_155_ind.

(* case [ 167 ] *)

intros _u1 _u2.  intro eq_1. intro. intro Heq2. rewrite <- Heq2.  intro HFabs0.
assert (Hind := HFabs0 F_167). clear HFabs0.
assert (HFabs0 : fst (F_167 Nil 0 0 0)).
apply Hind. trivial_in 1. unfold snd. unfold F_167. unfold F_155. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_155. unfold F_167.
auto.

intros _u1 _u2. intro u3. intro u5. intro u6.  intro eq_1. intro. intro Heq2. rewrite <- Heq2.  intro HFabs0.
case_eq (le u3 _u2); [intro H | intro H].

(* case [ 173 ] *)

assert (Hind := HFabs0 F_173). clear HFabs0.
assert (HFabs0 : fst (F_173 u6 _u2 u3 u5)).
apply Hind. trivial_in 2. unfold snd. unfold F_173. unfold F_155. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_155. unfold F_173. simpl in H. repeat(simpl; rewrite H). repeat(simpl in HFabs0; rewrite H in HFabs0). try (auto || (intro H0; contradict H0)).
auto.

(* case [ 179 ] *)

assert (Hind := HFabs0 F_179). clear HFabs0.
assert (HFabs0 : fst (F_179 u6 _u2 u3 u5)).
apply Hind. trivial_in 3. unfold snd. unfold F_179. unfold F_155. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_155. unfold F_179. simpl in H. repeat(simpl; rewrite H). repeat(simpl in HFabs0; rewrite H in HFabs0). try (auto || (intro H0; contradict H0)).
auto.

	(* TAUTOLOGY on [ 167 ] *)

unfold fst. unfold F_167.
auto.

	(* REWRITING on [ 173 ] *)

rename u1 into _u6. rename u2 into _u2. rename u3 into _u3. rename u4 into _u5.
rename _u6 into u6. rename _u2 into u2. rename _u3 into u3. rename _u5 into u5.
assert (Res := Hind F_182). clear Hind.
assert (HFabs1 : fst (F_182 u6 u2 u3 u5)).
apply Res. trivial_in 4. unfold snd. unfold F_182. unfold F_173. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_173. unfold fst in HFabs1. unfold F_182 in HFabs1.
pattern (C u3 u5), Nil. simpl (timel _). cbv beta.
 simpl. auto.

	(* REWRITING on [ 179 ] *)

rename u1 into _u6. rename u2 into _u2. rename u3 into _u3. rename u4 into _u5.
rename _u6 into u6. rename _u2 into u2. rename _u3 into u3. rename _u5 into u5.
assert (Res := Hind F_185). clear Hind.
assert (HFabs1 : fst (F_185 u6 u2 u3 u5)).
apply Res. trivial_in 6. unfold snd. unfold F_185. unfold F_179. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_179. unfold fst in HFabs1. unfold F_185 in HFabs1.
pattern (C u3 u5), (listUpTo u6 u2). simpl (timel _). cbv beta.
 simpl. auto.

	(* REWRITING on [ 182 ] *)

rename u1 into _u6. rename u2 into _u2. rename u3 into _u3. rename u4 into _u5.
rename _u6 into u6. rename _u2 into u2. rename _u3 into u3. rename _u5 into u5.
assert (Res := Hind F_188). clear Hind.
assert (HFabs1 : fst (F_188 Nil u2 u3 u5)).
apply Res. trivial_in 5. unfold snd. unfold F_188. unfold F_182. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_182. unfold fst in HFabs1. unfold F_188 in HFabs1.
pattern (C u3 u5), u6. simpl (timel _). cbv beta.
 simpl. auto.

	(* TAUTOLOGY on [ 188 ] *)

unfold fst. unfold F_188.
auto.

	(* REWRITING on [ 185 ] *)

rename u1 into _u6. rename u2 into _u2. rename u3 into _u3. rename u4 into _u5.
rename _u6 into u6. rename _u2 into u2. rename _u3 into u3. rename _u5 into u5.
assert (Res := Hind F_191). clear Hind.
assert (HFabs1 : fst (F_191 Nil u2 u3 u5)).
apply Res. trivial_in 7. unfold snd. unfold F_191. unfold F_185. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_185. unfold fst in HFabs1. unfold F_191 in HFabs1.
pattern (C u3 u5), u6. simpl (timel _). cbv beta.
 simpl. auto.

	(* TAUTOLOGY on [ 191 ] *)

unfold fst. unfold F_191.
auto.

Qed.

(* the set of all formula instances from the proof *)
Definition S_155 := fun f => exists F, In F LF_155 /\ exists e1, exists e2, exists e3, exists e4, f = F e1 e2 e3 e4.

Theorem all_true_155: forall F, In F LF_155 -> forall u1: PLAN, forall u2: nat, forall u3: nat, forall u4: nat, fst (F u1 u2  u3  u4).
Proof.
let n := constr:(4) in
let p := constr:(S(S(n))) in
intros;
let G := fresh "G" in
let x := fresh "x" in
apply wf_subset with (R:=@snd_rpo_mul P Prop max_size) (S:=S_155);
[(* 1 *) apply wf_snd_rpo_mul, prec_wf
|(* 2 *) idtac
|(* 3 *) eexists; split; [ eassumption | idtac]; do_nat n ltac:(eexists); reflexivity
];

intros x G;
do_nat p ltac:(elim G; intro; clear G; intro G);
rewrite G in * |- *; clear G; clear x;
intro G;
apply main_155;
 [assumption | idtac];
intros;
apply G;
 [ idtac | assumption ];
eexists; split;
 [idtac | do_nat n ltac:(eexists); reflexivity];
assumption.
Qed.

Theorem true_155: forall (u1: PLAN) (u2: nat), (timel (listUpTo u1 u2)) = (timel u1).
Proof.
do 2 intro.
apply (all_true_155 F_155);
 (trivial_in 0) ||
 (repeat constructor).
Qed.