(*
  This file contains the main soundness proof supporting our coinductive
  verification examples, by defining a semantics of claims,
  proving that it can be expressed as a greatest fixpoint,
  and then proving a soundness theorem giving a way to prove
  a set of claims are all true.

  In this file (used in most examples), 'reaches x P' holds
  if any execution path from configuration x is either infinite or
  reaches a configuration satisfying P.

  'reaches' is shown to be the greatest fixpoint of the 'step' function.

  'stable_sound' is plain coinduction theorem for 'reaches' and 'step',
  'proved_sound' is the generalized coinduction theorem also allowing
  the "proof" rules defined in 'trans'.
 *)
Set Contextual Implicit.
Set Implicit Arguments.

Section relations.
Variables (cfg : Type) (cstep : cfg -> cfg -> Prop).

Definition Spec : Type := cfg -> (cfg -> Prop) -> Prop.

(* Soundness *)
CoInductive reaches (k : cfg) (P : cfg -> Prop) : Prop :=
  (* reaches : Spec, but defining k and P as parameters
     gives a cleaner definition and induction principle. *)
| rdone : P k -> reaches k P
| rstep : forall k', cstep k k' -> reaches k' P -> reaches k P.

Definition sound (Rules : Spec) : Prop :=
  forall x P, Rules x P -> reaches x P.

Inductive step (X : Spec) (k : cfg) (P : cfg -> Prop) : Prop :=
  (* step : Spec -> Spec *)
| sdone : P k -> step X k P
| sstep : forall k', cstep k k' -> X k' P -> step X k P.

Inductive next (X : Spec) (k : cfg) (P : cfg -> Prop) : Prop :=
| nstep : forall k', cstep k k' -> X k' P -> next X k P.

Lemma reaches_stable :
  (forall x P, reaches x P -> step reaches x P).
Proof. destruct 1;econstructor;eassumption. Qed.

CoFixpoint stable_sound (Rules : Spec)
  (Hstable : forall x P, Rules x P -> step Rules x P)
  : sound Rules :=
  fun x P H =>
  match Hstable _ _ H with
    | sdone pf => rdone pf
    | sstep Hstep H' =>
        rstep Hstep (stable_sound Hstable H')
  end.

(*
Inductive derived (X : Spec) k P : Prop :=
| dclaim : X k P -> derived X k P
| ddone : P k -> derived X k P
| dstep : forall k', cstep k k' -> derived X k' P -> derived X k P
| dtrans' : forall Q, derived X k Q -> (forall k', Q k' -> derived X k' P)
    -> derived X k P
| dproved : reaches k P -> derived X k P.
*)

Inductive trans (X : Spec) (k : cfg) (P : cfg -> Prop) : Prop :=
  (* trans : Spec -> Spec *)
  | ddone : P k -> trans X k P
  | dtrans' : forall Q, trans X k Q -> (forall k', Q k' -> trans X k' P) -> trans X k P
  | drule : X k P -> trans X k P
  | dstep : forall k', cstep k k' -> trans X k' P -> trans X k P
  | dvalid : reaches k P -> trans X k P
  .
