(* ** Indirect reduction from ZF to finite set theory without Skolem functions *)

Require Import Undecidability.FOL.Syntax.Facts.
Require Import Undecidability.FOL.Semantics.Tarski.FullFacts.
Require Import Undecidability.FOL.Semantics.Tarski.FullSoundness.
Require Import Undecidability.FOL.Deduction.FullNDFacts.
Require Import Undecidability.FOL.Reductions.PCPb_to_binZF.
Require Import Undecidability.FOL.ZF.
Require Import Undecidability.FOL.FST.
From Undecidability.FOL.Sets Require Import  Models.FST_model Models.ZF_model binFST binZF.
Require Import Lia.

From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations ListAutomationHints ListAutomationInstances.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Local Hint Constructors prv : core.

Definition ZF_to_FST phi :=
  ax_pair' → ax_union' → ax_power' → ax_om' → phi.
Close Scope syn.

Lemma bZF_elem { p : peirce } T x x' y y' :
  binZF <<= T -> T ⊢ x ≡' x' -> T ⊢ y ≡' y' -> T ⊢ x ∈' y -> T ⊢ x' ∈' y'.
Proof.
  intros H1 H2 H3 H4. eapply IE; try apply H4.
  eapply IE; try apply H3. eapply IE; try apply H2.
  assert (H : T ⊢ ax_eq_elem') by (apply Ctx; firstorder).
  apply (AllE x), (AllE y), (AllE x'), (AllE y') in H; cbn in H.
  unfold eq' in H. cbn in H. subsimpl_in H. apply H.
Qed.

Lemma bZF_refl { p : peirce } T x :
  binZF <<= T -> T ⊢ x ≡' x.
Proof.
  intros H. prv_all' y. apply CI; apply II; auto.
Qed.

Ltac assert5 H :=
  match goal with |- (?g :: ?f :: ?phi :: ?psi :: ?theta :: ?T) ⊢ _
                  => assert (H : (g :: f :: phi :: psi :: theta :: T) ⊢ theta) by auto 7 end.

Ltac assert6 H :=
  match goal with |- (?h :: ?g :: ?f :: ?phi :: ?psi :: ?theta :: ?T) ⊢ _
                  => assert (H : (h :: g :: f :: phi :: psi :: theta :: T) ⊢ theta) by auto 7 end.

Lemma bZF_adj { p : peirce } :
  binZF ⊢ ax_adj'.
Proof.
  prv_all' x. prv_all' y.
  assert (H : binZF ⊢ ax_pair'). { apply Ctx. unfold binZF. auto. }
  apply (AllE y) in H. cbn in H. apply (AllE y) in H. cbn in H.
  use_exists' H sy. clear H.
  assert (H : binZF ⊢ ax_pair'). { apply Ctx. unfold binZF. auto. }
  apply (AllE x) in H. cbn in H. apply (AllE sy) in H. cbn in H.
  eapply Weak in H. use_exists' H pxy. clear H. 2: auto.
  assert (H : binZF ⊢ ax_union'). { apply Ctx. unfold binZF. auto. }
  apply (AllE pxy) in H. cbn in H. eapply Weak in H. use_exists' H a. clear H. 2: auto.
  apply (ExI a). cbn. subsimpl. prv_all' b. apply CI; apply II.
  - assert2 H. apply (AllE b) in H. cbn in H. subsimpl_in H. apply CE1 in H.
    rewrite imps in H. eapply Weak in H. use_exists' H c. clear H. 2: auto.
    assert4 H. apply (AllE c) in H. cbn in H. subsimpl_in H. cbn in H. apply CE1 in H.
    eapply DE. eapply IE. apply H. eapply CE1. auto.
    + apply DI1. eapply bZF_elem. auto 7.
      * apply bZF_refl. auto 7.
      * apply Ctx. left. unfold eq'. cbn. unfold binZF.eq'. cbn. subsimpl. reflexivity.
      * eapply CE2. auto.
    + apply DI2. clear H. assert6 H. apply (AllE b) in H. cbn in H. subsimpl_in H.
      apply CE1 in H. eapply DE. eapply IE; try apply H.
      * eapply bZF_elem. auto 7. 1: apply bZF_refl. auto 7. 2: eapply CE2; auto.
        apply Ctx. left. unfold eq'. cbn. subsimpl. reflexivity.
      * apply Ctx. left. unfold eq'. cbn. subsimpl. reflexivity.
      * apply Ctx. left. unfold eq'. cbn. subsimpl. reflexivity.
  - assert2 H. apply (AllE b) in H. cbn in H. subsimpl_in H. apply CE2 in H.
    apply (IE H). eapply DE; try now apply Ctx.
    + apply (ExI x). cbn. subsimpl. apply CI; auto.
      clear H. assert4 H. apply (AllE x) in H. cbn in H. subsimpl_in H. apply CE2 in H.
      apply (IE H). apply DI1. unfold eq'. cbn. subsimpl. apply bZF_refl. auto 7.
    + apply (ExI sy). cbn. subsimpl. apply CI.
      * clear H. assert4 H. apply (AllE sy) in H. cbn in H. subsimpl_in H. apply CE2 in H.
        apply (IE H). apply DI2. unfold eq'. cbn. subsimpl. apply bZF_refl. auto 7.
      * clear H. assert5 H. apply (AllE b) in H. cbn in H. subsimpl_in H. apply CE2 in H.
        apply (IE H). apply DI2. unfold eq'. cbn. subsimpl. auto.
Qed.

Theorem reduction_entailment phi :
  entailment_binZF phi <-> entailment_binFST (ZF_to_FST phi).
Proof.
  split; intros Hp D I rho HI.
  - unfold ZF_to_FST. intros H1 H2 H3 H4. apply Hp.
    intros psi [<-|[<-|[<-|[<-|[<-|[<-|[<-|[]]]]]]]]; trivial.
    all: apply HI; unfold binFST; intuition.
  - apply Hp; fold sat. 2-5: apply HI; unfold binZF; intuition auto 7.
    intros psi [<-|[<-|[<-|[<-|[]]]]]. 1-3: apply HI; unfold binZF; intuition.
    apply (soundness bZF_adj). apply HI.
Qed.

Theorem reduction_deduction phi :
  deduction_binZF phi <-> deduction_binFST (ZF_to_FST phi).
Proof.
  split; intros H.
  - repeat apply II. apply (prv_cut H).
    intros psi [<-|[<-|[<-|[<-|[<-|[<-|[<-|[]]]]]]]].
    all: unfold binFST; apply Ctx; intuition auto 7.
  - unfold ZF_to_FST in H. repeat setoid_rewrite imps in H. apply (prv_cut H).
    intros psi [<-|[<-|[<-|[<-|[<-|[<-|[<-|[<-|[]]]]]]]]]; trivial.
    8: apply bZF_adj. all: unfold binZF; apply Ctx; intuition auto 7.
Qed.


(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2015 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.
*)

From Coq Require Import Reals Psatz ssreflect.

Require Import Rcomplements Rbar Hierarchy Derive RInt Continuity Lim_seq ElemFct RInt_analysis.

(** This file describes an experiment: most 18-year old French
students pass an exam called Baccalaureate which ends the high school
and is required for attending the university. We took the 2013
mathematics test of the scientific Baccalaureate at the same time as
the students. The pdf of the test is available
#here#. *)

Ltac pos_rat :=
  repeat ( apply Rdiv_lt_0_compat
         || apply Rplus_lt_0_compat
         || apply Rmult_lt_0_compat) ;
  try by apply Rlt_0_1.

Lemma sign_0_lt : forall x, 0 < x <-> 0 < sign x.
Proof.
intros x.
unfold sign.
destruct total_order_T as [[H|H]|H] ; lra.
Qed.

Lemma sign_lt_0 : forall x, x < 0 <-> sign x < 0.
Proof.
intros x.
unfold sign.
destruct total_order_T as [[H|H]|H] ; lra.
Qed.

(** * Exercice 2 *)
(* 8:14 *)

Definition fab (a b x : R) : R := (a + b * ln x) / x.

(** ** Questions 1 *)

(** 1.a. On voit sur le graphique que l'image de 1 par f correspond au point B(1,2). On a donc f(1) = 2.
Comme la tangente (BC) à la courbe en ce point admet pour coefficient directeur 0, f'(1) = 0 *)

(** 1.b *)

Lemma Dfab (a b : R) : forall x, 0 < x
  -> is_derive (fab a b) x (((b - a) - b * ln x) / x ^ 2).
Proof.
  move => x Hx.
  evar_last.
  apply is_derive_div.
  apply @is_derive_plus.
  apply is_derive_const.
  apply is_derive_scal.
  now apply is_derive_Reals, derivable_pt_lim_ln.
  apply is_derive_id.
  by apply Rgt_not_eq.
  rewrite /Rdiv /plus /zero /one /=.
  field.
  by apply Rgt_not_eq.
Qed.

(** 1.c *)

Lemma Val_a_b (a b : R) : fab a b 1 = 2 -> Derive (fab a b) 1 = 0 -> a = 2 /\ b = 2.
Proof.
  move => Hf Hdf.
  rewrite /fab in Hf.
  rewrite ln_1 in Hf.
  rewrite Rdiv_1 in Hf.
  rewrite Rmult_0_r in Hf.
  rewrite Rplus_0_r in Hf.
  rewrite Hf in Hdf |- * => {a Hf}.
  split.
  reflexivity.
  replace (Derive (fab 2 b) 1) with (((b - 2) - b * ln 1) / 1 ^ 2) in Hdf.
  rewrite ln_1 /= in Hdf.
  field_simplify in Hdf.
  rewrite ?Rdiv_1 in Hdf.
  by apply Rminus_diag_uniq.
  apply sym_eq, is_derive_unique.
  apply Dfab.
  by apply Rlt_0_1.
Qed.

Definition f (x : R) : R := fab 2 2 x.

(** ** Questions 2 *)
(* 8:38 *)
(** 2.a. *)

Lemma Signe_df : forall x, 0 < x -> sign (Derive f x) = sign (- ln x).
Proof.
  move => x Hx.
  rewrite (is_derive_unique f x _ (Dfab 2 2 x Hx)).
  replace ((2 - 2 - 2 * ln x) / x ^ 2) with (2 / x ^ 2 * (- ln x)) by (field ; now apply Rgt_not_eq).
  rewrite sign_mult sign_eq_1.
  apply Rmult_1_l.
  apply Rdiv_lt_0_compat.
  apply Rlt_0_2.
  apply pow2_gt_0.
  by apply Rgt_not_eq.
Qed.

(** 2.b. *)

Lemma filterlim_f_0 :
  filterlim f (at_right 0) (Rbar_locally m_infty).
Proof.
  unfold f, fab.
  eapply (filterlim_comp_2 _ _ Rmult).
  eapply filterlim_comp_2.
  apply filterlim_const.
  eapply filterlim_comp_2.
  apply filterlim_const.
  by apply is_lim_ln_0.
  apply (filterlim_Rbar_mult 2 m_infty m_infty).
  unfold is_Rbar_mult, Rbar_mult'.
  case: Rle_dec (Rlt_le _ _ Rlt_0_2) => // H _ ;
  case: Rle_lt_or_eq_dec (Rlt_not_eq _ _ Rlt_0_2) => //.
  apply (filterlim_Rbar_plus 2 _ m_infty).
  by [].
  by apply filterlim_Rinv_0_right.
  by apply (filterlim_Rbar_mult m_infty p_infty).
Qed.

Lemma Lim_f_p_infty : is_lim f p_infty 0.
Proof.
  apply is_lim_ext_loc with (fun x => 2 / x + 2 * (ln x / x)).
    exists 0.
    move => y Hy.
    rewrite /f /fab.
    field.
    by apply Rgt_not_eq.
  eapply is_lim_plus.
  apply is_lim_scal_l.
  apply is_lim_inv.
  by apply is_lim_id.
  by [].
  apply is_lim_scal_l.
  by apply is_lim_div_ln_p.
  unfold is_Rbar_plus, Rbar_plus' ; apply f_equal, f_equal ; ring.
Qed.

(** 2.c. *)

Lemma Variation_1 : forall x y, 0 < x -> x < y -> y < 1 -> f x < f y.
Proof.
  apply (incr_function _ 0 1 (fun x => (2 - 2 - 2 * ln x) / x ^ 2)).
  move => x H0x Hx1.
  by apply (Dfab 2 2 x).
  move => x H0x Hx1.
  apply sign_0_lt.
  rewrite -(is_derive_unique _ _ _ (Dfab 2 2 x H0x)).
  rewrite Signe_df.
  apply -> sign_0_lt.
  apply Ropp_lt_cancel ; rewrite Ropp_0 Ropp_involutive.
  rewrite -ln_1.
  by apply ln_increasing.
  by apply H0x.
Qed.

Lemma Variation_2 : forall x y, 1 < x -> x < y -> f x > f y.
Proof.
  move => x y H1x Hxy.
  apply Ropp_lt_cancel.
  apply (incr_function (fun x => - f x) 1 p_infty (fun z => - ((2 - 2 - 2 * ln z) / z ^ 2))).
  move => z H1z _.
  apply: is_derive_opp.
  apply (Dfab 2 2 z).
  by apply Rlt_trans with (1 := Rlt_0_1).
  move => z H1z _.
  apply Ropp_lt_cancel ; rewrite Ropp_0 Ropp_involutive.
  apply sign_lt_0.
  rewrite -(is_derive_unique _ _ _ (Dfab 2 2 z (Rlt_trans _ _ _ Rlt_0_1 H1z))).
  rewrite Signe_df.
  apply -> sign_lt_0.
  apply Ropp_lt_cancel ; rewrite Ropp_0 Ropp_involutive.
  rewrite -ln_1.
  apply ln_increasing.
  by apply Rlt_0_1.
  by apply H1z.
  by apply Rlt_trans with (1 := Rlt_0_1).
  by [].
  by [].
  by [].
Qed.

(** ** Questions 3 *)
(* 9:40 *)

(** 3.a *)

Lemma f_eq_1_0_1 : exists x, 0 < x <= 1 /\ f x = 1.
Proof.
  case: (IVT_Rbar_incr (fun x => f (Rabs x)) 0 1 m_infty 2 1).
    eapply filterlim_comp.
    apply filterlim_Rabs_0.
    by apply filterlim_f_0.
  apply is_lim_comp with 1.
  replace 2 with (f 1).
  apply is_lim_continuity.
  apply derivable_continuous_pt.
  exists (((2 - 2) - 2 * ln 1) / 1 ^ 2) ; apply is_derive_Reals, Dfab.
  by apply Rlt_0_1.
  rewrite /f /fab ln_1 /= ; field.
  rewrite -{2}(Rabs_pos_eq 1).
  apply (is_lim_continuity Rabs 1).
  by apply continuity_pt_filterlim, continuous_Rabs.
  by apply Rle_0_1.
  exists (mkposreal _ Rlt_0_1) => /= x H0x Hx.
  rewrite /ball /= /AbsRing_ball /= in H0x.
  apply Rabs_lt_between' in H0x.
  rewrite Rminus_eq_0 in H0x.
  contradict Hx.
  rewrite -(Rabs_pos_eq x).
  by apply Rbar_finite_eq.
  by apply Rlt_le, H0x.
  move => x H0x Hx1.
  apply (continuity_pt_comp Rabs).
  by apply continuity_pt_filterlim, continuous_Rabs.
  rewrite Rabs_pos_eq.
  apply derivable_continuous_pt.
  exists (((2 - 2) - 2 * ln x) / x ^ 2) ; apply is_derive_Reals, Dfab.
  by [].
  by apply Rlt_le.
  by apply Rlt_0_1.
  split => //.
  apply Rminus_lt_0 ; ring_simplify ; by apply Rlt_0_1.
  move => x [H0x [Hx1 Hfx]].
  rewrite Rabs_pos_eq in Hfx.
  exists x ; repeat split.
  by apply H0x.
  by apply Rlt_le.
  by apply Hfx.
  by apply Rlt_le.
Qed.

(** 3.b. *)

Lemma f_eq_1_1_p_infty : exists x, 1 <= x /\ f x = 1.
Proof.
  case: (IVT_Rbar_incr (fun x => - f x) 1 p_infty (-2) 0 (-1)).
  replace (-2) with (-f 1).
  apply (is_lim_continuity (fun x => - f x)).
  apply continuity_pt_opp.
  apply derivable_continuous_pt.
  exists (((2 - 2) - 2 * ln 1) / 1 ^ 2) ; apply is_derive_Reals, Dfab.
  by apply Rlt_0_1.
  rewrite /f /fab ln_1 /= ; field.
  evar_last.
  apply is_lim_opp.
  by apply Lim_f_p_infty.
  simpl ; by rewrite Ropp_0.
  move => x H0x Hx1.
  apply continuity_pt_opp.
  apply derivable_continuous_pt.
  exists (((2 - 2) - 2 * ln x) / x ^ 2) ; apply is_derive_Reals, Dfab.
  by apply Rlt_trans with (1 := Rlt_0_1).
  by [].
  split ; apply Rminus_lt_0 ; ring_simplify ; by apply Rlt_0_1.
  move => x [H0x [Hx1 Hfx]].
  exists x ; split.
  by apply Rlt_le.
  rewrite -(Ropp_involutive (f x)) Hfx ; ring.
Qed.

(** ** Questions 5 *)
(* 10:08 *)

(** 5.a. *)

(** 5.b. *)

Lemma If : forall x, 0 < x -> is_derive (fun y : R => 2 * ln y + (ln y) ^ 2) x (f x).
Proof.
  move => y Hy.
  evar_last.
  apply @is_derive_plus.
  apply is_derive_Reals.
  apply derivable_pt_lim_scal.
  by apply derivable_pt_lim_ln.
  apply is_derive_pow.
  by apply is_derive_Reals, derivable_pt_lim_ln.
  rewrite /f /fab /plus /= ; field.
  by apply Rgt_not_eq.
Qed.

Lemma RInt_f : is_RInt f ( / exp 1) 1 1.
Proof.
  have Haux1: (0 < /exp 1).
    apply Rinv_0_lt_compat.
    apply exp_pos.
  evar_last.
  apply: is_RInt_derive.
  move => x Hx.
  apply If.
  apply Rlt_le_trans with (2 := proj1 Hx).
  apply Rmin_case.
  by apply Haux1.
  by apply Rlt_0_1.
  move => x Hx.
  apply continuity_pt_filterlim.
  apply derivable_continuous_pt.
  exists (((2 - 2) - 2 * ln x) / x ^ 2) ; apply is_derive_Reals, Dfab.
  apply Rlt_le_trans with (2 := proj1 Hx).
  apply Rmin_case.
  by apply Haux1.
  by apply Rlt_0_1.
  rewrite /minus /= /plus /opp /= -[eq]/(@eq R).
  rewrite ln_Rinv.
  rewrite ln_exp.
  rewrite ln_1.
  ring.
  by apply exp_pos.
Qed.

(** * Exercice 4 *)
(* 10:36 *)

Fixpoint u (n : nat) : R :=
  match n with
    | O => 2
    | S n => 2/3 * u n + 1/3 * (INR n) + 1
  end.

(** ** Questions 1 *)
(** 1.a. *)

(** 1.b. *)

(** ** Questions 2 *)
(* 10:40 *)
(** 2.a *)

Lemma Q2a : forall n, u n <= INR n + 3.
Proof.
  elim => [ | n IH] ; rewrite ?S_INR /=.
  apply Rminus_le_0 ; ring_simplify ; apply Rle_0_1.
  eapply Rle_trans.
  apply Rplus_le_compat_r.
  apply Rplus_le_compat_r.
  apply Rmult_le_compat_l.
  lra.
  by apply IH.
  lra.
Qed.

(** 2.b. *)
Lemma Q2b : forall n, u (S n) - u n = 1/3 * (INR n + 3 - u n).
Proof.
  move => n ; simpl.
  field.
Qed.

(** 2.c. *)

Lemma Q2c : forall n, u n <= u (S n).
Proof.
  move => n.
  apply Rminus_le_0.
  rewrite Q2b.
  apply Rmult_le_pos.
  lra.
  apply (Rminus_le_0 (u n)).
  by apply Q2a.
Qed.

(** ** Question 3 *)
(* 10:49 *)

Definition v (n : nat) : R := u n - INR n.

(** 3.a. *)

Lemma Q3a : forall n, v n = 2 * (2/3) ^ n.
Proof.
  elim => [ | n IH].
  rewrite /v /u /= ; ring.
  replace (2 * (2 / 3) ^ S n) with (v n * (2/3)) by (rewrite IH /= ; ring).
  rewrite /v S_INR /=.
  field.
Qed.

(** 3.b. *)

Lemma Q3b : forall n, u n = 2 * (2/3)^n + INR n.
Proof.
  move => n.
  rewrite -Q3a /v ; ring.
Qed.

Lemma Q3c : is_lim_seq u p_infty.
Proof.
  apply is_lim_seq_ext with (fun n => 2 * (2/3)^n + INR n).
  move => n ; by rewrite Q3b.
  eapply is_lim_seq_plus.
  eapply is_lim_seq_mult.
  by apply is_lim_seq_const.
  apply is_lim_seq_geom.
  rewrite Rabs_pos_eq.
  lra.
  lra.
  by [].
  apply is_lim_seq_INR.
  by [].
Qed.

(** ** Questions 4 *)
(* 11:00 *)

Definition Su (n : nat) : R := sum_f_R0 u n.
Definition Tu (n : nat) : R := Su n / (INR n) ^ 2.

(** 4.a. *)

Lemma Q4a : forall n, Su n = 6 - 4 * (2/3)^n + INR n * (INR n + 1) / 2.
Proof.
  move => n.
  rewrite /Su.
  rewrite -(sum_eq (fun n => (2/3)^n * 2 + INR n)).
  rewrite sum_plus.
  rewrite -scal_sum.
  rewrite tech3.
  rewrite sum_INR.
  simpl ; field.
  apply Rlt_not_eq, Rlt_div_l.
  repeat apply Rplus_lt_0_compat ; apply Rlt_0_1.
  apply Rminus_lt_0 ; ring_simplify ; by apply Rlt_0_1.
  move => i _.
  rewrite Q3b ; ring.
Qed.

(** 4.b. *)

Lemma Q4b : is_lim_seq Tu (1/2).
Proof.
  apply is_lim_seq_ext_loc with (fun n => (6 - 4 * (2/3)^n) / (INR n ^2) + / (2 * INR n) + /2).
    exists 1%nat => n Hn ; rewrite /Tu Q4a.
    simpl ; field.
    apply Rgt_not_eq, (lt_INR O) ; intuition.
  eapply is_lim_seq_plus.
  eapply is_lim_seq_plus.
  eapply is_lim_seq_div.
  eapply is_lim_seq_minus.
  apply is_lim_seq_const.
  eapply is_lim_seq_mult.
  by apply is_lim_seq_const.
  apply is_lim_seq_geom.
  rewrite Rabs_pos_eq.
  lra.
  lra.
  by [].
  rewrite /is_Rbar_minus /is_Rbar_plus /=.
  now ring_simplify (6 + - (4 * 0)).
  repeat eapply is_lim_seq_mult.
  apply is_lim_seq_INR.
  apply is_lim_seq_INR.
  apply is_lim_seq_const.
  apply is_Rbar_mult_p_infty_pos.
  by apply Rlt_0_1.
  by [].
  by [].
  by apply is_Rbar_div_p_infty.
  apply is_lim_seq_inv.
  eapply is_lim_seq_mult.
  by apply is_lim_seq_const.
  by apply is_lim_seq_INR.
  by apply is_Rbar_mult_sym, is_Rbar_mult_p_infty_pos, Rlt_0_2.
  by [].
  by [].
  apply is_lim_seq_const.
  apply (f_equal (@Some _)), f_equal.
  field.
Qed.
(* 11:33 *)


Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.ModalLogic.Syntax.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.ModalLogic.ProofTheory.ModalLogic.
Require Import Logic.ModalLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import ModalLanguageNotation.
Import SeparationLogicNotation.

Class SeparationTransparentModality1 (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} {sL: SeparationLanguage L} (Gamma: ProofTheory L) {minAX: MinimunAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {KmGamma: SystemK L Gamma} {sGamma: SeparationLogic L Gamma} := {
  sepcon_boxp: forall x y, |-- boxp x * boxp y --> boxp (x * y)
}.

Class SeparationTransparentModality2 (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} {sL: SeparationLanguage L} (Gamma: ProofTheory L) {minAX: MinimunAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {KmGamma: SystemK L Gamma} {sGamma: SeparationLogic L Gamma} := {
  boxp_sepcon: forall x y, |-- boxp (x * y) --> boxp x * boxp y
}.

Class SeparationTransparentModality3 (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} {sL: SeparationLanguage L} (Gamma: ProofTheory L) {minAX: MinimunAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {KmGamma: SystemK L Gamma} {sGamma: SeparationLogic L Gamma} := {
  wand_boxp: forall x y, |-- (boxp x -* boxp y) --> boxp (x -* y)
}.

Class SeparationTransparentModality4 (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} {sL: SeparationLanguage L} (Gamma: ProofTheory L) {minAX: MinimunAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {KmGamma: SystemK L Gamma} {sGamma: SeparationLogic L Gamma} := {
  boxp_wand: forall x y, |-- boxp (x -* y) --> (boxp x -* boxp y)
}.

Instance SeparationTransparentModality14 (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} {sL: SeparationLanguage L} (Gamma: ProofTheory L) {minAX: MinimunAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {KmGamma: SystemK L Gamma} {sGamma: SeparationLogic L Gamma} {sm1Gamma: SeparationTransparentModality1 L Gamma}:
  SeparationTransparentModality4 L Gamma.
Proof.
  constructor.
  intros.
  apply wand_sepcon_adjoint.
  rewrite sepcon_boxp.
  rewrite provable_wand_sepcon_modus_ponens1.
  apply provable_impp_refl.
Qed.

Instance SeparationTransparentModality41 (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} {sL: SeparationLanguage L} (Gamma: ProofTheory L) {minAX: MinimunAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {KmGamma: SystemK L Gamma} {sGamma: SeparationLogic L Gamma} {sm3Gamma: SeparationTransparentModality4 L Gamma}:
  SeparationTransparentModality1 L Gamma.
Proof.
  constructor.
  intros.
  apply wand_sepcon_adjoint.
  rewrite <- boxp_wand.
  eapply modus_ponens; [apply axiom_K |].
  apply rule_N.
  apply wand_sepcon_adjoint.
  apply provable_impp_refl.
Qed.


Require Export Unicode.Utf8.
Require Export ssreflect ssrfun.
Require Import Program.Equality.
Require Import Logic.ProofIrrelevance.
Require Import Logic.PropExtensionality.
Require Import Logic.FunctionalExtensionality.
Require Export Strings.String.

Close Scope nat_scope.
Set Primitive Projections.
Set Program Mode.

Hint Immediate proof_irrelevance : core.

From Coq.Classes Require Import RelationClasses.

Record EqRel A :=
  {EqRel_rel :> A → A → Prop;
   EqRel_equiv : Equivalence EqRel_rel}.

Existing Instances EqRel_equiv.

Lemma eq_subset {A : Type} {P : A → Prop} : ∀ (x y : {x : A | P x}), (x : A) = (y : A) → x = y.
Proof.
  move=> [x hx] [y hy] //= Q.
  dependent induction Q.
  have Q: hx = hy; auto.
  by rewrite Q.
Qed.

(* This is a nice tactic to add to the context whatever follows from the subset assumptions. *)
Ltac expose_subset :=
  repeat
    match goal with
    | [H : {x : ?A | @?P x} |- _] =>
      match goal with
      | [I : P (sval H) |- _] => idtac
      | _ => have ? : P (sval H); first by case: H => [? ?]; auto
      end
    end.

(* A useful tactic for incrementally rewriting an equation in a dependent record. Q is an equation of primitive tuples, and x0 and x1 are parallel components of the record in the goal that are equal as a consequence of Q. *)
Ltac proj_eq Q x0 x1 :=
  let H := fresh in
  suff H : x0 = x1;
  [dependent induction H | by dependent induction Q].

Record Case (name : string) (tp : Type) := {case_val : tp}.
Arguments case_val [_] [_].

Notation "⟨ name ∷ tp ⟩" := (Case name tp).
Notation "! f" := (case_val f) (at level 10).

Definition make_case (name : string) {tp} : tp → Case name tp.
  move=> x.
  constructor.
  exact: x.
Defined.

Open Scope string_scope.

Ltac axiom name :=
  refine (make_case name _); simpl.

Class ExtLaw (A : Type) (B : A → A → Type) :=
  {ext_law : ∀ x y : A, B x y → x = y}.

Instance prop_ext : ExtLaw Prop _ :=
  {ext_law := propositional_extensionality}.

Instance fun_ext {A B : Type} : ExtLaw (A → B) (λ f g, ∀ x, f x = g x) :=
  {ext_law := functional_extensionality}.

Instance dep_fun_ext {A : Type} {B : A → Type} : ExtLaw (∀ x, B x) _ :=
  {ext_law := functional_extensionality_dep}.

Instance subset_ext {A : Type} {P : A → Prop} : ExtLaw {x : A | P x} _ :=
  {ext_law := eq_subset}.

Instance sigma_ext {A : Type} {B : A → Type}
  : ExtLaw {x : A & B x} (λ p q, {α : projT1 p = projT1 q | eq_rect (projT1 p) _ (projT2 p) (projT1 q) α = projT2 q}).
Obligation 1.
Proof. by apply: eq_sigT. Qed.

Ltac ext :=
  apply: ext_law;
  match goal with
  | [|- {x : ?A | @?B x}] => unshelve econstructor
  | _ => idtac
  end;
  cbn.


From caml5 Require Import
  prelude.
From caml5.lang Require Import
  notations
  proofmode.
From caml5.std Require Export
  base.
From caml5.std Require Import
  lst.

Record fun_queue `{!heapGS Σ} {unboxed : bool} := {
  fun_queue_make : val ;
  fun_queue_is_empty : val ;
  fun_queue_push : val ;
  fun_queue_pop : val ;

  fun_queue_model : val → list val → iProp Σ ;

  fun_queue_model_persistent t vs :
    Persistent (fun_queue_model t vs) ;
  fun_queue_model_timeless t vs :
    Timeless (fun_queue_model t vs) ;

  fun_queue_make_spec :
    {{{ True }}}
      fun_queue_make #()
    {{{ t, RET t; fun_queue_model t [] }}} ;

  fun_queue_is_empty_spec t vs :
    {{{ fun_queue_model t vs }}}
      fun_queue_is_empty t
    {{{ RET #(bool_decide (vs = [])); True }}} ;

  fun_queue_push_spec t vs v :
    {{{ fun_queue_model t vs }}}
      fun_queue_push t v
    {{{ t', RET t'; fun_queue_model t' (v :: vs) }}} ;

  fun_queue_pop_spec t vs :
    {{{ fun_queue_model t vs }}}
      fun_queue_pop t
    {{{ w,
      RET w;
      (⌜vs = [] ∧ w = NONEV⌝) ∨
      (∃ vs' v t', ⌜vs = vs' ++ [v] ∧ w = SOMEV (v, t')⌝ ∗ fun_queue_model t' vs')
    }}} ;

  fun_queue_unboxed :
    if unboxed then ∀ t vs,
      fun_queue_model t vs -∗
      ⌜val_is_unboxed t⌝
    else
      True ;
}.
#[global] Arguments fun_queue _ {_} _ : assert.
#[global] Arguments Build_fun_queue {_ _} _ {_ _ _ _ _ _ _} _ _ _ _ _ : assert.
#[global] Existing Instance fun_queue_model_persistent.
#[global] Existing Instance fun_queue_model_timeless.

Section std_fun_queue.
  Context `{!heapGS Σ}.
  Implicit Types v t back front : val.

  Notation "t '.(back)'" := (Fst t)
  ( at level 5
  ) : expr_scope.
  Notation "t '.(front)'" := (Snd t)
  ( at level 5
  ) : expr_scope.

  Definition std_fun_queue_make : val :=
    λ: <>,
      (lst_nil, lst_nil).

  Definition std_fun_queue_is_empty : val :=
    λ: "t",
      lst_is_empty "t".(front) && lst_is_empty "t".(back).

  Definition std_fun_queue_push : val :=
    λ: "t" "v",
      (lst_cons "v" "t".(back), "t".(front)).

  Definition std_fun_queue_pop : val :=
    λ: "t",
      if: lst_is_empty "t".(front) then (
        let: "front" := lst_rev "t".(back) in
        if: lst_is_empty "front" then (
          NONE
        ) else (
          SOME (lst_head "front", (lst_nil, lst_tail "front"))
        )
      ) else (
        SOME (lst_head "t".(front), ("t".(back), lst_tail "t".(front)))
      ).

  Definition std_fun_queue_model t vs : iProp Σ :=
    ∃ back vs_back front vs_front,
    ⌜t = (back, front)%V ∧ vs = vs_back ++ reverse vs_front⌝ ∗
    lst_model back vs_back ∗ lst_model front vs_front.

  #[global] Instance std_fun_queue_model_persistent t vs :
    Persistent (std_fun_queue_model t vs).
  Proof.
    apply _.
  Qed.
  #[global] Instance std_fun_queue_model_timeless t vs :
    Timeless (std_fun_queue_model t vs).
  Proof.
    apply _.
  Qed.

  Lemma std_fun_queue_make_spec :
    {{{ True }}}
      std_fun_queue_make #()
    {{{ t, RET t; std_fun_queue_model t [] }}}.
  Proof.
    iIntros "%Φ _ HΦ".
    wp_rec. wp_pures.
    iModIntro. iApply "HΦ". iExists lst_nil, [], lst_nil, []. list_simplifier.
    iSplit; first done. iDestruct lst_nil_spec as "$".
  Qed.

  Lemma std_fun_queue_is_empty_spec t vs :
    {{{ std_fun_queue_model t vs }}}
      std_fun_queue_is_empty t
    {{{ RET #(bool_decide (vs = [])); True }}}.
  Proof.
    iIntros "%Φ (%back & %vs_back & %front & %vs_front & (-> & ->) & #Hback & #Hfront) HΦ".
    wp_rec. wp_pures.
    wp_apply (lst_is_empty_spec with "Hfront"). iIntros "_".
    destruct vs_front as [| v_front vs_front]; wp_pures.
    - wp_apply (lst_is_empty_spec with "Hback"). iIntros "_".
      destruct vs_back as [| v_back vs_back]; list_simplifier; iApply ("HΦ" with "[//]").
    - rewrite bool_decide_eq_false_2; last first.
      { rewrite reverse_cons. intros (_ & (_ & [=])%app_eq_nil)%app_eq_nil. }
      iApply ("HΦ" with "[//]").
  Qed.

  Lemma std_fun_queue_push_spec t vs v :
    {{{ std_fun_queue_model t vs }}}
      std_fun_queue_push t v
    {{{ t', RET t'; std_fun_queue_model t' (v :: vs) }}}.
  Proof.
    iIntros "%Φ (%back & %vs_back & %front & %vs_front & (-> & ->) & #Hback & #Hfront) HΦ".
    wp_rec. wp_pures.
    wp_apply (lst_cons_spec with "Hback"). iIntros "%back' #Hback'".
    wp_pures.
    iApply "HΦ". iExists back', (v :: vs_back), front, vs_front. auto with iFrame.
  Qed.

  Lemma std_fun_queue_pop_spec t vs :
    {{{ std_fun_queue_model t vs }}}
      std_fun_queue_pop t
    {{{ w,
      RET w;
      (⌜vs = [] ∧ w = NONEV⌝) ∨
      (∃ vs' v t', ⌜vs = vs' ++ [v] ∧ w = SOMEV (v, t')⌝ ∗ std_fun_queue_model t' vs')
    }}}.
  Proof.
    iIntros "%Φ (%back & %vs_back & %front & %vs_front & (-> & ->) & #Hback & #Hfront) HΦ".
    wp_rec. wp_pures.
    wp_apply (lst_is_empty_spec with "Hfront"). iIntros "_".
    destruct vs_front as [| v_front vs_front]; wp_pures.
    - iClear "Hfront". clear.
      wp_apply (lst_rev_spec with "Hback"). iIntros "%front #Hfront".
      wp_pures.
      wp_apply (lst_is_empty_spec with "Hfront"). iIntros "_".
      destruct (reverse vs_back) as [| v vs_front] eqn:Heq;
        apply (f_equal reverse) in Heq; rewrite reverse_involutive in Heq; subst;
        wp_pures.
      + iApply "HΦ". iLeft. done.
      + wp_apply (lst_tail_spec with "Hfront"); first done. iIntros "%front' #Hfront'".
        wp_pures.
        wp_apply (lst_head_spec with "Hfront"); first done. iIntros "_".
        wp_pures.
        iModIntro. iApply "HΦ". iRight. iExists (reverse vs_front), v, _. iSplit.
        { iPureIntro. split; last done.
          rewrite reverse_nil reverse_cons. list_simplifier. done.
        }
        iExists lst_nil, [], front', vs_front. repeat iSplit; try done. iApply lst_nil_spec.
    - wp_apply (lst_tail_spec with "Hfront"); first done. iIntros "%front' Hfront'".
      wp_pures.
      wp_apply (lst_head_spec with "Hfront"); first done. iIntros "_".
      wp_pures.
      iModIntro. iApply "HΦ". iRight. iExists (vs_back ++ reverse vs_front), v_front, _. iSplit.
      { iPureIntro. split; last done. list_simplifier. rewrite reverse_cons //. }
      iExists back, vs_back, front', vs_front. auto with iFrame.
  Qed.

  Definition std_fun_queue :=
    Build_fun_queue false
      std_fun_queue_make_spec
      std_fun_queue_is_empty_spec
      std_fun_queue_push_spec
      std_fun_queue_pop_spec
      I.
End std_fun_queue.

#[global] Opaque std_fun_queue_make.
#[global] Opaque std_fun_queue_is_empty.
#[global] Opaque std_fun_queue_push.
#[global] Opaque std_fun_queue_pop.

#[global] Opaque std_fun_queue_model.


Require Import CertiGraph.prim.prim_env.
Require Export CertiGraph.priq.priq_arr_specs.
Require Import CertiGraph.graph.MathUAdjMatGraph.
Require Import CertiGraph.prim.prim_constants.
Require Import CertiGraph.graph.SpaceUAdjMatGraph3.
Require Export CertiGraph.prim.prim3.

Local Open Scope Z_scope.

Section PrimSpec.

Context {Z_EqDec : EquivDec.EqDec Z eq}.

Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Global Existing Instance CompSpecs.

Definition G := @UAdjMatGG size inf.
Identity Coercion UAdjMatGG_G: G >-> UAdjMatGG.

Definition getCell_spec :=
  DECLARE _getCell
  WITH g: G,
       graph_ptr: pointer_val,
       addresses: list val,
       u: V,
       i : V
  PRE [tptr (tarray tint size), tint, tint]
    PROP (0 <= i < size;
          0 <= u < size)
    PARAMS (pointer_val_val graph_ptr;
           Vint (Int.repr u);
           Vint (Int.repr i))
    GLOBALS ()
    SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (@graph_to_symm_mat size g) (pointer_val_val graph_ptr))
  POST [tint]
    PROP ()
    RETURN (Vint (Int.repr (Znth i (Znth u (@graph_to_symm_mat size g)))))
    SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (@graph_to_symm_mat size g) (pointer_val_val graph_ptr)).

Definition initialise_list_spec :=
  DECLARE _initialise_list
  WITH arr : val, old_list: list val, a: Z
  PRE [tptr tint, tint]
     PROP ( writable_share Tsh;
            repable_signed a;
            size <= Int.max_signed
          )
     PARAMS ( arr; Vint (Int.repr a) )
     GLOBALS ()
     SEP (data_at Tsh (tarray tint size) (old_list) (arr))
  POST [ tvoid ]
     PROP ()
     LOCAL ()
     SEP (data_at Tsh (tarray tint size) (repeat (Vint (Int.repr a)) (Z.to_nat size)) arr
         ).

Definition initialise_matrix_spec :=
  DECLARE _initialise_matrix
  WITH arr : val, old_contents: list (list Z), a: Z
  PRE [tptr (tarray tint size), tint]
     PROP ( writable_share Tsh;
            Zlength old_contents = size;
            forall row, In row old_contents -> Zlength row = size;
            repable_signed a;
            0 < size <= Int.max_signed; (*this is not enough for malloc, requires*)
            size * (4 * size) <= Ptrofs.max_signed (*you can alloc the entire matrix. Can derive above from here*)
          )
     PARAMS ( arr ; Vint (Int.repr a) )
     GLOBALS ()
     SEP (@SpaceAdjMatGraph' size CompSpecs Tsh old_contents arr)
  POST [ tvoid ]
     PROP ()
     LOCAL ()
     SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (repeat (repeat a (Z.to_nat size)) (Z.to_nat size)) arr).

Definition prim_spec :=
  DECLARE _prim
  WITH g: G, garbage: list V, gptr : pointer_val, r: Z, parent_ptr : pointer_val
  PRE [tptr (tarray tint size), tint, tptr tint]
     PROP ( writable_share Tsh;
            vvalid g r;
            size * (4 * size) <= Ptrofs.max_signed;
            inf < Int.max_signed
          )
     PARAMS ( pointer_val_val gptr; (Vint (Int.repr r)); pointer_val_val parent_ptr)
     GLOBALS ()
     SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (@graph_to_symm_mat size g) (pointer_val_val gptr);
          data_at Tsh (tarray tint size) (map (fun x => Vint (Int.repr x)) garbage) (pointer_val_val parent_ptr)
         )
  POST [ tvoid ]
     EX mst: G,
     EX fmst: FiniteGraph mst,
     EX parents: list V,
     PROP ( (*connected_graph mst;*)
            @minimum_spanning_forest size inf mst g;
            Permutation (EList mst) (map (fun v => eformat (v, Znth v parents))
              (filter (fun v => Znth v parents <? size) (nat_inc_list (Z.to_nat size))))
          )
     RETURN ()
     SEP (@SpaceAdjMatGraph' size CompSpecs Tsh (@graph_to_symm_mat size g) (pointer_val_val gptr);
          data_at Tsh (tarray tint size) (map (fun x => Vint (Int.repr x)) parents) (pointer_val_val parent_ptr)
         ).

Definition Gprog: funspecs :=
  ltac:(with_library prog
                     [(@push_spec size inf _);
                     (@pq_emp_spec size inf _);
                     (@popMin_spec size inf Z_EqDec _);
                     (@adjustWeight_spec size inf _);
                     (@init_spec size _);
                     freePQ_spec;
                     getCell_spec;
                     initialise_list_spec;
                     initialise_matrix_spec;
                     prim_spec
       ]).

End PrimSpec.


Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Relations.Relation_Operators.
Require Import List.

Require Export Syntax.

Reserved Notation " id '/' cfg ';' e '==>' cfg' ';' e' " (at level 40).

Inductive step_actor (id : id) : configuration -> expr -> configuration -> expr -> Prop :=
  | EvalContext :
      forall O O' H H' n n' ctx e e',
        is_econtext ctx ->
        id / (O, H, n) ; e ==>
          (O', H', n') ; e' ->
        id / (O, H, n) ; ctx e ==>
          (O', H', n') ; ctx e'
  | EvalMutate :
      forall O H n l,
        id / (O, H, n) ; EMut (ELoc l) ==>
           (O, H, n) ; EUnit
  | EvalApply :
      forall O H n x t e v,
        is_val v ->
        id / (O, H, n) ; EApp (ELam x t e) v ==>
           (O, H, n) ; subst x v e
  | EvalNewPassive :
      forall O H n l L Q e,
        heapLookup H id = Some (l, L, Q, e) ->
        id / (O, H, n) ; ENew TPas ==>
           (O, heapUpdate H id (l, n :: L, Q, e), S n) ; ELoc n
  | EvalNewActive :
      forall O H n,
        id / (O, H, n) ; ENew TAct ==>
           (O, heapExtend H (n, n :: nil, nil, EUnit), S n) ; EId (length H)
  | EvalNewTrans :
      forall O H n l L Q e,
        heapLookup H id = Some (l, L, Q, e) ->
        id / (O, H, n) ; ENew TTrans ==>
           (extend O n id, heapUpdate H id (l, n :: L, Q, e), S n) ; ETId n
  | EvalSendActor :
      forall O H n id' x e l' L Q e',
        heapLookup H id' = Some (l', L, Q, e') ->
        id / (O, H, n) ; ESend (EId id') x TPas e ==>
           (O, heapUpdate H id' (l', L, snoc Q (ELam x TPas e), e'), n) ; EUnit
  | EvalSendTransDelegate :
      forall O H n l id' x e l' L Q e',
        O l = Some id' ->
        id <> id' ->
        heapLookup H id' = Some (l', L, Q, e') ->
        id / (O, H, n) ; ESend (ETId l) x TPas e ==>
           (O, heapUpdate H id' (l', L, snoc Q (ELam 0 TPas (ESend (ETId l) x TPas e)), e'), n) ; EUnit
  | EvalSendTransRun :
      forall O H n l x e,
        O l = Some id ->
        id / (O, H, n) ; ESend (ETId l) x TPas e ==>
           (O, H, n) ; EApp (ELam x TPas e) (ELoc l)
where " id '/' cfg ';' e '==>' cfg' ';' e' " := (step_actor id cfg e cfg' e').

Inductive step (id : id) : configuration -> configuration -> Prop :=
  | EvalActorMsg :
      forall O H n l L v' Q v,
        heapLookup H id = Some (l, L, v'::Q, v) ->
        is_val v ->
        step id (O, H, n) (O, heapUpdate H id (l, L, Q, EApp v' (ELoc l)), n)
  | EvalActorTransfer :
      forall id' O H n l l1 l2 L L' Q Q' v e,
        heapLookup H id = Some (l1, L, Q, v) ->
        is_val v ->
        O l = Some id ->
        id <> id' ->
        heapLookup H id' = Some (l2, L', Q', e) ->
        step id (O, H, n) (extend O l id', heapUpdate (heapUpdate H id (l1, remove id_eq_dec l L, Q, EUnit)) id' (l2, l :: L', Q', e), n)
  | EvalActorRun :
      (* e will always be equal to e'' *)
      forall O O' H H' n n' l L L' Q Q' e e' e'',
        heapLookup H id = Some (l, L, Q, e) ->
        id / (O, H, n) ; e ==> (O', H', n') ; e' ->
        heapLookup H' id = Some (l, L', Q', e'') ->
        step id (O, H, n) (O', heapUpdate H' id (l, L', Q', e'), n')
.


(* this is a simplified version of loops *)

Require Import AST.
Require Import Memory.
(*Require Import Values.*)
Require Import Maps.
Require Import NArith.
Require Import ZArith.
Require Import List.
Require Import Program.
Require Import Coqlibext.
Require Import ArithClasses.
Require Import Integers.
Require Import ClassesAndNotations.
Require Import Do_notation.
Require Import Bounds.
Open Scope Z_scope.

(* we want id for instruction that are not just ident (it polutes
   every thing) so we use a singleton, defined in ClassesAndNotations*)

(*Record Instr_Id := mk_Instr_Id
  { open_Instr_Id : ident}.

Global Instance singletonInd_Instr_Id : singletonInd Instr_Id ident :=
{ open := open_Instr_Id;
  mk := mk_Instr_Id}.
Proof.
  destruct i; auto.
  auto.
Qed.*)

(* The Loop language and its semantics are parametrized by the
   instructions of the source language, for example C instructions for
   the source to source version, or Cminor ones for the complete
   version bound to Compcert *)

Module Type INSTRS(N:NUMERICAL).
  Import N.
  Existing Instance Numerical_Num.
  Module T := Tools(N).
  Import T.

  (* The values of the language *)
  Parameter Value: Type.

  (* the abstract type of instructions *)
  Parameter Instruction: Type.

  (* the number of variables for the Instruction. Typically, the depth
     of the instruction in the loop nest in the original program plus
     the number of parameters of the program, but not counting the
     extra 1

     For example, for a program with one global variable N,

     for (i = 0 -> N){
       T[i] = 0; //I1
       for(j = 0 -> i){
         U[j] += T[j]; //I2
       }
     }

     I1 will have a context_size of 2 (i and N) and I2 of 3 (j, i and
     N) (even if i does not appear in I2)
     *)

  Parameter context_size: Instruction -> nat.

  (* What locations are read by the instruction.

     The ident is the one of the array, and the matrix is the linear
     form that must be applied to the context to obtain the cell in
     the array.

     The context is here augmented with 1, as usual, to allow affine
     and not just linear transformations. All the location are read.

     The lenght of the inside list must correspond to the dimension of
     the array, but this is not enforced by the type.

     *)

  Parameter read_locs: forall i: Instruction,
    list (Array_Id * list (Vector Num ( S (context_size i)))).

  (* each instruction write one, and exactly one location. The initial
     idea of having potentially several location optionally written to
     allow conditional has been abandoned because it would not allow
     to add dynamic tests. The idea is that since a dynamic comparison
     of pointers can fail if one of the two pointers is not defined,
     we must make sure that every location is accessed to be able to
     add the test, so that if a pointer is not valid, the write would
     have failed in the original program.

     One could think you may want to write at most one location. But
     the instructions in loops are pure except for the written
     location. So if an instruction does not write anything, it is
     just useless

     As for read locations, the length of the list must be equal to
     the dimension of the array *)

  Parameter write_loc: forall i: Instruction,
    Array_Id * list (Vector Num (S (context_size i))).

  (* the semantics of the instruction is "pure" (it does not talk
     explicitly about the memory), except specifically on the written
     instructions and depends only on the read values. It is in Prop
     because it is not used by the optimiser (the optimizer is
     agnostic in the semantics of the instructions. for example it
     cannot use the fact that addition is commutative), just by the
     preservation proof. It takes the context as an input to allow
     instruction like T[i] = i; or T[i] = N*)

  Parameter semantics: forall i,
    Context (context_size i) -> (** the context *)
    list Value -> (** the read Values *)
    Value -> (** the result of the evaluation *)
    Prop.

  (* For the validator to prove that two loops programs are
     equivalent, it will lift them to the polyhedral world, and
     compare them there. Hence, it needs a complete equivalence
     between the loop form and the polyhedral form, which should need
     determinism of the semantics. I should check that this is true for
     "pure" C instructions *)

  Parameter semantics_deterministic:
    forall i v lv val1 val2,
      semantics i v lv val1 -> semantics i v lv val2 -> val1 = val2.

End INSTRS.

(* as for memories, we need to be able to move from instruction in int
   to instructions in Z *)

Module INSTRSI2Z (I:INSTRS(IntNum)) <: INSTRS(ZNum).
  Definition Instruction := I.Instruction.
  Definition Value := I.Value.
  Module T := Tools(ZNum).
  Import T.
  (* the number of arguments for the instruction. Typically, the depth
     of the instruction in the loop nest in the original program plus
     the number of parameters of the program *)

  Definition context_size:= I.context_size.

  (* What locations are read by the instruction. The ident is then one
     of the array, and the matrix is the linear form that must be
     applied to the context to obtain the cell in the array. The
     context is here augmented with 1, as usual. All the location are
     read *)

  Definition i2zidmat {p} (pair : Array_Id * list (IVector p)) :=
    match pair with
      | (id, l) => (id, map i2zvect l)
    end.

  Definition read_locs i :=
    map i2zidmat (I.read_locs i).

  Definition write_loc i := i2zidmat (I.write_loc i).

  Inductive sem i (zv: Vector Z (context_size i)) lv v : Prop :=
    | sem_intro:
      forall iv, z2ivect zv = Some iv -> I.semantics i iv lv v ->
        sem i zv lv v.
  Definition semantics := sem.

  Lemma semantics_deterministic:
    forall i v lv val1 val2,
      semantics i v lv val1 -> semantics i v lv val2 -> val1 = val2.
  Proof.
    intros * SEM1 SEM2.
    inv SEM1; inv SEM2.
    replace iv0 with iv in *; [|congruence].
    eapply I.semantics_deterministic; eauto.
  Qed.
End INSTRSI2Z.


Require Import
  List
  Coq.Lists.ListSet
  Coq.Classes.RelationClasses
  .

From CasperCBC
    Require Import
      Preamble
      SortedLists
      ListExtras
      ListSetExtras
    .

Import ListNotations.

(** * VLSM Full-Node State Tracking Sent Messages *)

Set Contextual Implicit.
Set Implicit Arguments.
Section FullNodeState.

(** The development below defines a full-node-like state based on pointed sets,
with the distinguished element being the last message sent by the machine.
*)

Context
    (C V : Type)
    .

(**  As justifications contain sets of messages which contain justifications,
we define justifications, messages, and message sets by mutual recursion.
*)

Inductive justification : Type :=
    | NoSent : message_set -> justification
    | LastSent : message_set -> message -> justification

  with message : Type :=
    Msg : C -> V -> justification -> message

  with message_set : Type :=
    | Empty : message_set
    | add : message -> message_set -> message_set
  .

Scheme justification_mut_ind := Induction for justification Sort Prop
with message_mut_ind := Induction for message Sort Prop
with message_set_mut_ind := Induction for message_set Sort Prop
.

Definition justification0 : justification := NoSent Empty.

(**
States are defined as pair between a (regular) set of messages and an
optional message representing the last message sent.
*)

Definition state : Type := set message * option message.

End FullNodeState.
Unset Implicit Arguments.

Definition get_message_set {C V} (s : state C V) : set (message C V) := fst s.

Definition last_sent {C V} (s : state C V) : option (message C V) := snd s.

Section FullNodeStateProperties.

(** ** Full node state properties

This section defines syntactical orders for messages and justifications.

The main purpose of these is to define canonical ways to [make_justification]s
ensuring that whenever two states <<s1>>, <<s2>> are equal as pointed sets,
[make_justification] <<s1>> = [make_justification] <<s2>>
(Lemma [make_justification_set_eq]).

*)

Context
    {C V : Type}
    {about_C : StrictlyComparable C}
    {about_V : StrictlyComparable V}
    .

Definition estimate
  (msg : message C V)
  : C
  :=
  let (c,_,_) := msg in c.

Definition sender
  (msg : message C V)
  : V
  :=
  let (_,v,_) := msg in v.

Definition get_justification
  (msg : message C V)
  : justification C V
  :=
  let (_,_,j) := msg in j.

Definition justification_last_sent
  (j : justification C V)
  : option (message C V)
  :=
  match j with
  | NoSent _ => None
  | LastSent _ m => Some m
  end.

Definition justification_message_set
  (j : justification C V)
  : message_set C V
  :=
  match j with
  | NoSent msgs => msgs
  | LastSent msgs _ => msgs
  end.

Definition message_compare_helper
  (justification_compare : justification C V -> justification C V -> comparison)
  (msg1 msg2 : message C V)
  : comparison
  :=
  let (c1, v1, j1) := msg1 in
  let (c2, v2, j2) := msg2 in
    match compare c1 c2 with
    | Eq =>
      match compare v1 v2 with
      | Eq => justification_compare j1 j2
      | cmp_v => cmp_v
      end
    | cmp_c => cmp_c
    end.

Fixpoint justification_compare
  (sigma1 sigma2 : justification C V)
  : comparison
  :=
  match sigma1, sigma2 with
    | NoSent msgs1, NoSent msgs2 =>
      message_set_compare_helper msgs1 msgs2
    | NoSent _, _ => Lt
    | _, NoSent _ => Gt
    | LastSent msgs1 last1, LastSent msgs2 last2 =>
      match message_set_compare_helper msgs1 msgs2 with
      | Eq => message_compare_helper justification_compare last1 last2
      | cmp => cmp
      end
  end

with message_set_compare_helper
  (msgs1 msgs2 : message_set C V)
  : comparison
  :=
  match msgs1, msgs2 with
  | Empty, Empty => Eq
  | Empty, _ => Lt
  | _, Empty => Gt
  | add m1 msgs1', add m2 msgs2' =>
    match message_compare_helper justification_compare m1 m2 with
    | Eq => message_set_compare_helper msgs1' msgs2'
    | cmp => cmp
    end
  end.

Lemma justification_compare_reflexive
  : CompareReflexive justification_compare.
Proof.
  intro x.
  apply
    (justification_mut_ind
      (fun x : justification C V =>
        forall y : justification C V, justification_compare x y = Eq <-> x = y
      )
      (fun x : message C V =>
        forall y : message C V, message_compare_helper justification_compare x y = Eq <-> x = y
      )
      (fun x : message_set C V =>
        forall y : message_set C V, message_set_compare_helper x y = Eq <-> x = y
      )
    ); intros; simpl; split; intros.
  - destruct y; simpl in H0; try discriminate.
    f_equal. apply H. assumption.
  - subst. apply H. reflexivity.
  - destruct y; try discriminate.
    destruct (message_set_compare_helper m m1) eqn:Hset; try discriminate.
    apply H in Hset.
    apply H0 in H1.
    subst.
    reflexivity.
  - subst. rewrite (proj2 (H m) eq_refl). apply H0. reflexivity.
  - destruct y as (cy, vy, jy).
    destruct (compare c cy) eqn:Hc; try discriminate.
    apply StrictOrder_Reflexive in Hc; subst.
    destruct (compare v vy) eqn:Hv; try discriminate.
    apply StrictOrder_Reflexive in Hv; subst.
    apply H in H0. subst. reflexivity.
  - subst.
    rewrite (proj2 (StrictOrder_Reflexive c c) eq_refl).
    rewrite (proj2 (StrictOrder_Reflexive v v) eq_refl).
    apply H. reflexivity.
  - destruct y; try discriminate. reflexivity.
  - subst. reflexivity.
  - destruct y; try discriminate.
    destruct (message_compare_helper justification_compare m m1) eqn:Hmsg; try discriminate.
    apply H in Hmsg. subst.
    apply H0 in H1. subst.
    reflexivity.
  - subst.
    rewrite (proj2 (H m) eq_refl).
    apply H0.
    reflexivity.
Qed.

Lemma message_compare_helper_reflexive
  : CompareReflexive (message_compare_helper justification_compare).
Proof.
  intros (c1, v1, j1) (c2, v2, j2).
  split.
  - simpl. intro H.
    destruct (compare c1 c2) eqn:Hcmp; try discriminate.
    apply StrictOrder_Reflexive in Hcmp; subst.
    destruct (compare v1 v2) eqn:Hcmp; try discriminate.
    apply StrictOrder_Reflexive in Hcmp; subst.
    apply justification_compare_reflexive in H; subst.
    reflexivity.
  - intro H; inversion H; subst; clear H. simpl.
    rewrite (proj2 (StrictOrder_Reflexive c2 c2) eq_refl).
    rewrite (proj2 (StrictOrder_Reflexive v2 v2) eq_refl).
    apply justification_compare_reflexive.
    reflexivity.
Qed.

Lemma message_set_compare_helper_reflexive
  : CompareReflexive message_set_compare_helper.
Proof.
  intros x.
  induction x; intros; destruct y; simpl; split; intros
  ; try discriminate
  ; try reflexivity
  .
  - destruct (message_compare_helper justification_compare m m0) eqn:Hmsg; try discriminate.
    apply IHx in H. apply message_compare_helper_reflexive in Hmsg; subst; try reflexivity.
  - inversion H; subst.
    rewrite (proj2 (message_compare_helper_reflexive m0 m0) eq_refl).
    apply IHx.
    reflexivity.
Qed.

Lemma justification_compare_transitive
  : CompareTransitive justification_compare.
Proof.
  destruct (@compare_strictorder C about_C) as [Rc Tc].
  destruct (@compare_strictorder V about_V) as [Rv Tv].
  intros x y. generalize dependent x.
  apply
    (justification_mut_ind
      (fun y : justification C V =>
        forall (x z : justification C V) (comp : comparison)
          (Hxy : justification_compare x y = comp)
          (Hyz : justification_compare y z = comp),
          justification_compare x z = comp
      )
      (fun y : message C V =>
        forall (x z : message C V) (comp : comparison)
          (Hxy : message_compare_helper justification_compare x y = comp)
          (Hyz : message_compare_helper justification_compare y z = comp),
          message_compare_helper justification_compare x z = comp
      )
      (fun y : message_set C V =>
        forall (x z : message_set C V) (comp : comparison)
          (Hxy : message_set_compare_helper x y = comp)
          (Hyz : message_set_compare_helper y z = comp),
          message_set_compare_helper x z = comp
      )
    )
  ; intros; destruct x; destruct z; try discriminate; try assumption
  ; simpl in Hxy; simpl in Hyz; simpl
  ; subst; try discriminate.
  - apply H; try assumption. reflexivity.
  - destruct (message_set_compare_helper m m3) eqn:Hset3
    ; destruct (message_set_compare_helper m1 m) eqn:Hset1
    ; try discriminate
    ; try (apply message_set_compare_helper_reflexive in Hset3; subst; rewrite Hset1; reflexivity)
    ; try (apply message_set_compare_helper_reflexive in Hset1; subst; rewrite Hset3; assumption)
    ; rewrite (H m1 m3 _ Hset1 Hset3)
    ; try reflexivity
    .
    apply H0; try assumption.
    reflexivity.
  - destruct (compare c0 c) eqn:Hc0
    ; destruct (compare c c1) eqn:Hc1
    ; try discriminate
    ; try (apply StrictOrder_Reflexive in Hc1; subst; rewrite Hc0; reflexivity)
    ; try (apply StrictOrder_Reflexive in Hc0; subst; rewrite Hc1; assumption)
    ; rewrite (StrictOrder_Transitive c0 c c1 _ Hc0 Hc1)
    ; try reflexivity
    .
    destruct (compare v0 v) eqn:Hv0
    ; destruct (compare v v1) eqn:Hv1
    ; try discriminate
    ; try (apply StrictOrder_Reflexive in Hv1; subst; rewrite Hv0; reflexivity)
    ; try (apply StrictOrder_Reflexive in Hv0; subst; rewrite Hv1; assumption)
    ; rewrite (StrictOrder_Transitive v0 v v1 _ Hv0 Hv1)
    ; try reflexivity
    .
    apply H; try assumption.
    reflexivity.
  - destruct (message_compare_helper justification_compare m m2) eqn:Hmsg2
    ; destruct (message_compare_helper justification_compare m1 m) eqn:Hmsg1
    ; try discriminate
    ; try (apply message_compare_helper_reflexive in Hmsg2; subst; rewrite Hmsg1; reflexivity)
    ; try (apply message_compare_helper_reflexive in Hmsg1; subst; rewrite Hmsg2; assumption)
    ; rewrite (H m1 m2 _ Hmsg1 Hmsg2)
    ; try reflexivity
    .
    apply H0; try assumption.
    reflexivity.
Qed.

Lemma message_compare_helper_transitive
  : CompareTransitive (message_compare_helper justification_compare).
Proof.
  intros (c1, v1, j1) (c2, v2, j2) (c3, v3, j3) comp.
  simpl; intros H12 H23.
  destruct (compare c1 c2) eqn:Hc1; destruct (compare c2 c3) eqn:Hc3; subst
  ; try discriminate
  ; try (apply StrictOrder_Reflexive in Hc1; subst; rewrite Hc3; assumption)
  ; try (apply StrictOrder_Reflexive in Hc3; subst; rewrite Hc1; reflexivity)
  ; rewrite (StrictOrder_Transitive c1 c2 c3 _ Hc1 Hc3)
  ; try reflexivity
  .
  destruct (compare v1 v2) eqn:Hv1; destruct (compare v2 v3) eqn:Hv3; subst; try discriminate
  ; try (apply StrictOrder_Reflexive in Hv1; subst; rewrite Hv3; assumption)
  ; try (apply StrictOrder_Reflexive in Hv3; subst; rewrite Hv1; reflexivity)
  ; rewrite (StrictOrder_Transitive v1 v2 v3 _ Hv1 Hv3); try reflexivity
  .
  rewrite (justification_compare_transitive j1 j2 j3 (justification_compare j1 j2)); try assumption; reflexivity.
Qed.

Lemma justification_compare_strict_order
  : CompareStrictOrder justification_compare.
Proof.
  split.
  - apply justification_compare_reflexive.
  - apply justification_compare_transitive.
Qed.

Global Instance justification_type
  : StrictlyComparable (justification C V) :=
  {
    inhabited := justification0;
    compare := justification_compare;
    compare_strictorder := justification_compare_strict_order;
  }.

Definition message0
  : message C V
  :=
  Msg inhabited inhabited justification0.

Definition message_compare
  : message C V -> message C V -> comparison
  := message_compare_helper justification_compare.

Lemma message_compare_strict_order
  : CompareStrictOrder message_compare.
Proof.
  split.
  - apply message_compare_helper_reflexive.
  - apply message_compare_helper_transitive.
Qed.

Global Instance message_strictorder
  : CompareStrictOrder message_compare := message_compare_strict_order.

Global Instance message_type
  : StrictlyComparable (message C V) :=
  { inhabited := message0;
    compare := message_compare;
    compare_strictorder := message_compare_strict_order;
  }.

Global Instance message_eq : EqDecision (message C V)
  := @strictly_comparable_eq_dec _ message_type.

(* Constructing a StrictOrder type for message_lt *)

Definition message_lt
  : message C V -> message C V -> Prop
  :=
  compare_lt compare.

Global Instance message_lt_strictorder
  : StrictOrder message_lt.
Proof.
  split. apply compare_lt_irreflexive.
  apply compare_lt_transitive.
Defined.

Fixpoint in_message_set
  (m : message C V)
  (msgs : message_set C V)
  : Prop
  :=
  match msgs with
    | Empty => False
    | add m' msgs' => m' = m \/ in_message_set m msgs'
  end.

Definition message_set_incl
  (msgs1 msgs2 : message_set C V)
  : Prop
  := forall (m : message C V), in_message_set m msgs1 -> in_message_set m msgs2.

Definition message_set_eq
  (msgs1 msgs2 : message_set C V)
  : Prop
  := message_set_incl msgs1 msgs2 /\ message_set_incl msgs2 msgs1.

Definition justification_incl
  (j1 j2 : justification C V)
  :=
  message_set_incl (justification_message_set j1) (justification_message_set j2).

Fixpoint message_set_add
  (m : message C V)
  (s : message_set C V)
  : message_set C V
  :=
  match s with
  | Empty => add m Empty
  | add m' s' =>
    match message_compare m m' with
    | Eq => s
    | Lt => add m s
    | Gt => add m' (message_set_add m s')
    end
  end.

Lemma in_message_set_add
  (m m' : message C V)
  (s : message_set C V)
  : in_message_set m (message_set_add m' s) <-> m' = m \/ in_message_set m s.
Proof.
  induction s; simpl. try (split; intros; assumption).
  destruct (message_compare m' m0) eqn:Hcmp; simpl.
  - apply StrictOrder_Reflexive in Hcmp. subst.
    split; intros.
    + right. assumption.
    + destruct H as [H | H]; try assumption.
      left. assumption.
  - split; intros; assumption.
  - rewrite IHs.
    rewrite <- or_assoc.
    rewrite (or_comm (m0 = m) (m' = m)).
    rewrite or_assoc.
    split; intros; assumption.
Qed.

Definition make_message_set
  (msgs : set (message C V))
  : message_set C V
  :=
  fold_right message_set_add Empty msgs.

Lemma in_make_message_set
  (msgs : set (message C V))
  (m : message C V)
  : In m msgs <-> in_message_set m (make_message_set msgs).
Proof.
  induction msgs; simpl; split; intros; try assumption.
  - apply in_message_set_add.
    destruct H as [H | H]; try (left; assumption).
    right.
    apply IHmsgs.
    assumption.
  - apply in_message_set_add in H.
    destruct H as [H | H]; try (left; assumption).
    right.
    apply IHmsgs.
    assumption.
Qed.

Lemma make_message_set_incl
  (msgs1 msgs2 : set (message C V))
  : incl msgs1 msgs2
  <-> message_set_incl (make_message_set msgs1) (make_message_set msgs2).
Proof.
  split; intros Hincl m Hm
  ; apply in_make_message_set; apply in_make_message_set in Hm
  ; apply Hincl
  ; assumption.
Qed.

Lemma make_message_set_eq
  (msgs1 msgs2 : set (message C V))
  : set_eq msgs1 msgs2
  <-> message_set_eq (make_message_set msgs1) (make_message_set msgs2).
Proof.
  split; intros [Heq1 Heq2]; split; apply make_message_set_incl; assumption.
Qed.

Fixpoint unmake_message_set
  (msgs : message_set C V)
  : set (message C V)
  :=
  match msgs with
  | Empty => []
  | add m msgs' => set_add decide_eq m (unmake_message_set msgs')
  end.

Lemma in_unmake_message_set
  (msgs : message_set C V)
  (m : message C V)
  : in_message_set m msgs <-> In m (unmake_message_set msgs).
Proof.
  induction msgs; simpl; split; intros; try assumption.
  - apply set_add_iff.
    rewrite <- IHmsgs.
    destruct H.
    + left. symmetry. assumption.
    + right. assumption.
  - apply set_add_iff in H. rewrite <- IHmsgs in H.
    destruct H.
    + left. symmetry. assumption.
    + right. assumption.
Qed.

Lemma unmake_message_set_incl
  (msgs1 msgs2 : message_set C V)
  : message_set_incl msgs1 msgs2
  <-> incl (unmake_message_set msgs1) (unmake_message_set msgs2).
Proof.
  split; intros Hincl m Hm
  ; apply in_unmake_message_set; apply in_unmake_message_set in Hm
  ; apply Hincl
  ; assumption.
Qed.

Lemma message_set_incl_refl
  (msgs : message_set C V)
  : message_set_incl msgs msgs.
Proof.
  apply unmake_message_set_incl.
  apply incl_refl.
Qed.

Lemma message_set_incl_trans
  (msgs1 msgs2 msgs3 : message_set C V)
  (H12 : message_set_incl msgs1 msgs2)
  (H23 : message_set_incl msgs2 msgs3)
  : message_set_incl msgs1 msgs3.
Proof.
  apply unmake_message_set_incl.
  apply incl_tran with (unmake_message_set msgs2)
  ; apply unmake_message_set_incl
  ; assumption.
Qed.

Lemma justification_incl_refl
  (j : justification C V)
  : justification_incl j j.
Proof.
  destruct j; unfold justification_incl; simpl; apply message_set_incl_refl.
Qed.

Lemma in_justification_recursive
  (c : C)
  (v : V)
  (j j' : justification C V)
  (Hs : justification_incl j' j)
  : ~ in_message_set (Msg c v j) (justification_message_set j').
Proof.
  generalize dependent j.
  revert v. revert c. revert j'.
  apply
    (justification_mut_ind
      (fun j' : justification C V =>
        forall c v j,
          justification_incl j' j ->
          ~ in_message_set (Msg c v j) (justification_message_set j')
      )
      (fun m : message C V =>
        forall (msgs : message_set C V),
          message_set_incl msgs (justification_message_set (get_justification m)) ->
          ~ in_message_set m msgs
      )
      (fun msgs : message_set C V =>
        forall c v j,
          message_set_incl msgs (justification_message_set j) ->
          ~ in_message_set (Msg c v j) msgs
      )
    ); intros; simpl; intro Hin.
  - unfold justification_incl in H0. simpl in H0.
    specialize (H c v j H0). elim H. assumption.
  - unfold justification_incl in H1. simpl in H1.
    specialize (H c v j H1). elim H. assumption.
  - simpl in H0.
    specialize (H c v j (justification_incl_refl j)).
    apply H. apply H0. assumption.
  - assumption.
  - destruct Hin as [Heq | Hin].
    + subst m. simpl in H.
      specialize (H (justification_message_set j) (message_set_incl_refl _)).
      elim H. apply H1. constructor. reflexivity.
    + specialize (H0 c v j). apply H0; try assumption.
      apply message_set_incl_trans with (add m m0); try assumption.
      intros msg Hmsg. right. assumption.
Qed.

Lemma in_justification_recursive'
  (m : message C V)
  (msgs : set (message C V))
  (Hmsgs : justification_message_set (get_justification m) = make_message_set msgs)
  : ~ In m msgs.
Proof.
  destruct m as (c,v, j). simpl in Hmsgs.
  rewrite in_make_message_set. rewrite <- Hmsgs.
  apply in_justification_recursive.
  apply justification_incl_refl.
Qed.

Lemma unmake_message_set_eq
  (msgs1 msgs2 : message_set C V)
  : message_set_eq msgs1 msgs2
  <-> set_eq (unmake_message_set msgs1) (unmake_message_set msgs2).
Proof.
  split; intros [Heq1 Heq2]; split; apply unmake_message_set_incl; assumption.
Qed.

Lemma make_unmake_message_set_eq
  (msgs : set (message C V))
  : set_eq (unmake_message_set (make_message_set msgs)) msgs.
Proof.
  split; intros m Hm.
  - apply in_unmake_message_set in Hm.
    apply in_make_message_set in Hm.
    assumption.
  - apply in_unmake_message_set.
    apply in_make_message_set.
    assumption.
Qed.

Lemma unmake_make_message_set_eq
  (msgs : message_set C V)
  : message_set_eq (make_message_set (unmake_message_set msgs)) msgs.
Proof.
  split; intros m Hm.
  - apply in_make_message_set in Hm.
    apply in_unmake_message_set in Hm.
    assumption.
  - apply in_make_message_set.
    apply in_unmake_message_set.
    assumption.
Qed.

Inductive message_set_locally_sorted
  : message_set C V -> Prop :=
  | LSorted_Empty : message_set_locally_sorted Empty
  | LSorted_one : forall msg,
          message_set_locally_sorted (add msg Empty)
  | LSorted_more : forall msg msg' msgs,
          message_lt msg msg' ->
          message_set_locally_sorted (add msg' msgs) ->
          message_set_locally_sorted (add msg (add msg' msgs))
  .

Lemma message_set_locally_sorted_strong
  (msg : message C V)
  (msgs : message_set C V)
  (Hls : message_set_locally_sorted (add msg msgs))
  (msg' : message C V)
  (Hmsg' : in_message_set msg' msgs)
  : message_lt msg msg'.
Proof.
  remember (add msg msgs) as msgs'.
  generalize dependent msg'. generalize dependent msgs. generalize dependent msg.
  induction Hls; intros; inversion Heqmsgs'; subst; clear Heqmsgs'.
  - inversion Hmsg'.
  - specialize (IHHls  msg' msgs eq_refl).
    destruct Hmsg' as [Hmsg' | Hmsg']; subst; try assumption.
    specialize (IHHls msg'0 Hmsg').
    apply (compare_lt_transitive msg0 msg' msg'0); assumption.
Qed.

Lemma message_set_locally_sorted_tail
  (msg : message C V)
  (msgs : message_set C V)
  (Hls : message_set_locally_sorted (add msg msgs))
  : message_set_locally_sorted msgs.
Proof.
  inversion Hls; subst; try constructor.
  assumption.
Qed.

Lemma message_set_locally_sorted_eq
  (msgs1 msgs2 : message_set C V)
  (Hmsgs1 : message_set_locally_sorted msgs1)
  (Hmsgs2 : message_set_locally_sorted msgs2)
  (Heq : message_set_eq msgs1 msgs2)
  : msgs1 = msgs2.
Proof.
  generalize dependent msgs2.
  induction msgs1; destruct msgs2; intros; try reflexivity.
  - destruct Heq as [_ Hincl].
    specialize (Hincl m); simpl in Hincl.
    elim Hincl.
    left.
    reflexivity.
  - destruct Heq as [Hincl _].
    specialize (Hincl m); simpl in Hincl.
    elim Hincl.
    left.
    reflexivity.
  - assert (Htl1 := message_set_locally_sorted_tail _ _ Hmsgs1).
    assert (Htl2 := message_set_locally_sorted_tail _ _ Hmsgs2).
    specialize (IHmsgs1 Htl1 msgs2 Htl2). destruct Heq as [Hincl12 Hincl21].
    assert (Heqm : m = m0).
    {
      specialize (Hincl12 m). simpl in Hincl12.
      assert (Hm :  m0 = m \/ in_message_set m msgs2)
        by (apply Hincl12; left; reflexivity).
      destruct Hm as [Hm | Hm]; subst; try reflexivity.
      assert (Hlt := message_set_locally_sorted_strong _ _ Hmsgs2 _ Hm).
      specialize (Hincl21 m0). simpl in Hincl21.
      assert (Hm0 :  m = m0 \/ in_message_set m0 msgs1)
        by (apply Hincl21; left; reflexivity).
      destruct Hm0 as [Hm0 | Hm0]; subst; try reflexivity.
      assert (Hlt' := message_set_locally_sorted_strong _ _ Hmsgs1 _ Hm0).
      apply compare_asymmetric in Hlt'.
      unfold message_lt in Hlt. unfold compare_lt in Hlt.
      rewrite Hlt in Hlt'.
      discriminate Hlt'.
    }
    subst.
    f_equal.
    apply IHmsgs1.
    split; intros msg Hmsg.
    + assert (Hlt := message_set_locally_sorted_strong _ _ Hmsgs1 _ Hmsg).
      specialize (Hincl12 msg).
      assert (Hmsg' : in_message_set msg (add m0 msgs2))
        by (apply Hincl12; right; assumption).
      destruct Hmsg'; try assumption.
      subst.
      unfold message_lt in Hlt.
      unfold compare_lt in Hlt.
      rewrite (proj2 (StrictOrder_Reflexive msg msg) eq_refl) in Hlt.
      inversion Hlt.
    + assert (Hlt := message_set_locally_sorted_strong _ _ Hmsgs2 _ Hmsg).
      specialize (Hincl21 msg).
      assert (Hmsg' : in_message_set msg (add m0 msgs1))
        by (apply Hincl21; right; assumption).
      destruct Hmsg'; try assumption.
      subst.
      unfold message_lt in Hlt.
      unfold compare_lt in Hlt.
      rewrite (proj2 (StrictOrder_Reflexive msg msg) eq_refl) in Hlt.
      inversion Hlt.
Qed.

Lemma message_set_add_locally_sorted
  (m : message C V)
  (s : message_set C V)
  (Hs : message_set_locally_sorted s)
  : message_set_locally_sorted (message_set_add m s).
Proof.
  induction Hs.
  - simpl. constructor.
  - simpl.
    destruct (message_compare m msg) eqn:Hcmp
    ; constructor; try assumption
    ; try (constructor; assumption).
    apply compare_asymmetric.
    assumption.
  - simpl. simpl in IHHs.
    destruct (message_compare m msg) eqn:Hcmp.
    + constructor; assumption.
    + repeat (constructor; try assumption).
    + destruct (message_compare m msg') eqn:Hcmp'.
      * constructor; assumption.
      * constructor; try assumption.
        apply compare_asymmetric. assumption.
      * constructor; assumption.
Qed.

Lemma make_message_set_locally_sorted
  (msgs : set (message C V))
  : message_set_locally_sorted (make_message_set msgs).
Proof.
  induction msgs; try constructor.
  simpl.
  apply message_set_add_locally_sorted; assumption.
Qed.

Lemma make_message_set_equal
  (s1 s2 : set (message C V))
  : set_eq s1 s2 <-> make_message_set s1 = make_message_set s2.
Proof.
  split; intro Heq.
  - apply message_set_locally_sorted_eq
    ; try apply make_message_set_locally_sorted.
    apply make_message_set_eq.
    assumption.
  - apply set_eq_tran with (unmake_message_set (make_message_set s2))
    ; try apply make_unmake_message_set_eq.
    rewrite <- Heq. apply set_eq_comm.
    apply make_unmake_message_set_eq.
Qed.

Inductive message_set_recursively_sorted
  : message_set C V -> Prop :=
  | RSorted_Empty : message_set_recursively_sorted Empty
  | RSorted_one
    : forall msg
      (Hmsg : message_recursively_sorted msg),
    message_set_recursively_sorted (add msg Empty)
  | RSorted_more
    : forall msg msg' msgs
      (Hmsg : message_recursively_sorted msg)
      (Hlt : message_lt msg msg')
      (Hmsgs : message_set_recursively_sorted (add msg' msgs)),
    message_set_recursively_sorted (add msg (add msg' msgs))

with message_recursively_sorted
  : message C V -> Prop :=
  | RSorted_msg : forall c v j
    (Hj : justification_recursively_sorted j),
    message_recursively_sorted (Msg c v j)

with justification_recursively_sorted
  : justification C V -> Prop :=
  | RSorted_NoSent
    : forall
      msgs
      (Hmsgs : message_set_recursively_sorted msgs),
    justification_recursively_sorted (NoSent msgs)
  | RSorted_LastSent
    : forall
      msgs
      msg
      (Hmsgs : message_set_recursively_sorted msgs)
      (Hmsg : in_message_set msg msgs),
    justification_recursively_sorted (LastSent msgs msg)
  .

Definition sorted_state_property
  (s : state C V)
  : Prop
  :=
  let (msgs, last) := s in
  Forall message_recursively_sorted msgs
  /\
  match last with
  | None => True
  | Some msg => In msg msgs
  end.

Lemma message_set_recursively_sorted_local
  (msgs : message_set C V)
  (Hrs : message_set_recursively_sorted msgs)
  : message_set_locally_sorted msgs.
Proof.
  induction Hrs; constructor; assumption.
Qed.

Lemma message_set_add_recursively_sorted
  (m : message C V)
  (s : message_set C V)
  (Hm : message_recursively_sorted m)
  (Hs : message_set_recursively_sorted s)
  : message_set_recursively_sorted (message_set_add m s).
Proof.
  induction Hs.
  - simpl. constructor. assumption.
  - simpl.
    destruct (message_compare m msg) eqn:Hcmp
    ; constructor; try assumption
    ; try (constructor; assumption).
    apply compare_asymmetric.
    assumption.
  - simpl. simpl in IHHs.
    destruct (message_compare m msg) eqn:Hcmp.
    + constructor; assumption.
    + repeat (constructor; try assumption).
    + destruct (message_compare m msg') eqn:Hcmp'.
      * constructor; assumption.
      * constructor; try assumption.
        apply compare_asymmetric. assumption.
      * constructor; assumption.
Qed.

Lemma message_set_add_recursively_sorted_iff
  (m : message C V)
  (s : message_set C V)
  : message_set_recursively_sorted (message_set_add m s)
  <-> message_recursively_sorted m /\ message_set_recursively_sorted s.
Proof.
  split.
  - intros Hrs.
    remember (message_set_add m s) as s'.
    generalize dependent s. generalize dependent m.
    induction Hrs; intros; destruct s ; inversion Heqs'; subst.
    + destruct (message_compare m m0); inversion H0.
    + split; try assumption. constructor.
    + destruct (message_compare m m0) eqn:Hcmp; inversion H0; subst; clear H0.
      * apply StrictOrder_Reflexive in Hcmp. subst.
        split; try assumption.
        constructor.
        assumption.
      * destruct s; inversion H2.
        destruct (message_compare m m1); inversion H0.
    + destruct (message_compare m m0) eqn:Hcmp; inversion H0; subst; clear H0.
      * apply StrictOrder_Reflexive in Hcmp. subst.
        split; try assumption.
        constructor; assumption.
      * split; assumption.
      * specialize (IHHrs m s H2).
        destruct IHHrs as [Hm Hs].
        split; try assumption.
        rewrite H2 in *.
        destruct s; constructor; try assumption.
        simpl in H2.
        { destruct (message_compare m m1) eqn:Hm1.
        - inversion H2; subst.
          apply StrictOrder_Reflexive in Hm1. subst.
          apply compare_asymmetric.
          assumption.
        - inversion H2; subst.
          apply compare_asymmetric in Hcmp.
          apply (compare_lt_transitive m0 m m1); assumption.
        - inversion H2; subst.
          assumption.
        }
  - intros [Hm Hs]. apply message_set_add_recursively_sorted; assumption.
Qed.

Lemma make_message_set_recursively_sorted
  (msgs : set (message C V))
  : Forall message_recursively_sorted msgs
  <-> message_set_recursively_sorted (make_message_set msgs).
Proof.
  induction msgs; split; intros Hmsgs; try constructor.
  - specialize (Forall_inv Hmsgs); intro Ha.
    apply Forall_inv_tail in Hmsgs.
    apply IHmsgs in Hmsgs.
    simpl.
    apply message_set_add_recursively_sorted; assumption.
  - simpl in Hmsgs.
    apply message_set_add_recursively_sorted_iff in Hmsgs.
    destruct Hmsgs.
    assumption.
  - simpl in Hmsgs.
    apply message_set_add_recursively_sorted_iff in Hmsgs.
    apply IHmsgs. apply Hmsgs.
Qed.

Definition make_justification
  (s : state C V)
  : justification C V
  :=
  let (msgs, last) := s in
  let msg_set := make_message_set msgs in
  match last with
  | None => NoSent msg_set
  | Some m => LastSent msg_set m
  end.

Lemma make_justification_sorted
  (s : state C V)
  : sorted_state_property s
  <-> justification_recursively_sorted (make_justification s).
Proof.
  destruct s as (msgs, [msg|]); simpl in *; split; try constructor
  ; (destruct H as [Hall Hmsg] || (inversion H; subst))
  ; try exact I
  ; try (apply make_message_set_recursively_sorted; assumption).
  - apply in_make_message_set. assumption.
  - apply in_make_message_set. assumption.
Qed.

Lemma in_make_justification
  (m : message C V)
  (s : state C V)
  : in_message_set m (justification_message_set (make_justification s))
  <-> In m (get_message_set s).
Proof.
  destruct s as [msgs [final|]]; simpl
  ; rewrite <- in_make_message_set
  ; split; intro; assumption.
Qed.

Lemma unmake_message_set_recursively_sorted
  (msgs : message_set C V)
  (Hrs : message_set_recursively_sorted  msgs)
  : Forall message_recursively_sorted (unmake_message_set msgs).
Proof.
  induction msgs; simpl; intros; try constructor.
  apply Forall_forall. intros msg Hmsg.
  apply set_add_iff in Hmsg.
  inversion Hrs; subst; destruct Hmsg; subst; try assumption.
  + inversion H.
  + apply IHmsgs in Hmsgs.
    rewrite Forall_forall in Hmsgs.
    apply Hmsgs.
    assumption.
Qed.

Definition unmake_justification
  (j : justification C V)
  : state C V
  :=
  pair (unmake_message_set (justification_message_set j)) (justification_last_sent j).

Lemma in_unmake_justification
  (m : message C V)
  (j : justification C V)
  : in_message_set m (justification_message_set j)
  <-> In m (get_message_set (unmake_justification j)).
Proof.
  destruct j; simpl
  ; rewrite <- in_unmake_message_set
  ; split; intro; assumption.
Qed.

Lemma unmake_justification_sorted
  (j : justification C V)
  (Hj : justification_recursively_sorted j)
  : sorted_state_property (unmake_justification j).
Proof.
  destruct j; simpl in *; inversion Hj; subst; split; try exact I
  ; try (apply unmake_message_set_recursively_sorted; assumption).
  apply in_unmake_message_set.
  assumption.
Qed.

Definition make_justification_set_eq
  (s1 s2 : state C V)
  : make_justification s1 = make_justification s2
  <-> set_eq (get_message_set s1) (get_message_set s2) /\ last_sent s1 = last_sent s2.
Proof.
  destruct s1 as [msgs1 [lst1|]]; destruct s2 as [msgs2 [lst2|]]
  ; unfold last_sent; unfold get_message_set; simpl; split; intros [Heqs Heq] || intro Heq
  ; inversion Heq; subst; try (split; try reflexivity)
  ; try (apply make_message_set_equal; assumption)
  ; f_equal
  ; apply make_message_set_equal; assumption
  .
Qed.

Section message_oracles.

Fixpoint sent_messages_justification
  (j : justification C V)
  : set (message C V)
  :=
  match j with
  | NoSent _ => []
  | LastSent msgs (Msg c v j) =>
    set_add decide_eq (Msg c v j) (sent_messages_justification j)
  end.

Definition sent_messages
  (s : state C V)
  : set (message C V)
  :=
  match last_sent s with
  | None => []
  | Some (Msg c v j) =>
    set_add decide_eq (Msg c v j) (sent_messages_justification j)
  end.

Definition received_messages
  (s : state C V)
  : set (message C V)
  :=
  set_diff decide_eq (get_message_set s) (sent_messages s).

End message_oracles.

Instance eq_v : EqDecision V := compare_eq_dec.

Definition full_message_observable_messages
  (m : message C V)
  (v : V)
  : set (message C V)
  :=
  if decide (v = sender m) then [m] else [].

End FullNodeStateProperties.


From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From BitBlasting Require Import QFBV CNF BBCommon BBAdd.
From ssrlib Require Import ZAriths Tactics Bools Seqs.
From nbits Require Import NBits.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* ===== bit_blast_saddo ===== *)
(* TODO: check *)

Definition bit_blast_saddo g ls1 ls2: generator * cnf * literal :=
  let (tls1, sign1) := eta_expand (splitmsl ls1) in
  let (tls2, sign2) := eta_expand (splitmsl ls2) in
  let '(g_fa, cs_fa, cout, lrs_fa) := bit_blast_full_adder g lit_ff ls1 ls2 in
  let (ufa, sign_fa) := eta_expand (splitmsl lrs_fa) in
  let (gr, r) := gen g_fa in
  let csr := [::
                [:: neg_lit r; neg_lit sign1; sign2];
                [:: neg_lit r; sign1; neg_lit sign2];
                [:: neg_lit r; neg_lit sign2; neg_lit sign_fa];
                [:: neg_lit r; sign2; sign_fa];
                [:: r; neg_lit sign1; neg_lit sign2; sign_fa];
                [:: r; sign1; sign2; neg_lit sign_fa]
             ] in
  (gr, catrev cs_fa csr, r).

Lemma bit_blast_saddo_correct g bs1 bs2 E ls1 ls2 g' cs lr :
  bit_blast_saddo g ls1 ls2 = (g', cs, lr) ->
  size ls1 == size ls2 ->
  enc_bits E ls1 bs1 ->
  enc_bits E ls2 bs2 ->
  interp_cnf E (add_prelude cs) ->
  enc_bit E lr (Saddo bs1 bs2).
Proof.
  rewrite /bit_blast_saddo /gen.
  dcase (bit_blast_full_adder g lit_ff ls1 ls2) => [[[[g_fa cs_fa] cout_fa ] lrs_fa] Hblast_fa].
  case=> _ <- <-.
  move => Hsz Henc1 Henc2.
  rewrite !add_prelude_catrev.
  move /andP => [Hicnf_fa Hicnf].
  move: (add_prelude_enc_bit_ff Hicnf_fa) => Hencff.
  move: (add_prelude_enc_bit_tt Hicnf_fa) => Henctt.
  dcase (adcB false bs1 bs2) => [[bcout brs] HadcB].
  move: (bit_blast_full_adder_correct Hblast_fa Henc1 Henc2 Hencff Hicnf_fa HadcB (eqP Hsz)).
  move=> [Henc_bcout Henc_brs].
  have Hitt: interp_lit E lit_tt by exact: (eqP Henctt).
  move: (enc_bits_splitmsb Hitt Henc1) => /andP [Henc_s1 Henc_t1].
  move: (enc_bits_splitmsb Hitt Henc2) => /andP [Henc_s2 Henc_t2].
  move: (enc_bits_splitmsb Hitt Henc_brs) => /andP [Henc_sbrs Henc_tbrs].
  move: Hicnf.
  repeat rewrite add_prelude_cons add_prelude_singleton.
  rewrite /Saddo.
  rewrite /=.
  rewrite !interp_lit_neg_lit.
  move => H. split_andb_hyps.
  repeat match goal with H: is_true (E var_tt) |- _ => clear H end.
  rewrite /enc_bit.
  rewrite /= in Henc_tbrs.
  move: Henc_t1 Henc_t2 Henc_tbrs.
  rewrite /addB HadcB /=.
  move=> /eqP <- /eqP <- /eqP <-.
  move: H6 H7 H8 H9 H10 H11.
    by case H_gfa: (E g_fa); case H_s1 :(interp_lit E (lastd lit_ff ls1)); case H_s2: (interp_lit E (lastd lit_ff ls2)); case H_sbrs: (interp_lit E (lastd lit_ff lrs_fa)).
Qed.

Definition mk_env_saddo E g ls1 ls2: env * generator * cnf * literal :=
  let (tls1, sign1) := eta_expand (splitmsl ls1) in
  let (tls2, sign2) := eta_expand (splitmsl ls2) in
  let '(E_fa, g_fa, cs_fa, cout, lrs_fa) := mk_env_full_adder E g lit_ff ls1 ls2 in
  let (ufa, sign_fa) := eta_expand (splitmsl lrs_fa) in
  let (gr, r) := gen g_fa in
  let E' := env_upd E_fa (var_of_lit r) (
                      ((interp_lit E_fa sign1) && (interp_lit E_fa sign2) && ~~ (interp_lit E_fa sign_fa)
                      ) ||
                      (~~(interp_lit E_fa sign1) && ~~(interp_lit E_fa sign2) && (interp_lit E_fa sign_fa))) in
  let csr := [::
                [:: neg_lit r; neg_lit sign1; sign2];
                [:: neg_lit r; sign1; neg_lit sign2];
                [:: neg_lit r; neg_lit sign2; neg_lit sign_fa];
                [:: neg_lit r; sign2; sign_fa];
                [:: r; neg_lit sign1; neg_lit sign2; sign_fa];
                [:: r; sign1; sign2; neg_lit sign_fa]
             ] in
  (E', gr, catrev cs_fa csr, r).

Lemma mk_env_saddo_is_bit_blast_saddo E g ls1 ls2 E' g' cs lr :
  mk_env_saddo E g ls1 ls2 = (E', g', cs, lr) ->
  bit_blast_saddo g ls1 ls2 = (g', cs, lr).
Proof.
  rewrite /mk_env_saddo /bit_blast_saddo /gen.
  case Hmkfadd : (mk_env_full_adder E g lit_ff ls1 ls2)
  => [[[[E_fadd g_fadd] cs_fadd] cout] r_fadd].
  rewrite (mk_env_full_adder_is_bit_blast_full_adder Hmkfadd) {Hmkfadd}.
    by case=> _ <- <- <-.
Qed.

Lemma mk_env_saddo_newer_gen E g ls1 ls2 E' g' cs lr :
  mk_env_saddo E g ls1 ls2 = (E', g', cs, lr) ->
  (g <=? g')%positive.
Proof.
  rewrite /mk_env_saddo /gen.
  case Hmkfadd : (mk_env_full_adder E g lit_ff ls1 ls2)
  => [[[[E_fadd g_fadd] cs_fadd] cout] r_fadd].
  case=> _ <- _ _.
  move: (mk_env_full_adder_newer_gen Hmkfadd) => {Hmkfadd} Hgngf.
  move : (pos_leb_add_diag_r g_fadd 1) => Hgfg1.
    by apply (pos_leb_trans Hgngf Hgfg1).
Qed.

Lemma mk_env_saddo_newer_res E g ls1 ls2 E' g' cs lr :
  mk_env_saddo E g ls1 ls2 = (E', g', cs, lr) ->
  newer_than_lit g' lr.
Proof.
  rewrite /mk_env_saddo /gen.
  case Hmkfadd : (mk_env_full_adder E g lit_ff ls1 ls2)
  => [[[[E_fadd g_fadd] cs_fadd] cout] r_fadd].
  case=> _ <- _ <-.
    by apply newer_than_lit_add_diag_r.
Qed.

Lemma mk_env_saddo_newer_cnf E g ls1 ls2 E' g' cs lr :
  mk_env_saddo E g ls1 ls2 = (E', g', cs, lr) ->
  newer_than_lit g lit_tt ->
  newer_than_lits g ls1 -> newer_than_lits g ls2 ->
  newer_than_cnf g' cs.
Proof.
  rewrite /mk_env_saddo /gen.
  case Hmkfadd : (mk_env_full_adder E g lit_ff ls1 ls2)
  => [[[[E_fadd g_fadd] cs_fadd] cout] r_fadd].
  case=> _ <- <- _ Hgt Hgl1 Hgl2. rewrite /= !newer_than_cnf_catrev.
  generalize Hgt; rewrite newer_than_lit_tt_ff => Hgff .
  (* newer_than_cnf (g_fadd+1) cs_fadd *)
  move : (mk_env_full_adder_newer_cnf Hmkfadd Hgl1 Hgl2 Hgt Hgff) => Hgfcf.
  move : (pos_leb_add_diag_r g_fadd 1) => Hgfg1.
  rewrite (newer_than_cnf_le_newer Hgfcf Hgfg1) /=.
  (* others *)
  rewrite !newer_than_lit_neg.
  rewrite /=.
  move: (mk_env_full_adder_newer_gen Hmkfadd) => Hgf.
  move: (pos_leb_trans Hgf Hgfg1) => Hggf1.
  move : (newer_than_lits_splitmsl Hgt Hgl1) => /andP [_ Hgs1].
  move : (newer_than_lits_splitmsl Hgt Hgl2) => /andP [_ Hgs2].
  rewrite (newer_than_lit_le_newer Hgs1 Hggf1) (newer_than_lit_le_newer Hgs2 Hggf1).
  move: (mk_env_full_adder_newer_res Hmkfadd) => H.
  have Hgt2: newer_than_lit g_fadd lit_tt by t_newer_hook.
  move: (newer_than_lits_splitmsl Hgt2 H) => /andP /= [_ Hgsfa].
  rewrite (newer_than_lit_le_newer Hgsfa Hgfg1).
  rewrite /newer_than_lit /newer_than_var /=.
    by rewrite (pos_ltb_add_diag_r g_fadd 1).
Qed.

Lemma mk_env_saddo_preserve E g ls1 ls2 E' g' cs lr :
    mk_env_saddo E g ls1 ls2 = (E', g', cs, lr) ->
    env_preserve E E' g.
Proof.
  rewrite /mk_env_saddo /gen.
  case Hmkfadd : (mk_env_full_adder E g lit_ff ls1 ls2)
  => [[[[E_fadd g_fadd] cs_fadd] cout] r_fadd].
  case=> <- _ _ _.
  move : (mk_env_full_adder_preserve Hmkfadd) => HpEnEfgn.
  move : (mk_env_full_adder_newer_gen Hmkfadd) => {Hmkfadd} Hgngf.
  eapply env_preserve_trans.
  exact: HpEnEfgn.
  eapply env_preserve_le.
  exact: env_upd_eq_preserve.
  exact: Hgngf.
Qed.

Lemma mk_env_saddo_sat E g ls1 ls2 E' g' cs lr :
  mk_env_saddo E g ls1 ls2 = (E', g', cs, lr) ->
  newer_than_lit g lit_tt ->
  newer_than_lits g ls1 -> newer_than_lits g ls2 ->
  interp_cnf E' cs.
Proof.
  rewrite /mk_env_saddo /gen.
  case Henv_fa : (mk_env_full_adder E g lit_ff ls1 ls2)
  => [[[[E_fa g_fa] cs_fa] cout] r_fa].
  case=> <- _ <- _ Hngg Hngls1 Hngls2.
  generalize Hngg; rewrite newer_than_lit_tt_ff => Hgff .
  rewrite !interp_cnf_catrev.
  rewrite !interp_cnf_cons.
  remember (env_upd E_fa g_fa
           (interp_lit E_fa (lastd lit_ff ls1) && interp_lit E_fa (lastd lit_ff ls2) &&
            ~~ interp_lit E_fa (lastd lit_ff r_fa)
            || ~~ interp_lit E_fa (lastd lit_ff ls1) && ~~ interp_lit E_fa (lastd lit_ff ls2) &&
               interp_lit E_fa (lastd lit_ff r_fa))) as Ef.
  move: (mk_env_full_adder_sat Henv_fa Hngls1 Hngls2 Hngg Hgff) => Hicnf_fa.
  move: (mk_env_full_adder_newer_gen Henv_fa) => Hggfa.
  move: (mk_env_full_adder_newer_cnf Henv_fa Hngls1 Hngls2 Hngg Hgff) => H.
  move: (mk_env_full_adder_preserve Henv_fa) => Hpre_fa.
  have: (env_preserve E_fa Ef g_fa) => Hpre_ef.
  {
    rewrite HeqEf.
    exact: env_upd_eq_preserve.
  }
  have -> : (interp_cnf Ef cs_fa).
  {
      by rewrite (env_preserve_cnf Hpre_ef H).
  }
  rewrite /=.
  rewrite !interp_lit_neg_lit.
  move: (newer_than_lits_le_newer Hngls1 Hggfa) => Hngfals1.
  move: (newer_than_lits_le_newer Hngls2 Hggfa) => Hngfals2.
  move: (mk_env_full_adder_newer_res Henv_fa) => Hngfarfa.
  have Hgfatt: (newer_than_lit g_fa lit_tt) by t_newer_hook.
  move: (newer_than_lits_splitmsl Hgfatt Hngfals1) => /andP [ _ Hnfa_s1 ].
  move: (newer_than_lits_splitmsl Hgfatt Hngfals2) => /andP [ _ Hnfa_s2 ].
  move: (newer_than_lits_splitmsl Hgfatt Hngfarfa) => /andP [ _ Hnfa_sfa ].
  rewrite !(env_preserve_lit Hpre_ef Hnfa_s1).
  rewrite !(env_preserve_lit Hpre_ef Hnfa_s2).
  rewrite !(env_preserve_lit Hpre_ef Hnfa_sfa).
  rewrite HeqEf. rewrite !env_upd_eq.
  rewrite /=.
    by case (interp_lit E_fa (lastd lit_ff ls1));
      case (interp_lit E_fa (lastd lit_ff ls2));
      case (interp_lit E_fa (lastd lit_ff r_fa)).
Qed.

Lemma mk_env_saddo_env_equal E1 E2 g ls1 ls2 E1' E2' g1' g2' cs1 cs2 lr1 lr2 :
  env_equal E1 E2 ->
  mk_env_saddo E1 g ls1 ls2 = (E1', g1', cs1, lr1) ->
  mk_env_saddo E2 g ls1 ls2 = (E2', g2', cs2, lr2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lr1 = lr2.
Proof.
  rewrite /mk_env_saddo => Heq.
  dcase (mk_env_full_adder E1 g lit_ff ls1 ls2)
  => [[[[[E_fa1 g_fa1] cs_fa1] cout_fa1] lrs_fa1] Hfa1].
  dcase (mk_env_full_adder E2 g lit_ff ls1 ls2)
  => [[[[[E_fa2 g_fa2] cs_fa2] cout_fa2] lrs_fa2] Hfa2].
  move: (mk_env_full_adder_env_equal Heq Hfa1 Hfa2)
  => {Heq Hfa1 Hfa2} [Heq [? [? [? ?]]]]; subst.
  dcase (gen g_fa2) => [[g' r'] Hg']. case=> ? ? ? ?; case=> ? ? ? ?; subst.
  repeat split. rewrite !(env_equal_interp_lit _ Heq). apply: env_equal_upd.
  assumption.
Qed.


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Strings.String.
Require Import Language LibTactics.
Require Import SubAndTopLike Appsub.
Require Import Ptype Disjoint Value.
Require Import Consistent Tred Papp.

Set Printing Parentheses.

Theorem determinism:
  forall (e e1 e2 : trm) (A : typ),
    typing nil e A ->
    step e e1 -> step e e2 -> e1 = e2.
Proof with eauto with determinism.
  intros e e1 e2 A Htyp Hstep1 Hstep2.
  gen e2 A.
  dependent induction Hstep1; intros.
  - dependent destruction Hstep2...
  - dependent destruction Hstep2...
  - dependent destruction Hstep2...
    eapply papp_determinism. eapply H. eapply H0. eapply H1. eapply H4. eapply Htyp.
  - dependent destruction Hstep2...
    + dependent destruction Htyp.
      eapply tred_determinism; eauto.
      eapply consistent_reflexivity; eauto 3.
  - dependent destruction Hstep2...
    + assert (Heq: e' = e'0).
      dependent destruction Htyp; eauto.
      congruence.
  - dependent destruction Hstep2...
    + dependent destruction Htyp; eauto.
      assert (e1' = e1'0); eauto. congruence.
  - dependent destruction Hstep2...
    + dependent destruction Htyp.
      assert (e2' = e2'0); eauto. congruence.
  - dependent destruction Hstep2...
    + assert (e1' = e1'0).
      dependent destruction Htyp; eapply IHHstep1; eauto.
      congruence.
  - dependent destruction Hstep2...
    assert (e2' = e2'0); eauto.
    dependent destruction Htyp; eauto.
    congruence.
Qed.

Theorem preservation :
  forall (e e' : trm) (A: typ),
    typing nil e A ->
    step e e' ->
    (exists B, typing nil e' B /\ isomorphic B A).
Proof.
  intros e e' A Htyp Hred.
  dependent induction Htyp; intros; try solve [inversion Hred].
  - dependent destruction Hred.
    exists typ_int. split; eauto.
  - dependent destruction Hred.
    exists (typ_arrow A B). split; eauto.
  - dependent destruction Hred.
    + admit.
    + admit.
  - dependent destruction Hred; eauto.
    + admit.
    + admit.
    + admit.
  - admit.
  - admit.
Abort.

Theorem progress :
  forall (e : trm) (A : typ),
    typing nil e A ->
    value e \/ exists e', step e e'.
Proof.
  introv Htyp.
  dependent induction Htyp; eauto.
  - inversion H0.
  - destruct IHHtyp; eauto.
    + right.
      eapply tred_progress in Htyp; eauto.
      destruct Htyp.
      exists x. eapply step_anno_value; eauto.
    + assert (value (trm_anno e A) \/ not (value (trm_anno e A))).
      eapply value_or_not_value.
      destruct H1; eauto.
      right. destruct H0. exists (trm_anno x A); eauto.
  - right. destruct IHHtyp1; destruct IHHtyp2; eauto 3.
    + assert (toplike B \/ not (toplike B)).
      eapply toplike_or_not_toplike.
      destruct H2.
      * exists (trm_anno (trm_int 1) B); eauto.
      * admit.
    + destruct H1; eauto.
    + destruct H0; eauto.
    + destruct H1; eauto.
  - destruct IHHtyp1; destruct IHHtyp2; eauto.
    + destruct H1; eauto.
    + destruct H0; eauto.
    + destruct H0; eauto.
Admitted.


Require Export SystemFR.ErasedTypeRefine.
Require Export SystemFR.ScalaDepSugar.

Opaque reducible_values.

Lemma reducible_singleton:
  forall ρ t T,
    valid_interpretation ρ ->
    [ ρ ⊨ t : T ] ->
    [ ρ ⊨ t : T_singleton T t ].
Proof.
  unfold T_singleton; steps.
  apply reducible_type_refine with uu;
    repeat step || apply reducible_value_expr || open_none ||
           (rewrite shift_nothing2 by eauto with wf) ||
           simp_red_goal;
    t_closer;
      try solve [ apply equivalent_refl; steps; t_closer ].
Qed.

Lemma reducible_singleton2:
  forall ρ t1 t2 T,
    valid_interpretation ρ ->
    [ t1 ≡ t2 ] ->
    [ ρ ⊨ t1 : T ] ->
    [ ρ ⊨ t1 : T_singleton T t2 ].
Proof.
  unfold T_singleton; steps.
  apply reducible_type_refine with uu;
    repeat step || apply reducible_value_expr || open_none ||
           (rewrite shift_nothing2 by eauto with wf) ||
           simp_red_goal;
    t_closer;
      try solve [ apply equivalent_refl; steps; t_closer ].
Qed.

Lemma reducible_values_singleton:
  forall ρ v t T,
    valid_interpretation ρ ->
    wf t 0 ->
    [ t ≡ v ] ->
    [ ρ ⊨ v : T ]v ->
    [ ρ ⊨ v : T_singleton T t ]v.
Proof.
  unfold T_singleton;
    repeat step || simp_red || exists uu ||
           (rewrite (open_none t) by auto) ||
           (rewrite shift_nothing2 by auto);
    t_closer;
    eauto using equivalent_sym.
Qed.

Lemma open_reducible_singleton:
  forall Θ Γ t T,
    is_erased_term t ->
    wf t 0 ->
    subset (fv t) (support Γ) ->
    [ Θ; Γ ⊨ t : T ] ->
    [ Θ; Γ ⊨ t : T_singleton T t ].
Proof.
  intros.
  unfold T_singleton.
  apply open_reducible_type_refine with uu;
    repeat step || rewrite pfv_shift2 ||
           unfold open_reducible ||
           simp_red ||
           apply reducible_value_expr ||
           (rewrite shift_nothing2 by auto) ||
           (rewrite open_none by auto);
    eauto with erased wf fv;
    try solve [ apply equivalent_refl; t_closer ].
Qed.