(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
Require Import Decision.

(* This file defines a typeclass for observations (the return type of the
   observation functions discussed in the paper). We require all observations
   to come with a partial order here, in anticipation of proving monotonicity
   with respect to a semantics (see Section 2 of the paper for discussion of
   monotonicity). *)

Section OBSERVATION.

  (* To talk about observations, we need a carrier type for both the observations
     themselves and the principals that can do the observing.

     The obs_leq predicate defines the partial order.

     The obs_measure function maps each observation to a natural number, which
     is meant to represent the "number of observations" made (e.g., if the
     observation type is an output buffer, then the measure would be the size
     of the buffer). We need it for technical reasons that come up in simulations
     and whole-execution behaviors; we hope that a future version will be able to
     get rid of this measure. *)
  Class ObservationOps :=
    {
      principal : Type;
      obs : Type;
      obs_leq : obs -> obs -> Prop;
      obs_lt o1 o2 := obs_leq o1 o2 /\ o1 <> o2;
      obs_measure : obs -> nat
    }.

  Class Observation `{Obs: ObservationOps} :=
    {
      (* decidability is useful for technical reasons *)
      principal_eq_dec : forall p1 p2 : principal, Decision (p1 = p2);
      obs_eq_dec : forall o1 o2 : obs, Decision (o1 = o2);

      (* obs_leq must be a partial order *)
      obs_leq_refl : forall o, obs_leq o o;
      obs_leq_antisym :
        forall o1 o2, obs_leq o1 o2 -> obs_leq o2 o1 -> o1 = o2;
      obs_leq_trans :
        forall o1 o2 o3, obs_leq o1 o2 -> obs_leq o2 o3 -> obs_leq o1 o3;

      (* obs_measure must be consistent with obs_leq *)
      obs_lt_measure :
        forall o1 o2, obs_lt o1 o2 -> obs_measure o1 < obs_measure o2
    }.

  Context `{Obs : Observation}.

  Lemma obs_leq_lt :
    forall o1 o2,
      obs_leq o1 o2 <-> obs_lt o1 o2 \/ o1 = o2.
  Proof.
    unfold obs_lt; intros o1 o2; split; intro H.
    destruct (obs_eq_dec o1 o2); auto.
    destruct H as [[? ?]|?]; auto.
    subst; apply obs_leq_refl.
  Qed.

  Lemma obs_measure_eq :
    forall o1 o2,
      obs_leq o1 o2 ->
      obs_measure o1 = obs_measure o2 ->
      o1 = o2.
  Proof.
    intros o1 o2 Hleq Hm.
    rewrite obs_leq_lt in Hleq; destruct Hleq; auto.
    apply obs_lt_measure in H; omega.
  Qed.

End OBSERVATION.


Require Import Setoid.

Parameter recursion : forall A : Set, A -> (nat -> A -> A) -> nat -> A.

Axiom recursion_S :
  forall (A : Set) (EA : relation A) (a : A) (f : nat -> A -> A) (n : nat),
    EA (recursion A a f (S n)) (f n (recursion A a f n)).

Goal forall n : nat, recursion nat 0 (fun _ _ => 1) (S n) = 1.
intro n.
rewrite recursion_S.
reflexivity.
Qed.

Goal forall n : nat, recursion nat 0 (fun _ _ => 1) (S n) = 1.
intro n.
setoid_rewrite recursion_S.
reflexivity.
Qed.


(****************************************************************)
(*  On monadic parametricity of second-order functionals        *)
(*  by Bauer A., Hofmann M., Karbyshev A.                       *)
(*                                                              *)
(*  Aleksandr Karbyshev                                         *)
(*  May 2012                                                    *)
(*  Build with Coq 8.4 + Ssreflect 1.4                          *)
(****************************************************************)

(* typeddensem.v
   Calculus specification and its denotational semantics
*)

Require Import ssreflect seq.
Set Automatic Coercions Import.
Require Export PredomAll.
Require Export monads.
Require Import stuff.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(*Set Printing Width 65.*)

(* Types and contexts *)

Parameter baseType : Type.

Inductive Ty := Base (o : baseType) | Arrow (ty1 ty2 : Ty) | Prod (ty1 ty2 : Ty).
Infix " --> " := Arrow (at level 55, right associativity).
Infix " ** " := Prod (at level 55).
Definition Env := seq Ty.

(* Typed terms in context *)

Parameter Const : Ty -> Type.
(* Inductive Const : Ty -> Type :=
   | CONST : forall ty, Const ty. *)

Inductive Var : Env -> Ty -> Type :=
| ZVAR : forall env ty, Var (ty :: env) ty
| SVAR : forall env ty ty', Var env ty -> Var (ty' :: env) ty.

