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

Require Import Bool.
Require Import Reals.
Require Import trajectory_const.
Require Import trajectory_def.
Require Import constants.
Require Import ycngftys.
Require Import ycngstys.
Require Import ails_def.
Require Import math_prop.
Require Import tau.
Require Import ails.
Require Import trajectory.
Require Import measure2state.
Require Import ails_trajectory.

Unset Standard Proposition Elimination Names.

Lemma AlertRange_pos : (0 < AlertRange)%R.
unfold AlertRange in |- *; prove_sup.
Qed.

Lemma conflict_beta_theta :
 forall (intr : Trajectory) (evad : EvaderTrajectory) (T : TimeT),
 h intr = V ->
 (MinDistance T <= l intr evad T)%R ->
 (l intr evad T <= MaxDistance T)%R ->
 Omega (beta intr evad T + thetat intr 0) = false ->
 conflict intr evad T = true ->
 (beta intr evad T + thetat intr 0 <= MinBeta)%R \/
 (2 * PI - MinBeta < beta intr evad T + thetat intr 0)%R.
Proof with trivial.
intros intr evad T hyp_intr; intros; set (beta_p := beta intr evad T) in H1;
 set (thetat_p := thetat intr) in H1; set (l_p := l intr evad T) in H, H0;
 set (conflict_p := conflict intr evad) in H2;
assert (hyp1 : r_V = r_vi intr)...
unfold r_V, r_vi in |- *; unfold vi in |- *; rewrite hyp_intr...
assert (hyp2 : rho_V = rho_vi intr)...
unfold rho_V, rho_vi in |- *; unfold vi in |- *; rewrite hyp_intr...
case (Rtotal_order (beta_p + thetat_p 0%R) MinBeta); intro...
left; left...
elim H3; intro...
left; right...
case (Rlt_le_dec (2 * PI - MinBeta) (beta_p + thetat_p 0%R)); intro...
right...
assert (H5 := conflict_T_e_0 intr evad T H2)...
cut (0 <= e intr evad T T)%R...
cut (0 <= ConflictRange)%R...
intros; assert (H8 := Rsqr_incr_1 (e intr evad T T) ConflictRange H5 H7 H6);
 unfold e in H8; rewrite isometric_evader in H8; rewrite Rsqr_sqrt in H8...
change (MinBeta < beta_p + thetat_p 0)%R in H4;
 cut
  ((beta_p + thetat_p 0 < PI / 2)%R \/ (3 * (PI / 2) < beta_p + thetat_p 0)%R)...
intro; elim H9; intro...
cut
 (l_p * sin (beta_p + thetat_p 0) + r_V * (cos (rho_V * T) - 1) <=
  yp intr evad T T)%R...
cut
 (r_V * sin (rho_V * T) - l_p * cos (beta_p + thetat_p 0) <= xp intr evad T T)%R...
intros;
 generalize
  (Math_prop_no_conflict_1 (beta_p + thetat_p 0%R) l_p
     (xp intr evad T T) (yp intr evad T T) T H H0
     (Rlt_le MinBeta (beta_p + thetat_p 0%R) H4)
     (Rlt_le (beta_p + thetat_p 0%R) (PI / 2) H10) H12 H11);
 intro;
 generalize
  (Rlt_le_trans (Rsqr ConflictRange)
     (Rsqr (xp intr evad T T) + Rsqr (yp intr evad T T))
     (Rsqr ConflictRange) H13 H8); intro;
 elim (Rlt_irrefl (Rsqr ConflictRange) H14)...
rewrite hyp1; rewrite hyp2...
apply (xpt_PI intr evad T)...
left; apply Rlt_le_trans with MinT; [ apply MinT_is_pos | apply (cond_1 T) ]...
rewrite <- hyp2; left; apply Rlt_trans with (PI / 2)%R...
apply rho_t_PI2...
apply PI2_Rlt_PI...
rewrite hyp1; rewrite hyp2; cut (0 <= T)%R...
cut (rho_vi intr * T <= PI / 2)%R...
intros; generalize (ypt_PI2 intr evad T T H12 H11); intro...
elim H13; intros...
rewrite <- hyp2; left; apply rho_t_PI2...
left; apply Rlt_le_trans with MinT; [ apply MinT_is_pos | apply (cond_1 T) ]...
cut
 (yp intr evad T T <=
  l_p * sin (beta_p + thetat_p 0) - r_V * (cos (rho_V * T) - 1))%R...
cut
 (r_V * sin (rho_V * T) - l_p * cos (beta_p + thetat_p 0) <= xp intr evad T T)%R...
intros;
 generalize
  (Math_prop_no_conflict_2 (beta_p + thetat_p 0%R) l_p
     (xp intr evad T T) (yp intr evad T T) T H H0
     (Rlt_le (3 * (PI / 2)) (beta_p + thetat_p 0%R) H10) r H12 H11);
 intro...
elim
 (Rlt_irrefl (Rsqr ConflictRange)
    (Rlt_le_trans (Rsqr ConflictRange)
       (Rsqr (xp intr evad T T) + Rsqr (yp intr evad T T))
       (Rsqr ConflictRange) H13 H8))...
rewrite hyp1; rewrite hyp2; apply (xpt_PI intr evad T)...
left; apply Rlt_le_trans with MinT; [ apply MinT_is_pos | apply (cond_1 T) ]...
rewrite <- hyp2; left; apply Rlt_trans with (PI / 2)%R...
apply rho_t_PI2...
apply PI2_Rlt_PI...
rewrite hyp1; rewrite hyp2; cut (0 <= T)%R...
cut (rho_vi intr * T <= PI / 2)%R...
intros; generalize (ypt_PI2 intr evad T T H12 H11); intro; elim H13; intros...
rewrite <- hyp2; left; apply rho_t_PI2...
left; apply Rlt_le_trans with MinT; [ apply MinT_is_pos | apply (cond_1 T) ]...
cut (Omega (beta_p + thetat_p 0%R) = false)...
unfold Omega in |- *; case (Rle_dec (PI / 2) (beta_p + thetat_p 0%R)); intro...
case (Rle_dec (beta_p + thetat_p 0%R) (3 * (PI / 2))); intros...
elim diff_true_false...
right; auto with real...
intro; left; auto with real...
apply Rplus_le_le_0_compat; apply Rle_0_sqr...
unfold ConflictRange in |- *; left; prove_sup...
unfold e in |- *; apply sqrt_positivity; apply Rsqr_evader_distance_pos...
Qed.

Lemma alarm_NOT_Omega_T :
 forall (intr : Trajectory) (evad : EvaderTrajectory) (T : TimeT),
 h intr = V ->
 h (tr evad) = V ->
 (MinDistance T <= l intr evad T)%R ->
 (l intr evad T <= MaxDistance T)%R ->
 Omega (beta intr evad T + thetat intr 0) = false ->
 conflict intr evad T = true ->
 (RR (measure2state intr 0) (measure2state (tr evad) 0) T <= AlertRange)%R.
Proof with trivial.
intros intr evad T hyp_intr hyp_evad; intros; apply Rsqr_incr_0_var...
rewrite R_T...
generalize (conflict_beta_theta intr evad T hyp_intr H H0 H1 H2); intro;
 elim H3; intro...
cut (0 <= beta intr evad T + thetat intr 0)%R...
intro;
 apply
  (Math_prop_alarm_1 (beta intr evad T + thetat intr 0)
     (l intr evad T) T H H0 H5 H4)...
generalize (beta_def intr evad T); intro; decompose [and] H5; intros...
cut (beta intr evad T + thetat intr 0 <= 2 * PI)%R...
intro;
 apply
  (Math_prop_alarm_2 (beta intr evad T + thetat intr 0)
     (l intr evad T) T H H0
     (Rlt_le (2 * PI - MinBeta) (beta intr evad T + thetat intr 0) H4))...
generalize (beta_def intr evad T); intro; decompose [and] H5; intros; left...
(*Rewrite hyp_evad.*)
left; apply AlertRange_pos...
Qed.

Lemma alarm_NOT_Omega_tau :
 forall (intr : Trajectory) (evad : EvaderTrajectory) (T : TimeT),
 h intr = V ->
 h (tr evad) = V ->
 (MinDistance T <= l intr evad T)%R ->
 (l intr evad T <= MaxDistance T)%R ->
 Omega (beta intr evad T + thetat intr 0) = false ->
 conflict intr evad T = true ->
 (0 < tau (measure2state intr 0) (measure2state (tr evad) 0) 0)%R ->
 (RR (measure2state intr 0) (measure2state (tr evad) 0)
    (tau (measure2state intr 0) (measure2state (tr evad) 0) 0) <= AlertRange)%R.
Proof with trivial.
intros intr evad T hyp_intr hyp_evad; intros;
 apply
  Rle_trans with (RR (measure2state intr 0) (measure2state (tr evad) 0) T)...
generalize
 (derivative_eq_zero_min (measure2state intr 0) (measure2state (tr evad) 0) 0
    T); repeat rewrite Rplus_0_l; intro...
apply (alarm_NOT_Omega_T intr evad T hyp_intr hyp_evad H H0 H1 H2)...
Qed.

Lemma alarm_NOT_Omega_AlertTime :
 forall (intr : Trajectory) (evad : EvaderTrajectory) (T : TimeT),
 h intr = V ->
 h (tr evad) = V ->
 (MinDistance T <= l intr evad T)%R ->
 (l intr evad T <= MaxDistance T)%R ->
 Omega (beta intr evad T + thetat intr 0) = false ->
 conflict intr evad T = true ->
 (AlertTime < tau (measure2state intr 0) (measure2state (tr evad) 0) 0)%R ->
 (RR (measure2state intr 0) (measure2state (tr evad) 0) AlertTime <=
  AlertRange)%R.
Proof with trivial.
intros intr evad T hyp_intr hyp_evad; intros;
 apply
  Rle_trans with (RR (measure2state intr 0) (measure2state (tr evad) 0) T)...
rewrite <- (Rplus_0_l AlertTime); rewrite <- (Rplus_0_l T);
 apply asymptotic_decrease_tau...
left...
unfold AlertTime in |- *; apply Rle_trans with MaxT...
apply (cond_2 T)...
unfold MaxT in |- *; left; prove_sup...
apply (alarm_NOT_Omega_T _ _ _ hyp_intr hyp_evad H H0 H1 H2)...
Qed.

Lemma chktrack_NOT_Omega_trkrate_eq_0 :
 forall (intr : Trajectory) (evad : EvaderTrajectory) (T : TimeT),
 h intr = V ->
 h (tr evad) = V ->
 (MinDistance T <= l intr evad T)%R ->
 (l intr evad T <= MaxDistance T)%R ->
 Omega (beta intr evad T + thetat intr 0) = false ->
 conflict intr evad T = true ->
 (0 < tau (measure2state intr 0) (measure2state (tr evad) 0) 0)%R ->
 chktrack (measure2state intr 0) (measure2state (tr evad) 0) 0.
Proof with trivial.
intros intr evad T hyp_intr hyp_evad; intros; unfold chktrack in |- *;
 case (Rle_dec (tau (measure2state intr 0) (measure2state (tr evad) 0) 0) 0);
 intro...
elim
 (Rlt_irrefl 0
    (Rlt_le_trans 0
       (tau (measure2state intr 0) (measure2state (tr evad) 0) 0) 0 H3 r))...
rewrite Rplus_0_l;
 case
  (Rlt_dec AlertTime
     (tau (measure2state intr 0) (measure2state (tr evad) 0) 0));
 intro...
apply (alarm_NOT_Omega_AlertTime intr evad T)...
apply (alarm_NOT_Omega_tau intr evad T)...
Qed.

(**************************************************************)
(************************** THEOREM ***************************)
(**************************************************************)

Theorem ails_alarm_tau_gt0 :
 forall (intr : Trajectory) (evad : EvaderTrajectory) (T : TimeT),
 h intr = V ->
 h (tr evad) = V ->
 (MinDistance T <= l intr evad T)%R ->
 (l intr evad T <= MaxDistance T)%R ->
 Omega (beta intr evad T + thetat intr 0) = false ->
 (0 < tau (measure2state intr 0) (measure2state (tr evad) 0) 0)%R ->
 conflict intr evad T = true ->
 ails_alert (measure2state intr 0) (measure2state (tr evad) 0).
