section \<open>Generation of Verification Conditions\<close>

theory OG_Tactics
imports OG_Hoare
begin

lemmas ann_hoare_intros=AnnBasic AnnSeq AnnCond1 AnnCond2 AnnWhile AnnAwait AnnConseq
lemmas oghoare_intros=Parallel Basic Seq Cond While Conseq

lemma ParallelConseqRule:
 "\<lbrakk> p \<subseteq> (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts ! i))));
  \<parallel>- (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts ! i))))
      (Parallel Ts)
     (\<Inter>i\<in>{i. i<length Ts}. post(Ts ! i));
  (\<Inter>i\<in>{i. i<length Ts}. post(Ts ! i)) \<subseteq> q \<rbrakk>
  \<Longrightarrow> \<parallel>- p (Parallel Ts) q"
apply (rule Conseq)
prefer 2
 apply fast
apply assumption+
done

lemma SkipRule: "p \<subseteq> q \<Longrightarrow> \<parallel>- p (Basic id) q"
apply(rule oghoare_intros)
  prefer 2 apply(rule Basic)
 prefer 2 apply(rule subset_refl)
apply(simp add:Id_def)
done

lemma BasicRule: "p \<subseteq> {s. (f s)\<in>q} \<Longrightarrow> \<parallel>- p (Basic f) q"
apply(rule oghoare_intros)
  prefer 2 apply(rule oghoare_intros)
 prefer 2 apply(rule subset_refl)
apply assumption
done

lemma SeqRule: "\<lbrakk> \<parallel>- p c1 r; \<parallel>- r c2 q \<rbrakk> \<Longrightarrow> \<parallel>- p (Seq c1 c2) q"
apply(rule Seq)
apply fast+
done

lemma CondRule:
 "\<lbrakk> p \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>w) \<and> (s\<notin>b \<longrightarrow> s\<in>w')}; \<parallel>- w c1 q; \<parallel>- w' c2 q \<rbrakk>
  \<Longrightarrow> \<parallel>- p (Cond b c1 c2) q"
apply(rule Cond)
 apply(rule Conseq)
 prefer 4 apply(rule Conseq)
apply simp_all
apply force+
done

lemma WhileRule: "\<lbrakk> p \<subseteq> i; \<parallel>- (i \<inter> b) c i ; (i \<inter> (-b)) \<subseteq> q \<rbrakk>
        \<Longrightarrow> \<parallel>- p (While b i c) q"
apply(rule Conseq)
 prefer 2 apply(rule While)
apply assumption+
done

text \<open>Three new proof rules for special instances of the \<open>AnnBasic\<close> and the \<open>AnnAwait\<close> commands when the transformation
performed on the state is the identity, and for an \<open>AnnAwait\<close>
command where the boolean condition is \<open>{s. True}\<close>:\<close>

lemma AnnatomRule:
  "\<lbrakk> atom_com(c); \<parallel>- r c q \<rbrakk>  \<Longrightarrow> \<turnstile> (AnnAwait r {s. True} c) q"
apply(rule AnnAwait)
apply simp_all
done

lemma AnnskipRule:
  "r \<subseteq> q \<Longrightarrow> \<turnstile> (AnnBasic r id) q"
apply(rule AnnBasic)
apply simp
done

lemma AnnwaitRule:
  "\<lbrakk> (r \<inter> b) \<subseteq> q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnAwait r b (Basic id)) q"
apply(rule AnnAwait)
 apply simp
apply(rule BasicRule)
apply simp
done

text \<open>Lemmata to avoid using the definition of \<open>map_ann_hoare\<close>, \<open>interfree_aux\<close>, \<open>interfree_swap\<close> and
\<open>interfree\<close> by splitting it into different cases:\<close>

lemma interfree_aux_rule1: "interfree_aux(co, q, None)"
by(simp add:interfree_aux_def)

lemma interfree_aux_rule2:
  "\<forall>(R,r)\<in>(atomics a). \<parallel>- (q \<inter> R) r q \<Longrightarrow> interfree_aux(None, q, Some a)"
apply(simp add:interfree_aux_def)
apply(force elim:oghoare_sound)
done

lemma interfree_aux_rule3:
  "(\<forall>(R, r)\<in>(atomics a). \<parallel>- (q \<inter> R) r q \<and> (\<forall>p\<in>(assertions c). \<parallel>- (p \<inter> R) r p))
  \<Longrightarrow> interfree_aux(Some c, q, Some a)"
apply(simp add:interfree_aux_def)
apply(force elim:oghoare_sound)
done

lemma AnnBasic_assertions:
  "\<lbrakk>interfree_aux(None, r, Some a); interfree_aux(None, q, Some a)\<rbrakk> \<Longrightarrow>
    interfree_aux(Some (AnnBasic r f), q, Some a)"
apply(simp add: interfree_aux_def)
by force

lemma AnnSeq_assertions:
  "\<lbrakk> interfree_aux(Some c1, q, Some a); interfree_aux(Some c2, q, Some a)\<rbrakk>\<Longrightarrow>
   interfree_aux(Some (AnnSeq c1 c2), q, Some a)"
apply(simp add: interfree_aux_def)
by force

lemma AnnCond1_assertions:
  "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(Some c1, q, Some a);
  interfree_aux(Some c2, q, Some a)\<rbrakk>\<Longrightarrow>
  interfree_aux(Some(AnnCond1 r b c1 c2), q, Some a)"
apply(simp add: interfree_aux_def)
by force

lemma AnnCond2_assertions:
  "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(Some c, q, Some a)\<rbrakk>\<Longrightarrow>
  interfree_aux(Some (AnnCond2 r b c), q, Some a)"
apply(simp add: interfree_aux_def)
by force

lemma AnnWhile_assertions:
  "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(None, i, Some a);
  interfree_aux(Some c, q, Some a)\<rbrakk>\<Longrightarrow>
  interfree_aux(Some (AnnWhile r b i c), q, Some a)"
apply(simp add: interfree_aux_def)
by force

lemma AnnAwait_assertions:
  "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(None, q, Some a)\<rbrakk>\<Longrightarrow>
  interfree_aux(Some (AnnAwait r b c), q, Some a)"
apply(simp add: interfree_aux_def)
by force

lemma AnnBasic_atomics:
  "\<parallel>- (q \<inter> r) (Basic f) q \<Longrightarrow> interfree_aux(None, q, Some (AnnBasic r f))"
by(simp add: interfree_aux_def oghoare_sound)

lemma AnnSeq_atomics:
  "\<lbrakk> interfree_aux(Any, q, Some a1); interfree_aux(Any, q, Some a2)\<rbrakk>\<Longrightarrow>
  interfree_aux(Any, q, Some (AnnSeq a1 a2))"
apply(simp add: interfree_aux_def)
by force

lemma AnnCond1_atomics:
  "\<lbrakk> interfree_aux(Any, q, Some a1); interfree_aux(Any, q, Some a2)\<rbrakk>\<Longrightarrow>
   interfree_aux(Any, q, Some (AnnCond1 r b a1 a2))"
apply(simp add: interfree_aux_def)
by force

lemma AnnCond2_atomics:
  "interfree_aux (Any, q, Some a)\<Longrightarrow> interfree_aux(Any, q, Some (AnnCond2 r b a))"
by(simp add: interfree_aux_def)

lemma AnnWhile_atomics: "interfree_aux (Any, q, Some a)
     \<Longrightarrow> interfree_aux(Any, q, Some (AnnWhile r b i a))"
by(simp add: interfree_aux_def)

lemma Annatom_atomics:
  "\<parallel>- (q \<inter> r) a q \<Longrightarrow> interfree_aux (None, q, Some (AnnAwait r {x. True} a))"
by(simp add: interfree_aux_def oghoare_sound)

lemma AnnAwait_atomics:
  "\<parallel>- (q \<inter> (r \<inter> b)) a q \<Longrightarrow> interfree_aux (None, q, Some (AnnAwait r b a))"
by(simp add: interfree_aux_def oghoare_sound)

definition interfree_swap :: "('a ann_triple_op * ('a ann_triple_op) list) \<Rightarrow> bool" where
  "interfree_swap == \<lambda>(x, xs). \<forall>y\<in>set xs. interfree_aux (com x, post x, com y)
  \<and> interfree_aux(com y, post y, com x)"

lemma interfree_swap_Empty: "interfree_swap (x, [])"
by(simp add:interfree_swap_def)

lemma interfree_swap_List:
  "\<lbrakk> interfree_aux (com x, post x, com y);
  interfree_aux (com y, post y ,com x); interfree_swap (x, xs) \<rbrakk>
  \<Longrightarrow> interfree_swap (x, y#xs)"
by(simp add:interfree_swap_def)

lemma interfree_swap_Map: "\<forall>k. i\<le>k \<and> k<j \<longrightarrow> interfree_aux (com x, post x, c k)
 \<and> interfree_aux (c k, Q k, com x)
 \<Longrightarrow> interfree_swap (x, map (\<lambda>k. (c k, Q k)) [i..<j])"
by(force simp add: interfree_swap_def less_diff_conv)

lemma interfree_Empty: "interfree []"
by(simp add:interfree_def)

lemma interfree_List:
  "\<lbrakk> interfree_swap(x, xs); interfree xs \<rbrakk> \<Longrightarrow> interfree (x#xs)"
apply(simp add:interfree_def interfree_swap_def)
apply clarify
apply(case_tac i)
 apply(case_tac j)
  apply simp_all
apply(case_tac j,simp+)
done

lemma interfree_Map:
  "(\<forall>i j. a\<le>i \<and> i<b \<and> a\<le>j \<and> j<b  \<and> i\<noteq>j \<longrightarrow> interfree_aux (c i, Q i, c j))
  \<Longrightarrow> interfree (map (\<lambda>k. (c k, Q k)) [a..<b])"
by(force simp add: interfree_def less_diff_conv)

definition map_ann_hoare :: "(('a ann_com_op * 'a assn) list) \<Rightarrow> bool " ("[\<turnstile>] _" [0] 45) where
  "[\<turnstile>] Ts == (\<forall>i<length Ts. \<exists>c q. Ts!i=(Some c, q) \<and> \<turnstile> c q)"

lemma MapAnnEmpty: "[\<turnstile>] []"
by(simp add:map_ann_hoare_def)

lemma MapAnnList: "\<lbrakk> \<turnstile> c q ; [\<turnstile>] xs \<rbrakk> \<Longrightarrow> [\<turnstile>] (Some c,q)#xs"
apply(simp add:map_ann_hoare_def)
apply clarify
apply(case_tac i,simp+)
done

lemma MapAnnMap:
  "\<forall>k. i\<le>k \<and> k<j \<longrightarrow> \<turnstile> (c k) (Q k) \<Longrightarrow> [\<turnstile>] map (\<lambda>k. (Some (c k), Q k)) [i..<j]"
apply(simp add: map_ann_hoare_def less_diff_conv)
done

lemma ParallelRule:"\<lbrakk> [\<turnstile>] Ts ; interfree Ts \<rbrakk>
  \<Longrightarrow> \<parallel>- (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts!i))))
          Parallel Ts
        (\<Inter>i\<in>{i. i<length Ts}. post(Ts!i))"
