(************************************************************************)
(* Copyright 2006 Milad Niqui                                           *)
(* This file is distributed under the terms of the                      *)
(* GNU Lesser General Public License Version 2.1                        *)
(* A copy of the license can be found at                                *)
(*                  <http://www.gnu.org/licenses>                       *)
(************************************************************************)

 Require Import R_addenda.
Require Import Fourier_solvable_ineqs.
Require Import Fourier.
Require Import digits.
Require Import ub.
Require Import LNP_Digit.
Require Import homographic.
Require Import hcorrectness.
Require Import Refining_M.
Require Import Bounded_M.
Require Import Incl_M.

(** * Obtaining the productivity predicate for the refining Moebius maps. *)

Open Scope Z_scope.
Open Scope Q_scope.

Lemma thesis_5_6_9:forall mu H_refining, diameter mu H_refining < redundancy -> {d:Digit| Incl_M mu d}.
Proof.
 intros ((a,b),(c,d)) H_refining.
 assert (H_bounded:=proj1 H_refining).
 assert (H_denom: forall r : R, (-1 <= r <= 1)%R -> denom_nonvanishing_M (a, b, (c, d)) r);
  [intros r Hr; apply Is_refining_M_denom_nonvanishing_M; trivial|].
 set (mu_1:=as_Moebius_Q ((a,b),(c,d)) Qone).
 set (mu_2:=as_Moebius_Q ((a,b),(c,d)) (- Qone)).
 destruct (Qle_dec_weak (a*d-b*c) Zero) as [H_det|H_det]; unfold diameter,redundancy; fold mu_1 mu_2.
  (* det(mu)<=0 *)
  assert (H_mu:=det_nonpos_refining_endpoints _ _ _ _ H_refining H_det); fold mu_1 mu_2 in H_mu.
  rewrite (Qabs_non_eq _ (Qle_Qminus_Zero_neg _ _ H_mu)); intro H_diam.
  destruct (Q_le_lt_dec mu_2 Zero) as [H_mu_2|H_mu_2].
   (* mu(-1)<=0 *)
   exists LL.
   apply Incl_M_L_folded; trivial; intros r Hr; split.
    elim (Is_refining_M_property _ _ Hr H_refining); trivial.
    apply Rle_trans with mu_2; [ | realify_Q; auto].
     generalize (det_nonpos_nonincreasing _ _ _ _ (-1) r H_bounded H_det min_one_is_in_base_interval Hr (proj1 Hr));
     unfold mu_2, as_Moebius_Q, as_Moebius; simpl;
     let t_local:=  (destruct H_bounded as [[H1 H2]|[H1 H2]]; simpl in H1, H2; auto) in realify_Q_goal;
     [ trivial
     | stepl (d-c); try ring; t_local
     ].
   (* 0<mu(-1) *)
   destruct (Q_le_lt_dec Zero mu_1) as [H_mu_1|H_mu_1].
    (* 0<=mu(1) *)
    exists RR.
    apply Incl_M_R_folded; trivial; intros r Hr; split.
     apply Rle_trans with mu_1; [ realify_Q; auto| ].
      generalize (det_nonpos_nonincreasing _ _ _ _ r 1 H_bounded H_det Hr one_is_in_base_interval (proj2 Hr));
      unfold mu_1, as_Moebius_Q, as_Moebius; simpl.
      let t_local:=  (destruct H_bounded as [[H1 H2]|[H1 H2]]; simpl in H1, H2; auto) in realify_Q_goal;
      [ trivial
      | stepl (d+c); try ring; t_local
      ].
     elim (Is_refining_M_property _ _ Hr H_refining); trivial.
    (* mu(1)<Zero *)
    exists MM.
    apply Incl_M_M_folded; trivial; intros r Hr; split.
     apply Rle_trans with mu_1.
      generalize (Q_to_Rlt _ _ H_mu_2);
      assert (H_diam':(mu_2-mu_1<1/3)%R);
      [ stepl (-(mu_1 - mu_2))%R; [|ring]; generalize (Q_to_Rlt _ _ H_diam); rationalify_R_goal
      | realify_Q_goal; intros H_mu_2'; fourier
      ]...
      generalize (det_nonpos_nonincreasing _ _ _ _ r 1 H_bounded H_det Hr one_is_in_base_interval (proj2 Hr));
      unfold mu_1, as_Moebius_Q, as_Moebius; simpl;
      let t_local:=  (destruct H_bounded as [[H1 H2]|[H1 H2]]; simpl in H1, H2; auto) in realify_Q_goal;
      [ trivial
      | stepl (d+c); try ring; t_local
      ]...
     apply Rle_trans with mu_2.
      generalize (det_nonpos_nonincreasing _ _ _ _ (-1) r H_bounded H_det min_one_is_in_base_interval Hr (proj1 Hr));
      unfold mu_2, as_Moebius_Q, as_Moebius; simpl;
      let t_local:=  (destruct H_bounded as [[H1 H2]|[H1 H2]]; simpl in H1, H2; auto) in realify_Q_goal;
      [ trivial
      | stepl (d-c); try ring; t_local
      ]...
      generalize (Q_to_Rlt _ _ H_mu_1);
      assert (H_diam':(mu_2-mu_1<1/3)%R);
      [ stepl (-(mu_1 - mu_2))%R; [|ring]; generalize (Q_to_Rlt _ _ H_diam); rationalify_R_goal
      | realify_Q_goal; intros H_mu_2'; fourier
      ]...
  (* 0<=det(mu) *)
  assert (H_mu:=det_nonneg_refining_endpoints _ _ _ _ H_refining H_det); fold mu_1 mu_2 in H_mu.
  rewrite (Qabs_eq _ (Qle_Qminus_Zero _ _ H_mu)); intro H_diam.
  destruct (Q_le_lt_dec mu_1 Zero) as [H_mu_1|H_mu_1].
   (* mu(1)<=0 *)
   exists LL.
   apply Incl_M_L_folded; trivial; intros r Hr; split.
    elim (Is_refining_M_property _ _ Hr H_refining); trivial.
    apply Rle_trans with mu_1; [ | realify_Q; auto].
     generalize (det_nonneg_nondecreasing _ _ _ _ r 1 H_bounded H_det Hr one_is_in_base_interval (proj2 Hr));
     unfold mu_1, as_Moebius_Q, as_Moebius; simpl;
     let t_local:=  (destruct H_bounded as [[H1 H2]|[H1 H2]]; simpl in H1, H2; auto) in realify_Q_goal;
     [ trivial
     | stepl (d+c); try ring; t_local
     ].
   (* 0<mu(1) *)
   destruct (Q_le_lt_dec Zero mu_2) as [H_mu_2|H_mu_2].
    (* 0<=mu(-1) *)
    exists RR.
    apply Incl_M_R_folded; trivial; intros r Hr; split.
     apply Rle_trans with mu_2; [ realify_Q; auto| ].
      generalize (det_nonneg_nondecreasing _ _ _ _ (-1) r H_bounded H_det min_one_is_in_base_interval Hr (proj1 Hr));
      unfold mu_2, as_Moebius_Q, as_Moebius; simpl.
      let t_local:=  (destruct H_bounded as [[H1 H2]|[H1 H2]]; simpl in H1, H2; auto) in realify_Q_goal;
      [ trivial
      | stepl (d-c); try ring; t_local
      ].
     elim (Is_refining_M_property _ _ Hr H_refining); trivial.
    (* mu(-1)<Zero *)
    exists MM.
    apply Incl_M_M_folded; trivial; intros r Hr; split.
     apply Rle_trans with mu_2.
      generalize (Q_to_Rlt _ _ H_mu_1);
      assert (H_diam':(mu_1-mu_2<1/3)%R);
      [ generalize (Q_to_Rlt _ _ H_diam); rationalify_R_goal
      | realify_Q_goal; intros H_mu_2'; fourier
      ]...
      generalize (det_nonneg_nondecreasing _ _ _ _ (-1) r H_bounded H_det min_one_is_in_base_interval Hr (proj1 Hr));
      unfold mu_2, as_Moebius_Q, as_Moebius; simpl;
      let t_local:=  (destruct H_bounded as [[H1 H2]|[H1 H2]]; simpl in H1, H2; auto) in realify_Q_goal;
      [ trivial
      | stepl (d-c); try ring; t_local
      ]...
     apply Rle_trans with mu_1.
      generalize (det_nonneg_nondecreasing _ _ _ _ r 1 H_bounded H_det Hr one_is_in_base_interval (proj2 Hr));
      unfold mu_1, as_Moebius_Q, as_Moebius; simpl;
      let t_local:=  (destruct H_bounded as [[H1 H2]|[H1 H2]]; simpl in H1, H2; auto) in realify_Q_goal;
      [ trivial
      | stepl (d+c); try ring; t_local
      ]...
      generalize (Q_to_Rlt _ _ H_mu_2);
      assert (H_diam':(mu_1-mu_2<1/3)%R);
      [ generalize (Q_to_Rlt _ _ H_diam); rationalify_R_goal
      | realify_Q_goal; intros H_mu_2'; fourier
      ]...
Qed.

Lemma product_init_pure_ub:forall alpha n, as_Moebius_Q (product_init_pure alpha n) Qone = ub alpha n.
Proof.
 intros alpha n; revert alpha; induction n; intros [d alpha]; unfold product_init_pure.
  (* O *)
  simpl; auto.
  (* S n *)
  rewrite ub_S_n.
  rewrite Streams_addenda.take_S_n;
  rewrite (Streams_addenda.fold_right_cons product).
  unfold map_reals. rewrite Streams_addenda.map_spelled.
  unfold hd, tl.
  fold  map_reals.
  rewrite <- (IHn alpha).
  replace (List.fold_right product idM (Streams_addenda.take n (map_reals alpha))) with (product_init_pure alpha n); trivial.
  rewrite as_Moebius_Q_product; trivial.
   apply Is_refining_M_denom_nonvanishing_M.
    apply Is_refining_M_product_init_pure.
    realify_Q; apply one_is_in_base_interval.
   rewrite (IHn alpha); qZ_numerals; apply ub_is_in_base_interval_low.
   rewrite (IHn alpha); qZ_numerals; apply ub_is_in_base_interval_up.
   destruct d; [apply Is_refining_M_L|apply Is_refining_M_R|apply Is_refining_M_M].
Qed.

Lemma product_init_pure_lb:forall alpha n, as_Moebius_Q (product_init_pure alpha n) (-Qone) = lb alpha n.
 intros alpha n; revert alpha; induction n; intros [d alpha]; unfold product_init_pure.
  (* O *)
  simpl; auto.
  (* S n *)
  rewrite lb_S_n.
  rewrite Streams_addenda.take_S_n;
  rewrite (Streams_addenda.fold_right_cons product).
  unfold map_reals. rewrite Streams_addenda.map_spelled.
  unfold hd, tl.
  fold  map_reals.
  rewrite <- (IHn alpha).
  replace (List.fold_right product idM (Streams_addenda.take n (map_reals alpha))) with (product_init_pure alpha n); trivial.
  rewrite as_Moebius_Q_product; trivial.
   apply Is_refining_M_denom_nonvanishing_M.
    apply Is_refining_M_product_init_pure.
    realify_Q; apply min_one_is_in_base_interval.
   rewrite (IHn alpha); qZ_numerals; apply lb_is_in_base_interval_low.
   rewrite (IHn alpha); qZ_numerals; apply lb_is_in_base_interval_up.
   destruct d; [apply Is_refining_M_L|apply Is_refining_M_R|apply Is_refining_M_M].
Qed.

Lemma diameter_product:forall mu mu' H_mu H_mu', diameter (product mu mu') (Is_refining_M_product _ _ H_mu H_mu') =
(Qabs (Determinant mu))*  (diameter mu' H_mu') *
 (Qabs(as_Moebius_Q  (eta_discriminant mu) (as_Moebius_Q mu' (-Qone)))*Qabs(as_Moebius_Q  (eta_discriminant mu) (as_Moebius_Q mu' Qone))).
Proof.
 intros ((a,b),(c,d)) ((a',b'),(c',d')) H_mu H_mu'.
 assert (H_mu_bound:=proj1 H_mu); assert (H_mu'_bound:=proj1 H_mu').
 assert (H_prod:=Is_refining_M_product _ _ H_mu H_mu'); generalize (proj1 H_prod).
 revert H_prod;
 unfold diameter, Determinant, eta_discriminant, product, as_Moebius_Q, fst, snd.
 intros H_prod H_prod_bound.
 assert (H_cd:=Bounded_M_c_plus_d_nonzero _ _ _ _ H_mu_bound).
 assert (H_dc:=Bounded_M_d_minus_c_nonzero _ _ _ _ H_mu_bound).
 assert (H_cd':=Bounded_M_c_plus_d_nonzero _ _ _ _ H_mu'_bound).
 assert (H_dc':=Bounded_M_d_minus_c_nonzero _ _ _ _ H_mu'_bound).
 assert (H_pord_denom_one:=Bounded_M_c_plus_d_nonzero _ _ _ _ H_prod_bound).
 assert (H_prod_denom_min_one:=Bounded_M_d_minus_c_nonzero _ _ _ _ H_prod_bound).
 assert (H_cd_:c * - Qone + d<>Zero); [ring_exact_Q H_dc|].
 assert (H_cd'_:c' * - Qone + d'<>Zero); [ring_exact_Q H_dc'|].
 assert (H_prod_denom_min_one_:(c*a'+d*c')* - Qone + (c*b'+d*d') <> Zero); [ring_exact_Q H_prod_denom_min_one|].
 qZ_numerals.
 repeat rewrite <- Qabs_Qmult.
 repeat rewrite Qminus_Qdiv; trivial.
 apply (f_equal Qabs).
 field; repeat split; auto.
  ring_exact_Q H_pord_denom_one.
  ring_exact_Q H_prod_denom_min_one.
Qed.

Lemma diameter_product_init_pure:forall alpha n H_diam, diameter(product_init_pure alpha n) H_diam= ub alpha n-lb alpha n.
Proof.
 intros alpha n H_diam;
 unfold diameter; rewrite product_init_pure_ub; rewrite product_init_pure_lb; rewrite Qabs_eq_pos; trivial;
 apply Qlt_Qminus_Zero; apply lb_lt_ub_pointwise.
Qed.

Lemma diameter_product_init:forall a b c d alpha n H_mualpha,
 Is_refining_M ((a,b),(c,d)) -> diameter (product_init ((a,b),(c,d)) alpha n) H_mualpha =
  (Qabs (a*d - b*c)) * (ub alpha n - lb alpha n)
  * (Qabs (as_Moebius_Q  ((0/1,1/1),(c,d)) (lb alpha n)) * Qabs (as_Moebius_Q  ((0/1,1/1),(c,d)) (ub alpha n))).
Proof.
 intros a b c d alpha n.
 rewrite product_init_product_init_pure.
 intros H_mualpha H_mu.
 assert (H_alpha:=(Is_refining_M_product_init_pure alpha n)).
 rewrite <- (diameter_product_init_pure alpha n H_alpha).
 rewrite <- product_init_pure_lb.
 rewrite <- product_init_pure_ub.
 transitivity (diameter (product (a, b, (c, d)) (product_init_pure alpha n))
                (Is_refining_M_product (a, b, (c, d)) (product_init_pure alpha n) H_mu H_alpha)); [apply diameter_PI|].
 rewrite (diameter_product _ _ H_mu H_alpha).
 repeat apply (f_equal2 Qmult); trivial.
Qed.

Lemma eta_discriminant_twice_majorised: forall a b c d alpha n,  Is_refining_M ((a,b),(c,d)) ->
 let X := Qmax (Qabs(Qone/(c+d))) (Qabs (Qone/(d-c))) in
  (Qabs (as_Moebius_Q  ((0/1,1/1),(c,d)) (lb alpha n)) * Qabs (as_Moebius_Q  ((0/1,1/1),(c,d)) (ub alpha n)))<= X * X.
Proof.
 intros a b c d alpha n [H_bounded _] X.
 apply Qmult_Qle_compat ; [| |apply Qabs_nonneg|apply Qabs_nonneg];
 subst X; apply maximum_eta_discriminant_base_interval with a b; trivial.
  apply lb_is_in_base_interval_low.
  apply lb_is_in_base_interval_up.
  apply ub_is_in_base_interval_low.
  apply ub_is_in_base_interval_up.
Qed.

(** This is the main productivity lemma (similar to Lemma 5.6.10 of
the thesis) for the homographic algorithm. It extracts [n] --- number
of the absorption steps after which emission occurs. *)

Theorem thesis_5_6_10: forall mu alpha, Is_refining_M mu -> {n:nat & {d | Incl_M (product_init mu alpha n) d}}.
Proof.
 intros ((a,b),(c,d)) alpha H_refining.
 set (det:=a*d-b*c).
 set (X := Qmax (Qabs(Qone/(c+d))) (Qabs (Qone/(d-c)))).
 set (q:=3*(2*(Qabs det))*(X*X)).
 destruct (Q_Archimedean_nat_inf q) as [n Hn].
 exists n.
 assert (H_n_one_pos: Zero < n + 1); [natZ_numerals; qnat_one; natq_zero; natq_S n; natq_S (S n); auto|].
 assert (H_refining_prod:=Is_refining_M_product_init _ alpha n H_refining).
 apply thesis_5_6_9 with H_refining_prod; unfold redundancy.
 rewrite (diameter_product_init _ _ _ _ _ _ H_refining_prod H_refining).
 fold det.
 rewrite <- Qmult_assoc.
 apply Qle_lt_trans with ((Qabs det)*((2%nat/(n+1%nat))*(X*X))).
  apply Qle_reg_mult_l_strong; [apply Qabs_nonneg|].
  apply Qmult_Qle_compat.
   apply thesis_5_7_9.
   unfold X; apply eta_discriminant_twice_majorised with a b; assumption.
   apply Qle_Qminus_Zero; apply lb_leq_ub_pointwise.
   apply Qle_mult_nonneg_nonneg; apply Qabs_nonneg.
  stepl (((2*Qabs det)*(X*X))/(n+1)).
   apply Qmult_Qdiv_pos.
    auto.
    stepl (3*(2*Qabs det)*(X*X)); [|ring].
    stepr (n+1); [| qZ_numerals_one; ring].
    fold q.
    apply Qle_lt_trans with n; trivial.
    rewrite <- Z_to_Qplus; apply Z_to_Qlt; natZ_numerals; rewrite <- inj_plus; apply inj_lt; omega.
   revert H_n_one_pos; natZ_numerals; intros H_n_one_pos; field; auto.
Qed.

Close Scope Q_scope.
Close Scope Z_scope.

(** Using the above we prove that [n] can always be chosen to be the smallest such number. *)
Lemma semantic_modulus_h: forall mu alpha, Is_refining_M mu ->
  {n:nat & { d | Incl_M (product_init mu alpha n) d /\
                      (forall m d', (m<n)%nat ->~Incl_M (product_init mu alpha m) d') } }.
Proof.
 intros mu alpha H_r.
 apply LNP_sigS_nat_Digit.
  intros n d; apply Incl_M_dec_D.
  apply thesis_5_6_10; assumption.
Qed.

Lemma semantic_modulus_h_S_product:forall n n' mu alpha (H_r:Is_refining_M mu) H_r',
   let smodu':=semantic_modulus_h (product mu (map_digits (hd alpha))) (tl alpha) H_r' in
    let smodu:=semantic_modulus_h mu alpha H_r in
      (0 < n)%nat -> n' = projT1 smodu' -> n = projT1 smodu -> n =  S n'.
Proof.
 destruct n; intros n' mu alpha H_r H_r' smodu' smodu Hn_pos Hn' Hn; [inversion  Hn_pos |].
 set (d:=(proj1_sig (projT2 smodu)));
 set (d':=(proj1_sig (projT2 smodu')));
 assert (Hd:d=(proj1_sig (projT2 smodu))); trivial;
 assert (Hd':d'=(proj1_sig (projT2 smodu'))); trivial;
 destruct (proj2_sig (projT2 smodu)) as [H1 H3];
 destruct (proj2_sig (projT2 smodu')) as [H1' H3'].
 rewrite_all <- Hd; rewrite_all <- Hd'; rewrite_all <- Hn; rewrite_all <- Hn'.
 apply eq_S.
 destruct (lt_eq_lt_dec n n') as [[Hnn'|Hnn']|Hnn']; trivial.
  generalize (H3' n d Hnn');
  rewrite_all (product_init_folds mu alpha n);
  contradiction...
  generalize (lt_n_S _ _ Hnn'); intros Hnn'_S;
  generalize (H3 (S n') d' Hnn'_S);
  rewrite (product_init_folds mu alpha n');
  contradiction...
Qed.

Lemma Is_refining_M_emits_h_pointwise: forall n mu alpha H_r,
    let smodu:=semantic_modulus_h mu alpha H_r in
       n = projT1 smodu ->  emits_h mu alpha.
Proof.
 induction n;
 intros mu alpha H_r smodu Hn;
 set (n':=projS1 smodu);
 set (d:=(proj1_sig (projT2 smodu)));
 assert (Hn':n'=(projT1 smodu)); trivial;
 assert (Hd:d=(proj1_sig (projT2 smodu))); trivial;
 destruct (proj2_sig (projT2 smodu)) as [H1 H3].
 (* O *)
  simpl in H1.
  case (Incl_M_dec_D mu LL); intros t_l.
   constructor 1; trivial.
   case (Incl_M_dec_D mu RR); intros t_r.
    constructor 2; trivial.
    case (Incl_M_dec_D mu MM); intros t_m.
     constructor 3; trivial.
     rewrite_all <- Hd; rewrite_all <- Hn'; rewrite_all <- Hn; destruct d; contradiction.
 (* S n *)
 rewrite_all <- Hd; rewrite_all <- Hn.
 generalize (H3 O LL (lt_O_Sn _));  generalize (H3 O RR (lt_O_Sn _));  generalize (H3 O MM (lt_O_Sn _)).
 simpl; intros t_m t_r t_l.
 constructor 4; trivial.
 apply (IHn (product mu (hd alpha)) (tl alpha) (Is_refining_M_product_hd _ _ H_r)).
 apply eq_add_S.
 apply (semantic_modulus_h_S_product (S n) (projT1 (semantic_modulus_h (product mu (hd alpha))
                                                           (tl alpha) (Is_refining_M_product_hd mu alpha H_r)))
                                                mu alpha H_r (Is_refining_M_product_hd _ _ H_r)); trivial.
  apply lt_O_Sn.
Qed.

Lemma Is_refining_M_emits_h: forall mu alpha, Is_refining_M mu -> emits_h mu alpha.
Proof.
 intros mu alpha H_r.
 set (smodu:=semantic_modulus_h mu alpha H_r).
 set (n:=projS1 smodu).
 assert (Hn:n=(projT1 smodu)); trivial.
 apply Is_refining_M_emits_h_pointwise with n H_r; trivial.
Qed.

Lemma Is_refining_M_depth_h:forall n mu alpha (H_r:Is_refining_M mu),
   let smodu:=semantic_modulus_h mu alpha H_r in
     n= projS1 smodu ->  depth_h mu alpha (Is_refining_M_emits_h mu alpha H_r) = n.
Proof.
 induction n; intros mu alpha H_r smodu Hn;
 set (d:=(proj1_sig (projT2 smodu)));
 assert (Hd':d=(proj1_sig (projT2 smodu))); trivial;
 destruct (proj2_sig (projT2 smodu)) as [H1 H3].
  (* 0 *)
  revert H1; rewrite <- Hd'; rewrite <- Hn; intros H1.
  case (Incl_M_dec_D mu LL); intros t_l.
   apply depth_h_L; trivial.
   case (Incl_M_dec_D mu RR); intros t_r.
    apply depth_h_R; trivial.
    case (Incl_M_dec_D mu MM); intros t_m.
     apply depth_h_M; trivial.
     destruct d; contradiction.
  (* S n *)
  generalize H1 (H3 O); clear H1 H3; rewrite <- Hd'; rewrite <- Hn; intros H1 H3.
  case (Incl_M_dec_D mu LL); intros t_l.
   rewrite depth_h_L; trivial; generalize (H3 LL (lt_O_Sn _)); simpl; intros H4; contradiction.
   case (Incl_M_dec_D mu RR); intros t_r.
    rewrite depth_h_R; trivial; generalize (H3 RR (lt_O_Sn _)); simpl; intros H4; contradiction.
    case (Incl_M_dec_D mu MM); intros t_m.
     rewrite depth_h_M; trivial; generalize (H3 MM (lt_O_Sn _)); simpl; intros H4; contradiction.

     set (smodu':=semantic_modulus_h (product mu (map_digits (hd alpha))) (tl alpha) (Is_refining_M_product_hd _ _ H_r)).
     generalize (semantic_modulus_h_S_product  (S n) (projT1 smodu') _ alpha H_r (Is_refining_M_product_hd _ _ H_r)).
     intros H_Sn.
     rewrite (depth_h_absorbs _ _ (Is_refining_M_emits_h mu alpha H_r) t_l t_r t_m (Is_refining_M_emits_h _ (tl alpha)
     (Is_refining_M_product_hd mu alpha H_r))).
     apply eq_S.
     apply IHn.
     rewrite (eq_add_S _ _ (H_Sn (lt_O_Sn _) (refl_equal _) Hn)); trivial.
Qed.

Lemma Is_refining_M_modulus_h:forall mu alpha (H_r:Is_refining_M mu),
  let modu:=modulus_h mu alpha (Is_refining_M_emits_h mu alpha H_r) in
   let mu' := fstT (sndT modu) in
      Is_refining_M mu'.
Proof.
 intros mu alpha H_r.
 set (smodu:=semantic_modulus_h mu alpha H_r).
 set (n:=projS1 smodu).
 set (d':=(proj1_sig (projT2 smodu))).
 assert (Hn:n=(projT1 smodu)); trivial.
 assert (Hd':d'=(proj1_sig (projT2 smodu))); trivial.
 assert (H_depth: depth_h mu alpha (Is_refining_M_emits_h mu alpha H_r) = n);[apply (Is_refining_M_depth_h n _ alpha H_r Hn)|].
 destruct (depth_h_modulus_h mu alpha (Is_refining_M_emits_h mu alpha H_r) n (Is_refining_M_depth_h n _ _ _ Hn)) as [d Hd].
 destruct (proj2_sig (projS2 smodu)) as [H_Incl _].
 rewrite Hd; simpl.
 apply Incl_M_absorbs_Is_refining_M.
 destruct (depth_h_Incl_M_inf_strong_general _ _ (Is_refining_M_emits_h mu alpha H_r) n H_depth) as [d'' [Hd''1 Hd''2]].
 revert Hd''2.
 rewrite Hd; simpl.
 intros Hd''2.
 subst d''.
 assumption.
Qed.

Lemma Is_refining_M_step_productive_h: forall n mu alpha, Is_refining_M mu -> step_productive_h n mu alpha.
Proof.
 induction n;
 intros mu alpha H_refining.
 (* 0 *) constructor; apply Is_refining_M_emits_h; trivial.
 (* S *) apply (step_productive_h_S n _ _ (Is_refining_M_emits_h _ alpha H_refining)).
 apply IHn.
 apply (Is_refining_M_modulus_h _ alpha H_refining).
Qed.

Theorem Is_refining_M_productive_h: forall mu alpha, Is_refining_M mu -> productive_h mu alpha.
Proof.
 intros mu alpha H_refining.
 constructor; intros n; apply Is_refining_M_step_productive_h; trivial.
Qed.


Require Import Arith id_and_loc mlattice language LibTactics decision List tactics types Coq.Program.Basics bijection.

Module Type Memory (L: Lattice).
  Module LatProp := LatticeProperties L.
  Module T := Types L.
  Import T L Lang LatProp.

  Parameter Memory: Set.
  Parameter Heap: Set.

  (* A lookupfunc is the result of looking up a location in the heap *)
  Parameter lookupfunc: Set.
  Parameter lookup: lookupfunc -> nat -> option value.

  (* Two lookupfuncs are equal if they contain the same values *)
  Axiom lookupfunc_extensionality:
    forall μ ν,
      (forall n, lookup μ n = lookup ν n) -> μ = ν.

  (* A lookupfunc can be updated at an index to create a new lookupfunc *)
  Parameter update_lookup: lookupfunc -> nat -> value -> lookupfunc.

  (* Looking up a value at an index after updating the same index
     gives back the new value *)
  Axiom lookup_update_eq:
    forall μ n v,
      lookup (update_lookup μ n v) n = Some v.
  Hint Resolve lookup_update_eq.

  (* Updating a lookupfunc only affects the updated index *)
  Axiom lookup_update_neq:
    forall μ n1 n2 v,
      n1 <> n2 ->
      lookup (update_lookup μ n1 v) n2 = lookup μ n2.
  Hint Resolve lookup_update_neq.

  (* There exists an empty memory and an empty heap *)
  Parameter emptyMemory: Memory.
  Parameter emptyHeap: Heap.

  (* A memory can be extended *)
  Parameter extend_memory: id -> value -> Memory -> Memory.

  Notation "m '[' x '→' v ']'" := (extend_memory x v m) (at level 10, no associativity).

  (* Given a location we can get the amount of slots allocated for that location *)
  Parameter length_of: loc -> Heap -> option nat.

  (* A heap partition has a size *)
  Parameter size: level_proj1 -> Heap -> nat.

  (* Each heap partition has a maximum size *)
  Parameter maxsize : level_proj1 -> Heap -> nat.

  (* An empty heap has size 0 *)
  Axiom empty_heap_has_size_0:
    forall l,
      size l emptyHeap = 0.

  (* It's impossible to change the maximum size of a heap *)
  Axiom constant_maxsize:
    forall h1 h2 l,
      maxsize l h1 = maxsize l h2.

  (* A heap can be updated *)
  Parameter heap_lookup: loc -> Heap -> option (level_proj1 * lookupfunc).

  (* We can look up a value in a memory given an identifier *)
  Parameter memory_lookup: Memory -> id -> option value.

  (* We can extend a heap to obtain a new heap *)
  Parameter extend_heap:
    value ->
    forall loc ℓ n h,
      heap_lookup loc h = None ->
      size ℓ h + n <= maxsize ℓ h ->
      Heap.

  Notation "h '[' loc → '(' n '×' v ',' l ')' ',' H1 ',' H2 ']'" := (extend_heap v loc l n h H1 H2) (at level 10, no associativity, only parsing).

  (* Heap partition size increases by N if we extend a heap
     with a new location of size n in that partition *)
  Axiom size_extend_heap_eq_level:
    forall loc n v l h H1 H2,
      size l (h [loc → (n × v, l), H1, H2]) = size l h + n.

  (* Extending a heap partition only affects the heap partition we extend *)
  Axiom size_extend_heap_neq_level:
    forall loc n v l1 l2 h H1 H2,
      l1 <> l2 ->
      size l1 (h [loc → (n × v, l2), H1, H2]) = size l1 h.

  (* We can update a value in the heap (ie. update the lookupfunc stored at
     a location) *)
  Parameter update_heap: loc -> nat -> value -> Heap -> Heap.

  (* Looking up a location in an updated heap gives an updated lookupfunc *)
  Axiom heap_lookup_update_eq:
    forall loc n v h l μ,
      heap_lookup loc h = Some (l, μ) ->
      heap_lookup loc (update_heap loc n v h) = Some (l, update_lookup μ n v).
  Hint Resolve heap_lookup_update_eq.

  (* Updating a heap location only affects that one location *)
  Axiom heap_lookup_update_neq:
    forall loc1 loc2 n v h,
      loc1 <> loc2 ->
      heap_lookup loc1 (update_heap loc2 n v h) = heap_lookup loc1 h.
  Hint Resolve heap_lookup_update_neq.

  (* Looking up a value we just inserted gives back a lookupfunc which always returns the value inserted. *)
  Axiom heap_lookup_extend_eq:
    forall loc l n v h H1 H2,
      { μ | heap_lookup loc (h [loc → (n × v, l), H1, H2]) = Some (l, μ) /\
            forall n, lookup μ n = Some v }.
  Hint Resolve heap_lookup_extend_eq.

  (* Inserting a value into the heap only affects that one value *)
  Axiom heap_lookup_extend_neq:
    forall loc1 loc2 l n v h H1 H2,
      loc1 <> loc2 ->
      heap_lookup loc1 (h [loc2 → (n × v, l), H1, H2]) = heap_lookup loc1 h.
  Hint Resolve heap_lookup_extend_neq.

  (* We can remove locations from the heap *)
  Parameter reduce_heap: loc -> Heap -> Heap.

  (* Removing a location from a heap actually removes it *)
  Axiom heap_lookup_reduce_eq:
    forall loc h,
      heap_lookup loc (reduce_heap loc h) = None.
  Hint Resolve heap_lookup_reduce_eq.

  (* Removing a location from the heap only removes that one location *)
  Axiom heap_lookup_reduce_neq:
    forall loc1 loc2 h,
      loc1 <> loc2 ->
      heap_lookup loc1 (reduce_heap loc2 h) = heap_lookup loc1 h.
  Hint Resolve heap_lookup_reduce_neq.

  (* Removing a location of size n reduces the size of the heap partition by n *)
  Axiom size_reduce_heap_eq_level:
    forall loc h n l μ,
      heap_lookup loc h = Some (l, μ) ->
      length_of loc h = Some n ->
      size l h = size l (reduce_heap loc h) + n.
  Hint Resolve size_reduce_heap_eq_level.

  (* Removing a location only affects the heap partition we remove from *)
  Axiom size_reduce_heap_neq_level:
    forall loc l1 l2 μ h,
      l1 <> l2 ->
      heap_lookup loc h = Some (l1, μ) ->
      size l2 (reduce_heap loc h) = size l2 h.
  Hint Resolve size_reduce_heap_neq_level.

  (* Looking up a value just inserted gives back that value *)
  Axiom extend_memory_lookup_eq:
    forall x v m,
      memory_lookup (extend_memory x v m) x = Some v.
  Hint Resolve extend_memory_lookup_eq.

  (* Extending the memory only affects the entry we add to the memory *)
  Axiom extend_memory_lookup_neq:
    forall x y v m,
      x <> y ->
      memory_lookup (extend_memory x v m) y = memory_lookup m y.
  Hint Resolve extend_memory_lookup_neq.

  (* If we allocate an array of size n then the length of the location is n *)
  Axiom length_of_extend_eq:
    forall loc l n v h H1 H2,
      length_of loc (h [loc → (n × v, l), H1, H2]) = Some n.
  Hint Resolve length_of_extend_eq.

  (* Extending the heap does not affect any other length than the one we extend the heap with *)
  Axiom length_of_extend_neq:
    forall loc1 loc2 l n v h H1 H2,
      loc1 <> loc2 ->
      length_of loc1 (h [loc2 → (n × v, l), H1, H2]) = length_of loc1 h.
  Hint Resolve length_of_extend_neq.

  (* Updaing a value in the heap leaves the length unchanged *)
  Axiom length_of_update:
    forall loc1 loc2 n v h,
      length_of loc1 (update_heap loc2 n v h) = length_of loc1 h.
  Hint Resolve length_of_update.

  (* Updating a value on the heap does not extend the heap *)
  Axiom heap_lookup_update_none:
    forall loc1 loc2 v h n,
      heap_lookup loc1 h = None ->
      heap_lookup loc1 (update_heap loc2 n v h) = None.

  (* Heaps are abstract objects and we need a way to state that they are equal.
     We say that two heaps are equal if they contain the same locations, and the locations map to the same values.
 *)
  Axiom heap_extensionality:
    forall h1 h2,
      (forall loc, heap_lookup loc h1 = heap_lookup loc h2) <-> h1 = h2.

  (* This one is crucial:
     If we have space enough to allocate an array of size n in the heap
     (as specified by H2) then we can find a location which is not in the heap,
     and extend the heap with this location.
 *)
  Axiom fresh_location:
    forall h l n v H2,
    exists loc H1 μ,
      heap_lookup loc (h [loc → (n × v, l), H1, H2]) = Some (l, μ) /\
                       forall n', lookup μ n' = Some v.

  (* Garbage collection *)
  Parameter gc: Memory -> Heap -> nat -> Heap -> Prop.

  (* Definition of what it means for heaps to be disjoint *)
  Definition disjoint (h1 h2 : Heap) :=
    forall loc ℓ μ,
      (heap_lookup loc h1 = Some (ℓ, μ) -> heap_lookup loc h2 = None)
      /\
      (heap_lookup loc h2 = Some (ℓ, μ) -> heap_lookup loc h1 = None).
  Hint Unfold disjoint.

  (* We can union two heaps to produce a new heap provided that they are disjoint *)
  Parameter disjoint_union:
    forall (h1 h2 : Heap)
      (H: disjoint h1 h2),
    Heap.

  Notation "'[' h1 ⊎ h2 ',' H ']'" := (disjoint_union h1 h2 H) (at level 10, no associativity).
  Notation "h1 ⇝ '(' m ',' δ ')' h2" := (gc m h1 δ h2) (at level 10, no associativity).

  (* Technical details: Throughout many of the proofs we need to show that two heaps are equal. Sometimes the only difference between the two heaps is that they are disjoint for two different reasons. By having this weak form of proof irrelevance for we solve this problem and state that we don't care about WHY the heaps are disjoint, but just the fact that they are disjoint. *)
  Axiom disjoint_union_proof_irrelevance:
    forall h1 h2 H1 H2,
      [h1 ⊎ h2, H1] = [h1 ⊎ h2, H2].

  (* Disjoint union is forms a superset. *)
  Axiom disjoint_union_heap_lookup:
    forall h1 h2 loc ℓ μ H,
      heap_lookup loc h1 = Some (ℓ, μ) ->
      heap_lookup loc ([h1 ⊎ h2, H]) = Some (ℓ, μ).
  Hint Resolve disjoint_union_heap_lookup.

  (* Locations in h1 ⊎ h2 are locations from h1 and h2 *)
  Axiom disjoint_union_heap_lookup2:
    forall h1 h2 loc ℓ μ H,
      heap_lookup loc ([h1 ⊎ h2, H]) = Some (ℓ, μ) ->
      heap_lookup loc h1 = Some (ℓ, μ) \/
      heap_lookup loc h2 = Some (ℓ, μ).
  Hint Resolve disjoint_union_heap_lookup2.

  Ltac destruct_disjoint_heap_lookup :=
    match goal with
      [H: heap_lookup _ ([_ ⊎ _, _]) = Some _ |- _] =>
      destruct (disjoint_union_heap_lookup2 _ _ _ _ _ _ H)
    end.

  Lemma disjoint_sym:
    forall h1 h2,
      disjoint h1 h2 -> disjoint h2 h1.
  Proof.
    intros.
    unfold disjoint in *.
    intros.
    eapply and_comm.
    eauto.
  Qed.
  Hint Resolve disjoint_sym.

  (* Disjoint union is a symmetryc operation. This makes sense since we have a proof
     that they are disjoint. *)
  Axiom disjoint_union_sym:
    forall h1 h2 H,
      [h1 ⊎ h2, H] = [h2 ⊎ h1, disjoint_sym _ _ H].

  (* The characteristic property of an empty heap is that it contains no locations. *)
  Axiom empty_heap_is_empty:
    forall loc,
      heap_lookup loc emptyHeap = None.
  Hint Resolve empty_heap_is_empty.

  (* The size of two disjoint heap partitions is the sum of their sizes *)
  Axiom size_heap_distr:
    forall l h1 h2 H,
      size l ([h1 ⊎ h2, H]) = size l h1 + size l h2.

  (* Updating the heap preserves the size of the heap *)
  Axiom size_update_heap:
    forall l loc n v h,
      size l (update_heap loc n v h) = size l h.

  (* Induction principles for heaps. If a property P is true for the empty heap,
     and if it holds for an extension of the heap assuming it holds from the initial heap, then it holds for every heap.
 *)
  Axiom heap_ind:
    forall P : Heap -> Prop,
      P emptyHeap ->
      (forall loc n v h l H1 H2,
          P h ->
          P (h [loc → (n × v, l), H1, H2])) ->
      forall h, P h.

  (* The same as heap_ind, but for Set. This is used to lift a function operating on locations, to a function opearting on heaps. *)
  Axiom heap_rec:
    forall P : Heap -> Set,
      P emptyHeap ->
      (forall loc n v h l H1 H2,
          P h ->
          P (h [loc → (n × v, l), H1, H2])) ->
      forall h, P h.

  (* Base case and induction case for the recursion principle. Think of these as the two cases as the cases of a fold. *)
  Axiom heap_rec_bc:
    forall P bc ic,
      heap_rec P bc ic emptyHeap = bc.

  Axiom heap_rec_ic:
    forall P bc ic loc l n v h H1 H2,
      heap_rec P bc ic (h [loc → (n × v, l), H1, H2]) =
      ic loc n v h l H1 H2
         (heap_rec P bc ic h).

  (* A location has a length iff it has been allocated in the heap *)
  Axiom length_of_lookup_correspondance:
    forall h loc,
      (exists l μ, heap_lookup loc h = Some (l, μ)) <-> (exists n, length_of loc h = Some n).

  (* Union'ing a disjoint heap onto another heap preserves the allocation sizes of all locations *)
  Axiom disjoint_union_length_of:
    forall h1 h2 loc n H,
      length_of loc h1 = Some n ->
      length_of loc ([h1 ⊎ h2, H]) = Some n.
  Hint Resolve disjoint_union_length_of.

  (* If:
     - We have a bijection in the partial between two heaps
     - The partial bijection's domain includes at least the domain of heap h1
     - The partial bijection's codomain includes at lrast the domain of heap h2
     Then:
      The size of the two heaps is the same.
 *)
  Axiom implies_same_size:
    forall h1 h2 φ,
      (forall loc1 loc2,
          left φ loc1 = Some loc2 ->
          length_of loc1 h1 = length_of loc2 h2) ->
      (forall loc length,
          length_of loc h1 = Some length ->
          exists loc', left φ loc = Some loc') ->
      (forall loc length,
          length_of loc h2 = Some length ->
          exists loc', left φ loc' = Some loc) ->
      forall l, size l h1 = size l h2.

  (* This is the key axiom also specified in the paper. The premise is the same as above.
     If:
     - We have a bijection in the partial between two heaps h1 h2
     - We have a bijection in the partial between two heaps h1' h2'
     - The partial bijection's domain includes at least the domain of heap h1
     - The partial bijection's codomain includes at lrast the domain of heap h2
     - A gc happens in h1 producing h1' taking time δ
     Then:
     We can construct a gc in h2 producing h2' taking time δ.
  *)
  Axiom gc_axiom:
    forall h1 h1' h2 h2' m1 m2 φ δ,
      (forall loc1 loc2 ℓ,
          left φ loc1 = Some loc2 ->
          (exists μ, heap_lookup loc1 h1 = Some (ℓ, μ)) <->
          (exists ν, heap_lookup loc2 h2 = Some (ℓ, ν))) ->
      (forall loc1 loc2 ℓ,
          left φ loc1 = Some loc2 ->
          (exists μ, heap_lookup loc1 h1' = Some (ℓ, μ)) <->
          (exists ν, heap_lookup loc2 h2' = Some (ℓ, ν))) ->
      (forall loc ℓ μ,
          heap_lookup loc h1 = Some (ℓ, μ) ->
          exists loc', left φ loc = Some loc') ->
      (forall loc ℓ μ,
          heap_lookup loc h2 = Some (ℓ, μ) ->
          exists loc', left φ loc' = Some loc) ->
      h1 ⇝ (m1, δ) h1' ->
      h2 ⇝ (m2, δ) h2'.

End Memory.

Module MemoryProperties (L: Lattice) (M: Memory L).
  Import M T L Lang LatProp.

  Lemma disjoint_empty_heap:
    forall h, disjoint h emptyHeap.
  Proof.
    intros.
    unfolds.
    intros.
    splits.
    - intros.
      eauto.
    - intros.
      assert (heap_lookup loc emptyHeap = None) by eauto 2.
      congruence.
  Qed.
  Hint Resolve disjoint_empty_heap.

  Lemma disjoint_union_empty_heap:
    forall h H,
      h = [h ⊎ emptyHeap, H].
  Proof.
    intros.
    eapply heap_extensionality.
    intros.
    destruct (heap_lookup loc ([h ⊎ emptyHeap, H])) eqn:H_loc.
    - destruct p.
      destruct_disjoint_heap_lookup.
      + eauto 2.
      + assert (heap_lookup loc emptyHeap = None) by eauto 2.
        congruence.
    - destruct (heap_lookup loc h) eqn:H_loc'; try reflexivity.
      destruct p.
      assert (heap_lookup loc ([h ⊎ emptyHeap, H]) = Some (l, l0)).
      {
        eapply disjoint_union_heap_lookup; eauto 2.
      }
      congruence.
  Qed.
  Hint Resolve disjoint_union_empty_heap.

  Lemma disjoint_union_length_of2:
    forall h1 h2 loc n H,
      length_of loc ([h1 ⊎ h2, H]) = Some n ->
      length_of loc h1 = Some n \/ length_of loc h2 = Some n.
  Proof.
    intros.
    assert (exists ℓ μ, heap_lookup loc ([h1 ⊎ h2, H]) = Some (ℓ, μ)).
    {
      eapply length_of_lookup_correspondance; eauto 2.
    }
    super_destruct; subst.
    destruct_disjoint_heap_lookup.
    - assert (exists n', length_of loc h1 = Some n').
      {
        eapply length_of_lookup_correspondance; eauto 3.
      }
      super_destruct; subst.
      cut (n' = n).
      {
        intros.
        subst.
        eauto.
      }
      {
        cut (length_of loc ([h1 ⊎ h2, H]) = Some n').
        {
          congruence.
        }
        {
          eapply disjoint_union_length_of; eauto.
        }
      }
    - assert (exists n', length_of loc h2 = Some n').
      {
        eapply length_of_lookup_correspondance; eauto 3.
      }
      super_destruct; subst.
      cut (n' = n).
      {
        intros.
        subst.
        eauto.
      }
      {
        cut (length_of loc ([h1 ⊎ h2, H]) = Some n').
        {
          congruence.
        }
        {
          rewrite -> disjoint_union_sym.
          eapply disjoint_union_length_of; eauto.
        }
      }
  Qed.
  Hint Resolve disjoint_union_length_of2.

  Lemma heap_lookup_extend_none:
    forall loc1 loc2 l n v h H1 H2,
      heap_lookup loc1 (h [loc2 → (n × v, l), H1, H2]) = None ->
      heap_lookup loc1 h = None.
  Proof.
    intros.
    destruct (decide (loc1 = loc2)); subst.
    - remember_simple (heap_lookup_extend_eq loc2 l n v h H1 H2).
      super_destruct; congruence.
    - rewrite -> heap_lookup_extend_neq in * by solve[eauto 2].
      eauto.
  Qed.

  Lemma weak_heap_lookup_extend_eq:
    forall loc l n v h H1 H2,
      exists μ, heap_lookup loc (h [loc → (n × v, l), H1, H2]) = Some (l, μ) /\
           forall n, lookup μ n = Some v.
  Proof.
    intros.
    destruct (heap_lookup_extend_eq loc l n v h H1 H2); eauto.
  Qed.
  Hint Resolve weak_heap_lookup_extend_eq.

  Lemma heap_lookup_update_eq2:
    forall loc l n v h μ,
      heap_lookup loc (update_heap loc n v h) = Some (l, μ) ->
      exists ν,
        heap_lookup loc h = Some (l, ν) /\
        μ = update_lookup ν n v.
  Proof.
    intros.
    destruct (heap_lookup loc h) eqn:H_loc.
    - destruct p.
      rewrite -> (heap_lookup_update_eq loc n v h l0 l1 H_loc) in *.
      rewrite_inj.
      exists l1.
      splits*.
    - rewrite -> heap_lookup_update_none in * by eauto.
      discriminate.
  Qed.
  Hint Resolve heap_lookup_update_eq2.

  Lemma heap_lookup_update_none2:
    forall loc1 loc2 n v h,
      heap_lookup loc1 (update_heap loc2 n v h) = None ->
      heap_lookup loc1 h = None.
  Proof.
    intros.
    destruct (heap_lookup loc1 h) eqn:H_loc1.
    - destruct p.
      destruct (decide (loc1 = loc2)); subst.
      + erewrite -> heap_lookup_update_eq in * by solve[eauto].
        discriminate.
      + rewrite -> heap_lookup_update_neq in * by solve[eauto].
        rewrite_inj.
        discriminate.
    - reflexivity.
  Qed.

  Inductive reach : Memory -> Heap -> loc -> Prop :=
  | reach_mem:
      forall m h x loc,
        memory_lookup m x = Some (ValLoc loc) -> reach m h loc
  | reach_heap:
      forall m h loc loc' ℓ μ n,
        reach m h loc ->
        heap_lookup loc h = Some (ℓ, μ) ->
        lookup μ n = Some (ValLoc loc') ->
        reach m h loc'.
  Hint Constructors reach.

  Axiom reach_dec:
    forall m h loc,
      { reach m h loc } + { ~ reach m h loc }.

  Inductive low_reach: level_proj1 -> tenv -> stenv -> Memory -> Heap -> loc -> Prop :=
  | LowReachMem:
      forall Γ Σ ℓ_adv ℓ_p x τ m h loc l,
        Γ x = Some (SecType (Array τ ℓ_p) (l, ∘)) ->
        l ⊑ ℓ_adv ->
        memory_lookup m x = Some (ValLoc loc) ->
        low_reach ℓ_adv Γ Σ m h loc
  | LowReachHeap:
      forall Γ Σ ℓ_adv l ℓ ℓ_p m h τ loc1 loc2 n μ,
        low_reach ℓ_adv Γ Σ m h loc1 ->
        Σ loc1 = Some (SecType (Array τ ℓ_p) (l, ∘)) ->
        heap_lookup loc1 h = Some (ℓ, μ) ->
        l ⊑ ℓ_adv ->
        lookup μ n = Some (ValLoc loc2) ->
        low_reach ℓ_adv Γ Σ m h loc2.
  Hint Constructors low_reach.

  Axiom low_reach_dec:
    forall ℓ_adv Γ Σ m h loc,
      { low_reach ℓ_adv Γ Σ m h loc } + { ~ low_reach ℓ_adv Γ Σ m h loc }.

  Lemma disjoint_union_heap_lookup3:
    forall h1 h2 loc ℓ μ H,
      heap_lookup loc ([h1 ⊎ h2, H]) = Some (ℓ, μ) ->
      heap_lookup loc h1 = Some (ℓ, μ) ->
      heap_lookup loc h2 = None.
  Proof.
    intros.
    apply disjoint_union_heap_lookup2 in H0.
    destruct H0; eapply H; eauto 2.
  Qed.
  Hint Resolve disjoint_union_heap_lookup3.

  Lemma disjoint_union_heap_lookup4:
    forall h1 h2 loc ℓ μ H,
      heap_lookup loc ([h1 ⊎ h2, H]) = Some (ℓ, μ) ->
      heap_lookup loc h1 = None ->
      heap_lookup loc h2 = Some (ℓ, μ).
  Proof.
    intros.
    apply disjoint_union_heap_lookup2 in H0.
    destruct H0; eauto 2 || congruence.
  Qed.
  Hint Resolve disjoint_union_heap_lookup4.

  Lemma disjoint_union_id_left:
    forall h1 h2 H,
      h1 = [h1 ⊎ h2, H] ->
      h2 = emptyHeap.
  Proof.
    intros.
    eapply heap_extensionality.
    intros.
    rewrite -> empty_heap_is_empty.
    assert (forall loc : id_and_loc.loc, heap_lookup loc h1 = heap_lookup loc ([h1 ⊎ h2, H])).
    {
      eapply heap_extensionality; eauto.
    }
    destruct (heap_lookup loc h2) eqn:H_loc; try reflexivity.
    destruct p.
    assert (disjoint h2 h1) by eauto.
    assert (heap_lookup loc ([h2 ⊎ h1, H2]) = Some (l, l0)) as H3 by eauto.
    assert (heap_lookup loc h1 = None) by eauto 2.
    rewrite -> disjoint_union_sym in H3.
    rewrite -> H0 in H4.
    rewrite -> (disjoint_union_proof_irrelevance h1 h2 (disjoint_sym h2 h1 H2) H) in *.
    rewrite_inj.
    discriminate.
  Qed.
  Hint Resolve disjoint_union_id_left.

  Definition levels_satisfy (h: Heap) (p: level_proj1 -> Prop) :=
    forall loc ℓ μ,
      heap_lookup loc h = Some (ℓ, μ) -> p ℓ.

  Lemma disjoint_level_satsify:
    forall h1 h2 h3 h4 p H1 H2,
      [h1 ⊎ h2, H1] = [h3 ⊎ h4, H2] ->
      levels_satisfy h1 p ->
      levels_satisfy h2 (compose not p) ->
      levels_satisfy h3 p ->
      levels_satisfy h4 (compose not p) ->
      h1 = h3 /\ h2 = h4.
  Proof.
    intros.
    splits.
    - eapply heap_extensionality.
      intros.
      destruct (heap_lookup loc h1) eqn:H_loc1; destruct (heap_lookup loc h3) eqn:H_loc3.
      + destruct p0, p1.
        assert (heap_lookup loc ([h1 ⊎ h2, H1]) = Some (l, l0)) by eauto.
        assert (heap_lookup loc ([h3 ⊎ h4, H2]) = Some (l1, l2)) by eauto.
        rewrite -> H in *.
        rewrite_inj.
        reflexivity.
      + destruct p0.
        assert (heap_lookup loc ([h1 ⊎ h2, H1]) = Some (l, l0)) by eauto.
        rewrite -> H in *.
        assert (heap_lookup loc h3 = Some (l, l0) \/ heap_lookup loc h4 = Some (l, l0))
          as H7 by eauto.
        destruct H7.
        * rewrite_inj.
          discriminate.
        * assert (p l) by eauto.
          assert (compose not p l) by eauto.
          contradiction.
      + destruct p0.
        assert (heap_lookup loc ([h3 ⊎ h4, H2]) = Some (l, l0)) by eauto.
        rewrite <- H in *.
        assert (heap_lookup loc h1 = Some (l, l0) \/ heap_lookup loc h2 = Some (l, l0))
          as H7 by eauto.
        destruct H7.
        * rewrite_inj.
          discriminate.
        * assert (p l) by eauto.
          assert (compose not p l) by eauto.
          contradiction.
      + reflexivity.
    - eapply heap_extensionality.
      intros.
      assert ([h2 ⊎ h1, disjoint_sym _ _ H1] = [h4 ⊎ h3, disjoint_sym _ _ H2]) as H'.
      {
        do 2 rewrite <- disjoint_union_sym.
        eauto.
      }
      destruct (heap_lookup loc h2) eqn:H_loc1; destruct (heap_lookup loc h4) eqn:H_loc3.
      + destruct p0, p1.
        assert (heap_lookup loc ([h2 ⊎ h1, disjoint_sym h1 h2 H1]) = Some (l, l0)) by eauto.
        assert (heap_lookup loc ([h4 ⊎ h3, disjoint_sym h3 h4 H2]) = Some (l1, l2)) by eauto.
        rewrite -> H' in *.
        rewrite_inj.
        reflexivity.
      + destruct p0.
        assert (heap_lookup loc ([h2 ⊎ h1, disjoint_sym h1 h2 H1]) = Some (l, l0)) by eauto.
        rewrite -> H' in *.
        assert (heap_lookup loc h4 = Some (l, l0) \/ heap_lookup loc h3 = Some (l, l0))
          as H7 by eauto.
        destruct H7.
        * rewrite_inj.
          discriminate.
        * assert (p l) by eauto.
          assert (compose not p l) by eauto.
          contradiction.
      + destruct p0.
        assert (heap_lookup loc ([h4 ⊎ h3, disjoint_sym h3 h4 H2]) = Some (l, l0)) by eauto.
        rewrite <- H' in *.
        assert (heap_lookup loc h2 = Some (l, l0) \/ heap_lookup loc h1 = Some (l, l0))
          as H7 by eauto.
        destruct H7.
        * rewrite_inj.
          discriminate.
        * assert (p l) by eauto.
          assert (compose not p l) by eauto.
          contradiction.
      + reflexivity.
  Qed.

  Lemma extend_heap_disjoint:
    forall loc h ℓ n v H1 H2,
      heap_lookup loc h = None ->
      disjoint h (emptyHeap [loc → (n × v, ℓ), H1, H2]).
  Proof.
    intros.
    unfolds.
    intros.
    splits.
    - intros.
      destruct (decide (loc0 = loc)); subst.
      + rewrite_inj; discriminate.
      + rewrite -> heap_lookup_extend_neq by solve[eauto].
        eauto.
    - intros.
      destruct (decide (loc0 = loc)); subst.
      + eauto.
      + rewrite -> heap_lookup_extend_neq in * by solve[eauto].
        rewrite -> empty_heap_is_empty in *.
        discriminate.
  Qed.

  Lemma disjoint_union_assoc:
    forall h1 h2 h3 H1 H2 H3 H4,
      [h1 ⊎ [h2 ⊎ h3, H1], H2] = [[h1 ⊎ h2, H3] ⊎ h3, H4].
  Proof.
    intros.
    eapply heap_extensionality.
    intros.
    destruct (heap_lookup loc ([h1 ⊎ [h2 ⊎ h3, H1], H2])) eqn:H_1_23.
    - destruct p.
      destruct (disjoint_union_heap_lookup2 _ _ _ _ _ _ H_1_23).
      + destruct (heap_lookup loc ([[h1 ⊎ h2, H3] ⊎ h3, H4])) eqn:H_12_3.
        * destruct p.
          destruct (disjoint_union_heap_lookup2 _ _ _ _ _ _ H_12_3).
          {
            assert (heap_lookup loc ([h1 ⊎ h2, H3]) = Some (l, l0))
              by eauto 2.
            congruence.
          }
          {
            assert (heap_lookup loc ([h1 ⊎ h2, H3]) = Some (l, l0))
              by eauto 2.
            destruct (H4 loc l l0).
            specialize_gen.
            congruence.
          }
        * assert (heap_lookup loc ([h1 ⊎ h2, H3]) = Some (l, l0))
            by eauto 2.
          assert (heap_lookup loc ([[h1 ⊎ h2, H3] ⊎ h3, H4]) = Some (l, l0)) by eauto 2.
          congruence.
      + destruct (heap_lookup loc ([[h1 ⊎ h2, H3] ⊎ h3, H4])) eqn:H_12_3.
        * destruct p.
          destruct (disjoint_union_heap_lookup2 _ _ _ _ _ _ H_12_3).
          {
            destruct (disjoint_union_heap_lookup2 _ _ _ _ _ _ H0).
            - assert (heap_lookup loc ([h1 ⊎ [h2 ⊎ h3, H1], H2]) = Some (l1, l2)) by eauto 2.
              congruence.
            - assert (heap_lookup loc ([h2 ⊎ h3, H1]) = Some (l1, l2))
                by eauto 2.
              congruence.
          }
          {
            rewrite -> disjoint_union_sym in H.
            assert (heap_lookup loc ([h3 ⊎ h2, disjoint_sym h2 h3 H1]) = Some (l1, l2)) by eauto 2.
            congruence.
          }
        * destruct (disjoint_union_heap_lookup2 _ _ _ _ _ _ H).
          {
            assert (heap_lookup loc ([h1 ⊎ h2, H3]) =
                    Some (l, l0)).
            {
              rewrite -> disjoint_union_sym.
              eauto.
            }
            assert (heap_lookup loc ([[h1 ⊎ h2, H3] ⊎ h3, H4]) = Some (l, l0)) by eauto 2.
            congruence.
          }
          {
            rewrite -> disjoint_union_sym in H_12_3.
            assert (heap_lookup loc ([h3 ⊎ [h1 ⊎ h2, H3], disjoint_sym ([h1 ⊎ h2, H3]) h3 H4]) = Some (l, l0)) by eauto 2.
            congruence.
          }
    - assert (heap_lookup loc h1 = None).
      {
        destruct (heap_lookup loc h1) eqn:H_1; try reflexivity.
        destruct p.
        assert (heap_lookup loc ([h1 ⊎ [h2 ⊎ h3, H1], H2]) = Some (l, l0)) by eauto 2.
        congruence.
      }
      assert (heap_lookup loc h2 = None).
      {
        destruct (heap_lookup loc h2) eqn:H_2; try reflexivity.
        destruct p.
        assert (heap_lookup loc ([h2 ⊎ h3, H1]) = Some (l, l0)) by eauto 2.
        rewrite -> disjoint_union_sym in H_1_23.
        assert (heap_lookup loc ([[h2 ⊎ h3, H1] ⊎ h1, disjoint_sym h1 ([h2 ⊎ h3, H1]) H2]) = Some (l, l0)) by eauto 2.
        congruence.
      }
      assert (heap_lookup loc h3 = None).
      {
        destruct (heap_lookup loc h3) eqn:H_2; try reflexivity.
        destruct p.
        assert (heap_lookup loc ([h2 ⊎ h3, H1]) = Some (l, l0)).
        {
          rewrite -> disjoint_union_sym.
          eauto.
        }
        rewrite -> disjoint_union_sym in H_1_23.
        assert (heap_lookup loc ([[h2 ⊎ h3, H1] ⊎ h1, disjoint_sym h1 ([h2 ⊎ h3, H1]) H2]) = Some (l, l0)) by eauto 2.
        congruence.
      }
      assert (heap_lookup loc ([h1 ⊎ h2, H3]) = None).
      {
        destruct (heap_lookup loc ([h1 ⊎ h2, H3])) eqn:H_12; try reflexivity.
        destruct p.
        destruct (disjoint_union_heap_lookup2 _ _ _ _ _ _ H_12); congruence.
      }
      assert (heap_lookup loc ([[h1 ⊎ h2, H3] ⊎ h3, H4]) = None).
      {
        destruct (heap_lookup loc ([[h1 ⊎ h2, H3] ⊎ h3, H4])) eqn:H_12_3; try reflexivity.
        destruct p.
        destruct (disjoint_union_heap_lookup2 _ _ _ _ _ _ H_12_3); congruence.
      }
      destruct (heap_lookup loc ([[h1 ⊎ h2, H3] ⊎ h3, H4])) eqn:H_12_3.
      + discriminate.
      + reflexivity.
  Qed.

  Lemma disjoint_implies_disjoint_subheap:
    forall h1 h2 h3 H,
      disjoint ([h1 ⊎ h2, H]) h3 ->
      disjoint h1 h3.
  Proof.
    intros.
    unfolds.
    intros.
    splits.
    - intros.
      destruct (H loc ℓ μ).
      specialize_gen.
      assert (heap_lookup loc ([h1 ⊎ h2, H]) = Some (ℓ, μ)) by eauto 2.
      eauto.
      Unshelve.
      eauto.
    - intros.
      destruct (H0 loc ℓ μ).
      specialize_gen.
      destruct (heap_lookup loc h1) eqn:H_loc; try reflexivity.
      destruct p.
      assert (heap_lookup loc ([h1 ⊎ h2, H]) = Some (l, l0)) by eauto 2.
      congruence.
  Qed.
  Hint Resolve disjoint_implies_disjoint_subheap.

  Lemma disjoint_self_is_empty:
    forall h,
      disjoint h h ->
      h = emptyHeap.
  Proof.
    intros.
    eapply heap_extensionality.
    intros.
    rewrite -> empty_heap_is_empty.
    destruct (heap_lookup loc h) eqn:H_loc; try reflexivity.
    destruct p.
    unfold disjoint in *.
    destruct (H loc l l0).
    specialize_gen.
    congruence.
  Qed.
  Hint Resolve disjoint_self_is_empty.

End MemoryProperties.


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 P Q A B C Dprime Pprime Cprime Dprimeprime Pprimeprime Z : Universe, ((wd_ P Q /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Cprime Pprimeprime /\ (wd_ B Pprime /\ (wd_ B Cprime /\ (wd_ Dprimeprime Cprime /\ (wd_ Dprime B /\ (wd_ Z B /\ (wd_ B Pprimeprime /\ (wd_ B Dprimeprime /\ (wd_ Cprime C /\ (wd_ A Dprime /\ (wd_ Pprime Cprime /\ (col_ A B Z /\ (col_ B C Z /\ (col_ Cprime Dprimeprime Pprimeprime /\ (col_ B Cprime A /\ col_ B Dprime Pprime))))))))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 O E Eprime A B C Oprime Aprime Bprime Cprime Eprimeprime C2 C3 C0 : Universe, ((wd_ O E /\ (wd_ Oprime Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ A E /\ (wd_ Eprimeprime O /\ (wd_ O Oprime /\ (wd_ Bprime Oprime /\ (wd_ Eprimeprime E /\ (wd_ C B /\ (wd_ Eprimeprime A /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ Oprime Eprimeprime /\ (wd_ E Oprime /\ (wd_ Bprime C3 /\ (wd_ Eprime C2 /\ (wd_ Aprime C2 /\ (wd_ Oprime Aprime /\ (wd_ A Aprime /\ (wd_ C Cprime /\ (wd_ B Bprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ Oprime Eprime Aprime /\ (col_ Oprime Eprime Bprime /\ (col_ Oprime Eprime Cprime /\ (col_ O Eprimeprime C /\ (col_ O Eprimeprime Oprime /\ (col_ O Eprimeprime C2 /\ (col_ O Eprimeprime C3 /\ (col_ Eprimeprime C B /\ (col_ E C B /\ col_ O A C0))))))))))))))))))))))))))))))))))) -> col_ O E Eprimeprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj26eqsynthconj1 : forall  (lv0 : natural), (@eq natural (lv0) (plus Zero (plus Zero lv0))).
Admitted.
QuickChick conj26eqsynthconj1.


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(** * Gamma relation (Con -- Sen) *)

Set Implicit Arguments.

Require Import UserProofType.
Require DomCon DomSen.

Module Make (Import PInput : PINPUT).

Local Open Scope type.

Module Sen := DomSen.Make PInput.

Definition State_g (con_s : DomCon.state_t) (s : Sen.state_t) : Prop :=
  let '(mempos, (node, step, calls, intra_node_state)) := con_s in
  Mem_g intra_node_state (s (node, mempos, calls)).

Local Close Scope type.

End Make.


Require Import ZArith Ring.
Require Import coqutil.Tactics.rdelta.

Ltac is_ground_const e :=
  lazymatch e with
  | Z.of_nat => idtac
  | Z.to_nat => idtac
  | Z.of_N => idtac
  | Z.to_N => idtac
  | N.of_nat => idtac
  | N.to_nat => idtac

  | Z.succ => idtac
  | Z.pred => idtac
  | Z.add => idtac
  | Z.sub => idtac
  | Z.mul => idtac
  | Z.div => idtac
  | Z.pred => idtac
  | Z.succ => idtac
  | Z.ones => idtac
  | Z.opp => idtac
  | Z.lnot => idtac
  | Z.log2 => idtac
  | Z.log2_up => idtac
  | Z.add => idtac
  | Z.sub => idtac
  | Z.mul => idtac
  | Z.div => idtac
  | Z.modulo => idtac
  | Z.quot => idtac
  | Z.rem => idtac
  | Z.pow => idtac
  | Z.shiftl => idtac
  | Z.shiftr => idtac
  | Z.land => idtac
  | Z.lor => idtac
  | Z.lxor => idtac
  | Z.ldiff => idtac
  | Z.clearbit => idtac
  | Z.setbit => idtac
  | Z.min => idtac
  | Z.max => idtac
  | Z.gcd => idtac
  | Z.lcm => idtac

  | N.succ => idtac
  | N.pred => idtac
  | N.add => idtac
  | N.sub => idtac
  | N.mul => idtac
  | N.div => idtac
  | N.pred => idtac
  | N.succ => idtac
  | N.ones => idtac
  | N.lnot => idtac
  | N.log2 => idtac
  | N.log2_up => idtac
  | N.add => idtac
  | N.sub => idtac
  | N.mul => idtac
  | N.div => idtac
  | N.modulo => idtac
  | N.pow => idtac
  | N.shiftl => idtac
  | N.shiftr => idtac
  | N.land => idtac
  | N.lor => idtac
  | N.lxor => idtac
  | N.ldiff => idtac
  | N.clearbit => idtac
  | N.setbit => idtac
  | N.min => idtac
  | N.max => idtac
  | N.gcd => idtac
  | N.lcm => idtac

  | Nat.succ => idtac
  | Nat.pred => idtac
  | Nat.add => idtac
  | Nat.sub => idtac
  | Nat.mul => idtac
  | Nat.div => idtac
  | Nat.pred => idtac
  | Nat.succ => idtac
  | Nat.ones => idtac
  | Nat.lnot => idtac
  | Nat.log2 => idtac
  | Nat.log2_up => idtac
  | Nat.add => idtac
  | Nat.sub => idtac
  | Nat.mul => idtac
  | Nat.div => idtac
  | Nat.modulo => idtac
  | Nat.pow => idtac
  | Nat.shiftl => idtac
  | Nat.shiftr => idtac
  | Nat.land => idtac
  | Nat.lor => idtac
  | Nat.lxor => idtac
  | Nat.ldiff => idtac
  | Nat.clearbit => idtac
  | Nat.setbit => idtac
  | Nat.min => idtac
  | Nat.max => idtac
  | Nat.gcd => idtac
  | Nat.lcm => idtac
  end.

Ltac is_number_constructor e :=
  lazymatch e with
  | Zpos => idtac
  | Z0 => idtac
  | Zneg => idtac
  | N0 => idtac
  | Npos => idtac
  | xI => idtac
  | xO => idtac
  | xH => idtac
  | S => idtac
  | O => idtac
  end.

Ltac is_ground_atom var_allowed e :=
  match e with
  | _ => is_const e; is_ground_const e
  | _ => is_constructor e; is_number_constructor e
  | _ => is_var e; var_allowed e
  | _ => fail "not ground"
  end.

Ltac is_ground' var_allowed e :=
  let is_ground e := is_ground' var_allowed e in
  match e with
  | ?f ?x => is_ground f; is_ground x
  | _ => is_ground_atom var_allowed e
  (* note: lambdas could be implemented here I think *)
  end.
Ltac is_ground e := is_ground' ltac:(fun _ => fail) e.

Ltac cbv_if_number e :=
  let t := type of e in
  lazymatch rdelta t with
  | Z => eval cbv in e
  | N => eval cbv in e
  | nat => eval cbv in e
  | positive => eval cbv in e
  | _ => e
  end.

Inductive groundcbv_delayed :=.
Ltac groundcbv' e :=
  match e with
  | ?f ?x =>
      let gsf := groundcbv' f in
      let gsx := groundcbv' x in
      lazymatch gsx with
      | groundcbv_delayed =>
          lazymatch gsf with
          | groundcbv_delayed => constr:(groundcbv_delayed)
          | _ => let vx := cbv_if_number x in
                 constr:(gsf vx)
          end
      | ?gsx =>
          lazymatch gsf with
          | groundcbv_delayed => constr:(f gsx)
          | _ => constr:(gsf gsx)
          end
      end
  | ?P -> ?Q =>
      let gP := groundcbv' P in
      let gQ := groundcbv' Q in
      lazymatch gQ with
      | groundcbv_delayed =>
          lazymatch gP with
          | groundcbv_delayed => constr:(groundcbv_delayed)
          | _ => let vQ := cbv_if_number Q in
                 constr:(gP -> vQ)
          end
      | ?gQ =>
          lazymatch gP with
          | groundcbv_delayed => let vP := cbv_if_number P in constr:(vP -> gQ)
          | _ => constr:(gP -> gQ)
          end
      end
  | if ?c then ?a else ?b =>
      let gc := groundcbv c in
      lazymatch gc with
      | true =>
          let ga := groundcbv' a in
          lazymatch ga with
          | groundcbv_delayed => constr:(groundcbv_delayed)
          | _ => ga
          end
      | false =>
          let gb := groundcbv' b in
          lazymatch gb with
          | groundcbv_delayed => constr:(groundcbv_delayed)
          | _ => gb
          end
      | _ =>
          let ga := groundcbv a in
          let gb := groundcbv b in
          constr:(if gc then ga else gb)
      end
  | _ =>
      let __ := match constr:(Set) with _ => is_ground_atom ltac:(fun _ => fail) e end in
      constr:(groundcbv_delayed)
  | _ => e
  end
with groundcbv e :=
  let e' := groundcbv' e in
  lazymatch e' with
  | groundcbv_delayed => cbv_if_number e
  | ?e => e
  end.

Ltac groundcbv_in_goal :=
  repeat match goal with
  | |- ?t =>  let t' := groundcbv t in progress change t'
  end.

Ltac groundcbv_in_all :=
  repeat match goal with
  | H : ?t |- _ =>  let t' := groundcbv t in progress change t' in H
  | x := ?t |- _ =>  let t' := groundcbv t in progress change t' in (value of x)
  | |- ?t =>  let t' := groundcbv t in progress change t'
  end.

Goal Z.add 1 3 = Z.of_nat 4 -> True.
  intros. groundcbv_in_all.
  match goal with
  | _: 4%Z = 4%Z |- _ => idtac
  end.
Abort.


Require Export Coercion_Ambiguity.
Require Import Classical.
Set Undo 100000.

Hint Constructors coercion typing App.
Hint Unfold coerciongen.
Hint Resolve in_eq in_cons in_inv in_nil insingleton.
Hint Resolve coercion_pi_strengthening.
Hint Resolve altnosub_to_altsub.
Hint Constructors nd_typing.
Hint Resolve coercion_sub_rel coerce_non_identity.
Hint Unfold id compose funcompose paircompose.
Hint Unfold coerciongen.
Hint Constructors prims.

Lemma not_uniquepath_implies_prims_differ_coercion :
  forall sigma d t t' m1 m2 pi1 pi2 a1 a2 p1 p2,
    (ok sigma) ->
    (In t pi1) -> (In t pi2) ->
    (coercion sigma pi1 a1 t d t' m1) ->
    (coercion sigma pi2 a2 t d t' m2) ->
    (m1 <> m2) ->
    (prims m1 p1) ->
    (prims m2 p2) ->
    (p1 <> p2).
Proof.
intros until 1. rename H into ok_sigma.
intros In_pi1 In_pi2 C1 C2 m1_neq_m2 prims1 prims2.
generalize dependent m2.
generalize dependent pi2.
generalize dependent a2.
generalize dependent p1.
generalize dependent p2.
induction C1.
Case "id".
intros.
assert (t=t /\ (m2 = (id t))). unfold id. eauto using cycles_are_identity.
intuition.
Case "prim trans".
intros.
induction C2.
SCase "C2 is id".
  assert ((t2=t) /\ C =(id t2)). unfold id. eauto using cycles_are_identity, in_cons.
   intuition. subst. intuition.
SCase "C2 is prim trans".
  destruct (classic (f0=f)) as [f0_eq_f | f0_neq_f].
  SSCase "f0 = f".
    subst. clear IHC2.
    assert (typ_fun t1 t2=typ_fun t1 t0) as t1t2_eq_t1t0. clear -H H1 ok_sigma. eauto using binds_id.
    injection t1t2_eq_t1t0. intro t2_eq_t0. subst.
    inversion prims1. subst.
    inversion H6. subst. rename H5 into prims_C1.
    assert (C<>C0) as C_neq_C0. clear - m1_neq_m2. unfold compose in m1_neq_m2. unfold not. intro. subst. destruct m1_neq_m2. eauto.
    inversion prims2. subst. inversion H7. subst. rename H5 into prims_C0.
    pose proof (IHC1 ok_sigma (in_eq _ _) _ _ prims_C1 _ (t0::pi0) (in_eq _ _) _ C2 C_neq_C0 prims_C0) as fromIHC1.
    assert (fvs2 = (singleton f)). clear - H8. inversion H8. inversion H3. subst. inversion H1. fsetdec.
    assert (fvs3 = (singleton f)). clear - H10. inversion H10. inversion H3. subst. inversion H1. fsetdec.
    subst.
    assert (f `notin` fvs1).
       clear - C1 In_pi1 H1.
      SSSCase "f0=f".

        assert (f0 = f). clear - H H1. eauto using binds_id.

Admitted.

Lemma not_uniquepath_implies_prims_differ :
  forall sigma d t t' m1 m2 p1 p2,
    (ok sigma) ->
    (coerciongen sigma t d t' m1) ->
    (coerciongen sigma t d t' m2) ->
    (m1 <> m2) ->
    (prims m1 p1) ->
    (prims m2 p2) ->
    (p1 <> p2).
Proof.
Admitted.

Lemma ambiguity_relevant_not_uniquepath:
  forall sigma d,
    (ok sigma) ->
    ~(WF_uniquepath d sigma) ->
    (exists gamma, exists e, exists e1, exists e2, exists t1, exists t2,
      nd_typing sigma gamma e e1 t1 /\
      nd_typing sigma gamma e e2 t2 /\
      (forall p1 p2,  prims e1 p1 -> prims e2 p2 ->
        (p1 <> p2 \/ t1 <> t2))).
Proof.
intros sigma d ok_sigma not_wf_up.
 destruct (non_unique_path_witness _ _ ok_sigma not_wf_up) as [t [t' [m [m' [C_m [C_m' [m_neq_m' [m_neq_id m'_neq_id]]]]]]]].
 pick fresh f.
 pick fresh x.
 exists ([(f, (typ_fun t' t'))]++[(x, t)]).
 exists (exp_app (exp_fvar f) (exp_fvar x)).
 exists (exp_app (coerce (id (typ_fun t' t')) (exp_fvar f)) (coerce m (exp_fvar x))).
 exists (exp_app (coerce (id (typ_fun t' t')) (exp_fvar f)) (coerce m' (exp_fvar x))).
 exists t'. exists t'.
 split.
 SCase "nd_typing 1". unfold id.
   induction d; eapply nd_typing_App; eauto.
 split.
 SCase "nd_typing 2". unfold id.
   induction d; eapply nd_typing_App; eauto.
 SCase "p1 <> p2". intros p1 p2 prims1 prims2. left.
   simpl in prims1, prims2.
   rewrite (coerce_non_identity m (exp_fvar x) m_neq_id) in prims1.
   rewrite (coerce_non_identity m' (exp_fvar x) m'_neq_id) in prims2.
   inversion prims1. subst.
   inversion H1. subst. clear H1.
   inversion prims2. subst.
   inversion H1. subst. clear H1.
   inversion H3. subst. inversion H5. subst. clear H3 H5.
   inversion H4. subst. inversion H5. subst. clear H4 H5.
   assert (fvs1 <> fvs2). eauto using not_uniquepath_implies_prims_differ.
   assert (fvs1 = {} `union` fvs1 `union` {}). fsetdec.
   assert (fvs2 = {} `union` fvs2 `union` {}). fsetdec.
   rewrite <- H0. rewrite <- H3. eauto.
Qed.

Theorem ambiguity_is_relevant :
  forall sigma,
    (ok sigma) ->
    ~(NAC sigma RelPrim RelSub) ->
    (exists gamma, exists e, exists e1, exists e2, exists t1, exists t2,
      nd_typing sigma gamma e e1 t1 /\
      nd_typing sigma gamma e e2 t2 /\
      (forall p1 p2,  prims e1 p1 -> prims e2 p2 ->
        (p1 <> p2 \/ t1 <> t2))).
Proof.
intros sigma ok_sigma nac.
unfold NAC in nac.
destruct (not_and_or _ _ nac) as [not_wf_up | nac_1].
Case "not uniquepath relprim".
 eauto using nonamb_core_necessary_not_uniquepath.
destruct (not_and_or _ _ nac_1) as [not_wf_up | nac_2].
Case "not uniquepath relsub".
 eauto using nonamb_core_necessary_not_uniquepath.
destruct (not_and_or _ _ nac_2) as [not_wf_to_unique_pair | nac_3].
 clear nac nac_1 nac_2.
Case "not to uniquepair".
 destruct (non_unique_pair_witness _ _ ok_sigma (refl_equal _) not_wf_to_unique_pair) as [t [t1 [t2 [s1 [s2 [m [m' [C_m [C_m' diseqs]]]]]]]]].
 pick fresh x.
 exists ([(x, t)]).
 exists (exp_proj One (exp_fvar x)).
 exists (exp_proj One (coerce m (exp_fvar x))).
 exists (exp_proj One (coerce m' (exp_fvar x))).
 exists t1. exists s1.
 split.
 SCase "nd_typing 1". eauto.
 split.
 SCase "nd_typing 2". eauto.
 left.
 destruct diseqs as [m_neq_m' [m_neq_id | m'_neq_id]].
 SSCase "m_neq_id".
 rewrite (coerce_non_identity m (exp_fvar x) m_neq_id).
 destruct (coerce_disjunct m' (exp_fvar x)) as [eq_id | eq_app].
   rewrite eq_id. discriminate.
   rewrite eq_app. injection; eauto.
 SSCase "m'_neq_id".
 rewrite (coerce_non_identity m' (exp_fvar x) m'_neq_id).
 destruct (coerce_disjunct m (exp_fvar x)) as [eq_id | eq_app].
   rewrite eq_id. discriminate.
   rewrite eq_app. injection; eauto.
Case "not unique app".
 clear - nac_3 case ok_sigma.
 destruct (non_nac_app_witness _ _ _ nac_3) as [t [t1 [t2 [s1 [s2 [t' [m1 [m2 [m3 [m4 [cgen_f_1 [cgen_f_2 [cgen_3 [cgen_4 neq_disj]]]]]]]]]]]]]].
 pick fresh f.
 pick fresh x.
 exists ([(f, t)] ++ [(x,t')]).
 exists (exp_app (exp_fvar f) (exp_fvar x)).
 exists (exp_app (coerce m1 (exp_fvar f)) (coerce m3 (exp_fvar x))).
 exists (exp_app (coerce m2 (exp_fvar f)) (coerce m4 (exp_fvar x))).
 exists t2.
 exists s2.
 split.
 SCase "nd_typing 1".
   eapply nd_typing_App; eauto.
 split.
 SCase "nd_typing 2".
   eapply nd_typing_App; eauto.
 SCase "neq".
   destruct neq_disj as [t1_neq_s1 | t2_neq_s2].
   SSCase "t1_neq_s1".
   clear cgen_3 cgen_4.
   left.
   assert (m1 <> m2).
     assert ((typ_fun t1 t2) <> (typ_fun s1 s2)) as fun_neq.
       injection; intros. eauto.
     unfold coerciongen in cgen_f_1.
     unfold coerciongen in cgen_f_2.
     eapply (coercion_between_distinct_types sigma ([t]) ([t])); eauto.
     assert (~((t=(typ_fun t1 t2)) /\ (t=(typ_fun s1 s2)))) as not_t_eq_both.
       unfold not; intros eq_both.
       destruct eq_both as [eql eqr].
         subst t. injection eqr. intros; eauto.
     destruct (not_and_or _ _ not_t_eq_both) as [t_neq_t1t2 | t_neq_s1s2].
     SSSCase "t_neq_t1t2".
       assert ((coerce m1 (exp_fvar f)) = (exp_app m1 (exp_fvar f))) as cm1_eq.
       eapply coerce_non_identity.
         unfold coerciongen in cgen_f_1.
         eauto using inequality_implies_nonidentity.
       rewrite cm1_eq.
       destruct (coerce_disjunct m2 (exp_fvar f)) as [cm2l | cm2r].
       rewrite cm2l. discriminate.
       rewrite cm2r. injection; intros; eauto.
     SSSCase "t_neq_s1s2".
       assert ((coerce m2 (exp_fvar f)) = (exp_app m2 (exp_fvar f))) as cm2_eq.
       eapply coerce_non_identity.
         unfold coerciongen in cgen_f_2.
         eauto using inequality_implies_nonidentity.
       rewrite cm2_eq.
       destruct (coerce_disjunct m1 (exp_fvar f)) as [cm1l | cm1r].
       rewrite cm1l. discriminate.
       rewrite cm1r. injection; intros; eauto.
   SSCase "t2_neq_s2".
     right; eauto.
Qed.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Functor_Ops
        Functor.Representable.Hom_Func.
From Categories Require Import Functor.Functor_Extender.
From Categories Require Import NatTrans.NatTrans NatTrans.Operations
        NatTrans.Func_Cat NatTrans.NatIso.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat
     Ext_Cons.Prod_Cat.Operations Ext_Cons.Prod_Cat.Nat_Facts.
From Categories Require Import KanExt.Local
        KanExt.LocalFacts.HomToCones
        KanExt.LocalFacts.ConesToHom.

Local Open Scope functor_scope.

(** This module contains facts about local kan extensions involving natural
    isomorphism. *)

(** Any two naturally isomorphic functors have the same kan extensions –
stated with hom functor definition of local kan extensions. *)
Section Hom_Local_Right_KanExt_Iso.
  Context {C C' : Category} {p : C --> C'}
          {D : Category} {F F' : C --> D}
          (N : (F' ≃ F)%natiso)
          (hlrke : Hom_Local_Right_KanExt p F).

  Definition Hom_Local_Right_KanExt_Iso : Hom_Local_Right_KanExt p F' :=
    {|
      HLRKE := hlrke;
      HLRKE_Iso :=
        (
          (HLRKE_Iso hlrke)
            ∘ (
              (Fix_Bi_Func_2_object_NatIso (Hom_Func (Func_Cat C D)) N)
               ∘_h (NatTrans_id_Iso (Left_Functor_Extender p D)^op)
            )
        )%isomorphism%natiso
    |}.

End Hom_Local_Right_KanExt_Iso.

(** Any two naturally isomorphic functors have the same kan extensions –
stated with cones definition of local kan extensions. *)
Section Local_Right_KanExt_Iso.
  Context {C C' : Category}
          {p : C --> C'}
          {D : Category}
          {F F' : C --> D}
          (N : (F' ≃ F)%natiso)
          (hlrke : Local_Right_KanExt p F).

  Definition Local_Right_KanExt_Iso : Local_Right_KanExt p F' :=
    Hom_Local_Right_KanExt_to_Local_Right_KanExt
      (Hom_Local_Right_KanExt_Iso
         N
         (Local_Right_KanExt_to_Hom_Local_Right_KanExt hlrke)
      ).

End Local_Right_KanExt_Iso.

(** If a functor is naturally isomorphic to the local right kan extension then
it also is local right kan extensions *)
Section Iso_Hom_Local_Right_KanExt.
  Context {C C' : Category}
          {p : C --> C'}
          {D : Category}
          {F : C --> D}
          {hlrke hlrke' : C' --> D}
          (N : (hlrke ≃ hlrke')%natiso)
          (ihlrke : Hom_Local_Right_KanExt_Isomorphism p F hlrke).

  Definition Iso_Hom_Local_Right_KanExt : Hom_Local_Right_KanExt p F :=
    {|
      HLRKE := hlrke';
      HLRKE_Iso :=
        ((Fix_Bi_Func_2_object_NatIso (Hom_Func (Func_Cat C' D)) N)
           ∘ ihlrke)%isomorphism
    |}.

End Iso_Hom_Local_Right_KanExt.

(** If a functor is naturally isomorphic to the local left kan extension then
it also is local left kan extensions – proven using duality. *)
Section Iso_Local_Right_KanExt.
  Context {C C' : Category}
          {p : C --> C'}
          {D : Category}
          {F : C --> D}
          {hlrke hlrke' : C' --> D}
          (N : (hlrke ≃ hlrke')%natiso)
          (ihlrke : is_Local_Right_KanExt p F hlrke).

  Definition  Iso_Local_Right_KanExt : is_Local_Right_KanExt p F hlrke' :=
    Local_Right_KanExt_is_Local_Right_KanExt
      _
      _
      (
        Hom_Local_Right_KanExt_to_Local_Right_KanExt
          (Iso_Hom_Local_Right_KanExt
             N
             (HLRKE_Iso
                (Local_Right_KanExt_to_Hom_Local_Right_KanExt
                   (is_Local_Right_KanExt_Local_Right_KanExt _ _ ihlrke)
                )
             )
          )
      ).

End Iso_Local_Right_KanExt.

(** Kan extension along any two naturally isomorphic functors is the same –
stated with hom functor definition of local kan extensions. *)
Section Hom_Local_Right_KanExt_Iso_along.
  Context {C C' : Category} {p p' : C --> C'}
          (N : (p' ≃ p )%natiso)
          {D : Category} {F : C --> D}
          (hlrke : Hom_Local_Right_KanExt p F).

  Program Definition Hom_Local_Right_KanExt_Iso_along
    : Hom_Local_Right_KanExt p' F :=
    {|
      HLRKE := hlrke;
      HLRKE_Iso :=
        (
          (HLRKE_Iso hlrke)
            ∘ (
              (NatTrans_id_Iso
                 (@Fix_Bi_Func_2
                    _ (Func_Cat C D) _ F (Hom_Func (Func_Cat C D))))
                ∘_h ((Left_Functor_Extender_Iso N D)^op)
            )
        )%isomorphism%natiso
    |}.

End Hom_Local_Right_KanExt_Iso_along.

(** Any two naturally isomorphic functors have the same kan extensions –
stated with cones definition of local kan extensions. *)
Section Local_Right_KanExt_Iso_along.
  Context {C C' : Category} {p p' : C --> C'}
          (N : (p' ≃ p)%natiso)
          {D : Category} {F : C --> D}
          (hlrke : Local_Right_KanExt p F).

  Definition Local_Right_KanExt_Iso_along : Local_Right_KanExt p' F :=
    Hom_Local_Right_KanExt_to_Local_Right_KanExt
      (Hom_Local_Right_KanExt_Iso_along
         N
         (Local_Right_KanExt_to_Hom_Local_Right_KanExt hlrke)
      ).

End Local_Right_KanExt_Iso_along.


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_other_reduce :
  forall T1 L T1', T1 = (t_nom L T1') ->
              forall T2, (forall T2', T2 <> (t_nom L T2')) ->
                    (forall T2', T2 <> (t_upp L T2')) ->
                    subtype T1 T2 = false.

Proof.
  intros.

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

  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.

  destruct T2; auto.

  destruct (eq_label_dec L l) as [Heq|Heq];
    rewrite Heq in Heqsub_fn;
    [rewrite andb_true_l in Heqsub_fn
    |rewrite andb_false_l in Heqsub_fn; auto].

  apply beq_label_eq in Heq; subst L;
    contradiction (H1 T2); auto.

  destruct (eq_label_dec L l) as [Heq|Heq];
    rewrite Heq in Heqsub_fn;
    [rewrite andb_true_l in Heqsub_fn
    |rewrite andb_false_l in Heqsub_fn; auto].

  apply beq_label_eq in Heq; subst L;
    contradiction (H0 T2); auto.
Qed.


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

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

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

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Fixed-point format *)
Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_rnd.
Require Import Fcore_generic_fmt.
Require Import Fcore_ulp.
Require Import Fcore_rnd_ne.

Section RND_FIX.

Variable beta : radix.

Notation bpow := (bpow beta).

Variable emin : Z.

(* fixed-point format with exponent emin *)
Definition FIX_format (x : R) :=
  exists f : float beta,
  x = F2R f /\ (Fexp f = emin)%Z.

Definition FIX_exp (e : Z) := emin.

(** Properties of the FIX format *)

Global Instance FIX_exp_valid : Valid_exp FIX_exp.
Proof.
intros k.
unfold FIX_exp.
split ; intros H.
now apply Zlt_le_weak.
split.
apply Zle_refl.
now intros _ _.
Qed.

Theorem generic_format_FIX :
  forall x, FIX_format x -> generic_format beta FIX_exp x.
Proof.
intros x ((xm, xe), (Hx1, Hx2)).
rewrite Hx1.
now apply generic_format_canonic.
Qed.

Theorem FIX_format_generic :
  forall x, generic_format beta FIX_exp x -> FIX_format x.
Proof.
intros x H.
rewrite H.
eexists ; repeat split.
Qed.

Theorem FIX_format_satisfies_any :
  satisfies_any FIX_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FIX_exp)).
intros x.
split.
apply FIX_format_generic.
apply generic_format_FIX.
Qed.

Global Instance FIX_exp_monotone : Monotone_exp FIX_exp.
Proof.
intros ex ey H.
apply Zle_refl.
Qed.

Theorem ulp_FIX: forall x, ulp beta FIX_exp x = bpow emin.
Proof.
intros x; unfold ulp.
case Req_bool_spec; intros Zx.
case (negligible_exp_spec FIX_exp).
intros T; specialize (T (emin-1)%Z); contradict T.
unfold FIX_exp; omega.
intros n _; reflexivity.
reflexivity.
Qed.

End RND_FIX.


From CoqMTL Require Import Control.Applicative.

Class Monad (M : Type -> Type) : Type :=
{
  is_applicative :> Applicative M;
  compM : forall {A B C : Type}, (A -> M B) -> (B -> M C) -> (A -> M C);
  compM_pure_l :
    forall (A B : Type) (f : A -> M B), compM pure f = f;
  compM_pure_r :
    forall (A B : Type) (f : A -> M B), compM f pure = f;
  compM_assoc :
    forall (A B C D : Type) (f : A -> M B) (g : B -> M C) (h : C -> M D),
      compM f (compM g h) = compM (compM f g) h;
(*
  compM_const :
    forall (A B C : Type) (f : B -> M C) (a : A) (b : B),
      (compM (fun _ : A => pure b) f) a = f b;
*)
}.

Coercion is_applicative : Monad >-> Applicative.

Notation "f >=> g" := (compM f g) (at level 40).

Definition bindM
  {M : Type -> Type} {inst : Monad M}
  {A B : Type} (x : M A) (f : A -> M B) : M B :=
    compM (fun _ : unit => x) f tt.

Lemma bind_ap :
  forall
    (M : Type -> Type) (inst : Monad M) (A B : Type)
    (mf : M (A -> B)) (mx : M A),
        mf <*> mx = bindM mf (fun f => bindM mx (fun x => pure (f x))).
Proof.
  intros. unfold bindM.
Abort.

#[global] Hint Unfold bindM : CoqMTL.

From CoqMTL Require MonadBind.

(*
#[refine]
#[export]
Instance Comp_to_Bind
  (M : Type -> Type) (inst : Monad M) : MonadBind.Monad M :=
{
  bind := @bindM M inst;
  pure := @pure M inst
}.
Proof.
  all: unfold bindM; cbn; intros.
    rewrite compM_const. reflexivity.
    rewrite compM_pure_r. reflexivity.
    replace (fun x : A => ((fun _ : unit => f x) >=> g) tt)
       with (f >=> g).
      Focus 2. ext x. rewrite compM_const.
      rewrite compM_assoc.

Abort.
*)


From iris.program_logic Require Export ectx_language ectxi_language.
From iris.algebra Require Export ofe.
From stdpp Require Export strings.
From stdpp Require Import gmap.
Require Import Reals Rpower.
Set Default Proof Using "Type".

Module heap_lang.
Open Scope Z_scope.

(** Expressions and vals. *)
Definition loc := positive. (* Really, any countable type. *)

Inductive base_lit : Set :=
  | LitInt (n : Z) | LitREAL (r : R) | LitBool (b : bool) | LitUnit | LitLoc (l : loc).
Inductive un_op : Set :=
  | NegOp | MinusUnOp | RCastOp.
Inductive bin_op : Set :=
  | PlusOp | MinusOp | MulOp | DivOp | PowOp | RQuotOp | LeOp | LtOp | EqOp.
Inductive tern_op : Set :=
  | RLtOp.

Inductive binder := BAnon | BNamed : string → binder.
Delimit Scope binder_scope with bind.
Bind Scope binder_scope with binder.
Definition cons_binder (mx : binder) (X : list string) : list string :=
  match mx with BAnon => X | BNamed x => x :: X end.
Infix ":b:" := cons_binder (at level 60, right associativity).
Instance binder_eq_dec_eq : EqDecision binder.
Proof. solve_decision. Defined.

Instance set_unfold_cons_binder x mx X P :
  SetUnfold (x ∈ X) P → SetUnfold (x ∈ mx :b: X) (BNamed x = mx ∨ P).
Proof.
  constructor. rewrite -(set_unfold (x ∈ X) P).
  destruct mx; rewrite /= ?elem_of_cons; naive_solver.
Qed.

Inductive expr :=
  (* Base lambda calculus *)
  | Var (x : string)
  | Rec (f x : binder) (e : expr)
  | App (e1 e2 : expr)
  (* While *)
  | While (e1 e2 : expr)
  | Repeat (e1 e2 : expr)
  (* Base types and their operations *)
  | Lit (l : base_lit)
  | UnOp (op : un_op) (e : expr)
  | BinOp (op : bin_op) (e1 e2 : expr)
  | TernOp (op : tern_op) (e1 e2 e3 : expr)
  | If (e0 e1 e2 : expr)
  (* Products *)
  | Pair (e1 e2 : expr)
  | Fst (e : expr)
  | Snd (e : expr)
  (* Sums *)
  | InjL (e : expr)
  | InjR (e : expr)
  | Case (e0 : expr) (e1 : expr) (e2 : expr)
  (* Concurrency *)
  | Fork (e : expr)
  (* Heap *)
  | Alloc (e : expr)
  | Load (e : expr)
  | Store (e1 : expr) (e2 : expr)
  | CAS (e0 : expr) (e1 : expr) (e2 : expr).

Bind Scope expr_scope with expr.

Fixpoint is_closed (X : list string) (e : expr) : bool :=
  match e with
  | Var x => bool_decide (x ∈ X)
  | Rec f x e => is_closed (f :b: x :b: X) e
  | Lit _ => true
  | UnOp _ e | Fst e | Snd e | InjL e | InjR e | Fork e | Alloc e | Load e =>
     is_closed X e
  | While e1 e2 | Repeat e1 e2 | App e1 e2 | BinOp _ e1 e2 | Pair e1 e2 | Store e1 e2 =>
     is_closed X e1 && is_closed X e2
  | TernOp _ e0 e1 e2 | If e0 e1 e2 | Case e0 e1 e2 | CAS e0 e1 e2 =>
     is_closed X e0 && is_closed X e1 && is_closed X e2
  end.

Class Closed (X : list string) (e : expr) := closed : is_closed X e.
Instance closed_proof_irrel env e : ProofIrrel (Closed env e).
Proof. rewrite /Closed. apply _. Qed.
Instance closed_decision env e : Decision (Closed env e).
Proof. rewrite /Closed. apply _. Qed.

Inductive val :=
  | RecV (f x : binder) (e : expr) `{!Closed (f :b: x :b: []) e}
  | LitV (l : base_lit)
  | PairV (v1 v2 : val)
  | InjLV (v : val)
  | InjRV (v : val).

Bind Scope val_scope with val.

Fixpoint of_val (v : val) : expr :=
  match v with
  | RecV f x e _ => Rec f x e
  | LitV l => Lit l
  | PairV v1 v2 => Pair (of_val v1) (of_val v2)
  | InjLV v => InjL (of_val v)
  | InjRV v => InjR (of_val v)
  end.

Fixpoint to_val (e : expr) : option val :=
  match e with
  | Rec f x e =>
     if decide (Closed (f :b: x :b: []) e) then Some (RecV f x e) else None
  | Lit l => Some (LitV l)
  | Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
  | InjL e => InjLV <$> to_val e
  | InjR e => InjRV <$> to_val e
  | _ => None
  end.

(** The state: heaps of vals. *)
Definition state := gmap loc val.

(** Equality and other typeclass stuff *)
Lemma to_of_val v : to_val (of_val v) = Some v.
Proof.
  by induction v; simplify_option_eq; repeat f_equal; try apply (proof_irrel _).
Qed.

Lemma of_to_val e v : to_val e = Some v → of_val v = e.
Proof.
  revert v; induction e; intros v ?; simplify_option_eq; auto with f_equal.
Qed.

Instance of_val_inj : Inj (=) (=) of_val.
Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

Instance R_eq_dec : EqDecision R.
Proof.
  intros.
  destruct (Rle_dec x y).
  - destruct (Rle_lt_or_eq_dec x y); auto.
    + right. intro. subst. eapply Rlt_irrefl. eauto.
    + left. auto.
  - right. intro. subst. apply n. apply Rle_refl.
Qed.
Instance base_lit_eq_dec : EqDecision base_lit.
Proof. solve_decision. Defined.
Instance un_op_eq_dec : EqDecision un_op.
Proof. solve_decision. Defined.
Instance bin_op_eq_dec : EqDecision bin_op.
Proof. solve_decision. Defined.
Instance tern_op_eq_dec : EqDecision tern_op.
Proof. solve_decision. Defined.
Instance expr_eq_dec : EqDecision expr.
Proof. solve_decision. Defined.
Instance val_eq_dec : EqDecision val.
Proof.
 refine (λ v v', cast_if (decide (of_val v = of_val v'))); abstract naive_solver.
Defined.

Instance expr_inhabited : Inhabited expr := populate (Lit LitUnit).
Instance val_inhabited : Inhabited val := populate (LitV LitUnit).

Canonical Structure stateC := leibnizC state.
Canonical Structure valC := leibnizC val.
Canonical Structure exprC := leibnizC expr.

(** Evaluation contexts *)
Inductive ectx_item :=
  | AppLCtx (e2 : expr)
  | AppRCtx (v1 : val)
  | UnOpCtx (op : un_op)
  | BinOpLCtx (op : bin_op) (e2 : expr)
  | BinOpRCtx (op : bin_op) (v1 : val)
  | TernOp1Ctx (op : tern_op) (e2 e3 : expr)
  | TernOp2Ctx (op : tern_op) (v1 : val) (e3 : expr)
  | TernOp3Ctx (op : tern_op) (v1 v2 : val)
  | IfCtx (e1 e2 : expr)
  | PairLCtx (e2 : expr)
  | PairRCtx (v1 : val)
  | FstCtx
  | SndCtx
  | InjLCtx
  | InjRCtx
  | CaseCtx (e1 : expr) (e2 : expr)
  | AllocCtx
  | LoadCtx
  | StoreLCtx (e2 : expr)
  | StoreRCtx (v1 : val)
  | CasLCtx (e1 : expr) (e2 : expr)
  | CasMCtx (v0 : val) (e2 : expr)
  | CasRCtx (v0 : val) (v1 : val).

Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
  match Ki with
  | AppLCtx e2 => App e e2
  | AppRCtx v1 => App (of_val v1) e
  | UnOpCtx op => UnOp op e
  | BinOpLCtx op e2 => BinOp op e e2
  | BinOpRCtx op v1 => BinOp op (of_val v1) e
  | TernOp1Ctx op e2 e3 => TernOp op e e2 e3
  | TernOp2Ctx op v1 e3 => TernOp op (of_val v1) e e3
  | TernOp3Ctx op v1 v2 => TernOp op (of_val v1) (of_val v2) e
  | IfCtx e1 e2 => If e e1 e2
  | PairLCtx e2 => Pair e e2
  | PairRCtx v1 => Pair (of_val v1) e
  | FstCtx => Fst e
  | SndCtx => Snd e
  | InjLCtx => InjL e
  | InjRCtx => InjR e
  | CaseCtx e1 e2 => Case e e1 e2
  | AllocCtx => Alloc e
  | LoadCtx => Load e
  | StoreLCtx e2 => Store e e2
  | StoreRCtx v1 => Store (of_val v1) e
  | CasLCtx e1 e2 => CAS e e1 e2
  | CasMCtx v0 e2 => CAS (of_val v0) e e2
  | CasRCtx v0 v1 => CAS (of_val v0) (of_val v1) e
  end.

(** Substitution *)
Fixpoint subst (x : string) (es : expr) (e : expr)  : expr :=
  match e with
  | Var y => if decide (x = y) then es else Var y
  | Rec f y e =>
     Rec f y $ if decide (BNamed x ≠ f ∧ BNamed x ≠ y) then subst x es e else e
  | App e1 e2 => App (subst x es e1) (subst x es e2)
  | While e1 e2 => While (subst x es e1) (subst x es e2)
  | Repeat e1 e2 => Repeat (subst x es e1) (subst x es e2)
  | Lit l => Lit l
  | UnOp op e => UnOp op (subst x es e)
  | BinOp op e1 e2 => BinOp op (subst x es e1) (subst x es e2)
  | TernOp op e1 e2 e3 => TernOp op (subst x es e1) (subst x es e2) (subst x es e3)
  | If e0 e1 e2 => If (subst x es e0) (subst x es e1) (subst x es e2)
  | Pair e1 e2 => Pair (subst x es e1) (subst x es e2)
  | Fst e => Fst (subst x es e)
  | Snd e => Snd (subst x es e)
  | InjL e => InjL (subst x es e)
  | InjR e => InjR (subst x es e)
  | Case e0 e1 e2 => Case (subst x es e0) (subst x es e1) (subst x es e2)
  | Fork e => Fork (subst x es e)
  | Alloc e => Alloc (subst x es e)
  | Load e => Load (subst x es e)
  | Store e1 e2 => Store (subst x es e1) (subst x es e2)
  | CAS e0 e1 e2 => CAS (subst x es e0) (subst x es e1) (subst x es e2)
  end.

Definition subst' (mx : binder) (es : expr) : expr → expr :=
  match mx with BNamed x => subst x es | BAnon => Datatypes.id end.

(** The stepping relation *)
Definition un_op_eval (op : un_op) (v : val) : option val :=
  match op, v with
  | NegOp, LitV (LitBool b) => Some $ LitV $ LitBool (negb b)
  | MinusUnOp, LitV (LitInt n) => Some $ LitV $ LitInt (- n)
  | MinusUnOp, LitV (LitREAL r) => Some $ LitV $ LitREAL (- r)
  | RCastOp, LitV (LitInt n) => Some $ LitV $ LitREAL (IZR n)
  | _, _ => None
  end.

Definition bin_op_eval (op : bin_op) (v1 v2 : val) : option val :=
  match op, v1, v2 with
  | PlusOp, LitV (LitInt n1), LitV (LitInt n2) => Some $ LitV $ LitInt (n1 + n2)
  | MinusOp, LitV (LitInt n1), LitV (LitInt n2) => Some $ LitV $ LitInt (n1 - n2)
  | MulOp, LitV (LitInt n1), LitV (LitInt n2) => Some $ LitV $ LitInt (n1 * n2)
  | DivOp, LitV (LitInt n1), LitV (LitInt n2) => if bool_decide (n2 = 0) then None else Some $ LitV $ LitInt (n1 / n2)

  | PlusOp, LitV (LitREAL n1), LitV (LitREAL n2) => Some $ LitV $ LitREAL (n1 + n2)
  | MinusOp, LitV (LitREAL n1), LitV (LitREAL n2) => Some $ LitV $ LitREAL (n1 - n2)
  | MulOp, LitV (LitREAL n1), LitV (LitREAL n2) => Some $ LitV $ LitREAL (n1 * n2)
  | DivOp, LitV (LitREAL n1), LitV (LitREAL n2) => if bool_decide (n2 = 0)%R then None else Some $ LitV $ LitREAL (n1 / n2)
  | PowOp, LitV (LitREAL n1), LitV (LitInt n2) => Some $ (LitV $ LitREAL (Rpower n1 (IZR n2)))
  | RQuotOp, LitV (LitInt n1), LitV (LitInt n2) => Some $ (LitV $ LitREAL ((IZR n1) / (IZR n2)))

  | LeOp, LitV (LitInt n1), LitV (LitInt n2) => Some $ LitV $ LitBool $ bool_decide (n1 ≤ n2)
  | LtOp, LitV (LitInt n1), LitV (LitInt n2) => Some $ LitV $ LitBool $ bool_decide (n1 < n2)
  | EqOp, v1, v2 => Some $ LitV $ LitBool $ bool_decide (v1 = v2)
  | _, _, _ => None
  end.

Inductive tern_op_eval: forall (op : tern_op) (v1 v2 v3 result : val), Prop :=
| tern_op_eval_rlt_true
    k v2 v3
    (LT: (v2 < v3 + Rpower (INR 2) (IZR k))%R):
    tern_op_eval RLtOp (LitV (LitInt k)) (LitV (LitREAL v2)) (LitV (LitREAL v3)) (LitV $ LitBool $ true)
| tern_op_eval_rlt_false
    k v2 v3
    (GT: (v3 < v2 + Rpower (INR 2) (IZR k))%R):
    tern_op_eval RLtOp (LitV (LitInt k)) (LitV (LitREAL v2)) (LitV (LitREAL v3)) (LitV $ LitBool $ false)
.

Inductive head_step : expr → state → expr → state → list (expr) → Prop :=
  | BetaS f x e1 e2 v2 e' σ :
     to_val e2 = Some v2 →
     Closed (f :b: x :b: []) e1 →
     e' = subst' x (of_val v2) (subst' f (Rec f x e1) e1) →
     head_step (App (Rec f x e1) e2) σ e' σ []
  | WhileS e1 e2 σ :
     head_step (While e1 e2) σ (If e1 (App (Rec BAnon BAnon (While e1 e2)) e2) (Lit $ LitBool false)) σ []
  | RepeatS e1 e2 σ :
     head_step (Repeat e1 e2) σ (App (Rec BAnon BAnon (If e2 (Lit $ LitBool true) (Repeat e1 e2))) e1) σ []
  | UnOpS op e v v' σ :
     to_val e = Some v →
     un_op_eval op v = Some v' →
     head_step (UnOp op e) σ (of_val v') σ []
  | BinOpS op e1 e2 v1 v2 v' σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     bin_op_eval op v1 v2 = Some v' →
     head_step (BinOp op e1 e2) σ (of_val v') σ []
  | TernOpS op e1 e2 e3 v1 v2 v3 v' σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 → to_val e3 = Some v3 →
     tern_op_eval op v1 v2 v3 v' →
     head_step (TernOp op e1 e2 e3) σ (of_val v') σ []
  | IfTrueS e1 e2 σ :
     head_step (If (Lit $ LitBool true) e1 e2) σ e1 σ []
  | IfFalseS e1 e2 σ :
     head_step (If (Lit $ LitBool false) e1 e2) σ e2 σ []
  | FstS e1 v1 e2 v2 σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     head_step (Fst (Pair e1 e2)) σ e1 σ []
  | SndS e1 v1 e2 v2 σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     head_step (Snd (Pair e1 e2)) σ e2 σ []
  | CaseLS e0 v0 e1 e2 σ :
     to_val e0 = Some v0 →
     head_step (Case (InjL e0) e1 e2) σ (App e1 e0) σ []
  | CaseRS e0 v0 e1 e2 σ :
     to_val e0 = Some v0 →
     head_step (Case (InjR e0) e1 e2) σ (App e2 e0) σ []
  | ForkS e σ:
     head_step (Fork e) σ (Lit LitUnit) σ [e]
  | AllocS e v σ l :
     to_val e = Some v → σ !! l = None →
     head_step (Alloc e) σ (Lit $ LitLoc l) (<[l:=v]>σ) []
  | LoadS l v σ :
     σ !! l = Some v →
     head_step (Load (Lit $ LitLoc l)) σ (of_val v) σ []
  | StoreS l e v σ :
     to_val e = Some v → is_Some (σ !! l) →
     head_step (Store (Lit $ LitLoc l) e) σ (Lit LitUnit) (<[l:=v]>σ) []
  | CasFailS l e1 v1 e2 v2 vl σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     σ !! l = Some vl → vl ≠ v1 →
     head_step (CAS (Lit $ LitLoc l) e1 e2) σ (Lit $ LitBool false) σ []
  | CasSucS l e1 v1 e2 v2 σ :
     to_val e1 = Some v1 → to_val e2 = Some v2 →
     σ !! l = Some v1 →
     head_step (CAS (Lit $ LitLoc l) e1 e2) σ (Lit $ LitBool true) (<[l:=v2]>σ) [].

(** Basic properties about the language *)
Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
Proof. destruct Ki; intros ???; simplify_eq/=; auto with f_equal. Qed.

Lemma fill_item_val Ki e :
  is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.

Lemma val_stuck e1 σ1 e2 σ2 efs : head_step e1 σ1 e2 σ2 efs → to_val e1 = None.
Proof. destruct 1; naive_solver. Qed.

Lemma head_ctx_step_val Ki e σ1 e2 σ2 efs :
  head_step (fill_item Ki e) σ1 e2 σ2 efs → is_Some (to_val e).
Proof. destruct Ki; inversion_clear 1; simplify_option_eq; by eauto. Qed.

Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
  to_val e1 = None → to_val e2 = None →
  fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
Proof.
  destruct Ki1, Ki2; intros; try discriminate; simplify_eq/=;
    repeat match goal with
    | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
    end; auto.
Qed.

Lemma alloc_fresh e v σ :
  let l := fresh (dom _ σ) in
  to_val e = Some v → head_step (Alloc e) σ (Lit (LitLoc l)) (<[l:=v]>σ) [].
Proof. by intros; apply AllocS, (not_elem_of_dom (D:=gset _)), is_fresh. Qed.

(* Misc *)
Lemma to_val_rec f x e `{!Closed (f :b: x :b: []) e} :
  to_val (Rec f x e) = Some (RecV f x e).
Proof. rewrite /to_val. case_decide=> //. do 2 f_equal; apply proof_irrel. Qed.

(** Closed expressions *)
Lemma is_closed_weaken X Y e : is_closed X e → X ⊆ Y → is_closed Y e.
Proof. revert X Y; induction e; naive_solver (eauto; set_solver). Qed.

Lemma is_closed_weaken_nil X e : is_closed [] e → is_closed X e.
Proof. intros. by apply is_closed_weaken with [], list_subseteq_nil. Qed.

Lemma is_closed_of_val X v : is_closed X (of_val v).
Proof. apply is_closed_weaken_nil. induction v; simpl; auto. Qed.

Lemma is_closed_subst X e x es :
  is_closed [] es → is_closed (x :: X) e → is_closed X (subst x es e).
Proof.
  intros ?. revert X.
  induction e=> X /= ?; destruct_and?; split_and?; simplify_option_eq;
    try match goal with
    | H : ¬(_ ∧ _) |- _ => apply not_and_l in H as [?%dec_stable|?%dec_stable]
    end; eauto using is_closed_weaken with set_solver.
Qed.
Lemma is_closed_do_subst' X e x es :
  is_closed [] es → is_closed (x :b: X) e → is_closed X (subst' x es e).
Proof. destruct x; eauto using is_closed_subst. Qed.

(* Substitution *)
Lemma subst_is_closed X e x es : is_closed X e → x ∉ X → subst x es e = e.
Proof.
  revert X. induction e=> X /=; rewrite ?bool_decide_spec ?andb_True=> ??;
    repeat case_decide; simplify_eq/=; f_equal; intuition eauto with set_solver.
Qed.

Lemma subst_is_closed_nil e x es : is_closed [] e → subst x es e = e.
Proof. intros. apply subst_is_closed with []; set_solver. Qed.

Lemma subst_subst e x es es' :
  Closed [] es' → subst x es (subst x es' e) = subst x es' e.
Proof.
  intros. induction e; simpl; try (f_equal; by auto);
    simplify_option_eq; auto using subst_is_closed_nil with f_equal.
Qed.
Lemma subst_subst' e x es es' :
  Closed [] es' → subst' x es (subst' x es' e) = subst' x es' e.
Proof. destruct x; simpl; auto using subst_subst. Qed.

Lemma subst_subst_ne e x y es es' :
  Closed [] es → Closed [] es' → x ≠ y →
  subst x es (subst y es' e) = subst y es' (subst x es e).
Proof.
  intros. induction e; simpl; try (f_equal; by auto);
    simplify_option_eq; auto using eq_sym, subst_is_closed_nil with f_equal.
Qed.
Lemma subst_subst_ne' e x y es es' :
  Closed [] es → Closed [] es' → x ≠ y →
  subst' x es (subst' y es' e) = subst' y es' (subst' x es e).
Proof. destruct x, y; simpl; auto using subst_subst_ne with congruence. Qed.

Lemma subst_rec' f y e x es :
  x = f ∨ x = y ∨ x = BAnon →
  subst' x es (Rec f y e) = Rec f y e.
Proof. intros. destruct x; simplify_option_eq; naive_solver. Qed.
Lemma subst_rec_ne' f y e x es :
  (x ≠ f ∨ f = BAnon) → (x ≠ y ∨ y = BAnon) →
  subst' x es (Rec f y e) = Rec f y (subst' x es e).
Proof. intros. destruct x; simplify_option_eq; naive_solver. Qed.
End heap_lang.

(** Language *)
Program Instance heap_ectxi_lang :
  EctxiLanguage
    (heap_lang.expr) heap_lang.val heap_lang.ectx_item heap_lang.state := {|
  of_val := heap_lang.of_val; to_val := heap_lang.to_val;
  fill_item := heap_lang.fill_item; head_step := heap_lang.head_step
|}.
Solve Obligations with eauto using heap_lang.to_of_val, heap_lang.of_to_val,
  heap_lang.val_stuck, heap_lang.fill_item_val, heap_lang.fill_item_no_val_inj,
  heap_lang.head_ctx_step_val.

Canonical Structure heap_lang := ectx_lang (heap_lang.expr).

(* Prefer heap_lang names over ectx_language names. *)
Export heap_lang.

(** Define some derived forms *)
Notation Lam x e := (Rec BAnon x e).
Notation Let x e1 e2 := (App (Lam x e2) e1).
Notation Seq e1 e2 := (Let BAnon e1 e2).
Notation LamV x e := (RecV BAnon x e).
Notation LetCtx x e2 := (AppRCtx (LamV x e2)).
Notation SeqCtx e2 := (LetCtx BAnon e2).
Notation Skip := (Seq (Lit LitUnit) (Lit LitUnit)).
Notation Match e0 x1 e1 x2 e2 := (Case e0 (Lam x1 e1) (Lam x2 e2)).


Inductive two : bool -> Prop :=
| Zero : two false
| One : two true.

Ltac dup :=
  let H := fresh in assert (forall (P : Prop), P -> P -> P) as H by (intros; trivial);
  apply H; clear H.

Lemma transform : two false <-> two true.
Proof. split; intros _; constructor. Qed.

Goal two false /\ two true /\ two false /\ two true /\ two true /\ two true.
Proof.
  do 2 dup.
  - repeat split.
    2, 4-99, 100-3:idtac.
    2-5:exact One.
    par:exact Zero.
  - repeat split.
    3-6:swap 1 4.
    1-5:swap 1 5.
    0-4:exact One.
    all:exact Zero.
  - repeat split.
    1, 3:exact Zero.
    1, 2, 3, 4: exact One.
  - repeat split.
    all:apply transform.
    2, 4, 6:apply transform.
    all:apply transform.
    1-5:apply transform.
    1-6:exact One.
Qed.

Goal True -> True.
Proof.
  intros y; only 1-2 : repeat idtac.
  1-1:match goal with y : _ |- _ => let x := y in idtac x end.
  Fail 1-1:let x := y in idtac x.
  1:let x := y in idtac x.
  exact I.
Qed.

Goal True /\ (True /\ True).
Proof.
  dup.
  - split; only 2: (split; exact I).
    exact I.
  - split; only 2: split; exact I.
Qed.

Goal True -> exists (x : Prop), x.
Proof.
  intro H; eexists ?[x]; only [x]: exact True. 1: assumption.
Qed.

(* Strict focusing! *)
Set Default Goal Selector "!".

Goal True -> True /\ True /\ True.
Proof.
  intro.
  split;only 2:split.
  Fail exact I.
  Fail !:exact I.
  1:exact I.
  - !:exact H.
  - exact I.
Qed.