Proof with trivial.
intros intr evad T hyp_intr hyp_evad; intros; unfold ails_alert in |- *;
 case (Req_EM_var (trkrate (bank (measure2state intr 0))) 0);
 intro...
apply (chktrack_NOT_Omega_trkrate_eq_0 intr evad T)...
case (Rle_dec 3 (trkrate (bank (measure2state intr 0)))); intro...
unfold arc_loop in |- *; rewrite mod_eq_0...
case (Rlt_le_dec 0 (trkrate (bank (measure2state intr 0)))); intro...
unfold INR in |- *; repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r;
 repeat rewrite Rplus_0_r; unfold intruderSpeed in |- *;
 replace (v V) with 250%R...
cut
 (let z := 250%R in
  mkState
    (xt (measure2state intr 0) +
     Rsqr z / (g * tand (bank (measure2state intr 0))) *
     (sind (heading (measure2state intr 0)) -
      sind (heading (measure2state intr 0))))
    (yt (measure2state intr 0) +
     Rsqr z / (g * tand (bank (measure2state intr 0))) *
     (cosd (heading (measure2state intr 0)) -
      cosd (heading (measure2state intr 0))))
    (heading (measure2state intr 0)) (bank (measure2state intr 0)) =
  measure2state intr 0)...
intro; rewrite H4...
cut
 (mkState (xt (measure2state (tr evad) 0)) (yt (measure2state (tr evad) 0))
    (heading (measure2state (tr evad) 0)) (bank (measure2state (tr evad) 0)) =
  measure2state (tr evad) 0)...
intro; rewrite H5...
apply (chktrack_NOT_Omega_trkrate_eq_0 intr evad T)...
unfold Rminus in |- *; repeat rewrite Rplus_opp_r; repeat rewrite Rmult_0_r;
 repeat rewrite Rplus_0_r...
unfold INR in |- *; repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r;
 repeat rewrite Rplus_0_r; unfold Rminus in |- *; repeat rewrite Rplus_opp_r;
 unfold Rdiv in |- *; repeat rewrite Rmult_0_r; repeat rewrite Rplus_0_r;
 apply (chktrack_NOT_Omega_trkrate_eq_0 intr evad T)...
case (Rle_dec (3 / 2) (trkrate (bank (measure2state intr 0)))); intro...
unfold arc_loop in |- *; rewrite mod_eq_0;
 case (Rlt_le_dec 0 (trkrate (bank (measure2state intr 0))));
 intro...
repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r; repeat rewrite Rplus_0_r;
 unfold Rminus in |- *; repeat rewrite Rplus_opp_r;
 unfold Rdiv in |- *; repeat rewrite Rmult_0_r; repeat rewrite Rplus_0_r;
 apply (chktrack_NOT_Omega_trkrate_eq_0 intr evad T)...
repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r; repeat rewrite Rplus_0_r;
 unfold Rminus in |- *; repeat rewrite Rplus_opp_r;
 unfold Rdiv in |- *; repeat rewrite Rmult_0_r; repeat rewrite Rplus_0_r;
 apply (chktrack_NOT_Omega_trkrate_eq_0 intr evad T)...
case (Rle_dec (3 / 4) (trkrate (bank (measure2state intr 0)))); intro...
unfold arc_loop in |- *; rewrite mod_eq_0;
 case (Rlt_le_dec 0 (trkrate (bank (measure2state intr 0))));
 intro...
repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r; repeat rewrite Rplus_0_r;
 unfold Rminus in |- *; repeat rewrite Rplus_opp_r;
 unfold Rdiv in |- *; repeat rewrite Rmult_0_r; repeat rewrite Rplus_0_r;
 apply (chktrack_NOT_Omega_trkrate_eq_0 intr evad T)...
repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r; repeat rewrite Rplus_0_r;
 unfold Rminus in |- *; repeat rewrite Rplus_opp_r;
 unfold Rdiv in |- *; repeat rewrite Rmult_0_r; repeat rewrite Rplus_0_r;
 apply (chktrack_NOT_Omega_trkrate_eq_0 intr evad T)...
unfold arc_loop in |- *; rewrite mod_eq_0;
 case (Rlt_le_dec 0 (trkrate (bank (measure2state intr 0))));
 intro...
repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r; repeat rewrite Rplus_0_r;
 unfold Rminus in |- *; repeat rewrite Rplus_opp_r;
 unfold Rdiv in |- *; repeat rewrite Rmult_0_r; repeat rewrite Rplus_0_r;
 apply (chktrack_NOT_Omega_trkrate_eq_0 intr evad T)...
repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r; repeat rewrite Rplus_0_r;
 unfold Rminus in |- *; repeat rewrite Rplus_opp_r;
 unfold Rdiv in |- *; repeat rewrite Rmult_0_r; repeat rewrite Rplus_0_r;
 apply (chktrack_NOT_Omega_trkrate_eq_0 intr evad T)...
Qed.


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model Unknown *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition Acq := unknown_set "Acq".
Definition AcqRel := unknown_set "AcqRel".
Definition Fence_r_r := unknown_set "Fence.r.r".
Definition Fence_r_rw := unknown_set "Fence.r.rw".
Definition Fence_r_w := unknown_set "Fence.r.w".
Definition Fence_rw_r := unknown_set "Fence.rw.r".
Definition Fence_rw_rw := unknown_set "Fence.rw.rw".
Definition Fence_rw_w := unknown_set "Fence.rw.w".
Definition Fence_tso := unknown_set "Fence.tso".
Definition Fence_w_r := unknown_set "Fence.w.r".
Definition Fence_w_rw := unknown_set "Fence.w.rw".
Definition Fence_w_w := unknown_set "Fence.w.w".
Definition Rel := unknown_set "Rel".
Definition Sc := unknown_set "Sc".
Definition X := unknown_set "X".
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
Definition fence_r_r := [R] ⋅ (fencerel Fence_r_r ⋅ [R]).
Definition fence_r_w := [R] ⋅ (fencerel Fence_r_w ⋅ [W]).
Definition fence_r_rw := [R] ⋅ (fencerel Fence_r_rw ⋅ [M]).
Definition fence_w_r := [W] ⋅ (fencerel Fence_w_r ⋅ [R]).
Definition fence_w_w := [W] ⋅ (fencerel Fence_w_w ⋅ [W]).
Definition fence_w_rw := [W] ⋅ (fencerel Fence_w_rw ⋅ [M]).
Definition fence_rw_r := [M] ⋅ (fencerel Fence_rw_r ⋅ [R]).
Definition fence_rw_w := [M] ⋅ (fencerel Fence_rw_w ⋅ [W]).
Definition fence_rw_rw := [M] ⋅ (fencerel Fence_rw_rw ⋅ [M]).
Definition fence_tso := let f := fencerel Fence_tso in [W] ⋅ (f ⋅ [W]) ⊔ [R] ⋅ (f ⋅ [M]).
Definition fence := fence_r_r ⊔ (fence_r_w ⊔ (fence_r_rw ⊔ (fence_w_r ⊔ (fence_w_w ⊔ (fence_w_rw ⊔ (fence_rw_r ⊔ (fence_rw_w ⊔ (fence_rw_rw ⊔ fence_tso)))))))).
Definition po_loc_no_w := po_loc ⊓ !((po_loc ⊔ 1) ⋅ ([W] ⋅ po_loc)).
Definition rsw := rf° ⋅ rf.
Definition AcqRel_0 := AcqRel ⊔ Sc.
Definition AQ := Acq ⊔ AcqRel_0.
Definition RL := Rel ⊔ AcqRel_0.
Definition AMO := (*failed: try AMO with R ⊓ W*) R ⊓ W.
Definition RCsc := (Acq ⊔ (Rel ⊔ AcqRel_0)) ⊓ (AMO ⊔ X).
Definition r1 := [M] ⋅ (po_loc ⋅ [W]).
Definition r2 := [R] ⋅ (po_loc_no_w ⋅ [R]) ⊓ !rsw.
Definition r3 := [(AMO ⊔ X)] ⋅ (rfi ⋅ [R]).
Definition r4 := fence.
Definition r5 := [AQ] ⋅ (po ⋅ [M]).
Definition r6 := [M] ⋅ (po ⋅ [RL]).
Definition r7 := [RCsc] ⋅ (po ⋅ [RCsc]).
Definition r8 := rmw.
Definition r9 := [M] ⋅ (addr ⋅ [M]).
Definition r10 := [M] ⋅ (data ⋅ [W]).
Definition r11 := [M] ⋅ (ctrl ⋅ [W]).
Definition r12 := [M] ⋅ ((addr ⊔ data) ⋅ ([W] ⋅ (rfi ⋅ [R]))).
Definition r13 := [M] ⋅ (addr ⋅ ([M] ⋅ (po ⋅ [W]))).
Definition ppo := r1 ⊔ (r2 ⊔ (r3 ⊔ (r4 ⊔ (r5 ⊔ (r6 ⊔ (r7 ⊔ (r8 ⊔ (r9 ⊔ (r10 ⊔ (r11 ⊔ (r12 ⊔ r13))))))))))).
Definition witness_conditions := True.
Definition model_conditions := True.
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc Acq AcqRel Fence_r_r Fence_r_rw Fence_r_w Fence_rw_r Fence_rw_rw Fence_rw_w Fence_tso Fence_w_r Fence_w_rw Fence_w_w Rel Sc X tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW fence_r_r fence_r_w fence_r_rw fence_w_r fence_w_w fence_w_rw fence_rw_r fence_rw_w fence_rw_rw fence_tso fence po_loc_no_w rsw AcqRel_0 AQ RL AMO RCsc r1 r2 r3 r4 r5 r6 r7 r8 r9 r10 r11 r12 r13 ppo witness_conditions model_conditions : cat.

Definition valid (c : candidate) := True.

(* End of translation of model Unknown *)


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal27.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (x:lst):@eq lst (append (rev x) (Cons n Nil))
  (append (append (rev x) (Cons n Nil)) Nil).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal27_qreva_append_53_append_nil/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (x:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"x:" ++ "(" ++ show x ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  x.
QuickChick collect_data.
Success.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D Aprime Bprime Cprime Dprime X Y E Z Eprime : Universe, ((wd_ X A /\ (wd_ X Aprime /\ (wd_ X C /\ (wd_ X Cprime /\ (wd_ Y B /\ (wd_ Y Bprime /\ (wd_ Y D /\ (wd_ Y Dprime /\ (wd_ A C /\ (wd_ B D /\ (wd_ A Aprime /\ (wd_ B Bprime /\ (wd_ C Cprime /\ (wd_ D Dprime /\ (wd_ Aprime Cprime /\ (wd_ Bprime Dprime /\ (wd_ A E /\ (wd_ Aprime Eprime /\ (wd_ B E /\ (wd_ Bprime Eprime /\ (wd_ Y A /\ (wd_ A B /\ (wd_ X B /\ (wd_ Aprime Dprime /\ (wd_ Dprime Eprime /\ (wd_ A D /\ (wd_ D E /\ (wd_ A Eprime /\ (wd_ E Aprime /\ (wd_ E Eprime /\ (wd_ Y E /\ (wd_ Y Z /\ (wd_ B Z /\ (wd_ E Z /\ (wd_ X E /\ (wd_ X Z /\ (wd_ A Z /\ (wd_ X Y /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ Aprime Bprime /\ (col_ X A C /\ (col_ X A Aprime /\ (col_ X A Cprime /\ (col_ Y B D /\ (col_ Y B Bprime /\ (col_ Y B Dprime /\ (col_ E A B /\ (col_ E C D /\ (col_ Eprime Aprime Bprime /\ (col_ Eprime E Z /\ col_ B C E))))))))))))))))))))))))))))))))))))))))))))))))))) -> col_ B A C)).
Proof.
  time tac.
Qed.

End FOFProblem.


From iris.program_logic Require Export total_weakestpre.
From iris.bi Require Export big_op.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".