Definition dtrans_valid (X : Spec) (k : cfg) (P Q : cfg -> Prop)
  (rule : reaches k Q) (rest : forall k', Q k' -> trans X k' P) : trans X k P :=
  @dtrans' X k P Q (dvalid rule) rest.
Definition dtrans (X : Spec) (k : cfg) (P Q : cfg -> Prop)
  (rule : X k Q) (rest : forall k', Q k' -> trans X k' P) : trans X k P :=
  @dtrans' X k P Q (drule rule) rest.

Lemma trans_stable (Rules : Spec) :
  (forall x P, Rules x P -> step (trans Rules) x P)
  -> (forall x P, trans Rules x P -> step (trans Rules) x P).
induction 2;eauto using step.
destruct IHtrans; eauto using step, dtrans'.
destruct H0; eauto using step,dvalid.
Qed.

Lemma proved_sound (Rules : Spec) :
  (forall x P, Rules x P -> step (trans Rules) x P)
  -> sound Rules.
unfold sound.
intros H x P R.
eapply stable_sound.
apply trans_stable. eassumption.
apply drule. assumption.
Qed.

End relations.


(**********************************************************************)
(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                        SF-Calculus                                 *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                       Fixpoints.v                                  *)
(*                                                                    *)
(*                        Barry Jay                                   *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Omega List Max.
Require Import IntensionalLib.SF_calculus.Test.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Wave_as_SF.SF_Terms.
Require Import IntensionalLib.Wave_as_SF.SF_Tactics.
Require Import IntensionalLib.Wave_as_SF.SF_reduction.
Require Import IntensionalLib.Wave_as_SF.SF_Normal.
Require Import IntensionalLib.Wave_as_SF.SF_Closed.
Require Import IntensionalLib.Wave_as_SF.Substitution.
Require Import IntensionalLib.Wave_as_SF.SF_Eval.
Require Import IntensionalLib.Wave_as_SF.Star.

Lemma maxvar_op: forall o, maxvar (Op o) = 0.  Proof. split_all. Qed.

(* delayed application *)

Definition app_comb M N :=

App (App (Op Node) (App (Op Node) i_op))
    (App (App (Op Node) (App (Op Node) (App k_op N))) (App k_op M)).

Lemma app_comb_red : forall M N P, sf_red (App (app_comb M N) P) (App (App M N) P).
Proof.
unfold app_comb; unfold_op; split_all.
eapply succ_red. eapply2 s_red.
eapply succ_red.  eapply app_sf_red.
 eapply2 s_red.  eapply2 s_red. all: auto.
eapply succ_red. eapply app_sf_red.
 eapply app_sf_red. eapply2 k_red. all: auto.
eapply2 preserves_app_sf_red.
eapply2 preserves_app_sf_red. eval_tac. eval_tac.
Qed.

Lemma lift_rec_preserves_app_comb:
forall M1 M2 n k, lift_rec (app_comb M1 M2) n k = app_comb (lift_rec M1 n k) (lift_rec M2 n k).
Proof. intros; unfold app_comb; unfold_op; split_all. Qed.

Lemma subst_rec_preserves_app_comb:
forall i M N k, subst_rec (app_comb i M) N k = app_comb (subst_rec i N k) (subst_rec M N k).
Proof. intros; unfold app_comb; unfold_op; split_all.  Qed.

Lemma app_comb_normal: forall i M, normal i -> normal M -> normal (app_comb i M).
Proof. intros; unfold app_comb; unfold_op. repeat eapply2 nf_compound. Qed.

Lemma maxvar_app_comb : forall M N,  maxvar (app_comb M N) = max(maxvar M) (maxvar N).
Proof. intros; unfold app_comb. unfold_op; split_all. rewrite max_swap. auto. Qed.

Lemma rank_app_comb: forall M N, rank (app_comb M N) > rank (App M N).
Proof. intros; unfold app_comb; split_all. omega. Qed.

Lemma program_app_comb2 : forall M N, program (app_comb M N) -> program M /\ program N.
Proof.
  unfold app_comb; unfold_op; intros. inversion H. simpl in H1.  max_out.
assert(normal M /\ normal N). clear - H0.
  inversion H0. inversion H4. clear - H3.  inversion H3; subst. inversion H4.
clear - H1 H2. inversion H1; inversion H2; subst.
inversion H10. inversion H5. inversion H10. split; auto.
clear - H4. inversion H4. inversion H3. inversion H2. auto. auto.
inversion H1; split; unfold program; auto.
Qed.

Lemma app_comb_preserves_sf_red:
forall M M' N N',
sf_red M M' -> sf_red N N' ->
sf_red (app_comb M N) (app_comb M' N').
Proof.  intros; unfold app_comb. repeat eapply2 preserves_app_sf_red.  Qed.

Definition a_op := star_opt (star_opt (app_comb (Ref 1) (Ref 0))).

Ltac unfold_op := unfold a_op, app_comb, i_op, k_op, node.

Lemma a_op2_red: forall M N, sf_red (App (App a_op M) N) (app_comb M N).
Proof.
unfold a_op; intros. eapply transitive_red. eapply2 star_opt_beta2.
unfold subst. repeat rewrite subst_rec_preserves_app_comb.
unfold subst_rec; fold subst_rec. insert_Ref_out.
unfold subst_rec; fold subst_rec. insert_Ref_out. unfold lift.
repeat rewrite lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
repeat rewrite lift_rec_null.
auto.
Qed.

Lemma a_op_red: forall M N P, sf_red (App (App (App a_op M) N) P) (App (App M N) P).
Proof.
unfold a_op; intros. eapply transitive_red. eapply preserves_app_sf_red.
eapply2 star_opt_beta2. auto.
unfold subst. repeat rewrite subst_rec_preserves_app_comb.
eapply transitive_red. eapply2 app_comb_red.
unfold subst_rec; fold subst_rec. insert_Ref_out.
unfold subst_rec; fold subst_rec. insert_Ref_out. unfold lift.
repeat rewrite lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
repeat rewrite lift_rec_null.
auto.
Qed.

Fixpoint A_k k :=
match k with
| 0 => i_op
| 1 => i_op
| 2 => a_op
| S k1 => star_opt (star_opt (App (A_k k1) (app_comb (Ref 1) (Ref 0))))
end.

Lemma A_k_closed: forall k, k < 7 -> maxvar (A_k k) = 0.
Proof.
induction k; split_all.
induction k; split_all.
induction k; split_all.
induction k; split_all.
induction k; split_all.
induction k; split_all.
induction k; split_all.
noway.
Qed.

Lemma A_k_normal : forall k, k<5 -> normal (A_k k).
Proof.
induction k; split_all; unfold_op; auto.
induction k; split_all; unfold_op; auto.
induction k; split_all; unfold_op; auto.
repeat apply nf_compound; unfold_op; auto.
induction k; split_all;
repeat apply nf_compound; unfold_op; auto.
induction k; split_all;
repeat apply nf_compound; unfold_op; auto.
omega.
Qed.

 Lemma A_5_normal : normal (A_k 5).
Proof.
split_all; unfold_op; auto.
repeat apply nf_compound; unfold_op; auto.
Qed.

Lemma A_6_normal : normal (A_k 6).
Proof.
split_all; unfold_op; auto.
repeat apply nf_compound; unfold_op; auto.
Qed.

Hint Resolve A_k_closed A_k_normal.

Ltac nf_out :=
  unfold a_op; unfold_op;
  match goal with
    | |- normal ?M =>
      match M with
        | star_opt _ => apply star_opt_normal; nf_out
        | app_comb _ _ => apply app_comb_normal; nf_out
        | App (App (Op _) _) _ => apply nf_compound; [| |auto]; nf_out
        | App (Op _) _ => apply nf_compound; [| |auto]; nf_out
        | lift _ _ => unfold lift; nf_out
        | lift_rec _ _ _ => eapply2 lift_rec_preserves_normal; nf_out
        | _ => split_all
      end
    | _ => auto
        end.

(* fixpoints that wait *)

(* Y2 *)

Definition omega2 :=
star_opt(star_opt (App (Ref 0) (app_comb (app_comb (Ref 1) (Ref 1)) (Ref 0)))).

Definition Y2 f := app_comb (app_comb omega2 omega2) f.

Lemma Y2_program: forall f, program f -> program (Y2 f).
Proof.
  unfold Y2, omega2; split_all; unfold program; split;
unfold subst, subst_rec; fold subst_rec; nf_out; try eapply2 H.
unfold subst, subst_rec; fold subst_rec; nf_out; try eapply2 H.
unfold maxvar; fold maxvar. simpl. nf_out. simpl.
  rewrite max_zero; eapply2 H.
Qed.

Lemma omega2_omega2 :
forall f, sf_red (App (App omega2 omega2) f) (App f (Y2 f)).
Proof.
unfold omega2 at 1. intros.
eapply transitive_red. eapply2 star_opt_beta2.
unfold subst, subst_rec; fold subst_rec.
insert_Ref_out. unfold lift.  rewrite lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite lift_rec_null. eapply2 preserves_app_sf_red.
rewrite ! subst_rec_preserves_app_comb.
repeat (rewrite subst_rec_ref; insert_Ref_out).
unfold lift. rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.  rewrite lift_rec_null. unfold Y2. auto.
Qed.

Lemma Y2_fix_f: forall M N,
sf_red (App (Y2 M) N) (App (App M (Y2 M)) N).
Proof.
unfold Y2 at 1.  intros.
eapply transitive_red. eapply2 app_comb_red.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 omega2_omega2. auto. auto.
Qed.

(* Y3 *)

Definition omega3 :=
star_opt(star_opt (star_opt (App (App (Ref 1)
  (star_opt (app_comb (app_comb (app_comb (Ref 3) (Ref 3)) (Ref 2)) (Ref 0))))
                                    (Ref 0)))).

Definition Y3 f := star_opt (app_comb (app_comb (app_comb omega3 omega3) (lift 1 f)) (Ref 0)).

Lemma omega3_program: program omega3.
Proof.
split; auto. unfold omega3; nf_out.  eapply2 nf_active.  eapply2 nf_active.
unfold subst, subst_rec; fold subst_rec; nf_out; try eapply2 H; cbv; auto.
Qed.

Lemma Y3_program: forall f, program f -> program (Y3 f).
Proof.
intros.  unfold Y3; split; auto.
nf_out; try eapply2 omega3_program.   eapply2 H.
(* 1 *)
rewrite maxvar_star_opt. rewrite ! maxvar_app_comb.
replace (maxvar omega3) with 0 by eapply2 omega3_program. simpl.
replace (maxvar (lift 1 f)) with 0.
auto.  unfold lift; rewrite lift_rec_closed.
assert(maxvar f = 0) by eapply2 H; auto.
eapply2 H.
Qed.

Lemma omega3_omega3 :
forall f M, sf_red (App (App (App omega3 omega3) f) M) (App (App f (Y3 f)) M).
Proof.
unfold omega3 at 1. intros.
eapply transitive_red. eapply2 star_opt_beta3.
unfold subst; rewrite ! subst_rec_app.
rewrite ! subst_rec_preserves_star_opt.
rewrite ! subst_rec_preserves_app_comb.
repeat (rewrite ! subst_rec_ref; insert_Ref_out).
unfold lift; rewrite ! lift_rec_lift_rec; try omega. unfold plus.
rewrite ! subst_rec_lift_rec; try omega. rewrite ! lift_rec_null.
rewrite ! (lift_rec_closed omega3).
unfold Y3.  auto.
unfold omega3; cbv; auto.
Qed.

Lemma Y3_fix_f: forall M N P,
sf_red (App (App (Y3 M) N) P) (App (App (App M (Y3 M)) N) P).
Proof.
unfold Y3 at 1.  intros.
eapply transitive_red. eapply preserves_app_sf_red. eapply star_opt_beta. auto.
unfold subst, subst_rec; fold subst_rec.
rewrite ! subst_rec_preserves_app_comb.
rewrite ! (subst_rec_closed omega3).
2: unfold omega3; cbv; omega.
unfold lift; rewrite subst_rec_lift_rec; try omega.
unfold subst_rec; fold subst_rec. insert_Ref_out. unfold lift.
rewrite ! lift_rec_null.
eapply transitive_red. eapply2 app_comb_red.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red. eapply2 app_comb_red.
auto. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 omega3_omega3. auto. auto.
Qed.

(*

Definition omega_k k :=
star_opt(star_opt (App (Ref 0) (app_comb (app_comb (app_comb (A_k (S k)) (Ref 1)) (Ref 1))
                                    (Ref 0)))).

Definition Y_k k := app_comb (app_comb (A_k (S k)) (omega_k k)) (omega_k k).

Lemma omega_k_normal: forall k, k<4 -> normal (omega_k k).
Proof.
intros; unfold omega_k. repeat eapply2 star_opt_normal.
eapply2 nf_active.  repeat eapply2 app_comb_normal.
eapply2 A_k_normal. omega.
Qed.

(*
Lemma omega_4_normal: normal (omega_k 4).
Proof.
intros; unfold omega_k. repeat eapply2 star_opt_normal.
eapply2 nf_active.  repeat eapply2 app_comb_normal.
eapply2 A_5_normal.
Qed.

*)
Hint Resolve A_k_closed A_k_normal omega_k_normal.

Lemma omega_omega :
forall k M, k<4 -> sf_red (App (App (omega_k k) (omega_k k)) M) (App M (app_comb (Y_k k) M)).
Proof.
unfold omega_k at 1. intros.
eapply transitive_red. eapply2 star_opt_beta2.
unfold subst, subst_rec; fold subst_rec.
insert_Ref_out. unfold lift.  rewrite lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite lift_rec_null. eapply2 preserves_app_sf_red.
repeat rewrite subst_rec_preserves_app_comb.
repeat rewrite (subst_rec_closed (A_k (S k))); try (rewrite A_k_closed; omega).
rewrite ! subst_rec_ref; insert_Ref_out. unfold pred.
rewrite ! subst_rec_ref; insert_Ref_out.
unfold lift. rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.  rewrite lift_rec_null. unfold Y_k. auto.
Qed.

Lemma Y_k_program: forall k, k<4 -> program (Y_k k).
Proof.
intros. unfold program. split.
  unfold Y_k. repeat eapply2 app_comb_normal. eapply2 A_k_normal. omega.
 unfold Y_k. rewrite !  maxvar_app_comb.
rewrite A_k_closed; try omega.
unfold omega_k.
rewrite ! maxvar_star_opt. unfold maxvar; fold maxvar.
rewrite ! maxvar_app_comb.
rewrite ! A_k_closed; try omega. simpl. auto.
Qed.

Lemma Y_k_normal: forall k, k<4 -> normal (Y_k k). Proof. eapply2 Y_k_program. Qed.
Lemma Y_k_closed: forall k, k<4 -> maxvar (Y_k k) = 0. Proof. eapply2 Y_k_program. Qed.

(* restore ?

Lemma Y2_fix: forall M N,
sf_red (App (App (Y_k 2) M) N) (App (App M (app_comb (Y_k 2) M)) N).
Proof.
unfold Y_k at 1.  intros.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto. auto.
unfold A_k; fold A_k.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 star_opt_beta2. auto. auto.
unfold subst

rewrite ! (
app_comb_red. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto. auto.

 unfold_op.  eval_tac. eval_tac. eval_tac. eval_tac.
  eval_tac. eval_tac. eval_tac. eval_tac.   eval_tac. eval_tac. eval_tac. eval_tac.
  eval_tac. eval_tac. eval_tac. eval_tac.   eval_tac. eval_tac. eval_tac. eval_tac.
  eval_tac. eval_tac. eval_tac. eval_tac.   eval_tac. eval_tac. eval_tac. eval_tac.
  eval_tac.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red.  eapply succ_red. eapply2 f_op_red. auto.
eval_tac. eval_tac. eval_tac.
eapply transitive_red. eapply preserves_app_sf_red. eapply omega_omega. eval_tac.
  eval_tac.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply succ_red. eapply2 f_op_red. auto. auto. auto. auto. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply succ_red. eapply2 f_op_red. auto. auto. auto.
eapply2 preserves_app_sf_red. eapply2 preserves_app_sf_red. unfold_op.
eapply2 preserves_app_sf_red. eapply2 preserves_app_sf_red.
eapply2 preserves_app_sf_red. eapply2 preserves_app_sf_red.
eval_tac. eval_tac.
Qed.

Lemma Y3_fix: forall M N P,
sf_red (App (App (App (Y_k 3) M) N) P) (App (App (App M (app_comb (Y_k 3) M)) N) P).
Proof.
unfold Y_k at 1.  intros.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 app_comb_red. auto. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply2 app_comb_red. auto. auto. auto.
unfold A_k; fold A_k. unfold_op.  eval_tac. eval_tac. eval_tac. eval_tac.
  eval_tac. eval_tac. eval_tac. eval_tac.   eval_tac. eval_tac. eval_tac. eval_tac.
  eval_tac. eval_tac. eval_tac. eval_tac.   eval_tac. eval_tac. eval_tac. eval_tac.
  eval_tac. eval_tac. eval_tac. eval_tac.   eval_tac. eval_tac. eval_tac. eval_tac.
  eval_tac. eval_tac. eval_tac. eval_tac.   eval_tac. eval_tac. eval_tac. eval_tac.
  eval_tac. eval_tac. eval_tac. eval_tac.   eval_tac. eval_tac. eval_tac. eval_tac.
  eval_tac.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red.  eapply preserves_app_sf_red.
eapply succ_red. eapply2 f_op_red. auto.
eval_tac. eval_tac.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply succ_red. eapply2 f_op_red. auto.  auto.
eval_tac. eval_tac. eval_tac.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply omega_omega.  eval_tac.   eval_tac. eval_tac.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply succ_red. eapply2 f_op_red. auto. auto. eval_tac.  auto. auto. auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
 eapply preserves_app_sf_red.
eapply succ_red. eapply2 f_op_red. auto. auto. auto. auto.
eapply2 preserves_app_sf_red. eapply2 preserves_app_sf_red. eapply2 preserves_app_sf_red.
unfold_op.
eapply2 preserves_app_sf_red. eapply2 preserves_app_sf_red.
eapply2 preserves_app_sf_red. eapply2 preserves_app_sf_red.
eval_tac. eval_tac.
Qed.

*)

Lemma Y4_fix: forall M N P Q,
sf_red (App (App (App (App (Y_k 4) M) N) P) Q) (App (App (App (App M (app_comb (Y_k 4) M)) N) P) Q).
Proof.
unfold Y_k at 1.  intros.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply2 app_comb_red. auto. auto.  auto.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply preserves_app_sf_red. eapply2 app_comb_red.
 auto. auto. auto. auto.
unfold A_k; fold A_k.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red.  eapply preserves_app_sf_red.
eapply2 star_opt_beta2. auto. auto. auto. auto.
unfold subst; rewrite ! subst_rec_app.
rewrite ! subst_rec_preserves_star_opt.
rewrite ! subst_rec_app.
rewrite ! subst_rec_preserves_star_opt.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red.
eapply2 star_opt_beta2. auto. auto. auto.
unfold subst; rewrite ! subst_rec_app.
rewrite ! subst_rec_preserves_star_opt.
rewrite ! subst_rec_app.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 star_opt_beta2. auto. auto.
unfold subst; rewrite ! subst_rec_app.
rewrite ! (subst_rec_closed a_op).
all: cycle 1.
unfold_op. split_all.
rewrite ! subst_rec_preserves_app_comb.
rewrite ! subst_rec_ref; insert_Ref_out.
rewrite ! subst_rec_ref; insert_Ref_out.
rewrite ! subst_rec_ref; insert_Ref_out.
rewrite ! subst_rec_ref; insert_Ref_out.
rewrite ! subst_rec_ref; insert_Ref_out.
rewrite ! subst_rec_ref; insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
eapply transitive_red.
eapply a_op_red.
eapply2 preserves_app_sf_red.
eapply transitive_red. eapply2 app_comb_red.
eapply2 preserves_app_sf_red.
eapply transitive_red. eapply2 app_comb_red.
eapply2 preserves_app_sf_red.
eapply transitive_red. eapply2 app_comb_red.
unfold omega_k at 1.
eapply transitive_red. eapply2 star_opt_beta2.
unfold subst; rewrite ! subst_rec_app.
rewrite ! subst_rec_ref; insert_Ref_out.
rewrite ! subst_rec_preserves_app_comb.
 rewrite ! subst_rec_ref; insert_Ref_out.
 rewrite ! subst_rec_ref; insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
rewrite ! subst_rec_lift_rec; try omega.
rewrite lift_rec_null.
rewrite ! subst_rec_closed.
eapply2 zero_red.
rewrite A_k_closed.
 omega. omega.
rewrite ! subst_rec_closed.
rewrite A_k_closed.
 omega. omega.
rewrite A_k_closed.
 omega. omega.
Qed.

*)

Fixpoint size M :=
match M with
| Ref _ => 1
| Op _ => 1
| App M1 M2 => S(size M2 + size M1)
end .

Lemma size_Y2: size (Y2 (Op Node)) = 481.
  Proof. cbv. auto. Qed.

(*
Notation "A ~ B" := (App A B) (at level 79, left associativity).
Notation S := (Op Sop).
Notation K := (App (Op Fop) (Op Fop)).
Notation I := (App (App (Op Sop) (App (Op Fop) (Op Fop))) (App (Op Fop) (Op Fop))).

Print Y2_comb_val.

Lemma Y2_val: Y_k 2 = Y2_comb_val.
Proof.  cbv. auto. Qed.

Definition a_op_val :=
 (S ~
    (S ~ (K ~ S) ~
     (S ~ (K ~ (S ~ (K ~ S))) ~
      (S ~ (S ~ (K ~ S) ~ (S ~ (K ~ K) ~ (S ~ (K ~ S) ~ (S ~ (K ~ K) ~ I)))) ~
         (K ~ (S ~ (K ~ K) ~ I))))) ~ (K ~ (K ~ I))).

Lemma a_op_value : a_op  = a_op_val.
Proof. cbv. auto. Qed.

Lemma a_op_size : size a_op_val = 113.
Proof. cbv. auto. Qed.

  *)


Require Export GeoCoq.Elements.OriginalProofs.lemma_3_7a.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_3_5b :
   forall A B C D,
   BetS A B D -> BetS B C D ->
   BetS A C D.
Proof.
intros.
assert (BetS A B C) by (conclude axiom_innertransitivity).
assert (BetS A C D) by (conclude lemma_3_7a).
close.
Qed.

End Euclid.


Require Import Reals Coquelicot.Coquelicot Coquelicot.Series.
Require Import ProofIrrelevance EquivDec.
Require Import Sums utils.Utils Morphisms.
Require Import Lia Lra.
Require Import Coq.Logic.FunctionalExtensionality.
From mathcomp Require Import ssreflect ssrfun seq.
Require Import ExtLib.Structures.Monad ExtLib.Structures.MonadLaws.
Require Import ExtLib.Structures.Functor.

Import MonadNotation FunctorNotation.
Set Bullet Behavior "Strict Subproofs".
Require List.
Require Import Permutation.

(*

****************************************************************************************
This file defines the pmf monad (also called the finitary Giry monad) which is a monad
of finitely supported probability measures on a set. The construction is very general,
and we don't need to work in that generality. Our main application is to use this monad
to define and reason about Markov Decision Processes.

We also add results on conditional probability and conditional expectation, everything
tailored to the discrete case.
****************************************************************************************

 *)

(* Helper lemmas. Move to RealAdd. *)

Fixpoint list_fst_sum {A : Type} (l : list (nonnegreal*A)): R  :=
  match l with
  | nil => 0
  | (n,_) :: ns => n + list_fst_sum ns
  end.

Definition list_fst_sum' {A : Type} (l : list (nonnegreal*A)) : R :=
  list_sum (map (fun x => nonneg (fst x)) l).

Lemma list_fst_sum_compat {A : Type} (l : list (nonnegreal*A)) : list_fst_sum l = list_fst_sum' l.
Proof.
  induction l.
  * unfold list_fst_sum' ; simpl ; reflexivity.
  * unfold list_fst_sum'. destruct a. simpl.
    rewrite IHl. f_equal.
Qed.

Lemma list_sum_is_nonneg {A : Type} (l : list(nonnegreal*A)) : 0 <= list_fst_sum l.
Proof.
  induction l.
  simpl ; lra.
  simpl. destruct a as [n].
  assert (0 <= n) by apply (cond_nonneg n).
  apply (Rplus_le_le_0_compat _ _ H).
  lra.
Qed.

Lemma prod_nonnegreal : forall (a b : nonnegreal), 0 <= a*b.
Proof.
  intros (a,ha) (b,hb).
  exact (Rmult_le_pos _ _ ha hb).
Qed.

Lemma div_nonnegreal : forall (a b : nonnegreal), 0 <> b -> 0 <= a/b.
Proof.
  intros (a,ha) (b,hb) Hb.
  apply (Rdiv_le_0_compat).
  apply ha. simpl in *. case hb.
  trivial. intros H. firstorder.
Qed.

Lemma mknonnegreal_assoc (r1 r2 r3 : nonnegreal) :
  mknonnegreal _ (prod_nonnegreal (mknonnegreal _ (prod_nonnegreal r1 r2) ) r3) = mknonnegreal _ (prod_nonnegreal r1 (mknonnegreal _ (prod_nonnegreal r2 r3))).
Proof.
  apply nonneg_ext; simpl.
  lra.
Qed.

Lemma Rone_mult_nonnegreal (r : nonnegreal) (hr : 0 <= R1*r) : mknonnegreal (R1*r) hr = r.
Proof.
  destruct r as [r hr'].
  simpl. assert (r = R1 * r) by lra.
  simpl in hr. revert hr.
  rewrite <- H. intros.
  f_equal. apply proof_irrelevance.
Qed.

Lemma list_fst_sum_cat {A : Type} (l1 l2 : list (nonnegreal * A)) :
  list_fst_sum (l1 ++ l2) = (list_fst_sum l1) + (list_fst_sum l2).
Proof.
  induction l1.
  * simpl ; nra.
  * simpl ; destruct a; nra.
Qed.

Definition nonneg_list_sum {A : Type} (l : list (nonnegreal * A)) : nonnegreal
  := {|
  nonneg := list_fst_sum l;
  cond_nonneg := (list_sum_is_nonneg l)
|}.

Section Pmf.

(* Defines the record of discrete probability measures on a type. *)
Record Pmf (A : Type) := mkPmf {
  outcomes :> list (nonnegreal * A);
  sum1 : list_fst_sum outcomes = R1
 }.

 Global Arguments outcomes {_}.
 Global Arguments sum1 {_}.
 Global Arguments mkPmf {_}.

Lemma Pmf_ext  {A} (p q : Pmf A)  : outcomes p = outcomes q -> p = q.
Proof.
destruct p as [op sp].
destruct q as [oq sq].
rewrite /outcomes => ?. (* what's happening here? *)
subst. f_equal. apply proof_irrelevance.
Qed.

Lemma sum1_compat {B} (p : Pmf B) :
  list_sum (map (fun y : nonnegreal * B => nonneg (fst y)) (p.(outcomes))) = R1.
Proof.
  rewrite <- p.(sum1).
  rewrite list_fst_sum_compat.
  unfold list_fst_sum'. reflexivity.
Qed.

Lemma pure_sum1 {A} (a : A) : list_fst_sum [::(mknonnegreal R1 (Rlt_le _ _ Rlt_0_1),a)] = R1.
Proof.
  simpl. lra.
Qed.

Definition Pmf_pure : forall {A : Type}, A -> Pmf A := fun {A} (a:A) => {|
outcomes := [::(mknonnegreal R1 (Rlt_le _ _ Rlt_0_1),a)];
sum1 := pure_sum1 _
|}.

Global Instance Proper_pure {A : Type}: Proper (eq ==> eq) (@Pmf_pure A).
Proof.
  unfold Proper,respectful; intros.
  now subst.
Qed.

Fixpoint dist_bind_outcomes
         {A B : Type} (f : A -> Pmf B) (p : list (nonnegreal*A)) : list(nonnegreal*B) :=
  match p with
   | nil => nil
   | (n,a) :: ps =>
     map (fun (py:nonnegreal*B) => (mknonnegreal _ (prod_nonnegreal n py.1),py.2)) (f a).(outcomes) ++ (dist_bind_outcomes f ps)
  end.

Lemma dist_bind_outcomes_cat {A B : Type} (f : A -> Pmf B) (l1 l2 : list(nonnegreal*A)) :
  dist_bind_outcomes f (l1 ++ l2) = (dist_bind_outcomes f l1) ++ (dist_bind_outcomes f l2).
Proof.
  induction l1.
  * simpl; easy.
  * destruct a as [an aa]. simpl.
    rewrite <- catA. rewrite IHl1.
    reflexivity.
Qed.

Lemma list_fst_sum_const_mult {A B : Type} (f : A -> Pmf B) (n : nonnegreal) (a : A):
  list_fst_sum [seq (mknonnegreal _ (prod_nonnegreal n py.1), py.2) | py <- f a]
  = n*list_fst_sum [seq py | py <- f a].
Proof.
  destruct (f a) as [fa Hfa]. simpl. revert Hfa.
  generalize R1 as t. induction fa.
  * simpl; intros.
    auto with real.
  *
    simpl in *. destruct a0. intros t Htn0.
    rewrite (IHfa (t - n0)).
    specialize (IHfa (t-n0)). simpl. auto with real.
    rewrite <- Htn0. lra.
Qed.

Lemma list_fst_sum_const_div {A : Type} (l : list (nonnegreal*A)) {n : nonnegreal} (hn : 0 <> nonneg n) :
  list_fst_sum [seq (mknonnegreal _ (div_nonnegreal py.1 _ hn), py.2) | py <- l]
  = list_fst_sum [seq py | py <- l]/n.
Proof.
  generalize R1 as t. induction l.
  * simpl. intros H. lra.
  * simpl in *. destruct a. intros t. simpl.
    rewrite (IHl (t - n)).
    specialize (IHl (t-n)). simpl.
    lra.
Qed.

Lemma dist_bind_sum1 {A B : Type} (f : A -> Pmf B) (p : Pmf A) :
  list_fst_sum (dist_bind_outcomes f p.(outcomes)) = R1.
Proof.
  destruct p as [p Hp]. simpl.
  revert Hp. generalize R1 as t.
  induction p.
 *  simpl; intuition.
 *  simpl in *. destruct a as [n a]. intros t0 Hnt0.
    rewrite list_fst_sum_cat.  rewrite (IHp (t0-n)).
    rewrite list_fst_sum_const_mult. destruct (f a) as [fp Hfp]. simpl.
    rewrite map_id Hfp. lra.
    lra.
Qed.

Lemma dist_bind_sum1_compat {A B : Type} (f : A -> Pmf B) (p : Pmf A) :
  list_fst_sum' (dist_bind_outcomes f p.(outcomes)) = R1.
Proof.
  rewrite <-list_fst_sum_compat. apply dist_bind_sum1.
Qed.

Definition Pmf_bind {A B : Type} (p : Pmf A) (f : A -> Pmf B)  : Pmf B :={|
  outcomes := dist_bind_outcomes f p.(outcomes);
  sum1 := dist_bind_sum1 f p
  |}.

Global Instance Proper_bind {A B : Type}:
  Proper (eq ==> (pointwise_relation A eq) ==> eq) (@Pmf_bind A B).
Proof.
  unfold Proper, respectful, pointwise_relation.
  intros p q Hpq f g Hfg; subst.
  apply Pmf_ext.
  destruct q as [q Hq].
  unfold Pmf_bind; simpl.
  clear Hq.
  induction q; simpl; trivial.
  destruct a.
  f_equal; trivial.
  now rewrite Hfg.
Qed.

Global Instance Monad_Pmf : Monad Pmf := {|
  ret := @Pmf_pure;
  bind := @Pmf_bind;
|}.

(*We can use the nice bind and return syntax, since Pmf is now part of the Monad typeclass.*)
Open Scope monad_scope.

Lemma Pmf_ret_of_bind {A : Type} (p : Pmf A) : p >>= (fun a => ret a) = p.
Proof.
  apply Pmf_ext ; simpl.
  induction p.(outcomes).
  simpl. reflexivity.
  simpl. destruct a. rewrite IHl.
  f_equal. f_equal.
  destruct n.  apply nonneg_ext.
  apply Rmult_1_r.
Qed.

Lemma Pmf_bind_of_ret {A B : Type} (a : A) (f : A -> Pmf B) : (ret a) >>= f = f a.
Proof.
  apply Pmf_ext.
  simpl. rewrite cats0.
  rewrite <- map_id. apply eq_map.
  intros (n,b). simpl.
  now rewrite Rone_mult_nonnegreal.
Qed.

Lemma Pmf_bind_of_bind {A B C : Type} (p : Pmf A) (f : A -> Pmf B) (g : B -> Pmf C) :
  (p >>= f) >>= g = p >>= (fun a => (f a) >>= g).
Proof.
  apply Pmf_ext.
  destruct p as [pout Hp].
  revert Hp. simpl. generalize R1 as t.
  induction pout.
  * simpl ; easy.
  * simpl. destruct a as [an aa].
    intros t Ht. rewrite dist_bind_outcomes_cat. simpl.
    rewrite <- (IHpout (t-an)).
    destruct (f aa) as [faa Hfaa]. f_equal.
    revert Hfaa. simpl. generalize R1 as u.
    induction faa.
    - simpl. reflexivity.
    - destruct a as [an1 aa1].
      simpl. intros u Hu. rewrite map_cat.
      rewrite (IHfaa (u-an1)); clear IHfaa. f_equal. rewrite <- map_comp.
      unfold comp. simpl.
      apply List.map_ext; intros.
      f_equal.
      apply nonneg_ext. apply Rmult_assoc.
      lra.
    -
      lra.
Qed.

(* Global Instance Pmf_MonadLaws : MonadLaws Monad_Pmf := {| *)
(*   bind_of_return := @Pmf_bind_of_ret; *)
(*   bind_associativity := @Pmf_bind_of_bind; *)
(* | }.*)

Definition dist_bind_outcomes_alt
         {A B : Type} (f : A ->  list (nonnegreal * B)) (p : list (nonnegreal*A)) : list(nonnegreal*B) :=
  flatten (map (fun '(n,a) =>
                 map (fun (py:nonnegreal*B) => (mknonnegreal _ (prod_nonnegreal n py.1),py.2)) (f a)) p).

Definition dist_bind_outcomes_alt2
         {A B : Type} (f : A ->  list (nonnegreal * B)) (p : list (nonnegreal*A)) : list(nonnegreal*B) :=
  List.concat (List.map (fun na =>
                 List.map (fun (py:nonnegreal*B) => (mknonnegreal _ (prod_nonnegreal (fst na) py.1),py.2)) (f (snd na))) p).

Lemma dist_bind_outcomes_alt2_eq {A B : Type} (f : A ->  list (nonnegreal * B)) (p : list (nonnegreal*A)) :
  dist_bind_outcomes_alt f p = dist_bind_outcomes_alt2 f p.
Proof.
  induction p; simpl; trivial.
  unfold dist_bind_outcomes_alt, dist_bind_outcomes_alt2 in *.
  destruct a; simpl.
  rewrite IHp.
  firstorder.
Qed.

Instance dist_bind_outcomes_alt_eq_ext_proper {A B : Type} :
  Proper (pointwise_relation A eq ==> eq ==> eq) (@dist_bind_outcomes_alt A B).
Proof.
  intros ??????; subst.
  unfold dist_bind_outcomes_alt.
  f_equal.
  eapply eq_map.
  intros ?.
  destruct x0; simpl.
  rewrite H.
  eapply eq_map.
  intros ?.
  reflexivity.
Qed.

Lemma dist_bind_outcomes_alt_eq {A B : Type}
      (f : A -> Pmf  B)
      (p : list (nonnegreal*A)) :
  dist_bind_outcomes f p = dist_bind_outcomes_alt (fun x => (f x).(outcomes)) p.
Proof.
  unfold dist_bind_outcomes_alt.
  induction p; simpl; trivial.
  destruct a.
  simpl.
  now f_equal.
Qed.

Lemma dist_bind_outcomes_alt_comm {A B C : Type} (p:seq (nonnegreal * A)) (q:seq (nonnegreal * B)) (f : A -> B -> Pmf C) :
  Permutation (dist_bind_outcomes_alt2 (fun a : A => dist_bind_outcomes_alt2 (fun x : B => f a x) q) p)
    (dist_bind_outcomes_alt2 (fun a : B => dist_bind_outcomes_alt2 (fun x : A => (f^~ a) x) p) q).
Proof.
  unfold dist_bind_outcomes_alt2.
  erewrite List.map_ext.
  2: {
    intros.
    rewrite List.concat_map.
    rewrite List.map_map.
    reflexivity.
  }
  symmetry.
  erewrite List.map_ext.
  2: {
    intros.
    rewrite List.concat_map.
    rewrite List.map_map.
    reflexivity.
  }
  symmetry.
  repeat rewrite concat_map_concat'.
  rewrite concat_map_swap_perm.
  apply Permutation_concat.
  apply Permutation_concat.
  match goal with
  | [|- Permutation ?x ?y ] => cut (x = y); [intros eqqq; rewrite eqqq; reflexivity | ]
  end.
  repeat (apply List.map_ext; intros).
  repeat rewrite List.map_map.
  repeat (apply List.map_ext; intros).
  simpl.
  f_equal.
  apply nonneg_ext.
  lra.
Qed.

Lemma Pmf_bind_comm {A B C : Type} (p : Pmf A) (q : Pmf B) (f : A -> B -> Pmf C) :
  Permutation (Pmf_bind p (fun a => Pmf_bind q (f a))) (Pmf_bind q (fun b => Pmf_bind p (fun a => f a b))).
Proof.
  unfold Pmf_bind; simpl.
  destruct p as [p p1]; destruct q as [q q1].
  repeat rewrite dist_bind_outcomes_alt_eq; simpl.
  erewrite dist_bind_outcomes_alt_eq_ext_proper
  ; try (intros ?; rewrite dist_bind_outcomes_alt_eq; apply dist_bind_outcomes_alt2_eq)
  ; try reflexivity.
  erewrite (dist_bind_outcomes_alt_eq_ext_proper (fun x : B => dist_bind_outcomes (f^~ x) p))
  ; try (intros ?; rewrite dist_bind_outcomes_alt_eq; apply dist_bind_outcomes_alt2_eq)
  ; try reflexivity.
    repeat rewrite dist_bind_outcomes_alt2_eq; simpl.
  apply dist_bind_outcomes_alt_comm.
Qed.

(* The functorial action of Pmf. *)
Definition Pmf_map {A B : Type}(f : A -> B) (p : Pmf A) : Pmf B := p >>= (ret \o f).

Global Instance Pmf_Functor : Functor Pmf := {| fmap := @Pmf_map |}.

Lemma Pmf_map_id {A : Type} (p : Pmf A) : id <$> p = p.
Proof.
  simpl. unfold Pmf_map.
  now rewrite Pmf_ret_of_bind.
Qed.

Lemma Pmf_map_ret {A B : Type} (a : A) (f : A -> B) : f <$> (ret a) = ret (f a).
Proof.
  simpl.
  unfold Pmf_map.
  rewrite Pmf_bind_of_ret.
  now unfold comp.
Qed.

Lemma Pmf_map_bind {A B : Type} (p : Pmf A)  (f : A -> B) : p >>= (ret \o f) = f <$> p.
Proof.
  reflexivity.
Qed.

Lemma Pmf_map_comp {A B C : Type}(p : Pmf A) (f : A -> B)(g : B -> C) :
 g <$> (f <$> p) = (g \o f) <$> p.
Proof.
  simpl.
  unfold Pmf_map, comp.
  rewrite Pmf_bind_of_bind.
  now setoid_rewrite Pmf_bind_of_ret.
Qed.

Definition Pmf_prod {A B : Type} (p : Pmf A) (q : Pmf B) : Pmf (A*B) :=
  a <- p;;
  b <- q;;
  ret (a,b).

End Pmf.

Definition prob {A : Type} (l : seq(nonnegreal*A)) : nonnegreal :=
 mknonnegreal (list_fst_sum l) (list_sum_is_nonneg _).

(* Make all notations part of a single scope. *)
Notation "𝕡[ x ]" := (nonneg (prob x)) (at level 75, right associativity).

Section expected_value.

Open Scope fun_scope.
Arguments outcomes {_}.

Definition expt_value {A : Type} (p : Pmf A) (f : A -> R): R :=
  list_sum (map (fun x => (f x.2) * nonneg x.1) p.(outcomes)).

Global Instance expt_value_Proper {A : Type}:
  Proper (eq  ==> pointwise_relation A eq ==> eq) (@expt_value A).
intros p q Hpq f g Hfg.
rewrite Hpq.
apply list_sum_map_ext.
intros a. now f_equal.
Qed.

Lemma expt_value_zero {A : Type} (p : Pmf A) :
  expt_value p (fun a => 0) = 0.
Proof.
  unfold expt_value.
  induction p.(outcomes).
  - simpl;lra.
  - simpl. rewrite IHl. lra.
Qed.

Lemma expt_value_const_mul {A : Type} (p : Pmf A) (f : A -> R) (c : R):
  expt_value p (fun a => c * (f a)) = c * expt_value p (fun a => f a).
Proof.
  unfold expt_value.
  induction p.(outcomes).
  simpl ; lra.
  simpl. rewrite IHl. lra.
Qed.

Lemma expt_value_const_mul' {A : Type} (p : Pmf A) (f : A -> R) (c : R):
  expt_value p (fun a => (f a)*c) = c * expt_value p (fun a => f a).
Proof.
  unfold expt_value.
  induction p.(outcomes).
  simpl ; lra.
  simpl. rewrite IHl. lra.
Qed.

Lemma expt_value_add {A : Type} (p : Pmf A) (f1 f2 : A -> R) :
  expt_value p (fun x => f1 x + f2 x) = (expt_value p f1) + (expt_value p f2).
Proof.
  unfold expt_value.
  induction p.(outcomes).
  * simpl ; lra.
  * simpl. rewrite IHl. lra.
Qed.

Lemma expt_value_sub {A : Type} (p : Pmf A) (f1 f2 : A -> R) :
  expt_value p (fun x => f1 x - f2 x) = (expt_value p f1) - (expt_value p f2).
Proof.
  unfold expt_value.
  induction p.(outcomes).
  * simpl ; lra.
  * simpl. rewrite IHl. lra.
Qed.

Lemma expt_value_le {A : Type} (p : Pmf A) (f1 f2 : A -> R) :
  (forall a : A, f1 a <= f2 a) -> expt_value p f1 <= expt_value p f2.
Proof.
  intros Hf1f2. unfold expt_value.
  induction p.(outcomes).
  * simpl ; lra.
  * simpl. enough (f1 a.2 * a.1 <= f2 a.2 * a.1).
    apply (Rplus_le_compat _ _ _ _ H IHl).
    apply Rmult_le_compat_r. apply cond_nonneg.
    exact (Hf1f2 a.2).
Qed.

Lemma expt_value_sum_f_R0 {A : Type} (p : Pmf A) (f : nat -> A -> R) (N : nat) :
  expt_value p (fun a => sum_f_R0 (fun n => f n a) N) = sum_f_R0 (fun n => expt_value p (f n)) N.
Proof.
  unfold expt_value.
  induction p.(outcomes).
  * simpl. now rewrite sum_eq_R0.
  * simpl. rewrite IHl. rewrite sum_plus. f_equal.
    destruct a. simpl. rewrite <- scal_sum. apply Rmult_comm.
Qed.

Lemma sum_f_R0_Rabs_Series_aux_1 {A : Type} (p : Pmf A) (f : nat -> A -> R) (N : nat):
  sum_f_R0 (fun n => expt_value p (fun a => f n a)) N <= Rabs (sum_f_R0 (fun n => expt_value p (fun a => f n a)) N).
Proof.
  apply Rle_abs.
Qed.

Lemma sum_f_R0_Rabs_Series_aux_2 {A : Type} (p : Pmf A) (f : nat -> A -> R) (N : nat):
  Rabs (sum_f_R0 (fun n => expt_value p (fun a => f n a)) N) <= sum_f_R0 (fun n => Rabs (expt_value p (fun a => f n a))) N.
Proof.
  apply Rabs_triang_gen.
Qed.

Lemma expt_value_Rabs_Rle {A : Type} (p : Pmf A) (f : A -> R):
  Rabs (expt_value p f) <= expt_value p (fun a => Rabs (f a)).
Proof.
  unfold expt_value.
  induction p.(outcomes).
  * simpl. rewrite Rabs_R0 ; lra.
  * simpl. refine (Rle_trans _ _ _ _ _).
    apply Rabs_triang. rewrite Rabs_mult.
    rewrite (Rabs_pos_eq a.1). apply Rplus_le_compat.
    apply Rmult_le_compat_r. apply cond_nonneg. now right.
    apply IHl. apply cond_nonneg.
Qed.

Lemma ex_series_le_Reals
     : forall (a : nat -> R) (b : nat -> R),
    (forall n : nat, Rabs (a n) <= b n) -> ex_series b -> ex_series a.
Proof.
  intros a b Hab Hexb.
  apply (@ex_series_le _ _ a b).
  now apply Hab. assumption.
Qed.

Lemma expt_value_ex_series {A : Type} (p : Pmf A) (f : nat -> A -> R) :
  ex_series (fun n => expt_value p (fun a => Rabs (f n a))) ->
         ex_series (fun n => expt_value p (f n)).
Proof.
  intros Hex.
  refine (@ex_series_le_Reals _ _ _ _).
  intros n. apply expt_value_Rabs_Rle.
  assumption.
Qed.

Lemma expt_val_bdd_aux {A : Type} (g : nat -> A -> R) (p : Pmf A):
  (forall (a : A), is_lim_seq (fun n => g n a) 0) -> is_lim_seq (fun n => expt_value p (fun x => g n x)) 0.
Proof.
  intros H.
  unfold expt_value. rewrite is_lim_seq_Reals.
  unfold Un_cv.
  induction p.(outcomes).
  * simpl. intros eps0 H0. exists 0%nat.  rewrite R_dist_eq. intros n Hn. apply H0.
  * simpl in *. intros eps0 H0.
    enough (H0': eps0/4 > 0).
    specialize (IHl (eps0/4)%R H0').  destruct IHl as [N0 HN0].
    specialize (H a.2).
    revert H. rewrite is_lim_seq_Reals.
    intros H. unfold Un_cv in H.
    set (Ha := cond_nonneg a.1). case Ha.
    intro Ha1. clear Ha.
    enough (H1': eps0/(4 * a.1) > 0).
    specialize (H (eps0/(4 * a.1))%R H1').
    destruct H as [N1 HN1].
    exists (N0 + N1)%nat. intros n Hn.
    specialize (HN0 n).
    specialize (HN1 n).
    assert (Hn0 : (n >= N0)%nat) by lia.
    assert (Hn1 : (n >= N1)%nat) by lia.
    specialize (HN1 Hn1). specialize (HN0 Hn0).
    clear Hn0 ; clear Hn1.
    revert HN0. revert HN1.
    unfold R_dist. rewrite Rminus_0_r ; rewrite Rminus_0_r ; rewrite Rminus_0_r.
    intros HN0 HN1. refine (Rle_lt_trans _ _ _ _ _).
    apply Rabs_triang. rewrite Rabs_mult. rewrite (Rabs_pos_eq a.1).
    eapply Rlt_trans.
    assert ((eps0 / (4 * a.1))*a.1 + (eps0 / 4) = eps0/2). field ; lra.
    assert (Rabs (g n a.2) * a.1 + Rabs (list_sum [seq g n x.2 * nonneg (x.1) | x <- l])  < eps0/2).
    rewrite <-H.
    refine (Rplus_lt_compat _ _ _ _ _ _).
    now apply Rmult_lt_compat_r. assumption.
    apply H1. lra.
    now left. apply Rlt_gt. apply RIneq.Rdiv_lt_0_compat. assumption.
    lra.
    intros Ha1. rewrite <-Ha1. setoid_rewrite Rmult_0_r.
    setoid_rewrite Rplus_0_l. exists N0. intros n Hn.
    eapply Rlt_trans. specialize (HN0 n Hn). apply HN0.
    lra. lra.
Qed.

Lemma expt_value_Series {A : Type} (p : Pmf A) (f : nat -> A -> R) :
  (forall a:A, ex_series (fun n => f n a)) ->
         expt_value p (fun a => Series (fun n => f n a)) = Series (fun n => expt_value p (f n)).
Proof.
  intros Hex.
  symmetry.
  apply is_series_unique.
  rewrite is_series_Reals.
  unfold infinite_sum.
  intros eps Heps.
  setoid_rewrite <- expt_value_sum_f_R0.
  unfold R_dist. unfold Series. setoid_rewrite <-expt_value_sub.
  assert (Ha : forall a:A, is_series (fun n => f n a) (Series (fun n => f n a)) ).
  intros a. eapply (Series_correct _). apply (Hex a).
  assert (Hinf : forall a:A, infinite_sum (fun n => f n a) (Series (fun n => f n a)) ).
  intros a. rewrite <- is_series_Reals. apply Ha. clear Ha.
  unfold infinite_sum in Hinf. unfold Series in Hinf. unfold R_dist in Hinf.
  (* Change the name of the hypothesis from H to something else. *)
  assert (H : forall x, Rabs x = R_dist x 0). intros x. unfold R_dist. f_equal ; lra.
  setoid_rewrite H.
  setoid_rewrite H in Hinf.
  set (He := @expt_val_bdd_aux A).
  setoid_rewrite is_lim_seq_Reals in He.
  unfold Un_cv in He. apply He. apply Hinf. assumption.
Qed.

Lemma expt_value_pure {A : Type} (a : A) (f : A -> R) :
  expt_value (Pmf_pure a) f = f a.
Proof.
  unfold expt_value ; unfold Pmf_pure ; simpl.
  lra.
Qed.

Lemma expt_value_Series_aux_2 {A : Type} (p : Pmf A) (f : nat -> A -> R) (N : nat):
  expt_value p (fun a => sum_f_R0 (fun n => f n a) N) <= expt_value p (fun a => sum_f_R0 (fun n => Rabs (f n a)) N).
Proof.
  apply expt_value_le.
  intros a. induction N.
  * simpl. apply Rle_abs.
  * simpl. apply Rplus_le_compat ; try assumption.
    apply Rle_abs.
Qed.

Lemma expt_value_bind_aux {A B : Type} (p : Pmf A) (g : A -> Pmf B) (f : B -> R) (n : nonnegreal) :
forall a : A,  list_sum [seq (f x.2) * nonneg(x.1) * n | x <- (g a).(outcomes)] = list_sum [seq (f x.2) * nonneg(x.1) | x <- (g a).(outcomes)] * n.
Proof.
  intros a.
  induction (g a).(outcomes).
  * simpl ; lra.
  * rewrite map_cons. simpl. rewrite IHl. lra.
Qed.

Lemma expt_value_bind {A B : Type} (p : Pmf A) (g : A -> Pmf B) (f : B -> R) :
  expt_value (Pmf_bind p g) f = expt_value p (fun a => expt_value (g a) f).
Proof.
  unfold Pmf_bind.
  unfold expt_value. simpl.
  induction (p.(outcomes)).
  * simpl ; reflexivity.
  * destruct a. simpl. rewrite <-IHl. rewrite map_cat.
    rewrite list_sum_cat. f_equal.
    rewrite <-map_comp. rewrite <- (expt_value_bind_aux p).
    f_equal. apply List.map_ext.
    intros a0. simpl. lra.
Qed.

Lemma expt_value_bind' {A B : Type} (p : Pmf A) (g : A -> Pmf B) (f : A -> B -> R) :
 forall init:A, expt_value (Pmf_bind p g) (f init) = expt_value p (fun a => expt_value (g a) (f init)).
Proof.
  intros init.
  unfold Pmf_bind.
  unfold expt_value. simpl.
  induction (p.(outcomes)).
  * simpl ; reflexivity.
  * destruct a. simpl. rewrite <-IHl. rewrite map_cat.
    rewrite list_sum_cat. f_equal.
    rewrite <-map_comp. rewrite <- (expt_value_bind_aux p).
    f_equal. apply List.map_ext.
    intros a0. simpl. lra.
Qed.

Lemma expt_value_bind_ret {A B : Type} (a : A) (g : A -> Pmf B) (f : B -> R) :
  expt_value (Pmf_bind (Pmf_pure a) g) f = expt_value (g a) f.
Proof.
  rewrite expt_value_bind.
  rewrite expt_value_pure.
  reflexivity.
Qed.

Lemma expt_value_expt_value {A : Type} (p q : Pmf A) (f : A -> R) :
  expt_value p (fun a => expt_value q f) = (expt_value q f)*(expt_value p (fun a => 1)).
Proof.
  unfold expt_value.
  induction p.(outcomes).
  simpl ; lra.
  simpl. rewrite IHl. lra.
Qed.

Lemma expt_value_expt_value_pure {A : Type} (a : A) (p : Pmf A) (f : A -> R):
  expt_value p (fun a => expt_value (Pmf_pure a) f) = (expt_value p f).
Proof.
  f_equal. apply functional_extensionality. intros x.
  now rewrite expt_value_pure.
Qed.

Lemma expt_value_Rle {A : Type} {D : R} {f : A -> R} (hf : forall a:A, Rabs (f a) <= D) (p : Pmf A) :
  Rabs(expt_value p f) <= D.
Proof.
  eapply Rle_trans.
  apply expt_value_Rabs_Rle.
  unfold expt_value. rewrite <- Rmult_1_r.
  change (D*1) with (D*R1).  rewrite <- (sum1_compat p).
  induction p.(outcomes).
  * simpl ; lra.
  * simpl in *. rewrite Rmult_plus_distr_l.
    assert ( Rabs (f a.2) * a.1  <=  D * a.1). apply Rmult_le_compat_r. apply cond_nonneg.
    refine (Rle_trans _ _ _ _ _).
    apply Rle_abs. rewrite Rabs_Rabsolu.
    apply hf.
    refine (Rle_trans _ _ _ _ _).
    apply Rplus_le_compat.
    apply Rmult_le_compat_r.
    apply cond_nonneg. apply hf. apply IHl.
    now right.
Qed.

Lemma expt_value_bdd {A : Type} {D : R} {f : A -> R} (hf : forall a:A, (f a) <= D) (p : Pmf A) :
  (expt_value p f) <= D.
Proof.
  unfold expt_value. rewrite <- Rmult_1_r.
  change (D*1) with (D*R1).  rewrite <- (sum1_compat p).
  induction p.(outcomes).
  * simpl ; lra.
  * simpl in *. rewrite Rmult_plus_distr_l.
    assert ( f a.2 * a.1  <=  D * a.1). apply Rmult_le_compat_r. apply cond_nonneg.
    apply hf.
    now apply Rplus_le_compat.
Qed.

  Lemma expt_value_lbdd {A : Type} {D : R} {f : A -> R} (hf : forall a:A, D <= (f a)) (p : Pmf A) :
    D <= (expt_value p f).
  Proof.
    unfold expt_value.
    replace D with (D * R1) by lra.
    rewrite <- (sum1_compat p).
    induction p.(outcomes).
    * simpl; lra.
    * simpl in *. rewrite Rmult_plus_distr_l.
    assert ( D * a.1 <= f a.2 * a.1). apply Rmult_le_compat_r. apply cond_nonneg.
    apply hf.
    now apply Rplus_le_compat.
  Qed.

 Lemma expt_value_const {A : Type} (c : R) (p : Pmf A) : expt_value p (fun _ => c) = c.
  Proof.
    destruct p as [lp Hp].
    unfold expt_value.
    simpl.
    rewrite list_sum_const_mul.
    rewrite list_fst_sum_compat in Hp.
    unfold list_fst_sum' in Hp.
    rewrite Hp.
    lra.
  Qed.

  Lemma expt_value_sum_comm {A B : Type}
        (f : A -> B -> R) (p : Pmf B) (la : list A):
    expt_value p (fun b => list_sum (map (fun a => f a b) la)) =
    list_sum (List.map (fun a => expt_value p (fun b => f a b)) la).
 Proof.
   destruct p as [lp Hlp].
   unfold expt_value.
   simpl. clear Hlp.
   revert lp.
   induction lp.
   + simpl. symmetry.
     apply list_sum_map_zero.
   + simpl. rewrite IHlp.
     rewrite list_sum_map_add.
     f_equal. rewrite Rmult_comm.
     rewrite <-list_sum_const_mul.
     f_equal. apply List.map_ext; intros.
     lra.
 Qed.

 Lemma expt_value_minus {A : Type} (f : A -> R) (p : Pmf A):
   expt_value p (fun x => - (f x)) = - expt_value p f.
 Proof.
   apply Rplus_opp_r_uniq.
   rewrite <-expt_value_add.
   setoid_rewrite Rplus_opp_r.
   apply expt_value_const.
 Qed.

 Lemma expt_value_prod_pmf {A B : Type} (f : A -> B -> R) (p : Pmf A) (q : Pmf B):
   expt_value (Pmf_prod p q) (fun '(a,b) => f a b) = expt_value p (fun a => expt_value q (fun b => f a b)).
 Proof.
   unfold Pmf_prod; simpl.
   rewrite expt_value_bind.
   setoid_rewrite expt_value_bind.
   now setoid_rewrite expt_value_pure.
 Qed.

End expected_value.

Section variance.

  Definition variance {A : Type} (p : Pmf A) (f : A -> R) :=
    expt_value p (fun a => Rsqr((f a) - expt_value p f)).

  Lemma variance_eq {A : Type} (p : Pmf A) (f : A -> R):
    variance p f = expt_value p (fun a => (f a)²) - (expt_value p f)².
  Proof.
    unfold variance.
    setoid_rewrite Rsqr_plus.
    setoid_rewrite <-Rsqr_neg.
    setoid_rewrite Ropp_mult_distr_r_reverse.
    do 2 rewrite expt_value_add.
    rewrite Rplus_assoc. unfold Rminus. f_equal.
    rewrite expt_value_const.
    rewrite expt_value_minus.
    setoid_rewrite Rmult_assoc.
    rewrite expt_value_const_mul.
    rewrite expt_value_const_mul'.
    rewrite <-Rmult_assoc.
    replace (expt_value p [eta f]) with (expt_value p f) by reflexivity.
    unfold Rsqr.
    ring.
  Qed.

  Lemma variance_le_expt_value_sqr {A : Type} (p : Pmf A) (f : A -> R):
    variance p f <= expt_value p (fun a => (f a)²).
  Proof.
    rewrite variance_eq.
    rewrite Rle_minus_l.
    rewrite <-(Rplus_0_r) at 1.
    apply Rplus_le_compat_l.
    apply Rle_0_sqr.
  Qed.

  Definition total_variance {A : Type} (lp : list (Pmf A)) (lf : list (A -> R)): R :=
    list_sum (map (fun '(f,p) => variance p f) (zip lf lp)).

  Lemma list_sum_sqr_pos {A : Type} (f : A -> R) (l : list A):
    0 <= list_sum (map (fun x => (f x)²) l).
  Proof.
    apply list_sum_pos_pos'.
    rewrite List.Forall_forall; intros.
    rewrite List.in_map_iff in H *; intros.
    destruct H as [a [Ha HIna]].
    unfold comp in Ha; subst.
    apply Rle_0_sqr.
  Qed.

  Lemma total_variance_eq_sum {A : Type} (lp : list (Pmf A)) (lf : list (A -> R)) :
    total_variance lp lf = list_sum (map (fun '(f,p) => expt_value p (comp Rsqr f)) (zip lf lp))
                           - list_sum (map (fun '(f,p) => (expt_value p f)²) (zip lf lp)).
  Proof.
    rewrite <-list_sum_map_sub.
    unfold total_variance.
    apply list_sum_map_ext; intros.
    destruct x. apply variance_eq.
  Qed.

  Lemma total_variance_le_expt_sqr {A : Type} (lp : list (Pmf A)) (lf : list (A -> R)) :
    total_variance lp lf <= list_sum (map (fun '(f,p) => expt_value p (comp Rsqr f)) (zip lf lp)).
  Proof.
    rewrite total_variance_eq_sum.
    rewrite Rle_minus_l.
    rewrite <-(Rplus_0_r) at 1.
    apply Rplus_le_compat_l.
    apply list_sum_pos_pos'.
    rewrite List.Forall_forall; intros.
    rewrite List.in_map_iff in H *; intros.
    destruct H as [a [Ha HIna]].
    unfold comp in Ha; subst.
    destruct a; apply Rle_0_sqr.
  Qed.

End variance.


Inductive Expr0 :=
  | ex01 : Expr1 -> Expr0
  | add : Expr0 -> Expr1 -> Expr0
with Expr1 :=
  | ex12 : Expr2 -> Expr1
  | mul : Expr1 -> Expr2 -> Expr1
with Expr2 :=
  | lit : nat -> Expr2
  | grp : Expr0 -> Expr2.

Variant Token :=
  | Lit : nat -> Token
  | Plus
  | Times
  | Open
  | Close.

Require Import List.
Import ListNotations.

Fixpoint Expr0ToStr x := match x with
  | ex01 x1 => Expr1ToStr x1
  | add x0 x1 => Expr0ToStr x0 ++ [Plus] ++ Expr1ToStr x1
end with Expr1ToStr x := match x with
  | ex12 x2 => Expr2ToStr x2
  | mul x1 x2 => Expr1ToStr x1 ++ [Times] ++ Expr2ToStr x2
end with Expr2ToStr x := match x with
  | lit id => [ Lit id ]
  | grp x => [Open] ++ Expr0ToStr x ++ [Close]
end.

Theorem NoAmbiguity : forall x y, Expr0ToStr x = Expr0ToStr y -> x = y.


From Coq Require Import ZArith Reals Psatz.
From Coq Require Import Arith.Arith.
Require Import real_lemmas.
From Coquelicot Require Import Coquelicot.
Set Bullet Behavior "Strict Subproofs".

Require Import Interval.Tactic.

Open Scope R_scope.

(* Time step*)
Definition h := 1 / 32.
Definition ω := 1.

Definition leapfrog_stepR (h : R) (ic : R * R ) : R * R :=
  let q := snd ic in let p := fst ic in
  let q' := ( 1 - 0.5 * h^2*ω^2) * q + h * p  in
  let p' := ( 1 - 0.5 * h^2*ω^2) * p - 0.5 * h * (2 - 0.5 * h^2*ω^2 ) * q in
  (p', q').

(* assumes inputs of (p, w * q, w, n) *)
(* output q' will therefore be scaled appropriately *)
Fixpoint iternR (ic : R * R) (h : R) (n : nat): R * R:=
  match n with
  | 0%nat => ic
  | S n' => iternR (leapfrog_stepR h ic) h n'
end.

Lemma lfstepR_lfn:
  forall n ic h ,
  leapfrog_stepR h (iternR ic h n) = iternR (leapfrog_stepR h ic) h n.
Proof.
induction n.
- auto.
- simpl. auto.
Qed.

Lemma step_iternR:
  forall ic h n,
  iternR ic h (S n) = leapfrog_stepR h (iternR ic h n).
Proof.
induction n.
- auto.
- intros. rewrite -> IHn. simpl.
replace (leapfrog_stepR h0 (iternR ic h0 n)) with (iternR (leapfrog_stepR h0 ic) h0 n). destruct (leapfrog_stepR h0 ic).
all: symmetry; apply lfstepR_lfn.
Qed.

Lemma one_stepR_p_alt2:
  forall ic1 ic2: R * R,
  forall h,
  (fst (leapfrog_stepR h ic1) - fst (leapfrog_stepR h ic2)) =
  (1 - 0.5 * h ^ 2 * ω^2) * (fst ic1 - fst ic2) -
   0.5 * h * (2 - 0.5 * h^2 * ω^2) * (snd ic1 - snd ic2).
Proof.
intros. destruct ic1 as [x1 v1]. destruct ic2 as [x2 v2].
unfold leapfrog_stepR, fst, snd; field_simplify. nra.
Qed.

Lemma one_stepR_q_alt2:
  forall ic1 ic2: R * R,
  forall h: R,
  (snd (leapfrog_stepR h ic1) - snd (leapfrog_stepR h ic2)) =
  (1 - 0.5 * h ^ 2 * ω^2) * (snd ic1 - snd ic2) +   h *(fst ic1 - fst ic2).
Proof.
intros. destruct ic1 as [x1 v1]. destruct ic2 as [x2 v2].
unfold leapfrog_stepR, fst, snd; field_simplify; nra.
Qed.

Lemma step_iternR_2 :
  forall n : nat,
  forall x v h : R,
  (iternR (x,v) h (S n)) = leapfrog_stepR h (iternR (x,v) h n).
Proof.
intros.
rewrite step_iternR.
unfold iternR.
congruence.
Qed.

Lemma leapfrog_minus_args :
forall ic1 ic2 : (R * R),
forall h : R,
   Rprod_minus (leapfrog_stepR h ic1) (leapfrog_stepR h ic2)
 = leapfrog_stepR h (Rprod_minus ic1 ic2).
Proof.
intros.
destruct ic1; destruct ic2.
unfold leapfrog_stepR, Rprod_minus, fst ,snd.
f_equal; nra.
Qed.

Lemma leapfrog_plus_args :
forall ic1 ic2 : (R * R),
forall h : R,
Rprod_plus (leapfrog_stepR h ic1) (leapfrog_stepR h ic2) = leapfrog_stepR h (Rprod_plus ic1 ic2).
Proof.
intros.
destruct ic1; destruct ic2.
unfold leapfrog_stepR, Rprod_plus, fst ,snd.
f_equal; nra.
Qed.

(*  TODO: the following need to be updated with new def of leapfrogR over p, q
and moved into lf_harm_real_theorems *)

(*
Definition jacobian (x v: R) (S: R * R -> R * R) : (R * R) * (R * R) :=
  let dSx_dx := Derive (fun x => fst (S (x,v))) x in
  let dSx_dv := Derive (fun v => fst (S (x,v))) v in
  let dSv_dv := Derive (fun v => snd (S (x,v))) v in
  let dSv_dx := Derive (fun x => snd (S (x,v))) x in
  ((dSx_dx, dSx_dv), (dSv_dx, dSv_dv)).

Definition is_symplectic_1D (J: (R*R)*(R*R)) :=
  let S1 := fst (fst J) in
  let S2 := snd (fst J) in
  let S3 := fst (snd J) in
  let S4 := snd (snd J) in
  S1*S4 - S2*S3 = 1.

Lemma is_symplectic_LF :
  forall x v,
  is_symplectic_1D (jacobian x v (fun ic h => leapfrog_stepR h ic)).
Proof.
intros; unfold is_symplectic_1D.
unfold jacobian.
unfold leapfrog_stepR, F; unfold fst, snd.
simpl;
repeat match goal with |- context [Derive (?f) ?var] =>
auto_derive_fun f; unfold F;
assert True as TR by auto;
let H := fresh "H" in
          intro H;
let H1 := fresh "H" in
pose proof (H var TR) as H1; clear TR; clear H ;
apply is_derive_unique in H1;  rewrite H1; clear H1
end.
unfold h.
field_simplify.
nra.
Qed.

*)
Close Scope R_scope.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.
Set Implicit Arguments.

Import WfExtensionality.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Lemma subtype_nom_upp_reduce :
  forall T1 L1 t1 T1', T1 = (t_nom L1 t1 T1') ->
                  forall T2 L2 T2', T2 = (t_upp L2 T2') ->
                               subtype T1 T2 = (eq_label L1 L2) && (subtype T1' T2').
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.