theory Kruskal_Refine
imports Kruskal   "SeprefTime.Refine_Heuristics" UnionFind
begin

definition edges_less_eq :: "('a \<times> 'w::{linorder, ordered_comm_monoid_add} \<times> 'a) \<Rightarrow> ('a \<times> 'w \<times> 'a) \<Rightarrow> bool"
  where "edges_less_eq a b \<equiv> fst(snd a) \<le> fst(snd b)"

context Kruskal_intermediate_time
begin

thm  minWeightBasis3_refine
thm minWeightBasis3_aux_def

thm obtain_sorted_carrier_aux_def
term wsorted

definition (in -) "\<alpha> = (\<lambda>(x,y). Upair x y)"

definition (in -) wsorted_wrt_w' where "wsorted_wrt_w' w == sorted_wrt (\<lambda>x y. w (\<alpha> x) \<le> w (\<alpha> y))"

abbreviation "wsorted' \<equiv> wsorted_wrt_w' weight"

lemma wsorted_map\<alpha>[simp]: "wsorted' s \<Longrightarrow> wsorted (map \<alpha> s)"
  by(auto simp: wsorted_wrt_w'_def sorted_wrt_map)

definition (in -) "obtain_sorted_carrier'_aux c w obst == SPECT (emb (\<lambda>L. wsorted_wrt_w' w L \<and> distinct (map \<alpha> L) \<and> \<alpha> ` set L = c) obst)"

abbreviation "obtain_sorted_carrier' == obtain_sorted_carrier'_aux E weight (getEdges_time + sort_time)"

definition RR :: "(('a \<times> 'a)  \<times> 'a uprod) set" where "RR \<equiv> {( (cx,cy) , a). Upair cx cy = a }"

lemma RR_alt: "RR = br \<alpha> (\<lambda>_. True)"
  unfolding RR_def br_def \<alpha>_def by auto

lemma "obtain_sorted_carrier' \<le> \<Down>(list_rel RR) obtain_sorted_carrier"
  unfolding obtain_sorted_carrier'_aux_def obtain_sorted_carrier_aux_def
  oops

lemma obtain_sorted_carrier'_refine:
  "obtain_sorted_carrier' \<le> \<Down> (\<langle>RR\<rangle>list_rel) obtain_sorted_carrier"
  unfolding obtain_sorted_carrier'_aux_def obtain_sorted_carrier_aux_def
  apply(rule SPECT_refine)
  unfolding RR_alt
  subgoal for s apply(rule exI[where x="map \<alpha> s"])
    by(auto simp: map_in_list_rel_conv in_br_conv vcg_simp_rules)
  done

abbreviation "empty_forest \<equiv> {}"

definition kruskal0
  where "kruskal0 \<equiv> do {
    l \<leftarrow> obtain_sorted_carrier';
    s \<leftarrow> SPECT [empty_forest \<mapsto> enat (empty_forest_time+empty_uf_time)];
    spanning_forest \<leftarrow> nfoldli l (\<lambda>_. True)
        (\<lambda>(a,b) T. do {
            ASSERT (Upair a b\<notin>T \<and> forest T \<and> Upair a b\<in>E \<and> T \<subseteq> E);
            i \<leftarrow> SPECT [\<not> (a,b) \<in> connected T \<mapsto> enat indep_test_time];
            if i then
              do {
                ASSERT (Upair a b\<notin>T);
                SPECT [(insert (Upair a b) T) \<mapsto> enat (insert_time+insert_uf_time)]
              }
            else
              RETURNT T
        }) s;
        RETURNT spanning_forest
      }"

lemma "(xi, x) \<in> RR \<Longrightarrow>  xi = (x1, x2) \<Longrightarrow> x = Upair x1 x2"
  unfolding RR_def  by auto

declare RETURNT_refine [simp]

lemma ff: "(sa, sa) \<in> Id" by auto

lemma ffs: "A \<le> B \<Longrightarrow> A \<le> \<Down> Id B" by auto

lemma kruskal0_refine: "kruskal0 \<le> \<Down>Id minWeightBasis3"
  unfolding kruskal0_def minWeightBasis3_aux_def
  apply(refine_rcg obtain_sorted_carrier'_refine)
           apply simp
          apply simp
          apply (rule ff)
  apply simp
  subgoal by(auto simp: RR_def augment_forest)
  apply(rule ffs)
  subgoal by(auto simp: RR_def augment_forest)
  subgoal by(auto simp: RR_def augment_forest)
  subgoal by(auto simp: RR_def augment_forest)
  subgoal by(auto simp: RR_def augment_forest)
  subgoal by(auto simp: RR_def augment_forest)
  subgoal by(auto simp: RR_def augment_forest)
  done

section "kruskal1 - using union find"

definition corresponding_union_find :: "'a per \<Rightarrow> 'a uprod set \<Rightarrow> bool"
  where "corresponding_union_find uf T \<equiv> (\<forall>a\<in>V. \<forall>b\<in>V.
      per_compare uf a b \<longleftrightarrow> ((a,b)\<in> connected T ))"

definition "uf_graph_invar uf_T \<equiv> case uf_T of (uf, T) \<Rightarrow>
    corresponding_union_find uf T \<and>
    Domain uf = V"

lemma uf_graph_invarE: "uf_graph_invar (uf, T) \<Longrightarrow> corresponding_union_find uf T"
  unfolding uf_graph_invar_def by simp

definition "uf_graph_rel \<equiv> br snd uf_graph_invar"

lemma uf_graph_relsndD: "((a,b),c) \<in> uf_graph_rel \<Longrightarrow> b=c"
  by(auto simp: uf_graph_rel_def in_br_conv)

lemma uf_graph_relD: "((a,b),c) \<in> uf_graph_rel \<Longrightarrow> b=c \<and> uf_graph_invar (a,b)"
  by(auto simp: uf_graph_rel_def in_br_conv)

definition "initState = do {
  initial_union_find \<leftarrow> SPECT [per_init V \<mapsto> enat empty_uf_time];
       SPECT [(initial_union_find, empty_forest) \<mapsto> enat empty_forest_time]
  }"

definition "addEdge uf a b T = do {
    uf \<leftarrow> SPECT [per_union uf a b \<mapsto> enat insert_uf_time];
    SPECT [(uf, insert (Upair a b) T)\<mapsto>enat insert_time]
  }"

definition kruskal1
  where "kruskal1 \<equiv> do {
    l \<leftarrow> obtain_sorted_carrier';
    s \<leftarrow> initState;
    (per, spanning_forest) \<leftarrow> nfoldli l (\<lambda>_. True)
        (\<lambda>(a,b) (uf, T). do {
            ASSERT (Domain uf = Domain (fst s));
            ASSERT (a\<in>V \<and> b\<in>V \<and> a \<in> Domain uf \<and> b \<in> Domain uf \<and> a\<noteq>b \<and> T\<subseteq>E);
            i \<leftarrow> SPECT [\<not> per_compare uf a b  \<mapsto>  enat indep_test_time];
            if i then
              do {
                ASSERT (Upair a b\<notin>T);
                addEdge uf a b T
              }
            else
              RETURNT (uf,T)
        }) s;
        RETURNT spanning_forest
      }"

lemma corresponding_union_find_empty:
  shows "corresponding_union_find (per_init V) empty_forest"
  by(auto simp: corresponding_union_find_def connected_same per_init_def)

lemma empty_forest_refine1: "((per_init V, empty_forest), empty_forest)\<in>uf_graph_rel"
  using corresponding_union_find_empty
  unfolding  uf_graph_rel_def uf_graph_invar_def
  by (auto simp: in_br_conv per_init_def)

lemma uf_graph_invar_preserve: "uf_graph_invar (uf, T) \<Longrightarrow> a\<in>V \<Longrightarrow> b\<in>V \<Longrightarrow> a\<noteq>b \<Longrightarrow> T\<subseteq>E
         \<Longrightarrow> uf_graph_invar (per_union uf a b, insert (Upair a b) T)"
  by(auto simp add: uf_graph_invar_def corresponding_union_find_def insert_reachable per_union_def)