Section lifting.
Context `{irisG Λ Σ}.
Implicit Types v : val Λ.
Implicit Types e : expr Λ.
Implicit Types σ : state Λ.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val Λ → iProp Σ.

Hint Resolve reducible_no_obs_reducible.

Lemma twp_lift_step s E Φ e1 :
  to_val e1 = None →
  (∀ σ1 κs n, state_interp σ1 κs n ={E,∅}=∗
    ⌜if s is NotStuck then reducible_no_obs e1 σ1 else True⌝ ∗
    ∀ κ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={∅,E}=∗
      ⌜κ = []⌝ ∗
      state_interp σ2 κs (length efs + n) ∗
      WP e2 @ s; E [{ Φ }] ∗
      [∗ list] ef ∈ efs, WP ef @ s; ⊤ [{ fork_post }])
  ⊢ WP e1 @ s; E [{ Φ }].
Proof. by rewrite twp_unfold /twp_pre=> ->. Qed.

(** Derived lifting lemmas. *)
Lemma twp_lift_pure_step_no_fork `{Inhabited (state Λ)} s E Φ e1 :
  (∀ σ1, reducible_no_obs e1 σ1) →
  (∀ σ1 κ e2 σ2 efs, prim_step e1 σ1 κ e2 σ2 efs → κ = [] ∧ σ2 = σ1 ∧ efs = []) →
  (|={E}=> ∀ κ e2 efs σ, ⌜prim_step e1 σ κ e2 σ efs⌝ → WP e2 @ s; E [{ Φ }])
  ⊢ WP e1 @ s; E [{ Φ }].
Proof.
  iIntros (Hsafe Hstep) ">H". iApply twp_lift_step.
  { eapply reducible_not_val, reducible_no_obs_reducible, (Hsafe inhabitant). }
  iIntros (σ1 κs n) "Hσ".
  iMod fupd_intro_mask' as "Hclose"; last iModIntro; first by set_solver. iSplit.
  { iPureIntro. destruct s; auto. }
  iIntros (κ e2 σ2 efs ?). destruct (Hstep σ1 κ e2 σ2 efs) as (->&<-&->); auto.
  iMod "Hclose" as "_". iModIntro.
  iDestruct ("H" with "[//]") as "H". simpl. by iFrame.
Qed.

(* Atomic steps don't need any mask-changing business here, one can
   use the generic lemmas here. *)
Lemma twp_lift_atomic_step {s E Φ} e1 :
  to_val e1 = None →
  (∀ σ1 κs n, state_interp σ1 κs n ={E}=∗
    ⌜if s is NotStuck then reducible_no_obs e1 σ1 else True⌝ ∗
    ∀ κ e2 σ2 efs, ⌜prim_step e1 σ1 κ e2 σ2 efs⌝ ={E}=∗
      ⌜κ = []⌝ ∗
      state_interp σ2 κs (length efs + n) ∗
      from_option Φ False (to_val e2) ∗
      [∗ list] ef ∈ efs, WP ef @ s; ⊤ [{ fork_post }])
  ⊢ WP e1 @ s; E [{ Φ }].
