From Undecidability Require Import bestaxioms EA equiv_on DecidabilityFacts SemiDecidabilityFacts Definitions reductions EnumerabilityFacts ReducibilityTransport.

Import EmbedNatNotations.

Set Default Goal Selector "!".

Lemma Rice {p : nat -> Prop} c_bot c :
  (forall x, ~ W c_bot x) ->
  (forall c1 c2, W c1 ≡{_} W c2 -> p c1 -> p c2) ->
  ~ p c ->
  p c_bot -> compl K0 ⪯ₘ p.
Proof.
  intros Hbot Hequiv Hc Hpbot.
  edestruct EAP with (p := fun x y => K0 x /\ W c y) as [f Hf]. {
    exists (fun x => fun! ⟨n,m⟩ => if φ x n is Some x' then if Nat.eqb x x' then φ c m else None else None).
    intros x y. split.
    + intros [[n H1] [m H2]]. exists ⟨n,m⟩. now rewrite embedP, H1, PeanoNat.Nat.eqb_refl, H2.
    + intros [nm H]. destruct (unembed nm) as [n m].
      destruct φ as [x' | ] eqn:E; try congruence.
      destruct (PeanoNat.Nat.eqb_spec x x') as [-> | ]; try congruence.
      firstorder.
  }
  exists f. intros x. unfold K0, compl.
  split.
  - intros H. eapply Hequiv. 2:exact Hpbot.
    cbn. intros. rewrite <- (Hf x x0). firstorder.
  - intros H. intros Hx.
    apply Hc. eapply Hequiv. 2: exact H.
    intros y. rewrite <- (Hf x y). firstorder.
Qed.

Lemma Rice_Theorem {p : nat -> Prop} :
  (forall c1 c2, W c1 ≡{_} W c2 -> p c1 -> p c2) ->
  (exists c1, p c1) ->
  (exists c2, ~ p c2) -> ~ (enumerable p /\ enumerable (compl p)).
Proof.
  intros Hequiv [c1 Hc1] [c2 Hc2] [Hp1 Hp2].
  destruct (do_EA (fun _ => False)) as [c_bot Hbot].
  - exists (fun _ => None). firstorder congruence.
  - assert (~~ (p c_bot \/ ~ p c_bot)) as Hc by tauto.
    apply Hc; clear Hc. intros [? | ?].
    + clear Hp2. eapply K0_not_enumerable; eauto.
      eapply enumerable_red; eauto.
      1: eapply Rice with (c_bot0 := c_bot); eauto.
      firstorder.
    + clear Hp1. eapply K0_not_enumerable; eauto.
      eapply enumerable_red; eauto.
      1: eapply Rice with (c_bot0 := c_bot) (c := c1); eauto.
      1: firstorder.
      intros ? ? ? H1 ?. eapply H1, Hequiv; eauto; firstorder.
Qed.

Lemma Rice_TheoremCorr {p : nat -> Prop} :
  (forall c1 c2, W c1 ≡{_} W c2 -> p c1 -> p c2) ->
  (exists c1, p c1) ->
  (exists c2, ~ p c2) -> ~ decidable p.
Proof.
  intros Hequiv Hc1 Hc2 Hp.
  eapply Rice_Theorem; eauto.
  split.
  - eapply decidable_enumerable; eauto.
  - eapply decidable_enumerable; eauto.
    now eapply decidable_complement.
Qed.

Lemma Rice_HO {p : (nat -> Prop) -> Prop} :
  (forall (q q' : nat -> Prop), (forall x, q x <-> q' x) -> p q <-> p q') ->
  forall q1 q2,
    enumerable q1 -> enumerable q2 ->
    p q1 -> ~ p q2 -> ~ decidable p.
Proof.
  intros Hequiv q1 q2 H1 H2 Hq1 Hq2 H.
  eapply (@Rice_TheoremCorr (fun c => p (W c))).
  - firstorder.
  - eapply do_EA in H1 as [c Hc]. exists c. firstorder.
  - eapply do_EA in H2 as [c Hc]. exists c. firstorder.
  - destruct H as [f Hf]. exists (fun c => f (W c)). firstorder.
Qed.

Section EPF.

Variable Part : partiality.

Variable Θ : nat -> (nat ↛ nat).

Instance equiv_part `{partiality} {A} : equiv_on (part A) := {| equiv_rel := @partial.equiv _ A |}.

Variable EPF : forall f : nat -> nat ↛ nat, exists γ, forall x, Θ (γ x) ≡{nat ↛ nat} f x.

Lemma FP : forall f, exists e, Θ e ≡{_} Θ (f e).
Proof.
  intros f.
  pose (h := fun x y => bind (Θ x x) (fun e => Θ e y)).
  destruct (EPF h)  as [γ Hγ].
  destruct (EPF (fun _ x => ret (f (γ x))))  as [γ' Hc].
  pose (c := γ' 0).
  exists (γ c).
  rewrite Hγ. unfold h.
  intros x v. rewrite bind_hasvalue. split.
  - now intros (y & <- % Hc % ret_hasvalue_inv & H2).
  - intros Hv. eexists. split; eauto.
    eapply Hc. now eapply ret_hasvalue.
Qed.

Lemma Rice_Theorem' {p : nat -> Prop} :
  (forall c1 c2, Θ c1 ≡{_} Θ c2 -> p c1 -> p c2) ->
  (exists c1, p c1) ->
  (exists c2, ~ p c2) -> ~ decidable p.
Proof.
  intros Hequiv [c1 Hc1] [c2 Hc2] [f Hf].
  pose (h x := if f x then Θ c2 else Θ c1).
  destruct (EPF h) as [γ H].
  destruct (FP γ) as [c Hc].
  rewrite H in Hc. unfold h in Hc.
  destruct (f c) eqn:E.
  - assert (Hx : p c) by firstorder.
    eapply Hc2. eapply Hequiv. 2: eapply Hx. eapply Hc.
  - assert (Hx : ~ p c) by firstorder congruence.
    eapply Hx. eapply Hequiv. 1:symmetry; eapply Hc. exact Hc1.
Qed.

End EPF.

Corollary Rice_HO' {Part : partiality} {p : (nat ↛ nat) -> Prop} :
  EPF -> (forall f f', f ≡{_} f' -> p f <-> p f') ->
  forall f1 f2, p f1 -> ~ p f2 -> ~ decidable p.
Proof.
  intros [θ EPF] Hequiv f1 f2 H1 H2 H.
  eapply (@Rice_Theorem' Part θ EPF (fun c => p (θ c))).
  - firstorder.
  - destruct (EPF (fun _ => f1)) as [c Hc]. exists (c 0).
    firstorder.
  - destruct (EPF (fun _ => f2)) as [c Hc]. exists (c 0).
    firstorder.
  - destruct H as [f Hf]. exists (fun c => f (θ c)). firstorder.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C P Q I : Universe, ((wd_ P Q /\ (wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ A P /\ (wd_ A Q /\ (wd_ B P /\ (wd_ B Q /\ (wd_ C P /\ (wd_ C Q /\ (wd_ B I /\ (wd_ I C /\ (wd_ B C /\ (wd_ P I /\ (wd_ Q I /\ (col_ B I C /\ (col_ P Q I /\ col_ B C P))))))))))))))))) -> col_ B P Q)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import GeoCoq.Axioms.continuity_axioms.
Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Annexes.suma.
Require Import GeoCoq.Tarski_dev.Ch13_1.

Section triangle_playfair_bis.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma legendre_aux1 :
  greenberg_s_axiom ->
  triangle_postulate ->
  forall A1 A2 B1 B2 C1 C2 P,
    Perp2 A1 A2 B1 B2 P -> ~ Col A1 A2 P -> Col P B1 B2 -> Coplanar A1 A2 B1 B2 ->
    Par A1 A2 C1 C2 -> Col P C1 C2 -> ~ TS B1 B2 A1 C1 ->
    Col C1 B1 B2.
Proof.
  intros greenberg triangle.
  intros A1 A2 B1 B2 C1 C2 P HPerp2 HNC HPB HCop HParAC HPC HNts.
  assert(HParAB : Par A1 A2 B1 B2).
    {
    assert (Par_strict A1 A2 B1 B2); [|Par].
    apply (par_not_col_strict _ _ _ _ P); Col.
    apply par_symmetry.
    destruct HPerp2 as [X [Y [HCol1 [HPerp1 HPerp2]]]].
    assert (HI1 := HPerp1); assert (HI2 := HPerp2).
    destruct HI1 as [I1 H1]; destruct HI2 as [I2 H2].
    apply perp_in_col in H1; apply perp_in_col in H2.
    destruct H1 as [HCol2 HCol3]; destruct H2 as [HCol4 HCol5].
    assert (P = I2); [|treat_equalities; rename I1 into R].
      {
      elim (perp_not_col2 _ _ _ _ (perp_sym _ _ _ _ HPerp2)); intro;
      [apply l6_21 with B1 B2 X Y|apply l6_21 with B1 B2 Y X]; assert_diffs; Col.
      }
    elim (eq_dec_points P R); intro HNE; treat_equalities; [exfalso; Col|].
    apply (l12_9 _ _ _ _ X Y); Perp; apply coplanar_perm_16;
    apply col2_cop__cop with P R; try solve [assert_diffs; ColR];
    apply coplanar_perm_2;
    [apply col_cop__cop with A2|apply col_cop__cop with A1|
     apply col_cop__cop with A2|apply col_cop__cop with A1];
    Col; try solve [assert_diffs; auto]; apply coplanar_perm_16;
    [apply col_cop__cop with B2|apply col_cop__cop with B2|
     apply col_cop__cop with B1|apply col_cop__cop with B1];
    assert_diffs; Col; Cop.
    }
  elim(col_dec P A1 A2).
  { intro HConf.
    assert_diffs.
    apply (not_strict_par _ _ _ _ P) in HParAB; Col.
    apply (not_strict_par _ _ _ _ P) in HParAC; Col.
    spliter.
    apply(col3 A1 A2); auto.
  }
  intro HStrict.
  apply (par_not_col_strict _ _ _ _ P) in HParAB; Col.
  apply (par_not_col_strict _ _ _ _ P) in HParAC; Col.
  elim(col_dec C1 B1 B2); auto.
  intro HC1NotB.
  exfalso.
  assert(P<>C1) by (intro; subst C1; Col).
  destruct HPerp2 as [P1 [P2 [HP [HPerpAP HPerpBP]]]].
  assert(HQ := HPerpAP); auto.
  destruct HQ as [Q [_ [_ [HQP[HQA _]]]]].
  assert(HP' := HPerpBP); auto.
  destruct HP' as [P' HPerpP].
  assert(P'=P) by (apply (l8_14_2_1b _ P1 P2 B1 B2); Col).
  subst P'.
  destruct HPerpP as [_ [_ [HPP _]]].
  assert(P<>Q) by (intro; subst Q; auto).
  apply (perp_col0 _ _ _ _ P Q) in HPerpAP; Col.
  apply (perp_col0 _ _ _ _ P Q) in HPerpBP; Col.
  clear dependent P1.
  clear dependent P2.

  assert_diffs.
  assert(Hos : OS B1 B2 Q C1).
  { apply (one_side_transitivity _ _ _ A1).
    - elim(eq_dec_points A1 Q).
      intro; subst A1; apply one_side_reflexivity; auto; apply (par_strict_not_col_2 A2); Par.
      intro.
      apply l12_6.
      apply par_strict_right_comm.
      apply (par_strict_col_par_strict _ _ _ A2); Col; Par.

    - apply cop__not_two_sides_one_side; Col.
      assert (Coplanar A1 A2 P B1) by (apply col2_cop__cop with B1 B2; Col; Cop).
      assert (Coplanar A1 A2 P B2) by (apply col2_cop__cop with B1 B2; Col; Cop).
      assert (Coplanar A1 A2 C1 C2) by (apply pars__coplanar; auto).
      assert (Coplanar A1 A2 P C1) by (apply col2_cop__cop with C1 C2; Col; Cop).
      assert (Coplanar A1 A2 P C2) by (apply col2_cop__cop with C1 C2; Col; Cop).
      CopR.
      apply (par_strict_not_col_2 A2); Par.
  }
  assert(~ Col Q C1 P) by (apply (par_not_col A1 A2); auto; apply (par_strict_col_par_strict _ _ _ C2); Col).
  assert(~ Col B1 B2 Q) by (apply (one_side_not_col123 _ _ _ C1); auto).

  assert(HB3 : exists B3, Col B1 B2 B3 /\ OS P Q C1 B3).
  { assert (Coplanar A1 A2 P B1) by (apply col2_cop__cop with B1 B2; Col; Cop).
    assert (Coplanar A1 A2 P B2) by (apply col2_cop__cop with B1 B2; Col; Cop).
    assert (Coplanar A1 A2 C1 C2) by (apply pars__coplanar; auto).
    assert (Coplanar A1 A2 P C1) by (apply col2_cop__cop with C1 C2; Col; Cop).
    assert (Coplanar A1 A2 P C2) by (apply col2_cop__cop with C1 C2; Col; Cop).
    assert (Coplanar A1 A2 P Q) by Cop.
    assert (Coplanar B1 B2 P Q) by Cop.
    elim(col_dec P Q B1).
    2: intro; apply (cop_not_par_same_side _ _ _ _ P); Col.
    intro.
    assert(HB3 := cop_not_par_same_side P Q B2 B1 P C1).
    destruct HB3 as [B3 []]; Col.
    intro; assert(Col B1 B2 Q); Col; ColR.
    CopR.
    exists B3; split; Col.
    CopR.
  }
  destruct HB3 as [B3 []].
  assert(HB4 := symmetric_point_construction B3 P).
  destruct HB4 as [B4].
  assert(~ Col P Q B3) by (apply (one_side_not_col123 _ _ _ C1); Side).
  assert(HA3 : exists A3, Col A1 A2 A3 /\ OS P Q C1 A3).
  { assert (Coplanar A1 A2 P B1) by (apply col2_cop__cop with B1 B2; Col; Cop).
    assert (Coplanar A1 A2 P B2) by (apply col2_cop__cop with B1 B2; Col; Cop).
    assert (Coplanar A1 A2 C1 C2) by (apply pars__coplanar; auto).
    assert (Coplanar A1 A2 P C1) by (apply col2_cop__cop with C1 C2; Col; Cop).
    assert (Coplanar A1 A2 P C2) by (apply col2_cop__cop with C1 C2; Col; Cop).
    assert (Coplanar A1 A2 P Q) by Cop.
    assert (Coplanar B1 B2 P Q) by Cop.
    elim(col_dec P Q A1).
    2: intro; apply (cop_not_par_same_side _ _ _ _ Q); Col.
    intro.
    assert(HA3 := cop_not_par_same_side P Q A2 A1 Q C1).
    destruct HA3 as [A3 []]; Col.
    intro; apply HStrict; ColR.
    CopR.
    exists A3; split; Col.
    CopR.
  }
  destruct HA3 as [A3 []].
  assert(~ Col P Q A3) by (apply (one_side_not_col123 _ _ _ C1); Side).
  assert_diffs.
  assert(HInAngle : InAngle C1 Q P B3).
    apply os2__inangle; Side; apply (col2_os__os B1 B2); Col.
  assert(LtA B3 P C1 B3 P Q).
  { split.
    exists C1; split; try (apply l11_24); CongA.
    intro HConga.
    apply conga_cop__or_out_ts in HConga.
    destruct HConga as [Habs|Habs].
    assert_cols; Col.
    apply l9_9 in Habs.
    apply Habs.
    apply one_side_symmetry.
    apply (col2_os__os B1 B2); Col.
    assert (Coplanar A1 A2 P B1) by (apply col2_cop__cop with B1 B2; Col; Cop).
    assert (Coplanar A1 A2 P B2) by (apply col2_cop__cop with B1 B2; Col; Cop).
    assert (Coplanar A1 A2 C1 C2) by (apply pars__coplanar; auto).
    assert (Coplanar A1 A2 P C1) by (apply col2_cop__cop with C1 C2; Col; Cop).
    assert (Coplanar A1 A2 P C2) by (apply col2_cop__cop with C1 C2; Col; Cop).
    assert (Coplanar A1 A2 P Q) by Cop.
    assert (Coplanar B1 B2 P Q) by Cop.
    apply coplanar_perm_16, col2_cop__cop with B1 B2; Col; CopR.
  }
  assert(Acute B3 P C1).
  { exists B3.
    exists P.
    exists Q.
    split; auto.
    apply perp_per_2; auto.
    apply (perp_col2 B1 B2); Col.
  }
  assert(HR:= greenberg P Q A3 B3 P C1).
  destruct HR as [R []]; auto.
    intro; assert_cols; apply HC1NotB; ColR.
    apply perp_per_1; auto; apply (perp_col2_bis _ _ _ _ A1 A2); Perp; ColR.
  assert(P<>R) by (intro; subst R; assert_cols; Col).
  assert(OS P Q R A3) by (apply invert_one_side; apply out_one_side; Col).
  assert_diffs.
  assert(OS P C1 R Q).
    apply l12_6; apply (par_strict_col4__par_strict C1 C2 A1 A2); Col; Par; ColR.
  assert(Hsuma1 := ex_suma B4 P R P R Q).
  destruct Hsuma1 as [A [B [C Hsuma1]]]; auto.
  assert(Htri : TriSumA R Q P A B C).
  { exists B4.
    exists P.
    exists R.
    split; auto.
    apply (conga3_suma__suma B4 P Q Q P R B4 P R); try (apply conga_refl; auto).
    - exists R.
      repeat (split; CongA).
      apply l9_9.
      apply l9_2.
      apply (l9_8_2 _ _ B3).
      { repeat split; Col.
        intro; assert(Col P Q B3); Col; ColR.
        exists P.
        split; Col; Between.
      }
      apply (one_side_transitivity _ _ _ A3); Side.
      apply (one_side_transitivity _ _ _ C1); Side.
      assert (Coplanar P Q R C1)
        by (apply os__coplanar, one_side_transitivity with A3; Side).
      assert (Coplanar A1 A2 P B1) by (apply col2_cop__cop with B1 B2; Col; Cop).
      assert (Coplanar A1 A2 P B2) by (apply col2_cop__cop with B1 B2; Col; Cop).
      assert (Coplanar A1 A2 C1 C2) by (apply pars__coplanar; auto).
      assert (Coplanar A1 A2 P C1) by (apply col2_cop__cop with C1 C2; Col; Cop).
      assert (Coplanar A1 A2 P C2) by (apply col2_cop__cop with C1 C2; Col; Cop).
      assert (Coplanar A1 A2 P Q) by Cop.
      assert (Coplanar B1 B2 P Q) by Cop.
      apply coplanar_perm_16.
      elim (perp_not_col2 _ _ _ _ (perp_sym _ _ _ _ HPerpBP)); intro;
      [apply col2_cop__cop with P B1|apply col2_cop__cop with P B2];
      assert_diffs; Col; try ColR; CopR.

    - apply l11_16; auto.
      apply perp_per_2; auto; apply (perp_col2 B1 B2); Col; ColR.
      apply perp_per_1; auto; apply (perp_col2 A1 A2); Col; ColR.
  }
  assert(Hsuma2 := ex_suma B4 P R C1 P B3).
  destruct Hsuma2 as [D [E [F Hsuma2]]]; auto.
  assert(~ Col R P B4).
  { apply (par_not_col A1 A2); auto.
    apply (par_strict_col2_par_strict _ _ B1 B2); auto; ColR.
    ColR.
  }
  assert(~ OS P R B4 B3).
  { apply l9_9.
    repeat split; Col.
    intro; assert(Col R P B4); Col; ColR.
    exists P.
    split; Col; Between.
  }
  assert(Hsuma3 : SumA B4 P R R P B3 B4 P B3) by (exists B3; repeat (split; CongA); Cop).
  assert(Hsams3 : SAMS B4 P R R P B3).
  { repeat split; auto.
    right; intro; assert_cols; Col.
    exists B3; repeat (split; CongA); Cop.
    intro Habs.
    destruct Habs as [_ [Habs]].
    assert_cols; Col.
  }
  assert(LeA C1 P B3 R P B3).
  { apply lea_comm.
    exists C1.
    split; CongA.
    apply os_ts__inangle.
    - apply l9_2.
      apply (l9_8_2 _ _ Q); Side.
      apply invert_two_sides; apply in_angle_two_sides; Col.
      intro; apply HC1NotB; ColR.
    - apply (one_side_transitivity _ _ _ Q); apply (col2_os__os B1 B2); Col.
      apply l12_6.
      apply (par_strict_col2_par_strict _ _ A1 A2); Col; Par.
      ColR.
  }

  assert(Habs : LtA A B C B4 P B3).
  { apply (lea456789_lta__lta _ _ _ D E F).
    2: apply (sams_lea2_suma2__lea B4 P R C1 P B3 _ _ _ B4 P R R P B3); Lea.
    apply (sams_lea_lta456_suma2__lta B4 P R P R Q _ _ _ B4 P R C1 P B3); Lea.
    apply lta_right_comm; auto.
    apply (sams_lea2__sams _ _ _ _ _ _ B4 P R R P B3); Lea.
  }
  destruct Habs as [_ Habs].
  apply Habs.
  apply suma_distincts in Hsuma1.
  spliter.
  apply conga_line; Between.
  apply (triangle R Q P); auto.
Qed.

Lemma legendre_aux2 :
  greenberg_s_axiom ->
  triangle_postulate ->
  forall A1 A2 B1 B2 C1 C2 P,
    Perp2 A1 A2 B1 B2 P -> ~ Col A1 A2 P -> Col P B1 B2 -> Coplanar A1 A2 B1 B2 ->
    Par A1 A2 C1 C2 -> Col P C1 C2 ->
    Col C1 B1 B2. (* "half" of playfair_bis *)
Proof.
  intros greenberg triangle.
  intros A1 A2 B1 B2 C1 C2 P HPerp2 HNC HPB HCop HParAC HPC.
  assert(HParAB : Par A1 A2 B1 B2).
    {
    assert (Par_strict A1 A2 B1 B2); [|Par].
    apply (par_not_col_strict _ _ _ _ P); Col.
    apply par_symmetry.
    destruct HPerp2 as [X [Y [HCol1 [HPerp1 HPerp2]]]].
    assert (HI1 := HPerp1); assert (HI2 := HPerp2).
    destruct HI1 as [I1 H1]; destruct HI2 as [I2 H2].
    apply perp_in_col in H1; apply perp_in_col in H2.
    destruct H1 as [HCol2 HCol3]; destruct H2 as [HCol4 HCol5].
    assert (P = I2); [|treat_equalities; rename I1 into R].
      {
      elim (perp_not_col2 _ _ _ _ (perp_sym _ _ _ _ HPerp2)); intro;
      [apply l6_21 with B1 B2 X Y|apply l6_21 with B1 B2 Y X]; assert_diffs; Col.
      }
    elim (eq_dec_points P R); intro HNE; treat_equalities; [exfalso; Col|].
    apply (l12_9 _ _ _ _ X Y); Perp; apply coplanar_perm_16;
    apply col2_cop__cop with P R; try solve [assert_diffs; ColR];
    apply coplanar_perm_2;
    [apply col_cop__cop with A2|apply col_cop__cop with A1|
     apply col_cop__cop with A2|apply col_cop__cop with A1];
    Col; try solve [assert_diffs; auto]; apply coplanar_perm_16;
    [apply col_cop__cop with B2|apply col_cop__cop with B2|
     apply col_cop__cop with B1|apply col_cop__cop with B1];
    assert_diffs; Col; Cop.
    }
  elim(col_dec P A1 A2).
  { intro HConf.
    assert_diffs.
    apply (not_strict_par _ _ _ _ P) in HParAB; Col.
    apply (not_strict_par _ _ _ _ P) in HParAC; Col.
    spliter.
    apply(col3 A1 A2); auto.
  }
  intro HStrict.
  elim(two_sides_dec B1 B2 A1 C1).
  { intro Hts.
    exfalso.
    assert(HC1NotB : ~ Col C1 B1 B2) by (destruct Hts as [_ []]; auto).
    assert(C1<>P) by (intro; subst C1; Col).
    assert(HC3 := (symmetric_point_construction C1 P)).
    destruct HC3 as [C3].
    assert_diffs.
    assert(HC3NotB : ~ Col C3 B1 B2) by (intro; apply HC1NotB; ColR).
    apply HC3NotB.
    apply (legendre_aux1 greenberg triangle A1 A2 _ _ _ C1 P); Col.
    - apply par_right_comm.
      apply (par_col_par _ _ _ P); Col.
      apply (par_col_par _ _ _ C2); Col.
    - apply l9_9_bis.
      exists C1.
      repeat (split; auto).
      exists P.
      split; Between.
  }
  intro.
  apply (legendre_aux1 greenberg triangle A1 A2 _ _ _ C2 P); auto.
Qed.

Lemma triangle__playfair_bis :
  greenberg_s_axiom ->
  triangle_postulate ->
  alternative_playfair_s_postulate.
Proof.
  intros greenberg triangle.
  intros A1 A2 B1 B2 C1 C2 P.
  split.
  apply (legendre_aux2 greenberg triangle A1 A2 _ _ _ C2 P); auto.
  apply (legendre_aux2 greenberg triangle A1 A2 _ _ _ C1 P); Par; Col.
Qed.

End triangle_playfair_bis.


Require Import Crypto.Util.Notations.
Local Set Universe Polymorphism.

(** [x <- f ; C] encodes a call to function [f] with [C] as the
  continuation. In [C], [x] refers to the output of [f]. *)

Delimit Scope cps_scope with cps.

(* [cpscall] is a marker to get Coq to print code using this notation only when it was actually used *)
Definition cpscall {R} (f:forall{T}(continuation:R->T),T) {T} (continuation:R->T)
:= @f T continuation.
Notation "x' <- v ; C" := (cpscall v%cps (fun x' => C%cps)) : cps_scope.

(** A value of type [~>R] accepts a continuation that takes an
     argument of type [R].  It is meant to be used in [Definition] and
     such; for example:
<<
     Definition add_cps (a b:nat) : ~> nat.
>>
     The return type of the continuation is not yet specified; every
     [~> R] is universally quantified over the possible return types
     of the continuations that it can be applied to.
 *)
Notation "~> R" := (forall T (_:R->T), T) : type_scope.

(** The type [A ~> R] contains functions that takes an argument of
  type [A] and pass a value of type [R] to the continuation. Functions
  that take multiple arguments can be encoded as [A -> B ~> C] or [A
  ~> B ~>C] -- the first form requires both arguments to be specified
  before its output can be CPS-bound, the latter must be bound once it
  is partially applied to one argument. *)
Notation "A ~> R" := (A -> ~>R) : type_scope.

(* [cpsreturn] is a marker to get Coq to print loop notations before a [return] *)
Definition cpsreturn {T} (x:T) := x.
(** [return x] passes [x] to the continuation implicit in the previous notations. *)
Notation "'return' x" := (cpsreturn (fun T (continuation:_->T) => continuation x)) : cps_scope.

Definition cpsbind {A B} (v:~> A) (f:A ~> B) : ~> B
  := fun T k => (a <- v; fa <- f a; k fa)%cps.
Notation "x' <--- v ; C" := (cpsbind v%cps (fun x' => C%cps)) : cps_scope.

Definition cps_option_bind {A B} (v:~> option A) (f:A ~> option B) : ~> option B
  := cpsbind v (fun x' T k => match x' with Some x' => f x' T k | None => k None end).
Notation "x' <-- v ; C" := (cps_option_bind v%cps (fun x' => C%cps)) : cps_scope.

Module CPSBindNotations.
  Notation "x' <- v ; C" := (cpsbind v%cps (fun x' => C%cps)) : cps_scope.
End CPSBindNotations.


From discprob.basic Require Import base sval order monad bigop_ext nify.
From discprob.idxval Require Import pival_dist pival extrema.
From discprob.prob Require Import prob countable finite stochastic_order.

Record pidist_couplingP {A1 A2} (Is1: pidist A1) (Is2: pidist A2) (P: A1 → A2 → Prop) : Type :=
  mkCoupling { pc_witness :> pidist {xy: A1 * A2 | P (fst xy) (snd xy)};
     pc_proj1: eq_pidist Is1 (x ← pc_witness; mret (fst (sval x)));
     pc_proj2: eq_pidist Is2 (x ← pc_witness; mret (snd (sval x)));
     }.
Require Import Reals Psatz Omega.

Definition lsupport {A1 A2 Is1 Is2 P} (Icouple: pidist_couplingP Is1 Is2 P) (y: A2) :=
  { x : A1 |  ∃ I Hpf i, pival.In I Icouple ∧ ival.ind I i = (exist _ (x, y) Hpf)
                         ∧ ival.val I i > 0 }.
Definition rsupport {A1 A2 Is1 Is2 P} (Icouple: pidist_couplingP Is1 Is2 P) (x: A1) :=
  { y : A2 |  ∃ I Hpf i, pival.In I Icouple ∧ ival.ind I i = (exist _ (x, y) Hpf)
                         ∧ ival.val I i > 0 }.

Lemma pidist_coupling_sym {A1 A2} (Is1: pidist A1) (Is2: pidist A2) P
      (Ic: pidist_couplingP Is1 Is2 P): pidist_couplingP Is2 Is1 (λ x y, P y x).
Proof.
  destruct Ic as [Ic Hp1 Hp2].
  unshelve (eexists).
  { refine (mbind _ Ic). intros ((x&y)&HP).
    refine (mret (exist _ (y, x) _)); auto. }
  * setoid_rewrite Hp2. setoid_rewrite pidist_assoc; apply pidist_bind_congr; first by reflexivity.
    intros ((x&y)&Hpf). setoid_rewrite pidist_left_id => //=. reflexivity.
  * setoid_rewrite Hp1. setoid_rewrite pidist_assoc; apply pidist_bind_congr; first by reflexivity.
    intros ((x&y)&Hpf). setoid_rewrite pidist_left_id => //=. reflexivity.
Qed.

Lemma pidist_coupling_eq {A} (Is1 Is2: pidist A)
      (Ic: pidist_couplingP Is1 Is2 (λ x y, x = y)): eq_pidist Is1 Is2.
Proof.
  destruct Ic as [Ic Hp1 Hp2].
  setoid_rewrite Hp1. setoid_rewrite Hp2.
  apply pidist_bind_congr; first by reflexivity.
  intros ((x&y)&Heq) => //=. rewrite //= in Heq; subst; reflexivity.
Qed.

Lemma pidist_coupling_ext {A B} (Is1 Is1': pidist A) (Is2 Is2': pidist B) (P P': A → B → Prop) :
  eq_pidist Is1 Is1' →
  eq_pidist Is2 Is2' →
  (∀ x y, P x y ↔ P' x y) →
  pidist_couplingP Is1 Is2 P →
  pidist_couplingP Is1' Is2' P'.
Proof.
  intros Heq1 Heq2 HP [pc_wit Hproj1 Hproj2].
  unshelve (econstructor).
  - refine (x ← pc_wit; mret (exist _ (proj1_sig x) _)).
    { destruct x as (?&?). eapply HP => //=. }
  - rewrite -Heq1 Hproj1. rewrite pidist_assoc.
    eapply pidist_bind_congr; first reflexivity.
    intros ((x&y)&HPxy). rewrite pidist_left_id => //=; reflexivity.
  - rewrite -Heq2 Hproj2. rewrite pidist_assoc.
    eapply pidist_bind_congr; first reflexivity.
    intros ((x&y)&HPxy). rewrite pidist_left_id => //=; reflexivity.
Qed.

Lemma pidist_coupling_eq_inv {A} (Is1 Is2: pidist A):
      eq_pidist Is1 Is2 →
      pidist_couplingP Is1 Is2 (λ x y, x = y).
Proof.
  intros Heq.
  unshelve (econstructor).
  - refine (x ← Is1; mret (exist _ (x, x) _)) => //=.
  - rewrite pidist_assoc. rewrite -[a in eq_pidist a _]pidist_right_id.
    eapply pidist_bind_congr; first reflexivity.
    intros a. rewrite pidist_left_id => //=.
    reflexivity.
  - rewrite Heq. rewrite pidist_assoc. rewrite -[a in eq_pidist a _]pidist_right_id.
    eapply pidist_bind_congr; first reflexivity.
    intros a. rewrite pidist_left_id => //=.
    reflexivity.
Qed.

Lemma pidist_coupling_Ex_min {A1 A2} f g (Is1 : pidist A1) (Is2: pidist A2)
      (Ic: pidist_couplingP Is1 Is2 (λ x y, f x ≤ g y)):
  ex_Ex_extrema f Is1 →
  Rbar_le (Ex_min f Is1) (Ex_min g Is2).
Proof.
  intros Hex.
  destruct Ic as [Ic Hp1 Hp2].
  setoid_rewrite Hp1. setoid_rewrite Hp2.
  apply Ex_min_bind_le.
  *  rewrite /mbind/base.mbind in Hp1 *. rewrite -Hp1 //.
  * intros (?&?). rewrite ?Ex_min_mret => //=.
Qed.

Lemma pidist_coupling_Ex_max {A1 A2} f g (Is1 : pidist A1) (Is2: pidist A2)
      (Ic: pidist_couplingP Is1 Is2 (λ x y, f x ≤ g y)):
  ex_Ex_extrema g Is2 →
  Rbar_le (Ex_max f Is1) (Ex_max g Is2).
Proof.
  intros Hex.
  destruct Ic as [Ic Hp1 Hp2].
  setoid_rewrite Hp1. setoid_rewrite Hp2.
  apply Ex_max_bind_le.
  *  rewrite /mbind/base.mbind in Hp2 *. rewrite -Hp2 //.
  * intros (?&?). rewrite ?Ex_max_mret => //=.
Qed.

Lemma pidist_coupling_bind {A1 A2 B1 B2} (f1: A1 → pidist B1) (f2: A2 → pidist B2)
      Is1 Is2 P Q (Ic: pidist_couplingP Is1 Is2 P):
  (∀ x y, P x y → pidist_couplingP (f1 x) (f2 y) Q) →
  pidist_couplingP (mbind f1 Is1) (mbind f2 Is2) Q.
Proof.
  intros Hfc.
  destruct Ic as [Ic Hp1 Hp2].
  unshelve (eexists).
  { refine (xy ← Ic; _). destruct xy as ((x&y)&HP).
    exact (Hfc _ _ HP).
  }
  - setoid_rewrite Hp1; setoid_rewrite pidist_assoc;
      apply pidist_bind_congr; first by reflexivity.
    intros ((x&y)&HP). setoid_rewrite pidist_left_id => //=.
    destruct (Hfc x y); auto.
  - setoid_rewrite Hp2; setoid_rewrite pidist_assoc;
      apply pidist_bind_congr; first by reflexivity.
    intros ((x&y)&HP). setoid_rewrite pidist_left_id => //=.
    destruct (Hfc x y); auto.
Qed.

Lemma pidist_coupling_mret {A1 A2} x y (P: A1 → A2 → Prop):
  P x y →
  pidist_couplingP (mret x) (mret y) P.
Proof.
  intros HP. exists (mret (exist _ (x, y) HP)); setoid_rewrite pidist_left_id => //=; reflexivity.
Qed.

Lemma pidist_coupling_plus {A1 A2} p Hpf Is1 Is2 Is1' Is2' (P: A1 → A2 → Prop):
  pidist_couplingP Is1 Is2 P →
  pidist_couplingP Is1' Is2' P →
  pidist_couplingP (pidist_plus p Hpf Is1 Is1') (pidist_plus p Hpf Is2 Is2') P.
Proof.
  intros [Ic Hproj1 Hproj2].
  intros [Ic' Hproj1' Hproj2'].
  exists (pidist_plus p Hpf Ic Ic').
  - setoid_rewrite Hproj1. setoid_rewrite Hproj1'.
    symmetry; apply pidist_plus_bind.
  - setoid_rewrite Hproj2. setoid_rewrite Hproj2'.
    symmetry; apply pidist_plus_bind.
Qed.

Lemma pidist_coupling_union {A1 A2} Is1 Is2 Is1' Is2' (P: A1 → A2 → Prop):
  pidist_couplingP Is1 Is2 P →
  pidist_couplingP Is1' Is2' P →
  pidist_couplingP (pidist_union Is1 Is1') (pidist_union Is2 Is2') P.
Proof.
  intros [Ic Hproj1 Hproj2].
  intros [Ic' Hproj1' Hproj2'].
  exists (pidist_union Ic Ic').
  - setoid_rewrite Hproj1. setoid_rewrite Hproj1'.
    symmetry; apply pidist_union_bind.
  - setoid_rewrite Hproj2. setoid_rewrite Hproj2'.
    symmetry; apply pidist_union_bind.
Qed.

Lemma pidist_coupling_join {Idx1} {A1 A2} (i1: Idx1)
      (Iss1: Idx1 → pidist A1) (Is2: pidist A2) (P: A1 → A2 → Prop):
  (∀ i1', pidist_couplingP (Iss1 i1') Is2 P) →
  pidist_couplingP (pidist_join i1 Iss1) Is2 P.
Proof.
  intros Ics.
  exists (pidist_join i1 (λ i, Ics i)).
  - setoid_rewrite pidist_join_bind. split.
    * intros I (i&Hin).
      destruct (Ics i) as [Ic Hproj1 Hproj2] eqn:Heqi.
      destruct Hproj1 as (Hle1a&Hle1b).
      destruct (Hle1a _ Hin) as (I'&Heq'&Hin').
      exists I'. split; auto.
      exists i; eauto. rewrite Heqi => //=.
    * intros I (i&Hin).
      destruct (Ics i) as [Ic Hproj1 Hproj2] eqn:Heqi.
      destruct Hproj1 as (Hle1a&Hle1b).
      destruct (Hle1b _ Hin) as (I'&Heq'&Hin').
      exists I'. split; auto.
      exists i; eauto.
  - setoid_rewrite pidist_join_bind. split.
    * intros I Hin.
      destruct (Ics i1) as [Ic Hproj1 Hproj2] eqn:Heqi.
      destruct Hproj2 as (Hle1a&Hle1b).
      destruct (Hle1a _ Hin) as (I'&Heq'&Hin').
      exists I'. split; auto.
      exists i1; eauto. rewrite Heqi => //=.
    * intros I (i&Hin).
      destruct (Ics i) as [Ic Hproj1 Hproj2] eqn:Heqi.
      destruct Hproj2 as (Hle1a&Hle1b).
      destruct (Hle1b _ Hin) as (I'&Heq'&Hin').
      exists I'. split; auto.
Qed.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.
Require Export Category.Structure.Cocartesian.
Require Export Category.Construction.Coproduct.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.

Program Instance CoproductFunctor `(C : Category) `{@Cocartesian C} :
  C ∐ C ⟶ C := {
  fobj := fun p => sum_rect (λ _, C) (λ a, a) (λ b, b) p;
  fmap := fun x y p =>
            match x with
            | Datatypes.inl x =>
              match y with
              | Datatypes.inl y => _
              | Datatypes.inr _ => False_rect _ _
              end
            | Datatypes.inr x =>
              match y with
              | Datatypes.inl _ => False_rect _ _
              | Datatypes.inr y => _
              end
            end;
}.
Next Obligation. proper; destruct x, y; simpl; tauto. Qed.
Next Obligation. destruct x; simpl; reflexivity. Qed.
Next Obligation. destruct x, y, z; simpl; cat; tauto. Qed.


(* Celsius project *)
(* Clément Blaudeau - Lamp@EPFL 2021 *)
(* ------------------------------------------------------------------------ *)
(* This file defines the main result of local reasoning, built upon partial monotonicity,
 stackability and scopability. In a wellformed, fully initialized context, a newly created object
 can only access hot (transitively fully initialized) locations. *)

From Celsius Require Export Scopability Stackability MetaTheory.
Implicit Type (σ: Store) (ρ ω: Env) (l: Loc) (L: LocSet) (Σ: StoreTyping).

(* ------------------------------------------------------------------------ *)
(** ** Local Reasoning theorem *)
(** We start with a lemma : *)

Lemma hot_preservation:
  forall σ σ' L L',
    (* Side conditions *)
    L ⪽ σ ->
    L' ⪽ σ' ->
    wf σ' ->

    (* Scopability, stackability, monotonicity *)
    (σ, L) ⋖ (σ', L') ->
    σ ≪ σ' ->
    σ ⪯ σ' ->

    (* Preservation of hot locations *)
    σ  ⊨ L  : hot ->
    σ' ⊨ L' : hot.

Proof with (eauto with rch).
  intros. intros l' H__l'.
  apply sm_hot => l H__rch.
  assert (dom σ <= dom σ') by eauto with pM.
  assert (l < dom σ \/ l >= dom σ) as [|] by lia.

  + (* l ∈ (dom σ) : the object was already in the store *)
    eapply pM_wf_warm_monotone...
    assert (σ ⊨ L ⇝ l).
    * eapply H2...
      eexists...
    * rch_set.
      lets: H5 H__ln.
      inverts H9...
      apply H10...

  + (* l ∉ (dom σ) *)
    destruct (H3 l); eauto with lia rch.
Qed.

(* Then the main theorem : *)
Theorem local_reasoning:
  forall e σ ρ ψ v σ',
    ⟦e⟧(σ, ρ, ψ) --> (v, σ') ->
    wf σ ->
    (codom ρ ∪ {ψ}) ⪽ σ ->
    σ  ⊨ ((codom ρ) ∪ {ψ}) : hot ->
    σ' ⊨ v : hot.
Proof.
  intros.
  assert (σ' ⊨ (Singleton Loc v) : hot).
  + eapply hot_preservation;
      eauto using stk_theorem with pM stk wf lia.
    eapply scp_theorem_expr; eauto with pM wf lia; steps.
  + eapply H3; eauto using In_singleton.
Qed.

(* ------------------------------------------------------------------------ *)
(** ** Local Reasoning for typing *)
(* We show here that we can upgrade the whole transitive closure to hot while preserving typing
properties (monotonicity, authority, stackability) *)

(* This axiom could be removed, as Reachability is decidable *)
Axiom classicT : forall (P : Prop), {P} + {~ P}.

Theorem Local_reasoning_for_typing: forall Σ1 Σ2 σ1 σ2 L1 L2,
    L1 ⪽ σ1 -> L2 ⪽ σ2 ->
    (σ1, L1) ⋖ (σ2, L2) ->
    (Σ1 ≪ Σ2) ->
    (Σ1 ▷ Σ2) ->
    (Σ1 ≼ Σ2) ->
    (Σ1 ⊨ σ1) -> (Σ2 ⊨ σ2) ->
    (Σ1 ⊨ L1 : hot) ->
    wf σ1 -> wf σ2 ->
    exists Σ', (Σ2 ≪ Σ') /\
            (Σ2 ≼ Σ') /\
            (Σ2 ▷ Σ') /\
            (Σ' ⊨ σ2) /\
            (Σ' ⊨ L2 : hot).
Proof with (meta; eauto 3 with typ lia).

  Ltac getType_combine :=
    lazymatch goal with
    | H1: getType ?Σ ?l = Some ?T, H__st: ?Σ ⊨ ?σ
      |- context [getType (map ?f (combine (seq 0 (dom _)) ?Σ)) ?l ] =>
        try rewrite (proj1 H__st) ;
        rewrite /getType nth_error_map;
        rewrite (nth_error_nth' _  (0,(Entry,cold)));
        [rewrite combine_length seq_length PeanoNat.Nat.min_id ; auto |];
        rewrite ?combine_nth ?seq_nth ?seq_length; eauto with updates; simpl;
        rewrite (nth_error_nth _ _ _ H1)
    end.

  intros.
  remember ((fun l' '(C,μ) => if (classicT (σ2 ⊨ L2 ⇝ l'))
                           then (C, hot)
                           else (C, μ)):Loc -> Tpe -> Tpe) as f.
  remember (map (fun '(l, T) => f l T) (combine (seq 0 (dom Σ2)) Σ2)) as Σ2'.
  exists Σ2'.
  assert ( Σ2 ≪ Σ2' /\
             Σ2 ≼ Σ2' /\
             (Σ2 ≪ Σ2' -> Σ2 ▷ Σ2') /\
             (Σ2 ≪ Σ2' -> Σ2 ≼ Σ2' -> Σ2' ⊨ σ2) /\ Σ2' ⊨ L2 : hot);
    [| steps; eauto with typ].
  splits; subst.

  - (* ≪ *)
    intros l H__l.
    rewrite map_length combine_length seq_length Nat.min_id in H__l...

  - (* ≼ *)
    intros l H__l.
    lets [[C μ] ?]: getType_Some H__l.
    exists (C, μ). exists (if is_left (classicT (σ2 ⊨ L2 ⇝ l)) then (C, hot) else (C, μ)); splits; [| | steps]...
    getType_combine; steps...

  - (* ▷ *)
    intros H__stk l H__l Ω H__getType.
    getType_combine;
      destruct (classicT (σ2 ⊨ L2 ⇝ l)); steps.
    lets[|]: H2 l... inverts H14.
    apply H1 in d...
    lets: hot_transitivity_set d...
    lets (?T & ?T & ? & ? & ?): H4 l...
    congruence.

  - (* ⊨ *)
    intros H__stk H__mn.
    split; rewrite map_length combine_length seq_length Nat.min_id...
    intros l H__l.
    lets (C & ω & μ & ? & ? & ?): (proj2 H6) l...
    exists C, ω, (if is_left (classicT (σ2 ⊨ L2 ⇝ l)) then hot else μ); splits...
    getType_combine; steps.
    destruct (classicT (σ2 ⊨ L2 ⇝ l)); steps...
    destruct (ct C) as [Args Flds Mtds] eqn:?.
    eapply ot_hot...
    intros.
    lets: getObj_dom H10.
    lets [|]: H2 l...
    + inverts H15.
      * inverts H12...
        lets (v & D & μ & ? & ? & ?): H19 H13.
        exists v, D, μ; splits... exists (D, hot)...
        getType_combine.
        destruct (classicT (σ2 ⊨ L2 ⇝ v)); steps...
        exfalso; apply n. rch_set.
        exists l0; split; eauto with rch...
      * inverts H12...
        lets (v & D & μ & ? & ? & ?): H19 H13.
        exists v, D, μ; splits... exists (D, hot)...
        getType_combine.
        destruct (classicT (σ2 ⊨ L2 ⇝ v)); steps...
    + lets: H1 d... clear d.
      lets: hot_transitivity_set H16...
      lets [?T1 [?T2 (? & ? & ?)]]: H4 l...
      lets (?C & ?ω & ?μ & ? & ? & ?): (proj2 H6) l...
      inverts H21.
      lets (v & D & μ & ? & ? & ?): H24 f...
      exists v, D, μ; splits... exists (D, hot)...
      getType_combine.
      destruct (classicT (σ2 ⊨ L2 ⇝ v)); steps...

  - (* ⊨ L' : hot *)
    intros l H__l.
    lets []: getType_Some Σ2 l...
    exists C. exists (C, hot)...
    getType_combine.
    destruct (classicT (σ2 ⊨ L2 ⇝ l)); steps...
    exfalso. apply n. exists l; split; eauto with rch.

Qed.


Require Import Omega.
Require Import RRR.Lang.Lang.
Require Import RRR.Lebesgue.Lebesgue.
Require Import RRR.Rel.Relations.
Require Import Lra.

Lemma adequacy e₁ e₂ :
ERel_open ∅→ ℝ e₁ e₂ →
∀ N₁, ORel N₁ e₁ e₂.
Proof.
intros [[_ _] He].
intros N₁.
assert (N₁ <= N₁) as le_N₁_refl ; [ omega | ].
assert (EnvRel ∅→ N₁ ∅→ ∅→) as Hempty.
1:{ intro x ; destruct x. }
specialize (He N₁ ∅→ ∅→ Hempty).
repeat (erewrite V_bind_exp_id in He ; [ | intro x; destruct x ]).
specialize (He N₁ le_N₁_refl ktx_hole ktx_hole).
assert (KRel ℝ N₁ ktx_hole ktx_hole) as Hhole.
1:{
  clear.
  intros N₁' HN₁' v₁ v₂ Hv. destruct Hv as [r [? ?]].
  subst. simpl. split.
  - rewrite μNS_val. apply μNS_inf_le_1.
  - intro. rewrite μTV_val.
    unfold μTV_sup. erewrite sup_of_constant.
    2:{ intro. rewrite μTV_val. reflexivity. }
    apply ennr_le_refl.
}
apply He. apply Hhole.
Qed.


Require Import Ssreflect.ssreflect Ssreflect.ssrbool Ssreflect.ssrnat.
Require Import Ssreflect.eqtype Ssreflect.ssrfun Ssreflect.seq.
Require Import MathComp.path.
Require Import Eqdep pred prelude idynamic ordtype pcm finmap unionmap heap coding.
Require Import hgraphs.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Implementation of the mutator/collector logs and their execution *)
Section GCLog.

Inductive ActionKind : Set := T | M | A of nat.

Definition eq_kind k1 k2 := match (k1, k2) with
  | (T, T) => true
  | (M, M) => true
  | (A x, A y) => x == y
  | _ => false
  end.

Lemma eqkP : Equality.axiom eq_kind.
Proof.
do [case]; do?[constructor]=>//; do ?[by case; constructor].
move=>n; case; do?[constructor]=>//; rewrite /eq_kind.
move=>m; case X: (n == m).
by move/eqP: X=>X; subst m; constructor.
by constructor; case=>Z; subst m; move/eqP: X.
Qed.

Canonical kind_eqMixin := EqMixin eqkP.
Canonical kind_eqType := Eval hnf in EqType ActionKind kind_eqMixin.

Definition kindMA k := match k with
  | M   => true
  | A _ => true
  | _   => false
  end.

Record LogEntry : Set := Entry {
  kind    : ActionKind;
  source  : ptr;
  fld     : nat;
  old     : ptr;
  new     : ptr }.

Definition eq_entry e1 e2 :=
  [&& (kind e1 == kind e2), (source e1 == source e2),
      (fld e1 == fld e2)  , (old e1 == old e2) & (new e1 == new e2)].

(* Well, this is super-boring. Can it be automated a la Haskell? *)
Lemma eqeP: Equality.axiom eq_entry.
Proof.
move=>e1 e2; rewrite /eq_entry.
case: e1; case: e2=>//==> k1 s1 f1 o1 n1 k2 s2 f2 o2 n2.
case X:(k2 == k1)=>/=; last by constructor; move/eqP:X=>X H; apply: X; case: H.
case Y:(s2 == s1)=>/=; last by constructor; move/eqP:Y=>Y H; apply: Y; case: H.
case Z:(f2 == f1)=>/=; last by constructor; move/eqP:Z=>Z H; apply: Z; case: H.
case U:(o2 == o1)=>/=; last by constructor; move/eqP:U=>U H; apply: U; case: H.
case V:(n2 == n1)=>/=; last by constructor; move/eqP:V=>V H; apply: V; case: H.
by constructor; move: X Y Z U V; do![move/eqP=>->].
Qed.

Canonical entry_eqMixin := EqMixin eqeP.
Canonical entry_eqType := Eval hnf in EqType LogEntry entry_eqMixin.

Definition log := seq LogEntry.

(* A set of pointers *)
Definition ptr_set := ptrmap_pcm_Encoded unit_st_Encoded.

End GCLog.

Section ExecuteLogs.

(*

It reflect boolean condition into a certificate of type P via the
function g, and then uses the obtained certificate in the continuation
f. If the boolean check is failed, the result is undefined, hence both
the condK combinator and its argument f have the result type option.

*)
Definition condK P R (c : bool)
  (g : is_true c -> P) (f : P -> option R) :=
  (if c as z return _ = z -> _
   then fun (efl : c = true) => f (g efl)
   else fun _ => None) (erefl _).

Lemma condKE P R (c : bool) (g : is_true c -> P) (f : P -> option R) :
  c -> {pf | condK g f = f pf}.
Proof.
rewrite /condK=>X.
by suff Z: c = true=>//; subst c; apply: exist.
Qed.

Lemma condK_true P R (c : bool) (g : is_true c -> P) (f : P -> option R) z :
  condK g f = Some z -> c.
Proof.
rewrite /condK; case Z: (c == true); first by move/eqP: Z=>Z; subst c.
move/negbT: Z=>Z; have X: c = false by clear g; case: c Z.
by subst c.
Qed.

(*

The following function executeLog is partial and certified:

- If it returns None, then something must have gone wrong, because the
  log was malformed.

- If the result is Some (h, g), then h is the resulting heap and g is
  its new graph certificate, which is threaded through the execution.

*)

Record ExecuteResult := ExRes {hp : heap; gp : graph hp}.

Fixpoint executeLog (h : heap) (g : graph h) (l : log) :
    option ExecuteResult := match l with

  (* Empty log - return heap and its graph certificate *)
  | [::] => Some (ExRes g)

  (* Check for allocation with new graph certificate *)
  | (Entry (A fnum) x fld old y) :: ls =>
      condK (@allocG h g y fnum x fld old y) (fun g' => executeLog g' ls)

  (* Check for modification with new graph certificate *)
  | (Entry M x fld old new) :: ls =>
      condK (@modifyG h g x fld old new) (fun g' => executeLog g' ls)

  (* Tracing entry - do nothing, but enforce "sanity requirements" *)
  | (Entry T x fld old new) :: ls =>
      condK (@traceG h g x fld old new) (fun _ => executeLog g ls)
  end.

Lemma takeSn A n (a : A) l : take n.+1 (a :: l) = a :: (take n  l).
Proof. by []. Qed.

(* We can combing good logs transitively *)
Lemma replayLogCons h0 (g0: graph h0) x l h1 g1 h g:
    executeLog g0 [:: x] = Some {| hp := h1; gp := g1 |}
 -> executeLog g1 l = Some {| hp := h; gp := g |}
 -> executeLog g0 (x::l) = Some {| hp := h; gp := g |}.
Proof.
case: x=>k s f o nw; case: k=>/=[||n]; move=>E; move:(condK_true E)=> C H1.
- case: (condKE (traceG (new:=nw))
        (fun _ : trace g0 s f = h0 => Some {| hp := h0; gp := g0 |}) C)=>? E2.
  rewrite E2 in E; case: E=>Z; subst h1.
  have Eg: g0 = g1 by apply: (proof_irrelevance g0 g1). subst g1.
  by case: (condKE (traceG (new:=nw)) (fun _ => executeLog g0 l) C); rewrite H1.
- case: (condKE (modifyG g0 f (new:=nw))
        (fun pf => Some {| hp := (modify g0 s f nw); gp := pf |}) C)=>/=pg E2.
  rewrite E2 in E=>{E2}; case: pg E=>g' pg; case=>Z; subst h1; clear g'.
  case: (condKE (modifyG g0 f (new:=nw)) (fun pf => executeLog pf l) C)=>g'->.
  by rewrite -(proof_irrelevance g1 g') H1.
case: (condKE (allocG g0 n f (new:=nw))
        (fun pf => Some {| hp := alloc g0 nw n s f; gp := pf |}) C)=>/=pg E2.
rewrite E2 in E=>{E2}; case: pg E=>g' pg; case=>Z; subst h1; clear g'.
case: (condKE (allocG g0 n f (new:=nw))
      ((executeLog (h:=alloc g0 nw n s f))^~ l) C)=>g'->.
by rewrite -(proof_irrelevance g1 g') H1.
Qed.

(* By the way, the proofs are remarkably robust: almost nothing had to
be changed after refactoring of alloc! *)

(* We can reconstruct the intermediate graph for the cons *)
Lemma replayLogCons2 h0 (g0: graph h0) x l er :
  executeLog g0 (x :: l) = Some er ->
  {er | let: (er1, er2) := er in
        executeLog g0 [:: x] = Some er1 /\
        executeLog (gp er1) l = Some er2 }.
Proof.
case:er=>h g; case: x=>k s f o nw; case: k=>[||n];
move=>/=E; move:(condK_true E)=> C.
- apply: (exist _ (ExRes g0, ExRes g)); split=>//=.
  + by case: (condKE (traceG (new:=nw))
        (fun _ : trace g0 s f = h0 => Some {| hp := h0; gp := g0 |}) C).
  by case: (condKE (traceG (new:=nw))
           (fun _ : trace g0 s f = h0 => executeLog g0 l) C)=>_<-.
- case: (condKE (modifyG g0 f (new:=nw))
        (fun g' : _ => Some {| hp := modify g0 s f nw; gp := g' |}) C)=>g1 E2.
  apply: (exist _ (ExRes g1, ExRes g)); split=>//=.
  case: (condKE (modifyG g0 f (new:=nw))
        ((executeLog (h:=modify g0 s f nw))^~ l) C)=>g2 E3.
  by move: (proof_irrelevance g1 g2)=>Z; subst g2; rewrite -E3.
case: (condKE (allocG g0 n f (new:=nw))
       (fun g' : _ => Some {| hp := alloc g0 nw n s f; gp := g' |}) C)=>g1 E2.
apply: (exist _ (ExRes g1, ExRes g)); split=>//=.
case: (condKE (allocG g0 n f (new:=nw))
      ((executeLog (h:=alloc g0 nw n s f))^~ l) C)=>g2 E3.
by move: (proof_irrelevance g1 g2)=>Z; subst g2; rewrite -E3.
Qed.

(* [REM] All this business with inversion on the results via condKE
and condK_true should be automated somehow. What is the general
pattern? *)

Lemma replayLogRcons h0 (g0: graph h0) l e:
  {er | executeLog g0 (rcons l e) = Some er} ->
  {er | executeLog g0 l = Some er}.
Proof.
elim: l e h0 g0=>[e h0 g0|x l Hi e h0 g0 H]; last first.
- rewrite rcons_cons in H.
  case: H=>er /replayLogCons2[[er1 er2]][H1]H2.
  have X: {er : ExecuteResult | executeLog (gp er1) (rcons l e) = Some er}.
  - by apply: (exist _ er2).
  move: (Hi e _ (gp er1) X)=>{X}[]=>er3 H3.
  case: er1 H1 H2 H3=>h1 g1 H1; case: er3=>h2 g2 H2 H3; simpl in H2, H3.
  by move: (replayLogCons H1 H3)=>H4; apply: (exist _ (ExRes g2)).

(* Base case is the interesting one *)
case=>[[h g]]/=; case: e=>k s f o nw; case: k=>[||n];
move=>E; move:(condK_true E)=> C.
- case: (condKE (traceG (new:=nw))
        (fun _ : trace g0 s f = h0 => Some {| hp := h0; gp := g0 |}) C)=>? E2.
  by rewrite E2 in E; apply: (exist _ (ExRes g)).
- case: (condKE (modifyG g0 f (new:=nw))
        (fun pf => Some {| hp := _; gp := pf |}) C)=>[pg E2].
  by rewrite E2 in E; apply: (exist _ (ExRes g0)).
case: (condKE (allocG g0 n f (new:=nw))
      (fun g'=> Some {| hp := _; gp := g' |}) C)=>g' E2.
by rewrite E2 in E; apply: (exist _ (ExRes g0)).
Qed.

(* (* T-entries do not affect the execution *) *)
(* Lemma replayLogRconsT h0 (g0 : graph h0) l e h g h' g' :  *)
(*   executeLog g0 l = Some {| hp := h'; gp := g' |} -> *)
(*   executeLog g0 (rcons l e) = Some {| hp := h; gp := g |} -> *)
(*   kind e == T -> *)
(*   h = h' /\ nth null (fields g (source e)) (fld e) = (new e). *)
(* Proof. *)
(* case: e=>k s f o nw; case: k=>//=H1 H2 _. rewrite -cats1 in H2. *)
(* Search _ (rcons). *)

Lemma replayLogCat h0 (g0: graph h0) l1 l2 h g:
  executeLog g0 (l1 ++ l2) = Some (@ExRes h g) ->
  {er | executeLog g0 l1 = Some er}.
Proof.
elim/last_ind: l2 h g=>[h g|l2 e Hi h g H].
- by rewrite cats0; apply: (exist _ (ExRes g)).
rewrite -rcons_cat in H.
have X: {er | executeLog g0 (rcons (l1 ++ l2) e) = Some er}.
- by apply: (exist _ (ExRes g)).
by case/replayLogRcons: X=>[[h1 g1]]/Hi.
Qed.

(*******************************************************************************)
(* [Replaying logs]: the following certified definition is very
important, as it states that if a log (l) managed to deliver a graph
successfully, we can reconstruct heaps and graphs for *all* its
intermediate stages, expressed as (take n l).  *)
(*******************************************************************************)

Lemma replayLogLm h0 (g0: graph h0) l er:
  executeLog g0 l = Some er ->
  forall n, {er | executeLog g0 (take n l) = Some er}.
Proof.
move=>H n; case Y : (n < size l); last first.
- rewrite ltnNge in Y; move/negbFE: Y=>/take_oversize=>->.
  by apply: (exist _ er).
rewrite -[l](cat_take_drop n) in H.
by case:er H=>h g /replayLogCat.
Qed.

(* The following is a certified function extracting an intermediate result *)
Definition replayLog h0 (g0: graph h0) l er
    (pf : executeLog g0 l = Some er) (n : nat) : ExecuteResult :=
  match replayLogLm pf n with exist er _ => er end.

Theorem replayLogReplays h0 (g0: graph h0) l er
    (pf : executeLog g0 l = Some er) (n : nat) :
  executeLog g0 (take n l) = Some (replayLog pf n).
Proof. by rewrite /replayLog; case: (replayLogLm pf n). Qed.

End ExecuteLogs.

Section Wavefronts.

(* Definition of a wavefront *)
Definition wavefront (p : log) :=
  [seq (source pi, fld pi) | pi <- p & kind pi == T].

End Wavefronts.


Require Import Examples.AutoSep.

Inductive request :=
| Echo (_ : W)
| Add (_ _ : W).

Definition encode (req : request) : list W :=
  match req with
    | Echo w => $0 :: w :: nil
    | Add w1 w2 => $1 :: w1 :: w2 :: nil
  end.

Definition reply (req : request) : W :=
  match req with
    | Echo w => w
    | Add w1 w2 => w1 ^+ w2
  end.

Definition mainS := SPEC("req", "len") reserving 3
  Al req,
  PRE[V] [| V "len" = length (encode req) |] * array (encode req) (V "req")
  POST[R] [| R = reply req |] * array (encode req) (V "req").

Definition m := bmodule "m" {{
  bfunction "main"("req", "len", "pos", "x", "y") [mainS]
    "pos" <- 0;;
    Match "req" Size "len" Position "pos" {
      Case (0 ++ "x")
        Return "x"
      end;;
      Case (1 ++ "x" ++ "y")
        Return "x" + "y"
      end
    } Default {
      Fail
    }
  end
}}.

Ltac encode_case :=
  match goal with
    | [ H : context[match encode ?E with nil => _ | _ => _ end] |- _ ] =>
      destruct E; simpl in *; intuition (try discriminate)
  end.

Theorem mOk : moduleOk m.
  vcgen; abstract (parse0; post; evaluate auto_ext;
    repeat (parse1 auto; try encode_case; reveal_slots; evaluate auto_ext); sep_auto; parse2).
Qed.


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

(*****************************************************************************)
(*          Projet Formel - Calculus of Inductive Constructions V5.10        *)
(*****************************************************************************)
(*									     *)
(*	                CoUniversal Arrows               		     *)
(*									     *)
(*****************************************************************************)
(*									     *)
(*                            A.SAIBI   May 95				     *)
(*									     *)
(*****************************************************************************)

Require Export UniversalArrow.
Require Export Dual_Functor.

Set Implicit Arguments.
Unset Strict Implicit.

(* coUA *)

Section coua_def.

Variables (A B : Category) (b : B) (F : Functor A B).

 Section iscoua_def.

 Variables (a : A) (u : F a --> b).

  Section coua_laws.

  Variable co_diese : forall a' : A, (F a' --> b) -> (a' --> a).

  Definition CoUA_eq (a' : A) (f : F a' --> b) (g : a' --> a) :=
    FMor F g o u =_S f.

  Definition CoUA_law1 :=
    forall (a' : A) (f : F a' --> b), CoUA_eq f (co_diese f).

  Definition CoUA_law2 :=
    forall (a' : A) (f : F a' --> b) (g : a' --> a),
    CoUA_eq f g -> g =_S co_diese f.

  End coua_laws.

 Structure IsCoUA : Type :=
   {CoUA_diese : forall a' : A, (F a' --> b) -> (a' --> a);
    Prf_isCoUA_law1 : CoUA_law1 CoUA_diese;
    Prf_isCoUA_law2 : CoUA_law2 CoUA_diese}.

 Variable t : IsCoUA.

 (* f=g => f# = g# *)

 Lemma Codiese_map : forall a' : A, Map_law (CoUA_diese t (a':=a')).
 Proof.
 intros a'.
 unfold Map_law in |- *; intros f g H.
 apply (Prf_isCoUA_law2 t (f:=g) (g:=CoUA_diese t f)).
 unfold CoUA_eq in |- *.
 (* *) apply Trans with f.
 apply (Prf_isCoUA_law1 t f).
 assumption.
 Qed.

 End iscoua_def.

Structure > CoUA : Type :=
  {CoUA_ob : A; CoUA_mor : F CoUA_ob --> b; Prf_IsCoUA :> IsCoUA CoUA_mor}.

(*** rewrite rules ***)

Lemma CoUA_diag :
 forall (u : CoUA) (a' : A) (f : F a' --> b),
 FMor F (CoUA_diese u f) o CoUA_mor u =_S f.
Proof.
intros u a' f; exact (Prf_isCoUA_law1 (u:=CoUA_mor u) u f).
Qed.

Lemma CoUA_diag1 :
 forall (u : CoUA) (a' : A) (f : F a' --> b),
 f =_S FMor F (CoUA_diese u f) o CoUA_mor u.
Proof.
intros u a' f; apply Sym; apply CoUA_diag.
Qed.

Lemma CoUA_unic :
 forall (u : CoUA) (a' : A) (f : F a' --> b) (g : a' --> CoUA_ob u),
 FMor F g o CoUA_mor u =_S f -> g =_S CoUA_diese u f.
Proof.
intros u a' f g; exact (Prf_isCoUA_law2 u (f:=f) (g:=g)).
Qed.

Lemma CoUA_unic1 :
 forall (u : CoUA) (a' : A) (f : F a' --> b) (g : a' --> CoUA_ob u),
 FMor F g o CoUA_mor u =_S f -> CoUA_diese u f =_S g.
Proof.
intros u a' f g H; apply Sym; apply CoUA_unic; exact H.
Qed.

(* *)

End coua_def.

(* 2nd def : par dualite' *)

Section coua_def1.

Variables (A B : Category) (b : B) (F : Functor A B).

 Section iscoua_def1.

 Variables (a : A) (u : F a --> b).

 Definition IsCoUA1 := IsUA (G:=Dfunctor F) u.

 Variable u1 : IsCoUA1.

 Definition CoUA1_diese (a' : A) (f : F a' --> b) := UA_diese u1 f.

 Lemma Prf_isCoUA1_law1 : CoUA_law1 u CoUA1_diese.
 Proof.
 unfold CoUA_law1, CoUA_eq in |- *; intros a' f.
 unfold CoUA1_diese in |- *.
 exact (Prf_isUA_law1 u1 f).
 Qed.

 Lemma Prf_isCoUA1_law2 : CoUA_law2 u CoUA1_diese.
 Proof.
 unfold CoUA_law2, CoUA_eq in |- *; intros a' f g H.
 unfold CoUA1_diese in |- *.
 apply (Prf_isUA_law2 u1 H).
 Qed.

 Lemma IsCoUA1_to_IsCoUA : IsCoUA u.
 Proof.
 exact (Build_IsCoUA Prf_isCoUA1_law1 Prf_isCoUA1_law2).
 Defined.

 End iscoua_def1.

Coercion IsCoUA1_to_IsCoUA : IsCoUA1 >-> IsCoUA.

Definition CoUA1 := UA (b:Ob (Dual B)) (Dfunctor F).

Variable u1 : CoUA1.

Definition CoUA1_to_CoUA := Build_CoUA (IsCoUA1_to_IsCoUA (Prf_IsUA u1)).

End coua_def1.

Coercion CoUA1_to_CoUA : CoUA1 >-> CoUA.