Inductive Exp : Env -> Ty -> Type :=
| TCONST : forall env ty, Const ty -> Exp env ty
| TVAR :> forall env ty, Var env ty -> Exp env ty
| TPAIR : forall env ty1 ty2, Exp env ty1 -> Exp env ty2 -> Exp env (ty1 ** ty2)
| TFST : forall env ty1 ty2, Exp env (ty1 ** ty2) -> Exp env ty1
| TSND : forall env ty1 ty2, Exp env (ty1 ** ty2) -> Exp env ty2
| TABS : forall env ty1 ty2, Exp (ty1 :: env) ty2 -> Exp env (ty1 --> ty2)
| TAPP : forall env ty1 ty2, Exp env (ty1 --> ty2) -> Exp env ty1 -> Exp env ty2
| TLET : forall env ty1 ty2, Exp env ty1 -> Exp (ty1 :: env) ty2 -> Exp env ty2
| TFIX : forall env ty1 ty2, Exp (ty1 :: ty1 --> ty2 :: env) ty2 -> Exp env (ty1 --> ty2).

Definition CExp t := Exp nil t.

Implicit Arguments TCONST [env].

(* Semantics of types and contexts *)

Section Semantics.

Variable T : monadType.

Parameter semBase : baseType -> monadType -> cpoType.

Fixpoint SemTy ty : cpoType :=
  match ty with
    | Base o => semBase o T
    | ty1 --> ty2 => SemTy ty1 -=> T (SemTy ty2)
    | ty1 ** ty2 => SemTy ty1 * SemTy ty2
  end.

Fixpoint SemEnv env : cpoType :=
  match env with
    | nil => One
    | ty :: env => SemEnv env * SemTy ty
  end.

Fixpoint SemVar env ty (var : Var env ty) : SemEnv env =-> SemTy ty :=
  match var with
    | ZVAR _ _ => SND _ _
    | SVAR _ _ _ v => SemVar v << FST _ _
  end.

(* Semantics of constants as a parameter *)
Parameter SemConst : forall ty, Const ty -> SemTy ty.

(* Semantics of values and expressions *)

Fixpoint SemExp env ty (e : Exp env ty) : SemEnv env =-> T (SemTy ty) :=
  match e with
    | TCONST _ _ c => const _ (tval _ _ (SemConst c))
    | TVAR _ _ v => tval _ _ << SemVar v
    | TABS _ _ _ e => tval _ _ << CURRY (SemExp e)
    | TAPP _ _ _ e1 e2 =>
        Comp2 (tbind _ _ _) (SemExp e1) (tbind _ _ _ << SemExp e2)
    | TPAIR _ _ _ e1 e2 =>
        Comp2 (tbind _ _ _) (SemExp e1)
          (Fcont_app
            (CURRY (CCOMP _ _ _) << tbind _ _ _ << SemExp e2)
            (CURRY (tval _ _))
          )
    | TFST _ _ _ e =>
        Fcont_app (tbind _ _ _ << SemExp e) (tval _ _ << FST _ _)
    | TSND _ _ _ e =>
        Fcont_app (tbind _ _ _ << SemExp e) (tval _ _ << SND _ _)
    | TLET _ _ _ e1 e2 => Comp2 (tbind _ _ _) (SemExp e1) (CURRY (SemExp e2))
    | TFIX _ _ _ e =>
        tval _ _ << FIXP << CURRY (CURRY (SemExp e))
  end.

End Semantics.