apply(rule Parallel)
 apply(simp add:map_ann_hoare_def)
apply simp
done
(*
lemma ParamParallelRule:
 "\<lbrakk> \<forall>k<n. \<turnstile> (c k) (Q k);
   \<forall>k l. k<n \<and> l<n  \<and> k\<noteq>l \<longrightarrow> interfree_aux (Some(c k), Q k, Some(c l)) \<rbrakk>
  \<Longrightarrow> \<parallel>- (\<Inter>i\<in>{i. i<n} . pre(c i)) COBEGIN SCHEME [0\<le>i<n] (c i) (Q i) COEND  (\<Inter>i\<in>{i. i<n} . Q i )"
apply(rule ParallelConseqRule)
  apply simp
  apply clarify
  apply force
 apply(rule ParallelRule)
  apply(rule MapAnnMap)
  apply simp
 apply(rule interfree_Map)
 apply simp
apply simp
apply clarify
apply force
done
*)

text \<open>The following are some useful lemmas and simplification
tactics to control which theorems are used to simplify at each moment,
so that the original input does not suffer any unexpected
transformation.\<close>

lemma Compl_Collect: "-(Collect b) = {x. \<not>(b x)}"
  by fast

lemma list_length: "length []=0" "length (x#xs) = Suc(length xs)"
  by simp_all
lemma list_lemmas: "length []=0" "length (x#xs) = Suc(length xs)"
    "(x#xs) ! 0 = x" "(x#xs) ! Suc n = xs ! n"
  by simp_all
lemma le_Suc_eq_insert: "{i. i <Suc n} = insert n {i. i< n}"
  by auto
lemmas primrecdef_list = "pre.simps" "assertions.simps" "atomics.simps" "atom_com.simps"
lemmas my_simp_list = list_lemmas fst_conv snd_conv
not_less0 refl le_Suc_eq_insert Suc_not_Zero Zero_not_Suc nat.inject
Collect_mem_eq ball_simps option.simps primrecdef_list
lemmas ParallelConseq_list = INTER_eq Collect_conj_eq length_map length_upt length_append

ML \<open>
fun before_interfree_simp_tac ctxt =
  simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm com.simps}, @{thm post.simps}])

fun interfree_simp_tac ctxt =
  asm_simp_tac (put_simpset HOL_ss ctxt
    addsimps [@{thm split}, @{thm ball_Un}, @{thm ball_empty}] @ @{thms my_simp_list})

fun ParallelConseq ctxt =
  simp_tac (put_simpset HOL_basic_ss ctxt
    addsimps @{thms ParallelConseq_list} @ @{thms my_simp_list})
\<close>

text \<open>The following tactic applies \<open>tac\<close> to each conjunct in a
subgoal of the form \<open>A \<Longrightarrow> a1 \<and> a2 \<and> .. \<and> an\<close>  returning
\<open>n\<close> subgoals, one for each conjunct:\<close>

ML \<open>
fun conjI_Tac ctxt tac i st = st |>
       ( (EVERY [resolve_tac ctxt [conjI] i,
          conjI_Tac ctxt tac (i+1),
          tac i]) ORELSE (tac i) )
\<close>

subsubsection \<open>Tactic for the generation of the verification conditions\<close>

text \<open>The tactic basically uses two subtactics:

\begin{description}

\item[HoareRuleTac] is called at the level of parallel programs, it
 uses the ParallelTac to solve parallel composition of programs.
 This verification has two parts, namely, (1) all component programs are
 correct and (2) they are interference free.  \<open>HoareRuleTac\<close> is
 also called at the level of atomic regions, i.e.  \<open>\<langle> \<rangle>\<close> and
 \<open>AWAIT b THEN _ END\<close>, and at each interference freedom test.

\item[AnnHoareRuleTac] is for component programs which
 are annotated programs and so, there are not unknown assertions
 (no need to use the parameter precond, see NOTE).

 NOTE: precond(::bool) informs if the subgoal has the form \<open>\<parallel>- ?p c q\<close>,
 in this case we have precond=False and the generated  verification
 condition would have the form \<open>?p \<subseteq> \<dots>\<close> which can be solved by
 \<open>rtac subset_refl\<close>, if True we proceed to simplify it using
 the simplification tactics above.

\end{description}
\<close>

ML \<open>

fun WlpTac ctxt i = resolve_tac ctxt @{thms SeqRule} i THEN HoareRuleTac ctxt false (i + 1)
and HoareRuleTac ctxt precond i st = st |>
    ( (WlpTac ctxt i THEN HoareRuleTac ctxt precond i)
      ORELSE
      (FIRST[resolve_tac ctxt @{thms SkipRule} i,
             resolve_tac ctxt @{thms BasicRule} i,
             EVERY[resolve_tac ctxt @{thms ParallelConseqRule} i,
                   ParallelConseq ctxt (i+2),
                   ParallelTac ctxt (i+1),
                   ParallelConseq ctxt i],
             EVERY[resolve_tac ctxt @{thms CondRule} i,
                   HoareRuleTac ctxt false (i+2),
                   HoareRuleTac ctxt false (i+1)],
             EVERY[resolve_tac ctxt @{thms WhileRule} i,
                   HoareRuleTac ctxt true (i+1)],
             K all_tac i ]
       THEN (if precond then (K all_tac i) else resolve_tac ctxt @{thms subset_refl} i)))

and AnnWlpTac ctxt i = resolve_tac ctxt @{thms AnnSeq} i THEN AnnHoareRuleTac ctxt (i + 1)
and AnnHoareRuleTac ctxt i st = st |>
    ( (AnnWlpTac ctxt i THEN AnnHoareRuleTac ctxt i )
     ORELSE
      (FIRST[(resolve_tac ctxt @{thms AnnskipRule} i),
             EVERY[resolve_tac ctxt @{thms AnnatomRule} i,
                   HoareRuleTac ctxt true (i+1)],
             (resolve_tac ctxt @{thms AnnwaitRule} i),
             resolve_tac ctxt @{thms AnnBasic} i,
             EVERY[resolve_tac ctxt @{thms AnnCond1} i,
                   AnnHoareRuleTac ctxt (i+3),
                   AnnHoareRuleTac ctxt (i+1)],
             EVERY[resolve_tac ctxt @{thms AnnCond2} i,
                   AnnHoareRuleTac ctxt (i+1)],
             EVERY[resolve_tac ctxt @{thms AnnWhile} i,
                   AnnHoareRuleTac ctxt (i+2)],
             EVERY[resolve_tac ctxt @{thms AnnAwait} i,
                   HoareRuleTac ctxt true (i+1)],
             K all_tac i]))

and ParallelTac ctxt i = EVERY[resolve_tac ctxt @{thms ParallelRule} i,
                          interfree_Tac ctxt (i+1),
                           MapAnn_Tac ctxt i]

and MapAnn_Tac ctxt i st = st |>
    (FIRST[resolve_tac ctxt @{thms MapAnnEmpty} i,
           EVERY[resolve_tac ctxt @{thms MapAnnList} i,
                 MapAnn_Tac ctxt (i+1),
                 AnnHoareRuleTac ctxt i],
           EVERY[resolve_tac ctxt @{thms MapAnnMap} i,
                 resolve_tac ctxt @{thms allI} i,
                 resolve_tac ctxt @{thms impI} i,
                 AnnHoareRuleTac ctxt i]])

and interfree_swap_Tac ctxt i st = st |>
    (FIRST[resolve_tac ctxt @{thms interfree_swap_Empty} i,
           EVERY[resolve_tac ctxt @{thms interfree_swap_List} i,
                 interfree_swap_Tac ctxt (i+2),
                 interfree_aux_Tac ctxt (i+1),
                 interfree_aux_Tac ctxt i ],
           EVERY[resolve_tac ctxt @{thms interfree_swap_Map} i,
                 resolve_tac ctxt @{thms allI} i,
                 resolve_tac ctxt @{thms impI} i,
                 conjI_Tac ctxt (interfree_aux_Tac ctxt) i]])

and interfree_Tac ctxt i st = st |>
   (FIRST[resolve_tac ctxt @{thms interfree_Empty} i,
          EVERY[resolve_tac ctxt @{thms interfree_List} i,
                interfree_Tac ctxt (i+1),
                interfree_swap_Tac ctxt i],
          EVERY[resolve_tac ctxt @{thms interfree_Map} i,
                resolve_tac ctxt @{thms allI} i,
                resolve_tac ctxt @{thms allI} i,
                resolve_tac ctxt @{thms impI} i,
                interfree_aux_Tac ctxt i ]])

and interfree_aux_Tac ctxt i = (before_interfree_simp_tac ctxt i ) THEN
        (FIRST[resolve_tac ctxt @{thms interfree_aux_rule1} i,
               dest_assertions_Tac ctxt i])

and dest_assertions_Tac ctxt i st = st |>
    (FIRST[EVERY[resolve_tac ctxt @{thms AnnBasic_assertions} i,
                 dest_atomics_Tac ctxt (i+1),
                 dest_atomics_Tac ctxt i],
           EVERY[resolve_tac ctxt @{thms AnnSeq_assertions} i,
                 dest_assertions_Tac ctxt (i+1),
                 dest_assertions_Tac ctxt i],
           EVERY[resolve_tac ctxt @{thms AnnCond1_assertions} i,
                 dest_assertions_Tac ctxt (i+2),
                 dest_assertions_Tac ctxt (i+1),
                 dest_atomics_Tac ctxt i],
           EVERY[resolve_tac ctxt @{thms AnnCond2_assertions} i,
                 dest_assertions_Tac ctxt (i+1),
                 dest_atomics_Tac ctxt i],
           EVERY[resolve_tac ctxt @{thms AnnWhile_assertions} i,
                 dest_assertions_Tac ctxt (i+2),
                 dest_atomics_Tac ctxt (i+1),
                 dest_atomics_Tac ctxt i],
           EVERY[resolve_tac ctxt @{thms AnnAwait_assertions} i,
                 dest_atomics_Tac ctxt (i+1),
                 dest_atomics_Tac ctxt i],
           dest_atomics_Tac ctxt i])