Proof.
  iIntros (?) "H".
  iApply (twp_lift_step _ E _ e1)=>//; iIntros (σ1 κs n) "Hσ1".
  iMod ("H" $! σ1 with "Hσ1") as "[$ H]".
  iMod (fupd_intro_mask' E ∅) as "Hclose"; first set_solver.
  iIntros "!>" (κ e2 σ2 efs) "%". iMod "Hclose" as "_".
  iMod ("H" $! κ e2 σ2 efs with "[#]") as "($ & $ & HΦ & $)"; first by eauto.
  destruct (to_val e2) eqn:?; last by iExFalso.
  iApply twp_value; last done. by apply of_to_val.
Qed.

Lemma twp_lift_pure_det_step_no_fork `{Inhabited (state Λ)} {s E Φ} e1 e2 :
  (∀ σ1, reducible_no_obs e1 σ1) →
  (∀ σ1 κ e2' σ2 efs', prim_step e1 σ1 κ e2' σ2 efs' →
    κ = [] ∧ σ2 = σ1 ∧ e2' = e2 ∧ efs' = []) →
  (|={E}=> WP e2 @ s; E [{ Φ }]) ⊢ WP e1 @ s; E [{ Φ }].
Proof.
  iIntros (? Hpuredet) ">H". iApply (twp_lift_pure_step_no_fork s E); try done.
  { naive_solver. }
  iIntros "!>" (κ' e' efs' σ (_&_&->&->)%Hpuredet); auto.
Qed.

Lemma twp_pure_step `{Inhabited (state Λ)} s E e1 e2 φ n Φ :
  PureExec φ n e1 e2 →
  φ →
  WP e2 @ s; E [{ Φ }] ⊢ WP e1 @ s; E [{ Φ }].
Proof.
  iIntros (Hexec Hφ) "Hwp". specialize (Hexec Hφ).
  iInduction Hexec as [e|n e1 e2 e3 [Hsafe ?]] "IH"; simpl; first done.
  iApply twp_lift_pure_det_step_no_fork; [done|naive_solver|].
  iModIntro. by iApply "IH".
Qed.
End lifting.


(* -*- mode: coq; coq-prog-args: ("-nois") -*- *)

(* in Coq 8.8.0 *)

(** * Pre

    事前に定義すべきもの。

    第一に、表記法を事前に定義する。
    これらは実際に何を意味するか定義されていないが
    優先順位や結合性は定義されている。
    最初から [_ + _] を自然数同士の足し算を意味すると決めたりすると
    それを整数同士の足し算と解釈したいときに困ってしまうし、
    それぞれの単塊 (Module) で表記法を定義すると
    [2 + 3 + 4 * 0] という式が
    どの単塊に書かれているかによって
    [(2 + 3) + (4 * 0)] と解釈されたり
    [((2 + 3) + 4) * 0] と解釈されたりして
    読みづらくなってしまうことがあり得るため、
    両方の間を取っている。
    ちなみに書かれている場所によってどの解釈を選ぶかは
    視野 (scope) の仕組みによる。

    第二に、視野 (scope) を定義する。
    例えば [(Empty + Unit)%type] という式があったとする。
    このとき、百分率記号は右側の式が解釈されるときに
    その式の内部の表記法の意味が [type] という視野の中から探されることを示す。
    どの表記法がどの視野に入るかは表記法の意味を定義するときに一緒に定義できる。
    同じ表記法でも視野によって意味が異なることがある。
    式を読み取る何某から見える「視野」をイメージしてほしい。
    百分率記号で直接的に指定しなくとも型によって視野が選ばれることもある。

    第三に、戦略 (tactic) を使用するための設定をする。
    戦略 (tactic) は一気に定義を書き上げることが出来ない場合に有用な道具である。
    この部分の記述は Stack Overflow で Tej Chajed 氏に教えていただいた。
    さらに、 Coq の標準文庫 (library) の内部にある
    Coq.Init.Notations の記述も参考にした。

    第四に、設定旗 (flag) を操作する。
    HoTT の内部にある HoTT.Basics.Overture の記述に依った。

*)

Module Pre.

 (** ** 述語論理の記号

     これらのいずれも Coq.Init.Notations を参考にした。
     含意記号は右側のみ優先順位が低いため、
     [P -> _] と書かれた時に [_] の部分が分けられて認識されることはない。

 *)

 Reserved Notation "x -> y" (at level 99, right associativity, y at level 200).
 Reserved Notation "x <-> y" (at level 95, no associativity).
 Reserved Notation "x /\ y" (at level 80, right associativity).
 Reserved Notation "x \/ y" (at level 85, right associativity).
 Reserved Notation "~ x" (at level 75, right associativity).

 (** ** 等号及び不等号、大小関係 *)

 Reserved Notation "x = y :> T" (at level 70, y at next level, no associativity).
 Reserved Notation "x = y" (at level 70, no associativity).

 Reserved Notation "x <> y :> T"(at level 70, y at next level, no associativity).
 Reserved Notation "x <> y" (at level 70, no associativity).

 Reserved Notation "x <= y" (at level 70, no associativity).
 Reserved Notation "x < y" (at level 70, no associativity).
 Reserved Notation "x >= y" (at level 70, no associativity).
 Reserved Notation "x > y" (at level 70, no associativity).

 (** ** 算術演算子 *)

 Reserved Notation "x + y" (at level 50, left associativity).
 Reserved Notation "x - y" (at level 50, left associativity).
 Reserved Notation "x * y" (at level 40, left associativity).
 Reserved Notation "x / y" (at level 40, left associativity).
 Reserved Notation "x ^ y" (at level 30, right associativity).

 Reserved Notation "- x" (at level 35, right associativity).
 Reserved Notation "/ x" (at level 35, right associativity).

 (** ** 視野 (scope) *)

 Delimit Scope type_scope with type.
 Delimit Scope function_scope with function.
 Delimit Scope core_scope with core.

 Bind Scope type_scope with Sortclass.
 Bind Scope function_scope with Funclass.

 Open Scope core_scope.
 Open Scope function_scope.
 Open Scope type_scope.

 (** ** 戦略 (tactic) の設定 *)

 Declare ML Module "ltac_plugin".

 Export Set Default Proof Mode "Classic".

 (** ** 設定旗 (flag) の操作 *)

 Export Unset Bracketing Last Introduction Pattern.

 Export Set Typeclasses Strict Resolution.

 Export Unset Elimination Schemes.

 Export Set Keyed Unification.

 Export Unset Refine Instance Mode.

 Export Unset Strict Universe Declaration.

 Export Unset Universe Minimization ToSet.

End Pre.

(** * Predicate

    命題論理、述語論理についての定義。
    論理式はカリー・ハワード対応に従って型へ翻訳される。
    この小単位はそれらを定義するものである。
    ただ、これらは命題 (Prop) ではなく 型 (Type) であることに注意すること。

*)

Module Predicate.

 Export Pre.

 (** ** 関数 *)

 Definition arrow (A B : Type) : Type := forall (_ : A), B.

 Notation "A -> B" := (forall (_ : A), B) : type_scope.

 (** 汎用関数 *)

 Definition id {A : Type} : A -> A := fun x => x.

 Definition const {A B : Type} : A -> B -> A := fun x _ => x.

 Definition compose {A B C : Type} : (A -> B) -> (C -> A) -> C -> B := fun f g x => f (g x).

 Definition flip {A B C : Type} : (A -> B -> C) -> B -> A -> C := fun f x y => f y x.

 Definition apply {A B : Type} : (A -> B) -> A -> B := id.

 (** ** Empty *)

 (** 偽、矛盾、空の型、空の空間。 *)

 Inductive Empty : Type :=
 .

 Scheme Empty_ind := Induction for Empty Sort Type.
 Scheme Empty_rec := Minimality for Empty Sort Type.
 Definition Empty_rect := Empty_ind.

 Arguments Empty_rec {P} _.

 Definition not (A : Type) : Type := A -> Empty.

 Notation "~ x" := (not x) : type_scope.

 (** ** Unit *)

 (** 真、点の空間、ユニット。 *)

 Inductive Unit : Type :=
 | tt : Unit
 .

 Scheme Unit_ind := Induction for Unit Sort Type.
 Scheme Unit_rec := Minimality for Unit Sort Type.
 Definition Unit_rect := Unit_ind.

 Arguments Unit_rec {P} _ _.

 (** ** and *)

 (** 論理積、二つ組、対、ダブル、2-タプル、ペア。 *)

 Inductive and (A B : Type) : Type :=
 | pair : A -> B -> A /\ B
 where
   "A /\ B" := (and A B) : type_scope
 .

 Arguments pair {A B} _ _.

 Scheme and_ind := Induction for and Sort Type.
 Scheme and_rec := Minimality for and Sort Type.
 Definition and_rect := and_ind.

 Arguments and_ind {A B} _ _ _.
 Arguments and_rec {A B P} _ _.
 Arguments and_rect {A B} _ _ _.

 Definition first {A B : Type} : A /\ B -> A :=
  fun x => match x with pair xL _ => xL end
 .

 Definition second {A B : Type} : A /\ B -> B :=
  fun x => match x with pair _ xR => xR end
 .

 Definition and_proj1 {A B : Type} := @first A B.
 Definition and_proj2 {A B : Type} := @second A B.

 (** ** or *)

 (** 論理和。 *)

 Inductive or (A B : Type) : Type :=
 | left : A -> A \/ B
 | right : B -> A \/ B
 where
   "A \/ B" := (or A B) : type_scope
 .

 Arguments left {A B} _.
 Arguments right {A B} _.

 Scheme or_ind := Induction for or Sort Type.
 Scheme or_rec := Minimality for or Sort Type.
 Definition or_rect := or_ind.

 Arguments or_ind {A B} _ _ _ _.
 Arguments or_rec {A B P} _ _ _.
 Arguments or_rect {A B} _ _ _ _.

 (** 写像。 *)

 Theorem and_map_l {A B C : Type} : (A -> B) -> A /\ C -> B /\ C.
 Proof.
  intros f [xl xr]; refine (pair (f xl) xr).
 Defined.

 Theorem and_map_r {A B C : Type} : (A -> B) -> C /\ A -> C /\ B.
 Proof.
  intros f [xl xr]; refine (pair xl (f xr)).
 Defined.

 Theorem or_map_l {A B C : Type} : (A -> B) -> A \/ C -> B \/ C.
 Proof.
  intros f [xl | xr]; [> refine (left (f xl)) | refine (right xr) ].
 Defined.

 Theorem or_map_r {A B C : Type} : (A -> B) -> C \/ A -> C \/ B.
 Proof.
  intros f [xl | xr]; [> refine (left xl) | refine (right (f xr)) ].
 Defined.

 Theorem imp_map_l {A B C : Type} : (A -> B) -> (B -> C) -> (A -> C).
 Proof.
  intros f g; refine (compose g f).
 Defined.

 Theorem imp_map_r {A B C : Type} : (A -> B) -> (C -> A) -> (C -> B).
 Proof.
  intros f g; refine (compose f g).
 Defined.

 Theorem not_map {A B : Type} : (A -> B) -> ~ B -> ~ A.
 Proof.
  intros f x; refine (compose x f).
 Defined.

 (** ** 命題論理の定理 *)

 Definition exfalso {A : Type} : Empty -> A := Empty_rec.

 Definition unit_const {A : Type} : A -> Unit := const tt.

 Theorem and_fanout {A B C : Type} : (A -> B) -> (A -> C) -> A -> B /\ C.
 Proof.
  intros f g x; refine (pair (f x) (g x)).
 Defined.

 Theorem or_fanin {A B C : Type} : (A -> B) -> (C -> B) -> A \/ C -> B.
 Proof.
  intros f g [xl | xr]; [> refine (f xl) | refine (g xr) ].
 Defined.

 Theorem double_not {A : Type} : A -> ~ ~ A.
 Proof.
  intros a na.
  apply na.
  apply a.
 Defined.

 (** ** iff *)

 (** 同値。 *)

 Definition iff (A B : Type) : Type := (A -> B) /\ (B -> A).

 Notation "A <-> B" := (iff A B) : type_scope.

 (** iffの基本性質 *)

 Theorem iff_refl {A : Type} : A <-> A.
 Proof.
  refine (pair id id).
 Defined.

 Theorem iff_sym {A B : Type} : (A <-> B) -> (B <-> A).
 Proof.
  intros x.
  refine (pair (second x) (first x)).
 Defined.

 Theorem iff_trans {A B C : Type} :  (A <-> B) -> (C <-> A) -> (C <-> B).
 Proof.
  intros x y.
  apply pair.
  -
   refine (compose (first x) (first y)).
  -
   refine (compose (second y) (second x)).
 Defined.

 (** 双方向の写像 *)

 Theorem and_iff_map_l {A B C : Type} : (A <-> B) -> (A /\ C <-> B /\ C).
 Proof.
  intros [xl xr]; refine (pair (and_map_l xl) (and_map_l xr)).
 Defined.

 Theorem and_iff_map_r {A B C : Type} : (A <-> B) -> (C /\ A <-> C /\ B).
 Proof.
  intros [xl xr]; refine (pair (and_map_r xl) (and_map_r xr)).
 Defined.

 Theorem or_iff_map_l {A B C : Type} : (A <-> B) -> (A \/ C <-> B \/ C).
 Proof.
  intros [xl xr]; refine (pair (or_map_l xl) (or_map_l xr)).
 Defined.

 Theorem or_iff_map_r {A B C : Type} : (A <-> B) -> (C \/ A <-> C \/ B).
 Proof.
  intros [xl xr]; refine (pair (or_map_r xl) (or_map_r xr)).
 Defined.

 Theorem imp_iff_map_l {A B C : Type} : (A <-> B) -> ((A -> C) <-> (B -> C)).
 Proof.
  intros [xl xr]; refine (pair (imp_map_l xr) (imp_map_l xl)).
 Defined.

 Theorem imp_iff_map_r {A B C : Type} : (A <-> B) -> ((C -> A) <-> (C -> B)).
 Proof.
  intros [xl xr]; refine (pair (imp_map_r xl) (imp_map_r xr)).
 Defined.

 Theorem not_iff_map {A B C : Type} : (A <-> B) -> (~ A <-> ~B).
 Proof.
  intros [xl xr]; refine (pair (not_map xr) (not_map xl)).
 Defined.

 (** ** 重要な同値関係 *)

 Theorem neg_false {A : Type} : ~ A <-> (A <-> Empty).
 Proof.
  apply pair.
  -
   intros nx.
   refine (pair nx exfalso).
  -
   apply first.
 Defined.

 Theorem and_comm {A B : Type} : A /\ B <-> B /\ A.
 Proof.
  assert (comm : forall A B, A /\ B -> B /\ A).
  -
   intros gA gB [xl xr]; refine (pair xr xl).
  -
   apply pair.
   +
    apply comm.
   +
    apply comm.
 Defined.

 Theorem and_assoc {A B C : Type} : (A /\ B) /\ C <-> A /\ B /\ C.
 Proof.
  apply pair.
  -
   refine (and_fanout _ _).
   +
    refine (compose first first).
   +
    refine (and_fanout _ _).
    *
     refine (compose second first).
    *
     refine second.
  -
   refine (and_fanout _ _).
   +
    refine (and_fanout _ _).
    *
     refine first.
    *
     refine (compose first second).
   +
    refine (compose second second).
 Defined.

 Theorem and_unit_l {A : Type} : A /\ Unit <-> A.
 Proof.
  apply pair.
  -
   apply first.
  -
   refine (and_fanout id unit_const).
 Defined.

 Theorem and_unit_r {A : Type} : Unit /\ A <-> A.
 Proof.
  apply pair.
  -
   apply second.
  -
   refine (and_fanout unit_const id).
 Defined.

 Theorem or_comm {A B : Type} : (A \/ B) <-> (B \/ A).
 Proof.
  assert (comm : forall A B, A \/ B -> B \/ A).
  -
   intros gA gB [xl | xr]; [> refine (right xl) | refine (left xr) ].
  -
   apply pair.
   +
    apply comm.
   +
    apply comm.
 Defined.

 Theorem or_assoc {A B C : Type} : (A \/ B) \/ C <-> A \/ B \/ C.
 Proof.
  apply pair.
  -
   refine (or_fanin _ _).
   +
    refine (or_fanin _ _).
    *
     refine left.
    *
     refine (compose right left).
   +
    refine (compose right right).
  -
   refine (or_fanin _ _).
   +
    refine (compose left left).
   +
    refine (or_fanin _ _).
    *
     refine (compose left right).
    *
     refine right.
 Defined.

 Theorem or_empty_l {A : Type} : A \/ Empty <-> A.
 Proof.
  apply pair.
  -
   apply or_fanin.
   +
    apply id.
   +
    apply exfalso.
  -
   apply left.
 Defined.

 Theorem or_empty_r {A : Type} : Empty \/ A <-> A.
 Proof.
  apply pair.
  -
   apply or_fanin.
   +
    apply exfalso.
   +
    apply id.
  -
   apply right.
 Defined.

 Theorem iff_double_not {A : Type} : ~ ~ ~ A <-> ~ A.
 Proof.
  apply pair.
  -
   apply not_map.
   apply double_not.
  -
   apply double_not.
 Defined.

 Theorem de_morgan {A B : Type} : ~ (A \/ B) <-> ~ A /\ ~ B.
 Proof.
  apply pair.
  -
   apply and_fanout.
   +
    apply not_map.
    apply left.
   +
    apply not_map.
    apply right.
  -
   intros [xl xr].
   refine (or_rec xl xr).
 Defined.

 (** ** 量化子 *)

 Inductive ex (A : Type) (P : A -> Type) : Type :=
 | ex_pair : forall x : A, P x -> ex A P
 .

 Notation "'exists' x .. y , p"
   :=
     (ex _ (fun x => .. (ex _ (fun y => p)) ..))
   (
     at level 200,
     x binder,
     right associativity,
     format "'[' 'exists'  '/  ' x  ..  y ,  '/  ' p ']'")
   :
     type_scope.

 Arguments ex {A} _.
 Arguments ex_pair {A} _ _ _.

 Scheme ex_ind := Induction for ex Sort Type.
 Scheme ex_rec := Minimality for ex Sort Type.
 Definition ex_rect := ex_ind.

 Arguments ex_ind {A P} _ _ _.
 Arguments ex_rec {A P P0} _ _.
 Arguments ex_rect {A P} _ _ _.

 Definition ex_proj1 {A : Type} {P : A -> Type} : ex P -> A.
 Proof.
  intros x.
  case x.
  intros x1 x2.
  apply x1.
 Defined.

 Definition ex_proj2 {A : Type} {P : A -> Type} : forall (x : ex P), P (ex_proj1 x).
 Proof.
  intros x.
  case x.
  intros x1 x2.
  apply x2.
 Defined.

 Definition all {A : Type} (P : A -> Type) : Type := forall x, P x.

 (** 量化子に関する重要な同値関係 *)

 Theorem quant_de_morgan {A : Type} {P : A -> Type} : ~ (exists x, P x) <-> forall x, ~ P x.
 Proof.
  apply pair.
  -
   intros H x xH.
   apply H.
   apply ex_pair with x.
   apply xH.
  -
   intros H [x xH].
   apply H with x.
   apply xH.
 Defined.

End Predicate.

(** * Equality *)

(** 等号について。 *)

Module Equality.

 Export Predicate.

 (** ** eq *)

 Inductive eq (A : Type) (x : A) : A -> Type :=
 | eq_refl : x = x :> A
 where
   "x = y :> A" := (eq A x y) : type_scope
 .

 Notation "x = y" := (x = y :> _) : type_scope.
 Notation "x <> y :> T" := (~ x = y :> T) : type_scope.
 Notation "x <> y" := (x <> y :> _) : type_scope.

 Arguments eq {A} _ _.
 Arguments eq_refl {A x}, [A] x.

 Scheme eq_ind := Induction for eq Sort Type.
 Scheme eq_rec := Minimality for eq Sort Type.
 Definition eq_rect := eq_ind.

 Arguments eq_ind [A] _ _ _ _ _.
 Arguments eq_rec [A] _ _ _ _ _.
 Arguments eq_rect [A] _ _ _ _ _.

 (** eqの基本性質 *)

 Definition eq_sym {A : Type} {x y : A} : x = y -> y = x.
 Proof.
  intros [].
  apply eq_refl.
 Defined.

 Definition eq_trans {A : Type} {x y z : A} : x = y -> z = x -> y = z.
 Proof.
  intros [] [].
  apply eq_refl.
 Defined.

 (** eqの汎用関数 *)

 Definition eq_ind'
     : forall (A : Type) (P : forall a b : A, a = b -> Type),
         (forall a : A, P a a eq_refl) -> forall (a b : A) (p : a = b), P a b p.
 Proof.
  intros A P H a b [].
  apply H.
 Defined.

 Definition eq_rec'
     : forall (A : Type) (P : A -> A -> Type),
         (forall a : A, P a a) -> forall a b : A, a = b -> P a b.
 Proof.
  intros A P H a b [].
  apply H.
 Defined.

 Definition eq_rect' := eq_ind'.

 Definition eq_rec_r
     : forall (A : Type) (x : A) (P : A -> Type), P x -> forall (y : A), y = x -> P y.
 Proof.
  intros A x P H y p.
  apply (eq_rec x P H y).
  apply eq_sym.
  apply p.
 Defined.

 Arguments eq_ind' [A] _ _ _ _ _.
 Arguments eq_rec' [A] _ _ _ _ _.
 Arguments eq_rect' [A] _ _ _ _ _.
 Arguments eq_rec_r [A] _ _ _ _ _.

 Definition f_equal {A B : Type} (f : A -> B) {x y : A} : x = y -> f x = f y.
 Proof.
  intros [].
  apply eq_refl.
 Defined.

 Definition rew {A : Type} (P : A -> Type) {x y : A} : x = y -> P x -> P y.
 Proof.
  intros [].
  apply id.
 Defined.

End Equality.

Module Peano.
 Export Predicate Equality.

 Inductive nat : Type :=
 | O : nat
 | S : nat -> nat
 .

 Scheme nat_ind := Induction for nat Sort Type.
 Scheme nat_rec := Minimality for nat Sort Type.
 Definition nat_rect := nat_ind.

 Definition not_eq_O_S : forall n, O <> S n.
 Proof.
  intros n p.
  refine (
   match p in _ = x' return (match x' with O => Unit | S xp => Empty end) with
   | eq_refl _ _ => _
   end
  ).
  apply tt.
 Defined.

 Definition pred : nat -> nat :=
  fun x =>
   match x with
   | O => O
   | S xp => xp
   end
 .

 Inductive le (m : nat) : nat -> Type :=
 | le_n : le m m
 | le_S : forall n, le m n -> le m (S n)
 .

 Definition le_rect_simple : forall (m : nat) (P : nat -> Type),
   P m -> (forall n, le m n -> P n -> P (S n)) -> forall n, le m n -> P n.
 Proof.
  intros m P cN cS.
  apply le_rect.
  -
   apply cN.
  -
   apply cS.
 Defined.

 Definition le_ind_simple : forall (m : nat) (P : nat -> Prop),
   P m -> (forall n, le m n -> P n -> P (S n)) -> forall n, le m n -> P n.
 Proof.
  intros m P cN cS.
  apply le_rect.
  -
   apply cN.
  -
   apply cS.
 Defined.

 Definition le_rec_simple : forall (m : nat) (P : nat -> Set),
   P m -> (forall n, le m n -> P n -> P (S n)) -> forall n, le m n -> P n.
 Proof.
  intros m P.
  apply le_rect_simple.
 Defined.

 Definition le_0_n : forall n : nat, le O n.
 Proof.
  intros n.
  induction n as [ | n IHn ].
  -
   apply le_n.
  -
   apply le_S.
   apply IHn.
 Defined.

 Definition le_n_S : forall m n : nat, le m n -> le (S m) (S n).
 Proof.
  intros m.
  apply le_rect_simple.
  -
   apply le_n.
  -
   intros n nH H.
   apply le_S.
   apply H.
 Defined.

 Definition le_pred : forall m n : nat, le m n -> le (pred m) (pred n).
 Proof.
  intros m.
  apply le_rect_simple.
  -
   apply le_n.
  -
   intros [ | np ] nH H.
   +
    apply H.
   +
    cut (forall k, S (pred (S k)) = pred (S (S k))).
    *
     intros Lem.
     case (Lem np).
     apply le_S.
     apply H.
    *
     intros k.
     apply eq_refl.
 Defined.

 Definition le_S_n : forall m n : nat, le (S m) (S n) -> le m n.
 Proof.
  intros m n H.
  apply (le_pred (S m) (S n)).
  apply H.
 Defined.

 Definition le_trans : forall m n o, le m n -> le n o -> le m o.
 Proof.
  intros m n o H.
  revert o.
  apply le_rect_simple.
  -
   apply H.
  -
   intros o oH IH.
   apply le_S.
   apply IH.
 Defined.

 Definition lt m n := le (S m) n.

 Definition not_lt_n_0 : forall n, ~ lt n O.
 Proof.
  intros n nH.
  cut (O = O).
  -
   refine (
    match nH in le _ o' return O <> o' with
    | le_n _ => _
    | le_S _ o pH => _
    end
   ).
   +
    apply not_eq_O_S.
   +
    apply not_eq_O_S.
  -
   apply eq_refl.
 Defined.
