(** ** Kripke Semantics *)

Require Import Undecidability.FOL.Semantics.Tarski.FragmentFacts.
Require Export Undecidability.FOL.Semantics.Tarski.FragmentCore.
Require Export Undecidability.FOL.Syntax.Facts.
From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Local Notation vec := Vector.t.

#[local] Ltac comp := repeat (progress (cbn in *; autounfold in *)).

Section Kripke.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Section Model.

    Variable domain : Type.

    Class kmodel :=
      {
        nodes : Type ;

        reachable : nodes -> nodes -> Prop ;
        reach_refl u : reachable u u ;
        reach_tran u v w : reachable u v -> reachable v w -> reachable u w ;

        k_interp : interp domain ;
        k_P : nodes -> forall P : preds, Vector.t domain (ar_preds P) -> Prop ;
        (* k_Bot : nodes -> Prop ; *)

        mon_P : forall u v, reachable u v -> forall P (t : Vector.t domain (ar_preds P)), k_P u t -> k_P v t;
      }.

    Variable M : kmodel.

    Fixpoint ksat {ff : falsity_flag} u (rho : nat -> domain) (phi : form) : Prop :=
      match phi with
      | atom P v => k_P u (Vector.map (@eval _ _ _ k_interp rho) v)
      | falsity => False
      | bin Impl phi psi => forall v, reachable u v -> ksat v rho phi -> ksat v rho psi
      | quant All phi => forall j : domain, ksat u (j .: rho) phi
      end.

    Lemma ksat_mon {ff : falsity_flag} (u : nodes) (rho : nat -> domain) (phi : form) :
      forall v (H : reachable u v), ksat u rho phi -> ksat v rho phi.
    Proof.
      revert rho.
      induction phi; intros rho v' H; cbn; try destruct b0; try destruct q; intuition; eauto using mon_P, reach_tran.
    Qed.

    Lemma ksat_iff {ff : falsity_flag} u rho phi :
      ksat u rho phi <-> forall v (H : reachable u v), ksat v rho phi.
    Proof.
      split.
      - intros H1 v H2. eapply ksat_mon; eauto.
      - intros H. apply H. eapply reach_refl.
    Qed.
  End Model.

  Notation "rho  '⊩(' u ')'  phi" := (ksat _ u rho phi) (at level 20).
  Notation "rho '⊩(' u , M ')' phi" := (@ksat _ M _ u rho phi) (at level 20).
  Arguments ksat {_ _ _} _ _ _, _ _ _ _ _ _.

  Hint Resolve reach_refl : core.

  Section Substs.

    Variable D : Type.
    Context {M : kmodel D}.

    Lemma ksat_ext {ff : falsity_flag} u rho xi phi :
      (forall x, rho x = xi x) -> rho ⊩(u,M) phi <-> xi ⊩(u,M) phi.
    Proof.
      induction phi as [ | b P v | | ] in rho, xi, u |-*; intros Hext; comp.
      - tauto.
      - erewrite Vector.map_ext. reflexivity. intros t. now apply eval_ext.
      - destruct b0; split; intros H v Hv Hv'; now apply (IHphi2 v rho xi Hext), (H _ Hv), (IHphi1 v rho xi Hext).
      - destruct q; split; intros H d; apply (IHphi _ (d .: rho) (d .: xi)). all: ((intros []; cbn; congruence) + auto).
    Qed.

    Lemma ksat_comp {ff : falsity_flag} u rho xi phi :
      rho ⊩(u,M) phi[xi] <-> (xi >> eval rho (I := @k_interp _ M)) ⊩(u,M) phi.
    Proof.
      induction phi as [ | b P v | | ] in rho, xi, u |-*; comp.
      - tauto.
      - erewrite Vector.map_map. erewrite Vector.map_ext. 2: apply eval_comp. reflexivity.
      - destruct b0. setoid_rewrite IHphi1. now setoid_rewrite IHphi2.
      - destruct q. setoid_rewrite IHphi. split; intros H d; eapply ksat_ext. 2, 4: apply (H d).
        all: intros []; cbn; trivial; unfold funcomp; now erewrite eval_comp.
    Qed.

  End Substs.

  Context {ff : falsity_flag}.

  Definition kvalid_theo (T : form -> Prop) phi :=
    forall D (M : kmodel D) u rho, (forall psi, T psi -> ksat u rho psi) -> ksat u rho phi.

  Definition kvalid_ctx A phi :=
    forall D (M : kmodel D) u rho, (forall psi, psi el A -> ksat u rho psi) -> ksat u rho phi.

  Definition kvalid phi :=
    forall D (M : kmodel D) u rho, ksat u rho phi.

  Definition ksatis phi :=
    exists D (M : kmodel D) u rho, ksat u rho phi.

End Kripke.

Notation "rho  '⊩(' u ')'  phi" := (ksat u rho phi) (at level 20).
Notation "rho '⊩(' u , M ')' phi" := (@ksat _ _ _ M _ u rho phi) (at level 20).

Arguments ksat {_ _ _ _ _} _ _ _, {_ _ _} _ {_} _ _ _.