lemma initloop: "initState \<le> \<Down> uf_graph_rel (SPECT [{} \<mapsto> enat (empty_forest_time+empty_uf_time)])"
  unfolding initState_def conc_fun_RES
    apply(rule T_specifies_I)
  apply (vcg' \<open>-\<close>  )
  apply(rule Sup_upper)  apply (auto split: if_splits)
  using empty_forest_refine1 by auto

lemma ref: "\<And> xi x si sb x1 x2 x1a x2a x1b x2b.
       (xi, x) \<in> Id \<times>\<^sub>r Id \<Longrightarrow>
       (si, sb) \<in> uf_graph_rel \<Longrightarrow>
       x = (x1, x2) \<Longrightarrow>
       si = (x1b, x2b) \<Longrightarrow>
       xi = (x1a, x2a) \<Longrightarrow>
       x1a \<in> V \<and> x2a \<in> V \<and> x1a \<in> Domain x1b \<and> x2a \<in> Domain x1b \<and> x1a \<noteq> x2a \<and> x2b \<subseteq> E \<Longrightarrow>
        addEdge x1b x1a x2a x2b
       \<le> \<Down> uf_graph_rel (SPECT [insert (Upair x1 x2) sb \<mapsto> enat (insert_time+insert_uf_time)]) "
  unfolding addEdge_def  conc_fun_RES
    apply(rule T_specifies_I)
  apply (vcg' \<open>-\<close>  )
  by (auto dest: uf_graph_relD E_inV Eproper uf_graph_invarE
          simp:  corresponding_union_find_def uf_graph_rel_def in_br_conv uf_graph_invar_preserve
           split: if_splits)

theorem kruskal1_refine: "kruskal1 \<le> \<Down>Id kruskal0"
  unfolding kruskal1_def kruskal0_def Let_def
  apply (refine_rcg initloop ref)
           apply refine_dref_type
  apply simp apply simp apply auto []
  apply (auto dest: uf_graph_relD E_inV Eproper uf_graph_invarE
          simp:  corresponding_union_find_def uf_graph_rel_def in_br_conv uf_graph_invar_preserve)
  by (auto simp: uf_graph_invar_def dest: E_inV)

section "kruskal2 - using lists"

abbreviation "lst_graph_P l S \<equiv> lst_graph_P' weight l S"
lemmas lst_graph_P_def = lst_graph_P'_def

lemma lst_graph_P_distinctD: "lst_graph_P l S \<Longrightarrow> distinct l"
  by(auto simp: lst_graph_P_def dest: distinct_mapI)

abbreviation "lst_graph_rel \<equiv> lst_graph_rel' weight"
lemmas lst_graph_rel_def = lst_graph_rel'_def

lemma lst_graph_rel_empty[simp]: "([], {}) \<in> lst_graph_rel"
  by(simp add: lst_graph_rel_def lst_graph_P_def)

term set_rel
term list_set_rel
abbreviation "edge_rel \<equiv> br \<alpha>' (\<lambda>(a,w,b). weight (Upair a b) = w)"
abbreviation "edge_rel' \<equiv> br \<alpha>'' (\<lambda>(a,w,b). weight (Upair a b) = w)"

lemma lst_graph_rel_alt:
  "lst_graph_rel = \<langle>edge_rel\<rangle>list_set_rel" (is "?L = ?R")
proof
  show "?L \<subseteq> ?R"
    unfolding lst_graph_rel_def list_set_rel_def lst_graph_P_def
    apply rule apply safe subgoal for a b apply(intro relcompI[where b="map \<alpha>' a"])
      by(auto simp add: list_rel_def  in_br_conv list_all2_map2  list_all2_same)
    done
next
  have D: "\<And>x y. (x, y) \<in> \<langle>br \<alpha>' (\<lambda>(a, w, b). weight (Upair a b) = w)\<rangle>list_rel
      \<Longrightarrow> y = map \<alpha>' x \<and> (\<forall>(a, w, b)\<in>set x. weight (Upair a b) = w)"
    unfolding list_rel_def apply safe
    subgoal for x y
      by(auto intro: nth_equalityI[where xs=y and ys="map (\<lambda>(a, uu, y). Upair a y) x"]
              simp: list_rel_def list_all2_conv_all_nth in_br_conv)
    subgoal for x y by(auto simp: list_all2_conv_all_nth in_br_conv in_set_conv_nth)
    done

  show "?R \<subseteq> ?L"
    unfolding lst_graph_rel_def list_set_rel_def lst_graph_P_def
    by (force dest!: D simp: in_br_conv)
qed

abbreviation  (in -) getEdges'
  :: "('a uprod \<Rightarrow> 'w::{linorder, ordered_comm_monoid_add}) \<Rightarrow> 'a uprod set \<Rightarrow> enat \<Rightarrow> ('a \<times> 'w \<times> 'a) list nrest"
    where
    "getEdges' w c get == SPECT (emb (\<lambda>L. lst_graph_P' w L c) get)"
abbreviation     "getEdges == getEdges' weight E getEdges_time"

abbreviation (in -) obtain_sorted_carrier''_aux
  :: "('a uprod \<Rightarrow> 'w::{linorder, ordered_comm_monoid_add}) \<Rightarrow> 'a uprod set \<Rightarrow> enat \<Rightarrow> enat \<Rightarrow> ('a \<times> 'w \<times> 'a) list nrest"  where
  "obtain_sorted_carrier''_aux w c get st \<equiv> do {
    (l::('a \<times> 'w \<times> 'a) list) \<leftarrow> getEdges' w c get;
  ( ((ASSERT (length l = card c))) \<then>
    SPECT (emb (\<lambda>L. sorted_wrt edges_less_eq L \<and> distinct L \<and> set L = set l) st))
}"

abbreviation "obtain_sorted_carrier'' \<equiv> obtain_sorted_carrier''_aux weight E getEdges_time sort_time "

term "\<langle>edge_rel\<rangle>list_rel"

lemma "distinct x \<Longrightarrow> length x = length y \<Longrightarrow> set x = set y \<Longrightarrow> distinct y"
  using card_distinct distinct_card by fastforce

lemma wsorted'_sorted_wrt_edges_less_eq: "\<forall>x\<in>set s. case x of (a, wv, b) \<Rightarrow> weight (Upair a b) = wv \<Longrightarrow> sorted_wrt edges_less_eq s
  \<Longrightarrow> wsorted' (map \<alpha>'' s) "
  unfolding wsorted_wrt_w'_def sorted_wrt_map edges_less_eq_def
  apply(rule sorted_wrt_mono_rel )
  by (auto simp add: \<alpha>_def case_prod_beta)

lemma " distinct s \<Longrightarrow>
    set s = set l \<Longrightarrow>
    distinct (map f l) \<Longrightarrow>  distinct (map f s)"
  by (simp add: distinct_map)

lemma \<alpha>'_conv: "(((\<lambda>(x, y). Upair x y) \<circ>\<circ> case_prod) (\<lambda>a (_, y). (a, y)))
      = \<alpha>'"   by auto

lemma "SPECT (emb P1 t1) \<bind> (\<lambda>l. SPECT (emb (P2 l) t2))
  = SPECT (emb P (t1+t2)) " unfolding bindT_def
  apply auto unfolding emb'_def apply auto
  oops

lemma emb_eq_Some_conv': "\<And>T.  Some t' = emb' Q T x \<longleftrightarrow> (t'=T x \<and> Q x)"
  by (auto simp: emb'_def)

lemma obtain_sorted_carrier''_refine: "obtain_sorted_carrier'' \<le> \<Down> (\<langle>edge_rel'\<rangle>list_rel) obtain_sorted_carrier'"
  unfolding   obtain_sorted_carrier'_aux_def
  unfolding conc_fun_RES
    apply(rule T_specifies_I)
  apply(vcg' \<open>-\<close>  )
  apply(rule Sup_upper)  apply (auto split: if_splits)
  subgoal for l s
    apply(rule exI[where x="map \<alpha>'' s"])
    apply (simp add: emb_eq_Some_conv')
    apply(auto simp: in_br_conv lst_graph_P_def wsorted'_sorted_wrt_edges_less_eq
            \<alpha>_def \<alpha>'_conv distinct_map map_in_list_rel_conv)
     using image_iff
     by fastforce+
   subgoal unfolding lst_graph_P_def
     using distinct_card by fastforce
  done

definition (in -) "initState'_aux c eft eut = do {
  initial_union_find \<leftarrow> SPECT [per_init (Kruskal_intermediate_defs.V c) \<mapsto> enat eut];
       SPECT [(initial_union_find, []) \<mapsto> enat eft]
  }"

abbreviation "initState' == initState'_aux E empty_forest_time empty_uf_time"

definition (in -) "addEdge'_aux uf a w b T iut it = do {
  uf \<leftarrow> SPECT [per_union uf a b \<mapsto> enat iut];
  T' \<leftarrow> SPECT [  T@[ ( a,w, b) ] \<mapsto>enat it];
  RETURNT (uf, T')
  }"

abbreviation "addEdge' uf a w b T == addEdge'_aux uf a w b T insert_uf_time insert_time"

 definition (in -) kruskal2_aux
   where "kruskal2_aux w c  get st eft eut itt iut it \<equiv> do {
    sl \<leftarrow> obtain_sorted_carrier''_aux w c  get st;
    s \<leftarrow> initState'_aux c eft eut;
    (per, spanning_forest) \<leftarrow> nfoldli sl (\<lambda>_. True)
        (\<lambda>(a,w,b) (uf, T). do {
            ASSERT (a \<in> Domain uf \<and> b \<in> Domain uf);
            i \<leftarrow> SPECT [\<not> per_compare uf a b  \<mapsto> itt];
            if i then
              do {
                ASSERT ((a,w,b)\<notin>set T);
                addEdge'_aux uf a w b T iut it
              }
            else
              RETURNT (uf,T)
        }) s;
        RETURNT spanning_forest
      }"

abbreviation "kruskal2 == kruskal2_aux weight E getEdges_time sort_time
                             empty_forest_time empty_uf_time indep_test_time insert_uf_time insert_time "

lemma loop_initial_rel: "((per_init V, []), per_init V, {}) \<in> Id \<times>\<^sub>r lst_graph_rel"
  by simp

lemma loop_initial_refine: "initState'
   \<le> \<Down> (Id \<times>\<^sub>r lst_graph_rel) initState"
  unfolding initState'_aux_def initState_def
  apply(refine_rcg SPECT_refine)
  by (auto split: if_splits)

lemma wI: "(\<lambda>(a, _, y). Upair a y) ` D = A \<Longrightarrow> Upair b c \<notin> A \<Longrightarrow> (b, w, c) \<notin> D"
  by (metis case_prod_conv pair_imageI)

lemma listall2D: " list_all2 P xs y \<Longrightarrow> (\<And>x x'. P x x' \<longrightarrow> x' = a x)   \<Longrightarrow> y = map a xs"
  by (smt list.rel_eq list.rel_map(1) list_all2_mono)

lemma list_relD: "(x, y) \<in> \<langle>br a I\<rangle>list_rel \<Longrightarrow> y = map a x"
  by(auto dest!: listall2D simp: list_rel_def in_br_conv)

lemma list_set_rel_append: "(x,s)\<in>br a I \<Longrightarrow> (xs,S)\<in>\<langle>br a I\<rangle>list_set_rel \<Longrightarrow> s\<notin>S
     \<Longrightarrow> (xs@[x],insert s S)\<in>\<langle>br a I\<rangle>list_set_rel"
  unfolding list_set_rel_def
  apply(intro relcompI[where b="map a (xs @ [x])"])
   apply (auto simp: in_br_conv)
  apply parametricity by (auto dest: list_relD simp add: in_br_conv)

theorem kruskal2_refine: "kruskal2 \<le> \<Down>lst_graph_rel kruskal1 "
  unfolding kruskal1_def kruskal2_aux_def Let_def
  apply (refine_rcg obtain_sorted_carrier''_refine  loop_initial_refine)
           apply simp apply simp
  subgoal by (auto simp: in_br_conv)
  subgoal by (auto simp: in_br_conv)
       apply(rule ffs) subgoal by (auto simp: in_br_conv)
  subgoal by (auto simp: in_br_conv )
  subgoal   unfolding in_br_conv lst_graph_rel_def lst_graph_P_def list_set_rel_def
    by (simp add: wI)
  subgoal unfolding addEdge'_aux_def addEdge_def
    apply refine_rcg
     apply refine_dref_type
     apply(rule SPECT_refine)
     apply (auto split: if_splits simp: in_br_conv lst_graph_rel_alt  intro: list_set_rel_append)
    unfolding conc_fun_RES
    apply(rule T_specifies_I)
    apply (vcg' \<open>-\<close>  )
    apply(rule Sup_upper)  apply (auto split: if_splits)
    by (auto split: if_splits simp: in_br_conv lst_graph_rel_alt intro: list_set_rel_append)
  subgoal by (auto simp: in_br_conv )
  subgoal by (auto simp: in_br_conv )
  done

lemma  "single_valued lst_graph_rel"
  unfolding lst_graph_rel_alt list_set_rel_def
  by(auto intro!: single_valued_relcomp list_rel_sv)

end \<comment> \<open>whatIneed\<close>

end


(*  Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Inductive relation "ns_public" for the Needham-Schroeder Public-Key protocol.
Version incorporating Lowe's fix (inclusion of B's identity in round 2).
*)(*<*)
theory NS_Public imports Public begin(*>*)

section\<open>Modelling the Protocol \label{sec:modelling}\<close>

text_raw \<open>
\begin{figure}
\begin{isabelle}
\<close>

inductive_set ns_public :: "event list set"
  where

   Nil:  "[] \<in> ns_public"

 | Fake: "\<lbrakk>evsf \<in> ns_public;  X \<in> synth (analz (knows Spy evsf))\<rbrakk>
          \<Longrightarrow> Says Spy B X  # evsf \<in> ns_public"

 | NS1:  "\<lbrakk>evs1 \<in> ns_public;  Nonce NA \<notin> used evs1\<rbrakk>
          \<Longrightarrow> Says A B (Crypt (pubK B) \<lbrace>Nonce NA, Agent A\<rbrace>)
                 # evs1  \<in>  ns_public"

 | NS2:  "\<lbrakk>evs2 \<in> ns_public;  Nonce NB \<notin> used evs2;
           Says A' B (Crypt (pubK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs2\<rbrakk>
          \<Longrightarrow> Says B A (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB, Agent B\<rbrace>)
                # evs2  \<in>  ns_public"

 | NS3:  "\<lbrakk>evs3 \<in> ns_public;
           Says A  B (Crypt (pubK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs3;
           Says B' A (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB, Agent B\<rbrace>)
              \<in> set evs3\<rbrakk>
          \<Longrightarrow> Says A B (Crypt (pubK B) (Nonce NB)) # evs3 \<in> ns_public"

text_raw \<open>
\end{isabelle}
\caption{An Inductive Protocol Definition}\label{fig:ns_public}
\end{figure}
\<close>

text \<open>
Let us formalize the Needham-Schroeder public-key protocol, as corrected by
Lowe:
\begin{alignat*%
}{2}
  &1.&\quad  A\to B  &: \comp{Na,A}\sb{Kb} \\
  &2.&\quad  B\to A  &: \comp{Na,Nb,B}\sb{Ka} \\
  &3.&\quad  A\to B  &: \comp{Nb}\sb{Kb}
\end{alignat*%
}

Each protocol step is specified by a rule of an inductive definition.  An
event trace has type \<open>event list\<close>, so we declare the constant
\<open>ns_public\<close> to be a set of such traces.

Figure~\ref{fig:ns_public} presents the inductive definition.  The
\<open>Nil\<close> rule introduces the empty trace.  The \<open>Fake\<close> rule models the
adversary's sending a message built from components taken from past
traffic, expressed using the functions \<open>synth\<close> and
\<open>analz\<close>.
The next three rules model how honest agents would perform the three
protocol steps.

Here is a detailed explanation of rule \<open>NS2\<close>.
A trace containing an event of the form
@{term [display,indent=5] "Says A' B (Crypt (pubK B) \<lbrace>Nonce NA, Agent A\<rbrace>)"}
may be extended by an event of the form
@{term [display,indent=5] "Says B A (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB, Agent B\<rbrace>)"}
where \<open>NB\<close> is a fresh nonce: \<^term>\<open>Nonce NB \<notin> used evs2\<close>.
Writing the sender as \<open>A'\<close> indicates that \<open>B\<close> does not
know who sent the message.  Calling the trace variable \<open>evs2\<close> rather
than simply \<open>evs\<close> helps us know where we are in a proof after many
case-splits: every subgoal mentioning \<open>evs2\<close> involves message~2 of the
protocol.

Benefits of this approach are simplicity and clarity.  The semantic model
is set theory, proofs are by induction and the translation from the informal
notation to the inductive rules is straightforward.
\<close>

section\<open>Proving Elementary Properties \label{sec:regularity}\<close>

(*<*)
declare knows_Spy_partsEs [elim]
declare analz_subset_parts [THEN subsetD, dest]
declare Fake_parts_insert [THEN subsetD, dest]

(*A "possibility property": there are traces that reach the end*)
lemma "\<exists>NB. \<exists>evs \<in> ns_public. Says A B (Crypt (pubK B) (Nonce NB)) \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] ns_public.Nil [THEN ns_public.NS1, THEN ns_public.NS2,
                                   THEN ns_public.NS3])
by possibility

(**** Inductive proofs about ns_public ****)

(** Theorems of the form X \<notin> parts (knows Spy evs) imply that NOBODY
    sends messages containing X! **)

(*Spy never sees another agent's private key! (unless it's bad at start)*)
(*>*)

text \<open>
Secrecy properties can be hard to prove.  The conclusion of a typical
secrecy theorem is
\<^term>\<open>X \<notin> analz (knows Spy evs)\<close>.  The difficulty arises from
having to reason about \<open>analz\<close>, or less formally, showing that the spy
can never learn~\<open>X\<close>.  Much easier is to prove that \<open>X\<close> can never
occur at all.  Such \emph{regularity} properties are typically expressed
using \<open>parts\<close> rather than \<open>analz\<close>.

The following lemma states that \<open>A\<close>'s private key is potentially
known to the spy if and only if \<open>A\<close> belongs to the set \<open>bad\<close> of
compromised agents.  The statement uses \<open>parts\<close>: the very presence of
\<open>A\<close>'s private key in a message, whether protected by encryption or
not, is enough to confirm that \<open>A\<close> is compromised.  The proof, like
nearly all protocol proofs, is by induction over traces.
\<close>

lemma Spy_see_priK [simp]:
      "evs \<in> ns_public
       \<Longrightarrow> (Key (priK A) \<in> parts (knows Spy evs)) = (A \<in> bad)"
apply (erule ns_public.induct, simp_all)
txt \<open>
The induction yields five subgoals, one for each rule in the definition of
\<open>ns_public\<close>.  The idea is to prove that the protocol property holds initially
(rule \<open>Nil\<close>), is preserved by each of the legitimate protocol steps (rules
\<open>NS1\<close>--\<open>3\<close>), and even is preserved in the face of anything the
spy can do (rule \<open>Fake\<close>).

The proof is trivial.  No legitimate protocol rule sends any keys
at all, so only \<open>Fake\<close> is relevant. Indeed, simplification leaves
only the \<open>Fake\<close> case, as indicated by the variable name \<open>evsf\<close>:
@{subgoals[display,indent=0,margin=65]}
\<close>
by blast
(*<*)
lemma Spy_analz_priK [simp]:
      "evs \<in> ns_public \<Longrightarrow> (Key (priK A) \<in> analz (knows Spy evs)) = (A \<in> bad)"
by auto
(*>*)

text \<open>
The \<open>Fake\<close> case is proved automatically.  If
\<^term>\<open>priK A\<close> is in the extended trace then either (1) it was already in the
original trace or (2) it was
generated by the spy, who must have known this key already.
Either way, the induction hypothesis applies.

\emph{Unicity} lemmas are regularity lemmas stating that specified items
can occur only once in a trace.  The following lemma states that a nonce
cannot be used both as $Na$ and as $Nb$ unless
it is known to the spy.  Intuitively, it holds because honest agents
always choose fresh values as nonces; only the spy might reuse a value,
and he doesn't know this particular value.  The proof script is short:
induction, simplification, \<open>blast\<close>.  The first line uses the rule
\<open>rev_mp\<close> to prepare the induction by moving two assumptions into the
induction formula.
\<close>

lemma no_nonce_NS1_NS2:
    "\<lbrakk>Crypt (pubK C) \<lbrace>NA', Nonce NA, Agent D\<rbrace> \<in> parts (knows Spy evs);
      Crypt (pubK B) \<lbrace>Nonce NA, Agent A\<rbrace> \<in> parts (knows Spy evs);
      evs \<in> ns_public\<rbrakk>
     \<Longrightarrow> Nonce NA \<in> analz (knows Spy evs)"
apply (erule rev_mp, erule rev_mp)
apply (erule ns_public.induct, simp_all)
apply (blast intro: analz_insertI)+
done

text \<open>
The following unicity lemma states that, if \isa{NA} is secret, then its
appearance in any instance of message~1 determines the other components.
The proof is similar to the previous one.
\<close>

lemma unique_NA:
     "\<lbrakk>Crypt(pubK B)  \<lbrace>Nonce NA, Agent A \<rbrace> \<in> parts(knows Spy evs);
       Crypt(pubK B') \<lbrace>Nonce NA, Agent A'\<rbrace> \<in> parts(knows Spy evs);
       Nonce NA \<notin> analz (knows Spy evs); evs \<in> ns_public\<rbrakk>
      \<Longrightarrow> A=A' \<and> B=B'"
(*<*)
apply (erule rev_mp, erule rev_mp, erule rev_mp)
apply (erule ns_public.induct, simp_all)
(*Fake, NS1*)
apply (blast intro: analz_insertI)+
done
(*>*)

section\<open>Proving Secrecy Theorems \label{sec:secrecy}\<close>

(*<*)
(*Secrecy: Spy does not see the nonce sent in msg NS1 if A and B are secure
  The major premise "Says A B ..." makes it a dest-rule, so we use
  (erule rev_mp) rather than rule_format. *)
theorem Spy_not_see_NA:
      "\<lbrakk>Says A B (Crypt(pubK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs;
        A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
       \<Longrightarrow> Nonce NA \<notin> analz (knows Spy evs)"
apply (erule rev_mp)
apply (erule ns_public.induct, simp_all)
apply spy_analz
apply (blast dest: unique_NA intro: no_nonce_NS1_NS2)+
done

(*Authentication for A: if she receives message 2 and has used NA
  to start a run, then B has sent message 2.*)
lemma A_trusts_NS2_lemma [rule_format]:
   "\<lbrakk>A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
    \<Longrightarrow> Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB, Agent B\<rbrace> \<in> parts (knows Spy evs) \<longrightarrow>
        Says A B (Crypt(pubK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs \<longrightarrow>
        Says B A (Crypt(pubK A) \<lbrace>Nonce NA, Nonce NB, Agent B\<rbrace>) \<in> set evs"
apply (erule ns_public.induct, simp_all)
(*Fake, NS1*)
apply (blast dest: Spy_not_see_NA)+
done

theorem A_trusts_NS2:
     "\<lbrakk>Says A  B (Crypt(pubK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs;
       Says B' A (Crypt(pubK A) \<lbrace>Nonce NA, Nonce NB, Agent B\<rbrace>) \<in> set evs;
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
      \<Longrightarrow> Says B A (Crypt(pubK A) \<lbrace>Nonce NA, Nonce NB, Agent B\<rbrace>) \<in> set evs"
by (blast intro: A_trusts_NS2_lemma)

(*If the encrypted message appears then it originated with Alice in NS1*)
lemma B_trusts_NS1 [rule_format]:
     "evs \<in> ns_public
      \<Longrightarrow> Crypt (pubK B) \<lbrace>Nonce NA, Agent A\<rbrace> \<in> parts (knows Spy evs) \<longrightarrow>
          Nonce NA \<notin> analz (knows Spy evs) \<longrightarrow>
          Says A B (Crypt (pubK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs"
apply (erule ns_public.induct, simp_all)
(*Fake*)
apply (blast intro!: analz_insertI)
done

(*** Authenticity properties obtained from NS2 ***)

(*Unicity for NS2: nonce NB identifies nonce NA and agents A, B
  [unicity of B makes Lowe's fix work]
  [proof closely follows that for unique_NA] *)

lemma unique_NB [dest]:
     "\<lbrakk>Crypt(pubK A)  \<lbrace>Nonce NA, Nonce NB, Agent B\<rbrace> \<in> parts(knows Spy evs);
       Crypt(pubK A') \<lbrace>Nonce NA', Nonce NB, Agent B'\<rbrace> \<in> parts(knows Spy evs);
       Nonce NB \<notin> analz (knows Spy evs); evs \<in> ns_public\<rbrakk>
      \<Longrightarrow> A=A' \<and> NA=NA' \<and> B=B'"
apply (erule rev_mp, erule rev_mp, erule rev_mp)
apply (erule ns_public.induct, simp_all)
(*Fake, NS2*)
apply (blast intro: analz_insertI)+
done
(*>*)

text \<open>
The secrecy theorems for Bob (the second participant) are especially
important because they fail for the original protocol.  The following
theorem states that if Bob sends message~2 to Alice, and both agents are
uncompromised, then Bob's nonce will never reach the spy.
\<close>

theorem Spy_not_see_NB [dest]:
 "\<lbrakk>Says B A (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB, Agent B\<rbrace>) \<in> set evs;
   A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
  \<Longrightarrow> Nonce NB \<notin> analz (knows Spy evs)"
txt \<open>
To prove it, we must formulate the induction properly (one of the
assumptions mentions~\<open>evs\<close>), apply induction, and simplify:
\<close>

apply (erule rev_mp, erule ns_public.induct, simp_all)
(*<*)
apply spy_analz
defer
apply (blast intro: no_nonce_NS1_NS2)
apply (blast intro: no_nonce_NS1_NS2)
(*>*)

txt \<open>
The proof states are too complicated to present in full.
Let's examine the simplest subgoal, that for message~1.  The following
event has just occurred:
\[ 1.\quad  A'\to B'  : \comp{Na',A'}\sb{Kb'} \]
The variables above have been primed because this step
belongs to a different run from that referred to in the theorem
statement --- the theorem
refers to a past instance of message~2, while this subgoal
concerns message~1 being sent just now.
In the Isabelle subgoal, instead of primed variables like $B'$ and $Na'$
we have \<open>Ba\<close> and~\<open>NAa\<close>:
@{subgoals[display,indent=0]}
The simplifier has used a
default simplification rule that does a case
analysis for each encrypted message on whether or not the decryption key
is compromised.
@{named_thms [display,indent=0,margin=50] analz_Crypt_if [no_vars] (analz_Crypt_if)}
The simplifier has also used \<open>Spy_see_priK\<close>, proved in
{\S}\ref{sec:regularity} above, to yield \<^term>\<open>Ba \<in> bad\<close>.

Recall that this subgoal concerns the case
where the last message to be sent was
\[ 1.\quad  A'\to B'  : \comp{Na',A'}\sb{Kb'}. \]
This message can compromise $Nb$ only if $Nb=Na'$ and $B'$ is compromised,
allowing the spy to decrypt the message.  The Isabelle subgoal says
precisely this, if we allow for its choice of variable names.
Proving \<^term>\<open>NB \<noteq> NAa\<close> is easy: \<open>NB\<close> was
sent earlier, while \<open>NAa\<close> is fresh; formally, we have
the assumption \<^term>\<open>Nonce NAa \<notin> used evs1\<close>.

Note that our reasoning concerned \<open>B\<close>'s participation in another
run.  Agents may engage in several runs concurrently, and some attacks work
by interleaving the messages of two runs.  With model checking, this
possibility can cause a state-space explosion, and for us it
certainly complicates proofs.  The biggest subgoal concerns message~2.  It
splits into several cases, such as whether or not the message just sent is
the very message mentioned in the theorem statement.
Some of the cases are proved by unicity, others by
the induction hypothesis.  For all those complications, the proofs are
automatic by \<open>blast\<close> with the theorem \<open>no_nonce_NS1_NS2\<close>.

The remaining theorems about the protocol are not hard to prove.  The
following one asserts a form of \emph{authenticity}: if
\<open>B\<close> has sent an instance of message~2 to~\<open>A\<close> and has received the
expected reply, then that reply really originated with~\<open>A\<close>.  The
proof is a simple induction.
\<close>

(*<*)
by (blast intro: no_nonce_NS1_NS2)

lemma B_trusts_NS3_lemma [rule_format]:
     "\<lbrakk>A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk> \<Longrightarrow>
      Crypt (pubK B) (Nonce NB) \<in> parts (knows Spy evs) \<longrightarrow>
      Says B A (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB, Agent B\<rbrace>) \<in> set evs \<longrightarrow>
      Says A B (Crypt (pubK B) (Nonce NB)) \<in> set evs"
by (erule ns_public.induct, auto)
(*>*)
theorem B_trusts_NS3:
 "\<lbrakk>Says B A  (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB, Agent B\<rbrace>) \<in> set evs;
   Says A' B (Crypt (pubK B) (Nonce NB)) \<in> set evs;
   A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
  \<Longrightarrow> Says A B (Crypt (pubK B) (Nonce NB)) \<in> set evs"
(*<*)
by (blast intro: B_trusts_NS3_lemma)

(*** Overall guarantee for B ***)

(*If NS3 has been sent and the nonce NB agrees with the nonce B joined with
  NA, then A initiated the run using NA.*)
theorem B_trusts_protocol [rule_format]:
     "\<lbrakk>A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk> \<Longrightarrow>
      Crypt (pubK B) (Nonce NB) \<in> parts (knows Spy evs) \<longrightarrow>
      Says B A  (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB, Agent B\<rbrace>) \<in> set evs \<longrightarrow>
      Says A B (Crypt (pubK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs"
by (erule ns_public.induct, auto)
(*>*)

text \<open>
From similar assumptions, we can prove that \<open>A\<close> started the protocol
run by sending an instance of message~1 involving the nonce~\<open>NA\<close>\@.
For this theorem, the conclusion is
@{thm [display] (concl) B_trusts_protocol [no_vars]}
Analogous theorems can be proved for~\<open>A\<close>, stating that nonce~\<open>NA\<close>
remains secret and that message~2 really originates with~\<open>B\<close>.  Even the
flawed protocol establishes these properties for~\<open>A\<close>;
the flaw only harms the second participant.

\medskip

Detailed information on this protocol verification technique can be found
elsewhere~\<^cite>\<open>"paulson-jcs"\<close>, including proofs of an Internet
protocol~\<^cite>\<open>"paulson-tls"\<close>.  We must stress that the protocol discussed
in this chapter is trivial.  There are only three messages; no keys are
exchanged; we merely have to prove that encrypted data remains secret.
Real world protocols are much longer and distribute many secrets to their
participants.  To be realistic, the model has to include the possibility
of keys being lost dynamically due to carelessness.  If those keys have
been used to encrypt other sensitive information, there may be cascading
losses.  We may still be able to establish a bound on the losses and to
prove that other protocol runs function
correctly~\<^cite>\<open>"paulson-yahalom"\<close>.  Proofs of real-world protocols follow
the strategy illustrated above, but the subgoals can
be much bigger and there are more of them.
\index{protocols!security|)}
\<close>

(*<*)end(*>*)


theory Terms
  imports "../Nominal2/Nominal2"  Vars  "AList-Utils-Nominal"
begin

subsubsection {* Expressions *}

text {*
This is the main data type of the development; our minimal lambda calculus with recursive let-bindings.
It is created using the nominal\_datatype command, which creates alpha-equivalence classes.

The package does not support nested recursion, so the bindings of the let cannot simply be of type
@{text "(var, exp) list"}. Instead, the definition of lists have to be inlined here, as the custom type
@{text "assn"}. Later we create conversion functions between these two types, define a properly typed @{text let}
and redo the various lemmas in terms of that, so that afterwards, the type @{text "assn"} is no longer
referenced.
*}

nominal_datatype exp =
  Var "var"
| App "exp" "var"
| LetA as::"assn" body::"exp" binds "bn as" in "body" "as"
| Lam x::"var" body::"exp" binds x in body  ("Lam [_]. _" [100, 100] 100)
and assn =
  ANil | ACons "var" "exp" "assn"
binder
  bn
where "bn ANil = []" | "bn (ACons x t as) = (atom x) # (bn as)"

notation (latex output) Terms.Var ("_")
notation (latex output) Terms.App ("_ _")
notation (latex output) Terms.Lam ("\<lambda>_. _"  [100, 100] 100)

type_synonym heap = "(var \<times> exp) list"

subsubsection {* Rewriting in terms of heaps *}

text {*
We now work towards using @{type heap} instead of @{type assn}. All this
could be skipped if Nominal supported nested recursion.
*}

text {*
Conversion from @{typ assn} to @{typ heap}.
*}

nominal_function asToHeap :: "assn \<Rightarrow> heap"
 where ANilToHeap: "asToHeap ANil = []"
 | AConsToHeap: "asToHeap (ACons v e as) = (v, e) # asToHeap as"
unfolding eqvt_def asToHeap_graph_aux_def
apply rule
apply simp
apply rule
apply(case_tac x rule: exp_assn.exhaust(2))
apply auto
done
nominal_termination(eqvt) by lexicographic_order

lemma asToHeap_eqvt: "eqvt asToHeap"
  unfolding eqvt_def
  by (auto simp add: permute_fun_def asToHeap.eqvt)

text {* The other direction. *}

fun heapToAssn :: "heap \<Rightarrow> assn"
  where "heapToAssn [] = ANil"
  | "heapToAssn ((v,e)#\<Gamma>) = ACons v e (heapToAssn \<Gamma>)"
declare heapToAssn.simps[simp del]

lemma heapToAssn_eqvt[simp,eqvt]: "p \<bullet> heapToAssn \<Gamma> =  heapToAssn (p \<bullet> \<Gamma>)"
  by (induct \<Gamma> rule: heapToAssn.induct)
     (auto simp add: heapToAssn.simps)

lemma bn_heapToAssn: "bn (heapToAssn \<Gamma>) = map (\<lambda>x. atom (fst x)) \<Gamma>"
  by (induct rule: heapToAssn.induct)
     (auto simp add: heapToAssn.simps exp_assn.bn_defs)

lemma set_bn_to_atom_domA:
  "set (bn as) = atom ` domA (asToHeap as)"
   by (induct as rule: asToHeap.induct)
      (auto simp add: exp_assn.bn_defs)

text {*
They are inverse to each other.
*}

lemma heapToAssn_asToHeap[simp]:
  "heapToAssn (asToHeap as) = as"
  by (induct  rule: exp_assn.inducts(2)[of "\<lambda> _ . True"])
     (auto simp add: heapToAssn.simps)

lemma heapToAssn_inject[simp]:
  "heapToAssn x = heapToAssn y \<longleftrightarrow> x = y"
  by (metis asToHeap_heapToAssn)

text {*
They are transparent to varios notions from the Nominal package.
*}

lemma supp_heapToAssn: "supp (heapToAssn \<Gamma>) = supp \<Gamma>"
  by (induct rule: heapToAssn.induct)
     (simp_all add: heapToAssn.simps  exp_assn.supp supp_Nil supp_Cons supp_Pair sup_assoc)

lemma supp_asToHeap: "supp (asToHeap as) = supp as"
   by (induct as rule: asToHeap.induct)
      (simp_all add:  exp_assn.supp supp_Nil supp_Cons supp_Pair sup_assoc)

lemma fv_asToHeap: "fv (asToHeap \<Gamma>) = fv \<Gamma>"
  unfolding fv_def by (auto simp add: supp_asToHeap)

lemma fv_heapToAssn: "fv (heapToAssn \<Gamma>) = fv \<Gamma>"
  unfolding fv_def by (auto simp add: supp_heapToAssn)

text {* Now we define the Let constructor in the form that we actually want. *}

hide_const HOL.Let
definition Let :: "heap \<Rightarrow> exp \<Rightarrow> exp"
  where "Let \<Gamma> e = LetA (heapToAssn \<Gamma>) e"

notation (latex output) Let ("\<^raw:\textrm{\textsf{let}}> _ \<^raw:\textrm{\textsf{in}}> _")

abbreviation
  LetBe :: "var\<Rightarrow>exp\<Rightarrow>exp\<Rightarrow>exp" ("let _ be _ in _ " [100,100,100] 100)
where
  "let x be t1 in t2 \<equiv> Let [(x,t1)] t2"

text {*
We rewrite all (relevant) lemmas about @{term LetA} in terms of @{term Let}.
*}

lemma size_Let[simp]: "size (Let \<Gamma> e) = size_list (\<lambda>p. size (snd p)) \<Gamma> + size e + Suc 0"
  unfolding Let_def by (auto simp add: split_beta')

lemma Let_distinct[simp]:
  "Var v \<noteq> Let \<Gamma> e"
  "Let \<Gamma> e \<noteq> Var v"
  "App e v \<noteq> Let \<Gamma> e'"
  "Lam [v]. e' \<noteq> Let \<Gamma> e"
  "Let \<Gamma> e \<noteq> Lam [v]. e'"
  "Let \<Gamma> e' \<noteq> App e v"
  unfolding Let_def by simp_all

lemma Let_perm_simps[simp,eqvt]:
  "p \<bullet> Let \<Gamma> e = Let (p \<bullet> \<Gamma>) (p \<bullet> e)"
  unfolding Let_def by simp

lemma Let_supp:
  "supp (Let \<Gamma> e) = (supp e \<union> supp \<Gamma>) - atom ` (domA \<Gamma>)"
  unfolding Let_def by (simp add: exp_assn.supp supp_heapToAssn bn_heapToAssn domA_def image_image)

lemma Let_fresh[simp]:
  "a \<sharp> Let \<Gamma> e = (a \<sharp> e \<and> a \<sharp> \<Gamma> \<or> a \<in> atom ` domA \<Gamma>)"
  unfolding fresh_def by (auto simp add: Let_supp)

lemma Abs_eq_cong:
  assumes "\<And> p. (p \<bullet> x = x') \<longleftrightarrow> (p \<bullet> y = y')"
  assumes "supp y = supp x"
  assumes "supp y' = supp x'"
  shows "([a]lst. x = [a']lst. x') \<longleftrightarrow> ([a]lst. y = [a']lst. y')"
  by (simp add: Abs_eq_iff alpha_lst assms)

lemma Let_eq_iff[simp]:
  "(Let \<Gamma> e = Let \<Gamma>' e') = ([map (\<lambda>x. atom (fst x)) \<Gamma> ]lst. (e, \<Gamma>) = [map (\<lambda>x. atom (fst x)) \<Gamma>']lst. (e',\<Gamma>'))"
  unfolding Let_def
  apply (simp add: bn_heapToAssn)
  apply (rule Abs_eq_cong)
  apply (simp_all add: supp_Pair supp_heapToAssn)
  done

lemma exp_strong_exhaust:
  fixes c :: "'a :: fs"
  assumes "(\<And>var. y = Var var \<Longrightarrow> P)"
  assumes "\<And>exp var. y = App exp var \<Longrightarrow> P"
  assumes "\<And>\<Gamma> exp. atom ` domA \<Gamma> \<sharp>* c \<Longrightarrow> y = Let \<Gamma> exp \<Longrightarrow> P"
  assumes "\<And>var exp. {atom var} \<sharp>* c \<Longrightarrow> y = Lam [var]. exp \<Longrightarrow> P"
  shows P
  apply (rule  exp_assn.strong_exhaust(1)[where y = y and c = c])
  apply (metis assms(1))
  apply (metis assms(2))
  apply (metis assms(3) set_bn_to_atom_domA Let_def heapToAssn_asToHeap)
  apply (metis assms(4))
  done

text {*
And finally the induction rules with @{term Let}.
*}

lemma exp_heap_induct[case_names Var App Let Lam Nil Cons]:
  assumes "\<And>var. P1 (Var var)"
  assumes "\<And>exp var. P1 exp \<Longrightarrow> P1 (App exp var)"
  assumes "\<And>\<Gamma> exp. P2 \<Gamma> \<Longrightarrow> P1 exp \<Longrightarrow> P1 (Let \<Gamma> exp)"
  assumes "\<And>var exp. P1 exp \<Longrightarrow> P1 (Lam [var]. exp)"
  assumes "P2 []"
  assumes "\<And>var exp \<Gamma>. P1 exp \<Longrightarrow> P2 \<Gamma> \<Longrightarrow> P2 ((var, exp)#\<Gamma>)"
  shows "P1 e" and "P2 \<Gamma>"
proof-
  have "P1 e" and "P2 (asToHeap (heapToAssn \<Gamma>))"
    apply (induct rule: exp_assn.inducts[of P1 "\<lambda> assn. P2 (asToHeap assn)"])
    apply (metis assms(1))
    apply (metis assms(2))
    apply (metis assms(3) Let_def heapToAssn_asToHeap )
    apply (metis assms(4))
    apply (metis assms(5) asToHeap.simps(1))
    apply (metis assms(6) asToHeap.simps(2))
    done
  thus "P1 e" and "P2 \<Gamma>" unfolding asToHeap_heapToAssn.
qed

lemma exp_heap_strong_induct[case_names Var App Let Lam Nil Cons]:
  assumes "\<And>var c. P1 c (Var var)"
  assumes "\<And>exp var c. (\<And>c. P1 c exp) \<Longrightarrow> P1 c (App exp var)"
  assumes "\<And>\<Gamma> exp c. atom ` domA \<Gamma> \<sharp>* c \<Longrightarrow> (\<And>c. P2 c \<Gamma>) \<Longrightarrow> (\<And>c. P1 c exp) \<Longrightarrow> P1 c (Let \<Gamma> exp)"
  assumes "\<And>var exp c. {atom var} \<sharp>* c \<Longrightarrow> (\<And>c. P1 c exp) \<Longrightarrow> P1 c (Lam [var]. exp)"
  assumes "\<And>c. P2 c []"
  assumes "\<And>var exp \<Gamma> c. (\<And>c. P1 c exp) \<Longrightarrow> (\<And>c. P2 c \<Gamma>) \<Longrightarrow> P2 c ((var,exp)#\<Gamma>)"
  fixes c :: "'a :: fs"
  shows "P1 c e" and "P2 c \<Gamma>"
proof-
  have "P1 c e" and "P2 c (asToHeap (heapToAssn \<Gamma>))"
    apply (induct rule: exp_assn.strong_induct[of P1 "\<lambda> c assn. P2 c (asToHeap assn)"])
    apply (metis assms(1))
    apply (metis assms(2))
    apply (metis assms(3) set_bn_to_atom_domA Let_def heapToAssn_asToHeap )
    apply (metis assms(4))
    apply (metis assms(5) asToHeap.simps(1))
    apply (metis assms(6) asToHeap.simps(2))
    done
  thus "P1 c e" and "P2 c \<Gamma>" unfolding asToHeap_heapToAssn.
qed

subsubsection {* Nice induction rules *}

text {*
These rules can be used instead of the original induction rules, which require a separate
goal for @{typ assn}.
*}

lemma exp_induct[case_names Var App Let Lam]:
  assumes "\<And>var. P (Var var)"
  assumes "\<And>exp var. P exp \<Longrightarrow> P (App exp var)"
  assumes "\<And>\<Gamma> exp. (\<And> x. x \<in> domA \<Gamma> \<Longrightarrow>  P (the (map_of \<Gamma> x))) \<Longrightarrow> P exp \<Longrightarrow> P (Let \<Gamma> exp)"
  assumes "\<And>var exp.  P exp \<Longrightarrow> P (Lam [var]. exp)"
  shows "P  exp"
  apply (rule exp_heap_induct[of P "\<lambda> \<Gamma>. (\<forall>x \<in> domA \<Gamma>. P (the (map_of \<Gamma> x)))"])
  apply (metis assms(1))
  apply (metis assms(2))
  apply (metis assms(3))
  apply (metis assms(4))
  apply auto
  done

lemma  exp_strong_induct[case_names Var App Let Lam]:
  assumes "\<And>var c. P c (Var var)"
  assumes "\<And>exp var c. (\<And>c. P c exp) \<Longrightarrow> P c (App exp var)"
  assumes "\<And>\<Gamma> exp c.
    atom ` domA \<Gamma> \<sharp>* c \<Longrightarrow> (\<And>c x. x \<in> domA \<Gamma> \<Longrightarrow>  P c (the (map_of \<Gamma> x))) \<Longrightarrow> (\<And>c. P c exp) \<Longrightarrow> P c (Let \<Gamma> exp)"
  assumes "\<And>var exp c. {atom var} \<sharp>* c \<Longrightarrow> (\<And>c. P c exp) \<Longrightarrow> P c (Lam [var]. exp)"
  shows "P (c::'a::fs) exp"
  apply (rule exp_heap_strong_induct(1)[of P "\<lambda> c \<Gamma>. (\<forall>x \<in> domA \<Gamma>. P c (the (map_of \<Gamma> x)))"])
  apply (metis assms(1))
  apply (metis assms(2))
  apply (metis assms(3))
  apply (metis assms(4))
  apply auto
  done

subsubsection {* Testing alpha equivalence *}

lemma alpha_test:
  shows "Lam [x]. (Var x) = Lam [y]. (Var y)"
  by (simp add: Abs1_eq_iff fresh_at_base)

lemma alpha_test2:
  shows "let x be (Var x) in (Var x) = let y be (Var y) in (Var y)"
  by (simp add: fresh_Cons fresh_Nil Abs1_eq_iff fresh_Pair add: fresh_at_base)

lemma alpha_test3:
  shows "
    Let [(x, Var y), (y, Var x)] (Var x)
    =
    Let [(y, Var x), (x, Var y)] (Var y)" (is "Let ?la ?lb = _")
  by (simp add: bn_heapToAssn Abs1_eq_iff fresh_Pair fresh_at_base
                Abs_swap2[of "atom x" "(?lb, [(x, Var y), (y, Var x)])" "[atom x, atom y]" "atom y"])

subsubsection {* Free variables *}

lemma fv_supp_exp: "supp e = atom ` (fv (e::exp) :: var set)" and fv_supp_as: "supp as = atom ` (fv (as::assn) :: var set)"
  by (induction e and as rule:exp_assn.inducts)
     (auto simp add: fv_def exp_assn.supp supp_at_base)

lemma fv_supp_heap: "supp (\<Gamma>::heap) = atom ` (fv \<Gamma> :: var set)"
  by (metis fv_def fv_supp_as supp_heapToAssn)

lemma fv_Lam[simp]: "fv (Lam [x]. e) = fv e - {x}"
  unfolding fv_def by (auto simp add: exp_assn.supp)
lemma fv_Var[simp]: "fv (Var x) = {x}"
  unfolding fv_def by (auto simp add: exp_assn.supp supp_at_base)
lemma fv_App[simp]: "fv (App e x) = insert x (fv e)"
  unfolding fv_def by (auto simp add: exp_assn.supp supp_at_base)

lemma finite_fv_exp[simp]: "finite (fv (e::exp) :: var set)"
  and finite_fv_heap[simp]: "finite (fv (\<Gamma> :: heap) :: var set)"
  by (induction e rule:exp_heap_induct) auto

lemma fv_not_fresh: "atom x \<sharp> e \<longleftrightarrow> x \<notin> fv e"
  unfolding fv_def fresh_def by blast

lemma fv_delete_heap:
  assumes "map_of \<Gamma> x = Some e"
  shows "fv (delete x \<Gamma>, e) \<union> {x} \<subseteq> (fv (\<Gamma>, Var x) :: var set)"
proof-
  have "fv (delete x \<Gamma>) \<subseteq> fv \<Gamma>" by (metis fv_delete_subset)
  moreover
  have "(x,e) \<in> set \<Gamma>" by (metis assms map_of_is_SomeD)
  hence "fv e \<subseteq> fv \<Gamma>" by (metis assms domA_from_set map_of_fv_subset option.sel)
  moreover
  have "x \<in> fv (Var x)" by simp
  ultimately show ?thesis by auto
qed

end


theory Roalist
imports Oalist Linorder_Insts
begin
(* implementation of a recursive AList
   (i.e., ordered alist where values are ordered alists of the same type)
   this is needed for e.g. closures. *)

type_synonym closid = nat

type_synonym ('k, 'v) alist = "('k * 'v) list"

(* want 'v option here. problem - is this going to create issues for our data ordering? *)
(* 'd stores variable names (useful for representing closures *)
type_synonym ('k, 'v, 'd) roalist' =
  "(('k list) * ('v + 'd)) list"

(* also this lacks a canonical representation, I think *)
(*
type_synonym ('k, 'v) recclos =
  "(('k list), ('v + unit)) alist"
*)

(* old version that does not check validity *)

fun roalist_gather' :: "('k :: linorder, 'v, 'd) roalist' \<Rightarrow> 'k \<Rightarrow> ('k :: linorder, 'v, 'd) roalist'" where
"roalist_gather' [] _ = []"
| "roalist_gather' (([], vh)#l) k = roalist_gather' l k"
| "roalist_gather' (([kh], (Inl _))#l) k = roalist_gather' l k"
| "roalist_gather' (([kh], (Inr d))#l) k =
  ( if k = kh then ([], Inr d)#roalist_gather' l k
    else roalist_gather' l k)"
| "roalist_gather' (((khh1#khh2#kht), vh)#l) k =
  ( if k = khh1 then (khh2#kht, vh) # roalist_gather' l k
    else roalist_gather' l k)"

lemma roalist_gather'_elem :
  assumes Hord : "strict_order (map fst l)"
  assumes H : "(kt, v) \<in> set (roalist_gather' l kh)"
  shows "(kh#kt, v) \<in> set l" using Hord H
proof(induction l arbitrary: kh kt v)
  case Nil
  then show ?case by auto
next
  case (Cons a l)
  then have Ord_tl : "strict_order (map fst l)" using strict_order_tl by auto
  obtain k1 v1 where H1 : "(a = (k1, v1))" by (cases a; auto)

  then show ?case
  proof(cases k1)
    assume Nil' : "k1 = []"
    then show ?thesis using Cons H1 Ord_tl by auto
  next
    fix h1 t1
    assume Cons' : "k1 = h1 # t1"
    then show ?thesis
    proof(cases t1)
      case Nil
      then show ?thesis
      proof(cases v1)
        case (Inl a)
        then show ?thesis using Cons H1 Cons' Ord_tl Nil
          by(auto)
      next
        case (Inr b)
        then show ?thesis
        proof(cases "h1 = kh")
          case False
          then show ?thesis using Cons H1 Cons' Nil Ord_tl Inr by(auto)
        next
          case True
          then show ?thesis using Cons.prems Cons.IH[OF Ord_tl] H1 Cons' Nil Inr
            by(auto)
        qed
      qed
    next
      fix h2 t2
      assume Cons'' : "t1 = h2#t2"
      then show ?thesis
      proof(cases "h1 = kh")
        case False
        then show ?thesis using Cons H1 Cons' Cons'' Ord_tl by(auto)
      next
        case True
        then show ?thesis using Cons.prems Cons.IH[OF Ord_tl] H1 Cons' Cons'' by(auto)
      qed
    qed
  qed
qed

lemma roalist_gather'_elem'1 :
  assumes Hord : "strict_order (map fst l)"
  assumes H : "(kh1#kh2#kt, v) \<in> set l"
  shows "(kh2#kt, v) \<in> set (roalist_gather' l kh1)"
     using Hord H
proof(induction l arbitrary: kh1 kh2 kt v)
  case Nil
  then show ?case by auto
next
  case (Cons a l)
  then have Ord_tl : "strict_order (map fst l)" using strict_order_tl by auto
  obtain k1 v1 where H1 : "(a = (k1, v1))" by (cases a; auto)

  show ?case
  proof(cases k1)
    assume Nil' : "k1 = []"
    then show ?thesis using Cons H1 Ord_tl by auto
  next
    fix h1 t1
    assume Cons' : "k1 = h1 # t1"
    then show ?thesis
    proof(cases t1)
      case Nil
      then show ?thesis
      proof(cases v1)
        case (Inl a)
        then show ?thesis using Cons H1 Cons' Ord_tl Nil
          by(auto)
      next
        case (Inr b)
        then show ?thesis
        proof(cases "h1 = kh1")
          case False
          then show ?thesis using Cons H1 Cons' Nil Ord_tl Inr by(auto)
        next
          case True
          then show ?thesis using Cons.prems Cons.IH[OF Ord_tl] H1 Cons' Nil Inr
            by(auto)
        qed
      qed
    next
      fix h2 t2
      assume Cons'' : "t1 = h2#t2"
      then show ?thesis
      proof(cases "h1 = kh1")
        case False
        then show ?thesis using Cons H1 Cons' Cons'' Ord_tl by(auto)
      next
        case True
        then show ?thesis using Cons.prems Cons.IH[OF Ord_tl] H1 Cons' Cons'' by(auto)
      qed
    qed
  qed
qed

lemma roalist_gather'_elem'2 :
  assumes Hord : "strict_order (map fst l)"
  assumes H : "(kh1#kt, Inr d) \<in> set l"
  shows "(kt, Inr d) \<in> set (roalist_gather' l kh1)"
     using Hord H
proof(induction l arbitrary: kh1 kt)
  case Nil
  then show ?case by auto
next
  case (Cons a l)
  then have Ord_tl : "strict_order (map fst l)" using strict_order_tl by auto
  obtain k1 v1 where H1 : "(a = (k1, v1))" by (cases a; auto)

  show ?case
  proof(cases k1)
    assume Nil' : "k1 = []"
    then show ?thesis using Cons H1 Ord_tl by auto
  next
    fix h1 t1
    assume Cons' : "k1 = h1 # t1"
    then show ?thesis
    proof(cases t1)
      case Nil
      then show ?thesis
      proof(cases v1)
        case (Inl a)
        then show ?thesis using Cons H1 Cons' Ord_tl Nil
          by(auto)
      next
        case (Inr b)
        then show ?thesis
        proof(cases "h1 = kh1")
          case False
          then show ?thesis using Cons H1 Cons' Nil Ord_tl Inr by(auto)
        next
          case True
          then show ?thesis using Cons.prems Cons.IH[OF Ord_tl] H1 Cons' Nil Inr
            by(auto)
        qed
      qed
    next
      fix h2 t2
      assume Cons'' : "t1 = h2#t2"
      then show ?thesis
      proof(cases "h1 = kh1")
        case False
        then show ?thesis using Cons H1 Cons' Cons'' Ord_tl by(auto)
      next
        case True
        then show ?thesis using Cons.prems Cons.IH[OF Ord_tl] H1 Cons' Cons'' by(auto)
      qed
    qed
  qed
qed

lemma roalist_gather'_order :
  assumes Hord : "strict_order (map fst l)"
  shows "strict_order (map fst (roalist_gather' l k))" using Hord
proof(induction l arbitrary: k)
  case Nil
  then show ?case by auto
next
  case (Cons a l)
  then have Ord_tl : "strict_order (map fst l)" using strict_order_tl by auto
  obtain k1 v1 where H1 : "(a = (k1, v1))" by (cases a; auto)
  show ?case
  proof(cases k1)
    case Nil
    then show ?thesis using H1 Cons.IH[OF Ord_tl] by(auto)
  next
    fix h1 t1
    assume Cons' : "k1 = h1 # t1"
    show ?thesis
    proof(cases t1)
      case Nil
      show ?thesis
      proof(cases v1)
        case (Inl a)
        then show ?thesis using Cons H1 Cons' Ord_tl Nil
          by(auto)
      next
        case (Inr b)
        then show ?thesis using Cons H1 Cons' Nil Ord_tl Inr
(* need an argument similar to cons case here. *)
        proof(cases "h1 = k")
          case False
          then show ?thesis using Cons H1 Cons' Nil Ord_tl Inr by(auto)
        next
          case True
          then show ?thesis
          proof(cases "map fst (roalist_gather' l k)")
            case Nil' : Nil
            then show ?thesis  using H1 Cons' Nil Inr True by(auto simp add:strict_order_def)
          next
            case Cons'' : (Cons h2 t2)

            hence Cons'''_in : "h2 \<in> set (map fst (roalist_gather' l k))" by auto
            then obtain v3 where H2 : "(h2, v3) \<in> set (roalist_gather' l k)" by(auto)
            have H2_l : "(k#h2, v3) \<in> set l"
              using roalist_gather'_elem[OF Ord_tl H2]  by auto
            then obtain idx where "idx < length l" "l ! idx = (k#h2, v3)"
              unfolding in_set_conv_nth
              by auto

            then have Lt : "t1 < h2"
              using strict_order_unfold[OF Cons.prems, of "1 + idx" 0] H1 Cons' True
              by(auto simp add: list_lo_lt)

            show ?thesis using
              strict_order_cons[OF Lt]
              Cons.prems Cons.IH[OF Ord_tl, of k] H1 Cons' Cons'' Inr Nil True
              by(auto)
          qed
        qed
      qed
    next
      fix h2 t2
      assume Cons'' : "t1 = h2#t2"
      then show ?thesis
      proof(cases "h1 = k")
        case False
        then show ?thesis using Cons H1 Cons' Cons'' Ord_tl by(auto)
      next
        case True
        show ?thesis
        proof(cases "map fst (roalist_gather' l k)")
          case Nil
          then show ?thesis  using H1 Cons' Cons'' True by(auto simp add:strict_order_def)
        next
          fix h3 t3
          assume Cons''' : "map fst (roalist_gather' l k) = h3 # t3"
          hence Cons'''_in : "h3 \<in> set (map fst (roalist_gather' l k))" by auto
          then obtain v3 where H2 : "(h3, v3) \<in> set (roalist_gather' l k)" by(auto)
          have H2_l : "(k#h3, v3) \<in> set l"  (*roalist_gather'_elem[OF Ord_tl H2] by auto *)
            using roalist_gather'_elem[OF Ord_tl H2]  by auto
          then obtain idx where "idx < length l" "l ! idx = (k#h3, v3)"
            unfolding in_set_conv_nth
            by auto

          then have Lt : "t1 < h3"
            using strict_order_unfold[OF Cons.prems, of "1 + idx" 0] H1 Cons' True
            by(auto simp add: list_lo_lt)

          show ?thesis using
            strict_order_cons[OF Lt]
            Cons.prems Cons.IH[OF Ord_tl, of k] H1 Cons' Cons'' Cons''' True
            by(auto)
        qed
      qed
    qed
  qed
qed

(*
lift_definition rc_gather :: "('k :: linorder, 'v) recclos \<Rightarrow> 'k \<Rightarrow> ('k, 'v) recclos"
is rc_gather'
(*
  sorry (* can't be bothered to show this now, but it's a rather obvious fact.
           probably need some more generalized induction *)
*)
(* so now (i think) we can just reuse the mergeable instance for oalist *)

(* need a lemma that relates rc_gather to mapping tail over the list of keys *)
proof-
  fix list :: "('k, 'v) recclos'"
  fix k :: "'k"
  assume H : "strict_order (map fst list)"
  show "strict_order (map fst (rc_gather' list k))" using H
  proof(induction list)
    case Nil
    then show ?case by(auto intro: strict_order_nil)
  next
    case (Cons a list)
    obtain kh vh where Hd : "a = (kh, vh)" by(cases a; auto)
    show ?case
    proof(cases kh)
      assume Nil' : "kh = []"
      show ?thesis using Cons Hd Nil' strict_order_tl by auto
    next
      fix khh kht
      assume Cons' : "kh = khh#kht"
      show ?thesis
      proof(cases "k = khh")
        case False
        then show ?thesis using Cons Hd Cons' strict_order_tl by auto
      next
        case True
        then show ?thesis
        proof(cases "map fst (rc_gather' list khh)")
          assume Nil'' : "map fst (rc_gather' list khh) = []"
          then show ?thesis using Cons Hd Cons' True by(auto simp add:strict_order_def)
        next
          fix a2 list2
          assume Cons'' : "map fst (rc_gather' list khh) = (a2#list2)"
          then have A2_in' : "a2 \<in> set (map fst (rc_gather' list khh))" by auto
          then obtain a2v where A2_in : "(a2, a2v) \<in> set (rc_gather' list khh)"
            by(auto)
          have Ord' : "strict_order (map fst list)" using strict_order_tl Cons.prems by auto
          have A2_in_orig : "(khh#a2, a2v) \<in> set list"
            using Cons Hd Cons' True Cons'' rc_gather'_elem[OF Ord' A2_in] by auto
          then obtain a2idx where "a2idx < length list" "list ! a2idx = (khh#a2, a2v)"
            by (auto simp add: List.in_set_conv_nth)
          hence Conc_hd : "kht < a2" using strict_order_unfold[OF Cons.prems(1), of "1 + a2idx" 0] Cons Hd Cons' True Cons''
            by(auto simp add: list_lo_lt)
          then show ?thesis using Cons Hd Cons' True Cons'' Ord' strict_order_cons
            by(auto)
        qed
      qed
    qed
  qed
qed
*)
fun roalist_get' :: "('k :: linorder, 'v, 'd) roalist' \<Rightarrow> 'k \<Rightarrow> ('v + ('d * ('k, 'v, 'd) roalist')) option" where
"roalist_get' r k =
  (case map_of r [k] of
    None \<Rightarrow> None
    | Some (Inl v) \<Rightarrow> Some (Inl v)
    | Some (Inr d) \<Rightarrow> Some (Inr (d, roalist_gather' r k)))"

(* delete a closure *)
fun roalist_delete_clos' :: "('k :: linorder) \<Rightarrow> ('k :: linorder, 'v, 'd) roalist' \<Rightarrow> ('k, 'v, 'd) roalist'" where
"roalist_delete_clos' _ [] = []"
| "roalist_delete_clos' k (([], vh)#t) = ([], vh)#roalist_delete_clos' k t"
| "roalist_delete_clos' k (((khh#kht), vh)#t) =
  (if k = khh then roalist_delete_clos' k t
   else ((khh#kht), vh)# roalist_delete_clos' k t)"

lemma strict_order_singleton :
  "strict_order [x]"
  by(auto simp add:strict_order_def)

lemma strict_order_consE :
  assumes H : "strict_order (h1 # h2 # l)"
  shows "h1 < h2"
  using strict_order_unfold[OF H, of 1 0] by auto

(*
lemma roalist_delete_clos'_elem :
  assumes Hord : "strict_order (map fst l)"
  assumes H : "(k', v) \<in> set (roalist_delete_clos' k l)"
  shows "(k', v) \<in> set l" using Hord H
proof(induction l arbitrary: k v)
  case Nil
  then show ?case by auto
next
  case (Cons a l)
  then have Ord_tl : "strict_order (map fst l)" using strict_order_tl by auto
  obtain k1 v1 where H1 : "(a = (k1, v1))" by (cases a; auto)

  then show ?case
  proof(cases k1)
    assume Nil' : "k1 = []"
    then show ?thesis using Cons H1 Ord_tl by auto
  next
    fix h1 t1
    assume Cons' : "k1 = h1 # t1"
    then show ?thesis
    proof(cases "h1 = k")
      case False
      then show ?thesis using Cons H1 Cons' Ord_tl by(auto)
    next
      case True
      then show ?thesis using Cons.prems Cons.IH[OF Ord_tl] H1 Cons' by(auto)
    qed
  qed
qed

lemma roalist_delete_clos'_elem_contra :
  assumes Hord : "strict_order (map fst l)"
  assumes H : "(kh#kt, v) \<in> set l"
  assumes Hk : "(k \<noteq> kh)"
  shows "(kh#kt, v) \<in> set (roalist_delete_clos' k l)" using Hord H Hk
proof(induction l arbitrary: kh kt k v)
  case Nil
  then show ?case by auto
next
  case (Cons a l)
  then have Ord_tl : "strict_order (map fst l)" using strict_order_tl by auto
  obtain k1 v1 where H1 : "(a = (k1, v1))" by (cases a; auto)
  then show ?case
  proof(cases k1)
    case Nil
    then show ?thesis using Cons H1 Ord_tl by(auto)
  next
    fix h1 t1
    assume Cons' : "k1 = h1 # t1"
    then show ?thesis
    proof(cases "h1 = k")
      case False
      then show ?thesis using Cons H1 Cons' Ord_tl by(auto)
    next
      case True
      then show ?thesis using Cons.prems Cons.IH[OF Ord_tl] H1 Cons' by(auto)
    qed
  qed
qed
*)
(*
lemma roalist_delete_clos'_notelem1 :
  assumes Hord : "strict_order (map fst l)"
  assumes H1 : "(kh'#kt) \<notin> set (map fst (roalist_delete_clos' kh l))"
  assumes H2 : "kh \<noteq> kh'"
  shows "(kh'#kt) \<notin> set (map fst (roalist_delete_clos' kh l))" using Hord H1 H2
proof(induction l arbitrary: kh kh' kt)
  case Nil
  then show ?case  by auto
next
  case (Cons a l')
  then obtain ak av where Akv : "a = (ak, av)" by(cases a; auto)
  have Hord' : "strict_order (map fst l')" using Cons.prems strict_order_tl Akv by auto
  show ?case
  proof(cases ak)
    case Nil
    then show ?thesis using Cons Akv by(auto)
  next
    fix akh akt
    assume Cons' : "ak = akh#akt"
    show ?thesis
    proof(cases "akh = kh")
      case True
      then show ?thesis using Cons.prems Cons.IH[OF Hord'] Cons' Akv by(auto)
    next
      case False
      then show ?thesis using Cons.prems Cons.IH[OF Hord'] Cons' Akv by(auto)
    qed
  qed
qed
*)
(*
lemma roalist_delete_clos'_notelem2 :
  assumes Hord : "strict_order (map fst l)"
  shows "(kh#kt) \<notin> set (map fst (roalist_delete_clos' kh l))" using Hord
proof(induction l arbitrary: kh kt)
  case Nil
  then show ?case by auto
next
  case (Cons h t)
  obtain k1 v1 where Hkv1 : "h = (k1, v1)" by(cases h; auto)
  have Hord' : "strict_order (map fst t)" using strict_order_tl Cons.prems Hkv1 by auto
  then show ?case
  proof(cases "k1")
    case Nil
    then show ?thesis using Cons.IH[OF Hord', of kh kt] Hkv1 by(auto)
  next
    fix k1h k1t
    assume Cons' : "k1 = (k1h # k1t)"
    show ?thesis
    proof(cases "k1h = kh")
      case True
      then show ?thesis using Cons.prems Cons.IH[OF Hord'] Cons' Hkv1 by(auto)
    next
      case False
      then show ?thesis using Cons.prems Cons.IH[OF Hord'] Cons' Hkv1 by(auto)
    qed
  qed
qed
*)

fun roalist_update_v' :: "('key :: linorder) \<Rightarrow> 'value \<Rightarrow> ('key, 'value, 'd) roalist' \<Rightarrow> ('key, 'value, 'd) roalist'" where
"roalist_update_v' k v l =
  str_ord_update [k] (Inl v) (roalist_delete_clos' k l)"

(* unsafe because it doesn't check for presence of a value *)
fun roalist_update_clos_unsafe' :: "('key :: linorder) \<Rightarrow> ('key, 'value, 'd) roalist' \<Rightarrow> ('key, 'value, 'd) roalist' \<Rightarrow> ('key, 'value, 'd) roalist'" where
"roalist_update_clos_unsafe' k [] l = l"
| "roalist_update_clos_unsafe' k ((clkh,clvh)#clt) l =
   str_ord_update (k#clkh) clvh (roalist_update_clos_unsafe' k clt l)"

fun roalist_update_clos' :: "('key :: linorder) \<Rightarrow> 'd \<Rightarrow> ('key, 'value, 'd) roalist' \<Rightarrow> ('key, 'value, 'd) roalist' \<Rightarrow> ('key, 'value, 'd) roalist'"
  where
"roalist_update_clos' k d cl l =
  str_ord_update [k] (Inr d) (roalist_update_clos_unsafe' k cl (roalist_delete_clos' k l))"

(* cannot store a value and a closure at the same key *)

definition roalist_valid :: "('k :: linorder, 'v, 'd) roalist' \<Rightarrow> bool" where
"roalist_valid l =
  ((\<exists> d . map_of l [] = Some (Inr d)) \<and>
   (\<forall> pref v sufh suf . map_of l pref = Some (Inl v) \<longrightarrow>
            map_of l (pref@(sufh#suf)) = None) \<and>
   (\<forall> pref x sufh suf . map_of l (pref@(sufh#suf)) = Some x \<longrightarrow>
            (\<exists> d . map_of l pref = Some (Inr d))))"

lemma roalist_valid_intro :
  assumes H1 : "map_of l [] = Some (Inr x)"
  assumes H2 : "\<And> pref v sufh suf . map_of l pref = Some (Inl v) \<Longrightarrow>
                                    map_of l (pref @ (sufh # suf)) = None"
  assumes H3 : "\<And> pref x sufh suf . map_of l (pref @ sufh # suf) = Some x \<Longrightarrow>
                                    (\<exists> d . map_of l pref = Some (Inr ()))"
  shows "roalist_valid l" using H1 H2 H3 unfolding roalist_valid_def
  by(blast)

(* TODO: bogus *)
typedef (overloaded) ('key, 'value, 'd) roalist =
  "{xs :: (('key :: linorder), 'value, 'd option) roalist' .
       strict_order (map fst xs) \<and> roalist_valid xs}"
  morphisms impl_of Oalist
proof
  show "[([], Inr None)]  \<in>
          { rc :: (('key :: linorder), 'value, 'd option) roalist' . strict_order (map fst rc) \<and> roalist_valid rc }"
    sorry
(*
  have C1: "strict_order (map fst ([([], Inr ())] :: ('key, 'value, 'd) roalist'))"
    by(auto simp add:strict_order_def)
  have C2 : "roalist_valid  ([([], Inr ())] :: ('key, 'value, 'd) roalist')"
  proof(rule roalist_valid_intro)
    show "map_of [([], Inr ())] [] = Some (Inr ())"
      by(auto)
  next
    fix pref suf :: "'key list"
    fix sufh :: "'key"
    fix v :: "'value"
    assume H : "map_of [([], Inr ())] pref = Some (Inl v)"
    show "map_of [([], Inr ())] (pref @ sufh # suf) = None"
      by(auto)
  next
    fix pref suf :: "'key list"
    fix sufh :: "'key"
    fix x :: "'value + unit"
    assume H: "map_of [([], Inr ())] (pref @ sufh # suf) = Some x"
    then show "map_of [([], Inr ())] pref = Some (Inr ())"
      by(auto)
  qed
  show "[([], Inr ())]  \<in>
          { rc :: (('key :: linorder), 'value) roalist' . strict_order (map fst rc) \<and> roalist_valid rc }"
    using C1 C2 by auto
qed
*)
qed

setup_lifting type_definition_roalist
(*
lemma roalist_valid_elim1 :
  assumes Hv : "roalist_valid l"
  shows "map_of l [] = Some (Inr ())"
  using Hv unfolding roalist_valid_def by blast

lemma roalist_valid_elim2 :
  assumes Hv : "roalist_valid l"
  assumes H : "map_of l pref = Some (Inl v)"
  shows "map_of l (pref @ (sufh # suf)) = None"
  using Hv H unfolding roalist_valid_def by blast

lemma roalist_valid_elim3 :
  assumes Hv : "roalist_valid l"
  assumes H : "map_of l (pref @ (sufh#suf)) = Some x"
  shows "map_of l pref = Some (Inr ())"
  using Hv H unfolding roalist_valid_def by blast
*)

(* check if first argument is a prefix of the second *)
fun is_prefix :: "'k list \<Rightarrow> 'k list \<Rightarrow> bool" where
"is_prefix [] _ = True"
| "is_prefix (h#t) [] = False"
| "is_prefix (h1#t1) (h2#t2) =
   (if h1 = h2 then is_prefix t1 t2
    else False)"

lift_definition roalist_gather :: "('k :: linorder, 'v, 'd) roalist \<Rightarrow> 'k \<Rightarrow> ('k, 'v, 'd) roalist"
is roalist_gather' sorry

lift_definition roalist_update_v ::
  "('key :: linorder) \<Rightarrow> 'value \<Rightarrow> ('key, 'value, 'd) roalist \<Rightarrow> ('key, 'value, 'd) roalist"
is roalist_update_v' sorry

lift_definition roalist_update_clos ::
  "('key :: linorder) \<Rightarrow> 'd option \<Rightarrow> ('key, 'value, 'd) roalist \<Rightarrow> ('key, 'value, 'd) roalist \<Rightarrow> ('key, 'value, 'd) roalist"
is roalist_update_clos' sorry
(*
lift_definition roalist_get ::
"('k :: linorder, 'v, 'd) roalist \<Rightarrow> 'k \<Rightarrow> ('v + ('d option * ('k, 'v, 'd) roalist)) option"
is roalist_get' sorry
*)

fun roalist_is_val' :: "('k :: linorder, 'v, 'd) roalist' \<Rightarrow> 'k \<Rightarrow> bool option" where
"roalist_is_val' r k =
  (case map_of r [k] of
    None \<Rightarrow> None
    | Some (Inl _) \<Rightarrow> Some True
    | Some (Inr _) \<Rightarrow> Some False)"

lift_definition roalist_is_val ::
  "('k :: linorder, 'v, 'd) roalist \<Rightarrow> 'k \<Rightarrow> bool option"
is roalist_is_val' .

fun roalist_get_v' :: "('k :: linorder, 'v, 'd) roalist' \<Rightarrow> 'k \<Rightarrow> 'v option" where
"roalist_get_v' l k =
  (case map_of l [k] of
    Some (Inl v) \<Rightarrow> Some v
    | _ \<Rightarrow> None)"

lift_definition roalist_get_v :: "('k :: linorder, 'v, 'd) roalist \<Rightarrow> 'k \<Rightarrow> 'v option"
is roalist_get_v' .

fun roalist_get_d' :: "('k :: linorder, 'v, 'd option) roalist' \<Rightarrow> 'k \<Rightarrow> 'd option" where
"roalist_get_d' l k =
  (case map_of l [k] of
    Some (Inr d) \<Rightarrow> d
    | _ \<Rightarrow> None)"

term "roalist_get_d'"

lift_definition roalist_get_d :: "('k :: linorder, 'v, 'd) roalist \<Rightarrow> 'k \<Rightarrow> 'd option"
is "roalist_get_d' :: ('k :: linorder, 'v, 'd option) roalist' \<Rightarrow> 'k \<Rightarrow> 'd option" .

fun roalist_get :: "('k :: linorder, 'v, 'd) roalist \<Rightarrow> 'k \<Rightarrow>
  ('v + ('d option * ('k, 'v, 'd) roalist)) option"
  where
"roalist_get r k =
  (case roalist_get_v r k of
    Some v \<Rightarrow> Some (Inl v)
    | None \<Rightarrow> Some (Inr( (roalist_get_d r k), (roalist_gather r k))))"

fun roalist_update ::
  "('key :: linorder) \<Rightarrow> ('value + ('key, 'value, 'd) roalist) \<Rightarrow>
        ('key, 'value, 'd) roalist \<Rightarrow> ('key, 'value, 'd) roalist"
  where
"roalist_update k (Inl v) l = roalist_update_v k v l"
| "roalist_update k (Inr c) l =
    (case roalist_get l k of
      Some (Inr (d, _)) \<Rightarrow> roalist_update_clos k d c l
      | _ \<Rightarrow> roalist_update_clos k None c l)"

(* idea
   given a key, make sure there is no value stored in any prefix *)
(* we also need a function to "fill in" missing prefixes
   that is, if there is nothing at a particular prefix, we must add it (?)
    (or, does validity handle this?)
*)
fun roalist_check_prefixes' :: "('key, 'value, 'd) roalist' \<Rightarrow> 'key list \<Rightarrow> bool" where
"roalist_check_prefixes' [] _ = True"
| "roalist_check_prefixes' ((kh, (Inr d))#t) k = roalist_check_prefixes' t k"
| "roalist_check_prefixes' ((kh, (Inl v))#t) k =
   (if is_prefix kh k then False
    else roalist_check_prefixes' t k)"

lift_definition roalist_empty :: "('k :: linorder, 'v, 'd) roalist"
is "[([], Inr None)]"
  by(auto simp add: strict_order_def roalist_valid_def)

fun roalist_map' :: "('k :: linorder list \<Rightarrow> 'v1 \<Rightarrow> 'v2) \<Rightarrow>
                     ('k :: linorder list \<Rightarrow> 'd1 \<Rightarrow> 'd2) \<Rightarrow>
                     ('k :: linorder, 'v1, 'd1 option) roalist' \<Rightarrow>
                     ('k :: linorder, 'v2, 'd2 option) roalist'" where
"roalist_map' fv fd [] = []"
| "roalist_map' fv fd ((kh, Inl vh)#t) =
    ((kh, Inl (fv kh vh))#roalist_map' fv fd t)"
| "roalist_map' fv fd ((kh, Inr None)#t) =
    ((kh, Inr None)# roalist_map' fv fd t)"
| "roalist_map' fv fd ((kh, Inr (Some d))#t) =
    ((kh, Inr (Some (fd kh d)))#roalist_map' fv fd t)"

lift_definition roalist_map ::
"('k :: linorder list \<Rightarrow> 'v1 \<Rightarrow> 'v2) \<Rightarrow>
 ('k :: linorder list \<Rightarrow> 'd1 \<Rightarrow> 'd2) \<Rightarrow>
 ('k :: linorder, 'v1, 'd1) roalist \<Rightarrow>
 ('k :: linorder, 'v2, 'd2) roalist"
is roalist_map' sorry

fun roalist_keys' :: "('k :: linorder, 'v, 'd) roalist' \<Rightarrow>
                      ('k :: linorder) list list" where
"roalist_keys' r = map fst r"

lift_definition roalist_keys :: "('k :: linorder, 'v, 'd) roalist \<Rightarrow>
                                 ('k :: linorder) list list"
is roalist_keys' .

(* problem - need a way of figuring out how to deal with weird cases around
e.g. what if roalist elements at same keys have different value types?
(values vs closures)
etc
*)

(* used in defining liftings for roalist *)
(* idea. we start with a list of values to lift,
   as well as a "current" list of values we are updating.
   this works like map2, except that
   if we ever encounter a type mismatch or key mismatch,
   we use a default value instead *)
(*
proving correctness could end up being annoying
*)
(* this has been moved to LiftInstances, since it is
easier to express in terms of liftings *)
(*
fun roalist_fuse2_safe' ::
"('k :: linorder list \<Rightarrow> 'v1 \<Rightarrow> 'v2 \<Rightarrow> 'v2) \<Rightarrow>
 ('k :: linorder list \<Rightarrow> 'd1 \<Rightarrow> 'd2 \<Rightarrow> 'd2) \<Rightarrow>
                     ('k :: linorder, 'v1, 'd1 option) roalist' \<Rightarrow>
                     ('k :: linorder, 'v2, 'd2 option) roalist' \<Rightarrow>
                     ('k :: linorder, 'v2, 'd2 option) roalist'" where
"roalist_fuse2_safe' fv fd [] [] = Some []"
| "roalist_map2_safe' fv fd ((kh1, Inl vh1)#t1) ((kh2, Inl vh2)#t2) =
  (if kh1 = kh2 then
    (case roalist_map2_safe' fv fd t1 t2 of
     Some t3 \<Rightarrow> Some ((kh1, Inl (fv kh1 vh1 vh2))#t3)
     | _ \<Rightarrow> None)
   else None)"
| "roalist_map2_safe' fv fd ((kh1, Inr None)#t1) ((kh2, Inr None)#t2) =
    (if kh1 = kh2 then
      (case roalist_map2_safe' fv fd t1 t2 of
       Some t3 \<Rightarrow> Some ((kh1, Inr None)#t3)
       | _ \<Rightarrow> None)
    else None)"
| "roalist_map2_safe' fv fd ((kh1, Inr (Some dh1))#t1) ((kh2, Inr (Some dh2))#t2) =
    (if kh1 = kh2 then
      (case roalist_map2_safe' fv fd t1 t2 of
       Some t3 \<Rightarrow> Some ((kh1, Inr (Some (fd kh1 dh1 dh2)))#t3)
       | _ \<Rightarrow> None)
    else None)"
| "roalist_map2_safe' _ _ _ _ = None"

lift_definition roalist_map2_safe ::
"('k :: linorder list \<Rightarrow> 'v1 \<Rightarrow> 'v2 \<Rightarrow> 'v3) \<Rightarrow>
 ('k :: linorder list \<Rightarrow> 'd1 \<Rightarrow> 'd2 \<Rightarrow> 'd3) \<Rightarrow>
 ('k :: linorder, 'v1, 'd1) roalist \<Rightarrow>
 ('k :: linorder, 'v2, 'd2) roalist \<Rightarrow>
 ('k :: linorder, 'v3, 'd3) roalist option"
is roalist_map2_safe'
  apply(simp add: pred_option_def set_option_def)
*)

end