End Peano.

Export Peano. *)

Module Path.
 Export Equality.

 Definition paths := @eq.

 Definition idpath := @eq_refl.

 Definition inverse := eq_sym.

 Definition concat := fun (A : Type) (x y z : A) => flip (@eq_trans A y z x).

 Definition transport := rew.

 Definition ap := f_equal.

 (** apKN

<<
ap00 :=
  fun (f   : A -> B)                       (x   : A)                => (_ : B)
ap01 :=
  fun (f   : A -> B)                       (x y : A) (p : eq A x y) => (_ : eq B (f x) (f y))
ap10 :=
  fun (f g : A -> B) (p : eq (A -> B) f g) (x   : A)                => (_ : eq B (f x) (g x))
ap11 :=
  fun (f g : A -> B) (p : eq (A -> B) f g) (x y : A) (q : eq A x y) => (_ : eq B (f x) (g y))
>>

 *)

 Definition ap00 := apply.

 Definition ap01 := ap.

 Definition ap10 : forall (A B : Type) (f g : A -> B), f = g -> forall (x : A), f x = g x.
 Proof.
  intros A B f g p x.
  case p.
  apply idpath.
 Defined.

 Definition ap11
     : forall (A B : Type) (f g : A -> B), f = g -> forall (x y : A), x = y -> f x = g y.
 Proof.
  intros A B f g p x y q.
  case p.
  case q.
  apply idpath.
 Defined.

 Definition pw_paths (A : Type) (P : A -> Type) (f g : forall x, P x) := forall x, f x = g x.

 Definition pw_idpath : forall (A : Type) (P : A -> Type) (f : forall x, P x), pw_paths P f f.
 Proof.
  intros A P f x.
  apply idpath.
 Defined.

 Definition pw_whiskerL (A B C : Type) (f : A -> B) (g h : B -> C)
     : pw_paths (fun _ => C) g h -> pw_paths (fun _ => C) (compose g f) (compose h f).
 Proof.
  intros p x.
  apply p.
 Defined.

 Definition pw_whiskerR (A B C : Type) (f g : A -> B) (h : B -> C)
     : pw_paths (fun _ => B) f g -> pw_paths (fun _ => C) (compose h f) (compose h g).
 Proof.
  intros p x.
  apply ap with (f := h).
  apply p.
 Defined.

 Definition pw_pw_paths
     (A : Type) (P : A -> Type) (f g : forall x, P x) (pw_p pw_q : pw_paths P f g)
   := forall x, pw_p x = pw_q x.

 Definition sect (A B : Type) (s : A -> B) (r : B -> A)
     := pw_paths (fun _ => A) (compose r s) id.

 Definition equiv (A B : Type)
     := exists (f : A -> B) (g : B -> A) (es : sect g f) (er : sect f g),
         pw_pw_paths (fun _ => B) (compose f (compose g f)) f
             (pw_whiskerL f (compose f g) id es)
             (pw_whiskerR (compose g f) id f er).

End Path.

Module Relation.
 Export Predicate.

 Definition relation (A : Type) := A -> A -> Type.

 Definition mere (A : Type) (R : relation A) := forall x y : A, forall p q : R x y, p = q.

 Section Classes.
  Variable A : Type.
  Variable R : relation A.

  Class Reflexive : Type :=
    reflexivity : forall x, R x x.

  Class Irreflexive :=
    irreflexivity : forall x, ~ R x x.

  Class Symmetric :=
    symmetry : forall x y, R x y -> R y x.

  Class Asymmetric :=
    asymmetry : forall x y, R x y -> ~ R y x.

  Class Antisymmetric :=
    antisymmetry : forall x y, R x y -> R y x -> x = y.

  Class Transitive :=
    transitivity : forall x y z, R x y -> R y z -> R x z.

  Class Well_Founded :=
    well_foundness : forall P, (forall x, (forall y, R y x -> P y) -> P x) -> (forall x, P x).

  Class Trichotomous :=
    trichotomy : forall x y, x = y \/ R x y \/ R y x.

  Class Extensional :=
    extensionality : forall x y, (forall a, R a x <-> R a y) -> x = y.

  Theorem th_0 `{WF : Well_Founded} : Irreflexive.
  Proof.
   unfold Irreflexive.
   apply well_foundness.
   intros x IH H.
   apply IH with x.
   -
    apply H.
   -
    apply H.
  Defined.

  Theorem th_1 `{WF : Well_Founded} : Asymmetric.
  Proof.
   unfold Asymmetric.
   apply (@well_foundness _ (fun x => forall y, R x y -> ~ R y x)).
   intros x IH y Hl Hr.
   apply IH with y x.
   -
    apply Hr.
   -
    apply Hr.
   -
    apply Hl.
  Defined.

  Theorem th_2 `{IR : Irreflexive} `{T : Trichotomous} : Extensional.
  Proof.
   unfold Extensional.
   intros x y H.
   destruct (@trichotomy _ x y) as [both | [left | right]].
   -
    apply both.
   -
    apply exfalso.
    apply irreflexivity with x.
    apply (second (H _)).
    apply left.
   -
    apply exfalso.
    apply irreflexivity with y.
    apply (first (H _)).
    apply right.
  Defined.

  Theorem th_3 `{WF : Well_Founded} `{T : Trichotomous} : Transitive.
  Proof.
   unfold Transitive.
   intros x y z Hl Hr.
   destruct (@trichotomy _ x z) as [both | [left | right]].
   -
    apply exfalso.
    assert (AS : Asymmetric).
    +
     apply th_1.
    +
     apply asymmetry with y z.
     *
      apply Hr.
     *
      case both.
      apply Hl.
  -
   apply left.
  -
   assert (tri_loop : forall x y z, R x y -> R y z -> R z x -> Empty).
   +
    clear x y z Hl Hr right.
    apply (@well_foundness _ (fun x => forall y z, R x y -> R y z -> R z x -> Empty)).
    intros x IH y z Hx Hy Hz.
    apply IH with z x y.
    *
     apply Hz.
    *
     apply Hz.
    *
     apply Hx.
    *
     apply Hy.
   +
    apply exfalso.
    apply tri_loop with x y z.
    *
     apply Hl.
    *
     apply Hr.
    *
     apply right.
  Defined.
 End Classes.

Module Type Ord.
 Parameter ord : Type.
 Parameter lt : ord -> ord -> Type.
End Ord.

Module Ord_Defs (Export Model : Ord).
 Definition le : ord -> ord -> Type := fun a b => lt a b \/ a = b.

 Definition le_lt : forall a b, lt a b -> le a b.
 Proof.
  intros a b H.
  apply left.
  apply H.
 Defined.

 Definition le_eq : forall a b, a = b -> le a b.
 Proof.
  intros a b H.
  apply right.
  apply H.
 Defined.

 Definition le_refl : forall a, le a a.
 Proof.
  intros a.
  apply le_eq.
  apply eq_refl.
 Defined.
End Ord_Defs.

Module Type Induction (Export Model : Ord).
 Axiom ind
   : forall p : ord -> Type, (forall a, (forall x, lt x a -> p x) -> p a) -> forall a, p a.
End Induction.

Module Induction_Defs (Model : Ord) (Export IndModel : Induction Model).
 Module Model_Ord_Defs := Ord_Defs Model.
 Export Model_Ord_Defs.

 Definition not_lt_refl : forall a, ~ lt a a.
 Proof.
  apply (ind (fun a => ~ lt a a)).
  intros a IHa H.
  apply IHa with a.
  -
   apply H.
  -
   apply H.
 Defined.

 Definition not_lt_sym : forall a b, lt a b -> ~ lt b a.
 Proof.
  apply (ind (fun a => forall b, lt a b -> ~ lt b a)).
  intros a IHa b Ha Hb.
  apply IHa with b a.
  -
   apply Hb.
  -
   apply Hb.
  -
   apply Ha.
 Defined.

 Definition not_lt_sym_and : forall a b, ~ (lt a b /\ lt b a).
 Proof.
  intros a b.
  apply not_and_then.
  apply not_lt_sym.
 Defined.

 Definition not_lt_inf_dec_chain : forall f, ~ (forall n, lt (f (S n)) (f n)).
 Proof.
  intros f inf_dec_chain.
  cut (forall a x, f x <> a).
  -
   intros H.
   apply H with (f O) O.
   apply eq_refl.
  -
   apply (ind (fun a => forall x, f x <> a)).
   intros a IHa x H.
   apply IHa with (f (S x)) (S x).
   +
    case H.
    apply inf_dec_chain.
   +
    apply eq_refl.
 Defined.

 Definition not_le_lt : forall a b, lt a b -> ~ le b a.
 Proof.
  intros a b H [L | R].
  -
   apply not_lt_sym with a b.
   +
    apply H.
   +
    apply L.
  -
   revert H.
   case R.
   apply not_lt_refl.
 Defined.

 Definition not_and_lt_le : forall a b, ~ (lt a b /\ le b a).
 Proof.
  intros a b.
  apply not_and_then.
  apply not_le_lt.
 Defined.

 Definition not_lt_le : forall a b, le a b -> ~ lt b a.
 Proof.
  intros a b.
  apply not_then_then.
  apply not_le_lt.
 Defined.