Section Bottom.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Context {domain : Type}.
  Context {M : kmodel domain}.
  Program Definition kmodel_bot
    (F_P : @nodes _ _ _ M -> Prop)
    (mon_F : forall u v, reachable u v -> F_P u -> F_P v)
     : @kmodel Σ_funcs (@Σ_preds_bot Σ_preds) domain := {|
    nodes := @nodes _ _ _ M ;
    reachable := @reachable _ _ _ M ;
    k_interp := interp_bot False (@k_interp _ _ _ M) ;
    k_P := fun n P => match P with inl _ => fun _ => F_P n | inr P' => @k_P _ _ _ M n P' end
  |}.
  Next Obligation. apply reach_refl. Qed.
  Next Obligation. now apply reach_tran with v. Qed.
  Next Obligation. destruct P as [|P'].
    + now apply mon_F with u.
    + now apply mon_P with u.
  Qed.

  Definition ksat_bot
    {ff : falsity_flag} (F_P : @nodes _ _ _ M -> Prop)
    (mon_F : forall u v, reachable u v -> F_P u -> F_P v)
    u (rho : env domain) (phi : form) : Prop
    := @ksat _ Σ_preds_bot domain (kmodel_bot mon_F) falsity_off u rho (falsity_to_pred phi).
  Arguments ksat_bot {_} _ _ _ _.

  Lemma sat_bot_False {ff:falsity_flag} u rho phi
    (e : forall u v, reachable u v -> False -> False)
    : @ksat_bot ff (fun _ => False) e u rho phi <-> @ksat _ _ domain M ff u rho phi.
  Proof.
    induction phi in rho,u|-*.
    - easy.
    - easy.
    - destruct b0. unfold sat_bot, falsity_to_pred in *. cbn.
      split; intros H v Hreach H1 %IHphi1; apply IHphi2; now apply H, H1.
    - destruct q. unfold sat_bot, falsity_to_pred in *. cbn.
      split; intros H d; apply IHphi, H.
  Qed.

End Bottom.

Arguments ksat_bot {_} {_} {_} {_} {_} _ _ _ _.

Section BottomDef.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Context {ff : falsity_flag}.

  Definition kexploding D (M : kmodel D) F_P mon_F := forall v rho phi, ksat_bot F_P mon_F v rho (⊥ → phi).
  Arguments kexploding _ _ _ _ : clear implicits.
  Definition kvalid_exploding_ctx A phi :=
    forall D (M : kmodel D) F_P mon_F u rho, kexploding D M F_P mon_F -> (forall psi, psi el A -> ksat_bot F_P mon_F u rho psi) -> ksat_bot F_P mon_F u rho phi.

  Definition kvalid_exploding phi :=
    forall D (M : kmodel D) F_P mon_F u rho, kexploding D M F_P mon_F -> ksat_bot F_P mon_F u rho phi.

  Definition ksatis_exploding phi :=
    exists D (M : kmodel D) F_P mon_F u rho, kexploding D M F_P mon_F /\ ksat_bot F_P mon_F u rho phi.

End BottomDef.


Require Import ssreflect Arith.
Require Import Arith.EqNat.
Require Import Arith.Compare_dec.
Require Import List.
Require Import Omega.
Require Import untypedLambda.
Require Import substitution.
Require Import reduction.
Require Import krivineAM.
Require Import compiler.

(*Division of the general result*)
Lemma transition_inv_access0: forall (c c0: code) (e e0 stack: environment), correct_state ((cCons (Access 0) c, cons c0 e0 e, stack)) -> correct_state  (c0, e0, stack).
Proof.
  simpl.
  intros.
  split.
  destruct H.
  inversion H; trivial.
  split.
  apply H.
  destruct H.
  inversion H; trivial.
Qed.

Lemma transition_inv_accessN: forall (c c0: code) (e e0 stack: environment) (n: nat), (n > 0) -> correct_state (cCons (Access n) c, cons c0 e0 e, stack) -> correct_state (cCons (Access (n-1)) c, e, stack).
Proof.
  simpl.
  intros.
  split.
  destruct H0.
  inversion H0; trivial.
  split.
  apply H0.
  destruct H0 as [h0 [h1 h2]].
  omega.
Qed.

Lemma transition_inv_push: forall (c c0: code) (e stack: environment), correct_state (cCons (Push c) c0, e, stack) -> correct_state (c0, e, cons c e stack).
Proof.
  simpl.
  intros.
  destruct H as [h1 [h2 [h3 h4]]].
  split; trivial.
  split.
  apply Correct_stk.
  done.
  done.
  done.
  done.
Qed.

Lemma transition_inv_grab: forall (c c0: code) (e e0 stack: environment), correct_state (cCons Grab c, e, cons c0 e0 stack) -> correct_state (c, cons c0 e0 e, stack).
Proof.
  simpl.
  intros.
  destruct H as [h1 [h2 h3]].
  split.
  apply Correct_stk.
  inversion h2.
  done.
  by (inversion h2).
  trivial.
  split.
  by (inversion h2).
  by rewrite plus_comm in h3.
Qed.

(*Question 5.3*)
Theorem correct_invariance: forall s: state, correct_state s -> correct_state (exec_inst s).
Proof.
  intro.
  destruct s.
  destruct p.
  move: e e0.
  induction c.
  move => e e0.
  case e0.
  case e.
  simpl.
  done.
  simpl.
  done.
  simpl.
  done.
  case i.
  intros n e e0.
  case e0.
  case n.
  simpl.
  done.
  simpl.
  done.
  intros c0 e1 e2.
  unfold exec_inst.
  case n.
  apply transition_inv_access0.
  intro.
  apply transition_inv_accessN.
  omega.
  unfold exec_inst.
  intros e e0.
  case e.
  done.
  intros c0 e1 e2.
  apply transition_inv_grab.
  intros c0 e e0.
  apply transition_inv_push.
Qed.

Lemma correct_reduction_access0: forall (c c0: code) (e e0 s: environment),correct_state ((cCons (Access 0) c, cons c0 e0 e, s)) -> (tau (cCons (Access 0) c, cons c0 e0 e, s)) = (tau (c0, e0, s)) \/ reducesInOneTo (tau (cCons (Access 0) c, cons c0 e0 e, s)) (tau (c0, e0, s)).
Proof.
  simpl.
  intros.
  case s.
  by left.
  intros.
  by left.
Qed.

Lemma correct_reduction_accessN: forall (c c0: code) (e e0 s: environment) (n: nat), (n > 0) -> correct_state (cCons (Access n) c, cons c0 e0 e, s) -> (tau (cCons (Access n) c, cons c0 e0 e, s)) = (tau (exec_inst (cCons (Access n) c, cons c0 e0 e, s))) \/ reducesInOneTo (tau (cCons (Access n) c, cons c0 e0 e, s)) (tau (exec_inst (cCons (Access n) c, cons c0 e0 e, s))).
Proof.
  have:forall n:nat, beq_nat n n = true.
  intro.
  rewrite beq_nat_true_iff.
  reflexivity.
  intro h0.
  unfold correct_state.
  intros c c0 e e0 s n.
  induction n.
  omega.
  intros.
  unfold exec_inst.
  destruct H0 as [h1 [h2 h3]].
  move:h1 h2 h3.
  case s.
  intros h1 h2 h3.
  simpl.
  rewrite ?h0.
  rewrite -?(length_inv).
  simpl in h3.
  rewrite -?minus_n_O.
  have:(leb n (lenEnv e - 1) = true).
  apply leb_iff.
  omega.
  intro h4.
  rewrite h4.
  have:(lenEnv e > 0).
  omega.
  intro.
  have:(exists n0:nat, lenEnv e = S n0).
  exists (lenEnv e - 1).
  omega.
  intro.
  case:x0.
  intros.
  rewrite p.
  have:(leb n x0 = true).
  apply leb_iff.
  omega.
  intro.
  rewrite x1.
  by left.
  intros.
  unfold tau.
  rewrite NPeano.Nat.sub_succ.
  rewrite -minus_n_O.
  rewrite -?length_inv.
  unfold tau_code.
  unfold multiple_substitution.
  rewrite -?minus_n_O.
  have:forall n: nat, 0 + n = n.
  intro.
  omega.
  intro.
  rewrite ?x.
  simpl in h3.
  have: S n <= lenEnv (cons c0 e0 e) - 1.
  simpl.
  simpl in h3.
  rewrite -minus_n_O.
  omega.
  intro.
  apply leb_iff in x0.
  rewrite length_inv in x0.
  rewrite x0.
  have: leb 0 (S n) = true.
  apply leb_iff.
  omega.
  intro.
  rewrite x1.
  have: leb 0 n = true.
  apply leb_iff.
  omega.
  intro.
  rewrite x2.
  have:(leb n (lenEnv e - 1) = true).
  apply leb_iff.
  omega.
  intro.
  rewrite length_inv in x3.
  rewrite x3.
  simpl.
  rewrite ?h0.
  by left.
Qed.

(*VERY USEFUL RESULTS TO PROVE THE LAST CASE*)
Lemma correct_reduction_push: forall (c c0: code) (e s: environment), correct_state (cCons (Push c0) c,e,s) -> ((tau (cCons (Push c0) c,e,s)) = (tau (c, e, cons c0 e s)) \/reducesInOneTo (tau (cCons (Push c0) c,e,s)) (tau (c, e, cons c0 e s))).
Proof.
  intros.
  simpl.
  case s.
  simpl.
  by left.
  intros.
  simpl in H.
  simpl.
  by left.
Qed.

Definition c_list_i (i:nat) (lu: list term) : Prop :=
  forall k: nat, k < Datatypes.length lu -> C i (nth k lu (Var 0)).

Fixpoint closed_list (i:nat) (lu: list term): Prop :=
  match lu with
    | nil => True
    | x :: xs => C i x /\ closed_list i xs
  end.

Lemma closed_list_eq: forall (lu: list term) (i: nat), closed_list i lu <-> c_list_i i lu.
Proof.
  induction lu.
  simpl.
  unfold c_list_i.
  split.
  simpl.
  intros.
  omega.
  done.
  simpl.
  split.
  intros.
  unfold c_list_i.
  intro.
  case k.
  simpl.
  intros.
  tauto.
  simpl.
  intros.
  apply IHlu.
  tauto.
  omega.
  intro.
  split.
  unfold c_list_i in H.
  apply (H 0).
  simpl.
  omega.
  apply IHlu.
  unfold c_list_i.
  intro.
  case k.
  intro.
  apply (H 1).
  simpl.
  omega.
  intros.
  apply (H (S (S n))).
  simpl.
  omega.
Qed.

Lemma lift_len_inv: forall (lu: list term) (i k: nat), length lu = length (lift_all i k lu).
Proof.
  induction lu; simpl.
  by simpl.
  intros.
  by rewrite -IHlu.
Qed.

Lemma remove_lift: forall (t: term) (i k: nat), C k t -> lifting i k t = t.
Proof.
  induction t; simpl.
  intros.
  have: leb k v = false.
  by apply leb_iff_conv.
  intros.
  by rewrite x.
  intros.
  rewrite -lambda_equivalence.
  by apply IHt.
  intros.
  rewrite app_equivalence.
  split.
  apply IHt1.
  tauto.
  apply IHt2.
  tauto.
Qed.

Lemma list_lift_free: forall (lu : list term) (i k : nat), c_list_i i lu -> c_list_i (i + 1) (lift_all 1 k lu).
Proof.
  induction lu; simpl.
  unfold c_list_i.
  simpl.
  intros.
  omega.
  unfold c_list_i.
  intros i k h1 k0.
  case k0.
  simpl.
  intro.
  apply lift_free.
  apply (h1 0).
  simpl.
  omega.
  simpl.
  intros.
  apply IHlu.
  unfold c_list_i.
  intros.
  apply (h1 (S k1)).
  simpl.
  omega.
  omega.
Qed.

Lemma mult_sub_clos: forall (t: term) (u: list term) (i: nat), closed_list i u -> C (i+Datatypes.length u) t -> C i (multiple_substitution i t u).
Proof.
  induction t.
  simpl.
  intros.
  have: beq_nat v v = true.
  apply beq_nat_true_iff.
  done.
  intro.
  rewrite x.
  have:leb v (i + Datatypes.length u - 1) = true.
  apply leb_iff.
  omega.
  intro.
  rewrite x0.
  rewrite Bool.andb_true_r.
  have:leb i v = false \/ leb i v = true.
  apply dic.
  intro.
  case x1.
  intro.
  rewrite H1.
  simpl.
  apply leb_iff_conv in H1.
  trivial.
  intro.
  rewrite H1.
  apply leb_iff in x0.
  apply leb_iff in H1.
  apply closed_list_eq in H.
  unfold c_list_i in H.
  apply H.
  omega.
  simpl.
  intros.
  apply (IHt (lift_all 1 0 u) (i+1)).
  apply closed_list_eq.
  apply closed_list_eq in H.
  apply list_lift_free.
  done.
  rewrite -(lift_len_inv _ 1 0).
  have: i + Datatypes.length u + 1 = i + 1 + Datatypes.length u.
  omega.
  intro.
  rewrite -x.
  trivial.
  simpl.
  intros.
  split.
  apply IHt1.
  done.
  tauto.
  apply IHt2.
  done.
  tauto.
Qed.

Lemma closed_env: forall e:environment, correct_stk e -> closed_list 0 (tau_env e).
Proof.
  induction e.
  simpl.
  intros.
  trivial.
  intros.
  simpl.
  inversion H.
  split.
  apply mult_sub_clos.
  by apply IHe1.
  simpl.
  by rewrite -length_inv.
  by apply IHe2.
Qed.

Lemma remove_list_lift: forall lu: list term, closed_list 0 lu -> lift_all 1 0 lu = lu.
Proof.
  induction lu.
  by simpl.
  simpl.
  intros.
  have: lifting 1 0 a = a.
  apply remove_lift.
  tauto.
  intro.
  rewrite x.
  have: lift_all 1 0 lu = lu.
  apply IHlu.
  tauto.
  intro.
  by rewrite x0.
Qed.

Lemma fold_reduce: forall (s: environment) (t u: term), reducesInOneTo t u -> reducesInOneTo (fold_left (fun t1 t2 : term => App t1 t2) (transform_stk s) t) (fold_left (fun t1 t2 : term => App t1 t2) (transform_stk s) u).
Proof.
  induction s.
  intros t u.
  simpl.
  intro.
  trivial.
  intros.
  unfold transform_stk.
  fold transform_stk.
  have: match s2 with
        | nul => multiple_substitution 0 (tau_code c) (tau_env s1) :: nil
        | cons _ _ _ =>
            multiple_substitution 0 (tau_code c) (tau_env s1)
            :: transform_stk s2
        end = multiple_substitution 0 (tau_code c) (tau_env s1) :: match s2 with
        | nul => nil
        | cons _ _ _ => transform_stk s2
        end.
  by case s2.
  intro.
  rewrite x.
  clear x.
  have:forall t:term, (fold_left (fun t1 t2 : term => App t1 t2)
        (multiple_substitution 0 (tau_code c) (tau_env s1)
         :: match s2 with
            | nul => nil
            | cons _ _ _ => transform_stk s2
            end) t)
            =
            (fold_left (fun t1 t2 : term => App t1 t2)
                       match s2 with
                         | nul => nil
                         | cons _ _ _ => transform_stk s2
                       end) (App t (multiple_substitution 0 (tau_code c) (tau_env s1))).
  by case s2.
  intros.
  rewrite ?x.
  clear x.
  move:IHs2.
  case s2.
  simpl.
  intros.
  by apply appLeft.
  intros.
  apply IHs2.
  by apply appLeft.
Qed.

Lemma correct_reduction_grab: forall (c: code) (e s: environment), correct_state (cCons Grab c, e, s) -> (tau (cCons Grab c, e, s)) = (tau (exec_inst (cCons Grab c, e, s))) \/ reducesInOneTo (tau (cCons Grab c, e, s)) (tau (exec_inst (cCons Grab c, e, s))).
Proof.
  intros c e s.
  move: c e.
  induction s.
  simpl.
  intros.
  by left.
  intros.
  inversion H.
  unfold exec_inst.
  unfold tau.
  unfold tau_code.
  fold tau_code.
  unfold transform_stk.
  fold transform_stk.
  have: match s2 with
        | nul => multiple_substitution 0 (tau_code c) (tau_env s1) :: nil
        | cons _ _ _ =>
            multiple_substitution 0 (tau_code c) (tau_env s1)
            :: transform_stk s2
        end = multiple_substitution 0 (tau_code c) (tau_env s1) :: match s2 with
        | nul => nil
        | cons _ _ _ => transform_stk s2
        end.
  by case s2.
  intro.
  rewrite x.
  unfold multiple_substitution.
  fold multiple_substitution.
  simpl.
  rewrite mult_sub_inv.
  case s2.
  simpl.
  have:lift_all 1 0 (tau_env e) = tau_env e.
  apply remove_list_lift.
  by apply closed_env.
  clear x.
  intro.
  rewrite x.
  right.
  apply removeLamb.
  right.
  apply fold_reduce.
  simpl.
  have:lift_all 1 0 (tau_env e) = tau_env e.
  apply remove_list_lift.
  by apply closed_env.
  clear x.
  intro.
  rewrite x.
  apply removeLamb.
  intro j.
  apply closed_list_eq.
  simpl in H.
  destruct H as [h1 [h2 h3]].
  by apply closed_env.
Qed.

(*General case - Question 5.4*)
Theorem correct_reduction: forall s: state, correct_state s -> (tau s) = (tau (exec_inst s)) \/ reducesInOneTo (tau s) (tau (exec_inst s)).
Proof.
  intro s.
  destruct s as ((c, e), s).
  move: e s.
  induction c.
  intros.
  by left.
  case i.
  intros n e s.
  case n.
  intros.
  unfold exec_inst.
  move:H.
  case e.
  intro.
  by left.
  intros.
  apply correct_reduction_access0.
  done.
  case e.
  intros.
  unfold exec_inst.
  by left.
  intros c0 e0 e1 n0.
  intro.
  apply correct_reduction_accessN.
  omega.
  done.
  unfold exec_inst.
  intros.
  move:H.
  case s.
  intro.
  by left.
  intros.
  apply correct_reduction_grab.
  done.
  unfold exec_inst.
  intros.
  apply correct_reduction_push.
  done.
Qed.

(*Question 5.5*)
Lemma mult_exec_red: forall (s1 s2: state), mult_exec_inst s1 s2 -> correct_state s1 -> forall (t u:term), t = tau s1 -> u = tau s2 -> reduces t u.
Proof.
  intros s1 s2 h0 h1.
  induction h0.
  intros.
  rewrite H; rewrite H0.
  apply sym.
  intros.
  elim (correct_reduction s1).
  intro.
  rewrite H.
  rewrite H1.
  apply IHh0.
  apply correct_invariance; trivial.
  trivial.
  done.
  intro.
  apply (ind _ (tau (exec_inst s1)) _ ).
  rewrite H.
  done.
  apply IHh0.
    by apply correct_invariance.
    trivial.
    done.
    done.
Qed.

Lemma closed_implies_correct: forall t: term, C 0 t -> correct_state (compile t, nul, nul).
Proof.
  induction t; simpl.
  omega.
  intros.
  split.
  simpl.
  apply Correct_stk_nil.
  split.
  apply Correct_stk_nil.
  rewrite -tau_nil_env.
  have:(tau (compile t, nul, nul)) = t.
  apply invert_comp.
  intro.
    by rewrite x.
  intros; destruct H.
  split.
  apply Correct_stk_nil.
  split.
  apply Correct_stk_nil.
  split.
  rewrite -tau_nil_env.
  by rewrite invert_comp.
  rewrite -tau_nil_env.
  by rewrite invert_comp.
Qed.

Theorem compiling_correct: forall (t: term) (s: state), C 0 t -> mult_exec_inst (compile t, nul, nul) s -> reduces t (tau s).
Proof.
  intros.
  apply (mult_exec_red (compile t, nul, nul) s).
  done.
  by apply closed_implies_correct.
  symmetry.
  apply invert_comp.
  done.
Qed.


From mathcomp.ssreflect Require Import ssreflect ssrnat ssrbool eqtype seq ssrnat.
From mathcomp.algebra Require Import ssrint.

Require Import Coq.Logic.Eqdep.

(*** Quality of life *)
Definition _dollar {Tx Ty} (x:Tx->Ty) (v:Tx) := x v.
Transparent _dollar.

Notation "x $ y" := (@_dollar _ _ x y) (at level 100, right associativity) :core_scope.
Hint Transparent _dollar.
Hint Unfold _dollar.

Definition cast {A B : Type} (a: A ) (H: A= B ) : B. rewrite <- H. exact a. Defined.
Notation "/! x" := (cast x _) (at level 100, no associativity).
Notation "x ?" := (option x) (at level 150, left associativity).

(*** Decidable quality and reflect *)
Definition eq_dec T := forall x y: T, {x = y} + {~ x = y}.
Scheme Equality for nat.
Scheme Equality for unit.

Definition reflect_from_dec {T} (cmp: eq_dec T): (@Equality.axiom T (fun x y => if cmp x y then true else false) ).
  rewrite /Equality.axiom. move=> x y.
  move: (cmp x y) => [] //=; by constructor.
Qed.

Definition to_cmp {T} {E:eqType} (f: T-> E) (x y: T) := f x == f y .
Notation "//= f , .. , z // " := ( cons (to_cmp f) .. (cons  (to_cmp z) nil)  .. ).
Definition cmp_with {T:Type} (fs: seq (T->T->bool) ) (x y: T) := all (fun f=> f x y) fs.

Definition dec_from_reflect {T:eqType} (Hr: forall (x y:T), reflect (x=y) (x==y)) : eq_dec T.
  rewrite /eq_dec.
  move=> x y.  case: ( Hr x y ); by [apply left | apply right]. Defined.

Definition int_eq_dec := @dec_from_reflect int_eqType (@eqP int_eqType).
Ltac depcomp H := apply EqdepFacts.eq_sigT_eq_dep in H; apply Coq.Logic.Eqdep.EqdepTheory.eq_dep_eq in H.

(*** seq helpers *)
Fixpoint  zipwith_when_eqlength {A B} (f: A->B->bool) (x: seq A) (y: seq B) : bool :=
  match x,y with
    | x::xs, y::ys => f x y &&  zipwith_when_eqlength f xs ys
    | nil, nil => true
    | nil, _ | _, nil => false
  end.

Theorem seq_eq_dec T: eq_dec T -> eq_dec ( seq T ).
  rewrite /eq_dec.
  move=> H s1 s2.
  elim: s1 s2.
  elim; by [left| right ; discriminate].
  move => a l IH [].
       * by right; discriminate.
       * move=> y ys.
         move: (H a y) => [Ha|Ha]; move: (IH ys) => [Hy|Hy].
         ** inversion Hy; subst; by left.
         ** by right; case=> * *; subst.
         ** by right; case.
         ** by right; case.
Qed.

Definition option_find {T:Type} (p: T -> bool) (s:seq T): option T :=
  match filter p s with
    | nil => None
    | x::_ => Some x
    end.

Definition option_nth {T:eqType} (s:seq T) (n: nat) := nth None (map (@Some _) s) n.

Definition cat_if_some {T} (l r: option ( seq T) ) : option (seq T):=
  match l, r with
    | Some x, Some y => Some ( x ++ y )
    | _, _ => None
    end.
Notation "x /++/ y" := (cat_if_some x y) (at level 35).


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Mult.
Require Import BinNat.
Require Import Nnat.
Require Export Ring.
Set Implicit Arguments.

Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq nat).
 Proof.
  constructor. exact plus_0_l. exact plus_comm. exact plus_assoc.
  exact mult_1_l. exact mult_0_l. exact mult_comm. exact mult_assoc.
  exact mult_plus_distr_r.
 Qed.

