(**
* Rewriting with K and S
*)

Local Ltac inj_subst H := injection H; intros; subst; clear H.

Require Import Coq.Classes.Morphisms.
Require Import Coq.Relations.Operators_Properties.
Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Setoids.Setoid.

Require Import pas.
Require Import pca.
Require Import rewriting.

Import PAS.NOTATIONS.
Import RW.NOTATIONS.

Local Open Scope PAS.

Module KS_RW.

  (**
  ** Definitions
  *)

  (**
  *** Terms
  *)

  Inductive term :=
  | K    : term
  | S    : term
  | appl : term -> term -> term.
  Local Infix "⋅" := appl (at level 40, left associativity).

  (**
  *** Terms to closed PCA terms
  *)

  Fixpoint termToClosedPcaTerm `{_ : PCA.Pca} (T : term) : PAS.term 0 :=
  match T with
  | K   => &k
  | S   => &s
  | U⋅V => termToClosedPcaTerm U * termToClosedPcaTerm V
  end.
  Local Notation "§ t" := (termToClosedPcaTerm t) (at level 6).

  (**
  *** Non-deterministic reduction
  *)

  Local Reserved Infix ">" (at level 70).
  Inductive OneStepReduces : term -> term -> Prop :=
  | oneStepReducesK U V    : K⋅U⋅V > U
  | oneStepReducesS U V W  : S⋅U⋅V⋅W > U⋅W⋅(V⋅W)
  | oneStepReducesL U U' V : U > U' -> U⋅V > U'⋅V
  | oneStepReducesR U V V' : V > V' -> U⋅V > U⋅V'
  where "U > V" := (OneStepReduces U V).

  Definition Reduces := RTC OneStepReduces.
  Local Infix ">*" := Reduces (at level 70).

  (**
  *** Convertibility
  *)

  Definition Convertible (U V : term) : Prop := exists W, U >* W /\ V >* W.
  Local Infix "≈" := Convertible (at level 70).

  (**
  *** Deterministic eager reduction
  *)

  Fixpoint eagerReduct (T : term) : option term :=
  match T with
  | K
  | S   => None
  | U⋅V => match eagerReduct U, eagerReduct V with
           | Some U,      _ => Some (U⋅V)
           |   None, Some V => Some (U⋅V)
           |   None,   None => match T with
                               | K⋅U⋅V   => Some U
                               | S⋅U⋅V⋅W => Some (U⋅W⋅(V⋅W))
                               | _       => None
                               end
           end
  end.

  Definition EagerlyOneStepReduces (U V : term) : Prop :=
    eagerReduct U = Some V.
  Local Infix ">>" := EagerlyOneStepReduces (at level 70).

  Definition EagerlyReduces : term -> term -> Prop :=
    RTC (fun U V : term => U >> V).
  Infix ">>*" := EagerlyReduces (at level 70).

  (**
  *** Normal terms and normal forms
  *)

  Notation Normal := (RW.Normal OneStepReduces).

  Local Notation NF := (NF OneStepReduces).

  Definition StrictlyNormal (T : term) := eagerReduct T = None.
  Local Notation SN := StrictlyNormal.

  Definition StrictNormalForm (U V : term) : Prop := U >>* V /\ SN V.
  Local Notation SNF := StrictNormalForm.

  (**
  ** Notations
  *)

  Module NOTATIONS.

    Delimit Scope KS_RW with KS_RW.

    Notation "§ T" := (§T) (at level 6) : KS_RW.
    Infix "⋅" := appl : KS_RW.
    Infix ">" := (fun U V => U > V) (at level 70) : KS_RW.
    Infix ">*" := (fun U V => U >* V) (at level 70) : KS_RW.
    Infix ">>" := (fun U V => U >> V) (at level 70) : KS_RW.
    Infix ">>*" := (fun U V => U >>* V) (at level 70) : KS_RW.
    Infix "≈" := (fun U V => U ≈ V) (at level 70) : KS_RW.
    Notation Normal := Normal.
    Notation NF := NF.
    Notation SNF := SNF.

  End NOTATIONS.

  (**
  ** Theorems
  *)

  Module Type THMS_SIG.

    (**
    *** Convertibility is an equivalence relation
    *)

    Declare Instance convertibleEquivalence : Equivalence Convertible.

    (**
    *** Application respects convertibility
    *)

    Declare Instance applRespectsConvertibility :
      Proper (Convertible ==> Convertible ==> Convertible) appl.

    (**
    *** Normal forms respects convertibility
    *)

    Declare Instance normalFormsRespectConvertibility :
      Proper (Convertible ==> eq ==> iff) NF.

    (**
    *** Induction principle for eager reduction
    *)

    Axiom eagerReductionInduction :
      forall P : term -> term -> Prop,
      (forall U U' V : term, P U U' -> P (U⋅V) (U'⋅V)) ->
      (forall U V V' : term, SN U -> P V V' -> P (U⋅V) (U⋅V')) ->
      (forall U V : term, SN U -> SN V -> P (K⋅U⋅V) U) ->
      (forall U V W : term, SN U -> SN V -> SN W -> P (S⋅U⋅V⋅W) (U⋅W⋅(V⋅W))) ->
      forall U V : term, U >> V -> P U V.

    (**
    *** Induction principle for normal terms
    *)

    Axiom normalTermInduction :
      forall P : term -> Prop,
      P K ->
      P S ->
      (forall T : term, Normal T -> P T -> P (K⋅T)) ->
      (forall T : term, Normal T -> P T -> P (S⋅T)) ->
      (forall U V : term, Normal U -> Normal V -> P U -> P V -> P (S⋅U⋅V)) ->
      forall T : term, Normal T -> P T.

    Axiom strictlyNormalTermInduction :
      forall P : term -> Prop,
      P K ->
      P S ->
      (forall T : term, SN T -> P T -> P (K⋅T)) ->
      (forall T : term, SN T -> P T -> P (S⋅T)) ->
      (forall U V : term, SN U -> SN V -> P U -> P V -> P (S⋅U⋅V)) ->
      forall T : term, SN T -> P T.

    (**
    *** Relations between reduction relations
    *)

    Axiom eagerlyOneStepReduces_oneStepReduces :
      forall U V : term, U >> V -> U > V.

    Axiom eagerlyReduces_reduces : forall U V : term, U >>* V -> U >* V.

    (**
    *** Properties of reduction
    *)

    Axiom reductionL : forall U U' V : term, U >* U' -> U⋅V >* U'⋅V.

    Axiom reductionR : forall U V V' : term,  V >* V' -> U⋅V >* U⋅V'.

    Axiom reductionPar :
      forall U V U' V' : term,  U >* U' -> V >* V' -> U⋅V >* U'⋅V'.

    (**
    *** Properties of eager reduction
    *)

    Axiom eagerOneStepReductionFunctional : RW.Functional EagerlyOneStepReduces.

    Axiom eagerReductionL : forall U U' V : term, U >>* U' -> U⋅V >>* U'⋅V.

    Axiom eagerReductionR :
      forall U V V' : term, SN U -> V >>* V' -> U⋅V >>* U⋅V'.

    Axiom eagerReductionPar :
      forall U U' V V' : term, SN U' -> U >>* U' -> V >>* V' -> U⋅V >>* U'⋅V'.

    (**
    *** Reduction relations are confluent
    *)

    Axiom reductionConfluent : RW.Confluence OneStepReduces.

    Axiom eagerReductionConfluent : RW.Confluence EagerlyOneStepReduces.

    (**
    *** Definition of strict normal terms is correct
    *)

    Axiom strictlyNormalCorrect :
      forall T : term, SN T <-> RW.Normal EagerlyOneStepReduces T.

    Axiom strictNormalFormsCorrect :
      forall U V : term, SNF U V <-> RW.NormalForm EagerlyOneStepReduces U V.

    (**
    *** Properties of normal terms
    *)

    Axiom normalIffStrictlyNormal : forall T, Normal T <-> SN T.

    Axiom strictNormalForm_normalForm : forall U V : term, SNF U V -> NF U V.

    Axiom normalApplL : forall U V : term, Normal (U⋅V) -> Normal U.

    Axiom strictlyNormalApplL : forall U V : term, SN (U⋅V) -> SN U.

    Axiom normalApplR : forall U V : term, Normal (U⋅V) -> Normal V.

    Axiom strictlyNormalApplR : forall U V : term, SN (U⋅V) -> SN V.

    Axiom normalReduction : forall U V : term, Normal U -> U >* V -> U = V.

    Axiom strictlyNormalEagerReduction :
      forall U V : term, SN U -> U >>* V -> U = V.

    Axiom strictNormalFormApplL :
      forall U V W : term, SNF (U⋅V) W -> exists U' : term, SNF U U'.

    Axiom strictNormalFormApplR :
      forall U V W : term, SNF (U⋅V) W -> exists V' : term, SNF V V'.

    Axiom normalFormsUnique :
      forall U V V' : term,  NF U V -> NF U V' -> V = V'.

    Axiom strictNormalFormsUnique :
      forall U V W : term, SNF U V -> SNF U W -> V = W.

    (**
    *** Normal terms
    *)

    Axiom kNormal : Normal K.

    Axiom kStrictlyNormal : SN K.

    Axiom ktNormal : forall T : term, Normal T -> Normal (K⋅T).

    Axiom ktStrictlyNormal : forall T : term, SN T -> SN (K⋅T).

    Axiom sNormal : Normal S.

    Axiom sStrictlyNormal : SN S.

    Axiom stNormal : forall T : term, Normal T -> Normal (S⋅T).

    Axiom stStrictlyNormal : forall T : term, SN T -> SN (S⋅T).

    Axiom suvNormal :
      forall U V : term,  Normal U -> Normal V -> Normal (S⋅U⋅V).

    Axiom suvStrictlyNormal : forall U V : term, SN U -> SN V -> SN (S⋅U⋅V).

    Axiom kuvNotStrictlyNormal : forall U V : term, ~ SN (K⋅U⋅V).

    Axiom suvwNotStrictlyNormal : forall U V W : term, ~ SN (S⋅U⋅V⋅W).

    (**
    *** Normal terms denote in all PCAs
    *)

    Axiom normalTermsDenote : forall `{_ : PCA.Pca} (T : term), Normal T -> §T!.

    (**
    *** Relation between strict reduction and closed term equivalence in PCAs
    *)

    Axiom eagerlyReduces_closedTermEq :
      forall `{_ : PCA.Pca} (U V : term), U >>* V -> §U ≃ §V.

  End THMS_SIG.

  (**
  ** Proofs
  *)

  Module THMS : THMS_SIG.

    Theorem strictlyNormalApplL (U V : term) : SN (U⋅V) -> SN U.
    Proof.
      intro H.
      remember (eagerReduct U) as rU eqn:HU. symmetry in HU.
      unfold SN in H. simpl in H.
      destruct rU as [U' | ]; rewrite HU in H.
      - discriminate H.
      - exact HU.
    Qed.

    Theorem strictlyNormalApplR (U V : term) : SN (U⋅V) -> SN V.
    Proof.
      intro H.
      remember (eagerReduct U) as rU eqn:HU.
      remember (eagerReduct V) as rV eqn:HV.
      symmetry in HU, HV. unfold SN in H. simpl in H.
      destruct rU as [U' | ]; rewrite HU in H.
      - discriminate H.
      - destruct rV as [V' | ].
        + rewrite HV in H. discriminate H.
        + exact HV.
    Qed.

    Theorem eagerReductionInduction (P : term -> term -> Prop) :
      (forall U U' V : term, P U U' -> P (U⋅V) (U'⋅V)) ->
      (forall U V V' : term, SN U -> P V V' -> P (U⋅V) (U⋅V')) ->
      (forall U V : term, SN U -> SN V -> P (K⋅U⋅V) U) ->
      (forall U V W : term, SN U -> SN V -> SN W -> P (S⋅U⋅V⋅W) (U⋅W⋅(V⋅W))) ->
      forall U V : term, U >> V -> P U V.
    Proof.
      intros HL HR HK HS T.
      induction T as [ | | U IHU V IHV]; [discriminate | discriminate | ].
      remember (eagerReduct U) as rU eqn:HU. symmetry in HU.
      destruct rU as [U' | ].
      - intros W H.
        unfold EagerlyOneStepReduces in H. simpl in H. rewrite HU in H.
        injection H. intro H'. subst.
        apply HL. apply IHU. exact HU.
      - remember (eagerReduct V) as rV eqn:HV. symmetry in HV.
        destruct rV as [V' | ].
        + intros W H.
          unfold EagerlyOneStepReduces in H. simpl in H. rewrite HU, HV in H.
          injection H. intro H'. subst. apply HR.
          * exact HU.
          * apply IHV. exact HV.
        + intros W H.
          unfold EagerlyOneStepReduces in H. simpl in H. rewrite HU, HV in H.
          refine
            (match U as U' return (U' = U -> _) with
             | K       => _
             | S       => _
             | K⋅U'    => _
             | S⋅_     => _
             | K⋅_⋅_   => _
             | S⋅U'⋅V' => _
             | _⋅_⋅_⋅_ => _
             end _).
          * intro H'. subst. inversion H.
          * intro H'. subst. inversion H.
          * intro H'. subst. injection H. intro H'. subst.
            apply strictlyNormalApplR in HU. apply HK; assumption.
          * intro H'. subst. inversion H.
          * intro H'. subst. inversion H.
          * intro H'. subst. injection H. intro H'. subst.
            pose proof (strictlyNormalApplR _ _ HU) as HV'.
            apply strictlyNormalApplL, strictlyNormalApplR in HU.
            apply HS; assumption.
          * intro H'. subst. inversion H.
          * reflexivity.
    Qed.

    Theorem eagerOneStepReductionFunctional :
      RW.Functional EagerlyOneStepReduces.
    Proof.
      unfold EagerlyOneStepReduces.
      intros U V W HUV HUW. rewrite HUV in HUW. injection HUW. tauto.
    Qed.

    Theorem eagerReductionConfluent : RW.Confluence EagerlyOneStepReduces.
    Proof.
      apply RW.THMS.functionalRelation_confluence.
      apply eagerOneStepReductionFunctional.
    Qed.

    Theorem eagerlyOneStepReduces_oneStepReduces (U V : term) : U >> V -> U > V.
    Proof.
      intro HUV.
      induction HUV as [U U' V IH | U V V' _ IH | U V _ _ | U V W _ _ _ ]
        using eagerReductionInduction.
      - apply oneStepReducesL. exact IH.
      - apply oneStepReducesR. exact IH.
      - apply oneStepReducesK.
      - apply oneStepReducesS.
    Qed.

    Theorem eagerlyReduces_reduces (U V : term) : U >>* V -> U >* V.
    Proof.
      intro H. induction H as [U V | T | U V W _ IHL _ IHR].
      - apply rt_step. apply eagerlyOneStepReduces_oneStepReduces. exact H.
      - apply rt_refl.
      - apply rt_trans with (y := V); assumption.
    Qed.

    Theorem strictlyNormalCorrect (T : term) :
      SN T <-> RW.Normal EagerlyOneStepReduces T.
    Proof.
      unfold RW.Normal, EagerlyOneStepReduces, SN.
      split.
      - intros H [T' H']. rewrite H' in H. discriminate H.
      - intros H. destruct (eagerReduct T) as [T' | T'].
        + exfalso. eauto.
        + reflexivity.
    Qed.

    Theorem strictNormalFormsCorrect (U V : term) :
      SNF U V <-> RW.NormalForm EagerlyOneStepReduces U V.
    Proof.
      split.
      - intros [H HV]. split; [exact H | ]. clear U H. intros [W H].
        unfold SN in HV. unfold EagerlyOneStepReduces in H.
        rewrite HV in H. discriminate H.
      - intros [H HV]. split; [exact H | ]. clear U H.
        unfold SN.
        set (W' := eagerReduct V). remember W' as W eqn:HW.
        destruct W as [W | ]; subst.
        + exfalso. apply HV. unfold EagerlyOneStepReduces. eauto.
        + reflexivity.
    Qed.

    Theorem strictNormalFormsUnique (U V W : term) :
      SNF U V -> SNF U W -> V = W.
    Proof.
      intros H H'.
      apply strictNormalFormsCorrect in H.
      apply strictNormalFormsCorrect in H'.
      eapply (RW.THMS.confluence_normalFormsUnique _ eagerReductionConfluent);
      eauto.
    Qed.

    Theorem normalApplL (U V : term) : Normal (U⋅V) -> Normal U.
    Proof. intros H [T HT]. eauto using OneStepReduces. Qed.

    Theorem normalApplR (U V : term) : Normal (U⋅V) -> Normal V.
    Proof. intros H [T HT]. eauto using OneStepReduces. Qed.

    Theorem normalReduction (U V : term) : Normal U -> U >* V -> U = V.
    Proof.
      intros H H'.
      induction H' as [U V H' | U H' | U V W _ IHL _ IHR].
      - exfalso. eauto.
      - reflexivity.
      - specialize (IHL H). subst. exact (IHR H).
    Qed.

    Theorem strictlyNormalEagerReduction (U V : term) :
      SN U -> U >>* V -> U = V.
    Proof.
      rewrite strictlyNormalCorrect. apply RW.THMS.normalReductionTrivial.
    Qed.

    Theorem kuvNotStrictlyNormal (U V : term) : ~ SN (K⋅U⋅V).
    Proof.
      intro H.
      remember (eagerReduct U) as rU eqn:HU.
      remember (eagerReduct V) as rV eqn:HV.
      symmetry in HU, HV. unfold SN in H. simpl in H.
      destruct rU as [U' | ]; rewrite HU in H.
      - discriminate H.
      - destruct rV as [V' | ]; rewrite HV in H; discriminate H.
    Qed.

    Theorem suvwNotStrictlyNormal (U V W : term) : ~ SN (S⋅U⋅V⋅W).
    Proof.
      intro H.
      remember (eagerReduct U) as rU eqn:HU.
      remember (eagerReduct V) as rV eqn:HV.
      remember (eagerReduct W) as rW eqn:HW.
      symmetry in HU, HV, HW. unfold SN in H. simpl in H.
      destruct rU as [U' | ]; rewrite HU in H.
      - discriminate H.
      - destruct rV as [V' | ]; rewrite HV in H.
        + discriminate H.
        + destruct rW as [W' | ]; rewrite HW in H; discriminate.
    Qed.

    Theorem normalIffStrictlyNormal (T : term) : Normal T <-> SN T.
    Proof.
      split.
      - intro H. remember (eagerReduct T) as r eqn:Hr. symmetry in Hr.
        destruct r as [T' | ].
        + exfalso. apply H. exists T'.
          apply eagerlyOneStepReduces_oneStepReduces. exact Hr.
        + exact Hr.
      - intros HT [T' H]. induction H as [ | | U U' V _ IH | U V V' _ IH].
        + apply (kuvNotStrictlyNormal _ _ HT).
        + apply (suvwNotStrictlyNormal _ _ _ HT).
        + apply IH. eapply strictlyNormalApplL. eauto.
        + apply IH. eapply strictlyNormalApplR. eauto.
    Qed.

    Theorem strictNormalFormApplL (U V W : term) :
      SNF (U⋅V) W -> exists U' : term, SNF U U'.
    Proof.
      intros [H HW]. remember (U⋅V) as T eqn:HT.
      revert U V HT.
      setoid_rewrite clos_rt_rt1n_iff in H.
      induction H as [T | T' T W HUVT HTW IH]; intros U V HT; subst.
      - exists U. split.
        + apply rt_refl.
        + eapply strictlyNormalApplL. eauto.
      - setoid_rewrite <- clos_rt_rt1n_iff in HTW. specialize (IH HW).
        remember (eagerReduct U) as U' eqn:HU.
        unfold EagerlyOneStepReduces in HUVT.
        destruct U' as [U' | ].
        + simpl in HUVT. rewrite <- HU in HUVT.
          injection HUVT. intro H. subst.
          specialize (IH U' V).
          destruct IH as [U'' [IH HU'']]; [reflexivity | ].
          exists U''. split; [ | exact HU'']. apply rt_trans with (y := U').
          * apply rt_step. symmetry. exact HU.
          * exact IH.
        + symmetry in HU. exists U. split.
          * apply rt_refl.
          * exact HU.
    Qed.

    Theorem strictNormalFormApplR (U V W : term) :
      SNF (U⋅V) W -> exists V' : term, SNF V V'.
    Proof.
      intros [H HW]. remember (U⋅V) as T eqn:HT.
      revert U V HT.
      setoid_rewrite clos_rt_rt1n_iff in H.
      induction H as [T | T' T W HUVT HTW IH]; intros U V HT; subst.
      - exists V. split.
        + apply rt_refl.
        + eapply strictlyNormalApplR. eauto.
      - setoid_rewrite <- clos_rt_rt1n_iff in HTW. specialize (IH HW).
        remember (eagerReduct U) as U' eqn:HU.
        remember (eagerReduct V) as V' eqn:HV.
        unfold EagerlyOneStepReduces in HUVT.
        destruct U' as [U' | ]; [ | destruct V' as [V' | ]].
        + simpl in HUVT. rewrite <- HU in HUVT.
          injection HUVT. intro H. subst.
          eapply IH. eauto.
        + simpl in HUVT. rewrite <- HU, <- HV in HUVT.
          injection HUVT. intro H. subst.
          specialize (IH U V').
          destruct IH as [V'' [IH HV'']]; [reflexivity | ].
          exists V''. split; [ | exact HV'']. apply rt_trans with (y := V').
          * apply rt_step. symmetry. exact HV.
          * exact IH.
        + symmetry in HV. exists V. split.
          * apply rt_refl.
          * exact HV.
    Qed.

    Theorem strictNormalForm_normalForm (U V : term) : SNF U V -> NF U V.
    Proof.
      firstorder using normalIffStrictlyNormal, eagerlyReduces_reduces.
    Qed.

    Theorem normalTermInduction (P : term -> Prop) :
      P K ->
      P S ->
      (forall T : term, Normal T -> P T -> P (K⋅T)) ->
      (forall T : term, Normal T -> P T -> P (S⋅T)) ->
      (forall U V : term, Normal U -> Normal V -> P U -> P V -> P (S⋅U⋅V)) ->
      forall T : term, Normal T -> P T.
    Proof.
      assert (forall T U V W, ~ Normal (T⋅U⋅V⋅W)) as lemma. {
        clear. intro T.
        induction T as [ | | U IHU V _].
        - intros U V W H. apply H. exists (U⋅W). constructor. constructor.
        - intros U V W H. apply H. eexists. constructor.
        - intros W U' V' H. apply (IHU V W U'). eapply normalApplL. eauto.
      }
      intros HK HS HKU HSU HSUV T.
      refine
        ((fix IH T :=
         match T as T' return (T = T' -> Normal T ->  P T) with
         | K       => _
         | S       => _
         | K⋅T     => _
         | S⋅T     => _
         | K⋅U⋅V   => _
         | S⋅U⋅V   => _
         | _⋅_⋅_⋅_ => _
         end _) T).
      - intros H _. subst. apply HK.
      - intros H _. subst. apply HS.
      - intros H' H. subst.
        pose proof (normalApplR _ _ H) as HV.
        apply (HKU _ HV). apply (IH _ HV).
      - intros H' H. subst.
        pose proof (normalApplR _ _ H) as HV.
        apply (HSU _ HV). apply (IH _ HV).
      - intros H' H. subst. exfalso. apply H. exists U. constructor.
      - intros H' H. subst.
        pose proof (normalApplL _ _ H) as HU. apply normalApplR in HU.
        pose proof (normalApplR _ _ H) as HV.
        apply (HSUV _ _ HU HV).
        + apply (IH _ HU).
        + apply (IH _ HV).
      - intros H' H. subst. exfalso. eapply lemma. eauto.
      - reflexivity.
    Qed.

    Theorem strictlyNormalTermInduction (P : term -> Prop) :
      P K ->
      P S ->
      (forall T : term, SN T -> P T -> P (K⋅T)) ->
      (forall T : term, SN T -> P T -> P (S⋅T)) ->
      (forall U V : term, SN U -> SN V -> P U -> P V -> P (S⋅U⋅V)) ->
      forall T : term, SN T -> P T.
    Proof.
      setoid_rewrite <- normalIffStrictlyNormal. apply normalTermInduction.
    Qed.

    Theorem eagerReductionL (U U' V : term) : U >>* U' -> U⋅V >>* U'⋅V.
    Proof.
      intros H. induction H as [U U' H | U | U T U' _ IHL _ IHR].
      - apply rt_step.
        unfold EagerlyOneStepReduces. simpl. rewrite H.
        reflexivity.
      - apply rt_refl.
      - eapply rt_trans; eauto.
    Qed.

    Theorem eagerReductionR (U V V' : term) : SN U -> V >>* V' -> U⋅V >>* U⋅V'.
    Proof.
      intros HU H. induction H as [V V' H | V | V T V' _ IHL _ IHR].
      - apply rt_step.
        unfold EagerlyOneStepReduces. simpl. rewrite HU, H.
        reflexivity.
      - apply rt_refl.
      - eapply rt_trans; eauto.
    Qed.

    Theorem eagerReductionPar (U U' V V' : term) :
      SN U' -> U >>* U' -> V >>* V' -> U⋅V >>* U'⋅V'.
    Proof.
      intros HU' HU HV. apply rt_trans with (y := U'⋅V).
      - apply eagerReductionL. exact HU.
      - apply eagerReductionR; assumption.
    Qed.

    Theorem reductionL (U U' V : term) : U >* U' -> U⋅V >* U'⋅V.
    Proof.
      intro H. induction H as [U U' | U | U W U' HL IHL HR IHR].
      - apply rt_step. constructor. assumption.
      - apply rt_refl.
      - apply rt_trans with (y := W⋅V); assumption.
    Qed.

    Theorem reductionR (U V V' : term) :  V >* V' -> U⋅V >* U⋅V'.
    Proof.
      intro H. induction H as [V V' | V | V W V' HL IHL HR IHR].
      - apply rt_step. constructor. assumption.
      - apply rt_refl.
      - apply rt_trans with (y := U⋅W); assumption.
    Qed.

    Theorem reductionPar (U V U' V' : term) :
      U >* U' -> V >* V' -> U⋅V >* U'⋅V'.
    Proof.
      intros HU HV.
      apply rt_trans with (y := U'⋅V);
      [apply reductionL | apply reductionR]; assumption.
    Qed.

    Theorem kStrictlyNormal : SN K.
    Proof. reflexivity. Qed.

    Theorem kNormal : Normal K.
    Proof. apply normalIffStrictlyNormal, kStrictlyNormal. Qed.

    Theorem ktStrictlyNormal (T : term) : SN T -> SN (K⋅T).
    Proof. unfold StrictlyNormal. simpl. intro H. rewrite H. reflexivity. Qed.

    Theorem ktNormal (T : term) : Normal T -> Normal (K⋅T).
    Proof. setoid_rewrite normalIffStrictlyNormal. apply ktStrictlyNormal. Qed.

    Theorem sStrictlyNormal : SN S.
    Proof. reflexivity. Qed.

    Theorem sNormal : Normal S.
    Proof. apply normalIffStrictlyNormal, sStrictlyNormal. Qed.

    Theorem stStrictlyNormal (T : term) : SN T -> SN (S⋅T).
    Proof. unfold StrictlyNormal. simpl. intro H. rewrite H. reflexivity. Qed.

    Theorem stNormal (T : term) : Normal T -> Normal (S⋅T).
    Proof. setoid_rewrite normalIffStrictlyNormal. apply stStrictlyNormal. Qed.

    Theorem suvStrictlyNormal (U V : term) : SN U -> SN V -> SN (S⋅U⋅V).
    Proof.
      unfold SN. simpl. intros H H'. rewrite H, H'. reflexivity.
    Qed.

    Theorem suvNormal (U V : term) : Normal U -> Normal V -> Normal (S⋅U⋅V).
    Proof. setoid_rewrite normalIffStrictlyNormal. apply suvStrictlyNormal. Qed.

    Local Reserved Infix ">=" (at level 70).
    Inductive OneStepReflParReduces : term -> term -> Prop :=
    | oneStepReflParReducesK    U V       : K⋅U⋅V >= U
    | oneStepReflParReducesS    U V W     : S⋅U⋅V⋅W >= U⋅W⋅(V⋅W)
    | oneStepReflParReducesRefl U         : U >= U
    | oneStepReflParReducesPar  U U' V V' : U >= U' -> V >= V' -> U⋅V >= U'⋅V'
    where "U >= V" := (OneStepReflParReduces U V).

    Definition ReflParReduces := RTC OneStepReflParReduces.
    Local Infix ">=*" := ReflParReduces (at level 70).

    Lemma inclusion1 (U V : term) : U > V -> U >= V.
    Proof. intro H. induction H; auto using OneStepReflParReduces. Qed.

    Lemma inclusion2 (U V : term) : U >= V -> U >* V.
    Proof.
      intro H. induction H as [V T | U V W | V | U U' V V' HL IHL HR IHR].
      - apply rt_step. constructor.
      - apply rt_step. constructor.
      - apply rt_refl.
      - apply rt_trans with (y := U'⋅V);
        [apply reductionL | apply reductionR]; assumption.
    Qed.

    Lemma redEqReflParRed (U V : term) : U >* V <-> U >=* V.
    Proof.
      split.
      - apply RW.THMS.rtcIncreasing. apply inclusion1.
      - intros H.
        induction H as [U V H | U | U W V _ IHL _ IHR].
        + apply inclusion2. assumption.
        + apply rt_refl.
        + apply rt_trans with (y := W); assumption.
    Qed.

    Lemma dpOneStepReflParReduces : DP OneStepReflParReduces.
    Proof.
      (* redundant cases *)
      assert (forall T U V, K⋅T >= U -> exists W, T >= W /\ U⋅V >= W) as case1.
      {
        intros T U V H. inversion_clear H.
        - eauto using OneStepReflParReduces.
        - inversion_clear H0. eauto using OneStepReflParReduces.
      }
      assert
        (forall U V W U' V',
         S⋅U⋅V >= U' -> W >= V' -> exists W', U⋅W⋅(V⋅W) >= W' /\ U'⋅V' >= W')
      as case2. {
        intros U V W U' V' HL HR. remember (S⋅U⋅V) as SUv eqn:HSUV.
        destruct HL as [U'' V'' | U'' V'' W'' | T | U'' U''' V'' V''' HL' HR'].
        - inversion HSUV.
        - discriminate HSUV.
        - subst. eauto 6 using OneStepReflParReduces.
        - inj_subst HSUV. inversion_clear HL'.
          + eauto 6 using OneStepReflParReduces.
          + inversion_clear H. eauto 6 using OneStepReflParReduces.
      }
      (* the proof *)
      intros T U V H. generalize dependent V.
      induction H as [U V | U V W | T | U U' V V' HL IHL HR IHR].
      - remember (K⋅U⋅V) as T eqn:HT.
        intros W H.
        destruct H as [U' V' | U' V' W' | T | U'' U' V'' V' H' H'' ].
        + inj_subst HT. eauto using OneStepReflParReduces.
        + inversion HT.
        + subst. eauto using OneStepReflParReduces.
        + inj_subst HT. apply (case1 _ _ _ H').
      - remember (S⋅U⋅V⋅W) as T eqn:HT.
        intros T' H.
        destruct H as [U' V' | U' V' W' | T | U'' U' V'' V' H' H''].
        + inversion HT.
        + inj_subst HT. eauto using OneStepReflParReduces.
        + subst. eauto using OneStepReflParReduces.
        + inj_subst HT. apply (case2 _ _ _ _  _ H' H'').
      - eauto using OneStepReflParReduces.
      - remember (U⋅V) as T eqn:HT.
        intros T' H.
        destruct H as [U'' V'' | U'' V'' W'' | T | U''' U'' V''' V'' HL' HR'].
        + inj_subst HT. pose proof (case1 _ _ V' HL). firstorder.
        + inj_subst HT. pose proof (case2 _ _ _ _ _ HL HR). firstorder.
        + subst. eauto using OneStepReflParReduces.
        + inj_subst HT.
          destruct
            (IHL _ HL') as [U''' [H H']],
            (IHR _ HR') as [V''' [H'' H''']].
          eauto using OneStepReflParReduces.
    Qed.

    Theorem reductionConfluent : RW.Confluence OneStepReduces.
    Proof.
      cut (DP ReflParReduces).
      + intros H U V V' H' H''.
        apply redEqReflParRed in H'.
        apply redEqReflParRed in H''.
        destruct (H _ _ _ H' H'') as [W [H''' H4]].
        apply redEqReflParRed in H'''.
        apply redEqReflParRed in H4.
        eauto.
      + apply RW.THMS.dp_confluence. apply dpOneStepReflParReduces.
    Qed.

    Theorem normalFormsUnique (U V V' : term) : NF U V -> NF U V' -> V = V'.
    Proof.
      intros H H'.
      eapply (RW.THMS.confluence_normalFormsUnique _ reductionConfluent); eauto.
    Qed.

    Instance convertibleEquivalence : Equivalence Convertible.
    Proof.
      split.
        - intro T. exists T. split; apply rt_refl.
        - firstorder.
        - intros U V w [U' [HUV HVU] [V' [HVW HWV]]].
          destruct (reductionConfluent _ _ _ HVU HVW) as [W' [HU'W' HV'W']].
          exists W'. split; eapply rt_trans; eauto.
    Qed.

    Instance normalFormsRespectConvertibility :
      Proper (Convertible ==> eq ==> iff) NF.
    Proof.
      assert (forall U V W, U ≈ V -> NF U W -> NF V W) as H. {
        intros U V W [T [HUT HVT]] [HUW HW].
        destruct (reductionConfluent _ _ _ HUT HUW) as [W' [HTW' HWW']].
        apply (normalReduction _ _ HW) in HWW'. subst. split.
        - eapply rt_trans; eauto.
        - exact HW.
      }
      intros U V HUV W' W HW. subst.
      split; [ | symmetry in HUV]; apply H; exact HUV.
    Qed.

    Instance applRespectsConvertibility :
      Proper (Convertible ==> Convertible ==> Convertible) appl.
    Proof.
      intros U U' [U'' [HU HU']] V V' [V'' [HV HV']]. exists (U''⋅V'').
      split; apply reductionPar; assumption.
    Qed.

    Theorem normalTermsDenote `{pca : PCA.Pca} (T : term) : Normal T -> §T!.
    Proof.
      revert T. apply normalTermInduction.
      - exists k. reflexivity.
      - exists s. reflexivity.
      - intros U _ [a Ha]. simpl. rewrite Ha. apply PCA.THMS.kaDenotes.
      - intros U _ [a Ha]. simpl. rewrite Ha. apply PCA.THMS.saDenotes.
      - intros U V _ _ [a Ha] [b Hb]. simpl. rewrite Ha, Hb. apply PCA.sSpec1.
    Qed.

    Theorem eagerlyReduces_closedTermEq `{pca : PCA.Pca} (U V : term) :
      U >>* V -> §U ≃ §V.
    Proof.
      intro H. apply clos_rt_rt1n in H.
      induction H as [T | U V W HL _ IH]; [reflexivity | ].
      rewrite <- IH. clear dependent W.
      induction HL as [U U' V IH | U V V' H IH | U V HU HV | U V W _ _ _ ]
        using eagerReductionInduction;
      simpl.
      - rewrite IH. reflexivity.
      - rewrite IH. reflexivity.
      - apply normalIffStrictlyNormal in HU.
        apply normalIffStrictlyNormal in HV.
        destruct
          (normalTermsDenote _ HU) as [a Ha],
          (normalTermsDenote _ HV) as [b Hb].
        rewrite Ha, Hb. apply PCA.kSpec.
      - apply PCA.THMS.sSpec2'.
    Qed.

  End THMS.

End KS_RW.


Require Import Lia.
Require Import RelationClasses.
Require Import Coq.Lists.ListDec Decidable.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.

Require Import Time.

Set Implicit Arguments.

Lemma time_decidable: decidable_eq Time.t.
Proof.
  ii. destruct (Time.eq_dec x y); [left|right]; eauto.
Qed.

Definition loc_ts_eq_dec (lhs rhs:Loc.t * Time.t):
  {(fst lhs) = (fst rhs) /\ (snd lhs) = (snd rhs)} +
  {(fst lhs) <> (fst rhs) \/ (snd lhs) <> (snd rhs)}.
Proof.
  destruct lhs, rhs.
  destruct (Loc.eq_dec t t1), (Time.eq_dec t0 t2); subst; auto.
Defined.
Global Opaque loc_ts_eq_dec.

Lemma loc_time_decidable: decidable_eq (Loc.t * Time.t).
Proof.
  ii. destruct x, y.
  destruct (loc_ts_eq_dec (t, t0) (t1, t2)); ss.
  - left. des. subst. ss.
  - right. ii. inv H. des; ss.
Qed.

Module TimeMap <: JoinableType.
  Definition t := Loc.t -> Time.t.

  Definition eq := @eq t.

  Definition le (lhs rhs:t): Prop :=
    forall loc, Time.le (lhs loc) (rhs loc).

  Global Program Instance le_PreOrder: PreOrder le.
  Next Obligation. ii. refl. Qed.
  Next Obligation. ii. etrans; eauto. Qed.
  #[global] Hint Resolve le_PreOrder_obligation_2: core.

  Definition bot: t := fun _ => Time.bot.

  Lemma bot_spec (tm:t): le bot tm.
  Proof. ii. apply Time.bot_spec. Qed.

  Definition get (loc:Loc.t) (c:t) := c loc.

  Definition add (l:Loc.t) (ts:Time.t) (tm:t): t :=
    fun l' =>
      if Loc.eq_dec l' l
      then ts
      else get l' tm.

  Definition add_spec l' l ts tm:
    get l' (add l ts tm) =
    if Loc.eq_dec l' l
    then ts
    else get l' tm.
  Proof. auto. Qed.

  Lemma add_spec_eq l ts tm:
    get l (add l ts tm) = ts.
  Proof.
    rewrite add_spec.
    destruct (Loc.eq_dec l l); auto.
    congruence.
  Qed.

  Lemma add_spec_neq l' l ts tm (NEQ: l' <> l):
    get l' (add l ts tm) = get l' tm.
  Proof.
    rewrite add_spec.
    destruct (Loc.eq_dec l' l); auto.
    congruence.
  Qed.

  Definition join (lhs rhs:t): t :=
    fun loc => Time.join (lhs loc) (rhs loc).

  Lemma join_comm lhs rhs: join lhs rhs = join rhs lhs.
  Proof. apply LocFun.ext. i. apply Time.join_comm. Qed.

  Lemma join_assoc a b c: join (join a b) c = join a (join b c).
  Proof.
    apply LocFun.ext. i. apply Time.join_assoc.
  Qed.

  Lemma join_l lhs rhs: le lhs (join lhs rhs).
  Proof. ii. apply Time.join_l. Qed.

  Lemma join_r lhs rhs: le rhs (join lhs rhs).
  Proof. ii. apply Time.join_r. Qed.

  Lemma join_spec lhs rhs o
        (LHS: le lhs o)
        (RHS: le rhs o):
    le (join lhs rhs) o.
  Proof. unfold join. ii. apply Time.join_spec; auto. Qed.

  Definition singleton loc ts :=
    LocFun.add loc ts (LocFun.init Time.bot).

  Lemma singleton_spec loc ts c
        (LOC: Time.le ts (c loc)):
    le (singleton loc ts) c.
  Proof.
    ii. unfold singleton, LocFun.add, LocFun.find.
    condtac; subst; ss. apply Time.bot_spec.
  Qed.

  Lemma singleton_inv loc ts c
        (LE: le (singleton loc ts) c):
    Time.le ts (c loc).
  Proof.
    generalize (LE loc). unfold singleton, LocFun.add, LocFun.find.
    condtac; [|congr]. auto.
  Qed.

  Lemma le_join_l l r
        (LE: le r l):
    join l r = l.
  Proof.
    apply LocFun.ext. i.
    unfold join, Time.join, LocFun.find. condtac; auto.
    apply TimeFacts.antisym; auto.
  Qed.

  Lemma le_join_r l r
        (LE: le l r):
    join l r = r.
  Proof.
    apply LocFun.ext. i.
    unfold join, Time.join, LocFun.find. condtac; auto.
    exfalso. eapply Time.lt_strorder. eapply TimeFacts.lt_le_lt; eauto.
  Qed.

  Lemma antisym l r
        (LR: le l r)
        (RL: le r l):
    l = r.
  Proof.
    extensionality loc. apply TimeFacts.antisym; auto.
  Qed.
End TimeMap.

Module View <: JoinableType.
  Structure t_ := mk {
    pln: TimeMap.t;
    rlx: TimeMap.t;
  }.
  Definition t := t_.

  Inductive wf (view:t): Prop :=
  | wf_intro
      (PLN_RLX: TimeMap.le (pln view) (rlx view))
  .
  #[global] Hint Constructors wf: core.

  Inductive opt_wf: forall (view:option View.t), Prop :=
  | opt_wf_some
      view
      (WF: wf view):
      opt_wf (Some view)
  | opt_wf_none:
      opt_wf None
  .
  #[global] Hint Constructors opt_wf: core.

  Definition eq := @eq t.

  Inductive le_ (lhs rhs:t): Prop :=
  | le_intro
      (PLN: TimeMap.le (pln lhs) (pln rhs))
      (RLX: TimeMap.le (rlx lhs) (rlx rhs))
  .
  Definition le := le_.

  Global Program Instance le_PreOrder: PreOrder le.
  Next Obligation.
    ii. econs; refl.
  Qed.
  Next Obligation.
    ii. inv H. inv H0. econs; etrans; eauto.
  Qed.
  #[global] Hint Resolve le_PreOrder_obligation_2: core.

  Inductive opt_le: forall (lhs rhs:option t), Prop :=
  | opt_le_none
      rhs:
      opt_le None rhs
  | opt_le_some
      lhs rhs
      (LE: le lhs rhs):
      opt_le (Some lhs) (Some rhs)
  .
  #[global] Hint Constructors opt_le: core.

  Global Program Instance opt_le_PreOrder: PreOrder opt_le.
  Next Obligation.
    ii. destruct x; econs. refl.
  Qed.
  Next Obligation.
    ii. inv H; inv H0; econs. etrans; eauto.
  Qed.
  #[global] Hint Resolve opt_le_PreOrder_obligation_2: core.

  Lemma ext l r
        (PLN: (pln l) = (pln r))
        (RLX: (rlx l) = (rlx r))
    : l = r.
  Proof.
    destruct l, r. f_equal; auto.
  Qed.

  Definition bot: t := mk TimeMap.bot TimeMap.bot.

  Lemma bot_wf: wf bot.
  Proof. econs; refl. Qed.

  Lemma bot_spec (c:t): le bot c.
  Proof. econs; apply TimeMap.bot_spec. Qed.

  Definition join (lhs rhs:t): t :=
    mk (TimeMap.join (pln lhs) (pln rhs))
       (TimeMap.join (rlx lhs) (rlx rhs)).

  Lemma join_comm lhs rhs: join lhs rhs = join rhs lhs.
  Proof. unfold join. f_equal; apply TimeMap.join_comm. Qed.

  Lemma join_assoc a b c: join (join a b) c = join a (join b c).
  Proof.
    unfold join. ss. f_equal.
    - apply TimeMap.join_assoc.
    - apply TimeMap.join_assoc.
  Qed.

  Lemma join_l lhs rhs: le lhs (join lhs rhs).
  Proof. econs; apply TimeMap.join_l. Qed.

  Lemma join_r lhs rhs: le rhs (join lhs rhs).
  Proof. econs; apply TimeMap.join_r. Qed.

  Lemma join_spec lhs rhs o
        (LHS: le lhs o)
        (RHS: le rhs o):
    le (join lhs rhs) o.
  Proof.
    inv LHS. inv RHS.
    econs; apply TimeMap.join_spec; eauto.
  Qed.

  Lemma join_wf
        lhs rhs
        (LHS: wf lhs)
        (RHS: wf rhs):
    wf (join lhs rhs).
  Proof.
    econs.
    - apply TimeMap.join_spec.
      + etrans; [apply LHS|]. apply TimeMap.join_l.
      + etrans; [apply RHS|]. apply TimeMap.join_r.
  Qed.

  Definition bot_unless (cond:bool) (c:t): t :=
    if cond then c else bot.

  Lemma bot_unless_wf
        cond c
        (WF: wf c):
    wf (bot_unless cond c).
  Proof.
    destruct cond; ss. apply bot_wf.
  Qed.

  Definition singleton_ur loc ts :=
    mk (TimeMap.singleton loc ts)
       (TimeMap.singleton loc ts).

  Lemma singleton_ur_wf
        loc ts:
    wf (singleton_ur loc ts).
  Proof.
    econs; ss; refl.
  Qed.

  Lemma singleton_ur_spec loc ts c
        (WF: wf c)
        (TS: Time.le ts ((pln c) loc)):
    le (singleton_ur loc ts) c.
  Proof.
    econs; s;
      try apply TimeMap.bot_spec;
      try apply TimeMap.singleton_spec; auto.
    - etrans; eauto. apply WF.
  Qed.

  Lemma singleton_ur_inv loc ts c
        (LE: le (singleton_ur loc ts) c):
    Time.le ts ((pln c) loc).
  Proof.
    apply TimeMap.singleton_inv. apply LE.
  Qed.

  Definition singleton_rw loc ts :=
    mk TimeMap.bot
       (TimeMap.singleton loc ts).

  Lemma singleton_rw_wf
        loc ts:
    wf (singleton_rw loc ts).
  Proof.
    econs; ss; try refl. apply TimeMap.bot_spec.
  Qed.

  Lemma singleton_rw_spec loc ts c
        (WF: wf c)
        (TS: Time.le ts ((rlx c) loc)):
    le (singleton_rw loc ts) c.
  Proof.
    econs; s;
      try apply TimeMap.bot_spec;
      try apply TimeMap.singleton_spec; auto.
  Qed.

  Lemma singleton_rw_inv loc ts c
        (LE: le (singleton_rw loc ts) c):
    Time.le ts ((rlx c) loc).
  Proof.
    apply TimeMap.singleton_inv. apply LE.
  Qed.

  Definition singleton_ur_if (cond:bool) loc ts :=
    (if cond then singleton_ur else singleton_rw) loc ts.

  Lemma singleton_ur_if_wf
        cond loc ts:
    wf (singleton_ur_if cond loc ts).
  Proof.
    destruct cond; ss.
    - apply singleton_ur_wf.
    - apply singleton_rw_wf.
  Qed.

  Lemma singleton_ur_if_spec (cond:bool) loc ts c
        (WF: wf c)
        (TS: Time.le ts ((if cond then (pln c) else (rlx c)) loc)):
    le (singleton_ur_if cond loc ts) c.
  Proof.
    destruct cond; ss.
    - apply singleton_ur_spec; ss.
    - apply singleton_rw_spec; ss.
  Qed.

  Lemma singleton_ur_if_inv cond loc ts c
        (LE: le (singleton_ur_if cond loc ts) c):
    Time.le ts ((if cond then (pln c) else (rlx c)) loc).
  Proof.
    destruct cond; ss.
    - apply singleton_ur_inv. ss.
    - apply singleton_rw_inv. ss.
  Qed.

  Lemma le_join_l l r
        (LE: le r l):
    join l r = l.
  Proof.
    unfold join. destruct l. ss.
    f_equal; apply TimeMap.le_join_l; apply LE.
  Qed.

  Lemma le_join_r l r
        (LE: le l r):
    join l r = r.
  Proof.
    unfold join. destruct r. ss.
    f_equal; apply TimeMap.le_join_r; apply LE.
  Qed.

  Lemma antisym l r
        (LR: le l r)
        (RL: le r l):
    l = r.
  Proof.
    destruct l, r. inv LR. inv RL. ss. f_equal.
    - apply TimeMap.antisym; auto.
    - apply TimeMap.antisym; auto.
  Qed.

  Lemma opt_antisym l r
        (LR: opt_le l r)
        (RL: opt_le r l):
    l = r.
  Proof.
    inv LR; inv RL; ss. f_equal.
    apply antisym; ss.
  Qed.

  Lemma timemap_le_le tm1 tm2
        (LE: TimeMap.le tm1 tm2):
    le (mk tm1 tm1) (mk tm2 tm2).
  Proof. econs; eauto. Qed.

  Definition unwrap (view:option t): t :=
    match view with
    | Some view => view
    | None => bot
    end.

  Lemma unwrap_opt_wf
        view
        (WF: opt_wf view):
    wf (unwrap view).
  Proof.
    inv WF; ss. apply bot_wf.
  Qed.

  Lemma unwrap_opt_le
        view1 view2
        (WF: opt_le view1 view2):
    le (unwrap view1) (unwrap view2).
  Proof.
    inv WF; ss. apply bot_spec.
  Qed.

  Lemma opt_None_spec rhs:
    opt_le None rhs.
  Proof. econs. Qed.

  Lemma join_bot_l rhs:
    join bot rhs = rhs.
  Proof.
    apply antisym.
    - apply join_spec.
      + apply bot_spec.
      + refl.
    - apply join_r.
  Qed.

  Lemma join_bot_r lhs:
    join lhs bot = lhs.
  Proof.
    rewrite join_comm.
    apply join_bot_l.
  Qed.

  Lemma join_le
        v1 v2 w1 w2
        (LE1: le v1 w1)
        (LE2: le v2 w2):
    le (join v1 v2) (join w1 w2).
  Proof. eauto using join_spec, join_l, join_r. Qed.

  Lemma opt_le_ts
        v1 v2 loc
        (LE: opt_le v1 v2):
    Time.le ((rlx (unwrap v1)) loc) ((rlx (unwrap v2)) loc).
  Proof.
    inv LE; ss.
    - unfold TimeMap.bot. apply Time.bot_spec.
    - inv LE0. ss.
  Qed.
End View.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* A denotational semantics for computations that relates every computation to a denotation. *)

Set Implicit Arguments.

Require Export FCF.Comp.
Require Export FCF.Rat.
Require Import FCF.Fold.
Require Import List.
Require Import FCF.Blist.
Require Import micromega.Lia.
Require Import FCF.StdNat.
Require Import FCF.NotationV1.
Require Import FCF.EqDec.

Local Open Scope list_scope.
Local Open Scope rat_scope.

Ltac simp_in_support :=
  unfold setLet in *;
  match goal with
    | [H : In _ (getSupport (Bind _ _)) |- _ ] =>
      apply getSupport_Bind_In in H; destruct_exists; intuition
    | [H : In _ (getSupport (if ?t then _ else _)) |- _ ] => let x := fresh "x" in remember t as x; destruct x
    | [H : In _ (getSupport (ret _)) |- _ ] => apply getSupport_In_Ret in H; try pairInv; subst
(*     | [H : false = inRange _ _ |- _] => symmetry in H *)
    | [H : true = negb ?t |- _ ] => let x := fresh "x" in remember t as x; destruct x; simpl in H; try discriminate
  end.

(* evalDist is a denotational semantics that produces a distribution instead of a value. *)

Definition Distribution(A : Set) := A -> Rat.

Definition indicator(A : Set)(P : A -> bool) :=
  fun a => if (P a) then rat1 else rat0.

Fixpoint evalDist(A : Set)(c : Comp A) : Distribution A :=
  match c with
    | Ret eqd a => fun a' => if (eqd a a') then 1 else 0
    | Bind c1 c2 => fun a =>
      sumList (getSupport c1) (fun b => (evalDist c1 b) * (evalDist (c2 b) a))
    | Rnd n => fun v => 1 / (expnat 2 n)
    | Repeat c P => fun a => (indicator P a) * (ratInverse (sumList (filter P (getSupport c)) (evalDist c))) * (evalDist c a)
  end.

Definition dist_sem_eq(A : Set)(c1 c2 : Comp A) :=
  forall a, (evalDist c1 a) == (evalDist c2 a).

Definition Support(A : Set)(ls : list A)(d : Distribution A) :=
  NoDup ls /\
  (forall a, In a ls <-> ~((d a) == 0)).

Lemma getSupport_NoDup : forall (A : Set)(c : Comp A),
  NoDup (getSupport c).

  destruct c; intuition; simpl in *.

  econstructor.
  apply in_nil.
  econstructor.

  eapply getUnique_NoDup.

  eapply getAllBvectors_NoDup.

  eapply filter_NoDup.
  eapply getSupport_NoDup.

Qed.

Lemma filter_not_In : forall (A : Set)(ls : list A)(P : A -> bool) a,
                        (~In a ls) \/ P a = false <->
                        ~In a (filter P ls).

    intuition.
    eapply H1.
    eapply filter_In; eauto.
    assert (P a = true -> False).
    intuition.
    congruence.
    eapply H.
    eapply filter_In; eauto.

    case_eq (P a); intuition.
    left.
    intuition.
    eapply H.
    eapply filter_In; eauto.

Qed.

Theorem getSupport_In_evalDist : forall (A : Set)(c : Comp A)(a : A),
  In a (getSupport c) <-> ~(evalDist c a == 0).

  induction c; simpl in *; intuition.
  subst.
  destruct (e a0 a0).
  eapply rat1_ne_rat0.
  trivial.
  congruence.

  destruct (e a a0); subst.
  intuition.
  right.
  intuition.

  apply in_getUnique_if in H0.
  apply in_flatten in H0.

  destruct H0.
  intuition.
  apply in_map_iff in H2.
  destruct H2.
  intuition.

  eapply sumList_0 in H1; eauto.
  apply ratMult_0 in H1; intuition.
  eapply IHc; eauto.
  subst.
  eapply H; eauto.

  apply (in_getUnique (flatten (map (fun b : B => getSupport (c0 b)) (getSupport c)))).
  apply in_flatten.
  apply sumList_nz in H0.
  destruct H0.
  intuition.
  apply ratMult_nz in H2.
  intuition.
  econstructor.
  split.
  eapply in_map_iff.
  econstructor.
  split.
  eapply eq_refl.
  eapply H1.
  eapply H.
  eauto.

  eapply in_getAllBvectors.

  apply ratMult_0 in H0.
  intuition.
  apply ratMult_0 in H1.
  intuition.
  unfold indicator in *.
  case_eq (b a); intuition.
  rewrite H1 in H0.
  eapply rat1_ne_rat0.
  trivial.

  eapply filter_not_In.
  eauto.
  eauto.

  eapply ratInverse_nz; eauto.
  eapply IHc.
  eapply filter_In.
  eauto.
  trivial.

  apply ratMult_nz in H.
  intuition.
  apply ratMult_nz in H0.
  intuition.
  unfold indicator in *.
  case_eq (b a); intuition;
  rewrite H0 in H.
  eapply filter_In.
  intuition.
  eapply IHc.
  trivial.
  exfalso.
  intuition.

Qed.

Theorem getSupport_not_In_evalDist_h : forall (A : Set)(c : Comp A)(a : A),
~In a (getSupport c) -> (evalDist c a == 0).

  induction c; intuition; simpl in *.
  intuition.
  destruct (e a a0); subst;
  intuition.

  eapply sumList_0.
  intuition.
  eapply ratMult_0.
  right.
  eapply H.
  intuition.
  eapply H0.
  eapply (in_getUnique (flatten (map (fun b : B => getSupport (c0 b)) (getSupport c)))).
  eapply in_flatten.
  exists (getSupport (c0 a0)).
  intuition.
  eapply in_map_iff.
  exists a0.
  intuition.

  exfalso.
  eapply H.
  eapply in_getAllBvectors.

  apply filter_not_In in H.
  intuition.

  eapply ratMult_0.
  right.
  eauto.

  eapply ratMult_0.
  left.
  unfold indicator.
  rewrite H0.
  rewrite ratMult_0_l.
  intuition.
Qed.

Theorem getSupport_not_In_evalDist : forall (A : Set)(c : Comp A)(a : A),
  ~In a (getSupport c) <-> (evalDist c a == 0).

  intuition.

  eapply getSupport_not_In_evalDist_h.
  intuition.

  eapply getSupport_In_evalDist; eauto.
Qed.

Theorem getSupport_correct : forall (A : Set)(c : Comp A),
  Support (getSupport c)(evalDist c).

  intuition.
  econstructor.
  eapply getSupport_NoDup.

  apply getSupport_In_evalDist.

Qed.

(* We use evalDist as the probability measure.  Instead of supplying an event on the return type, we expect the computation to test for the occurrence of the event.  *)
Notation "'Pr' [ c  ] " := (evalDist c true) (at level 20).

Lemma evalDist_sum_bind_eq : forall (A B : Set)(eqdb : eq_dec B)(eqda : eq_dec A)(c1 : Comp B)(c2 : B -> Comp A),
  sumList (getSupport (Bind c1 c2)) (evalDist (Bind c1 c2)) ==
  sumList (getSupport c1) (fun b => evalDist c1 b * (sumList (getSupport (c2 b)) (evalDist (c2 b)))).

  intuition. simpl.
  eapply eqRat_trans.
  eapply sumList_comm.
  eapply sumList_body_eq; intuition.

  eapply eqRat_trans.
  eapply sumList_factor_constant_l.
  eapply ratMult_eqRat_compat; intuition.

  eapply eqRat_symm.
  eapply sumList_subset; intuition.
  eapply getSupport_NoDup.
  eapply getUnique_NoDup.
  eapply (in_getUnique (flatten (map (fun b : B => getSupport (c2 b)) (getSupport c1)))).
  eapply in_flatten.
  econstructor.
  split.
  eapply in_map_iff.
  econstructor.
  split.
  eapply eq_refl.
  eauto.
  eauto.

  eapply getSupport_not_In_evalDist.
  eauto.
Qed.

(*
Lemma evalDist_sum_repeat_eq : forall (A : Set)(eqda : eq_dec A)(c : Comp A) P,
  let scale := (ratInverse (sumList (filter P (getSupport c)) (evalDist c))) in
  sumList (getSupport (Repeat c P)) (evalDist (Repeat c P)) ==
  sumList (filter P (getSupport c1)) (fun b => scale * evalDist c1 b * (sumList (getSupport (c2 b)) (evalDist (c2 b)))).

  intuition. simpl.
  eapply eqRat_trans.
  eapply sumList_comm.
  eapply sumList_body_eq; intuition.

  eapply eqRat_trans.
  eapply sumList_factor_constant_l.
  eapply ratMult_eqRat_compat; intuition.

  eapply eqRat_symm.
  eapply sumList_subset; intuition.
  eapply getSupport_NoDup.
  eapply getUnique_NoDup.
  eapply in_getUnique.
  eapply in_flatten.
  econstructor.
  split.
  eapply in_map_iff.
  econstructor.
  split.
  eapply eq_refl.
  eauto.
  eauto.

  eapply getSupport_not_In_evalDist.
  eauto.

Qed.
*)

Lemma ratInverse_scale_sum_1 : forall (A : Set)(ls : list A)(f : A -> Rat),
  (forall a, In a ls -> ~f a == 0) ->
  length ls > O ->
  sumList ls (fun a => (ratInverse (sumList ls f)) * (f a)) == 1.

  intuition.
  rewrite sumList_factor_constant_l.
  eapply ratInverse_prod_1.
  intuition.
  destruct ls; simpl in *.
  lia.
  eapply sumList_0 in H1.
  eapply H.
  eauto.
  eauto.
  simpl.
  eauto.

Qed.

Lemma evalDist_lossless : forall (A : Set)(c : Comp A),
  well_formed_comp c ->
  sumList (getSupport c) (evalDist c) == 1.

  induction 1; intuition; simpl in *.
  unfold sumList; simpl in *.
  destruct (pf a a); intuition.
  rewrite <- ratAdd_0_l.
  intuition.

  eapply eqRat_trans.
  apply evalDist_sum_bind_eq.
  eapply comp_eq_dec; eauto.
  eapply bind_eq_dec; eauto.
  eapply eqRat_trans.
  eapply sumList_body_eq.
  intuition.
  apply ratMult_eqRat_compat.
  apply eqRat_refl.
  apply H1.
  trivial.
  eapply eqRat_trans.
  eapply sumList_body_eq; intuition.
  apply ratMult_1_r.
  trivial.

  rewrite sumList_body_const.
  rewrite getAllBvectors_length.
  rewrite <- ratMult_num_den.
  rewrite mult_1_l.
  eapply num_dem_same_rat1.

  rewrite posnatMult_1_r.
  unfold posnatToNat, natToPosnat.
  trivial.

  eapply eqRat_trans.
  eapply sumList_body_eq.
  intuition.
  eapply ratMult_eqRat_compat.
  assert (P a = true).
  eapply filter_In; eauto.
  unfold indicator.
  rewrite H2.
  eapply ratMult_1_l.
  eapply eqRat_refl.
  eapply ratInverse_scale_sum_1.
  intuition.
  eapply getSupport_In_evalDist.
  eapply filter_In.
  eapply H1.
  trivial.
  destruct (filter P (getSupport c)); simpl in *; intuition.

Qed.

Lemma sumList_filter_evalDist_le_1 : forall (A : Set)(c : Comp A)(P : A -> bool) a,
  well_formed_comp c ->
  In a (filter P (getSupport c)) ->
  1 <= sumList (filter (fun a' => negb (P a')) (getSupport c)) (evalDist c) ->
  False.

  intuition.
  assert (sumList (filter (fun a0 : A => negb (P a0)) (getSupport c)) (evalDist c) == 1).
  eapply leRat_impl_eqRat; trivial.
  eapply leRat_trans.
  eapply sumList_filter_le.
  rewrite evalDist_lossless.
  intuition.
  trivial.

  rewrite <- evalDist_lossless in H2; eauto.
  rewrite (sumList_filter_partition P (getSupport c)) in H2.
  symmetry in H2.
  rewrite ratAdd_comm in H2.
  apply ratAdd_arg_0 in H2.
  eapply sumList_0 in H2; eauto.
  eapply getSupport_In_evalDist.
  eapply filter_In; eauto.
  trivial.
Qed.

Theorem sumList_support_bool :
  forall (c : Comp bool),
    sumList (getSupport c) (evalDist c) ==
    evalDist c true + evalDist c false.

  intuition.
  rewrite (sumList_filter_partition (eqb true)).
  eapply ratAdd_eqRat_compat.

  destruct (eq_Rat_dec (Pr[c]) 0).
  rewrite e.
  eapply sumList_0.
  intuition.
  apply filter_In in H.
  intuition.
  rewrite eqb_leibniz in H1.
  subst.
  trivial.

  eapply sumList_exactly_one.
  eapply filter_NoDup.
  eapply getSupport_NoDup.
  eapply filter_In.
  intuition.
  eapply getSupport_In_evalDist.
  intuition.
  eapply eqb_leibniz.
  trivial.
  intuition.
  eapply filter_In in H.
  intuition.
  rewrite eqb_leibniz in H2.
  subst.
  intuition.

  destruct (eq_Rat_dec (evalDist c false) 0).
  rewrite e.
  eapply sumList_0.
  intuition.
  eapply filter_In in H.
  intuition.
  destruct a.
  rewrite eqb_refl in H1.
  simpl in *.
  discriminate.
  trivial.

  eapply sumList_exactly_one.
  eapply filter_NoDup.
  eapply getSupport_NoDup.
  eapply filter_In.
  intuition.
  eapply getSupport_In_evalDist.
  intuition.
  case_eq (eqb true false); intuition.
  rewrite eqb_leibniz in H.
  discriminate.

  intuition.
  eapply filter_In in H.
  intuition.
  destruct b.
  rewrite eqb_refl in H2.
  simpl in *.
  discriminate.
  intuition.
Qed.

Lemma evalDist_sum_le_1 : forall (A : Set)(c : Comp A),
  sumList (getSupport c) (evalDist c) <= 1.

  induction c; intuition; simpl in *.
  unfold sumList; simpl in *.
  destruct (e a a); intuition.
  rewrite <- ratAdd_0_l.
  intuition.

  eapply leRat_trans.
  eapply eqRat_impl_leRat.
  apply evalDist_sum_bind_eq.
  eapply comp_eq_dec; eauto.
  eapply bind_eq_dec; eauto.
  eapply leRat_trans.
  eapply sumList_le.
  intuition.
  apply ratMult_leRat_compat.
  apply leRat_refl.
  apply H.
  eapply leRat_trans.
  eapply sumList_le; intuition.
  eapply eqRat_impl_leRat.
  eapply ratMult_1_r.
  trivial.

  rewrite sumList_body_const.
  rewrite getAllBvectors_length.
  rewrite <- ratMult_num_den.
  rewrite mult_1_l.
  eapply eqRat_impl_leRat.
  eapply num_dem_same_rat1.

  rewrite posnatMult_1_r.
  unfold posnatToNat, natToPosnat.
  trivial.

  destruct (gt_dec (length (filter b (getSupport c))) 0).

  eapply leRat_trans.
  eapply eqRat_impl_leRat.
  eapply sumList_body_eq.
  intuition.
  eapply ratMult_eqRat_compat.
  assert (b a = true).
  eapply filter_In; eauto.

  unfold indicator.
  rewrite H0.
  eapply ratMult_1_l.
  eapply eqRat_refl.
  eapply leRat_trans.
  eapply eqRat_impl_leRat.
  eapply ratInverse_scale_sum_1.
  intuition.
  eapply getSupport_In_evalDist.
  eapply filter_In.
  eapply H.
  trivial.
  trivial.
  intuition.

  destruct (filter b (getSupport c)); simpl in *.
  unfold sumList.
  simpl.
  eapply rat0_le_all.

  lia.
Qed.

Lemma evalDist_le_1 : forall (A : Set)(c : Comp A) a,
  evalDist c a <= 1.

  intuition.
  eapply leRat_trans.
  2:{
    eapply (@evalDist_sum_le_1 _ c).
  }
  pose proof (comp_EqDec c).
  destruct (in_dec (EqDec_dec _) a (getSupport c)).
  eapply leRat_trans.
  2:{
    eapply eqRat_impl_leRat.
    symmetry.
    rewrite (sumList_partition (eqb a)).
    eapply ratAdd_eqRat_compat.
    eapply sumList_exactly_one.
    eapply getSupport_NoDup.
    eauto.
    intuition.
    case_eq (eqb a b); intuition.
    exfalso.
    eapply H1.
    eapply eqb_leibniz.
    trivial.
    eapply ratMult_0_r.
    eapply eqRat_refl.
  }

  eapply leRat_trans.
  eapply eqRat_impl_leRat.
  eapply ratAdd_0_r.
  eapply ratAdd_leRat_compat.
  rewrite eqb_refl.

  eapply leRat_trans.
  2:{
    eapply eqRat_impl_leRat.
    symmetry.
    eapply ratMult_1_r.
  }
  intuition.

  eapply rat0_le_all.

  apply getSupport_not_In_evalDist in n.
  rewrite n.
  eapply rat0_le_all.
Qed.

Theorem evalDist_complement :
  forall (c : Comp bool),
    well_formed_comp c ->
    evalDist c false == ratSubtract 1 (Pr[c]).

  intuition.
  eapply (@ratAdd_add_same_l _ (Pr[c])).
  rewrite ratSubtract_ratAdd_inverse_2.
  rewrite <- sumList_support_bool.
  eapply evalDist_lossless.
  trivial.

  eapply evalDist_le_1.
Qed.

Theorem evalDist_le_1_gen :
  forall (A : Set)(eqd : EqDec A)(c : Comp A)(ls : list A),
    NoDup ls ->
    sumList ls (evalDist c) <= 1.

  intuition.
  eapply leRat_trans.
  eapply eqRat_impl_leRat.
  eapply (sumList_filter_partition (fun a => if (in_dec (EqDec_dec _) a (getSupport c)) then true else false)).

  eapply leRat_trans.
  2:{
    eapply eqRat_impl_leRat.
    symmetry.
    eapply ratAdd_0_r.
  }
  eapply ratAdd_leRat_compat.

  eapply leRat_trans.
  eapply sumList_subset_le.
  intuition.
  eapply filter_NoDup.
  trivial.
  eapply (getSupport_NoDup c).
  intuition.
  eapply filter_In in H0.
  intuition.
  destruct (in_dec (EqDec_dec eqd) a (getSupport c)); intuition.
  discriminate.
  eapply evalDist_sum_le_1.

  eapply eqRat_impl_leRat.
  eapply sumList_0.
  intuition.
  eapply filter_In in H0.
  intuition.
  destruct (in_dec (EqDec_dec eqd) a (getSupport c)).
  simpl in *.
  discriminate.
  eapply getSupport_not_In_evalDist.
  trivial.

Qed.

Theorem evalDist_1_0 :
  forall (A : Set){eqd : EqDec A}(c : Comp A) a,
    well_formed_comp c ->
    evalDist c a == 1 ->
      (forall b, b <> a -> evalDist c b == 0).

  intuition.
  eapply leRat_impl_eqRat.

  eapply (leRat_ratAdd_same_r (evalDist c a)).
  eapply leRat_trans.
  2:{
    eapply eqRat_impl_leRat.
    rewrite H0.
    eapply ratAdd_0_l.
  }

  assert ( evalDist c b + evalDist c a ==
    sumList (a :: b :: nil)%list (evalDist c)).
  repeat rewrite sumList_cons.
  rewrite ratAdd_comm.
  eapply ratAdd_eqRat_compat; intuition.
  rewrite ratAdd_0_r at 1.
  eapply ratAdd_eqRat_compat; intuition.
  unfold sumList; simpl; intuition.

  rewrite H2.
  eapply evalDist_le_1_gen; intuition.
  econstructor.
  simpl; intuition.
  econstructor; simpl; intuition.
  econstructor.

  eapply rat0_le_all.

Qed.

Local Open Scope comp_scope.

Theorem EqDec_pair_l
  : forall (A B : Set)(eqd : EqDec (A * B))(b : B),
    EqDec A.

  intuition.
  exists (fun a1 a2 => eqb (a1, b) (a2, b)).
  intuition.
  rewrite eqb_leibniz in H.
  inversion H; intuition.
  subst.
  eapply eqb_refl.
Qed.

Fixpoint evalDist_OC(A B C: Set)(c : OracleComp A B C): forall(S : Set), EqDec S -> (S -> A -> Comp (B * S)) -> S -> Comp (C * S) :=
  match c in (OracleComp A B C) return (forall(S : Set), EqDec S -> (S -> A -> Comp (B * S)) -> S -> Comp (C * S))
    with
    | @OC_Query A' B' a =>
      fun (S : Set)(eqds : EqDec S)(o : S -> A' -> Comp (B' * S))(s : S) =>
        o s a
    | @OC_Run A'' B'' C' A' B' S' eqds' eqda'' eqdb'' c' o' s' =>
      fun (S : Set)(eqds : EqDec S)(o : S -> A' -> Comp (B' * S))(s : S) =>
      p <-$ evalDist_OC c' (pair_EqDec eqds' eqds) (fun x y => p <-$ evalDist_OC (o' (fst x) y) _ o (snd x); ret (fst (fst p), (snd (fst p), snd p))) (s', s);
      Ret
      (EqDec_dec (pair_EqDec (pair_EqDec
        (oc_EqDec c' (fun x => fst (oc_base_exists (o' s' x) (fun y => fst (comp_base_exists (o s y))))) (fun x => EqDec_pair_l (oc_EqDec (o' s' x) (fun y => fst (comp_base_exists (o s y))) (fun y => EqDec_pair_l (comp_EqDec (o s y)) s)) s' ))
        _) _ ))
      (fst p, fst (snd p), snd (snd p))

    | @OC_Ret A' B' C' c =>
      fun (S : Set)(eqds : EqDec S)(o : S -> A' -> Comp (B' * S))(s : S) =>
      x <-$ c; Ret
      (EqDec_dec (pair_EqDec (comp_EqDec c) _ ))
      (x, s)
    | @OC_Bind A' B' C' C'' c' f' =>
      fun (S : Set)(eqds : EqDec S)(o : S -> A' -> Comp (B' * S))(s : S) =>
      [z, s'] <-$2 evalDist_OC c' _ o s;
      evalDist_OC (f' z) _ o s'
  end.

Coercion evalDist_OC : OracleComp >-> Funclass.

Inductive well_formed_oc : forall (A B C : Set), OracleComp A B C -> Prop :=
| well_formed_OC_Query :
  forall (A B : Set)(a : A),
    well_formed_oc (OC_Query B a)
| well_formed_OC_Run :
  forall (A B C A' B' S : Set)
  (eqds : EqDec S)(eqdb : EqDec B)(eqda : EqDec A)(c : OracleComp A B C)
  (o : S -> A -> OracleComp A' B' (B * S))(s : S),
  well_formed_oc c ->
  (forall s a, well_formed_oc (o s a)) ->
  well_formed_oc (OC_Run eqds eqdb eqda c o s)
| well_formed_OC_Ret :
  forall (A B C : Set)(c : Comp C),
      well_formed_comp c ->
      well_formed_oc (OC_Ret A B c)
| well_formed_OC_Bind :
  forall (A B C C' : Set)(c : OracleComp A B C)(f : C -> OracleComp A B C'),
    well_formed_oc c ->
    (forall c, well_formed_oc (f c)) ->
    well_formed_oc (OC_Bind c f).

Local Open Scope nat_scope.

Definition in_oc_support(A B C : Set)(x : C)(c : OracleComp A B C) :=
  exists (S : Set)(eqds : EqDec S)(o : S -> A -> Comp (B * S))(s s' : S),
    In (x, s') (getSupport (c _ _ o s)).

Inductive queries_at_most : forall (A B C : Set), OracleComp A B C -> nat -> Prop :=
| qam_Bind :
  forall (A B C C' : Set)(c : OracleComp A B C')(f : C' -> OracleComp A B C) q1 q2,
    queries_at_most c q1 ->
    (forall c',
      in_oc_support c' c ->
       queries_at_most (f c') q2) ->
    queries_at_most (OC_Bind c f) (q1 + q2)
| qam_Query :
  forall (A B : Set)(a : A),
  queries_at_most (OC_Query B a) 1
| qam_Ret :
  forall (A B C : Set)(c : Comp C),
    queries_at_most (OC_Ret A B c) 0
| qam_Run :
  forall (A A' B B' C S : Set)(eqds : EqDec S)(eqda : EqDec A)(eqdb : EqDec B)
    (c : OracleComp A B C)(oc : S -> A -> OracleComp A' B' (B * S)) s q1 q2,
    queries_at_most c q1 ->
    (forall s a, queries_at_most (oc s a) q2) ->
    queries_at_most (OC_Run _ _ _ c oc s) (q1 * q2)
| qam_le :
  forall (A B C : Set)(c : OracleComp A B C) q1 q2,
    queries_at_most c q1 ->
    q1 <= q2 ->
    queries_at_most c q2.


Require Export Modal_syntax.
Require Export Classical.

Open Scope modal_scope.

(* Modal turnstile at world on model. *)
Reserved Notation "< W R V w > ⊩w ϕ"
         (at level 50, W at level 9, R at level 9, V at level 9, w at level 9,
          format "'<' W  R  V  w '>'  '⊩w'  ϕ").

Fixpoint mturnst (W:Set) (R: W -> W -> Prop) (V: propvar -> W -> Prop) (w:W) (ϕ: Modal)
  : Prop :=
  match ϕ with
    # p => (V p w)
  | m~ ψ => ~ <W R V w> ⊩w ψ
  | ψ1 m∧ ψ2 => <W R V w> ⊩w ψ1 /\ <W R V w> ⊩w ψ2
  | ψ1 m∨ ψ2 => <W R V w> ⊩w ψ1 \/ <W R V w> ⊩w ψ2
  | ψ1 m→ ψ2 => <W R V w> ⊩w ψ1 -> <W R V w> ⊩w ψ2
  | [.] ψ => forall u:W, (R w u) -> <W R V u> ⊩w ψ
  | <.> ψ => exists u:W, (R w u) /\ <W R V u> ⊩w ψ
  end
where  "< W R V w > ⊩w  ϕ" := (mturnst W R V w ϕ) : modal_scope.

(* Modal turnstile on model. *)
Definition mturnst_model (W:Set) (R: W -> W -> Prop) (V: propvar -> W -> Prop) (ϕ: Modal)
  : Prop := forall w:W, <W R V w> ⊩w ϕ.

Notation "< W R V > ⊩m ϕ" := (mturnst_model W R V ϕ)
                               (at level 50, W at level 9, R at level 9, V at level 9,
                                format  "'<' W  R  V '>'  '⊩m'  ϕ") : modal_scope.

(* Modal turnstile on frame. *)
Definition mturnst_frame (W:Set) (R: W -> W -> Prop) (ϕ: Modal) : Prop :=
  forall (V: propvar -> W -> Prop), <W R V> ⊩m ϕ.

Notation "< W R > ⊩ ϕ" := (mturnst_frame W R ϕ) (at level 50, W at level 9, R at level 9,
           format "'<' W  R '>'  '⊩'  ϕ"): modal_scope.

(* Modal validity w.r.t. all frames. *)
Definition mvalid (ϕ:Modal) : Prop :=
   forall (W:Set) (R: W -> W -> Prop), < W R > ⊩ ϕ.

(* Modal turnstile on frame locally. *)
Definition mturnst_frame_loc (W:Set) (R: W -> W -> Prop) (w : W) (ϕ: Modal) : Prop :=
  forall V: propvar -> W -> Prop, <W R V w> ⊩w ϕ.

Lemma mturnst_box : forall (W:Set) (R: W -> W -> Prop) (V: propvar -> W -> Prop)
                           (w:W) (ϕ:Modal),
<W R V w> ⊩w ([.]ϕ) = (forall d:W, (R w d) -> <W R V d> ⊩w ϕ).
Proof. auto. Qed.

Lemma mturnst_dia : forall (W:Set) (R: W -> W -> Prop) (V: propvar -> W -> Prop)
                            (w:W) (ϕ:Modal),
<W R V w> ⊩w (<.> ϕ) = (exists d:W, ((R w d) /\ <W R V d> ⊩w ϕ)).
Proof. auto. Qed.

(* ------------------------------------------------------------------------------------- *)

(* Proof of classicality *)

Lemma modal_LEM : forall ϕ W R V w,
    <W R V w> ⊩w (ϕ m∨ m~ ϕ).
Proof. intros. apply classic. Qed.

Lemma modal_LEM_model : forall ϕ W R V,
    <W R V> ⊩m (ϕ m∨ m~ ϕ).
Proof. intros. intros w. apply modal_LEM. Qed.

Lemma modal_LEM_frame : forall ϕ W R,
    <W R> ⊩ (ϕ m∨ m~ ϕ).
Proof.
  intros. intros V.
  apply modal_LEM_model.
Qed.


Require Import New.Field.
Require Import New.Complex.
Require Import Scalars.
Require Import Coq.Sets.Ensembles.

(* Fundamental operations on states. *)
Class StateOps Scalar State
  {scalar_cops : ComplexOps Scalar}
  {scalar_fops : FieldOps Scalar} := {
  cops :> ComplexOps State;
  (* Null state *)
  null : State;
  meet : State -> State -> State;
  join : State -> State -> State;
  scalar_prod : Scalar -> State -> State
}.

(* All properties of states will be theorems *)
Class States Scalar State
  {sops : ScalarOps Scalar}
  {state_ops : StateOps Scalar State} := {
  cprops_st :> ComplexProps State
}.

(* Is a set of states B a basis for state S, the inductive version *)
Inductive state_basis
  {Scalar} {State}
  {sops : ScalarOps Scalar}
  {state_ops : StateOps Scalar State}
  (B : Ensemble State) :
  State -> Prop :=
  (* Everything is a basis for null *)
  | state_null : state_basis B null
  (* B is a basis for S if it contains S *)
  | state_in_basis : forall (S : State),
                       In State B S -> state_basis B S
  (* B is a basis for a join if it's a basis for the components *)
  | state_join_basis : forall (S1 S2 : State),
                         state_basis B S1 ->
                         state_basis B S2 ->
                         state_basis B (join S1 S2)
  (* B is a basis for a meet if it's a basis for the components *)
  | state_meet_basis : forall (S1 S2 : State),
                              state_basis B S1 ->
                              state_basis B S2 ->
                              state_basis B (meet S1 S2)
  (* B is a basis for a scalar product if it's a basis for the inner state *)
  | state_scalar_basis : forall (a : Scalar) (S : State),
                                state_basis B S ->
                                state_basis B (scalar_prod a S)
  (* B is a basis for a complex conjugate if it's a basis for the inner state *)
  | state_conj_basis : forall (S : State),
                              state_basis B S ->
                              state_basis B (~ S).

(* Inductive predicates on states.  Basically, predicates that behave
 * nicely in induction. *)
Definition state_pred_inductive
  {Scalar} {State}
  {sops : ScalarOps Scalar}
  {state_ops : StateOps Scalar State}
  (P : State -> Prop) : Prop :=
  (forall (S1 S2 : State), P S1 -> P S2 -> P (join S1 S2)) /\
  (forall (S1 S2 : State), P S1 -> P S2 -> P (meet S1 S2)) /\
  (forall (S : State) (a : Scalar), P S -> P (scalar_prod a S)) /\
  (forall (S : State), P S -> P (~ S)) /\
  P null.

Definition state_pred_forall_basis
  {Scalar} {State}
  {sops : ScalarOps Scalar}
  {state_ops : StateOps Scalar State}
  (B : Ensemble State) (P : State -> Prop) : Prop :=
  forall (S : State), In State B S -> P S.