End Induction_Defs.

Module Type Extensionality (Export Model : Ord).
 Axiom extension : forall a b, (forall x, lt x a <-> lt x b) -> a = b.
End Extensionality.

Module Extensionality_Defs (Model : Ord) (Export ExModel : Extensionality Model).
End Extensionality_Defs.

Module Type Transitivity (Export Model : Ord).
 Axiom transition : forall a b c, lt a b -> lt b c -> lt a c.
End Transitivity.

Module Transitivity_Defs (Model : Ord) (Export TransModel : Transitivity Model).
End Transitivity_Defs.

Module IndExTrans_Defs
  (Model : Ord)
  (Export IndModel : Induction Model)
  (Export ExModel : Extensionality Model)
  (Export TransModel : Transitivity Model).

 Module IndDefs := Induction_Defs Model IndModel.
 Export IndDefs.

 Module ExDefs := Extensionality_Defs Model ExModel.
 Export ExDefs.

 Module TransDefs := Transitivity_Defs Model TransModel.
 Export TransDefs.

 (*
  double-negation translated [forall x y, x = y \/ lt x y \/ lt y x] (Gödel–Gentzen translation)
 *)
 Definition trichotomy : forall x y, ~ (~ ~ ~ x = y /\ ~ ~ (~ ~ ~ lt x y /\ ~ ~ ~ lt y x)).
 Proof.
  intros x y H.
  case H.
  intros HL HR.
  apply HL.
  intros HL'.
  apply HR.
  intros HR'.
  case HR'.
  intros HR'L HR'R.
  apply HR'L.

Module Nat_Ord <: Ord.
 Definition ord : Type := nat.
 Definition lt : ord -> ord -> Type := lt.
End Nat_Ord.

Module Nat_Induction <: Induction Nat_Ord.
 Export Nat_Ord.

 Definition ind
   : forall p : ord -> Type, (forall a, (forall x, lt x a -> p x) -> p a) -> forall a, p a.
 Proof.
  intros p f.
  cut (forall n k, lt k n -> p k).
  -
   intros Lem a.
   apply f.
   apply Lem.
  -
   apply (nat_rect (fun n => forall k, lt k n -> p k)).
   +
    intros k kH.
    apply Empty_rect.
    apply not_lt_n_0 with k.
    apply kH.
   +
    intros n IHn k kH.
    apply f.
    intros x xH.
    apply IHn.
    apply le_trans with k.
    *
     apply xH.
    *
     apply le_S_n.
     apply kH.
 Defined.
End Nat_Induction.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Defining recursive functions by Noetherian induction.  This is a simplified
  interface to the [Wf] module of Coq's standard library, where the functions
  to be defined have non-dependent types, and function extensionality is assumed. *)

Require Import Axioms.
Require Import Wf.
Require Import Wf_nat.

Set Implicit Arguments.

Section FIX.

Variables A B: Type.
Variable R: A -> A -> Prop.
Hypothesis Rwf: well_founded R.
Variable F: forall (x: A), (forall (y: A), R y x -> B) -> B.

Definition Fix (x: A) : B := Wf.Fix Rwf (fun (x: A) => B) F x.

Theorem unroll_Fix:
  forall x, Fix x = F (fun (y: A) (P: R y x) => Fix y).
Proof.
  unfold Fix; intros. apply Wf.Fix_eq with (P := fun (x: A) => B).
  intros. assert (f = g). apply functional_extensionality_dep; intros.
  apply functional_extensionality; intros. auto.
  subst g; auto.
Qed.

End FIX.

(** Same, with a nonnegative measure instead of a well-founded ordering *)

Section FIXM.

Variables A B: Type.
Variable measure: A -> nat.
Variable F: forall (x: A), (forall (y: A), measure y < measure x -> B) -> B.

Definition Fixm (x: A) : B := Wf.Fix (well_founded_ltof A measure) (fun (x: A) => B) F x.

Theorem unroll_Fixm:
  forall x, Fixm x = F (fun (y: A) (P: measure y < measure x) => Fixm y).
Proof.
  unfold Fixm; intros. apply Wf.Fix_eq with (P := fun (x: A) => B).
  intros. assert (f = g). apply functional_extensionality_dep; intros.
  apply functional_extensionality; intros. auto.
  subst g; auto.
Qed.

End FIXM.


From discprob.basic Require Import base sval order monad bigop_ext nify seq_ext.
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 seq div choice fintype finset finfun bigop.
Require Import stdpp.tactics.
Local Open Scope R_scope.
From discprob.idxval Require Import ival pival ival_dist pival_dist pidist_singleton extrema.
From discprob.prob Require Import prob countable finite stochastic_order.

Definition pspec {A: Type} (m: pidist A) (P: A → Prop) :=
  ∀ y, In_psupport y m → P y.

Section pspec.

  Context {A: Type}.
  Implicit Types m : pidist A.
  Implicit Types P : A → Prop.

Lemma pspec_mret (x: A) P:
  P x → pspec (mret x) P.