Lemma nat_morph_N :
   semi_morph 0 1 plus mult (eq (A:=nat))
          0%N 1%N Nplus Nmult Neq_bool nat_of_N.
Proof.
  constructor;trivial.
  exact nat_of_Nplus.
  exact nat_of_Nmult.
  intros x y H;rewrite (Neq_bool_ok _ _ H);trivial.
Qed.

Ltac natcst t :=
  match isnatcst t with
    true => constr:(N_of_nat t)
  | _ => constr:InitialRing.NotConstant
  end.

Ltac Ss_to_add f acc :=
  match f with
  | S ?f1 => Ss_to_add f1 (S acc)
  | _ => constr:(acc + f)%nat
  end.

Ltac natprering :=
  match goal with
    |- context C [S ?p] =>
    match p with
      O => fail 1 (* avoid replacing 1 with 1+0 ! *)
    | p => match isnatcst p with
           | true => fail 1
           | false => let v := Ss_to_add p (S 0) in
                         fold v; natprering
           end
    end
  | _ => idtac
  end.

Add Ring natr : natSRth
  (morphism nat_morph_N, constants [natcst], preprocess [natprering]).


Require Import Framework.
Import ListNotations.
Import Mem.

Set Implicit Arguments.

Instance value_eq_dec: EqDec value := value_dec.
Instance hash_eq_dec: EqDec hash := hash_dec.