and dest_atomics_Tac ctxt i st = st |>
    (FIRST[EVERY[resolve_tac ctxt @{thms AnnBasic_atomics} i,
                 HoareRuleTac ctxt true i],
           EVERY[resolve_tac ctxt @{thms AnnSeq_atomics} i,
                 dest_atomics_Tac ctxt (i+1),
                 dest_atomics_Tac ctxt i],
           EVERY[resolve_tac ctxt @{thms AnnCond1_atomics} i,
                 dest_atomics_Tac ctxt (i+1),
                 dest_atomics_Tac ctxt i],
           EVERY[resolve_tac ctxt @{thms AnnCond2_atomics} i,
                 dest_atomics_Tac ctxt i],
           EVERY[resolve_tac ctxt @{thms AnnWhile_atomics} i,
                 dest_atomics_Tac ctxt i],
           EVERY[resolve_tac ctxt @{thms Annatom_atomics} i,
                 HoareRuleTac ctxt true i],
           EVERY[resolve_tac ctxt @{thms AnnAwait_atomics} i,
                 HoareRuleTac ctxt true i],
                 K all_tac i])
\<close>

text \<open>The final tactic is given the name \<open>oghoare\<close>:\<close>

ML \<open>
fun oghoare_tac ctxt = SUBGOAL (fn (_, i) => HoareRuleTac ctxt true i)
\<close>

text \<open>Notice that the tactic for parallel programs \<open>oghoare_tac\<close> is initially invoked with the value \<open>true\<close> for
the parameter \<open>precond\<close>.

Parts of the tactic can be also individually used to generate the
verification conditions for annotated sequential programs and to
generate verification conditions out of interference freedom tests:\<close>

ML \<open>
fun annhoare_tac ctxt = SUBGOAL (fn (_, i) => AnnHoareRuleTac ctxt i)

fun interfree_aux_tac ctxt = SUBGOAL (fn (_, i) => interfree_aux_Tac ctxt i)
\<close>

text \<open>The so defined ML tactics are then ``exported'' to be used in
Isabelle proofs.\<close>