Proof.
  intros HP y. intros (I&i&Hin&Heq&Hgt).
  rewrite -Heq. inversion Hin as [Heq']. subst => //=.
Qed.

Lemma pspec_union m1 m2 P:
  pspec m1 P → pspec m2 P → pspec (pidist_union m1 m2) P.
Proof.
  intros HP1 HP2. intros a (I&i&Hin&?&?).
  destruct Hin.
  * eapply HP1; eauto. eexists; eauto.
  * eapply HP2; eauto. eexists; eauto.
Qed.

Lemma pspec_union_inv_l m1 m2 P:
  pspec (pidist_union m1 m2) P →
  pspec m1 P.
Proof.
  intros HP. intros a (I&i&Hin&?&?).
  eapply HP. eapply In_psupport_alt. exists I; split_and!; eauto.
  * by left.
  * eexists; eauto.
Qed.

Lemma pspec_union_inv_r m1 m2 P:
  pspec (pidist_union m1 m2) P →
  pspec m2 P.
Proof.
  intros HP. intros a (I&i&Hin&?&?).
  eapply HP. eapply In_psupport_alt. exists I; split_and!; eauto.
  * by right.
  * eexists; eauto.
Qed.

Lemma In_isupport_proper (a: A) (I1 I2: ival A):
  eq_ival I1 I2 →
  In_isupport a I1 →
  In_isupport a I2.
Proof.
  intros Heq Hin.
  destruct Heq as (w1&w2&?&?&Hind&Hval).
  destruct Hin as (i1&Heq&Hgt).
  assert (Hgti: Rgt_dec (val I1 i1) 0).
  { destruct Rgt_dec => //=. }
  unshelve (eexists).
  { exact (sval (w1 (exist _ i1 Hgti))).  }
  rewrite Hind Hval //=.
Qed.

Lemma In_psupport_proper (a: A) (I1 I2: pival A):
  eq_pival I1 I2 →
  In_psupport a I1 →
  In_psupport a I2.
Proof.
  intros Heqpi (I&i&Hin&Heq&Hval).
  apply In_psupport_alt.
  destruct (Heqpi) as (Hle1&Hle2).
  destruct (Hle1 _ Hin) as (I'&HeqI'&Hin').
  exists I'; split; auto. eapply In_isupport_proper; try eassumption.
  subst. eexists; eauto.
Qed.

Global Instance pspec_proper:
  Proper (@eq_pidist A ==> pointwise_relation A iff ==> iff) pspec.
Proof.
  intros m1 m2 Heq P1 P2 Hiff.
  split.
  - intros Hm x Hin. apply Hiff. apply Hm. eapply In_psupport_proper; eauto.
    by symmetry.
  - intros Hm x Hin. apply Hiff. apply Hm. eapply In_psupport_proper; eauto.
Qed.

Lemma In_isupport_iscale p (I: ival A) x:
  In_isupport x (iscale p I) → In_isupport x I.
Proof.
  intros (i&Heq&Hval).
  subst. rewrite //=. exists i; split; eauto.
  rewrite //= in Hval.
  apply Rlt_gt.
  destruct (Rabs_pos p).
  * eapply Rmult_gt_reg_l; first eassumption.
    nra.
  * nra.
Qed.

Lemma In_psupport_pscale p (Is: pival A) x:
  In_psupport x (pscale p Is) → In_psupport x Is.
Proof.
  intros (I&i&Hin&Heq&Hval).
  apply pscale_in_inv in Hin as (I'&?&?).
  apply In_psupport_alt.
  exists I'; split; eauto.
  eapply In_isupport_iscale.
  eapply In_isupport_proper; eauto. subst.
  eexists; eauto.
Qed.

Lemma pspec_pidist_plus p Hpf m1 m2 P:
  pspec m1 P → pspec m2 P → pspec (pidist_plus p Hpf m1 m2) P.
Proof.
  intros HP1 HP2. intros a (I&i&Hin&?&Hval).
  destruct Hin as (I1&I2&Hin1&Hin2&Heq).
  subst. rewrite //= in Hval. destruct i as [i|i].
  * eapply HP1. rewrite //=. eapply In_psupport_pscale; eauto.
    exists I1; eauto.
  * eapply HP2. rewrite //=. eapply In_psupport_pscale; eauto.
    exists I2; eauto.
Qed.

Lemma pspec_conseq m (P Q: A → Prop):
  pspec m P → (∀ a, P a → Q a) → pspec m Q.
Proof.
  intros HP HPQ a Hin. apply HPQ; eauto.
Qed.

Lemma pspec_mbind {B: Type} (f: A → pidist B) m (P: A → Prop) (Q: B → Prop):
  pspec m P →
  (∀ a, P a → pspec (f a) Q) →
  pspec (mbind f m) Q.
Proof.
  intros Hinput Hbody b Hin.
  edestruct (@In_psupport_bind_inv) as (x&Hin'&I&i&?&?); eauto.
  eapply Hbody; eauto. exists I, i. eauto.
Qed.

Lemma pspec_bounded m (f: A → R):
  (∃ c, pspec m (λ x, Rabs (f x) <= c)) →
  bounded_fun_on f (λ x, In_psupport x m).
Proof.
  intros (c&Hspec). exists c. intros. eapply Hspec; eauto.
Qed.

Lemma bounded_psupp_pidist_plus f p Hpf (Is1 Is2: pidist A):
    bounded_fun_on f (λ i, In_psupport i Is1) →
    bounded_fun_on f (λ i, In_psupport i Is2) →
    bounded_fun_on f (λ i, In_psupport i (pidist_plus p Hpf Is1 Is2)).
Proof.
  intros (max1&Hm1).
  intros (max2&Hm2).
  exists (Rmax max1 max2).
  eapply pspec_pidist_plus.
  * eapply pspec_conseq; rewrite /pspec; first apply Hm1.
    intros. setoid_rewrite <-Rmax_l. auto.
  * eapply pspec_conseq; rewrite /pspec; first apply Hm2.
    intros. setoid_rewrite <-Rmax_r. auto.
Qed.

End pspec.

Tactic Notation "pbind" open_constr(P) :=
  match goal with
  | [ |- pspec (mbind ?f ?m) ?Q ] =>
    intros; eapply (@pspec_mbind _ _ f m P); auto
  end.


(** The polymorphic lambda calculus, a.k.a. System F *)

(** * Description *)

(** The main elements of this file are:

  - Syntax: types [ty] and terms [tm], with typed DeBruijn indices.
  - Denotational semantics:
      - [eval_ty]: types evaluated as Coq types;
      - [eval_tm]: terms evaluated as Coq values;
      - [eval2_ty]: types evaluated/interpreted as (Coq) relations between term
        values/denotations.
  - Parametricity theorem, [parametricity]: all terms satisfy the relational
    interpretation of their type.

  Example application:
  - [parametric_ID]: the polymorphic identity function is the only function of
    its type.
  *)

(* begin hide *)
Require Import List.
Import ListNotations.
(* end hide *)

(** * Generic (dependently typed) data structures *)

(** If you're reading this for the first time, you might want to
    skip to the next section, Polymorphic lambda calculus. *)

(** ** Bijections *)

Record iso (A B : Type) : Type :=
  { iso_from : A -> B
  ; iso_to   : B -> A
  }.

Arguments iso_from {A B} _.
Arguments iso_to {A B} _.

Definition iso_id {A} : iso A A :=
  {| iso_from := fun i => i ; iso_to := fun i => i |}.

Definition iso_prod {A A' B B'}
  : iso A A' -> iso B B' -> iso (A * B) (A' * B') :=
  fun ia ib =>
    {| iso_from := fun x => (iso_from ia (fst x), iso_from ib (snd x))
     ; iso_to   := fun x => (iso_to ia (fst x), iso_to ib (snd x))
    |}.

Definition iso_sum {A A' B B'}
  : iso A A' -> iso B B' -> iso (A + B) (A' + B') :=
  fun ia ib =>
    {| iso_from := fun x =>
         match x with
         | inl y => inl (iso_from ia y)
         | inr z => inr (iso_from ib z)
         end
     ; iso_to := fun x =>
         match x with
         | inl y => inl (iso_to ia y)
         | inr z => inr (iso_to ib z)
         end
    |}.

Definition iso_eq {A A'}
  : A = A' -> iso A A' :=
  fun e =>
  match e with
  | eq_refl => iso_id
  end.

(** ** Generic collections *)

(** Bounded nats *)
Fixpoint bnat (n : nat) : Type :=
  match n with
  | O => Empty_set
  | S n => option (bnat n)
  end.

Definition N0 {n : nat} : bnat (S n) := None.
Definition NS {n : nat} : bnat n -> bnat (S n) := Some.

Notation N1 := (NS N0).
Notation N2 := (NS N1).
Notation N3 := (NS N2).

(** Length-indexed lists (aka "vectors") *)
Fixpoint lilist (A : Type) (n : nat)
  : Type :=
  match n with
  | O => unit
  | S n => A * lilist A n
  end.

(** Heterogeneous lists (type-indexed lists)
    This could also be defined with [lilist]. *)
Fixpoint hlist {A : Type} (f : A -> Type) (xs : list A)
  : Type :=
  match xs with
  | [] => unit
  | x :: xs => f x * hlist f xs
  end.

(** Heterogeneous lists indexed by two lists. *)
Fixpoint ziphlist {A B : Type} {n : nat} (f : A -> B -> Type)
  : lilist A n -> lilist B n -> Type :=
  match n with
  | O => fun _ _ => unit
  | S n => fun ts1 ts2 =>
      (f (fst ts1) (fst ts2) * ziphlist f (snd ts1) (snd ts2))%type
  end.

(** *** Bounded lookup *)

Fixpoint lookup_lilist {A : Type} {n : nat}
  : bnat n -> lilist A n -> A :=
  match n with
  | O => fun y => match y with end
  | S n => fun tv ts =>
    match tv with
    | None => fst ts
    | Some tv => lookup_lilist tv (snd ts)
    end
  end.

Fixpoint lookup_list {A : Type} (xs : list A) : bnat (length xs) -> A :=
  match xs with
  | [] => fun v => match v with end
  | x :: xs => fun v =>
    match v with
    | None => x
    | Some v => lookup_list xs v
    end
  end.

Fixpoint lookup_hlist {A} {f : A -> Type} {vs : list A}
  : forall v : bnat (length vs), hlist f vs -> f (lookup_list vs v) :=
  match vs with
  | [] => fun v => match v with end
  | t :: vs => fun v vls =>
    match v with
    | None => fst vls
    | Some v => lookup_hlist v (snd vls)
    end
  end.

Fixpoint lookup_ziphlist {A B} {f : A -> B -> Type} {n : nat}
  : forall {ts1 : lilist A n} {ts2 : lilist B n} (tv : bnat n),
      ziphlist f ts1 ts2 -> f (lookup_lilist tv ts1) (lookup_lilist tv ts2) :=
  match n with
  | O => fun _ _ tv => match tv with end
  | S n => fun ts1 ts2 tv rs =>
      match tv with
      | None => fst rs
      | Some tv => lookup_ziphlist tv (snd rs)
      end
  end.

Definition rel_list {n : nat} : lilist Type n -> lilist Type n -> Type :=
  ziphlist (fun a b => a -> b -> Prop).

(** *** Insertion *)

(** "Insert" a number in the range [[0 .. n-1]] into the range [[0 .. n]],
    by sending [[0 .. m-1]] to itself, and [[m .. n-1]] to [[m+1 .. n]]. *)
Fixpoint insert_bnat (m : nat) {n : nat} : bnat n -> bnat (S n) :=
  match n with
  | O => fun v => match v with end
  | S n => fun v =>
    match m with
    | O => Some v
    | S m =>
      match v with
      | None => None
      | Some v => Some (insert_bnat m v)
      end
    end
  end.

(** Insert an element at position [n]. *)
Fixpoint insert_lilist {A} (m : nat) (t0 : A) {n : nat}
  : lilist A n -> lilist A (S n) :=
  match m with
  | O => fun ts => (t0, ts)
  | S m =>
    match n with
    | O => fun _ => (t0, tt)
    | S n => fun ts => (fst ts, insert_lilist m t0 (snd ts))
    end
  end.

Fixpoint eq_insert_lookup_lilist (m : nat) (t0 : Type) {n : nat}
  : forall {ts : lilist Type n} (tv : bnat n),
        lookup_lilist tv ts
      = lookup_lilist (insert_bnat m tv) (insert_lilist m t0 ts) :=
  match n with
  | O => fun ts tv => match tv with end
  | S n => fun ts tv =>
    match m with
    | O => eq_refl
    | S m =>
      match tv with
      | None => eq_refl
      | Some tv => eq_insert_lookup_lilist m t0 tv
      end
    end
  end.

Definition iso_insert_lookup_lilist (m : nat) (t0 : Type) {n : nat}
  : forall {ts : lilist Type n} (tv : bnat n),
      iso (lookup_lilist tv ts) (lookup_lilist (insert_bnat m tv) (insert_lilist m t0 ts)) :=
  fun ts tv => iso_eq (eq_insert_lookup_lilist m t0 tv).

Fixpoint insert_lookup_rel_list (m : nat) {n : nat}
  {t01 t02 : Type} (r0 : t01 -> t02 -> Prop)
  : forall {ts01 ts02 : lilist Type n},
      rel_list ts01 ts02 -> rel_list (insert_lilist m t01 ts01) (insert_lilist m t02 ts02) :=
  match m with
  | O => fun _ _ rs => (r0, rs)
  | S m =>
    match n with
    | O => fun _ _ rs => (r0, rs)
    | S n => fun _ _ rs => (fst rs, insert_lookup_rel_list m r0 (snd rs))
    end
  end.

(** * Polymorphic lambda calculus *)

(** ** Syntax *)

(** *** Types *)

(**
<<
t ::= t -> t     (* Function *)
    | forall t   (* Type generalization *)
    | i          (* Type variable (DeBruijn index) *)
    | unit       (* Unit type *)
    | t * t      (* Product *)
    | t + t      (* Sum *)
>>
  *)
Inductive ty (n : nat) : Type :=
| Arrow : ty n -> ty n -> ty n
| Forall : ty (S n) -> ty n
| Tyvar : bnat n -> ty n

(* Basic data types *)
| Unit : ty n
| Prod : ty n -> ty n -> ty n
| Sum : ty n -> ty n -> ty n
.

Arguments Arrow  {n}.
Arguments Forall {n}.
Arguments Tyvar  {n}.

Arguments Unit {n}.
Arguments Prod {n}.
Arguments Sum  {n}.

(** **** Notations *)

Delimit Scope ty_scope with ty.
Bind Scope ty_scope with ty.

Infix "->" := Arrow : ty_scope.
Coercion Tyvar : bnat >-> ty.

Definition V0 {n} : bnat (S n) := N0.
Definition V1 {n} : bnat (S (S n)) := NS N0.
Definition V2 {n} : bnat (S (S (S n))) := NS (NS N0).

(** Shift *)
Fixpoint shift_ty (m : nat) {n : nat} (t : ty n) : ty (S n) :=
  match t with
  | Arrow t1 t2 => Arrow (shift_ty m t1) (shift_ty m t2)
  | Forall t => Forall (shift_ty (S m) t)
  | Tyvar v => @Tyvar (S n) (insert_bnat m v)
  | Unit => Unit
  | Prod t1 t2 => Prod (shift_ty m t1) (shift_ty m t2)
  | Sum t1 t2 => Sum (shift_ty m t1) (shift_ty m t2)
  end.

(** *** Terms *)

Section Constants.

Context {n : nat}.

(** Constants *)
Inductive cn : ty n -> Type :=
| One : cn Unit
  (* [unit] *)

| Pair : cn (Forall (Forall (V1 -> V0 -> Prod V1 V0)))
  (* [forall a b, a -> b -> a * b] *)

| Fst : cn (Forall (Forall (Prod V1 V0 -> V1)))
  (* [forall a b, a * b -> a] *)

| Snd : cn (Forall (Forall (Prod V1 V0 -> V0)))
  (* [forall a b, a * b -> b] *)

| Inl : cn (Forall (Forall (V1 -> Sum V1 V0)))
  (* [forall a b, a -> a + b] *)

| Inr : cn (Forall (Forall (V0 -> Sum V1 V0)))
  (* [forall a b, b -> a + b] *)

| Case : cn (Forall (Forall (Forall (
    (V2 -> V0) ->
    (V1 -> V0) ->
    Sum V2 V1 -> V0))))
  (* [forall a b c, (a -> c) -> (b -> c) -> (a + b -> c)] *)
.

End Constants.

(**
<<
u ::= tyfun u   (* Type abstraction *)
    | fun u     (* Value abstraction *)
    | u u       (* Application *)
    | i         (* Variable *)
    | c         (* Constant *)
>>
  *)
Inductive tm (n : nat) (vs : list (ty n)) : ty n -> Type :=
| TAbs {t}
  : tm (S n) (map (shift_ty 0) vs) t ->
    tm n vs (Forall t)
| Abs {t1 t2}
  : tm n (t1 :: vs) t2 ->
    tm n vs (Arrow t1 t2)
| App {t1 t2}
  : tm n vs (Arrow t1 t2) ->
    tm n vs t1 ->
    tm n vs t2
| Var (v : bnat (length vs))
  : tm n vs (lookup_list vs v)
| Con {t}
  : cn t ->
    tm n vs t
.

Arguments TAbs {n vs t}.
Arguments Abs  {n vs t1 t2}.
Arguments App  {n vs t1 t2}.
Arguments Var  {n vs}.
Arguments Con  {n vs t}.

Delimit Scope tm_scope with tm.
Bind Scope tm_scope with tm.

Infix "@@" := App (at level 40) : tm_scope.

(** Closed term *)
Notation tm0 := (tm 0 []).

(** ** Semantics *)

(** *** Types *)

(** Semantics of types as Coq types *)
Fixpoint eval_ty {n : nat} (ts : lilist Type n) (t : ty n)
  : Type :=
  match t with
  | Arrow t1 t2 => eval_ty ts t1 -> eval_ty ts t2
  | Forall t => forall (t0 : Type), @eval_ty (S n) (t0, ts) t
  | Tyvar tv => lookup_lilist tv ts
  | Unit => unit
  | Prod t1 t2 => eval_ty ts t1 * eval_ty ts t2
  | Sum t1 t2 => eval_ty ts t1 + eval_ty ts t2
  end.

(** Semantics of types in the empty context. *)
Definition eval_ty0 : ty 0 -> Type := @eval_ty 0 tt.

(** *** Terms *)

(** To evaluate terms, we need some auxiliary functions to update the context
  when new type variables are introduced, together with the [Type] that the
  variable denotes. *)

(** Add a new variable-[Type] binding to the context of a term *)
Fixpoint shift_eval (m : nat) {n : nat} {ts : lilist Type n} (t0 : Type) (t : ty n)
  : iso (eval_ty ts t) (@eval_ty (S n) (insert_lilist m t0 ts) (shift_ty m t)) :=
  match t with
  | Arrow t1 t2 =>
      let i1 := shift_eval m t0 t1 in
      let i2 := shift_eval m t0 t2 in
      {| iso_from := fun f x1 => iso_from i2 (f (iso_to i1 x1))
       ; iso_to := fun f x0 => iso_to i2 (f (iso_from i1 x0))
      |}
  | Forall t =>
      {| iso_from := fun (f : forall a : Type, @eval_ty (S n) (a, ts) t) a =>
           let i := @shift_eval (S m) (S n) (a, ts) t0 t in
           iso_from i (f a)
       ; iso_to := fun (f : forall a : Type, @eval_ty (S (S n)) (a, _) (shift_ty (S m) t)) a =>
           let i := @shift_eval (S m) (S n) (a, _) t0 t in
           iso_to i (f a)
      |} : iso (forall (a : Type), @eval_ty (S n) (a, ts) t) _
  | Tyvar tv => iso_insert_lookup_lilist m t0 tv
  | Unit => iso_id
  | Prod t1 t2 => iso_prod (shift_eval m t0 t1) (shift_eval m t0 t2)
  | Sum t1 t2 => iso_sum (shift_eval m t0 t1) (shift_eval m t0 t2)
  end.

(** Add a new variable-[Type] binding to the context of a context. *)
Fixpoint shift_hlist {n : nat} {ts : lilist Type n} {vs : list (ty n)} (t0 : Type)
  : hlist (eval_ty ts) vs -> hlist (@eval_ty (S n) (t0, ts)) (map (shift_ty 0) vs) :=
  match vs with
  | [] => fun _ => tt
  | t :: vs => fun ts =>
    (iso_from (shift_eval 0 t0 _) (fst ts), shift_hlist t0 (snd ts))
  end.

(** Semantics of constants as Coq values *)
Definition eval_cn {n : nat} (ts : lilist Type n) {t : ty n} (c : cn t)
  : eval_ty ts t :=
  match c with
  | One => tt
  | Pair => @pair
  | Fst => @fst
  | Snd => @snd
  | Inl => @inl
  | Inr => @inr
  | Case => fun _ _ _ f g x =>
    match x with
    | inl y => f y
    | inr z => g z
    end
  end.

(** Semantics of terms as Coq values *)
Fixpoint eval_tm
  {n : nat} (ts : lilist Type n)
  {vs : list (ty n)} (vls : hlist (eval_ty ts) vs)
  {t : ty n} (u : tm n vs t)
  : eval_ty ts t :=
  match u with
  | TAbs u => fun t0 => @eval_tm (S n) (t0, ts) _ (shift_hlist t0 vls) _ u
  | Abs u => fun x => @eval_tm _ ts (_ :: vs) (x, vls) _ u
  | App u1 u2 => (eval_tm ts vls u1) (eval_tm ts vls u2)
  | Var v => lookup_hlist v vls
  | Con c => eval_cn _ c
  end.

(** Semantics of terms in the empty context *)
Definition eval_tm0 {t : ty 0} : tm0 t -> eval_ty0 t :=
  @eval_tm 0 tt [] tt t.

(** *** Types as relations *)

(** Relational semantics of types *)
Fixpoint eval2_ty {n : nat}
  {ts1 ts2 : lilist Type n}
  (rs : rel_list ts1 ts2)
  (t : ty n)
  : eval_ty ts1 t -> eval_ty ts2 t -> Prop :=
  match t with
  | Arrow t1 t2 => fun f1 f2 =>
      forall x1 x2, eval2_ty rs t1 x1 x2 -> eval2_ty rs t2 (f1 x1) (f2 x2)
  | Forall t => fun f1 f2 =>
      forall (t01 t02 : Type) (r0 : t01 -> t02 -> Prop),
        @eval2_ty (S n) (t01, ts1) (t02, ts2) (r0, rs) t (f1 t01) (f2 t02)
  | Tyvar tv => lookup_ziphlist tv rs

  | Unit => fun _ _ => True
  | Prod t1 t2 => fun x1 x2 =>
      eval2_ty rs t1 (fst x1) (fst x2) /\
      eval2_ty rs t2 (snd x1) (snd x2)
  | Sum t1 t2 => fun x1 x2 =>
      match x1, x2 with
      | inl y1, inl y2 => eval2_ty rs t1 y1 y2
      | inr z1, inr z2 => eval2_ty rs t2 z1 z2
      | _, _ => False
      end
  end.

(** Relational semantics in the empty context *)
Definition eval2_ty0 (t : ty 0) : eval_ty0 t -> eval_ty0 t -> Prop :=
  @eval2_ty 0 tt tt tt t.

(** Relational semantics of contexts *)
Fixpoint eval2_ctx {n : nat} {vs : list (ty n)}
  : forall
      {ts1 ts2 : lilist Type n} (rs : rel_list ts1 ts2)
      (vls1 : hlist (eval_ty ts1) vs) (vls2 : hlist (eval_ty ts2) vs),
        Prop :=
  match vs with
  | [] => fun _ _ _ _ _ => True
  | v :: vs => fun _ _ rs vls1 vls2 =>
    eval2_ty rs v (fst vls1) (fst vls2) /\
    eval2_ctx rs (snd vls1) (snd vls2)
  end.

(** ** Parametricity theorem *)

(* TODO: generalize *)
Lemma param_insert_bnat_from (m : nat)
  : forall {n : nat}
      (ts1 ts2 : lilist Type n)
      (rs : rel_list ts1 ts2)
      (v : bnat n)
      (t01 t02 : Type) (r0 : t01 -> t02 -> Prop)
      (vl1 : lookup_lilist v ts1) (vl2 : lookup_lilist v ts2)
      , lookup_ziphlist v rs vl1 vl2 ->
        lookup_ziphlist (insert_bnat m v) (insert_lookup_rel_list m r0 rs)
          (iso_from (iso_insert_lookup_lilist m t01 v) vl1)
          (iso_from (iso_insert_lookup_lilist m t02 v) vl2).
Proof.
  induction m; intros; cbn; (destruct n; [ destruct v |]); auto.
  destruct v; cbn; auto.
  apply IHm. auto.
Qed.

Lemma param_insert_bnat_to (m : nat)
  : forall {n : nat}
      (ts1 ts2 : lilist Type n)
      (rs : rel_list ts1 ts2)
      (v : bnat n)
      (t01 t02 : Type) (r0 : t01 -> t02 -> Prop)
      (vl1' : lookup_lilist (insert_bnat m v) (insert_lilist m t01 ts1))
      (vl2' : lookup_lilist (insert_bnat m v) (insert_lilist m t02 ts2))
      , lookup_ziphlist (insert_bnat m v) (insert_lookup_rel_list m r0 rs) vl1' vl2'->
        lookup_ziphlist v rs
          (iso_to (iso_insert_lookup_lilist m t01 v) vl1')
          (iso_to (iso_insert_lookup_lilist m t02 v) vl2').
Proof.
  induction m; intros; cbn; (destruct n; [ destruct v |]); auto.
  destruct v; cbn in *; auto.
  apply IHm in H. auto.
Qed.

(* TODO: get rid of this hack of not unfolding these function. *)
Section Hack_param_shift.
Arguments lookup_ziphlist : simpl never.
Arguments lookup_lilist : simpl never.

Lemma param_shift (m : nat) {n : nat}
  (ts1 ts2 : lilist Type n)
  (rs : rel_list ts1 ts2)
  (t : ty n)
  (t01 t02 : Type)
  (r0 : t01 -> t02 -> Prop)
  : (forall (vl1 : eval_ty ts1 t) (vl2 : eval_ty ts2 t),
       eval2_ty rs t vl1 vl2 ->
       @eval2_ty (S n) _ _ (insert_lookup_rel_list m r0 rs) (shift_ty m t)
         (iso_from (shift_eval m t01 _) vl1)
         (iso_from (shift_eval m t02 _) vl2))
  /\ (forall vl1' vl2',
       eval2_ty (insert_lookup_rel_list m r0 rs) (shift_ty m t) vl1' vl2' ->
       eval2_ty rs t
         (iso_to (shift_eval m t01 _) vl1')
         (iso_to (shift_eval m t02 _) vl2')).
Proof.
  revert m.
  induction t; cbn; intros; auto.
  - edestruct IHt1, IHt2; auto.
  - split; intros;
      eapply (IHt (_, ts1) (_, ts2) (r1, rs) (S m));
      eauto.
  - split; intros.
    + auto using param_insert_bnat_from.
    + eauto using param_insert_bnat_to.
  - split; intros; destruct H; split; apply IHt1 + apply IHt2; auto.
  - split; intros; destruct (_ : _ + _), (_ : _ + _);
      contradiction + apply IHt1 + apply IHt2; auto.
Qed.

End Hack_param_shift.

Lemma param_tabs {n : nat}
  (ts1 ts2 : lilist Type n)
  (rs : rel_list ts1 ts2)
  (vs : list (ty n)) (vls1 : hlist (eval_ty ts1) vs) (vls2 : hlist (eval_ty ts2) vs)
  (t01 t02 : Type)
  (r0 : t01 -> t02 -> Prop)
  : eval2_ctx rs vls1 vls2 ->
    @eval2_ctx (S n) _ (t01, ts1) (t02, ts2) (r0, rs)
      (shift_hlist t01 vls1)
      (shift_hlist t02 vls2).
Proof.
  induction vs; auto.
  destruct vls1, vls2; cbn.
  intros []; split; auto.
  apply (param_shift 0); auto.
Qed.

Lemma param_var {n : nat}
  (ts1 ts2 : lilist Type n)
  (rs : rel_list ts1 ts2)
  (vs : list (ty n)) (vls1 : hlist (eval_ty ts1) vs) (vls2 : hlist (eval_ty ts2) vs)
  (v : bnat (length vs))
  : eval2_ctx rs vls1 vls2 ->
    eval2_ty rs (lookup_list vs v) (lookup_hlist v vls1) (lookup_hlist v vls2).
Proof.
  induction vs; [ contradiction | ].
  destruct vls1, vls2, v; cbn; intros []; auto.
Qed.

Lemma param_cn {n : nat}
  (ts1 ts2 : lilist Type n)
  (rs : rel_list ts1 ts2)
  (t : ty n)
  (c : cn t)
  : eval2_ty rs t (eval_cn ts1 c) (eval_cn ts2 c).
Proof.
  destruct c; simpl; auto; intros.
  - apply H.
  - apply H.
  - do 2 destruct (_ : _ + _); contradiction + auto.
Qed.

(** Main theorem! Every term satisfies the logical relation of its type. *)
Theorem parametricity (n : nat)
  (ts1 ts2 : lilist Type n)
  (rs : rel_list ts1 ts2)
  (vs : list (ty n)) (vls1 : hlist (eval_ty ts1) vs) (vls2 : hlist (eval_ty ts2) vs)
  (t : ty n)
  (u : tm n vs t)
  : eval2_ctx rs vls1 vls2 -> eval2_ty rs t (eval_tm ts1 vls1 u) (eval_tm ts2 vls2 u).
Proof.
  induction u; cbn; intros; auto.
  - (* TAbs u *)
    auto using param_tabs.

  - (* Abs u *)
    apply IHu; split; auto.

  - (* App u1 u2 *)
    pose proof H as H'.
    apply IHu1 in H.
    apply IHu2 in H'.
    auto.

  - (* Var v *)
    apply param_var; auto.

  - (* Con c *)
    apply param_cn.
Qed.

(** Parametricity theorem in the empty context. *)
Theorem parametricity0 (t : ty 0) (u : tm0 t)
  : eval2_ty0 t (eval_tm0 u) (eval_tm0 u).
Proof.
  apply parametricity. constructor.
Qed.

(** * Examples *)

(** Type of the polymorphic identity function *)
Definition ID_ty {n} : ty n := (Forall (V0 -> V0)).

Compute (eval_ty0 ID_ty).
Compute (eval2_ty0 ID_ty).

(** Any term [u] of the same type as the polymorphic identity behaves like the
    identity function. Let [f] be the interpretation of [u] ([f := eval_tm0 u]),
    then [f _ a = a].
  *)
Example parametric_ID (t : tm0 ID_ty) (A : Type) (a : A)
  : (eval_tm0 t) A a = a.
Proof.
  pose proof (parametricity0 ID_ty t A A (fun x1 x2 => x1 = a) a a) as H.
  simpl in H; auto.
Qed.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import ZArith machine_int.
Import MachineInt.
Require Import mips_cmd.

Local Open Scope mips_cmd_scope.

Definition abs (rx a0 : reg) :=
  addu a0 r0 rx ;
  sra a0 rx (Z2u 5 31) ;
  xor rx rx a0 ;
  subu rx rx a0.