From HoTT Require Import TruncType ExcludedMiddle abstract_algebra.
From HoTT Require Import PropResizing.PropResizing.
From HoTT Require Import Spaces.Nat Spaces.Card.
From HoTT Require Import Equiv.BiInv.
From HoTT Require Import HIT.unique_choice.

From HoTT.Sets Require Import Ordinals Hartogs Powers GCH AC.

Open Scope type.

(* The proof of Sierpinski's results that GCH implies AC given in this file consists of 2 ingredients:
   1. Adding powers of infinite sets does not increase the cardinality (path_infinite_power).
   2. A variant of Cantor's theorem saying that P(X) <= (X + Y) implies P(X) <= Y for large X (Cantor_injects_injects).
   Those are used to obtain that cardinality-controlled functions are well-behaved in the presence of GCH (Sierpinski),
   from which we obtain by instantiation with the Hartogs number that every set embeds into an ordinal,
   which is enough to conclude GCH -> AC (GCH_AC) since the well-ordering theorem implies AC (WO_AC). *)

(** * Constructive equivalences *)

(* For the 1. ingredient, we establish a bunch of paths and conclude the wished result by equational reasoning. *)

Section Preparation.

Context {UA : Univalence}.

Lemma path_sum_prod X Y Z :
  (X -> Z) * (Y -> Z) = ((X + Y) -> Z).
Proof.
  apply path_universe_uncurried. apply equiv_sum_distributive.
Qed.

Lemma path_sum_assoc X Y Z :
  X + (Y + Z) = X + Y + Z.
Proof.
  symmetry. apply path_universe_uncurried. apply equiv_sum_assoc.
Qed.

Lemma path_sum_bool X :
  X + X = Bool * X.
Proof.
  apply path_universe_uncurried. srapply equiv_adjointify.
  - exact (fun x => match x with inl x => (true, x) | inr x => (false, x) end).
  - exact (fun x => match x with (true, x) => inl x | (false, x) => inr x end).
  - intros [[]]; reflexivity.
  - intros []; reflexivity.
Qed.

Lemma path_unit_nat :
  Unit + nat = nat.
Proof.
  apply path_universe_uncurried. srapply equiv_adjointify.
  - exact (fun x => match x with inl _ => O | inr n => S n end).
  - exact (fun n => match n with O => inl tt | S n => inr n end).
  - now intros [].
  - now intros [[]|n].
Qed.

Lemma path_unit_fun X :
  X = (Unit -> X).
Proof.
  apply path_universe_uncurried. apply equiv_unit_rec.
Qed.

(** * Equivalences relying on LEM **)

Context {EM : ExcludedMiddle}.