method_setup oghoare = \<open>
  Scan.succeed (SIMPLE_METHOD' o oghoare_tac)\<close>
  "verification condition generator for the oghoare logic"

method_setup annhoare = \<open>
  Scan.succeed (SIMPLE_METHOD' o annhoare_tac)\<close>
  "verification condition generator for the ann_hoare logic"

method_setup interfree_aux = \<open>
  Scan.succeed (SIMPLE_METHOD' o interfree_aux_tac)\<close>
  "verification condition generator for interference freedom tests"

text \<open>Tactics useful for dealing with the generated verification conditions:\<close>

method_setup conjI_tac = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (conjI_Tac ctxt (K all_tac)))\<close>
  "verification condition generator for interference freedom tests"

ML \<open>
fun disjE_Tac ctxt tac i st = st |>
       ( (EVERY [eresolve_tac ctxt [disjE] i,
          disjE_Tac ctxt tac (i+1),
          tac i]) ORELSE (tac i) )
\<close>

method_setup disjE_tac = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (disjE_Tac ctxt (K all_tac)))\<close>
  "verification condition generator for interference freedom tests"

end


theory IMP_Minus_Minus_Subprograms_Nat
  imports Primitives IMP_Minus_Minus_Subprograms
begin

fun map_all_subprograms:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_all_subprograms c n = (if n =0 then 0 else ( 2## (hd_nat n) ## c ## 0) ## map_all_subprograms c (tl_nat n) )"

lemma submap_all_subprograms:
"map_all_subprograms c n = map_nat (\<lambda>x. 2## x ## c ## 0) n"
  apply (induct c n rule: map_all_subprograms.induct)
  apply auto
  done

fun map_all_subprograms_acc:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_all_subprograms_acc  c acc n = (if n =0 then acc else
map_all_subprograms_acc c (( 2## (hd_nat n) ## c ## 0) ## acc) (tl_nat n) )"

lemma  map_all_subprograms_induct:
" map_all_subprograms_acc c acc n = map_acc  (\<lambda>x. 2## x ## c ## 0) acc n"
  apply(induct c acc n rule:map_all_subprograms_acc.induct)
  apply auto
  done

definition map_all_subprograms_tail :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_all_subprograms_tail c n = reverse_nat (map_all_subprograms_acc c 0 n)"

lemma subtail_map_all_subprograms:
"map_all_subprograms_tail c n = map_all_subprograms c n"
  using submap_all_subprograms map_all_subprograms_tail_def  map_all_subprograms_induct[of c 0 n]
  subtail_map by presburger

datatype all_sub = Bot  "com list" |
                   SKIP|
                   Assign vname bit |
                   Seq_0 com com|
                   Seq_m com com "com list"|
                   Seq_f com com "com list" "com list"|
                   If_0 "vname list" com com |
                   If_m  "vname list" com com "com list"|
                   If_f  "vname list" com com "com list" "com list"|
                   While_0  "vname list" com |
                   While_f  "vname list" com "com list"

fun all_sub_encode :: "all_sub \<Rightarrow> nat" where
"all_sub_encode SKIP = list_encode [0] "|
"all_sub_encode (Assign v b) = list_encode [1, vname_encode v, bit_encode b]"|
"all_sub_encode (Seq_0 c1 c2) = list_encode[2 , comm_encode c1 , comm_encode c2]"|
"all_sub_encode (If_0 v c1 c2) = list_encode [3, vname_list_encode v, comm_encode c1, comm_encode c2]"|
"all_sub_encode (While_0 v c) = list_encode [4,vname_list_encode v, comm_encode c]"|
"all_sub_encode (Seq_m  c1 c2 c3) = list_encode[5, comm_encode c1 ,comm_encode c2, list_encode (map comm_encode c3) ]"|
"all_sub_encode (Seq_f c1 c2 c3 c4) = list_encode [6, comm_encode c1 ,comm_encode c2 , list_encode (map comm_encode c3) , list_encode (map comm_encode c4)]"|
"all_sub_encode (If_m v c1 c2 c3) = list_encode[7, vname_list_encode v, comm_encode c1 ,comm_encode c2, list_encode (map comm_encode c3)]"|
"all_sub_encode (If_f v c1 c2 c3 c4) = list_encode [8, vname_list_encode v, comm_encode c1, comm_encode c2, list_encode (map comm_encode c3), list_encode (map comm_encode c4)]"|
"all_sub_encode (While_f v c c') = list_encode [9, vname_list_encode v, comm_encode c, list_encode (map comm_encode c')]"|
"all_sub_encode (Bot x) = list_encode [10, list_encode (map comm_encode x)]"

fun push_stack :: "com \<Rightarrow> all_sub list \<Rightarrow> all_sub list" where
"push_stack com.SKIP s = SKIP#s "|
"push_stack (com.Assign v b) s = Assign v b # s"|
"push_stack (com.Seq c1 c2) s = Seq_0 c1 c2 # s"|
"push_stack (com.If v c1 c2) s = If_0 v c1 c2 # s"|
"push_stack (com.While v c) s = While_0 v c #s"

fun push_stack_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"push_stack_nat c s = (c ##s )"

lemma sub_push_stack:
"push_stack_nat (comm_encode c) (list_encode (map all_sub_encode s))
= list_encode (map all_sub_encode (push_stack c s))"
  apply( cases c)
  apply (auto simp add: sub_cons simp del: list_encode.simps)
  done

lemma push_stack_not_Nil:
"push_stack c s \<noteq> []"
  apply(cases c)
      apply auto
  done

fun add_res :: "com list \<Rightarrow> all_sub list \<Rightarrow> all_sub list" where
"add_res c [] = [Bot c] "|
"add_res c (Seq_0 c1 c2 # s) = Seq_m c1 c2 c #s "|
"add_res c (Seq_m c1 c2 c3 # s) = Seq_f c1 c2 c3 c # s"|
"add_res c (If_0 v c1 c2 # s) = If_m v c1 c2 c # s "|
"add_res c (If_m v c1 c2 c3 #s) = If_f v c1 c2 c3 c # s"|
"add_res c (While_0 v c'#s) = While_f v c' c # s"|
"add_res c s = s"

lemma add_res_not_Nil:
"add_res c s \<noteq> []"
  apply(cases s)
   apply auto
  subgoal for a xs
    apply (cases a)
    apply auto
    done
  done

fun add_res_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add_res_nat c s = (if s =0 then (10##c##0)##0 else
(let h = hd_nat s; con = hd_nat h ; fs = nth_nat (Suc 0) h ; sn = nth_nat (Suc (Suc 0)) h;
       th = nth_nat (Suc (Suc (Suc 0))) h; ft = nth_nat (Suc (Suc (Suc (Suc 0)))) h; t = tl_nat s in
    if con = 2 then (5## fs ## sn ## c ## 0) ## t
else if con = 5 then(6 ## fs ## sn ## th ## c ## 0) ## t
else if con = 3 then (7 ## fs ## sn ## th ## c ## 0) ## t
else if con = 7 then (8 ## fs ## sn ## th ## ft ## c ## 0)## t
else if con = 4 then (9 ## fs ## sn ## c ## 0) ## t else s
  ))"

lemma sub_add_res:
"add_res_nat (list_encode (map comm_encode c)) (list_encode  (map all_sub_encode s))
= list_encode (map all_sub_encode (add_res c s))"
  apply (cases s)
   apply (simp add: cons0 sub_cons  flip: list_encode.simps)
  subgoal for a xs
    apply(cases a)
       apply (auto simp add:cons0 sub_cons list_encode_eq sub_hd sub_tl  simp flip: list_encode.simps)
                   apply(auto simp add: Let_def sub_hd sub_tl simp flip: list_encode.simps(2))
    done
  done

function (sequential, domintros) all_subprograms_stack :: "all_sub list \<Rightarrow> com list" where
"all_subprograms_stack (Bot x#s) = x"|
"all_subprograms_stack (SKIP # s) = all_subprograms_stack (add_res  [com.SKIP] s )"|
"all_subprograms_stack (Assign v b # s) = all_subprograms_stack (add_res [(com.Assign v b), com.SKIP] s )"|
"all_subprograms_stack (Seq_0 c1 c2 # s) = all_subprograms_stack (push_stack c1 (Seq_0 c1 c2 # s) )"|
"all_subprograms_stack (Seq_m c1 c2 c3 # s) = all_subprograms_stack (push_stack c2 (Seq_m c1 c2 c3 # s))"|
"all_subprograms_stack (Seq_f c1 c2 c3 c4 #s) = all_subprograms_stack (add_res ((map (\<lambda> c. c ;; c2) c3 ) @ c3
  @ c4) s) "|
"all_subprograms_stack (If_0 v c1 c2 # s) = all_subprograms_stack (push_stack c1 (If_0 v c1 c2 # s))"|
"all_subprograms_stack (If_m v c1 c2 c3 # s) = all_subprograms_stack (push_stack c2 (If_m v c1 c2 c3 # s)) "|
"all_subprograms_stack (If_f v c1 c2 c3 c4 # s) = all_subprograms_stack (add_res (
[(com.If v c1 c2)] @ c3 @ c4 ) s )"|
"all_subprograms_stack (While_0 v c # s) = all_subprograms_stack (push_stack c (While_0 v c # s) )"|
"all_subprograms_stack (While_f v c c' # s) = all_subprograms_stack (add_res ([(While v c), com.SKIP] @ c' @
  (map (\<lambda> x. x ;; (While v c))  c')) s)"
  by pat_completeness auto
termination sorry

function all_subprograms_stack_nat :: "nat  \<Rightarrow> nat" where
"all_subprograms_stack_nat s = (let h = hd_nat s; con = hd_nat h ; fs = nth_nat (Suc 0) h ; sn = nth_nat (Suc (Suc 0)) h;
       th = nth_nat (Suc (Suc (Suc 0))) h; ft = nth_nat (Suc (Suc (Suc (Suc 0)))) h; v = nth_nat (Suc (Suc (Suc (Suc (Suc 0))))) h;  t = tl_nat s in
if con = 10 then  fs else
if con = 0 then  all_subprograms_stack_nat (add_res_nat  ((0##0)##0) t ) else
if con = 1 then  all_subprograms_stack_nat (add_res_nat   (h##(0##0)##0)  t ) else
if con = 2 then all_subprograms_stack_nat (push_stack_nat fs s) else
if con = 5 then all_subprograms_stack_nat (push_stack_nat sn s) else
if con = 6 then all_subprograms_stack_nat (add_res_nat (append_nat ( append_nat (map_all_subprograms_tail sn th ) th
  ) ft) t) else
if con = 3 then all_subprograms_stack_nat (push_stack_nat sn s) else
if con = 7 then all_subprograms_stack_nat (push_stack_nat th s) else
if con = 8 then all_subprograms_stack_nat (add_res_nat (append_nat ((3##fs##sn##th##0)## ft )v) t) else
if con = 4 then all_subprograms_stack_nat (push_stack_nat sn s) else
all_subprograms_stack_nat (add_res_nat ((4##fs##sn##0) ## (0##0) ## append_nat th (map_all_subprograms_tail (4##fs##sn##0) th)) t)
) "
  sorry
termination sorry

lemma map_singleton:
"[f x] = map f [x]" by auto
lemma sub_all_programs_stack:
"s \<noteq> [] \<Longrightarrow> all_subprograms_stack_nat (list_encode (map all_sub_encode s))
 = list_encode (map comm_encode (all_subprograms_stack s))"
  apply (cases s)
   apply simp
  subgoal  for a xs
    apply(induct s  arbitrary : a xs rule:all_subprograms_stack.induct)
    using push_stack_not_Nil add_res_not_Nil   apply (auto simp only:)
              apply (subst all_subprograms_stack_nat.simps)
   apply (simp add: Let_def sub_nth sub_hd sub_cons
              del: all_subprograms_stack_nat.simps
                list_encode.simps nth_nat.simps add_res_nat.simps push_stack.simps )
   apply (subst all_subprograms_stack_nat.simps)
   apply (simp add: Let_def sub_nth sub_hd sub_cons sub_tl  cons0
              del: all_subprograms_stack_nat.simps
                list_encode.simps nth_nat.simps add_res_nat.simps push_stack.simps )
             apply(simp only:  add_res.simps sub_add_res map_singleton[of comm_encode]  flip: comm_encode.simps list.map )
    apply (metis neq_Nil_conv)
 apply (subst all_subprograms_stack_nat.simps)
   apply (simp add: Let_def sub_nth sub_hd sub_cons sub_tl  cons0
              del: all_subprograms_stack_nat.simps
                list_encode.simps nth_nat.simps add_res_nat.simps push_stack.simps )
             apply(simp only:  add_res.simps sub_add_res map_singleton[of comm_encode]  flip: One_nat_def comm_encode.simps list.map )
    apply (metis neq_Nil_conv)
     apply (subst all_subprograms_stack_nat.simps)
   apply (simp add: Let_def sub_nth sub_hd sub_cons sub_tl  cons0
              del: all_subprograms_stack_nat.simps
                list_encode.simps nth_nat.simps add_res_nat.simps push_stack_nat.simps )
             apply(simp only:  sub_push_stack   flip: One_nat_def all_sub_encode.simps list.map )
           apply (metis list.exhaust)
  apply (subst all_subprograms_stack_nat.simps)
   apply (simp add: Let_def sub_nth sub_hd sub_cons sub_tl  cons0
              del: all_subprograms_stack_nat.simps
                list_encode.simps nth_nat.simps add_res_nat.simps push_stack_nat.simps )
          apply(simp only:  sub_push_stack   flip: One_nat_def all_sub_encode.simps list.map )
               apply (metis list.exhaust)
 apply (subst all_subprograms_stack_nat.simps)
   apply (simp add: Let_def sub_nth sub_hd sub_cons sub_tl  cons0
              del: all_subprograms_stack_nat.simps
                list_encode.simps nth_nat.simps add_res_nat.simps push_stack_nat.simps )
         apply(simp only: subtail_map_all_subprograms submap_all_subprograms
        sub_map sub_append map_map comp_def sub_cons cons0
  add_res.simps sub_add_res  flip: One_nat_def comm_encode.simps list.map )
    apply (simp only: sub_add_res flip: map_append comp_def[of comm_encode "\<lambda>x. (com.Seq x  _ )"] map_map)
         apply (metis append.assoc neq_Nil_conv)
  apply (subst all_subprograms_stack_nat.simps)
   apply (simp add: Let_def sub_nth sub_hd sub_cons sub_tl  cons0
              del: all_subprograms_stack_nat.simps
                list_encode.simps nth_nat.simps add_res_nat.simps push_stack_nat.simps )
          apply(simp only:  sub_push_stack   flip: One_nat_def all_sub_encode.simps list.map )
        apply (metis list.exhaust)
  apply (subst all_subprograms_stack_nat.simps)
   apply (simp add: Let_def sub_nth sub_hd sub_cons sub_tl  cons0
              del: all_subprograms_stack_nat.simps
                list_encode.simps nth_nat.simps add_res_nat.simps push_stack_nat.simps )
          apply(simp only:  sub_push_stack   flip: One_nat_def all_sub_encode.simps list.map )
       apply (metis list.exhaust)
 apply (subst all_subprograms_stack_nat.simps)
   apply (simp add: Let_def sub_nth sub_hd sub_cons sub_tl  cons0
              del: all_subprograms_stack_nat.simps
                list_encode.simps nth_nat.simps add_res_nat.simps push_stack_nat.simps )
         apply(simp only: subtail_map_all_subprograms submap_all_subprograms
        sub_map sub_append map_map comp_def sub_cons cons0
  add_res.simps sub_add_res  flip: One_nat_def comm_encode.simps list.map map_append)
      apply (metis append_Cons neq_Nil_conv)
  apply (subst all_subprograms_stack_nat.simps)
   apply (simp add: Let_def sub_nth sub_hd sub_cons sub_tl  cons0
              del: all_subprograms_stack_nat.simps
                list_encode.simps nth_nat.simps add_res_nat.simps push_stack_nat.simps )
          apply(simp only:  sub_push_stack   flip: One_nat_def all_sub_encode.simps list.map )
     apply (metis list.exhaust)
 apply (subst all_subprograms_stack_nat.simps)
   apply (simp add: Let_def sub_nth sub_hd sub_cons sub_tl  cons0
              del: all_subprograms_stack_nat.simps
                list_encode.simps nth_nat.simps add_res_nat.simps push_stack_nat.simps )
         apply(simp only: subtail_map_all_subprograms submap_all_subprograms
        sub_map sub_append map_map comp_def sub_cons cons0
  add_res.simps sub_add_res  flip: One_nat_def comm_encode.simps list.map map_append)
    apply (simp only: sub_add_res flip: comp_def [of comm_encode "\<lambda>x. (com.Seq x  (com.While _ _))" ]
          map_map map_append list.map )
    apply (metis list.exhaust)
    done
  done

lemma all_subprograms_stack_correct:
"all_subprograms_stack (push_stack c s) = all_subprograms_stack (add_res (all_subprograms c) s)"
  apply (induct c arbitrary: s )
      apply auto
  done

definition all_subprograms_t :: "com \<Rightarrow> com list" where
"all_subprograms_t c = all_subprograms_stack (push_stack c [] )"

definition all_subprograms_nat :: "nat \<Rightarrow> nat" where
"all_subprograms_nat c = all_subprograms_stack_nat (push_stack_nat c 0)"

lemma subtailnat_all_subprograms:
"all_subprograms_nat (comm_encode c) = list_encode (map comm_encode (all_subprograms_t c))"
  by (metis all_subprograms_nat_def all_subprograms_t_def list.simps(8) list_encode.simps(1)
 push_stack_not_Nil sub_all_programs_stack sub_push_stack)

lemma sub_all_subprograms_t:
"all_subprograms_t c = all_subprograms c"
  by (simp add: all_subprograms_stack_correct all_subprograms_t_def)

lemma sub_all_subprograms:
 "all_subprograms_nat (comm_encode c) = list_encode(map comm_encode (all_subprograms c))"
  by (simp add: sub_all_subprograms_t subtailnat_all_subprograms)

definition all_subprograms_tail :: "nat \<Rightarrow> nat" where
"all_subprograms_tail c = all_subprograms_nat c"

lemma subtail_all_subprograms:
"all_subprograms_tail c = all_subprograms_nat c"
  by (simp add: all_subprograms_tail_def)

definition enumerate_subprograms_nat :: "nat \<Rightarrow>nat" where
"enumerate_subprograms_nat c = remdups_nat (all_subprograms_nat c)"

definition enumerate_subprograms_tail :: "nat \<Rightarrow>nat" where
"enumerate_subprograms_tail c = remdups_tail (all_subprograms_tail c)"

lemma subtail_enumerate_subprograms:
"enumerate_subprograms_tail c = enumerate_subprograms_nat c"
  using all_subprograms_tail_def enumerate_subprograms_nat_def
enumerate_subprograms_tail_def subtail_remdups by auto

lemma sub_enumerate_subprograms:
"enumerate_subprograms_nat (comm_encode c) = list_encode (map comm_encode (enumerate_subprograms c))"
  using comm_inj
  apply (auto simp only: enumerate_subprograms_nat_def enumerate_subprograms_def remdups_map sub_all_subprograms sub_remdups list_encode_eq)
  done

fun all_variables_nat :: "nat \<Rightarrow>nat" where
"all_variables_nat n = (if n=0 \<or> hd_nat n =0 \<or> hd_nat n =2  then 0 else
if hd_nat n = 1 then (nth_nat (Suc 0) n) ## 0 else
nth_nat (Suc 0) n )"

definition all_variables_tail where "all_variables_tail = all_variables_nat"

lemma subtail_all_variables : "all_variables_tail = all_variables_nat" using  all_variables_tail_def by meson

lemma sub_all_variables: "all_variables_nat (comm_encode c) = vname_list_encode (all_variables c)"
  apply (cases c)
      apply (auto simp only:all_variables_nat.simps sub_hd comm_encode.simps head.simps
              vname_list_encode_def cons0 sub_cons sub_nth nth.simps)
      apply auto
  done

fun map_all_variables:: "nat \<Rightarrow> nat" where
"map_all_variables n = (if n =0 then 0 else (all_variables_nat (hd_nat n)) ## map_all_variables (tl_nat n) )"

fun map_all_variables_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_all_variables_acc acc n = (if n =0 then acc else map_all_variables_acc ((all_variables_tail (hd_nat n)) ## acc) (tl_nat n) )"

lemma submap_all_variables:
"map_all_variables n = map_nat all_variables_nat n"
  apply (induct n rule:map_all_variables.induct)
  apply auto
  done
lemma  map_all_variables_induct:
" map_all_variables_acc acc n = map_acc all_variables_nat acc n"
  apply(induct acc n rule: map_all_variables_acc.induct)
  apply (auto simp add: subtail_all_variables )
  done

definition map_all_variables_tail :: "nat \<Rightarrow> nat" where
" map_all_variables_tail n = reverse_nat (map_all_variables_acc 0 n)"

lemma subtail_map_all_variables:
" map_all_variables_tail n  =  map_all_variables n "
  using map_all_variables_tail_def  map_all_variables_induct[of 0 n]
  submap_all_variables subtail_map by presburger

definition enumerate_variables_nat :: "nat \<Rightarrow> nat" where
"enumerate_variables_nat c =
     remdups_nat (concat_nat (map_all_variables (enumerate_subprograms_nat c)))"

definition enumerate_variables_tail :: "nat \<Rightarrow> nat" where
"enumerate_variables_tail c =
     remdups_tail (concat_tail (map_all_variables_tail (enumerate_subprograms_tail c)))"

lemma subtail_enumerate_variables:
"enumerate_variables_tail c = enumerate_variables_nat c "
  by (simp add: enumerate_variables_nat_def enumerate_variables_tail_def subtail_concat
subtail_enumerate_subprograms subtail_map_all_variables subtail_remdups)

lemma sub_enumerate_variables:
  "enumerate_variables_nat (comm_encode c) = vname_list_encode ( enumerate_variables c)"
  apply
   (simp only:  submap_all_variables enumerate_variables_nat_def enumerate_variables_def sub_enumerate_subprograms
                sub_map  map_map)
  apply (simp only: comp_def)
  apply (simp only: sub_all_variables)
  apply (simp only: flip:comp_def)
  apply (simp only: flip:map_map)
  apply (simp only: vname_list_encode_as_comp)
  apply (simp only: flip:map_map)
  using vname_inj
  apply (simp only: sub_concat sub_remdups comp_apply map_concat flip:remdups_map )
  done

end


section {* ICF-setup for Automatic Refinement *}
theory ICF_Autoref
imports
  ICF_Refine_Monadic
  "../GenCF/Intf/Intf_Set"
  "../GenCF/Intf/Intf_Map"
begin

subsection {* Unique Priority Queue *}
consts i_prio :: "interface \<Rightarrow> interface \<Rightarrow> interface"
definition [simp]: "op_uprio_empty \<equiv> Map.empty"
definition [simp]: "op_uprio_is_empty x \<equiv> x = Map.empty"
definition [simp]: "op_uprio_insert s e a \<equiv> s(e \<mapsto> a)"
definition op_uprio_prio :: "('e\<rightharpoonup>'a)\<Rightarrow>'e\<rightharpoonup>'a"
  where [simp]: "op_uprio_prio s e \<equiv> s e"

(* FIXME: Tune id-op phase such that it can distinguish those patterns!
  For now: Only include this patterns on demand!
*)
context begin interpretation autoref_syn .

lemma uprio_pats:
  fixes s :: "'e\<rightharpoonup>'a"
  shows
  "Map.empty::'e\<rightharpoonup>'a \<equiv> op_uprio_empty"
  "s e \<equiv> op_uprio_prio$s$e"
  "s(e\<mapsto>a) \<equiv> op_uprio_insert$s$e$a"

  "dom s = {} \<equiv> op_uprio_is_empty$s"
  "{} = dom s \<equiv> op_uprio_is_empty$s"
  "s=Map.empty \<equiv> op_uprio_is_empty$s"
  "Map.empty=s \<equiv> op_uprio_is_empty$s"
  by (auto intro!: eq_reflection)

end

term prio_pop_min

lemma [autoref_itype]:
  "op_uprio_empty ::\<^sub>i \<langle>Ie,Ia\<rangle>\<^sub>ii_prio"
  "op_uprio_prio ::\<^sub>i \<langle>Ie,Ia\<rangle>\<^sub>ii_prio \<rightarrow>\<^sub>i Ie \<rightarrow>\<^sub>i \<langle>Ia\<rangle>\<^sub>ii_option"
  "op_uprio_is_empty ::\<^sub>i \<langle>Ie,Ia\<rangle>\<^sub>ii_prio \<rightarrow>\<^sub>i i_bool"
  "op_uprio_insert ::\<^sub>i \<langle>Ie,Ia\<rangle>\<^sub>ii_prio \<rightarrow>\<^sub>i Ie \<rightarrow>\<^sub>i Ia \<rightarrow>\<^sub>i \<langle>Ie,Ia\<rangle>\<^sub>ii_prio"
  "prio_pop_min ::\<^sub>i \<langle>Ie,Ia\<rangle>\<^sub>ii_prio \<rightarrow>\<^sub>i \<langle>\<langle>Ie,\<langle>Ia,\<langle>Ie,Ia\<rangle>\<^sub>ii_prio\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_nres"
  by simp_all

context uprio begin
  definition rel_def_internal:
    "rel Re Ra \<equiv> br \<alpha> invar O (Re \<rightarrow> \<langle>Ra\<rangle> option_rel)"
  lemma rel_def:
    "\<langle>Re,Ra\<rangle>rel \<equiv> br \<alpha> invar O (Re \<rightarrow> \<langle>Ra\<rangle> option_rel)"
    by (simp add: rel_def_internal relAPP_def)

  lemma rel_sv[relator_props]:
    "\<lbrakk>Range Re = UNIV; single_valued Ra\<rbrakk> \<Longrightarrow> single_valued (\<langle>Re,Ra\<rangle>rel)"
    unfolding rel_def by tagged_solver

  lemmas [autoref_rel_intf] = REL_INTFI[of rel i_prio]
end

lemma (in uprio) rel_alt: "\<langle>Id,Rv\<rangle>rel =
  { (c,a). \<forall>x. (\<alpha> c x,a x)\<in>\<langle>Rv\<rangle>option_rel \<and> invar c }"
  by (auto simp: rel_def br_def dest: fun_relD)

lemma (in uprio_empty) autoref_empty[autoref_rules]:
  "PREFER_id Re \<Longrightarrow> (empty (),op_uprio_empty)\<in>\<langle>Re,Ra\<rangle>rel"
  by (auto simp: empty_correct rel_alt)

lemma (in uprio_isEmpty) autoref_is_empty[autoref_rules]:
  "PREFER_id Re \<Longrightarrow> (isEmpty,op_uprio_is_empty)\<in>\<langle>Re,Ra\<rangle>rel\<rightarrow>bool_rel"
  by (auto simp: isEmpty_correct rel_alt intro!: ext)

lemma (in uprio_prio) autoref_prio[autoref_rules]:
  "PREFER_id Re \<Longrightarrow> (prio,op_uprio_prio)\<in>\<langle>Re,Ra\<rangle>rel\<rightarrow>Re\<rightarrow>\<langle>Ra\<rangle>option_rel"
  by (auto simp: prio_correct rel_alt intro!: ext)

lemma (in uprio_insert) autoref_insert[autoref_rules]:
  "PREFER_id Re \<Longrightarrow> (insert,op_uprio_insert)\<in>\<langle>Re,Ra\<rangle>rel\<rightarrow>Re\<rightarrow>Ra\<rightarrow>\<langle>Re,Ra\<rangle>rel"
  by (auto simp: insert_correct rel_alt intro!: ext)

lemma (in uprio_pop) autoref_prio_pop_min[autoref_rules]:
  "\<lbrakk>PREFER_id Re; PREFER_id Ra \<rbrakk>
  \<Longrightarrow> (\<lambda>s. RETURN (pop s),prio_pop_min)\<in>\<langle>Re,Ra\<rangle>rel\<rightarrow>\<langle>\<langle>Re,\<langle>Ra,\<langle>Re,Ra\<rangle>rel\<rangle>prod_rel\<rangle>prod_rel\<rangle>nres_rel"
  apply simp
  apply (intro fun_relI nres_relI)
  by (rule prio_pop_min_refine)

context set begin
  definition rel_def_internal: "rel R \<equiv> br \<alpha> invar O \<langle>R\<rangle>set_rel"
  lemma rel_def: "\<langle>R\<rangle>rel \<equiv> br \<alpha> invar O \<langle>R\<rangle>set_rel"
    by (simp add: rel_def_internal relAPP_def)

  lemma rel_id[simp]: "\<langle>Id\<rangle>rel = br \<alpha> invar" by (simp add: rel_def)

  lemma rel_sv[relator_props]: "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>rel)"
    unfolding rel_def by tagged_solver

  lemmas [autoref_rel_intf] = REL_INTFI[of rel i_set]

end

context map begin
  definition rel_def_internal:
    "rel Rk Rv \<equiv> br \<alpha> invar O (Rk \<rightarrow> \<langle>Rv\<rangle> option_rel)"
  lemma rel_def:
    "\<langle>Rk,Rv\<rangle>rel \<equiv> br \<alpha> invar O (Rk \<rightarrow> \<langle>Rv\<rangle> option_rel)"
    by (simp add: rel_def_internal relAPP_def)

  lemma rel_id[simp]: "\<langle>Id,Id\<rangle>rel = br \<alpha> invar"
    by (simp add: rel_def)

  lemma rel_sv[relator_props]:
    "\<lbrakk>Range Rk = UNIV; single_valued Rv\<rbrakk> \<Longrightarrow> single_valued (\<langle>Rk,Rv\<rangle>rel)"
    unfolding rel_def
    by (tagged_solver (trace))

  lemmas [autoref_rel_intf] = REL_INTFI[of rel i_map]

end

(*
context list begin
  definition rel_def_internal:
    "rel R \<equiv> br \<alpha> invar O R"
  lemma rel_def: "\<langle>R\<rangle>rel \<equiv> br \<alpha> invar O R"
    by (simp add: rel_def_internal relAPP_def)

  lemma rel_id[simp]: "\<langle>Id\<rangle>rel = br \<alpha> invar"
    by (simp add: rel_def)

  lemma rel_sv[relator_props]: "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>rel)"
    unfolding rel_def by refine_post
end

context al begin
  definition rel_def_internal:
    "rel Re Ra \<equiv> br \<alpha> invar O \<langle>\<langle>Re,Ra\<rangle> prod_rel\<rangle>list_rel"
  lemma rel_def:
    "\<langle>Re,Ra\<rangle>rel \<equiv> br \<alpha> invar O \<langle>\<langle>Re,Ra\<rangle> prod_rel\<rangle>list_rel"
    by (simp add: rel_def_internal relAPP_def)

  lemma rel_id[simp]: "\<langle>Id,Id\<rangle>rel = br \<alpha> invar"
    by (simp add: rel_def)

  lemma rel_sv[relator_props]:
    "\<lbrakk>single_valued Re; single_valued Ra\<rbrakk> \<Longrightarrow> single_valued (\<langle>Re,Ra\<rangle>rel)"
    unfolding rel_def by refine_post

end

context prio begin
  (* TODO: Fix that to use multiset_rel! *)
  definition rel_def[simp]: "rel \<equiv> br \<alpha> invar"
  lemma rel_sv: "single_valued rel" unfolding rel_def by refine_post
end

context uprio begin
  definition rel_def_internal:
    "rel Re Ra \<equiv> br \<alpha> invar O (Re \<rightarrow> \<langle>Ra\<rangle> option_rel)"
  lemma rel_def:
    "\<langle>Re,Ra\<rangle>rel \<equiv> br \<alpha> invar O (Re \<rightarrow> \<langle>Ra\<rangle> option_rel)"
    by (simp add: rel_def_internal relAPP_def)

  lemma rel_id[simp]: "\<langle>Id,Id\<rangle>rel = br \<alpha> invar"
    by (simp add: rel_def)

  lemma rel_sv[relator_props]:
    "\<lbrakk>Range Re = UNIV; single_valued Ra\<rbrakk> \<Longrightarrow> single_valued (\<langle>Re,Ra\<rangle>rel)"
    unfolding rel_def by refine_post

end
*)

setup {* Revert_Abbrev.revert_abbrev "Autoref_Binding_ICF.*.rel" *}

(* TODO: Move *)
lemma Collect_x_x_pairs_rel_image[simp]: "{p. \<exists>x. p = (x, x)}``x = x"
    by auto

subsection "Set"

lemma (in set_empty) empty_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (empty (), {}) \<in> \<langle>Rk\<rangle>rel"
  by (simp add: br_def empty_correct)

lemma (in set_memb) memb_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (memb,op \<in>)\<in>Rk\<rightarrow>\<langle>Rk\<rangle>rel\<rightarrow>Id"
  apply simp
  by (auto simp add: memb_correct br_def)

lemma (in set_ins) ins_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (ins,Set.insert)\<in>Rk\<rightarrow>\<langle>Rk\<rangle>rel\<rightarrow>\<langle>Rk\<rangle>rel"
  by simp (auto simp add: ins_correct br_def)

context set_ins_dj begin
context begin interpretation autoref_syn .
lemma ins_dj_autoref[autoref_rules]:
  assumes "SIDE_PRECOND_OPT (x'\<notin>s')"
  assumes "PREFER_id Rk"
  assumes "(x,x')\<in>Rk"
  assumes "(s,s')\<in>\<langle>Rk\<rangle>rel"
  shows "(ins_dj x s,(OP Set.insert ::: Rk \<rightarrow> \<langle>Rk\<rangle>rel \<rightarrow> \<langle>Rk\<rangle>rel)$x'$s')\<in>\<langle>Rk\<rangle>rel"
  using assms
  apply simp
  apply (auto simp add: ins_dj_correct br_def)
  done
end
end

lemma (in set_delete) delete_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (delete,op_set_delete)\<in>Rk\<rightarrow>\<langle>Rk\<rangle>rel\<rightarrow>\<langle>Rk\<rangle>rel"
  by simp (auto simp add: delete_correct op_set_delete_def br_def)

lemma (in set_isEmpty) isEmpty_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (isEmpty,op_set_isEmpty) \<in> \<langle>Rk\<rangle>rel\<rightarrow>Id"
  apply (simp add: br_def)
  apply (fastforce simp: isEmpty_correct)
  done

lemma (in set_isSng) isSng_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (isSng,op_set_isSng) \<in> \<langle>Rk\<rangle>rel\<rightarrow>Id"
  by simp
    (auto simp add: isSng_correct op_set_isSng_def br_def card_Suc_eq)

lemma (in set_ball) ball_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (ball,Set.Ball) \<in> \<langle>Rk\<rangle>rel\<rightarrow>(Rk\<rightarrow>Id)\<rightarrow>Id"
  by simp (auto simp add: ball_correct fun_rel_def br_def)

lemma (in set_bex) bex_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (bex,Set.Bex) \<in> \<langle>Rk\<rangle>rel\<rightarrow>(Rk\<rightarrow>Id)\<rightarrow>Id"
  apply simp
  apply (auto simp: bex_correct fun_rel_def br_def intro!: ext)
  done

lemma (in set_size) size_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (size,card) \<in> \<langle>Rk\<rangle>rel \<rightarrow> Id"
  by simp (auto simp add: size_correct br_def)

lemma (in set_size_abort) size_abort_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (size_abort,op_set_size_abort) \<in> Id \<rightarrow> \<langle>Rk\<rangle>rel \<rightarrow> Id"
  by simp
    (auto simp add: size_abort_correct op_set_size_abort_def br_def)

lemma (in set_union) union_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (union,op \<union>)\<in>\<langle>Rk\<rangle>s1.rel\<rightarrow>\<langle>Rk\<rangle>s2.rel\<rightarrow>\<langle>Rk\<rangle>s3.rel"
  by simp (auto simp add: union_correct br_def)

context set_union_dj begin
context begin interpretation autoref_syn .

lemma union_dj_autoref[autoref_rules]:
  assumes "PREFER_id Rk"
  assumes "SIDE_PRECOND_OPT (a'\<inter>b'={})"
  assumes "(a,a')\<in>\<langle>Rk\<rangle>s1.rel"
  assumes "(b,b')\<in>\<langle>Rk\<rangle>s2.rel"
  shows "(union_dj a b,(OP op \<union> ::: \<langle>Rk\<rangle>s1.rel \<rightarrow> \<langle>Rk\<rangle>s2.rel \<rightarrow> \<langle>Rk\<rangle>s3.rel)$a'$b')
    \<in>\<langle>Rk\<rangle>s3.rel"
  using assms
  by simp (auto simp: union_dj_correct br_def)
end
end

lemma (in set_diff) diff_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (diff,op -)\<in>\<langle>Rk\<rangle>s1.rel\<rightarrow>\<langle>Rk\<rangle>s2.rel\<rightarrow>\<langle>Rk\<rangle>s1.rel"
  by simp (auto simp add: diff_correct br_def)

lemma (in set_filter) filter_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (filter,op_set_filter)\<in>(Rk \<rightarrow> Id) \<rightarrow> \<langle>Rk\<rangle>s1.rel\<rightarrow>\<langle>Rk\<rangle>s2.rel"
  by simp (auto simp add: filter_correct op_set_filter_def fun_rel_def
    br_def)

lemma (in set_inter) inter_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (inter,op \<inter>)\<in>\<langle>Rk\<rangle>s1.rel\<rightarrow>\<langle>Rk\<rangle>s2.rel\<rightarrow>\<langle>Rk\<rangle>s3.rel"
  by simp (auto simp add: inter_correct br_def)

lemma (in set_subset) subset_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (subset,op \<subseteq>)\<in>\<langle>Rk\<rangle>s1.rel\<rightarrow>\<langle>Rk\<rangle>s2.rel\<rightarrow>Id"
  by simp (auto simp add: subset_correct br_def)

lemma (in set_equal) equal_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (equal,op =)\<in>\<langle>Rk\<rangle>s1.rel\<rightarrow>\<langle>Rk\<rangle>s2.rel\<rightarrow>Id"
  by simp (auto simp add: equal_correct br_def)

lemma (in set_disjoint) disjoint_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (disjoint,op_set_disjoint)\<in>\<langle>Rk\<rangle>s1.rel\<rightarrow>\<langle>Rk\<rangle>s2.rel\<rightarrow>Id"
  by simp (auto simp add: disjoint_correct op_set_disjoint_def br_def)

lemma (in list_to_set) to_set_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (to_set,set)\<in>\<langle>Rk\<rangle>list_rel \<rightarrow> \<langle>Rk\<rangle>rel"
  apply simp
  apply (auto simp add: to_set_correct br_def)
  done

context set_sel' begin
context begin interpretation autoref_syn .

lemma autoref_op_set_pick[autoref_rules]:
  assumes "SIDE_PRECOND (s'\<noteq>{})"
  assumes "PREFER_id Rk"
  assumes "(s,s')\<in>\<langle>Rk\<rangle>rel"
  shows "(RETURN (the (sel' s (\<lambda>_. True))),
          (OP op_set_pick ::: \<langle>Rk\<rangle>rel \<rightarrow> \<langle>Rk\<rangle>nres_rel) $ s')
    \<in> \<langle>Rk\<rangle>nres_rel"
  using assms
  apply (clarsimp simp add: br_def nres_rel_def ex_in_conv[symmetric])
  apply (erule (1) sel'E[OF _ _ TrueI])
  apply (auto intro: RES_refine)
  done
end
end

lemma (in poly_set_iteratei) proper[proper_it]:
  "proper_it' iteratei iteratei"
  apply (rule proper_it'I)
  by (rule pi_iteratei)

lemma (in poly_set_iteratei) autoref_iteratei[autoref_ga_rules]:
  "REL_IS_ID Rk \<Longrightarrow> is_set_to_list Rk rel (it_to_list iteratei)"
  unfolding is_set_to_list_def is_set_to_sorted_list_def it_to_list_def
    it_to_sorted_list_def
  apply (simp add: br_def, intro allI impI)
  apply (drule iteratei_correct)
  unfolding set_iterator_def set_iterator_genord_foldli_conv
  apply (elim exE)
  apply clarsimp
  apply (drule fun_cong[where x="\<lambda>_::'x list. True"])
  apply simp
  done

lemma (in poly_set_iterateoi) proper_o[proper_it]:
  "proper_it' iterateoi iterateoi"
  apply (rule proper_it'I)
  by (rule pi_iterateoi)

lemma (in poly_set_rev_iterateoi) autoref_rev_iterateoi[autoref_ga_rules]:
  "REL_IS_ID Rk \<Longrightarrow>
    is_set_to_sorted_list op \<ge> Rk rel (it_to_list rev_iterateoi)"
  unfolding is_set_to_sorted_list_def it_to_list_def it_to_sorted_list_def
  apply (simp add: br_def, intro allI impI)
  apply (drule rev_iterateoi_correct)
  unfolding set_iterator_rev_linord_def set_iterator_genord_foldli_conv
  apply (elim exE)
  apply clarsimp
  apply (drule fun_cong[where x="\<lambda>_::'x list. True"])
  apply simp
  done

lemma (in poly_set_rev_iterateoi) proper_ro[proper_it]:
  "proper_it' rev_iterateoi rev_iterateoi"
  apply (rule proper_it'I)
  by (rule pi_rev_iterateoi)

subsection "Map"

lemma (in map) rel_alt: "\<langle>Id,Rv\<rangle>rel =
  { (c,a). \<forall>x. (\<alpha> c x,a x)\<in>\<langle>Rv\<rangle>option_rel \<and> invar c }"
  by (auto simp: rel_def br_def dest: fun_relD)

lemma (in map_empty) empty_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (empty (),op_map_empty)\<in>\<langle>Rk,Rv\<rangle>rel"
  by (auto simp: empty_correct rel_alt)

lemma (in map_lookup) lookup_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (lookup,op_map_lookup)\<in>Rk\<rightarrow>\<langle>Rk,Rv\<rangle>rel\<rightarrow>\<langle>Rv\<rangle>option_rel"
  apply (intro fun_relI option_relI)
  apply (auto simp: lookup_correct rel_alt
    dest: fun_relD2)
  done

lemma (in map_update) update_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (update,op_map_update)\<in>Rk\<rightarrow>Rv\<rightarrow>\<langle>Rk,Rv\<rangle>rel\<rightarrow>\<langle>Rk,Rv\<rangle>rel"
  apply (intro fun_relI)
  apply (simp add: update_correct rel_alt)
  done

context map_update_dj begin
context begin interpretation autoref_syn .

lemma update_dj_autoref[autoref_rules]:
  assumes "SIDE_PRECOND_OPT (k'\<notin>dom m')"
  assumes "PREFER_id Rk"
  assumes "(k,k')\<in>Rk"
  assumes "(v,v')\<in>Rv"
  assumes "(m,m')\<in>\<langle>Rk,Rv\<rangle>rel"
  shows "(update_dj k v m,
    (OP op_map_update ::: Rk \<rightarrow> Rv \<rightarrow> \<langle>Rk,Rv\<rangle>rel \<rightarrow> \<langle>Rk,Rv\<rangle>rel)$k'$v'$m'
  )\<in>\<langle>Rk,Rv\<rangle>rel"
  using assms
  apply (subgoal_tac "k\<notin>dom (\<alpha> m)")
  apply (simp add: update_dj_correct rel_alt)
  apply (auto simp add: rel_alt option_rel_def)
  apply (metis option.simps(3))
  done
end
end

lemma (in map_delete) delete_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (delete,op_map_delete)\<in>Rk\<rightarrow>\<langle>Rk,Rv\<rangle>rel\<rightarrow>\<langle>Rk,Rv\<rangle>rel"
  apply (intro fun_relI)
  apply (simp add: delete_correct restrict_map_def rel_alt)
  done

lemma (in map_restrict) restrict_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow>
    (restrict,op_map_restrict)
    \<in> (\<langle>Rk,Rv\<rangle>prod_rel \<rightarrow> Id) \<rightarrow> \<langle>Rk,Rv\<rangle>m1.rel \<rightarrow> \<langle>Rk,Rv\<rangle>m2.rel"
  apply (intro fun_relI)
  apply (simp add: restrict_correct br_comp_alt m1.rel_def m2.rel_def )
  apply (intro fun_relI)
  apply (auto simp: restrict_map_def split: split_if_asm)
  apply (drule (1) fun_relD1)
  apply (auto simp: option_rel_def) []
  apply (drule (1) fun_relD1)
  apply (auto simp: option_rel_def) []
  apply (drule (1) fun_relD1)
  apply (auto simp: option_rel_def prod_rel_def fun_rel_def) []
  apply (drule (1) fun_relD2)
  apply (auto simp: option_rel_def prod_rel_def fun_rel_def) []
  done

lemma (in map_add) add_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (add,op ++)\<in>\<langle>Rk,Rv\<rangle>rel\<rightarrow>\<langle>Rk,Rv\<rangle>rel\<rightarrow>\<langle>Rk,Rv\<rangle>rel"
  apply (auto simp add: add_correct rel_alt Map.map_add_def
    split: option.split)
  apply (drule_tac x=x in spec)+
  apply simp
  apply (metis option.simps(3) option_rel_simp(2))
  by (metis (lifting) option_rel_simp(3))

context map_add_dj begin
context begin interpretation autoref_syn .

lemma add_dj_autoref[autoref_rules]:
  assumes "PREFER_id Rk"
  assumes "SIDE_PRECOND_OPT (dom a' \<inter> dom b' = {})"
  assumes "(a,a')\<in>\<langle>Rk,Rv\<rangle>rel"
  assumes "(b,b')\<in>\<langle>Rk,Rv\<rangle>rel"
  shows "(add_dj a b, (OP op ++ ::: \<langle>Rk,Rv\<rangle>rel \<rightarrow> \<langle>Rk,Rv\<rangle>rel \<rightarrow> \<langle>Rk,Rv\<rangle>rel) $ a' $ b')\<in>\<langle>Rk,Rv\<rangle>rel"
  using assms
  apply simp
  apply (subgoal_tac "dom (\<alpha> a) \<inter> dom (\<alpha> b) = {}")
  apply (clarsimp simp add: add_dj_correct rel_def br_comp_alt)
  apply (auto
    simp add: rel_def br_comp_alt Map.map_add_def
    split: option.split
    elim: fun_relE1 dest: fun_relD1 intro: option_relI
  ) []

  apply (clarsimp simp add: rel_def br_comp_alt)

  apply (auto simp: dom_def)
  apply (drule (1) fun_relD1)
  apply (drule (1) fun_relD1)
  apply (auto simp: option_rel_def)
  done
end
end

lemma (in map_isEmpty) isEmpty_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (isEmpty,op_map_isEmpty)\<in>\<langle>Rk,Rv\<rangle>rel\<rightarrow>Id"
  by (auto simp: isEmpty_correct rel_alt
    intro!: ext)

lemma sngI:
  assumes "m k = Some v"
  assumes "\<forall>k'. k'\<noteq>k \<longrightarrow> m k' = None"
  shows "m = [k\<mapsto>v]"
  using assms
  by (auto intro!: ext)

lemma (in map_isSng) isSng_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (isSng,op_map_isSng)\<in>\<langle>Rk,Rv\<rangle>rel\<rightarrow>Id"
  (* TODO: Clean up this mess *)
  apply (auto simp add: isSng_correct rel_alt)
  apply (rule_tac x=k in exI)
  apply (rule_tac x="the (a' k)" in exI)
  apply (rule sngI)
  apply (drule_tac x=k in spec)
  apply (auto elim: option_relE) []
  apply (force elim: option_relE) []

  apply (rule_tac x=k in exI)
  apply (rule_tac x="the (\<alpha> a k)" in exI)
  apply (rule sngI)
  apply (drule_tac x=k in spec)
  apply (auto elim: option_relE) []
  apply (force elim: option_relE) []
  done

lemma (in map_ball) ball_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (ball,op_map_ball)\<in>\<langle>Rk,Rv\<rangle>rel\<rightarrow>(\<langle>Rk,Rv\<rangle>prod_rel\<rightarrow>Id)\<rightarrow>Id"
  apply (auto simp: ball_correct rel_alt map_to_set_def
    option_rel_def prod_rel_def fun_rel_def)
  apply (metis option.inject option.simps(3))+
  done

lemma (in map_bex) bex_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (bex,op_map_bex)\<in>\<langle>Rk,Rv\<rangle>rel\<rightarrow>(\<langle>Rk,Rv\<rangle>prod_rel\<rightarrow>Id)\<rightarrow>Id"
  apply (auto simp: bex_correct map_to_set_def rel_alt
    option_rel_def prod_rel_def fun_rel_def)
  apply (metis option.inject option.simps(3))+
  done

lemma (in map_size) size_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (size,op_map_size)\<in>\<langle>Rk,Rv\<rangle>rel\<rightarrow>Id"
  apply (auto simp: size_correct rel_alt option_rel_def dom_def
    intro!: arg_cong[where f=card])
  apply (metis option.simps(3))+
  done

lemma (in map_size_abort) size_abort_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (size_abort,op_map_size_abort)\<in>Id\<rightarrow>\<langle>Rk,Rv\<rangle>rel\<rightarrow>Id"
  apply (auto simp: size_abort_correct
    rel_alt option_rel_def
    dom_def intro!: arg_cong[where f=card] cong[OF arg_cong[where f=min]])
  apply (metis option.simps(3))+
  done

lemma (in list_to_map) to_map_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (to_map,map_of)\<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>Rk,Rv\<rangle>rel"
proof (intro fun_relI)
  fix l :: "('u\<times>'v) list" and l' :: "('u\<times>'a) list"
  assume "PREFER_id Rk" hence [simp]: "Rk=Id" by simp
  assume "(l,l')\<in>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
  thus "(to_map l, map_of l') \<in> \<langle>Rk,Rv\<rangle>rel"
    apply (simp add: list_rel_def)
  proof (induct rule: list_all2_induct)
    case Nil thus ?case
      by (auto simp add: to_map_correct rel_alt)
  next
    case (Cons x x' l l') thus ?case
      by (auto simp add: to_map_correct
        rel_alt prod_rel_def)
  qed
qed

(* TODO: Move *)
lemma key_rel_true[simp]: "key_rel (\<lambda>_ _. True) = (\<lambda>_ _. True)"
  by (auto intro!: ext simp: key_rel_def)

lemma (in poly_map_iteratei) proper[proper_it]:
  "proper_it' iteratei iteratei"
  apply (rule proper_it'I)
  by (rule pi_iteratei)

lemma (in poly_map_iteratei) autoref_iteratei[autoref_ga_rules]:
  assumes ID: "REL_IS_ID Rk"
    "REL_IS_ID Rv" (* TODO: Unnecessary*)
  shows "is_map_to_list Rk Rv rel (it_to_list iteratei)"
proof -
  from ID have [simp]: "Rk=Id" "Rv = Id" by simp_all

  show ?thesis
    unfolding is_map_to_sorted_list_def is_map_to_list_def
      it_to_sorted_list_def
    apply simp
    apply (intro allI impI conjI)
  proof -
    fix m m'
    assume "(m, m') \<in> br \<alpha> invar"
    hence I: "invar m" and M': "m' = \<alpha> m" by (simp_all add: br_def)

    have [simp]: "\<And>c. (\<lambda>(_,_). c) = (\<lambda>_. c)" by auto

    from map_it_to_list_genord_correct[where it = iteratei,
      where R="\<lambda>_ _. True", simplified, OF
      iteratei_correct[OF I, unfolded set_iterator_def]
    ] have
        M: "Map.map_of (it_to_list iteratei m) = \<alpha> m"
        and D: "distinct (List.map fst (it_to_list iteratei m))"
      by (simp_all)

    from D show "distinct (it_to_list iteratei m)"
      by (rule distinct_mapI)

    from M show "map_to_set m' = set (it_to_list iteratei m)"
      by (simp add: M' map_of_map_to_set[OF D])
  qed
qed

lemma (in poly_map_iterateoi) proper_o[proper_it]:
  "proper_it' iterateoi iterateoi"
  apply (rule proper_it'I)
  by (rule pi_iterateoi)

lemma (in poly_map_iterateoi) autoref_iterateoi[autoref_ga_rules]:
  assumes ID: "REL_IS_ID Rk"
    "REL_IS_ID Rv" (* TODO: Unnecessary*)
  shows "is_map_to_sorted_list op \<le> Rk Rv rel (it_to_list iterateoi)"
proof -
  from ID have [simp]: "Rk=Id" "Rv = Id" by simp_all

  show ?thesis
    unfolding is_map_to_sorted_list_def
      it_to_sorted_list_def
    apply simp
    apply (intro allI impI conjI)
  proof -
    fix m m'
    assume "(m, m') \<in> br \<alpha> invar"
    hence I: "invar m" and M': "m' = \<alpha> m" by (simp_all add: br_def)

    have [simp]: "\<And>c. (\<lambda>(_,_). c) = (\<lambda>_. c)" by auto

    from map_it_to_list_linord_correct[where it = iterateoi,
      OF iterateoi_correct[OF I]
    ] have
        M: "map_of (it_to_list iterateoi m) = \<alpha> m"
        and D: "distinct (map fst (it_to_list iterateoi m))"
        and S: "sorted (map fst (it_to_list iterateoi m))"
      by (simp_all)

    from D show "distinct (it_to_list iterateoi m)"
      by (rule distinct_mapI)

    from M show "map_to_set m' = set (it_to_list iterateoi m)"
      by (simp add: M' map_of_map_to_set[OF D])

    from S show "sorted_by_rel (key_rel op \<le>) (it_to_list iterateoi m)"
      by (simp add: key_rel_def[abs_def])

  qed
qed

lemma (in poly_map_rev_iterateoi) proper_ro[proper_it]:
  "proper_it' rev_iterateoi rev_iterateoi"
  apply (rule proper_it'I)
  by (rule pi_rev_iterateoi)

lemma (in poly_map_rev_iterateoi) autoref_rev_iterateoi[autoref_ga_rules]:
  assumes ID: "REL_IS_ID Rk"
    "REL_IS_ID Rv" (* TODO: Unnecessary*)
  shows "is_map_to_sorted_list op \<ge> Rk Rv rel (it_to_list rev_iterateoi)"
proof -
  from ID have [simp]: "Rk=Id" "Rv = Id" by simp_all

  show ?thesis
    unfolding is_map_to_sorted_list_def
      it_to_sorted_list_def
    apply simp
    apply (intro allI impI conjI)
  proof -
    fix m m'
    assume "(m, m') \<in> br \<alpha> invar"
    hence I: "invar m" and M': "m' = \<alpha> m" by (simp_all add: br_def)

    have [simp]: "\<And>c. (\<lambda>(_,_). c) = (\<lambda>_. c)" by auto

    from map_it_to_list_rev_linord_correct[where it = rev_iterateoi,
      OF rev_iterateoi_correct[OF I]
    ] have
        M: "map_of (it_to_list rev_iterateoi m) = \<alpha> m"
        and D: "distinct (map fst (it_to_list rev_iterateoi m))"
        and S: "sorted (rev (map fst (it_to_list rev_iterateoi m)))"
      by (simp_all)

    from D show "distinct (it_to_list rev_iterateoi m)"
      by (rule distinct_mapI)

    from M show "map_to_set m' = set (it_to_list rev_iterateoi m)"
      by (simp add: M' map_of_map_to_set[OF D])

    from S show "sorted_by_rel (key_rel op \<ge>) (it_to_list rev_iterateoi m)"
      by (simp add: key_rel_def[abs_def])

  qed
qed

end


(*  Title:      ZF/Inductive.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge

Inductive definitions use least fixedpoints with standard products and sums
Coinductive definitions use greatest fixedpoints with Quine products and sums

Sums are used only for mutual recursion;
Products are used only to derive "streamlined" induction rules for relations
*)

section\<open>Inductive and Coinductive Definitions\<close>

theory Inductive
imports Fixedpt QPair Nat
keywords
  "inductive" "coinductive" "inductive_cases" "rep_datatype" "primrec" :: thy_decl and
  "domains" "intros" "monos" "con_defs" "type_intros" "type_elims"
    "elimination" "induction" "case_eqns" "recursor_eqns" :: quasi_command
begin

lemma def_swap_iff: "a == b ==> a = c \<longleftrightarrow> c = b"
  by blast

lemma def_trans: "f == g ==> g(a) = b ==> f(a) = b"
  by simp

lemma refl_thin: "!!P. a = a ==> P ==> P" .

ML_file \<open>ind_syntax.ML\<close>
ML_file \<open>Tools/ind_cases.ML\<close>
ML_file \<open>Tools/cartprod.ML\<close>
ML_file \<open>Tools/inductive_package.ML\<close>
ML_file \<open>Tools/induct_tacs.ML\<close>
ML_file \<open>Tools/primrec_package.ML\<close>

ML \<open>
structure Lfp =
  struct
  val oper      = \<^const>\<open>lfp\<close>
  val bnd_mono  = \<^const>\<open>bnd_mono\<close>
  val bnd_monoI = @{thm bnd_monoI}
  val subs      = @{thm def_lfp_subset}
  val Tarski    = @{thm def_lfp_unfold}
  val induct    = @{thm def_induct}
  end;

structure Standard_Prod =
  struct
  val sigma     = \<^const>\<open>Sigma\<close>
  val pair      = \<^const>\<open>Pair\<close>
  val split_name = \<^const_name>\<open>split\<close>
  val pair_iff  = @{thm Pair_iff}
  val split_eq  = @{thm split}
  val fsplitI   = @{thm splitI}
  val fsplitD   = @{thm splitD}
  val fsplitE   = @{thm splitE}
  end;

structure Standard_CP = CartProd_Fun (Standard_Prod);

structure Standard_Sum =
  struct
  val sum       = \<^const>\<open>sum\<close>
  val inl       = \<^const>\<open>Inl\<close>
  val inr       = \<^const>\<open>Inr\<close>
  val elim      = \<^const>\<open>case\<close>
  val case_inl  = @{thm case_Inl}
  val case_inr  = @{thm case_Inr}
  val inl_iff   = @{thm Inl_iff}
  val inr_iff   = @{thm Inr_iff}
  val distinct  = @{thm Inl_Inr_iff}
  val distinct' = @{thm Inr_Inl_iff}
  val free_SEs  = Ind_Syntax.mk_free_SEs
            [distinct, distinct', inl_iff, inr_iff, Standard_Prod.pair_iff]
  end;

structure Ind_Package =
    Add_inductive_def_Fun
      (structure Fp=Lfp and Pr=Standard_Prod and CP=Standard_CP
       and Su=Standard_Sum val coind = false);

structure Gfp =
  struct
  val oper      = \<^const>\<open>gfp\<close>
  val bnd_mono  = \<^const>\<open>bnd_mono\<close>
  val bnd_monoI = @{thm bnd_monoI}
  val subs      = @{thm def_gfp_subset}
  val Tarski    = @{thm def_gfp_unfold}
  val induct    = @{thm def_Collect_coinduct}
  end;

structure Quine_Prod =
  struct
  val sigma     = \<^const>\<open>QSigma\<close>
  val pair      = \<^const>\<open>QPair\<close>
  val split_name = \<^const_name>\<open>qsplit\<close>
  val pair_iff  = @{thm QPair_iff}
  val split_eq  = @{thm qsplit}
  val fsplitI   = @{thm qsplitI}
  val fsplitD   = @{thm qsplitD}
  val fsplitE   = @{thm qsplitE}
  end;

structure Quine_CP = CartProd_Fun (Quine_Prod);

structure Quine_Sum =
  struct
  val sum       = \<^const>\<open>qsum\<close>
  val inl       = \<^const>\<open>QInl\<close>
  val inr       = \<^const>\<open>QInr\<close>
  val elim      = \<^const>\<open>qcase\<close>
  val case_inl  = @{thm qcase_QInl}
  val case_inr  = @{thm qcase_QInr}
  val inl_iff   = @{thm QInl_iff}
  val inr_iff   = @{thm QInr_iff}
  val distinct  = @{thm QInl_QInr_iff}
  val distinct' = @{thm QInr_QInl_iff}
  val free_SEs  = Ind_Syntax.mk_free_SEs
            [distinct, distinct', inl_iff, inr_iff, Quine_Prod.pair_iff]
  end;

structure CoInd_Package =
  Add_inductive_def_Fun(structure Fp=Gfp and Pr=Quine_Prod and CP=Quine_CP
    and Su=Quine_Sum val coind = true);

\<close>

end