Definition hashmap := @mem hash hash_dec (hash * value).
Definition encryption_map:= @mem value value_dec (key * value).

  Inductive token' :=
  | Key : key -> token'
  | Crash : token'
  | Cont : token'.

  Definition state' := (list key * hashmap * encryption_map)%type.

  Inductive crypto_prog : Type -> Type :=
  | GetKey : crypto_prog key
  | Hash : hash -> value -> crypto_prog hash
  | Encrypt : key -> value -> crypto_prog value
  | Decrypt : key -> value -> crypto_prog value.

  Inductive exec' :
    forall T, user -> token' ->  state' -> crypto_prog T -> @Result state' T -> Prop :=

  | ExecHash :
      forall s h v u,
        let kl := fst (fst s) in
        let hm := snd (fst s) in
        let em := snd s in
        let hv := hash_function h v in
        consistent hm hv (h, v) ->
        exec' u Cont s (Hash h v) (Finished (kl, (upd hm hv (h, v)), em) hv)

  | ExecEncrypt :
      forall s k v u,
        let kl := fst (fst s) in
        let hm := snd (fst s) in
        let em := snd s in
        consistent em (encrypt k v) (k, v) ->
        exec' u Cont s (Encrypt k v) (Finished (kl, hm, upd em (encrypt k v) (k, v)) (encrypt k v))

  | ExecDecrypt :
      forall s ev k u,
        let kl := fst (fst s) in
        let hm := snd (fst s) in
        let em := snd s in
        consistent em ev (k, decrypt k ev) ->
        exec' u Cont s (Decrypt k ev) (Finished (kl, hm, upd em ev (k, decrypt k ev)) (decrypt k ev))

  | ExecGetKey :
      forall s k u,
        let kl := fst (fst s) in
        let hm := snd (fst s) in
        let em := snd s in
        ~In k kl ->
        exec' u (Key k) s GetKey (Finished ((k::kl), hm, em) k)

  | ExecCrash :
      forall T d (p: crypto_prog T) u,
        exec' u Crash d p (Crashed d).

  Hint Constructors exec' : core.

  Theorem exec_deterministic_wrt_token' :
    forall u o s T (p: crypto_prog T) ret1 ret2,
      exec' u o s p ret1 ->
      exec' u o s p ret2 ->
      ret1 = ret2.
  Proof.
    intros; destruct p; simpl in *; cleanup;
    repeat
      match goal with
      | [H: exec' _ _ _ _ _ |- _] =>
        inversion H; clear H; cleanup
      end; eauto.
  Qed.

  Definition CryptoOperation :=
    Build_Core
      crypto_prog
      exec'
      exec_deterministic_wrt_token'.

  Definition CryptoLang := Build_Layer CryptoOperation.


(** * Registration modes *)

(**
  There are three registration modes:
  - [SIGNAL_ONLY] for tasks that do not wait for others and produce signals;
  - [WAIT_ONLY] for tasks that wait for others and do not produce signals;
  - [SIGNAL_WAIT] for tasks that wait for others and produce signals.
*)

Inductive regmode := SIGNAL_ONLY | WAIT_ONLY | SIGNAL_WAIT.

(**
  The relation [r_le], notation <=, establishes an ordering among registration
  modes. This relation plays a crutial role in the registration of tasks.
  Tasks can only register tasks being spawned. Registration must follow the
  Capability rule that states that the registration mode of the spawned task
  cannot be greater than the spawner.
*)

Inductive r_le : regmode -> regmode -> Prop :=
  | r_le_so:
    r_le SIGNAL_ONLY SIGNAL_ONLY
  | r_le_wo:
    r_le WAIT_ONLY WAIT_ONLY
  | r_le_sw:
    forall m,
    r_le m SIGNAL_WAIT.

  Definition union r1 r2 :=
  match r1, r2 with
  | WAIT_ONLY, WAIT_ONLY => WAIT_ONLY
  | SIGNAL_ONLY, SIGNAL_ONLY => SIGNAL_ONLY
  | _, _ => SIGNAL_WAIT
  end.

Module Notations.
  Infix "<=" := (r_le) : reg_scope.
End Notations.

(**
  Two important notions used throught the formalization are wait-/signal-capabilities.
*)

Inductive CanWait : regmode -> Prop :=
  | can_wait_sw:
    CanWait SIGNAL_WAIT
  | can_wait_wo:
    CanWait WAIT_ONLY.

Hint Constructors CanWait.

Inductive CanSignal : regmode -> Prop :=
  | can_signal_sw:
    CanSignal SIGNAL_WAIT
  | can_signal_so:
    CanSignal SIGNAL_ONLY.

Hint Constructors CanSignal.

Section Facts.

  (** We now define the facts related to registration modes. *)

  Import Notations.
  Open Scope reg_scope.

  (** The equality of registration mode is decidable. *)

  Lemma regmode_eq:
    forall (m1 m2:regmode),
    { m1 = m2 } + { m1 <> m2 }.
  Proof.
    intros.
    destruct m1, m2; auto;
    right;
    unfold not;
    intros N;
    inversion N.
  Defined.

  (** Checking for the wait capability is a decidable property. *)

  Lemma can_wait:
    forall r,
    { CanWait r } + { ~ CanWait r }.
  Proof.
    intros.
    destruct r; auto.
    right; intuition; inversion H.
  Defined.

  Lemma neq_so_to_can_wait:
    forall r,
    r <> SIGNAL_ONLY ->
    CanWait r.
  Proof.
    intros.
    destruct r; auto.
    contradiction H; trivial.
  Qed.

  Lemma can_wait_to_neq_so:
    forall r,
    CanWait r ->
    r <> SIGNAL_ONLY.
  Proof.
    intros.
    inversion H;
      subst;
      intuition;
      inversion H0.
  Qed.

  Lemma can_wait_rw:
    forall r,
    CanWait r <-> r <> SIGNAL_ONLY.
  Proof.
    intros.
    split; auto using can_wait_to_neq_so, neq_so_to_can_wait.
  Qed.

  Lemma not_can_wait_to_so:
    forall r,
    ~ CanWait r ->
    r = SIGNAL_ONLY.
  Proof.
    intros.
    destruct r;
    intuition;
    contradiction H;
    auto.
  Qed.

  Lemma so_to_not_can_wait:
    forall r,
    r = SIGNAL_ONLY ->
    ~ CanWait r.
  Proof.
    intros.
    intuition.
    inversion H0;
    rewrite <- H1 in *;
    inversion H.
  Qed.

  Lemma can_wait_so:
    forall r,
    { CanWait r } + { r = SIGNAL_ONLY }.
  Proof.
    intros.
    destruct (can_wait r);
    auto using not_can_wait_to_so.
  Defined.

  Lemma can_signal:
    forall r,
    { CanSignal r } + { ~ CanSignal r }.
  Proof.
    intros.
    destruct r; auto.
    right; intuition; inversion H.
  Defined.

  Lemma neq_wo_to_can_signal:
    forall r,
    r <> WAIT_ONLY ->
    CanSignal r.
  Proof.
    destruct r; intuition.
  Qed.

  Lemma can_signal_to_neq_wo:
    forall r,
    CanSignal r ->
    r <> WAIT_ONLY.
  Proof.
    intros.
    inversion H;
      subst;
      intuition;
      inversion H0.
  Qed.

  Lemma can_signal_rw:
    forall r,
    CanSignal r <-> r <> WAIT_ONLY.
  Proof.
    intros.
    split; auto using can_signal_to_neq_wo, neq_wo_to_can_signal.
  Qed.

  Lemma not_can_signal_to_wo:
    forall r,
    ~ CanSignal r ->
    r = WAIT_ONLY.
  Proof.
    intros.
    destruct r;
    intuition;
    contradiction H;
    auto.
  Qed.

  Lemma can_signal_wo:
    forall r,
    { CanSignal r } + { r = WAIT_ONLY }.
  Proof.
    intros.
    destruct (can_signal r);
    auto using not_can_signal_to_wo.
  Defined.

  Lemma can_signal_and_can_wait_to_sw:
    forall r,
    CanSignal r ->
    CanWait r ->
    r = SIGNAL_WAIT.
  Proof.
    intros.
    destruct H; trivial.
    inversion H0.
  Qed.

  Lemma can_signal_can_wait_to_sw:
    forall r,
    CanWait r ->
    CanSignal r ->
    r = SIGNAL_WAIT.
  Proof.
    intros.
    destruct r; try (inversion H || inversion H0).
    trivial.
  Qed.

  Definition le_dec x y:
    { x <= y } + { ~ x <= y }.
  Proof.
    destruct x, y;
    auto using r_le_so, r_le_sw, r_le_wo;
    right; unfold not; intros N;
    inversion N.
  Defined.

  Lemma can_wait_le:
    forall x y,
    CanWait y ->
    y <= x ->
    CanWait x.
  Proof.
    intros.
    inversion H0; subst; auto using can_wait_sw, can_wait_wo.
  Qed.

  Lemma can_signal_le:
    forall x y,
    CanSignal y ->
    y <= x ->
    CanSignal x.
  Proof.
    intros.
    inversion H0; subst; auto using can_signal_sw, can_signal_wo.
  Qed.
End Facts.