section "Graph Interface"
theory GraphSpec
imports Main Graph
  Collections.Collections
  (*"../Collections/Lib/Proper_Iterator"*)
  (*"../Refine_Monadic/Refine_Autodet"*)
begin
  text \<open>
    This theory defines an ICF-style interface for graphs.
\<close>

  type_synonym ('V,'W,'G) graph_\<alpha> = "'G \<Rightarrow> ('V,'W) graph"

  locale graph =
    fixes \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    fixes invar :: "'G \<Rightarrow> bool"
    assumes finite[simp, intro!]:
      "invar g \<Longrightarrow> finite (nodes (\<alpha> g))"
      "invar g \<Longrightarrow> finite (edges (\<alpha> g))"
    assumes valid: "invar g \<Longrightarrow> valid_graph (\<alpha> g)"

  type_synonym ('V,'W,'G) graph_empty = "unit \<Rightarrow> 'G"
  locale graph_empty = graph +
    constrains \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    fixes empty :: "unit \<Rightarrow> 'G"
    assumes empty_correct:
      "\<alpha> (empty ()) = Graph.empty"
      "invar (empty ())"

  type_synonym ('V,'W,'G) graph_add_node = "'V \<Rightarrow> 'G \<Rightarrow> 'G"
  locale graph_add_node = graph +
    constrains \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    fixes add_node :: "'V \<Rightarrow> 'G \<Rightarrow> 'G"
    assumes add_node_correct:
      "invar g \<Longrightarrow> invar (add_node v g)"
      "invar g \<Longrightarrow> \<alpha> (add_node v g) = Graph.add_node v (\<alpha> g)"

  type_synonym ('V,'W,'G) graph_delete_node = "'V \<Rightarrow> 'G \<Rightarrow> 'G"
  locale graph_delete_node = graph +
    constrains \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    fixes delete_node :: "'V \<Rightarrow> 'G \<Rightarrow> 'G"
    assumes delete_node_correct:
      "invar g \<Longrightarrow> invar (delete_node v g)"
      "invar g \<Longrightarrow> \<alpha> (delete_node v g) = Graph.delete_node v (\<alpha> g)"

  type_synonym ('V,'W,'G) graph_add_edge = "'V \<Rightarrow>'W \<Rightarrow> 'V \<Rightarrow> 'G \<Rightarrow> 'G"
  locale graph_add_edge = graph +
    constrains \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    fixes add_edge :: "'V \<Rightarrow> 'W \<Rightarrow> 'V \<Rightarrow> 'G \<Rightarrow> 'G"
    assumes add_edge_correct:
      "invar g \<Longrightarrow> invar (add_edge v e v' g)"
      "invar g \<Longrightarrow> \<alpha> (add_edge v e v' g) = Graph.add_edge v e v' (\<alpha> g)"

  type_synonym ('V,'W,'G) graph_delete_edge = "'V \<Rightarrow>'W \<Rightarrow> 'V \<Rightarrow> 'G \<Rightarrow> 'G"
  locale graph_delete_edge = graph +
    constrains \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    fixes delete_edge :: "'V \<Rightarrow> 'W \<Rightarrow> 'V \<Rightarrow> 'G \<Rightarrow> 'G"
    assumes delete_edge_correct:
      "invar g \<Longrightarrow> invar (delete_edge v e v' g)"
      "invar g \<Longrightarrow> \<alpha> (delete_edge v e v' g) = Graph.delete_edge v e v' (\<alpha> g)"

  type_synonym ('V,'W,'\<sigma>,'G) graph_nodes_it = "'G \<Rightarrow> ('V,'\<sigma>) set_iterator"

  locale graph_nodes_it_defs =
    fixes nodes_list_it :: "'G \<Rightarrow> ('V,'V list) set_iterator"
  begin
    definition "nodes_it g \<equiv> it_to_it (nodes_list_it g)"
  end

  locale graph_nodes_it = graph \<alpha> invar + graph_nodes_it_defs nodes_list_it
    for \<alpha> :: "'G \<Rightarrow> ('V,'W) graph" and invar and
    nodes_list_it :: "'G \<Rightarrow> ('V,'V list) set_iterator"
    +
    assumes nodes_list_it_correct:
      "invar g \<Longrightarrow> set_iterator (nodes_list_it g) (Graph.nodes (\<alpha> g))"
  begin
    lemma nodes_it_correct:
      "invar g \<Longrightarrow> set_iterator (nodes_it g) (Graph.nodes (\<alpha> g))"
      unfolding nodes_it_def
      apply (rule it_to_it_correct)
      by (rule nodes_list_it_correct)

    lemma pi_nodes_it[icf_proper_iteratorI]:
      "proper_it (nodes_it S) (nodes_it S)"
      unfolding nodes_it_def
      by (intro icf_proper_iteratorI)

    lemma nodes_it_proper[proper_it]:
      "proper_it' nodes_it nodes_it"
      apply (rule proper_it'I)
      by (rule pi_nodes_it)

  end

  type_synonym ('V,'W,'\<sigma>,'G) graph_edges_it
    = "'G \<Rightarrow> (('V\<times>'W\<times>'V),'\<sigma>) set_iterator"

  locale graph_edges_it_defs =
    fixes edges_list_it :: "('V,'W,('V\<times>'W\<times>'V) list,'G) graph_edges_it"
  begin
    definition "edges_it g \<equiv> it_to_it (edges_list_it g)"
  end

  locale graph_edges_it = graph \<alpha> invar + graph_edges_it_defs edges_list_it
    for \<alpha> :: "'G \<Rightarrow> ('V,'W) graph" and invar and
    edges_list_it :: "('V,'W,('V\<times>'W\<times>'V) list,'G) graph_edges_it"
    +
    assumes edges_list_it_correct:
      "invar g \<Longrightarrow> set_iterator (edges_list_it g) (Graph.edges (\<alpha> g))"
  begin
    lemma edges_it_correct:
      "invar g \<Longrightarrow> set_iterator (edges_it g) (Graph.edges (\<alpha> g))"
      unfolding edges_it_def
      apply (rule it_to_it_correct)
      by (rule edges_list_it_correct)

    lemma pi_edges_it[icf_proper_iteratorI]:
      "proper_it (edges_it S) (edges_it S)"
      unfolding edges_it_def
      by (intro icf_proper_iteratorI)

    lemma edges_it_proper[proper_it]:
      "proper_it' edges_it edges_it"
      apply (rule proper_it'I)
      by (rule pi_edges_it)

  end

  type_synonym ('V,'W,'\<sigma>,'G) graph_succ_it =
    "'G \<Rightarrow> 'V \<Rightarrow> ('W\<times>'V,'\<sigma>) set_iterator"

  locale graph_succ_it_defs =
    fixes succ_list_it :: "'G \<Rightarrow> 'V \<Rightarrow> ('W\<times>'V,('W\<times>'V) list) set_iterator"
  begin
    definition "succ_it g v \<equiv> it_to_it (succ_list_it g v)"
  end

  locale graph_succ_it = graph \<alpha> invar + graph_succ_it_defs succ_list_it
    for \<alpha> :: "'G \<Rightarrow> ('V,'W) graph" and invar and
    succ_list_it :: "'G \<Rightarrow> 'V \<Rightarrow> ('W\<times>'V,('W\<times>'V) list) set_iterator" +
    assumes succ_list_it_correct:
      "invar g \<Longrightarrow> set_iterator (succ_list_it g v) (Graph.succ (\<alpha> g) v)"
  begin
    lemma succ_it_correct:
      "invar g \<Longrightarrow> set_iterator (succ_it g v) (Graph.succ (\<alpha> g) v)"
      unfolding succ_it_def
      apply (rule it_to_it_correct)
      by (rule succ_list_it_correct)

    lemma pi_succ_it[icf_proper_iteratorI]:
      "proper_it (succ_it S v) (succ_it S v)"
      unfolding succ_it_def
      by (intro icf_proper_iteratorI)

    lemma succ_it_proper[proper_it]:
      "proper_it' (\<lambda>S. succ_it S v) (\<lambda>S. succ_it S v)"
      apply (rule proper_it'I)
      by (rule pi_succ_it)

  end

  subsection "Adjacency Lists"
  type_synonym ('V,'W) adj_list = "'V list \<times> ('V\<times>'W\<times>'V) list"

  definition adjl_\<alpha> :: "('V,'W) adj_list \<Rightarrow> ('V,'W) graph" where
    "adjl_\<alpha> l \<equiv> let (nl,el) = l in \<lparr>
      nodes = set nl \<union> fst`set el \<union> snd`snd`set el,
      edges = set el
    \<rparr>"

  (* TODO: Do we have naming conventions for such a lemma ? *)
  lemma adjl_is_graph: "graph adjl_\<alpha> (\<lambda>_. True)"
    apply (unfold_locales)
    unfolding adjl_\<alpha>_def
    by force+

  type_synonym ('V,'W,'G) graph_from_list = "('V,'W) adj_list \<Rightarrow> 'G"
  locale graph_from_list = graph +
    constrains \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    fixes from_list :: "('V,'W) adj_list \<Rightarrow> 'G"
    assumes from_list_correct:
      "invar (from_list l)"
      "\<alpha> (from_list l) = adjl_\<alpha> l"

  type_synonym ('V,'W,'G) graph_to_list = "'G \<Rightarrow> ('V,'W) adj_list"
  locale graph_to_list = graph +
    constrains \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    fixes to_list :: "'G \<Rightarrow> ('V,'W) adj_list"
    assumes to_list_correct:
      "invar g \<Longrightarrow> adjl_\<alpha> (to_list g) = \<alpha> g"

  subsection \<open>Record Based Interface\<close>
  record ('V,'W,'G) graph_ops =
    gop_\<alpha> :: "('V,'W,'G) graph_\<alpha>"
    gop_invar :: "'G \<Rightarrow> bool"
    gop_empty :: "('V,'W,'G) graph_empty"
    gop_add_node :: "('V,'W,'G) graph_add_node"
    gop_delete_node :: "('V,'W,'G) graph_delete_node"
    gop_add_edge :: "('V,'W,'G) graph_add_edge"
    gop_delete_edge :: "('V,'W,'G) graph_delete_edge"
    gop_from_list :: "('V,'W,'G) graph_from_list"
    gop_to_list :: "('V,'W,'G) graph_to_list"
    gop_nodes_list_it :: "'G \<Rightarrow> ('V,'V list) set_iterator"
    gop_edges_list_it :: "('V,'W,('V\<times>'W\<times>'V) list,'G) graph_edges_it"
    gop_succ_list_it :: "'G \<Rightarrow> 'V \<Rightarrow> ('W\<times>'V,('W\<times>'V) list) set_iterator"

  locale StdGraphDefs =
    graph_nodes_it_defs "gop_nodes_list_it ops"
    + graph_edges_it_defs "gop_edges_list_it ops"
    + graph_succ_it_defs "gop_succ_list_it ops"
    for ops :: "('V,'W,'G,'m) graph_ops_scheme"
  begin
    abbreviation \<alpha> where "\<alpha> \<equiv> gop_\<alpha> ops"
    abbreviation invar where "invar \<equiv> gop_invar ops"
    abbreviation empty where "empty \<equiv> gop_empty ops"
    abbreviation add_node where "add_node \<equiv> gop_add_node ops"
    abbreviation delete_node where "delete_node \<equiv> gop_delete_node ops"
    abbreviation add_edge where "add_edge \<equiv> gop_add_edge ops"
    abbreviation delete_edge where "delete_edge \<equiv> gop_delete_edge ops"
    abbreviation from_list where "from_list \<equiv> gop_from_list ops"
    abbreviation to_list where "to_list \<equiv> gop_to_list ops"
    abbreviation nodes_list_it where "nodes_list_it \<equiv> gop_nodes_list_it ops"
    abbreviation edges_list_it where "edges_list_it \<equiv> gop_edges_list_it ops"
    abbreviation succ_list_it  where "succ_list_it \<equiv> gop_succ_list_it ops"
  end

  locale StdGraph = StdGraphDefs +
    graph \<alpha> invar +
    graph_empty \<alpha> invar empty +
    graph_add_node \<alpha> invar add_node +
    graph_delete_node \<alpha> invar delete_node +
    graph_add_edge \<alpha> invar add_edge +
    graph_delete_edge \<alpha> invar delete_edge +
    graph_from_list \<alpha> invar from_list +
    graph_to_list \<alpha> invar to_list +
    graph_nodes_it \<alpha> invar nodes_list_it +
    graph_edges_it \<alpha> invar edges_list_it +
    graph_succ_it \<alpha> invar succ_list_it
  begin
    lemmas correct = empty_correct add_node_correct delete_node_correct
      add_edge_correct delete_edge_correct
      from_list_correct to_list_correct

  end

  subsection \<open>Refinement Framework Bindings\<close>
  lemma (in graph_nodes_it) nodes_it_is_iterator[refine_transfer]:
    "invar g \<Longrightarrow> set_iterator (nodes_it g) (nodes (\<alpha> g))"
    by (rule nodes_it_correct)

  lemma (in graph_edges_it) edges_it_is_iterator[refine_transfer]:
    "invar g \<Longrightarrow> set_iterator (edges_it g) (edges (\<alpha> g))"
    by (rule edges_it_correct)

  lemma (in graph_succ_it) succ_it_is_iterator[refine_transfer]:
    "invar g \<Longrightarrow> set_iterator (succ_it g v) (Graph.succ (\<alpha> g) v)"
    by (rule succ_it_correct)

  lemma (in graph) drh[refine_dref_RELATES]: "RELATES (build_rel \<alpha> invar)"
    by (simp add: RELATES_def)

  (*text {* Autodet bindings: *}

  lemma (in graph_nodes_it) graph_nodes_it_t[trans_uc]:
    "DETREFe g (build_rel \<alpha> invar) g' \<Longrightarrow>
      set_iterator (nodes_it g) (nodes g')"
    using nodes_it_correct by auto

  lemma (in graph_succ_it) graph_succ_it_t[trans_uc]:
    "DETREFe g (build_rel \<alpha> invar) g' \<Longrightarrow> DETREFe v Id v' \<Longrightarrow>
      set_iterator (succ_it g v) (succ g' v')"
    using succ_it_correct by auto

  lemma (in graph_edges_it) graph_edges_it_t[trans_uc]:
    "DETREFe g (build_rel \<alpha> invar) g' \<Longrightarrow>
      set_iterator (edges_it g) (edges g')"
    using edges_it_correct by auto*)

end


theory WellTypedExp
  imports WTMiscEnv
begin

    (*
      ####################################
        P1. expression syntax
      ####################################
    *)

    (* expressions *)

datatype p_const =
  UnitConst
  | IConst int
  | BConst bool
  | FixConst
    (* arrays *)
  | EmptyArrayConst
  | ExtArrayConst
  | ReadConst
  | WriteConst
    (* pairs *)
  | UnpackConst
    (* channels *)
  | NewChanConst
  | SendConst
  | RecvConst
  | ForkConst

datatype p_op =
  I2Op "int \<Rightarrow> int \<Rightarrow> int"
  | I1Op "int \<Rightarrow> int"
  | C2Op "int \<Rightarrow> int \<Rightarrow> bool"
  | C1Op "int \<Rightarrow> bool"
  | R2Op "bool \<Rightarrow> bool \<Rightarrow> bool"
  | R1Op "bool \<Rightarrow> bool"

datatype var_val_ref =
  NoRef
  | SelfRef
  | OtherRef string

datatype p_exp =
  ConstExp p_const
  | OpExp p_op
  | VarExp string var_val_ref
  | PairExp p_exp p_exp
  | IfExp p_exp p_exp p_exp
  | LamExp string p_exp
  | AppExp p_exp p_exp

fun bin_const where
  "bin_const ExtArrayConst = True"
| "bin_const ReadConst = True"
| "bin_const WriteConst = True"
| "bin_const SendConst = True"
| "bin_const c = False"

fun is_value :: "p_exp \<Rightarrow> bool" where
  "is_value (ConstExp c) = True"
| "is_value (OpExp xop) = True"
| "is_value (VarExp x v) = (v \<noteq> NoRef)"
| "is_value (PairExp v1 v2) = (is_value v1 \<and> is_value v2)"
| "is_value (LamExp x e) = True"
| "is_value (AppExp (ConstExp c) v) = (bin_const c \<and> is_value v)"
| "is_value other = False"

fun is_sexp :: "p_exp \<Rightarrow> bool" where
  "is_sexp (ConstExp c) = True"
| "is_sexp (OpExp xop) = True"
| "is_sexp (VarExp x v) = (v \<noteq> NoRef)"
| "is_sexp (PairExp v1 v2) = (is_value v1 \<and> is_value v2)"
| "is_sexp (LamExp x e) = True"
| "is_sexp (AppExp (ConstExp FixConst) (LamExp x e)) = True"
| "is_sexp (AppExp (ConstExp c) v) = (bin_const c \<and> is_value v)"
| "is_sexp other = False"

fun free_vars :: "p_exp \<Rightarrow> string set" where
  "free_vars (ConstExp c) = {}"
| "free_vars (OpExp xop) = {}"
| "free_vars (VarExp x v) = {x}"
| "free_vars (PairExp e1 e2) = free_vars e1 \<union> free_vars e2"
| "free_vars (IfExp e1 e2 e3) = free_vars e1 \<union> free_vars e2 \<union> free_vars e3"
| "free_vars (LamExp x e) = free_vars e - {x}"
| "free_vars (AppExp e1 e2) = free_vars e1 \<union> free_vars e2"

fun deref_vars where
  "deref_vars x NoRef = {}"
| "deref_vars x SelfRef = {x}"
| "deref_vars x (OtherRef y) = {x, y}"

fun ref_vars :: "p_exp \<Rightarrow> string set" where
  "ref_vars (ConstExp c) = {}"
| "ref_vars (OpExp xop) = {}"
| "ref_vars (VarExp x r) = deref_vars x r"
| "ref_vars (PairExp e1 e2) = ref_vars e1 \<union> ref_vars e2"
| "ref_vars (IfExp e1 e2 e3) = ref_vars e1 \<union> ref_vars e2 \<union> ref_vars e3"
| "ref_vars (LamExp x e) = ref_vars e"
| "ref_vars (AppExp e1 e2) = ref_vars e1 \<union> ref_vars e2"

definition non_prim_vars where
  "non_prim_vars env e = { x | x. non_prim_entry env x \<and> x \<in> free_vars e }"

definition env_vars :: "(string \<Rightarrow> 'a option) \<Rightarrow> string set" where
  "env_vars env = { x | x. env x \<noteq> None }"

definition use_env_vars where
  "use_env_vars r_s = { x | x. r_s x \<noteq> NoPerm }"

definition own_env_vars where
  "own_env_vars r_s = { x | x. r_s x = OwnPerm }"

    (*
      ####################################
        P4. type system for expressions
      ####################################
    *)

definition pure_fun where
  "pure_fun t1 t2 r = FunTy t1 t2 UsePerm r"
  (*
definition impure_fun where
  "impure_fun t1 t2 = FunTy t1 t2 UsePerm Aff"

 *)
(*
fun is_unique where
  "is_unique (ArrayTy a) = True"
| "is_unique (PairTy t1 t2) = (is_unique t1 \<or> is_unique t2)"
| "is_unique (FunTy t1 t2 r a) = (a = Aff)"
| "is_unique other = False"

definition take_fun where
  "take_fun t1 t2 a = (if is_unique t1 then FunTy t1 t2 OwnPerm a else FunTy t1 t2 UsePerm a)"
  *)
fun const_type :: "p_const \<Rightarrow> p_type set" where
  "const_type UnitConst = {UnitTy}"
| "const_type (IConst i) = {IntTy}"
| "const_type (BConst b) = {BoolTy}"
| "const_type FixConst = {pure_fun (pure_fun t t (req_type t)) t Prim | t. fun_ty t \<and> unlim t}"
  (* arrays: since t is unlim and arrays are unlim, no functions require ownership.
      pairs are affine because they are only needed once. *)
(*| "const_type NewArrayConst = {pure_fun (PairTy IntTy (pure_fun IntTy t)) (ArrayTy t) | t. unlim t}"*)
| "const_type EmptyArrayConst = {pure_fun UnitTy (ArrayTy t) Prim | t. unlim t}"
| "const_type ExtArrayConst = {pure_fun (ArrayTy t) (FunTy t (ArrayTy t) OwnPerm Ref) Prim | t. unlim t}"
| "const_type ReadConst = {pure_fun (ArrayTy t) (pure_fun IntTy t Ref) Prim | t. unlim t}"
| "const_type WriteConst = {pure_fun (ArrayTy t) (FunTy (PairTy IntTy t OwnPerm) UnitTy OwnPerm Ref) Prim | t. unlim t}"
  (* pairs: a reusable pair must be constructed from unlimited values + requires ownership of both its elements,
    however permissions-wise it is treated like a var.
      - an affine pair can be constructed from anything, and also requires ownership of both its elements
  *)
(*| "const_type PairConst = {FunTy t1 (FunTy t2 (PairTy t1 t2 r) r Ref) r Prim | t1 t2 r. True}"*)
  (*
| "const_type PairConst = {take_fun t1 (take_fun t2 (PairTy t1 t2) Aff) NoAff | t1 t2. True}"*)
  (* - for unpacking, the pair is assumed to be owned, whatever is put in *)
| "const_type UnpackConst = {FunTy (PairTy t1 t2 r) (FunTy (FunTy t1 (FunTy t2 tx r (as_aff r')) r (as_aff r')) tx r' (as_aff r)) r Prim | t1 t2 tx r r'. leq_perm r r'}"
  (* channels: all uses of a channel use up ownership *)
| "const_type NewChanConst = {pure_fun UnitTy (PairTy (ChanTy t SEnd) (ChanTy t REnd) OwnPerm) Prim | t. True}"
| "const_type SendConst = {pure_fun (ChanTy t SEnd) (FunTy t UnitTy r Ref) Prim | t r. is_own r}"
| "const_type RecvConst = {pure_fun (ChanTy t REnd) t Prim | t. True }"
| "const_type ForkConst = {FunTy (FunTy UnitTy UnitTy UsePerm a) UnitTy r Prim | a r. is_own r}"

fun op_type :: "p_op \<Rightarrow> p_type" where
  "op_type (I2Op xop) = pure_fun IntTy (pure_fun IntTy IntTy Prim) Prim"
| "op_type (I1Op xop) = pure_fun IntTy IntTy Prim"
| "op_type (C2Op xop) = pure_fun IntTy (pure_fun IntTy BoolTy Prim) Prim"
| "op_type (C1Op xop) = pure_fun IntTy BoolTy Prim"
| "op_type (R2Op xop) = pure_fun BoolTy (pure_fun BoolTy BoolTy Prim) Prim"
| "op_type (R1Op xop) = pure_fun BoolTy BoolTy Prim"

fun var_val_type :: "var_val_ref \<Rightarrow> p_type \<Rightarrow> p_type \<Rightarrow> bool" where
  "var_val_type NoRef tau tau_x = True"
| "var_val_type r tau (ArrayTy tau_x) = (req_type tau \<noteq> Prim)"
| "var_val_type r tau (ChanTy tau_x c_end) = (req_type tau \<noteq> Prim)"
| "var_val_type r tau tau_x = False"

definition app_req where
  "app_req rx1 rx2 r tau r_ex = (if req_type tau = Prim then empty_use_env else
    diff_use_env (comp_use_env rx1 rx2) (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex))"

definition pair_req where
  "pair_req rx r_ex tau = (if req_type tau = Prim then empty_use_env else diff_use_env rx r_ex)"

fun safe_type where
  "safe_type tau OwnPerm = True"
| "safe_type tau UsePerm = unlim tau"
| "safe_type tau NoPerm = False"

fun safe_type_x where
  "safe_type_x tau OwnPerm = True"
| "safe_type_x tau UsePerm = unlim tau"
| "safe_type_x tau NoPerm = (req_type tau = Prim)"

definition deref_name where
  "deref_name x r = (case r of
    NoRef \<Rightarrow> x
    | SelfRef \<Rightarrow> x
    | OtherRef a \<Rightarrow> a
  )"

fun safe_pair_aff where
  "safe_pair_aff a NoPerm = False"
| "safe_pair_aff a UsePerm = (a \<noteq> Aff)"
| "safe_pair_aff a OwnPerm = True"

fun aff_leq where
  "aff_leq Prim r = True"
| "aff_leq Ref NoPerm = False"
| "aff_leq Ref r = True"
| "aff_leq Aff OwnPerm = True"
| "aff_leq Aff r = False"

fun well_typed :: "pt_env \<Rightarrow> perm_use_env \<Rightarrow> p_exp \<Rightarrow> p_type \<Rightarrow> perm_use_env \<Rightarrow> perm_use_env \<Rightarrow> bool" where
  "well_typed env r_s1 (ConstExp c) tau r_s2 rx = (tau \<in> const_type c \<and> leq_use_env r_s2 r_s1 \<and> leq_use_env rx r_s2)"
| "well_typed env r_s1 (OpExp xop) tau r_s2 rx = (tau = op_type xop \<and> leq_use_env r_s2 r_s1 \<and> leq_use_env rx r_s2)"
    (* in a variable value, the name carries the owner, but the actual type must be dereferenced *)
| "well_typed env r_s1 (VarExp x v) tau r_s2 rx = (\<exists> r_ex tau_x. env (deref_name x v) = Some tau \<and> env x = Some tau_x \<and> var_val_type v tau tau_x \<and>
    leq_use_env (ereq_use_env x tau_x) r_s1 \<and> leq_use_env r_s2 (diff_use_env r_s1 (comp_use_env (ereq_use_env x tau_x) r_ex)) \<and>
    leq_use_env rx r_s2 \<and> leq_use_env r_ex r_s1 \<and> leq_use_env (diff_use_env (ereq_use_env x tau_x) (comp_use_env (ereq_use_env x tau_x) r_ex)) rx)"
| "well_typed env r_s1 (PairExp e1 e2) tau r_sf rf = (\<exists> t1 t2 r r_s2 r_s3 rx1 rx2 r_ex. tau = PairTy t1 t2 r \<and>
    well_typed env r_s1 e1 t1 r_s2 rx1 \<and> well_typed env r_s2 e2 t2 r_s3 rx2 \<and> (*aff_use_env rx (req_type tau) \<and>*)
    (*safe_pair_aff (max_aff (req_type t1) (req_type t2)) r \<and>*)
    leq_use_env (lift_use_env rx1 r) r_s3 \<and> leq_use_env (lift_use_env rx2 r) r_s3 \<and> aff_leq (max_aff (req_type t1) (req_type t2)) r \<and>
    (*safe_use_lift rx1 r \<and> safe_use_lift rx2 r \<and> safe_type t1 r \<and> safe_type t2 r
    (*leq_use_env rx1 rx \<and> leq_use_env rx2 rx*) \<and>*) disj_use_env (lift_use_env rx1 r) (lift_use_env rx2 r) \<and>
    leq_use_env r_sf (diff_use_env r_s3 r_ex) \<and> leq_use_env rf r_sf \<and> leq_use_env r_ex r_s1 \<and>
    leq_use_env (pair_req (comp_use_env (lift_use_env rx1 r) (lift_use_env rx2 r)) r_ex tau) rf
  )"
(*| "well_typed env r_s1 (PairExp e1 e2) tau r_s2 rf = (\<exists> t1 t2 r rx rx1 rx2 r_xa r_xb r_sa r_sb r_ex. tau = PairTy t1 t2 r \<and>
    well_typed env rx1 e1 t1 r_sa r_xa \<and> well_typed env rx2 e2 t2 r_sb r_xb \<and> (*aff_use_env rx (req_type tau) \<and>*) r \<noteq> NoPerm \<and> leq_use_env rx r_s1 \<and>
    leq_use_env (lift_use_env rx1 r) rx \<and> leq_use_env (lift_use_env rx2 r) rx
    (*leq_use_env rx1 rx \<and> leq_use_env rx2 rx*) \<and> disj_use_env (lift_use_env rx1 r) (lift_use_env rx2 r) \<and>
    leq_use_env r_s2 (diff_use_env r_s1 r_ex) \<and> leq_use_env rf r_s2 \<and> leq_use_env r_ex r_s1 \<and> leq_use_env (pair_req rx r_ex tau) rf
  )"*)
| "well_typed env r_s1 (IfExp e1 e2 e3) tau r_s3 rx = (\<exists> rx' r_s2 rx1 rx2.
    well_typed env r_s1 e1 BoolTy r_s2 rx' \<and> well_typed env r_s2 e2 tau r_s3 rx1 \<and> well_typed env r_s2 e3 tau r_s3 rx2 \<and>
    rx = comp_use_env rx1 rx2)"
| "well_typed env r_s1 (LamExp x e) tau r_s2 rf = (\<exists> t1 t2 r a rx r_end r_s' r_ex. tau = FunTy t1 t2 r a \<and> x \<notin> ref_vars e \<and>
    well_typed (add_env env x t1) (add_use_env rx x r) e t2 r_s' r_end \<and> aff_use_env rx a \<and>
    leq_use_env rx r_s1 \<and> leq_use_env r_s2 (diff_use_env r_s1 r_ex) \<and> leq_use_env rf r_s2 \<and>
    leq_use_env r_ex r_s1 \<and> leq_use_env (diff_use_env rx r_ex) rf)"
| "well_typed env r_s1 (AppExp e1 e2) tau r_sf rx = (\<exists> t1 r a r_s2 rx1 rx2 r_s3 r_ex.
    well_typed env r_s1 e1 (FunTy t1 tau r a) r_s2 rx1 \<and> well_typed env r_s2 e2 t1 r_s3 rx2 \<and>
    leq_use_env r_sf (diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)) \<and> (*r \<noteq> NoPerm \<and>*) (*safe_use_lift rx2 r \<and>
    safe_type t1 r \<and>*) leq_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_s3 \<and>
    disj_use_env rx1 (lift_use_env rx2 r) \<and> leq_use_env rx r_sf \<and>
    leq_use_env r_ex r_s1 \<and> leq_use_env (app_req rx1 rx2 r tau r_ex) rx
  )"

  (* let's briefly explain the permissions system. all expressions are typed by the permissions available,
    as well as the permissions required to further evaluate the expression.
      - var case. requires x as a use-permission, and also requires ownership of the x. it is not
          strictly necessary to have this condition, however doing so removes many edge cases.
      - lam case. an arbitrary set of permissions are pulled from the start and are allowed in the
          lambda. these permissions are then given as the evaluation requirements.
          note: requirement permissions may be dropped if they are also dropped from the available permissions.
      - app case. the requisite permissions are removed from the environment, with the remaining permissions
          being any uses from either expression. function types are decorated with a requirement for the
          argument type which can "upgrade" the permissions required. for instance, a mere use can be
          upgraded into ownership.

      - requirements can be dropped for any s-exp. for const/op it's because they dont have any.
        for var, it's because only one permission is relevant. for lambda it's by construction.
        for the fix-point case, it's bc the rhs is a lambda.
      - we also want to allow permissions to be required liberally (for the sake of substitution).
        for const/op we can allow non-empty requirements. for var, we minimally specify rx. for
        lambda it's already possible since rx is arbitrary. for if/app, one can simply extend e2.

    the other issue is the idea of an affine function. ie, we want to make sure no "use"
    functions are secretly hiding ownership values. so we designate them as affine if they are.
  *)

    (* - expression lemmas *)

lemma value_is_sexp: "is_value e \<Longrightarrow> is_sexp e"
  apply (case_tac e)
        apply (auto)
  apply (case_tac x71)
        apply (auto)
  apply (case_tac x1)
              apply (auto)
  done

lemma e2_sexp: "\<lbrakk> is_sexp (AppExp e1 e2) \<rbrakk> \<Longrightarrow> is_sexp e2"
  apply (case_tac e1)
       apply (auto)
  apply (case_tac e2)
        apply (auto)
  apply (case_tac x71)
        apply (auto)
  apply (case_tac x1a)
              apply (auto)
  done

end


theory SINVAR_ACLcommunicateWith
imports "../TopoS_Helper"
begin
subsection {* SecurityInvariant ACLcommunicateWith *}
text{*An access control list strategy that says that hosts must only transitively access each other if allowed*}

text{*Warning: this transitive model has exponential computational complexity*}

definition default_node_properties :: "'v list"
  where  "default_node_properties \<equiv> []"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> 'v list) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> v \<in> nodes G. (\<forall>a \<in> (succ_tran G v). a \<in> set (nP v)))"

definition receiver_violation :: "bool" where
  "receiver_violation \<equiv> False"

(*Alternative definition*)
lemma ACLcommunicateWith_sinvar_alternative:
  "wf_graph G \<Longrightarrow> sinvar G nP = (\<forall> (e1,e2) \<in> (edges G)\<^sup>+. e2 \<in> set (nP e1))"
  proof(unfold sinvar.simps, rule iffI, goal_cases)
  case 1
      from 1(1) have e1_nodes: "(e1, e2) \<in> edges G \<Longrightarrow> e1 \<in> nodes G" for e1 e2
        by (simp add: wf_graph.E_wfD(1))
      from 1(2) have "\<forall>v\<in>nodes G. \<forall>a. (v, a) \<in> (edges G)\<^sup>+ \<longrightarrow> a \<in> set (nP v)"
        by(simp add: succ_tran_def)
      with e1_nodes have "(e1, e2)\<in>(edges G)\<^sup>+ \<Longrightarrow> e2 \<in> set (nP e1)" for e1 e2
        by (meson tranclD)
      thus ?case by blast
    next
    case 2
      from 2(1) have e1_nodes: "(v, a) \<in> edges G \<Longrightarrow> v \<in> nodes G" for v a
        by (simp add: wf_graph.E_wfD(1))
      with 2(2) show ?case by(auto simp add: succ_tran_def)
  qed

    from a3 have "v \<in> N \<Longrightarrow> \<forall>a\<in>(succ_tran \<lparr>nodes = N, edges = E\<rparr> v). a \<in> set (nP v)" for v by fastforce
    with a2 have g2: "v \<in> N \<Longrightarrow> (\<forall> a \<in> (succ_tran \<lparr>nodes = N, edges = E'\<rparr> v). a \<in> set (nP v))" for v
      using succ_tran_mono[OF a1] by blast
    thus "sinvar \<lparr>nodes = N, edges = E'\<rparr> nP" by simp
qed

interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
  apply unfold_locales
    apply(frule_tac finite_distinct_list[OF wf_graph.finiteE])
    apply(erule_tac exE)
    apply(rename_tac list_edges)
    apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
        apply(auto)[4]
    apply(auto simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops False_set succ_tran_empty)[1]
   apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_sinvar_mono[OF sinvar_mono])
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
 done

lemma unique_default_example: "succ_tran \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> vertex_2 = {}"
apply (simp add: succ_tran_def)
by (metis Domain.DomainI Domain_empty Domain_insert distinct_vertices12 singleton_iff trancl_domain)

interpretation ACLcommunicateWith: SecurityInvariant_ACS
where default_node_properties = SINVAR_ACLcommunicateWith.default_node_properties
and sinvar = SINVAR_ACLcommunicateWith.sinvar
  unfolding SINVAR_ACLcommunicateWith.default_node_properties_def
  apply unfold_locales

   apply simp
   apply(subst(asm) SecurityInvariant_withOffendingFlows.set_offending_flows_simp, simp)
   apply(clarsimp)
   apply (metis)

  apply(erule default_uniqueness_by_counterexample_ACS)
  apply(simp)
  apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
  apply (simp add:graph_ops)
  apply (simp split: prod.split_asm prod.split)
  apply(simp add: List.neq_Nil_conv)
  apply(erule exE)
  apply(rename_tac canAccessThis)
  apply(case_tac "canAccessThis = vertex_1")
   apply(rule_tac x="\<lparr> nodes={canAccessThis,vertex_2}, edges = {(vertex_2,canAccessThis)} \<rparr>" in exI, simp)
   apply(rule conjI)
    apply(simp add: wf_graph_def)
   apply(rule_tac x="(\<lambda> x. [])(vertex_1 := [], vertex_2 := [])" in exI, simp)
   apply(simp add: example_simps)
   apply(rule_tac x="{(vertex_2,vertex_1)}" in exI, simp)
   apply(simp add: example_simps)
   apply(fastforce)

  apply(rule_tac x="\<lparr> nodes={vertex_1,canAccessThis}, edges = {(vertex_1,canAccessThis)} \<rparr>" in exI, simp)
  apply(rule conjI)
   apply(simp add: wf_graph_def)
  apply(rule_tac x="(\<lambda> x. [])(vertex_1 := [], canAccessThis := [])" in exI, simp)
  apply(simp add: example_simps)
  apply(rule_tac x="{(vertex_1,canAccessThis)}" in exI, simp)
  apply(simp add: example_simps)
  apply(fastforce)
 done

  lemma TopoS_ACLcommunicateWith: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_const (open) sinvar receiver_violation default_node_properties

end