Lemma PE (P P' : HProp) :
  P <-> P' -> P = P'.
Proof.
  intros [f g]. apply path_trunctype.
  exists f. apply isequiv_biinv. split.
  - exists g. intros x. apply P.
  - exists g. intros x. apply P'.
Qed.

Lemma path_bool_prop :
  HProp = Bool.
Proof.
  apply path_universe_uncurried. srapply equiv_adjointify.
  - exact (fun P => if LEM P _ then true else false).
  - exact (fun b : Bool => if b then merely Unit else merely Empty).
  - intros []; destruct LEM as [H|H]; auto.
    + destruct (H (tr tt)).
    + apply (@merely_destruct Empty); easy.
  - intros P. destruct LEM as [H|H]; apply PE.
    + split; auto. intros _. apply tr. exact tt.
    + split; try easy. intros HE. apply (@merely_destruct Empty); easy.
Qed.

Lemma path_bool_subsingleton :
  (Unit -> HProp) = Bool.
Proof.
  rewrite <- path_unit_fun. apply path_bool_prop.
Qed.

Lemma path_pred_sum X (p : X -> HProp) :
  X = sig p + sig (fun x => ~ p x).
Proof.
  apply path_universe_uncurried. srapply equiv_adjointify.
  - intros x. destruct (LEM (p x) _) as [H|H]; [left | right]; now exists x.
  - intros [[x _]|[x _]]; exact x.
  - cbn. intros [[x Hx]|[x Hx]]; destruct LEM as [H|H]; try contradiction.
    + enough (H = Hx) as -> by reflexivity. apply p.
    + enough (H = Hx) as -> by reflexivity. apply path_forall. now intros HP.
  - cbn. intros x. now destruct LEM.
Qed.

Definition ran {X Y : Type} (f : X -> Y) :=
  fun y => hexists (fun x => f x = y).

Lemma path_ran {X} {Y : HSet} (f : X -> Y) :
  IsInjective f -> sig (ran f) = X.
Proof.
  intros Hf. apply path_universe_uncurried. srapply equiv_adjointify.
  - intros [y H]. destruct (iota (fun x => f x = y) _) as [x Hx]; try exact x.
    split; try apply H. intros x x'. cbn. intros Hy Hy'. rewrite <- Hy' in Hy. now apply Hf.
  - intros x. exists (f x). apply tr. exists x. reflexivity.
  - cbn. intros x. destruct iota as [x' H]. now apply Hf.
  - cbn. intros [y x]. apply path_sigma_hprop. cbn.
    destruct iota as [x' Hx]. apply Hx.
Qed.

(** * Equivalences on infinite sets *)

Lemma path_infinite_unit (X : HSet) :
  infinite X -> Unit + X = X.
Proof.
  intros [f Hf]. rewrite (@path_pred_sum X (ran f)).
  rewrite (path_ran _ Hf). rewrite path_sum_assoc.
  rewrite path_unit_nat. reflexivity.
Qed.

Fact path_infinite_power (X : HSet) :
  infinite X -> (X -> HProp) + (X -> HProp) = (X -> HProp).
Proof.
  intros H. rewrite path_sum_bool. rewrite <- path_bool_subsingleton.
  rewrite path_sum_prod. now rewrite path_infinite_unit.
Qed.

(** * Variants of Cantors's theorem *)

(* For the 2. ingredient, we give a preliminary version (Cantor_path_inject) to see the idea,
   as well as a stronger refinement (Cantor_injects_injects) which is then a mere reformulation. *)

Context {PR : PropResizing}.

Lemma Cantor X (f : X -> X -> Type) :
  { p | forall x, f x <> p }.
Proof.
  exists (fun x => ~ f x x). intros x H.
  enough (Hx : f x x <-> ~ f x x).
  - apply Hx; apply Hx; intros H'; now apply Hx.
  - pattern (f x) at 1. rewrite H. reflexivity.
Qed.

Lemma hCantor {X} (f : X -> X -> HProp) :
  { p | forall x, f x <> p }.
Proof.
  exists (fun x => Build_HProp (f x x -> Empty)). intros x H.
  enough (Hx : f x x <-> ~ f x x).
  - apply Hx; apply Hx; intros H'; now apply Hx.
  - pattern (f x) at 1. rewrite H. reflexivity.
Qed.

Definition clean_sum {X Y Z} (f : X -> Y + Z) :
  (forall x y, f x <> inl y) -> forall x, { z | inr z = f x }.
Proof.
  intros Hf. enough (H : forall x a, a = f x -> {z : Z & inr z = f x}).
  - intros x. now apply (H x (f x)).
  - intros x a Hxa. specialize (Hf x). destruct (f x) as [y|z].
    + apply Empty_rect. now apply (Hf y).
    + now exists z.
Qed.

Fact Cantor_path_injection {X Y} :
  (X -> HProp) = (X + Y) -> (X + X) = X -> Injection (X -> HProp) Y.
Proof.
  intros H1 H2. assert (H : X + Y = (X -> HProp) * (X -> HProp)).
  - now rewrite <- H1, path_sum_prod, H2.
  - apply equiv_path in H as [f [g Hfg Hgf _]].
    pose (f' x := fst (f (inl x))). destruct (hCantor f') as [p Hp].
    pose (g' q := g (p, q)). assert (H' : forall q x, g' q <> inl x).
    + intros q x H. apply (Hp x). unfold f'. rewrite <- H. unfold g'. now rewrite Hfg.
    + exists (fun x => proj1 (clean_sum _ H' x)). intros q q' H. assert (Hqq' : g' q = g' q').
      * destruct clean_sum as [z <-]. destruct clean_sum as [z' <-]. cbn in H. now rewrite H.
      * unfold g' in Hqq'. change (snd (p, q) = snd (p, q')).
        rewrite <- (Hfg (p, q)), <- (Hfg (p, q')). now rewrite Hqq'.
Qed.

(* Version just requiring propositional injections *)

Lemma Cantor_rel X (R : X -> (X -> HProp) -> HProp) :
  (forall x p p', R x p -> R x p' -> merely (p = p')) -> { p | forall x, ~ R x p }.
Proof.
  intros HR. pose (pc x := Build_HProp (resize_hprop (forall p : X -> HProp, R x p -> ~ p x))).
  exists pc. intros x H. enough (Hpc : pc x <-> ~ pc x). 2: split.
  { apply Hpc; apply Hpc; intros H'; now apply Hpc. }
  - intros Hx. apply equiv_resize_hprop in Hx. now apply Hx.
  - intros Hx. apply equiv_resize_hprop. intros p Hp.
    eapply merely_destruct; try apply (HR _ _ _ Hp H). now intros ->.
Qed.

Lemma InjectsInto_power_morph X Y :
  InjectsInto X Y -> InjectsInto (X -> HProp) (Y -> HProp).
Proof.
  intros HF. eapply merely_destruct; try apply HF. intros [f Hf].
  apply tr. exists (fun p => fun y => hexists (fun x => p x /\ y = f x)).
  intros p q H. apply path_forall. intros x. apply PE. split; intros Hx.
  - assert (Hp : (fun y : Y => hexists (fun x : X => p x * (y = f x))) (f x)). { apply tr. exists x. split; trivial. }
    pattern (f x) in Hp. rewrite H in Hp. eapply merely_destruct; try apply Hp. now intros [x'[Hq <- % Hf]].
  - assert (Hq : (fun y : Y => hexists (fun x : X => q x * (y = f x))) (f x)). { apply tr. exists x. split; trivial. }
    pattern (f x) in Hq. rewrite <- H in Hq. eapply merely_destruct; try apply Hq. now intros [x'[Hp <- % Hf]].
Qed.

Fact Cantor_injects_injects {X Y : HSet} :
  InjectsInto (X -> HProp) (X + Y) -> InjectsInto (X + X) X -> InjectsInto (X -> HProp) Y.
Proof.
  intros H1 H2. assert (HF : InjectsInto ((X -> HProp) * (X -> HProp)) (X + Y)).
  - eapply InjectsInto_trans; try apply H1.
    eapply InjectsInto_trans; try apply InjectsInto_power_morph, H2.
    rewrite path_sum_prod. apply tr. reflexivity.
  - eapply merely_destruct; try apply HF. intros [f Hf].
    pose (R x p := hexists (fun q => f (p, q) = inl x)). destruct (@Cantor_rel _ R) as [p Hp].
    { intros x p p' H3 H4. eapply merely_destruct; try apply H3. intros [q Hq].
      eapply merely_destruct; try apply H4. intros [q' Hq']. apply tr.
      change p with (fst (p, q)). rewrite (Hf (p, q) (p', q')); trivial. now rewrite Hq, Hq'. }
    pose (f' q := f (p, q)). assert (H' : forall q x, f' q <> inl x).
    + intros q x H. apply (Hp x). apply tr. exists q. apply H.
    + apply tr. exists (fun x => proj1 (clean_sum _ H' x)). intros q q' H. assert (Hqq' : f' q = f' q').
      * destruct clean_sum as [z <-]. destruct clean_sum as [z' <-]. cbn in H. now rewrite H.
      * apply Hf in Hqq'. change q with (snd (p, q)). now rewrite Hqq'.
Qed.

End Preparation.

(** * Sierpinski's Theorem *)

Section Sierpinski.

Context {UA : Univalence}.
Context {EM : ExcludedMiddle}.
Context {PR : PropResizing}.

Definition powfix X :=
  forall n, (power_iterated X n + power_iterated X n) = (power_iterated X n).

Variable HN : HSet -> HSet.

Hypothesis HN_ninject : forall X, ~ InjectsInto (HN X) X.

Variable HN_bound : nat.
Hypothesis HN_inject : forall X, InjectsInto (HN X) (power_iterated X HN_bound).

(* This section then concludes the intermediate result that abstractly,
   any function HN behaving like the Hartogs number is tamed in the presence of GCH.
   Morally we show that X <= HN(X) for all X, we just ensure that X is large enough by considering P(N + X). *)

Lemma InjectsInto_sum X Y X' Y' :
  InjectsInto X X' -> InjectsInto Y Y' -> InjectsInto (X + Y) (X' + Y').
Proof.
  intros H1 H2.
  eapply merely_destruct; try apply H1. intros [f Hf].
  eapply merely_destruct; try apply H2. intros [g Hg].
  apply tr. exists (fun z => match z with inl x => inl (f x) | inr y => inr (g y) end).
  intros [x|y] [x'|y'] H.
  - apply ap. apply Hf. apply path_sum_inl with Y'. apply H.
  - now apply inl_ne_inr in H.
  - now apply inr_ne_inl in H.
  - apply ap. apply Hg. apply path_sum_inr with X'. apply H.
Qed.

(* The main proof is by induction on the cardinality bound for HN.
   As the Hartogs number is bounded by P^3(X), we'd actually just need finitely many instances of GCH. *)

Lemma Sierpinski_step (X : HSet) n :
  GCH -> infinite X -> powfix X -> InjectsInto (HN X) (power_iterated X n) -> InjectsInto X (HN X).
Proof.
  intros gch H1 H2 Hi. induction n.
  - now apply HN_ninject in Hi.
  - destruct (gch (Build_HSet (power_iterated X n)) (Build_HSet (power_iterated X n + HN X))) as [H|H].
    + now apply infinite_power_iterated.
    + apply tr. exists inl. intros x x'. apply path_sum_inl.
    + eapply InjectsInto_trans.
      * apply InjectsInto_sum; try apply Hi. apply tr, Injection_power. exact _.
      * cbn. specialize (H2 (S n)). cbn in H2. rewrite H2. apply tr, Injection_refl.
    + apply IHn. eapply InjectsInto_trans; try apply H. apply tr. exists inr. intros x y. apply path_sum_inr.
    + apply InjectsInto_trans with (power_iterated X (S n)); try apply tr, Injection_power_iterated.
      cbn. apply (Cantor_injects_injects H). rewrite (H2 n). apply tr, Injection_refl.
Qed.

Theorem GCH_injects' (X : HSet) :
  GCH -> infinite X -> InjectsInto X (HN (Build_HSet (X -> HProp))).
Proof.
  intros gch HX. eapply InjectsInto_trans; try apply tr, Injection_power; try apply X.
  apply (@Sierpinski_step (Build_HSet (X -> HProp)) HN_bound gch).
  - apply infinite_inject with X; trivial. apply Injection_power. apply X.
  - intros n. cbn. rewrite !power_iterated_shift. eapply path_infinite_power. cbn. now apply infinite_power_iterated.
  - apply HN_inject.
Qed.

Theorem GCH_injects (X : HSet) :
  GCH -> InjectsInto X (HN (Build_HSet (Build_HSet (nat + X) -> HProp))).
Proof.
  intros gch. eapply InjectsInto_trans with (nat + X).
  - apply tr. exists inr. intros x y. apply path_sum_inr.
  - apply GCH_injects'; trivial. exists inl. intros x y. apply path_sum_inl.
Qed.

End Sierpinski.

(* Main result: GCH implies AC *)

Theorem GCH_AC {UA : Univalence} {PR : PropResizing} {LEM : ExcludedMiddle} :
  GCH -> Choice_type.
Proof.
  intros gch.
  apply WO_AC. intros X. apply tr. exists (hartogs_number (Build_HSet (Build_HSet (nat + X) -> HProp))).
  unshelve eapply (@GCH_injects UA LEM PR hartogs_number _ 3 _ X gch).
  - intros Y. intros H. eapply merely_destruct; try apply H. apply hartogs_number_no_injection.
  - intros Y. apply tr. apply hartogs_number_injection.
Qed.

(* Note that the assumption of LEM is actually not necessary due to GCH_LEM. *)


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import PendingCheckAux.Spec.
Require Import RVIC4.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition check_pending_ptimers_spec (rec: Pointer) (adt: RData) : option RData :=
    let slot := (offset rec) in
    rely (peq (base rec) buffer_loc);
    rely prop_dec (0 <= slot < 16);
    when gidx == (buffer (priv adt)) @ slot;
    let cntp_ctl := r_cntp_ctl_el0 (cpu_regs (priv adt)) in
    rely is_int64 cntp_ctl; rely is_gidx gidx;
    let gn := (gs (share adt)) @ gidx in
    rely (g_tag (ginfo gn) =? GRANULE_STATE_REC);
    rely (gtype gn =? GRANULE_STATE_REC);
    rely (g_inited (gro gn));
    rely (ref_accessible gn CPU_ID);
    let cntp_is_masked := (if Z.land cntp_ctl 2 =? 2 then 1 else 0) in
    let ptimer_is_asserted := (t_asserted (g_ptimer (grec gn))) in
    let cntp_condition_met := __timer_condition_met cntp_ctl in
    rely is_int ptimer_is_asserted; rely (g_rec (gro gn) =? gidx);
    if ptimer_is_asserted =? 0 then
      let g' := gn {grec : (grec gn) {g_ptimer : (g_ptimer (grec gn)) {t_masked : cntp_is_masked}}} in
      let adt := adt {share : (share adt) {gs : (gs (share adt)) # gidx == g'}} in
      if (cntp_is_masked =? 0) && cntp_condition_met then
        when adt == query_oracle adt;
        let gn' := (gs (share adt)) @ gidx in
        rely (g_tag (ginfo gn') =? GRANULE_STATE_REC);
        rely (gtype gn' =? GRANULE_STATE_REC);
        rely (ref_accessible gn' CPU_ID);
        rely prop_dec (glock gn' = None);
        let cnthctl := (r_cnthctl_el2 (g_regs (grec gn'))) in
        rely is_int64 cnthctl;
        let idx := INTID_PTIMER_EL1 / 64 in
        let bit := INTID_PTIMER_EL1 mod 64 in
        let bits := (r_pending_bits (g_rvic (gnorm gn'))) @ idx in
        let bits' := Z.lor bits (Z.shiftl 1 bit) in
        let rvic' := (g_rvic (gnorm gn'))
                      {r_pending_bits: (r_pending_bits (g_rvic (gnorm gn'))) # idx == bits'} in
        let r := grec gn' in
        let g' := gn' {gnorm: (gnorm gn') {g_rvic: rvic'}}
                      {grec: r {g_ptimer: (g_ptimer r) {t_asserted: 1}}
                               {g_regs: (g_regs r) {r_cnthctl_el2: Z.land cnthctl NOT_CNTHCTL_EL2_EL1PTEN}}} in
        let e := EVT CPU_ID (ACQ gidx) in
        let e' := EVT CPU_ID (REL gidx (g' {glock: Some CPU_ID})) in
        Some adt {log: e' :: e :: log adt}
            {priv: (priv adt) {cpu_regs: (cpu_regs (priv adt))
                                            {r_cntp_ctl_el0: Z.lor cntp_ctl CNTx_CTL_IMASK}
                                            {r_cnthctl_el2: Z.land cnthctl NOT_CNTHCTL_EL2_EL1PTEN}}}
            {share: (share adt) {gs: (gs (share adt)) # gidx == g'}}
      else Some adt
    else Some adt.

End Spec.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^338 - 15
Base: 24 + 1/7
***)

Definition curve : CurveParameters :=
  {|
    sz := 14%nat;
    base := 24 + 1/7;
    bitwidth := 32;
    s := 2^338;
    c := [(1, 15)];
    carry_chains := Some [seq 0 (pred 14); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.HoareLogic.ImperativeLanguage.
Require Import Logic.HoareLogic.ProgramState.
Require Import Logic.HoareLogic.BigStepSemantics.
Require Import Logic.HoareLogic.HoareTriple_BigStepSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelSingleNotation.
Import KripkeModelNotation_Intuitionistic.

Section partial_soundness.

Existing Instance unit_kMD.
Import Partial.

Context {P: ProgrammingLanguage}
        {iP: ImperativeProgrammingLanguage P}
        {MD: Model}
        {R: Relation model}
        {po_R: PreOrder Krelation}
        {BSS: BigStepSemantics P model}
        {iBSS: ImpBigStepSemantics P model BSS}.

Context {L: Language}
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {SM: Semantics L MD}
        {kiSM: KripkeIntuitionisticSemantics L MD tt SM}
        {kminSM: KripkeMinimumSemantics L MD tt SM}
        {kandpSM: KripkeAndSemantics L MD tt SM}
        {kfalsepSM: KripkeFalseSemantics L MD tt SM}
        {knegpSM: KripkeNegSemantics L MD tt SM}.

Lemma hoare_seq_partial_sound: forall c1 c2 P1 P2 P3,
  triple_partial_valid P1 c1 P2 ->
  triple_partial_valid P2 c2 P3 ->
  triple_partial_valid P1 (Ssequence c1 c2) P3.
Proof.
  intros.
  unfold triple_partial_valid in *.
  intros s ms ? ?.
  apply access_Ssequence in H2.
  destruct H2 as [ms' [ms'' [? [? ?]]]].
  specialize (H s ms' H1 H2).
  destruct ms' as [| | s'].
  + inversion H.
  + inversion H3; subst ms''; clear H3.
    inversion H4; auto.
  + inversion H3; subst.
    - apply lift_relation_forward in H4.
      subst ms; auto.
    - eapply sat_mono in H; [| exact H6].
      clear H2 H6 H3 s'; rename y into s'.
      apply (H0 s' ms); auto.
      inversion H4; auto.
Qed.

Lemma hoare_if_partial_sound: forall b c1 c2 B P1 P2,
  (forall s, s |= B <-> eval_bool s b) ->
  triple_partial_valid (P1 && B) c1 P2 ->
  triple_partial_valid (P1 && ~~ B) c2 P2 ->
  triple_partial_valid P1 (Sifthenelse b c1 c2) P2.
Proof.
  intros.
  unfold triple_partial_valid in *.
  intros s ms ? ?.
  apply access_Sifthenelse in H3.
  destruct H3 as [[? [s' [? ?]]] | [? [s' [? ?]]]].
  + assert (KRIPKE: s |= P1 && B) by (rewrite sat_andp; firstorder).
    inversion H4; subst.
    - apply lift_relation_forward in H5; subst; auto.
    - eapply sat_mono in H6; [| eassumption].
      inversion H5; subst.
      apply (H0 y); auto.
  + assert (KRIPKE: s |= P1 && ~~ B).
    {
      rewrite sat_andp; split; auto.
      apply sat_negp. unfold not.
      intros.
      rewrite H in H7.
      pose proof eval_bool_stable b _ _ H6.
      simpl in H7, H8.
      rewrite <- H8 in H7; exfalso; auto.
    }
    inversion H4; subst.
    - apply lift_relation_forward in H5; subst; auto.
    - eapply sat_mono in H6; [| eassumption].
      inversion H5; subst.
      apply (H1 y); auto.
Qed.

Lemma hoare_while_partial_sound: forall b c B P,
  (forall s, s |= B <-> eval_bool s b) ->
  triple_partial_valid (P && B) c P ->
  triple_partial_valid P (Swhile b c) (P && ~~ B).
Proof.
  intros.
  unfold triple_partial_valid in *.
  intros s ms ? ?.
  apply access_Swhile in H2.
  inversion H2; subst; clear H2; auto.

  induction H3.
  + inversion H3.
    - subst.
      auto.
    - subst.
      eapply sat_mono; [eassumption |].
      rewrite sat_andp.
      split; auto.
      apply sat_negp; unfold not; intros.
      rewrite H in H6.
      pose proof eval_bool_stable b _ _ H4.
      simpl in H6, H7.
      tauto.
  + assert (KRIPKE: s1 |= P0 && B) by (rewrite sat_andp; firstorder).
    inversion H3.
    - subst.
      apply lift_relation_forward in H4; subst.
      auto.
    - subst.
      eapply sat_mono in H6; [| eassumption].
      inversion H4; subst.
      specialize (H0 _ _ H6 H9).
      destruct H5; subst; auto.
  + apply IHloop_access_fin; clear IHloop_access_fin H6.
    assert (KRIPKE: s1 |= P0 && B) by (rewrite sat_andp; firstorder).
    eapply sat_mono in H6; [| eassumption].
    eapply sat_mono; [eassumption |].
    exact (H0 _ _ H6 H4).
  + destruct H3.
    subst; auto.
Qed.

End partial_soundness.

Section total_soundness.

Existing Instance unit_kMD.
Import Total.

Context {P: ProgrammingLanguage}
        {iP: ImperativeProgrammingLanguage P}
        {MD: Model}
        {R: Relation model}
        {po_R: PreOrder Krelation}
        {BSS: BigStepSemantics P model}
        {iBSS: ImpBigStepSemantics P model BSS}.

Context {L: Language}
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {SM: Semantics L MD}
        {kiSM: KripkeIntuitionisticSemantics L MD tt SM}
        {kminSM: KripkeMinimumSemantics L MD tt SM}
        {kandpSM: KripkeAndSemantics L MD tt SM}
        {kfalsepSM: KripkeFalseSemantics L MD tt SM}
        {knegpSM: KripkeNegSemantics L MD tt SM}.

Lemma hoare_seq_total_sound: forall c1 c2 P1 P2 P3,
  triple_total_valid P1 c1 P2 ->
  triple_total_valid P2 c2 P3 ->
  triple_total_valid P1 (Ssequence c1 c2) P3.
Proof.
  intros.
  unfold triple_total_valid in *.
  intros s ms ? ?.
  apply access_Ssequence in H2.
  destruct H2 as [ms' [ms'' [? [? ?]]]].
  specialize (H s ms' H1 H2).
  destruct ms' as [| | s'].
  + inversion H.
  + inversion H.
  + inversion H3; subst.
    eapply sat_mono in H; [| exact H6].
    clear H2 H6 H3 s'; rename y into s'.
    apply (H0 s' ms); auto.
    inversion H4; auto.
Qed.

Lemma hoare_if_total_sound: forall b c1 c2 B P1 P2,
  (forall s, s |= B <-> eval_bool s b) ->
  triple_total_valid (P1 && B) c1 P2 ->
  triple_total_valid (P1 && ~~ B) c2 P2 ->
  triple_total_valid P1 (Sifthenelse b c1 c2) P2.
Proof.
  intros.
  unfold triple_total_valid in *.
  intros s ms ? ?.
  apply access_Sifthenelse in H3.
  destruct H3; destruct H3 as [? [s' [? ?]]].
  + assert (KRIPKE: s |= P1 && B) by (rewrite sat_andp; firstorder).
    inversion H4; subst.
    inversion H5; subst.
    eapply sat_mono in H6; [| eassumption].
    apply (H0 y); auto.
  + assert (KRIPKE: s |= P1 && ~~ B).
    {
      rewrite sat_andp; split; auto.
      apply sat_negp; unfold not.
      intros.
      rewrite H in H7.
      pose proof eval_bool_stable b _ _ H6.
      simpl in H7, H8.
      tauto.
    }
    inversion H4; subst.
    inversion H5; subst.
    eapply sat_mono in H6; [| eassumption].
    apply (H1 y); auto.
Qed.

Lemma hoare_while_total_sound:
  forall {A: Type} (R: A -> A -> Prop) (Wf: well_founded R) (EQ LE: A -> expr) (D: model -> A),
    (forall s v, s |= EQ v <-> D s = v) ->
    (forall s v, s |= LE v <-> R (D s) v) ->
    (forall s1 s2, s1 <= s2 -> D s1 = D s2) ->
    forall b c B P,
     (forall s, s |= B <-> eval_bool s b) ->
     (forall v, triple_total_valid (P && B && EQ v) c (P && LE v)) ->
     triple_total_valid P (Swhile b c) (P && ~~ B).
Proof.
  intros ? ? WF ? ? ? H_EQ H_LE H_F; intros.
  unfold triple_total_valid in *.
  intros s ms ? ?.
  apply access_Swhile in H2.
  inversion H2; subst; clear H2; auto.

  {
  induction H3.
  + inversion H3; subst.
    eapply sat_mono; [eassumption |].
    rewrite sat_andp.
    split; auto.
    apply sat_negp; unfold not; intros.
    rewrite H in H6.
    pose proof eval_bool_stable b _ _ H4.
    simpl in H6, H7.
    tauto.
  + inversion H3; subst.
    inversion H4; subst.
    assert (KRIPKE: s1 |= P0 && B && EQ (D y)).
    - rewrite !sat_andp.
      rewrite H_EQ, H, <- (H_F _ _ H7).
      simpl; tauto.
    - eapply sat_mono in H6; [| eassumption].
      specialize (H0 _ _ _ H6 H8).
      destruct H5; subst; auto.
  + apply IHloop_access_fin; clear IHloop_access_fin H6.
    assert (KRIPKE: s1 |= P0 && B && EQ (D s2)).
    - rewrite !sat_andp.
      rewrite H_EQ, H, <- (H_F _ _ H3).
      simpl; tauto.
    - eapply sat_mono in H6; [| eassumption].
      eapply sat_mono; [eassumption |].
      specialize (H0 _ _ _ H6 H4).
      rewrite sat_andp in H0.
      tauto.
  }
  {
    destruct H3; subst.
    inversion H2; subst; clear H2.
    specialize (WF (D (s1 0))).
    set (n := 0) in WF, H1; clearbody n.
    remember (D (s1 n)) as D0 eqn:?H.
    revert n H1 H2.
    induction WF.

    intros.
    subst x.
    assert (KRIPKE: s1 n |= P0 && B && EQ (D (s1 n))).
    - rewrite !sat_andp.
      rewrite H_EQ, H.
      specialize (H3 n).
      simpl; tauto.
    - eapply sat_mono in H8; [| apply H4].
      specialize (H0 _ _ _ H8 (H5 _)).
      eapply sat_mono in H0; [| apply H6].
      rewrite sat_andp in H0; destruct H0.
      rewrite H_LE in H9; simpl in H9.
      exact (H2 _ H9 (S n) H0 eq_refl).
  }
Qed.

End total_soundness.