(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)
(*
A story of AutoCorres and recursion.

To do:
-- prove SIMPL total correctness
-- remove (* slow *) steps
-- remove word32 metis (or wait for word lifting...)
-- fix wp to support recursive fib'
-- Isar style proof?
*)

theory FibProof
imports
  "AutoCorres.AutoCorres"
begin

external_file "fib.c"

(*
 * The venerable Fibonacci function.
 *)
fun fibo :: "nat \<Rightarrow> nat" where
  "fibo 0 = 0" |
  "fibo (Suc 0) = Suc 0" |
  "fibo (Suc (Suc n)) = fibo n + fibo (Suc n)"
declare fibo.simps [simp del]

lemma fibo_alt_def: "fibo n = (if n = 0 then 0 else if n = 1 then 1 else fibo (n - 1) + fibo (n - 2))"
  apply (induct n rule: less_induct)
  apply (rename_tac n, case_tac n, simp add: fibo.simps)
  apply (rename_tac n1, case_tac n1, simp add: fibo.simps)
  apply (simp add: fibo.simps)
  done

lemma fibo_mono_Suc: "fibo n \<le> fibo (Suc n)"
  by (simp add: fibo_alt_def)
lemma fibo_mono: "a \<le> b \<Longrightarrow> fibo a \<le> fibo b"
  by (metis mono_iff_le_Suc mono_def fibo_mono_Suc)

lemma fibo_mono_strict: "n \<ge> 2 \<Longrightarrow> fibo n < fibo (Suc n)"
  apply (case_tac n, simp)
  apply (rename_tac n', subgoal_tac "fibo (Suc 0) \<le> fibo n'")
   apply (simp add: fibo.simps)
  apply (simp add: fibo_mono)
  done

lemma fiboI: "\<lbrakk> a + 1 = b; b + 1 = c \<rbrakk> \<Longrightarrow> fibo a + fibo b = fibo c"
  by (auto simp: fibo.simps)

(*
 * We write two versions in C, and compare correctness proofs on the
 * SIMPL and AutoCorres embeddings.
 *)

(*
 * C arithmetic is done using `unsigned', which is translated as `word32'.
 * So, it is much easier to prove that the C code implements this function,
 * which is not quite the same function as fibo.
 *)
function fibo32 :: "word32 \<Rightarrow> word32" where
  "fibo32 n = (if n = 0 then 0 else if n = 1 then 1 else fibo32 (n - 1) + fibo32 (n - 2))"
apply auto
done
termination fibo32
  by (relation "measure (\<lambda>x. unat x)", (simp|unat_arith)+)
declare fibo32.simps [simp del]

(*
 * But we really want to say that the C code does implement fibo
 * (at least up till 2971215073 < 2^32)...
 *)
lemma fibo_greater: "(6 + n) < fibo (6 + n)"
  apply (induct n)
   apply eval
  apply (subst add_Suc_right)+
  apply (subgoal_tac "Suc (6 + n) \<le> fibo (6 + n)")
   apply (subgoal_tac "fibo (6 + n) < fibo (Suc (6 + n))")
    apply simp
   apply (rule fibo_mono_strict)
   apply simp
  apply simp
  done
lemma fibo_greater': "n \<ge> 6 \<Longrightarrow> n < fibo n"
  by (metis le_iff_add fibo_greater)
lemma unat_word32_plus: "unat x + unat y < 2^32 \<Longrightarrow> unat x + unat y = unat (x + y :: word32)"
  by (metis len32 unat_of_nat_len word_arith_nat_add)

(* ... so we should say that too. *)
lemma fibo32_is_fibo: "fibo n < 2^32 \<Longrightarrow> fibo n = unat (fibo32 (of_nat n))"
  apply (induct n rule: less_induct)
  apply (subst fibo32.simps)
  apply (subst fibo_alt_def)
  apply (rename_tac n, case_tac "n = 0", simp)
  apply (case_tac "n = 1", simp)
  apply (subgoal_tac "n < 2^32"
                     "fibo (n - 1) + fibo (n - 2) < 2^32"
                     "of_nat n \<noteq> (0 :: word32)"
                     "of_nat n \<noteq> (1 :: word32)"
                     "fibo (n - 1) < 2^32"
                     "fibo (n - 2) < 2^32"
                     "fibo (n - 1) = unat (fibo32 (of_nat (n - 1)))"
                     "fibo (n - 2) = unat (fibo32 (of_nat (n - 2)))")
          apply (fastforce intro: unat_word32_plus)
         apply (metis diff_less gr0I zero_less_numeral)
        apply (metis diff_less gr0I zero_less_one)
       apply simp
      apply simp
     apply (metis len32 unat_1 unat_of_nat_len)
    apply (metis len32 unat_0 unat_of_nat_len)
   apply (metis fibo_alt_def)
  apply (case_tac "n < 6")
   apply simp
  apply (subgoal_tac "n < fibo n")
   apply simp
  apply (simp add: fibo_greater')
done

(* A helper for the SIMPL proofs later. *)
lemma fibo32_rec: "\<lbrakk> a < a + 2; b = a + 1; c = a + 2 \<rbrakk> \<Longrightarrow> fibo32 a + fibo32 b = fibo32 c"
  apply (subst(3) fibo32.simps)
  apply simp
  apply safe
     apply unat_arith
    apply (metis not_le overflow_plus_one_self word_n1_ge word_not_simps(1))
   apply (metis word_not_simps(1))
  apply (simp add: field_simps)
  done

(* First we invoke CParser to translate the C code to SIMPL. *)
install_C_file "fib.c"

context fib begin
(* fib_linear\<^bsub>C\<^esub> is the linear-time implementation. *)
thm fib_linear_body_def
(* fib\<^bsub>C\<^esub> is the pretty (inefficient) recursive implementation. *)
thm fib_body_def
(* First, let us prove that they implement fibo32. *)

(* First, the linear version. *)
lemma fib_linear_simpl_spec:
"\<Gamma> \<turnstile> {s. s = t}
     \<acute>ret__unsigned :== CALL fib_linear(\<acute>n)
     \<lbrace> (\<acute>ret__unsigned = fibo32 \<^bsup>t\<^esup>n) \<rbrace>"
  (* We have not annotated the code yet, so we cannot apply vcg usefully. *)
  (* First we expand the function call and defer the overall precondition. *)
  apply vcg_step
   defer
   (* Now we annotate the loop with the correct invariant and termination measure. *)
   apply (subst whileAnno_def)
   apply (subst whileAnno_def [symmetric,
     where I=" \<lbrace> \<acute>a = fibo32 (\<^bsup>t\<^esup>n - \<acute>n) \<and> \<acute>n \<le> \<^bsup>t\<^esup>n \<and> (\<acute>n \<noteq> 0 \<longrightarrow> (\<acute>b = fibo32 (\<^bsup>t\<^esup>n + 1 - \<acute>n))) \<rbrace>"
     and V="measure (\<lambda>s. unat (n_' s))"])
   apply vcg
  (* It is mostly word arithmetic from here on. *)
    apply (simp add: scast_def field_simps)
    apply clarsimp
    apply (case_tac "n = 0")
     apply clarsimp
    apply (case_tac "n = 1")
     apply (rename_tac n1, subgoal_tac "n1 = 1")
      apply simp
     apply unat_arith
    apply (rename_tac n1, case_tac "n1 = 1")
     apply simp
    apply clarsimp
    apply safe
       apply (metis linear word_must_wrap)
      apply (rule fibo32_rec)
        (* unat_arith is too slow for this subgoal *)
        apply (subst word_less_nowrapI'[where k = 2 and z = "-1"])
           apply (subgoal_tac "n1 \<ge> 2")
            apply (metis word_n1_ge word_sub_le_iff word_sub_mono)
           apply unat_arith
          apply simp
         apply simp
        apply simp
       apply (simp add: field_simps)+
   apply (simp add: fibo32.simps)
  apply (simp add: scast_def fibo32.simps)
done

(* And the recursive version. *)
thm fib_body_def

lemma fib_simpl_spec: "\<forall>n. \<Gamma>,\<Theta>\<turnstile>\<^sub>t\<lbrace>\<acute>n=n\<rbrace>  PROC fib(\<acute>n,\<acute>ret__unsigned) \<lbrace>\<acute>ret__unsigned = fibo32 n\<rbrace>"
  apply (hoare_rule HoareTotal.ProcRec1[where r = "measure (\<lambda>(s, d). unat \<^bsup>s\<^esup>n)"])
  apply (unfold creturn_def | vcg_step)+
  apply (subst fibo32.simps, simp)
  apply (subst fibo32.simps, simp)
  apply (subst fibo32.simps[where n = n])
  apply unat_arith
  done

(*
 * We need to temporarily leave the local context to run autocorres.
 * Normally, we would run autocorres immediately after install_C_file.
 *)
end (* context fib *)

autocorres [unsigned_word_abs = fib_linear] "fib.c"

context fib begin

thm fib_linear'_def
thm fib'.simps fib'.simps[unfolded fun_app_def, folded One_nat_def]
thm call_fib'_def call_fib'_def[simplified]

(*
 * fib_linear\<^bsub>C\<^esub> has been lifted to fib_linear', using the option monad.
 * The option monad expresses programs that read the heap
 * and may fail. fib_linear\<^bsub>C\<^esub> does not read the heap, but its loop
 * might fail to terminate, so it cannot be a simple HOL function.
 *
 * Note that arithmetic in fib_linear' has been converted to type @{typ nat}.
 * This conversion is enabled by the word_abs option.
 * fib_linear' still matches the C code as long as calculations do not wrap around;
 * AutoCorres inserts an extra guard to ensure this.
 *)

thm fib_linear'_def

(* Here we prove that fib_linear' implements fibo, assuming that
 * no calculations wrap around. *)
lemma fib_linear'_correct: "ovalid (\<lambda>_. True) (fib_linear' n) (\<lambda>r s. r = fibo n)"
  unfolding fib_linear'_def
  (* The loop invariant, as before. *)
  apply (subst owhile_add_inv
    [where I = "\<lambda>(a, b, i) s. i \<le> n \<and> a = fibo (n - i) \<and> (i \<noteq> 0 \<longrightarrow> (b = fibo (n - i + 1)))"])
  apply wp
     apply safe
        (* Again, we prove largely arithmetical facts. However, these
         * proofs are easier because we are using the @{typ nat} type. *)
        apply (fastforce intro: arg_cong[where f = fibo])
       apply (simp add: Suc_diff_le)
      apply (fastforce intro: fiboI simp: field_simps)
     apply simp
    apply (rename_tac b s, case_tac b, simp, simp)
   apply (simp_all add: fibo.simps)
  done

(* Here we prove that fib_linear' terminates, and calculations do not overflow
 * for Fibonacci numbers below UINT_MAX.
 * This involves proving something similar to fibo32_is_fibo, so we
 * do not need that theorem to interpret this one.
 *
 * NB: Because the variable b is ahead of the Fibonacci number
 *     being calculated, we need to consider integer wraparound for
 *     fibo (Suc n) instead of fibo n. *)
lemma fib_linear'_term: "no_ofail (\<lambda>_. fibo (Suc n) < UINT_MAX) (fib_linear' n)"
  (* We would like to use the wp tactic, so we will translate our goal into
     ovalidNF form. *)
  unfolding fib_linear'_def no_ofail_is_ovalidNF
  apply (subst owhile_add_inv
    [where I = "\<lambda>(a, b, i) s. i \<le> n \<and> a = fibo (n - i) \<and> b = fibo (n - i + 1) \<and> fibo (Suc n) \<le> UINT_MAX"
       and M = "\<lambda>(_, _, i) _. i"])
  apply wp
     apply safe
         apply (fastforce intro: le_trans[rotated] add_le_mono simp: fibo_alt_def[where n = "Suc n"] fibo_mono)
        apply arith
       apply (simp add: field_simps Suc_diff_le)
      apply (fastforce intro: fiboI simp: field_simps)
     apply wp
     apply simp
    apply (simp_all add: fibo.simps)
  done

(* And we are done. *)
lemma fib_linear'_proof: "ovalidNF (\<lambda>_. fibo (Suc n) < UINT_MAX) (fib_linear' n) (\<lambda>r _. r = fibo n)"
  by (metis ovalidNF_combine ovalid_pre_imp fib_linear'_correct fib_linear'_term)

(* WIP: convert and prove in nondet_monad *)

(* First, set up the conversion... *)
lemma validE_NF_validNF: "validE_NF P (liftE f) Q (K (K False)) \<Longrightarrow> validNF P f Q"
  unfolding validE_NF_def validE_def validNF_def valid_def no_fail_def liftE_def K_def
  apply monad_eq
  apply fastforce
  done

lemma [ts_rule option unlift]: "oreturn a = ogets (\<lambda>_. a)"
  by (simp add: oreturn_def ogets_def)

declare liftE_liftE[symmetric, ts_rule option unlift]

lemma gets_theE_split[ts_rule option unlift]:
  "gets_theE (case p of (x, y) \<Rightarrow> f x y) = (case p of (x, y) \<Rightarrow> gets_theE (f x y))"
  apply (simp split: prod.splits)
  done

declare gets_theE_L2_while[symmetric, where n = "[]", ts_rule option unlift]
declare K_bind_def[ts_rule option unlift]

lemma nondet_fib_linear'_proof: "\<lbrace> \<lambda>s. fibo (Suc n) \<le> UINT_MAX \<and> P s \<rbrace> gets_the (fib_linear' n) \<lbrace> \<lambda>r s. r = fibo n \<and> P s \<rbrace>!"
  unfolding fib_linear'_def
  apply (rule validE_NF_validNF)
  apply (subst fun_cong[OF gets_theE_def[symmetric, THEN meta_eq_to_obj_eq]])
  (* Then it works! *)
  apply (monad_convert nondet "gets_theE _")

  apply (subst whileLoop_add_inv
    [where I="\<lambda>(a', b', n') s. a' = fibo (n - n') \<and> n' \<le> n \<and> (n' \<noteq> 0 \<longrightarrow> (b' = fibo (n - n' + 1))) \<and> fibo (Suc n) \<le> UINT_MAX \<and> P s"
       and M="\<lambda>((_, _, n'), _). n'"])
  apply wp
    apply safe
           apply (fastforce intro: arg_cong[where f = fibo])
          apply arith
         apply (fastforce intro: fiboI simp: field_simps)
        apply simp
       apply (fastforce intro: le_trans[rotated] simp: fiboI field_simps fibo_mono)
      apply simp
     apply simp
    apply (simp_all add: UINT_MAX_def fibo.simps)
  done

(*
 * Now for the recursive function fib\<^bsub>C\<^esub>.
 * The lifted function fib' is a recursive function in HOL, but all HOL functions
 * must be well-founded (ie. terminate) and AutoCorres cannot prove this.
 * Instead, fib' gets an extra parameter called “measure”, which limits the
 * recursion depth. With this recursion limit, it is obvious that
 * fib' terminates, so fib' can be defined as a HOL function.
 *)
thm fib'.simps (* Just a reminder *)
(*
 * Like fib_linear\<^bsub>C\<^esub>, fib\<^bsub>C\<^esub> is lifted to the option monad. If the measure parameter
 * is too small, fib' will fail instead of giving the result that would be
 * returned by fib\<^bsub>C\<^esub>.
 *)

(*
 * AutoCorres also generates a \<^bitalic>measure function\<^eitalic> for fib'. This function is
 * used to generate the measure parameter anywhere fib' is called. For example,
 *
 *   void call_fib(void) { fib(42); }
 *
 * is translated to:
 *)
thm call_fib'_def
(*
 * The measure function receives all of the information needed, in principle,
 * to determine an upper bound on the call depth (if there is one).
 * Namely, the function arguments and the global program state.
 *)
term measure_of'_fib
(*
 * measure_of'_fib does not actually have a definition, yet.
 * To give it a sensible definition, we need to work out the maximum
 * recursion depth, and AutoCorres does not know how to do that.
 * We will manually define the function later.
 *)

(*
 * But first, let us prove the correctness of fib'.
 * Again, we prove partial correctness separately, assuming that fib'
 * does not return None.
 *)

lemma fib'_correct_rec_helper:
  assumes ind: "\<And>y P m. ovalid (\<lambda>_. y < x \<and> P (fibo32 y)) (fib' m y) (\<lambda>r _. P r)"
  shows "ovalid (\<lambda>_. P (fibo32 x)) (fib' m x) (\<lambda>r _. P r)"
  apply (subst fib'.simps)
  apply (clarsimp simp: unat_eq_of_nat)
  apply (wp ind)
  apply (clarsimp simp: split: if_split_asm)
  apply safe
      apply (subst (asm) fibo32.simps, simp)
     apply (subst (asm) fibo32.simps, simp)
    apply unat_arith
   apply unat_arith
  apply (subst (asm) fibo32.simps, simp)
  done

lemma fib'_correct: "ovalid P (fib' m n) (\<lambda>r s. P s \<and> r = fibo32 n)"
  apply (subgoal_tac "\<And>P. ovalid (\<lambda>_. P (fibo32 n)) (fib' m n) (\<lambda>r _. P r)")
   apply (unfold ovalid_def, fast)[1]
  apply (induct n arbitrary: P m rule: less_induct)
  apply (subgoal_tac "\<And>y P m. ovalid (\<lambda>_. y < x \<and> P (fibo32 y)) (fib' m y) (\<lambda>r _. P r)")
   apply (rule fib'_correct_rec_helper)
   apply (unfold ovalid_def, fast)[1]
  apply (unfold ovalid_def)
  apply blast
  done

lemma fib'_term_rec_helper:
  assumes ind: "\<And>y P rec_measure'. ovalidNF (\<lambda>_. y < x \<and> unat y < rec_measure' \<and> P) (fib' rec_measure' y) (\<lambda>_ _. P)"
  shows "ovalidNF (\<lambda>_. unat x < rec_measure') (fib' rec_measure' x) (\<lambda>_ _. True)"
  apply (subst fib'.simps)
  apply (wp ind)
  apply simp
  apply unat_arith (* slow *)
  done

lemma fib'_term: "no_ofail (\<lambda>_. rec_measure' > unat n) (fib' rec_measure' n)"
  apply (subst no_ofail_is_ovalidNF)
  apply (induct n arbitrary: rec_measure' rule: less_induct)
  apply (subgoal_tac "\<And>y P rec_measure'. ovalidNF (\<lambda>_. y < x \<and> unat y < rec_measure' \<and> P) (fib' rec_measure' y) (\<lambda>_ _. P)")
  apply (rule fib'_term_rec_helper, assumption)
  apply (metis (full_types) ovalidNF_assume_pre)
  done

(* The overall correctness proof. *)
lemma fib'_spec: "ovalidNF (\<lambda>s. P s \<and> m > unat n) (fib' m n) (\<lambda>r s. P s \<and> r = fibo32 n)"
  apply (rule ovalidNF_combine)
  apply (wp fib'_correct, simp)
  apply (wp fib'_term, simp)
  done

(*
If fib\<^bsub>C\<^esub> was lifted to the state monad...
Once we get hoare triples and wp reasoning on the option monad,
the proof might also look like this.

(* isar proof lets us rewrite the inductive assumption r and pass it to wp *)
lemma fib2'_correct: "\<lbrace> \<lambda>_. P (fibo32 n) \<rbrace> fib2' m n \<lbrace> \<lambda>r s. P r \<rbrace>"
proof (induct n arbitrary: P m rule: less_induct)
   fix x P m
   assume r: "\<And>y P m. y < x \<Longrightarrow> \<lbrace>  \<lambda>_. P (fibo32 y) \<rbrace> fib2' m y \<lbrace> \<lambda>r s. P r \<rbrace>"

   have r': "\<And>y P m. \<lbrace>  \<lambda>_. y < x \<and> P (fibo32 y) \<rbrace> fib2' m y \<lbrace> \<lambda>r s. P r \<rbrace>"
    apply (rule hoare_assume_pre)
    apply clarsimp
    apply (insert r)
    apply (clarsimp simp: valid_def)
    done

   show "\<lbrace> \<lambda>_. P (fibo32 x) \<rbrace> fib2' m x \<lbrace> \<lambda>r s. P r \<rbrace>"
     apply (subst fib2'.simps)
     apply (wp r')
    apply auto
    apply (simp_all add: fibo32.simps)
    apply unat_arith+
    done
qed
*)

(* Finally, we can show that anyone who calls fib' will get the correct result. *)
lemma fib'_call:
  "fib' (unat n + 1) n s = Some (fibo32 n)"
  using fib'_spec[unfolded ovalidNF_def]
  apply fastforce
  done

lemma "\<lbrace> P \<rbrace> call_fib' \<lbrace> \<lambda>_. P \<rbrace>!"
  including nf_no_pre
  apply (unfold call_fib'_def)
  apply wp
   apply (blast intro: fib'_call)
  apply (force simp: fib'_mono option_monad_mono_eq)
  done

end (* context fib *)

end


(******************************************************************************)
(* Project: The Isabelle/UTP Proof System                                     *)
(* File: Transfer_extra.thy                                                   *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@gmail.com and simon.foster@york.ac.uk                  *)
(******************************************************************************)
(* LAST REVIEWED: 09 Jun 2022 *)

section \<open>Typedef Extras\<close>

theory Typedef_extra
imports Main
begin

subsection \<open>Transfer Laws\<close>

text \<open>
  We extend Isabelle's @{text type_definition} locale here with transfer laws
  for existential, universal and meta quantifiers. These laws can be used with
  plain rewriting via @{method simp}, hence do not require the full-blown use
  of the transfer package. Note that we have to instantiate them manually for
  particular type definitions, an example is at the bottom of the theory.
\<close>

context type_definition
begin
lemma meta_transfer:
"(\<And>y::'b. PROP P y) \<equiv> (\<And>x::'a. x \<in> A \<Longrightarrow> PROP P (Abs x))"
apply (rule)
\<comment> \<open>Subgoal 1\<close>
apply (drule_tac x = "Abs x" in meta_spec)
apply (assumption)
\<comment> \<open>Subgoal 2\<close>
apply (drule_tac x = "Rep y" in meta_spec)
apply (simp add: Rep)
apply (simp add: Rep_inverse)
done

lemma forall_transfer:
"(\<forall>y::'b. P y) = (\<forall>(x::'a)\<in>A. P (Abs x))"
apply (safe)
\<comment> \<open>Subgoal 1\<close>
apply (drule_tac x = "Abs x" in spec)
apply (assumption)
\<comment> \<open>Subgoal 2\<close>
apply (drule_tac x = "Rep y" in bspec)
apply (simp add: Rep)
apply (simp add: Rep_inverse)
done

lemma exists_transfer:
"(\<exists>y::'b. P y) = (\<exists>(x::'a)\<in>A. P (Abs x))"
apply (safe)
\<comment> \<open>Subgoal 1\<close>
apply (rule_tac x = "Rep y" in bexI)
apply (simp add: Rep_inverse)
apply (simp add: Rep)
\<comment> \<open>Subgoal 2\<close>
apply (rule_tac x = "Abs x" in exI)
apply (assumption)
done

lemmas transfer =
  meta_transfer
  forall_transfer
  exists_transfer
end

text \<open>An example of an instantiation i.e.~for the product type would be.\<close>

lemmas list_transfer =
  type_definition.transfer [OF Product_Type.type_definition_prod]

hide_fact list_transfer
end


theory LamEx
imports "../Nominal/Nominal2" "Nominal2_Eqvt" "Nominal2_Supp" "Abs"
begin

atom_decl name

datatype rlam =
  rVar "name"
| rApp "rlam" "rlam"
| rLam "name" "rlam"

fun
  rfv :: "rlam \<Rightarrow> atom set"
where
  rfv_var: "rfv (rVar a) = {atom a}"
| rfv_app: "rfv (rApp t1 t2) = (rfv t1) \<union> (rfv t2)"
| rfv_lam: "rfv (rLam a t) = (rfv t) - {atom a}"

instantiation rlam :: pt
begin

primrec
  permute_rlam
where
  "permute_rlam pi (rVar a) = rVar (pi \<bullet> a)"
| "permute_rlam pi (rApp t1 t2) = rApp (permute_rlam pi t1) (permute_rlam pi t2)"
| "permute_rlam pi (rLam a t) = rLam (pi \<bullet> a) (permute_rlam pi t)"

instance
apply default
apply(induct_tac [!] x)
apply(simp_all)
done

end

instantiation rlam :: fs
begin

lemma neg_conj:
  "\<not>(P \<and> Q) \<longleftrightarrow> (\<not>P) \<or> (\<not>Q)"
  by simp

instance
apply default
apply(induct_tac x)
(* var case *)
apply(simp add: supp_def)
apply(fold supp_def)[1]
apply(simp add: supp_at_base)
(* app case *)
apply(simp only: supp_def)
apply(simp only: permute_rlam.simps)
apply(simp only: rlam.inject)
apply(simp only: neg_conj)
apply(simp only: Collect_disj_eq)
apply(simp only: infinite_Un)
apply(simp only: Collect_disj_eq)
apply(simp)
(* lam case *)
apply(simp only: supp_def)
apply(simp only: permute_rlam.simps)
apply(simp only: rlam.inject)
apply(simp only: neg_conj)
apply(simp only: Collect_disj_eq)
apply(simp only: infinite_Un)
apply(simp only: Collect_disj_eq)
apply(simp)
apply(fold supp_def)[1]
apply(simp add: supp_at_base)
done

end

(* for the eqvt proof of the alpha-equivalence *)
declare permute_rlam.simps[eqvt]

lemma rfv_eqvt[eqvt]:
  shows "(pi\<bullet>rfv t) = rfv (pi\<bullet>t)"
apply(induct t)
apply(simp_all)
apply(simp add: permute_set_eq atom_eqvt)
apply(simp add: union_eqvt)
apply(simp add: Diff_eqvt)
apply(simp add: permute_set_eq atom_eqvt)
done

inductive
    alpha :: "rlam \<Rightarrow> rlam \<Rightarrow> bool" ("_ \<approx> _" [100, 100] 100)
where
  a1: "a = b \<Longrightarrow> (rVar a) \<approx> (rVar b)"
| a2: "\<lbrakk>t1 \<approx> t2; s1 \<approx> s2\<rbrakk> \<Longrightarrow> rApp t1 s1 \<approx> rApp t2 s2"
| a3: "\<exists>pi. (({atom a}, t) \<approx>gen alpha rfv pi ({atom b}, s)) \<Longrightarrow> rLam a t \<approx> rLam b s"
print_theorems
thm alpha.induct

lemma a3_inverse:
  assumes "rLam a t \<approx> rLam b s"
  shows "\<exists>pi. (({atom a}, t) \<approx>gen alpha rfv pi ({atom b}, s))"
using assms
apply(erule_tac alpha.cases)
apply(auto)
done

text {* should be automatic with new version of eqvt-machinery *}
lemma alpha_eqvt:
  shows "t \<approx> s \<Longrightarrow> (pi \<bullet> t) \<approx> (pi \<bullet> s)"
apply(induct rule: alpha.induct)
apply(simp add: a1)
apply(simp add: a2)
apply(simp)
apply(rule a3)
apply(rule alpha_gen_atom_eqvt)
apply(rule rfv_eqvt)
apply assumption
done

lemma alpha_refl:
  shows "t \<approx> t"
apply(induct t rule: rlam.induct)
apply(simp add: a1)
apply(simp add: a2)
apply(rule a3)
apply(rule_tac x="0" in exI)
apply(rule alpha_gen_refl)
apply(assumption)
done

lemma alpha_sym:
  shows "t \<approx> s \<Longrightarrow> s \<approx> t"
  apply(induct rule: alpha.induct)
  apply(simp add: a1)
  apply(simp add: a2)
  apply(rule a3)
  apply(erule alpha_gen_compose_sym)
  apply(erule alpha_eqvt)
  done

lemma alpha_trans:
  shows "t1 \<approx> t2 \<Longrightarrow> t2 \<approx> t3 \<Longrightarrow> t1 \<approx> t3"
apply(induct arbitrary: t3 rule: alpha.induct)
apply(simp add: a1)
apply(rotate_tac 4)
apply(erule alpha.cases)
apply(simp_all add: a2)
apply(erule alpha.cases)
apply(simp_all)
apply(rule a3)
apply(erule alpha_gen_compose_trans)
apply(assumption)
apply(erule alpha_eqvt)
done

lemma alpha_equivp:
  shows "equivp alpha"
  apply(rule equivpI)
  unfolding reflp_def symp_def transp_def
  apply(auto intro: alpha_refl alpha_sym alpha_trans)
  done

lemma alpha_rfv:
  shows "t \<approx> s \<Longrightarrow> rfv t = rfv s"
  apply(induct rule: alpha.induct)
  apply(simp_all add: alpha_gen.simps)
  done

quotient_type lam = rlam / alpha
  by (rule alpha_equivp)

quotient_definition
  "Var :: name \<Rightarrow> lam"
is
  "rVar"

quotient_definition
   "App :: lam \<Rightarrow> lam \<Rightarrow> lam"
is
  "rApp"

quotient_definition
  "Lam :: name \<Rightarrow> lam \<Rightarrow> lam"
is
  "rLam"

quotient_definition
  "fv :: lam \<Rightarrow> atom set"
is
  "rfv"

lemma perm_rsp[quot_respect]:
  "(op = ===> alpha ===> alpha) permute permute"
  apply(auto)
  apply(rule alpha_eqvt)
  apply(simp)
  done

lemma rVar_rsp[quot_respect]:
  "(op = ===> alpha) rVar rVar"
  by (auto intro: a1)

lemma rApp_rsp[quot_respect]:
  "(alpha ===> alpha ===> alpha) rApp rApp"
  by (auto intro: a2)

lemma rLam_rsp[quot_respect]:
  "(op = ===> alpha ===> alpha) rLam rLam"
  apply(auto)
  apply(rule a3)
  apply(rule_tac x="0" in exI)
  unfolding fresh_star_def
  apply(simp add: fresh_star_def fresh_zero_perm alpha_gen.simps)
  apply(simp add: alpha_rfv)
  done

lemma rfv_rsp[quot_respect]:
  "(alpha ===> op =) rfv rfv"
apply(simp add: alpha_rfv)
done

section {* lifted theorems *}

lemma lam_induct:
  "\<lbrakk>\<And>name. P (Var name);
    \<And>lam1 lam2. \<lbrakk>P lam1; P lam2\<rbrakk> \<Longrightarrow> P (App lam1 lam2);
    \<And>name lam. P lam \<Longrightarrow> P (Lam name lam)\<rbrakk>
    \<Longrightarrow> P lam"
  apply (lifting rlam.induct)
  done

instantiation lam :: pt
begin

quotient_definition
  "permute_lam :: perm \<Rightarrow> lam \<Rightarrow> lam"
is
  "permute :: perm \<Rightarrow> rlam \<Rightarrow> rlam"

lemma permute_lam [simp]:
  shows "pi \<bullet> Var a = Var (pi \<bullet> a)"
  and   "pi \<bullet> App t1 t2 = App (pi \<bullet> t1) (pi \<bullet> t2)"
  and   "pi \<bullet> Lam a t = Lam (pi \<bullet> a) (pi \<bullet> t)"
apply(lifting permute_rlam.simps)
done

instance
apply default
apply(induct_tac [!] x rule: lam_induct)
apply(simp_all)
done

end

lemma fv_lam [simp]:
  shows "fv (Var a) = {atom a}"
  and   "fv (App t1 t2) = fv t1 \<union> fv t2"
  and   "fv (Lam a t) = fv t - {atom a}"
apply(lifting rfv_var rfv_app rfv_lam)
done

lemma fv_eqvt:
  shows "(p \<bullet> fv t) = fv (p \<bullet> t)"
apply(lifting rfv_eqvt)
done

lemma a1:
  "a = b \<Longrightarrow> Var a = Var b"
  by  (lifting a1)

lemma a2:
  "\<lbrakk>x = xa; xb = xc\<rbrakk> \<Longrightarrow> App x xb = App xa xc"
  by  (lifting a2)

lemma alpha_gen_rsp_pre:
  assumes a5: "\<And>t s. R t s \<Longrightarrow> R (pi \<bullet> t) (pi \<bullet> s)"
  and     a1: "R s1 t1"
  and     a2: "R s2 t2"
  and     a3: "\<And>a b c d. R a b \<Longrightarrow> R c d \<Longrightarrow> R1 a c = R2 b d"
  and     a4: "\<And>x y. R x y \<Longrightarrow> fv1 x = fv2 y"
  shows   "(a, s1) \<approx>gen R1 fv1 pi (b, s2) = (a, t1) \<approx>gen R2 fv2 pi (b, t2)"
apply (simp add: alpha_gen.simps)
apply (simp only: a4[symmetric, OF a1] a4[symmetric, OF a2])
apply auto
apply (subst a3[symmetric])
apply (rule a5)
apply (rule a1)
apply (rule a2)
apply (assumption)
apply (subst a3)
apply (rule a5)
apply (rule a1)
apply (rule a2)
apply (assumption)
done

lemma [quot_respect]: "(prod_rel op = alpha ===>
           (alpha ===> alpha ===> op =) ===> (alpha ===> op =) ===> op = ===> prod_rel op = alpha ===> op =)
           alpha_gen alpha_gen"
apply simp
apply clarify
apply (rule alpha_gen_rsp_pre[of "alpha",OF alpha_eqvt])
apply auto
done

(* pi_abs would be also sufficient to prove the next lemma *)
lemma replam_eqvt: "pi \<bullet> (rep_lam x) = rep_lam (pi \<bullet> x)"
apply (unfold rep_lam_def)
sorry

lemma [quot_preserve]: "(prod_fun id rep_lam --->
           (abs_lam ---> abs_lam ---> id) ---> (abs_lam ---> id) ---> id ---> (prod_fun id rep_lam) ---> id)
           alpha_gen = alpha_gen"
apply (simp add: expand_fun_eq alpha_gen.simps Quotient_abs_rep[OF Quotient_lam])
apply (simp add: replam_eqvt)
apply (simp only: Quotient_abs_rep[OF Quotient_lam])
apply auto
done

lemma alpha_prs [quot_preserve]: "(rep_lam ---> rep_lam ---> id) alpha = (op =)"
apply (simp add: expand_fun_eq)
apply (simp add: Quotient_rel_rep[OF Quotient_lam])
done

lemma a3:
  "\<exists>pi. ({atom a}, t) \<approx>gen (op =) fv pi ({atom b}, s) \<Longrightarrow> Lam a t = Lam b s"
  apply (unfold alpha_gen)
  apply (lifting a3[unfolded alpha_gen])
  done

lemma a3_inv:
  "Lam a t = Lam b s \<Longrightarrow> \<exists>pi. ({atom a}, t) \<approx>gen (op =) fv pi ({atom b}, s)"
  apply (unfold alpha_gen)
  apply (lifting a3_inverse[unfolded alpha_gen])
  done

lemma alpha_cases:
  "\<lbrakk>a1 = a2; \<And>a b. \<lbrakk>a1 = Var a; a2 = Var b; a = b\<rbrakk> \<Longrightarrow> P;
    \<And>t1 t2 s1 s2. \<lbrakk>a1 = App t1 s1; a2 = App t2 s2; t1 = t2; s1 = s2\<rbrakk> \<Longrightarrow> P;
    \<And>a t b s. \<lbrakk>a1 = Lam a t; a2 = Lam b s; \<exists>pi. ({atom a}, t) \<approx>gen (op =) fv pi ({atom b}, s)\<rbrakk>
   \<Longrightarrow> P\<rbrakk>
    \<Longrightarrow> P"
unfolding alpha_gen
apply (lifting alpha.cases[unfolded alpha_gen])
done

(* not sure whether needed *)
lemma alpha_induct:
  "\<lbrakk>qx = qxa; \<And>a b. a = b \<Longrightarrow> qxb (Var a) (Var b);
    \<And>x xa xb xc. \<lbrakk>x = xa; qxb x xa; xb = xc; qxb xb xc\<rbrakk> \<Longrightarrow> qxb (App x xb) (App xa xc);
 \<And>a t b s. \<exists>pi. ({atom a}, t) \<approx>gen (\<lambda>x1 x2. x1 = x2 \<and> qxb x1 x2) fv pi ({atom b}, s) \<Longrightarrow> qxb (Lam a t) (Lam b s)\<rbrakk>
    \<Longrightarrow> qxb qx qxa"
unfolding alpha_gen by (lifting alpha.induct[unfolded alpha_gen])

(* should they lift automatically *)
lemma lam_inject [simp]:
  shows "(Var a = Var b) = (a = b)"
  and   "(App t1 t2 = App s1 s2) = (t1 = s1 \<and> t2 = s2)"
apply(lifting rlam.inject(1) rlam.inject(2))
apply(regularize)
prefer 2
apply(regularize)
prefer 2
apply(auto)
apply(drule alpha.cases)
apply(simp_all)
apply(simp add: alpha.a1)
apply(drule alpha.cases)
apply(simp_all)
apply(drule alpha.cases)
apply(simp_all)
apply(rule alpha.a2)
apply(simp_all)
done

thm a3_inv
lemma Lam_pseudo_inject:
  shows "(Lam a t = Lam b s) = (\<exists>pi. ({atom a}, t) \<approx>gen (op =) fv pi ({atom b}, s))"
apply(rule iffI)
apply(rule a3_inv)
apply(assumption)
apply(rule a3)
apply(assumption)
done

lemma rlam_distinct:
  shows "\<not>(rVar nam \<approx> rApp rlam1' rlam2')"
  and   "\<not>(rApp rlam1' rlam2' \<approx> rVar nam)"
  and   "\<not>(rVar nam \<approx> rLam nam' rlam')"
  and   "\<not>(rLam nam' rlam' \<approx> rVar nam)"
  and   "\<not>(rApp rlam1 rlam2 \<approx> rLam nam' rlam')"
  and   "\<not>(rLam nam' rlam' \<approx> rApp rlam1 rlam2)"
apply auto
apply (erule alpha.cases)
apply (simp_all only: rlam.distinct)
apply (erule alpha.cases)
apply (simp_all only: rlam.distinct)
apply (erule alpha.cases)
apply (simp_all only: rlam.distinct)
apply (erule alpha.cases)
apply (simp_all only: rlam.distinct)
apply (erule alpha.cases)
apply (simp_all only: rlam.distinct)
apply (erule alpha.cases)
apply (simp_all only: rlam.distinct)
done

lemma lam_distinct[simp]:
  shows "Var nam \<noteq> App lam1' lam2'"
  and   "App lam1' lam2' \<noteq> Var nam"
  and   "Var nam \<noteq> Lam nam' lam'"
  and   "Lam nam' lam' \<noteq> Var nam"
  and   "App lam1 lam2 \<noteq> Lam nam' lam'"
  and   "Lam nam' lam' \<noteq> App lam1 lam2"
apply(lifting rlam_distinct(1) rlam_distinct(2) rlam_distinct(3) rlam_distinct(4) rlam_distinct(5) rlam_distinct(6))
done

lemma var_supp1:
  shows "(supp (Var a)) = (supp a)"
  apply (simp add: supp_def)
  done

lemma var_supp:
  shows "(supp (Var a)) = {a:::name}"
  using var_supp1 by (simp add: supp_at_base)

lemma app_supp:
  shows "supp (App t1 t2) = (supp t1) \<union> (supp t2)"
apply(simp only: supp_def lam_inject)
apply(simp add: Collect_imp_eq Collect_neg_eq)
done

(* supp for lam *)
lemma lam_supp1:
  shows "(supp (atom x, t)) supports (Lam x t) "
apply(simp add: supports_def)
apply(fold fresh_def)
apply(simp add: fresh_Pair swap_fresh_fresh)
apply(clarify)
apply(subst swap_at_base_simps(3))
apply(simp_all add: fresh_atom)
done

lemma lam_fsupp1:
  assumes a: "finite (supp t)"
  shows "finite (supp (Lam x t))"
apply(rule supports_finite)
apply(rule lam_supp1)
apply(simp add: a supp_Pair supp_atom)
done

instance lam :: fs
apply(default)
apply(induct_tac x rule: lam_induct)
apply(simp add: var_supp)
apply(simp add: app_supp)
apply(simp add: lam_fsupp1)
done

lemma supp_fv:
  shows "supp t = fv t"
apply(induct t rule: lam_induct)
apply(simp add: var_supp)
apply(simp add: app_supp)
apply(subgoal_tac "supp (Lam name lam) = supp (Abs {atom name} lam)")
apply(simp add: supp_Abs)
apply(simp (no_asm) add: supp_def permute_set_eq atom_eqvt)
apply(simp add: Lam_pseudo_inject)
apply(simp add: Abs_eq_iff)
apply(simp add: alpha_gen.simps)
apply(simp add: supp_eqvt[symmetric] fv_eqvt[symmetric])
done

lemma lam_supp2:
  shows "supp (Lam x t) = supp (Abs {atom x} t)"
apply(simp add: supp_def permute_set_eq atom_eqvt)
apply(simp add: Lam_pseudo_inject)
apply(simp add: Abs_eq_iff)
apply(simp add: alpha_gen  supp_fv)
done

lemma lam_supp:
  shows "supp (Lam x t) = ((supp t) - {atom x})"
apply(simp add: lam_supp2)
apply(simp add: supp_Abs)
done

lemma fresh_lam:
  "(atom a \<sharp> Lam b t) \<longleftrightarrow> (a = b) \<or> (a \<noteq> b \<and> atom a \<sharp> t)"
apply(simp add: fresh_def)
apply(simp add: lam_supp)
apply(auto)
done

lemma lam_induct_strong:
  fixes a::"'a::fs"
  assumes a1: "\<And>name b. P b (Var name)"
  and     a2: "\<And>lam1 lam2 b. \<lbrakk>\<And>c. P c lam1; \<And>c. P c lam2\<rbrakk> \<Longrightarrow> P b (App lam1 lam2)"
  and     a3: "\<And>name lam b. \<lbrakk>\<And>c. P c lam; (atom name) \<sharp> b\<rbrakk> \<Longrightarrow> P b (Lam name lam)"
  shows "P a lam"
proof -
  have "\<And>pi a. P a (pi \<bullet> lam)"
  proof (induct lam rule: lam_induct)
    case (1 name pi)
    show "P a (pi \<bullet> Var name)"
      apply (simp)
      apply (rule a1)
      done
  next
    case (2 lam1 lam2 pi)
    have b1: "\<And>pi a. P a (pi \<bullet> lam1)" by fact
    have b2: "\<And>pi a. P a (pi \<bullet> lam2)" by fact
    show "P a (pi \<bullet> App lam1 lam2)"
      apply (simp)
      apply (rule a2)
      apply (rule b1)
      apply (rule b2)
      done
  next
    case (3 name lam pi a)
    have b: "\<And>pi a. P a (pi \<bullet> lam)" by fact
    obtain c::name where fr: "atom c\<sharp>(a, pi\<bullet>name, pi\<bullet>lam)"
      apply(rule obtain_atom)
      apply(auto)
      sorry
    from b fr have p: "P a (Lam c (((c \<leftrightarrow> (pi \<bullet> name)) + pi)\<bullet>lam))"
      apply -
      apply(rule a3)
      apply(blast)
      apply(simp add: fresh_Pair)
      done
    have eq: "(atom c \<rightleftharpoons> atom (pi\<bullet>name)) \<bullet> Lam (pi \<bullet> name) (pi \<bullet> lam) = Lam (pi \<bullet> name) (pi \<bullet> lam)"
      apply(rule swap_fresh_fresh)
      using fr
      apply(simp add: fresh_lam fresh_Pair)
      apply(simp add: fresh_lam fresh_Pair)
      done
    show "P a (pi \<bullet> Lam name lam)"
      apply (simp)
      apply(subst eq[symmetric])
      using p
      apply(simp only: permute_lam)
      apply(simp add: flip_def)
      done
  qed
  then have "P a (0 \<bullet> lam)" by blast
  then show "P a lam" by simp
qed

lemma var_fresh:
  fixes a::"name"
  shows "(atom a \<sharp> (Var b)) = (atom a \<sharp> b)"
  apply(simp add: fresh_def)
  apply(simp add: var_supp1)
  done

end


theory T123
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


section \<open>Additions to Separation Algebra Library\<close>
theory Sep_Algebra_Add
imports "Separation_Algebra.Sep_Tactics"
begin

no_notation pred_K ("\<langle>_\<rangle>")

subsection \<open>Simp-Lemmas for Separation Algebra\<close>

named_theorems sep_algebra_simps \<open>Advanced simplification lemmas for separation algebra\<close>

lemmas [sep_algebra_simps] = sep_conj_exists sep_add_ac
lemmas [simp] = sep_conj_assoc

lemmas sep_conj_c = sep_conj_commute sep_conj_left_commute

lemmas sep_conj_aci = sep_conj_ac sep_conj_empty sep_conj_empty'

subsection \<open>Separation Algebra with a Unique Zero\<close>

class unique_zero_sep_algebra = stronger_sep_algebra +
  assumes unique_zero: "x##x \<Longrightarrow> x=0"
begin
  lemma unique_zero_simps[simp]:
    "a##a \<longleftrightarrow> a=0"
    "a##b \<Longrightarrow> a+b = a \<longleftrightarrow> b=0"
    "a##b \<Longrightarrow> a+b = b \<longleftrightarrow> a=0"
    "a##b \<Longrightarrow> a + b = 0 \<longleftrightarrow> a=0 \<and> b=0"
    apply -
    using local.sep_disj_zero local.unique_zero apply blast
    apply (metis local.sep_add_disjD local.sep_add_zero local.unique_zero)
    apply (metis local.sep_add_disjD local.sep_add_zero_sym local.sep_disj_commute local.unique_zero)
    by (metis local.sep_add_disjD local.sep_add_zero local.sep_disj_zero local.unique_zero)

end

subsection \<open>Standard Instantiations\<close>

instantiation "fun" :: (type,stronger_sep_algebra) stronger_sep_algebra
begin
  definition "f1 ## f2 \<longleftrightarrow> (\<forall>x. f1 x ## f2 x)"
  definition [simp]: "(f1 + f2) x = (f1 x + f2 x)"
  definition [simp]: "0 x \<equiv> 0"

  instance
    apply standard
    unfolding sep_disj_fun_def plus_fun_def zero_fun_def
    apply (auto)
    subgoal
      by (simp add: sep_disj_commute)
    subgoal
      using sep_add_commute by auto
    subgoal
      by (simp add: sep_add_assoc)
    (*subgoal
      using sep_disj_addD1 by blast
    subgoal
      by (simp add: sep_disj_addI1)
    *)
    done

end

instance "fun" :: (type,unique_zero_sep_algebra) unique_zero_sep_algebra
  apply standard
  unfolding sep_disj_fun_def plus_fun_def zero_fun_def
  by (metis unique_zero)

lemma disj_fun_upd_iff[simp]:
  "\<lbrakk>f a = 0; g a = 0\<rbrakk> \<Longrightarrow> (f(a:=x) ## g(a:=y)) \<longleftrightarrow> (f ## g \<and> x ## y)"
  unfolding sep_disj_fun_def by force

lemma fun_upd_Z_Z[simp]: "fun_upd 0 i 0 = 0" by auto

lemma sep_disj_fun_updI[sep_algebra_simps, intro]: "\<lbrakk>f##g; a##b\<rbrakk> \<Longrightarrow> f(x:=a) ## g(x:=b)"
  by (simp add: sep_disj_fun_def)

lemma sep_disj_fun_Zupd_eq[sep_algebra_simps]:
  "f##0(x:=y) \<longleftrightarrow> f x ## y"
  "0(x:=y) ## f \<longleftrightarrow> y ## f x"
  by (auto simp add: sep_disj_fun_def)

lemma sep_disj_funD: "f##g \<Longrightarrow> f x ## g x" by (auto simp: sep_disj_fun_def)

lemma merge_fun_singleton: "fun_upd 0 i a + fun_upd 0 i b = fun_upd 0 i (a+b)" by auto

lemma split_fun_upd_0: "fun_upd (a+b) i 0 = fun_upd a i 0 + fun_upd b i 0" by auto

instantiation option :: (stronger_sep_algebra) stronger_sep_algebra begin

  fun sep_disj_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool" where
    "sep_disj None None \<longleftrightarrow> True"
  | "sep_disj None (Some _) \<longleftrightarrow> True"
  | "sep_disj (Some _) None \<longleftrightarrow> True"
  | "sep_disj (Some x) (Some y) \<longleftrightarrow> x##y"

  lemma sep_disj_option_add_simps[simp]:
    "sep_disj None x"
    "sep_disj x None"
    by (cases x; simp)+

  fun plus_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> 'a option" where
    "plus None None = None"
  | "plus None (Some x) = Some x"
  | "plus (Some x) None = Some x"
  | "plus (Some x) (Some y) = Some (x+y)"

  lemma plus_option_add_simps[simp]: "plus None x = x" "plus x None = x"
    by (cases x; simp)+

  definition "0 = None"

  instance
    apply standard
    apply (simp_all add: zero_option_def)
    apply (case_tac x; case_tac y; simp add: sep_disj_commute)
    apply (case_tac x; case_tac y; auto simp add: sep_disj_commute sep_add_commute)
    apply (case_tac x; case_tac y; case_tac z; simp add: sep_add_assoc)
    apply (case_tac x; case_tac y; case_tac z; auto dest: sep_disj_addD1)
    (*apply (case_tac x; case_tac y; case_tac z; auto dest: sep_disj_addI1)*)
    done

end

instantiation prod :: (stronger_sep_algebra, stronger_sep_algebra) stronger_sep_algebra
begin
  definition "a##b \<longleftrightarrow> fst a ## fst b \<and> snd a ## snd b"
  definition "a+b = (fst a + fst b, snd a + snd b)"
  definition "0 = (0,0)"

  instance
    apply standard
    unfolding sep_disj_prod_def plus_prod_def zero_prod_def
    by (auto
      simp: sep_add_ac
      intro: sep_disj_commuteI sep_disj_addD1 sep_disj_addI1)
end

lemma sep_disj_prod_lower[sep_algebra_simps]: "(a,b) ## (c,d) \<longleftrightarrow> a##c \<and> b##d"
  by (simp add: sep_disj_prod_def)

lemma plus_prod_lower[sep_algebra_simps]: "(a,b) + (c,d) = (a+c,b+d)"
  by (simp add: plus_prod_def)

instance prod :: (unique_zero_sep_algebra,unique_zero_sep_algebra) unique_zero_sep_algebra
  by standard (auto simp: zero_prod_def sep_algebra_simps)

lemma prod_Z_lower[sep_algebra_simps]:
  "(a,b) = 0 \<longleftrightarrow> a=0 \<and> b=0"
  "0 = (a,b) \<longleftrightarrow> a=0 \<and> b=0"
  by (auto simp: zero_prod_def)

lemma plus_prod_eqI: "(a+b,c+d) = (a,c) + (b,d)" by (simp add: sep_algebra_simps)

lemma fst_Z[simp]: "fst 0 = 0" by (simp add: zero_prod_def)
lemma snd_Z[simp]: "snd 0 = 0" by (simp add: zero_prod_def)

lemma fst_plus[sep_algebra_simps]: "fst (a+b) = fst a + fst b" by (auto simp: plus_prod_def)
lemma snd_plus[sep_algebra_simps]: "snd (a+b) = snd a + snd b" by (auto simp: plus_prod_def)
lemma disj_fstI[sep_algebra_simps]: "a##b \<Longrightarrow> fst a ## fst b" by (auto simp: sep_disj_prod_def)
lemma disj_sndI[sep_algebra_simps]: "a##b \<Longrightarrow> snd a ## snd b" by (auto simp: sep_disj_prod_def)

datatype 'a tsa_opt = ZERO | TRIV (the_tsa: 'a)

instantiation tsa_opt :: (type) unique_zero_sep_algebra begin
  definition sep_disj_tsa_opt :: "'a tsa_opt \<Rightarrow> 'a tsa_opt \<Rightarrow> bool"
    where "a##b \<longleftrightarrow> a=ZERO \<or> b=ZERO"

  definition "a+b \<equiv> (case (a,b) of (ZERO,x) \<Rightarrow> x | (x,ZERO) \<Rightarrow> x)"
  definition "0 = ZERO"

  instance
    apply standard
    by (auto simp: zero_tsa_opt_def sep_disj_tsa_opt_def plus_tsa_opt_def split: tsa_opt.splits)

end

instance tsa_opt :: (type) cancellative_sep_algebra
  apply standard
  by (auto simp: zero_tsa_opt_def sep_disj_tsa_opt_def plus_tsa_opt_def split: tsa_opt.splits)

(* Lowering lemmas. If one side of operation breaks abstraction level,
  the other side is also lowered
*)
lemma TRIV_not_zero[simp]: "TRIV x \<noteq> 0" "0\<noteq>TRIV x" by (auto simp: zero_tsa_opt_def)
lemma TRIV_Z_lower[intro!]:
  "ZERO = 0"
  "0 = ZERO"
  by (auto simp: zero_tsa_opt_def)

lemma triv_Z_lower2[sep_algebra_simps]:
  "x + ZERO = x"
  "ZERO + x = x"
  by (auto simp: zero_tsa_opt_def plus_tsa_opt_def split: tsa_opt.splits)

lemma TRIV_disj_simps[sep_algebra_simps]:
  "TRIV a ## b \<longleftrightarrow> b=ZERO"
  "b ## TRIV a \<longleftrightarrow> b=ZERO"
  by (auto simp: sep_disj_tsa_opt_def)

subsection \<open>Additional Simplifier Setup\<close>

(*
  This may cause trouble on non-eta-normalized terms.
    (\<lambda>s. \<box> s) \<rightarrow> \<lambda>s. s=0
  The next lemma hopefully fixes that.
*)

lemma sep_empty_app[sep_algebra_simps]: "\<box> h \<longleftrightarrow> h=0"
  by (simp add: sep_empty_def)

lemma sep_empty_I[sep_algebra_simps]: "(\<lambda>h. h=0) = \<box>"
  by (simp add: sep_empty_def)

lemma sep_triv_ineqs[simp]:
  "\<box> \<noteq> sep_false"
  "sep_true \<noteq> sep_false"
  "sep_false \<noteq> \<box>"
  "sep_false \<noteq> sep_true"
  by (auto dest: fun_cong)

lemma sep_true_not_empty:
  assumes "(a::'a::sep_algebra) \<noteq> (b::'a)"
  shows "(\<box>::'a\<Rightarrow>bool) \<noteq> sep_true"
  by (metis (mono_tags, lifting) assms sep_empty_I)

subsection \<open>Pure Assertions\<close>

text \<open>The Separation Algebra entry only defines @{term "pred_K \<Phi>"}, which
  makes no constraint on the heap. We define \<open>\<up>\<Phi>\<close>, which requires an empty heap,
  and is more natural when using separation logic with deallocation.
\<close>

definition pred_lift :: "bool \<Rightarrow> 'a::sep_algebra \<Rightarrow> bool" ("\<up>_" [100] 100)
  where "(\<up>\<Phi>) s \<equiv> \<Phi> \<and> \<box> s"

text \<open>Relation between \<open>pred_lift\<close> and \<open>pred_K\<close>. Warning, do not use
  as simp-lemma, as \<open>sep_true\<close> is an abbreviation for \<open>\<langle>True\<rangle>\<close>\<close>
lemma "pred_K \<Phi> = (\<up>\<Phi> ** sep_true)" by (auto simp: pred_lift_def sep_conj_def sep_algebra_simps)

lemma pred_lift_move_front_simps[sep_algebra_simps]:
  "(\<up>\<Phi> ** \<up>\<Psi>) = (\<up>(\<Phi>\<and>\<Psi>))"
  "(\<up>\<Phi> ** \<up>\<Psi> ** B) = (\<up>(\<Phi>\<and>\<Psi>) ** B)"
  "NO_MATCH (\<up>X) A \<Longrightarrow> (A ** \<up>\<Phi> ** B) = (\<up>\<Phi> ** A ** B)"
  "NO_MATCH (\<up>X) A \<Longrightarrow> (A ** \<up>\<Phi>) = (\<up>\<Phi> ** A)"
  by (auto simp: pred_lift_def sep_conj_def sep_algebra_simps)

lemma pred_lift_extract_simps:
  "(\<up>\<Phi>) h \<longleftrightarrow> \<Phi> \<and> h=0"
  "(\<up>\<Phi> ** A) h \<longleftrightarrow> \<Phi> \<and> A h"
  by (auto simp: pred_lift_def sep_conj_def sep_algebra_simps)

lemma pure_true_conv[sep_algebra_simps]: "\<up>True = \<box>" by (auto simp: sep_algebra_simps pred_lift_extract_simps)

lemma pred_lift_false_conv[simp]: "\<up>False = sep_false" by (auto simp: sep_algebra_simps pred_lift_extract_simps)

lemma pure_assn_eq_conv[simp]: "(\<up>\<Phi>) = (\<up>\<Psi>) \<longleftrightarrow> \<Phi>=\<Psi>"
  by (smt pred_lift_extract_simps(1))

lemmas sep_conj_false_simps =
  pred_lift_false_conv
  sep_conj_false_left sep_conj_false_right

definition sep_is_pure_assn :: "('a::sep_algebra \<Rightarrow> bool) \<Rightarrow> bool" where
  "sep_is_pure_assn A \<equiv> \<forall>s. A s \<longrightarrow> s=0"

definition pure_part :: "('a::sep_algebra \<Rightarrow> bool) \<Rightarrow> bool" where
  "pure_part A \<equiv> Ex A"

lemma pure_partI: "A s \<Longrightarrow> pure_part A" by (auto simp: pure_part_def)

lemma pure_part_pure_eq[simp]: "sep_is_pure_assn A \<Longrightarrow> \<up>pure_part A = A"
  apply (rule ext)
  by (auto simp: sep_is_pure_assn_def pure_part_def pred_lift_def sep_algebra_simps)

lemma pure_part_triv_simps[simp]:
  "\<not>pure_part sep_false"
  "pure_part \<box>"
  by (auto simp: pure_part_def)

lemma pure_part_pure[simp]: "pure_part (\<up>\<Phi>) = \<Phi>"
  by (auto simp: pure_part_def sep_algebra_simps pred_lift_def)

lemma pure_part_split_conj: "pure_part (A**B) \<Longrightarrow> pure_part A \<and> pure_part B"
  by (auto simp: pure_part_def sep_conj_def)

lemma sep_is_pure_lift_pred[simp]: "sep_is_pure_assn (\<up>\<Phi>)"
  by (auto simp: sep_is_pure_assn_def pred_lift_def sep_algebra_simps)

lemma sep_is_pure_assn_false[simp]: "sep_is_pure_assn sep_false" by (auto simp: sep_is_pure_assn_def)
lemma sep_is_pure_assn_empty[simp]: "sep_is_pure_assn \<box>" by (auto simp: sep_is_pure_assn_def sep_algebra_simps)

lemma sep_is_pure_assn_conjI: "sep_is_pure_assn A \<Longrightarrow> sep_is_pure_assn B \<Longrightarrow> sep_is_pure_assn (A**B)"
  by (auto simp: sep_is_pure_assn_def sep_conj_def)

lemma pure_part_pure_conj_eq: "pure_part (\<up>P ** Q) \<longleftrightarrow> P \<and> pure_part Q"
  unfolding pure_part_def by (auto simp: sep_algebra_simps pred_lift_extract_simps)

subsection \<open>Exact Assertion\<close>

definition EXACT :: "'a::sep_algebra \<Rightarrow> 'a \<Rightarrow> bool" where [simp]: "EXACT h h' \<equiv> h'=h"
lemma strictly_exact_EXACT[simp]: "strictly_exact (EXACT h)"
  unfolding EXACT_def by (auto intro: strictly_exactI)

lemma EXACT_split: "a##b \<Longrightarrow> EXACT (a+b) = (EXACT a ** EXACT b)"
  unfolding EXACT_def sep_conj_def by auto

lemma EXACT_zero[simp]: "EXACT 0 = \<box>" by (auto simp: sep_algebra_simps)

lemma EXACT_eq_iff[simp]: "EXACT a = EXACT b \<longleftrightarrow> a=b"
  unfolding EXACT_def by metis

subsection \<open>List-Sum over Separation Algebra\<close>

(* TODO: Move. Clean up *)

definition "sepsum_list l \<equiv> foldr (+) l (0::_::stronger_sep_algebra)"

lemma sepsum_list_simps[simp]:
  "sepsum_list [] = 0"
  "sepsum_list (x#xs) = x + sepsum_list xs"
  by (auto simp: sepsum_list_def)

context begin

private named_theorems ss

private definition "sep_ldisj1 x ys \<equiv> \<forall>y\<in>List.set ys. x##y"

private lemma sep_ldisj1_simps[ss]:
  "sep_ldisj1 x []"
  "sep_ldisj1 x (y#ys) \<longleftrightarrow> x##y \<and> sep_ldisj1 x ys"
  by (auto simp: sep_ldisj1_def)

private lemma sep_ldisj1_append[ss]: "sep_ldisj1 x (ys\<^sub>1@ys\<^sub>2) \<longleftrightarrow> sep_ldisj1 x ys\<^sub>1 \<and> sep_ldisj1 x ys\<^sub>2"
  by (induction ys\<^sub>1) (auto simp: ss)

private definition "sep_ldisj xs ys \<equiv> \<forall>x\<in>List.set xs. sep_ldisj1 x ys"

private lemma sep_ldisj_simps[ss]:
  "sep_ldisj [] ys"
  "sep_ldisj xs []"
  "sep_ldisj (x#xs) ys \<longleftrightarrow> sep_ldisj1 x ys \<and> sep_ldisj xs ys"
  "sep_ldisj xs (y#ys) \<longleftrightarrow> sep_ldisj1 y xs \<and> sep_ldisj xs ys"
  by (auto simp: sep_ldisj_def sep_ldisj1_def sep_algebra_simps)

private lemma sep_ldisj_append1[ss]: "sep_ldisj (xs\<^sub>1@xs\<^sub>2) ys \<longleftrightarrow> sep_ldisj xs\<^sub>1 ys \<and> sep_ldisj xs\<^sub>2 ys"
  by (induction xs\<^sub>1) (auto simp: ss)

private lemma sep_ldisj_append2[ss]: "sep_ldisj xs (ys\<^sub>1@ys\<^sub>2) \<longleftrightarrow> sep_ldisj xs ys\<^sub>1 \<and> sep_ldisj xs ys\<^sub>2"
  by (induction ys\<^sub>1) (auto simp: ss)

private lemma sep_ldisj_commute[sep_algebra_simps]: "sep_ldisj xs ys \<longleftrightarrow> sep_ldisj ys xs"
  by (force simp: sep_ldisj_def sep_ldisj1_def sep_algebra_simps)

fun sep_distinct :: "_::stronger_sep_algebra list \<Rightarrow> bool" where
  "sep_distinct [] \<longleftrightarrow> True"
| "sep_distinct (x#xs) \<longleftrightarrow> sep_ldisj1 x xs \<and> sep_distinct xs"

declare sep_distinct.simps[simp del, ss add]

private lemma sep_distinct_append_aux[ss]:
  "sep_distinct (xs@ys) \<longleftrightarrow> sep_distinct xs \<and> sep_distinct ys \<and> sep_ldisj xs ys"
  by (induction xs) (auto simp: ss)

private lemma norm_ldisj1[ss]: "sep_distinct ys \<Longrightarrow> sep_ldisj1 x ys \<longleftrightarrow> x ## sepsum_list ys"
  by (induction ys arbitrary: x) (auto simp: ss)

private lemma norm_ldisj[ss]: "sep_distinct xs \<Longrightarrow> sep_distinct ys \<Longrightarrow> sep_ldisj xs ys \<longleftrightarrow> sepsum_list xs ## sepsum_list ys"
  by (induction xs) (auto simp: ss)

lemma sep_distinct_append[simp]:
  "sep_distinct (xs@ys) \<longleftrightarrow> sep_distinct xs \<and> sep_distinct ys \<and> sepsum_list xs ## sepsum_list ys"
  by (auto simp: ss)

lemma sepsum_append[simp]: "sep_distinct (xs@ys) \<Longrightarrow> sepsum_list (xs@ys) = sepsum_list xs + sepsum_list ys"
  by (induction xs) (auto simp: sep_algebra_simps ss)

lemma sep_distinct_simps[simp]:
  "sep_distinct []"
  "sep_distinct (x#xs) \<longleftrightarrow> x ## sepsum_list xs \<and> sep_distinct xs"
  by (auto simp: ss)

end

subsection \<open>Finite Assertion Families\<close>
interpretation sep_folding: folding "\<lambda>i Q. P i ** Q" \<box> for P
  apply unfold_locales
  apply (intro ext)
  apply (simp add: sep.add_ac)
  done

definition "sep_set_img S P \<equiv> \<up>(finite S) ** sep_folding.F P S"

syntax
  "_SEP_SET_IMG"      :: "pttrn => 'a set => ('b \<Rightarrow> bool) => ('b \<Rightarrow> bool)"  ("(3\<Union>*_\<in>_./ _)" [0, 0, 10] 10)

translations
  "\<Union>*x\<in>A. B"   \<rightleftharpoons> "CONST sep_set_img A (\<lambda>x. B)"

print_translation \<open>
  [Syntax_Trans.preserve_binder_abs2_tr' @{const_syntax sep_set_img} @{syntax_const "_SEP_SET_IMG"}]
\<close> \<comment> \<open>to avoid eta-contraction of body\<close>

lemma sep_set_img_infinite[simp]: "infinite I \<Longrightarrow> sep_set_img I P = sep_false"
  unfolding sep_set_img_def by auto

lemma sep_set_img_empty[simp]: "sep_set_img {} P = \<box>"
  and sep_set_img_insert_remove: "sep_set_img (insert x S) P = (P x ** sep_set_img (S-{x}) P)"
  and sep_set_img_insert[simp]: "x\<notin>S \<Longrightarrow> sep_set_img (insert x S) P = (P x ** sep_set_img S P)"
  and sep_set_img_remove: "x\<in>S \<Longrightarrow> sep_set_img S P = (P x ** sep_set_img (S-{x}) P)"
  by (auto
    simp: sep_set_img_def sep_algebra_simps pred_lift_extract_simps sep_folding.insert_remove sep_folding.remove
    del: ext intro!: ext)

lemma sep_set_img_cong:
  assumes [simp]: "I=I'"
  assumes P: "\<And>x. finite I' \<Longrightarrow> x\<in>I' \<Longrightarrow> P x = P' x"
  shows "sep_set_img I P = sep_set_img I' P'"
proof -
  {
    assume "finite I'"
    then have "sep_set_img I' P = sep_set_img I' P'" using P
      by induction auto
  }
  then show ?thesis by (cases "finite I'") auto
qed

lemma sep_set_img_cong_strong[cong]:
  assumes [simp]: "I=I'"
  assumes P: "\<And>x. finite I' =simp=> x\<in>I' =simp=> P x = P' x"
  shows "sep_set_img I P = sep_set_img I' P'"
  using assms
  unfolding simp_implies_def
  by (rule sep_set_img_cong)

lemma sep_set_img_union[simp]:
  assumes "S\<^sub>1\<inter>S\<^sub>2={}"
  shows "sep_set_img (S\<^sub>1\<union>S\<^sub>2) P = (sep_set_img S\<^sub>1 P ** sep_set_img S\<^sub>2 P)"
proof -
  {
    assume "finite S\<^sub>1"
    then have ?thesis using assms
      by (induction S\<^sub>1) auto
  }
  then show ?thesis by (cases "finite S\<^sub>1") auto

qed

lemmas sep_set_img_ins[simp] = sep_set_img_union[where S\<^sub>1="{i}", simplified] for i

lemma sep_set_img_unionI':
  assumes NDUP: "\<And>x. \<lbrakk>x\<in>S\<^sub>2 \<rbrakk> \<Longrightarrow> (P x ** P x) = sep_false"
  assumes P: "(sep_set_img S\<^sub>1 P ** sep_set_img S\<^sub>2 P) s"
  shows "sep_set_img (S\<^sub>1\<union>S\<^sub>2) P s"
proof -

  have A: "(P x ** P x ** F) = sep_false" if "x\<in>S\<^sub>2" for x F
    using assms
    by (simp add: sep.mult_commute sep_conj_left_commute that)

  {
    assume "finite S\<^sub>1"
    then have "?thesis" using P
    proof (induction S\<^sub>1 arbitrary: s)
      case empty
      then show ?case by simp
    next
      case (insert x S\<^sub>1)
      then show ?case
        apply (cases "x\<notin>S\<^sub>2")
        apply (auto simp: sep_set_img_remove sep_set_img_insert_remove sep_algebra_simps sep_conj_impl)
        by (simp add: A sep_conj_left_commute)
    qed
  }
  then show ?thesis using P by (cases "finite S\<^sub>1") auto
qed

lemma sep_set_img_pull_EXS: "(\<Union>*x\<in>I. EXS y. f x y) = (EXS Y. \<Union>*x\<in>I. f x (Y x))"
proof -
  {
    assume "finite I"
    then have ?thesis
      apply (induction I)
      apply simp
      apply (rule ext)
      apply (clarsimp simp: sep_algebra_simps; safe)
      subgoal for x F s xa xb
        apply (rule exI[where x="xb(x:=xa)"])
        apply auto
        by (smt sep_set_img_cong)
      subgoal by auto
      done
  }
  then show ?thesis by (cases "finite I") auto
qed

lemma list_conj_eq_sep_set_img: "distinct xs \<Longrightarrow> (\<And>*map P xs) = sep_set_img (List.set xs) P"
  by (induction xs) auto

lemma sep_is_pure_assn_imgI:
  assumes "\<And>i. i\<in>I \<Longrightarrow> sep_is_pure_assn (f i)"
  shows "sep_is_pure_assn (\<Union>*i\<in>I. f i)"
proof (cases "finite I")
  assume "finite I"
  then show ?thesis using assms
    by (induction I) (auto simp: sep_is_pure_assn_conjI)
qed simp

end


section \<open>\isaheader{Simple DFS Algorithm}\<close>
theory Simple_DFS
imports
  Collections.Refine_Dflt
begin

section \<open>Graphs Implemented by Successor Function\<close>
subsection \<open>Refinement relation\<close>
definition "E_of_succ succ \<equiv> {(u,v). v\<in>succ u}"
definition [to_relAPP]: "succg_rel R \<equiv> (R \<rightarrow> \<langle>R\<rangle>list_set_rel) O br E_of_succ (\<lambda>_. True)"

consts i_graph :: "interface \<Rightarrow> interface"
  \<comment> \<open>Define the conceptual type of graphs.\<close>

lemmas [autoref_rel_intf] = REL_INTFI[of "succg_rel" i_graph]
  \<comment> \<open>Declare \<open>succg_rel\<close> to be a relator for graphs.\<close>

lemma in_id_succg_rel_iff: "(s,E)\<in>\<langle>Id\<rangle>succg_rel \<longleftrightarrow> (\<forall>v. distinct (s v) \<and> set (s v) = E``{v})"
  \<comment> \<open>Simplification in case of identity refinements for nodes\<close>
  unfolding succg_rel_def br_def E_of_succ_def list_set_rel_def
  by (auto; force dest: fun_relD)

subsection \<open>Successor Operation\<close>
definition [simp]: "op_succ E u \<equiv> E``{u}"
  \<comment> \<open>Define the abstract successor operation.\<close>

context begin interpretation autoref_syn .

lemma refine_succg_succs[autoref_rules]:
  "(\<lambda>succs v. succs v,op_succ)\<in>\<langle>R\<rangle>succg_rel\<rightarrow>R\<rightarrow>\<langle>R\<rangle>list_set_rel"
  \<comment> \<open>Declare implementation of successor function to Autoref.\<close>
  apply (intro fun_relI)
  apply (auto simp add: succg_rel_def br_def E_of_succ_def dest: fun_relD)
  done

section \<open>DFS Algorithm\<close>
text \<open>
  We define a simple DFS-algorithm, prove a simple correctness
  property, and do data refinement to an efficient implementation.
\<close>

subsection \<open>Definition\<close>

text \<open>Recursive DFS-Algorithm.
  \<open>E\<close> is the edge relation of the graph, \<open>tgt\<close> the node to
  search for, and \<open>src\<close> the start node.
  Already explored nodes are
  stored in \<open>V\<close>.\<close>

context
  fixes E :: "('v\<times>'v) set" and src :: 'v and tgt :: 'v
begin
  definition dfs :: "bool nres" where
    "dfs \<equiv> do {
      (_,r) \<leftarrow> RECT (\<lambda>dfs (V,v).
        if v=tgt then RETURN (V,True)
        else do {
          let V = insert v V;
          FOREACHc (E``{v}) (\<lambda>(V,brk). \<not>brk) (\<lambda>v' (V,brk).
            if v'\<notin>V then dfs (V,v') else RETURN (V,False)
          ) (V,False)
        }) ({},src);
      RETURN r
    }"

  definition "reachable \<equiv> {v. (src,v)\<in>E\<^sup>*}"

subsection \<open>Correctness Proof\<close>
  lemma dfs_correct:
    assumes FIN: "finite (E\<^sup>*``{src})"
    shows "dfs \<le> SPEC (\<lambda>r. r \<longleftrightarrow> (src,tgt)\<in>E\<^sup>*)"
  proof -
    from FIN have [simp, intro!]: "finite reachable"
      unfolding reachable_def by (auto simp: Image_def)

    text \<open>We first define the (inductive) pre and postconditions for
      the recursion, and the loop invariant\<close>

    define rpre where "rpre \<equiv> \<lambda>S (V,v).
        v\<in>reachable - V
      \<and> V\<subseteq>reachable
      \<and> S\<subseteq>V
      \<and> tgt\<notin>V
      \<and> E``(V-S) \<subseteq> V"

    define rpost where "rpost \<equiv> \<lambda>S (V,v) (V',r).
          (r\<longrightarrow>tgt\<in>reachable)
        \<and> (\<not>r \<longrightarrow>
            tgt\<notin>V'
          \<and> V\<subseteq>V'
          \<and> v\<in>V'
          \<and> V'\<subseteq>reachable
          \<and> E``(V'-S) \<subseteq> V'
          )
      "

    define fe_inv where "fe_inv \<equiv> \<lambda>S V v it (V',r).
        (r\<longrightarrow>tgt\<in>reachable)
      \<and> (\<not>r \<longrightarrow>
          tgt \<notin> V'
        \<and> insert v V\<subseteq>V'
        \<and> E``{v} - it \<subseteq> V'
        \<and> V'\<subseteq>reachable
        \<and> S\<subseteq>insert v V
        \<and> E``(V'-S) \<subseteq> V' \<union> it
        \<and> E``(V'-insert v S) \<subseteq> V'
        )"

    text \<open>Then we prove the verification conditions that our VCG will generate as separate facts.
      Of course, the workflow is to first let run the VCG, and then extract these facts from
      its output. This way, we can make explicit the ideas of the proof, and present them separately
      from the mainly technical VC generation.
     \<close>

    have vc_pre_initial: "rpre {} ({}, src)"
      by (auto simp: rpre_def reachable_def)

    {
      (* Case: Found node *)
      fix S V
      assume "rpre S (V,tgt)"
      hence "rpost S (V,tgt) (insert tgt V, True)"
        unfolding rpre_def rpost_def
        by auto
    } note vc_node_found = this

    { (* The set of nodes that the foreach loop iterates over is finite *)
      fix S V v
      assume "rpre S (V, v)"
      hence "finite (E``{v})"
        unfolding rpre_def reachable_def
        using FIN
        apply auto
        by (meson finite_Image_subset finite_reachable_advance r_le_rtrancl)
    } note vc_foreach_finite = this

    {
      (* fe_inv initial *)
      fix S V v
      assume A: "v \<notin> V" "v \<noteq> tgt"
        and PRE: "rpre S (V, v)"
      hence "fe_inv S V v (E``{v}) (insert v V, False)"
        unfolding fe_inv_def rpre_def by (auto simp: )
    } note vc_enter_foreach = this

    {
      (* fe_inv ensures rpre *)
      fix S V v v' it V'
      assume A: "v'\<notin>V'" "v' \<in> it" "it \<subseteq> E``{v}"
        and FEI: "fe_inv S V v it (V', False)"
        and PRE: "rpre S (V, v)"

      from A have "(v,v')\<in>E" by auto
      moreover from PRE have "v \<in> reachable" by (auto simp: rpre_def)
      hence "E``{v} \<subseteq> reachable" by (auto simp: reachable_def)
      ultimately have [simp]: "v'\<in>reachable" by blast

      from A FEI PRE have "rpre (insert v S) (V', v')"
        unfolding rpre_def fe_inv_def by auto
    } note vc_rec_pre = this

    {
      (* rpost implies fe_inv *)
      fix S V V' v v' it Vr''
      assume "fe_inv S V v it (V', False)"
        and "rpost (insert v S) (V', v') Vr''"
      hence "fe_inv S V v (it - {v'}) Vr''"
        unfolding rpre_def rpost_def fe_inv_def by clarsimp (auto; blast)
    } note vc_iterate_foreach = this

    { (* Recursive call in variant relation *)
      fix S V V' v it
      assume "rpre S (V, v)"
      and "fe_inv S V v it (V', False)"
      hence "(V',V)\<in>finite_psupset local.reachable"
        unfolding fe_inv_def rpre_def
        by (auto simp: finite_psupset_def)

    } note vc_rec_var = this

    {
      (* fe_inv preserved if ignoring visitied node*)
      fix S V V' v v' it Vr''
      assume "fe_inv S V v it (V', False)"
        and "v'\<in>V'"
      hence "fe_inv S V v (it - {v'}) (V', False)"
        unfolding fe_inv_def by auto
    } note vc_foreach_ignore = this

    {
      (* fe_inv (completed) implies rpost *)
      fix S V v V'
      assume FEI: "fe_inv S V v {} (V', False)"
      have "rpost S (V, v) (V', False)"
        unfolding rpost_def
        using FEI by (auto simp: fe_inv_def) []
    } note vc_foreach_completed_imp_post = this

    {
      (* fe_inv (interrupted) implies rpost *)
      fix S V v V' it
      assume FEI: "fe_inv S V v it (V', True)"
      hence "rpost S (V, v) (V', True)"
        by (auto simp add: rpost_def fe_inv_def) []
    } note vc_foreach_interrupted_imp_post = this

    { (* The postcondition of the recursion implies our desired specification *)
      fix V r
      assume "rpost {} ({}, src) (V, r)"
      hence "r = ((src, tgt) \<in> E\<^sup>*)"
        by (auto
          simp: rpost_def reachable_def
          dest: Image_closed_trancl
          intro: rev_ImageI)
    } note vc_rpost_imp_spec = this

    text \<open>The verification condition generation is technical. We invoke the VCG,
      and discharge the generated VCs. The trivial ones are discharged on the spot, the
      more complicated ones have been extracted to separate facts, that we use in the proof
      text below.
    \<close>
    show ?thesis
      unfolding dfs_def
      apply (refine_vcg RECT_rule_arb[
        where
              pre=rpre and arb="{}"
          and M="\<lambda>a x. SPEC (rpost a x)"
          and V="inv_image (finite_psupset reachable) fst",
        THEN order_trans
        ])
      subgoal by blast  (* Well-Foundedness  *)
      subgoal by (rule vc_pre_initial)
      subgoal by (auto simp add: rpre_def rpost_def) (* Found tgt node *)

      subgoal for f S _ V v (* Entering inner FOREACH loop *)
        apply (refine_rcg refine_vcg
          FOREACHc_rule'[where I="fe_inv S V v" (*for S V*)]
          )
        apply clarsimp_all

        subgoal by (simp add: vc_foreach_finite) (* Finiteness of iteration set *)

        subgoal by (rule vc_enter_foreach) (simp add: rpre_def) (* Loop invar holds initially*)
        subgoal (* Loop invar preserved by inner recursion *)
          apply (rule order_trans, rprems)   (* Applying recursion induction hypothesis *)
          apply (erule (4) vc_rec_pre; fail) (* Precondition of inner recursion holds*)
          apply (simp add: vc_rec_var; fail) (* Parameters are smaller wrt termination ordering *)
          apply (auto simp: vc_iterate_foreach; fail) (* Postcondition of inner rec implies loop invar again  *)
          done

        subgoal by (rule vc_foreach_ignore; auto)  (* Node already visited: invariant is preserved *)
        subgoal by (auto simp: vc_foreach_completed_imp_post) (* Foreach loop terminated normally: Implies postcondition *)
        subgoal by (auto simp: vc_foreach_interrupted_imp_post) (* Foreach loop interrupted (tgt found): Implies postcondition *)
        done
      subgoal by (auto simp add: vc_rpost_imp_spec) (* Postcondition implies our specification *)
      done
    qed

end

subsection \<open>Data Refinement and Determinization\<close>

text \<open>
  Next, we use automatic data refinement and transfer to generate an
  executable algorithm. We fix the node-type to natural numbers,
  and the successor-function to return a list-set.
  The implementation of the visited set is left open, and Autoref's heuristics
  will choose one (default for nat set: red-black-trees).
\<close>

text \<open>In our first example, we use \<open>autoref_monadic\<close>, which combines the
  Autoref tool and the determinization of the Monadic Refinement Framework.\<close>

schematic_goal dfs_impl_refine_aux:
  fixes succi and E :: "('a::linorder \<times> 'a) set" and tgt src :: 'a
  assumes [autoref_rules]: "(succi,E)\<in>\<langle>Id\<rangle>succg_rel"
  notes [autoref_rules] = IdI[of src] IdI[of tgt]
  shows "RETURN (?f::?'c) \<le> \<Down>?R (dfs E src tgt)"
  unfolding dfs_def by autoref_monadic

text \<open>We define a new constant from the synthesis result\<close>
concrete_definition dfs_impl for succi src tgt uses dfs_impl_refine_aux
text \<open>Set up code equations for the recursion combinators\<close>
prepare_code_thms dfs_impl_def
text \<open>And export the algorithm to all supported target languages\<close>
export_code dfs_impl in Haskell
export_code dfs_impl checking SML OCaml? Haskell? Scala

text \<open>Chaining the refinement theorems, we get correctness arguments that
  are almost independent of the refinement framework:\<close>

lemma succ_ran_fin:
  assumes R: "(succi,E) \<in> \<langle>Rv\<rangle>succg_rel"
  assumes "v\<in>Range Rv"
  shows "finite (E``{v})"
  using assms
  unfolding succg_rel_def br_def E_of_succ_def
  apply clarsimp
  apply (drule (1) fun_relD)
  using list_set_rel_range[of Rv]
  by auto

lemma run_ran_aux:
  assumes R: "(succi,E) \<in> \<langle>Rv\<rangle>succg_rel"
  assumes REACH: "(src,v)\<in>E\<^sup>*"
  assumes R0: "(v0i,src) \<in> Rv"
  shows "v \<in> Range Rv"
  using REACH R0
proof (induction arbitrary: v0i rule: converse_rtrancl_induct)
  case base thus ?case by auto
next
  case (step src v')
  from \<open>(src, v') \<in> E\<close> have "v' \<in> Range Rv" using R list_set_rel_range[of Rv]
    apply (clarsimp simp: succg_rel_def br_def E_of_succ_def)
    apply (drule fun_relD[OF _ \<open>(v0i, src) \<in> Rv\<close>])
    by auto
  with step.IH show ?thesis by blast
qed

lemma run_ran_fin:
  assumes R: "(succi,E) \<in> \<langle>Rv\<rangle>succg_rel"
  assumes R0: "(v0i,src) \<in> Rv"
  shows "\<forall>v. (src,v)\<in>E\<^sup>* \<longrightarrow> finite (E``{v})"
  using succ_ran_fin run_ran_aux assms by metis

text \<open>Correctness theorem presented in the paper:\<close>
theorem dfs_code_correct:
  assumes SUCCI: "(succi,E)\<in>\<langle>Id\<rangle>succg_rel"
  assumes FIN: "finite (E\<^sup>*``{src})"
  shows "dfs_impl succi src tgt \<longleftrightarrow> (src,tgt)\<in>E\<^sup>*"
proof -
  note dfs_impl.refine[OF SUCCI, of src tgt]
  also note dfs_correct[OF FIN]
  finally show ?thesis by (auto simp: split: dres.split)
qed

subsubsection \<open>Using only Autoref\<close>

text \<open>Here we show the result of Autoref, without the determinization phase of
  the Monadic Refinement Framework: \<close>
schematic_goal
  fixes succi and E :: "('a::linorder \<times> 'a) set" and tgt src :: 'a
  assumes [autoref_rules]: "(succi,E)\<in>\<langle>Id\<rangle>succg_rel"
  notes [autoref_rules] = IdI[of src] IdI[of tgt]
  shows "(?f::?'c, dfs E src tgt) \<in> ?R"
  unfolding dfs_def[abs_def]
  apply (autoref (trace))
  done

subsubsection \<open>Choosing Different Implementations\<close>
text \<open>Ad-hoc override of implementation selection heuristics: Using hashset for the visited set\<close>
schematic_goal dfs_impl_refine_aux2:
  fixes succi and E :: "(('a::hashable) \<times> 'a) set" and tgt src :: 'a
  assumes [autoref_rules]: "(succi,E)\<in>\<langle>Id\<rangle>succg_rel"
  notes [autoref_rules] = IdI[of src] IdI[of tgt]
  notes [autoref_tyrel] = ty_REL[where 'a="'a set" and R="\<langle>Id\<rangle>dflt_ahs_rel"]
  shows "(?f::?'c, dfs E src tgt) \<in> ?R"
  unfolding dfs_def[abs_def]
  apply autoref_monadic
  done

text \<open>We can also leave the type of the nodes and its implementation
  unspecified. However, we need a comparison operator on nodes\<close>

(* With linorder typeclass on abstract type *)
schematic_goal dfs_impl_refine_aux3:
  fixes succi and E :: "('a::linorder \<times> 'a) set"
    and Rv :: "('ai\<times>'a) set"
  assumes [autoref_rules_raw]: "(cmpk, dflt_cmp (\<le>) (<))\<in>(Rv\<rightarrow>Rv\<rightarrow>Id)"
  notes [autoref_tyrel] = ty_REL[where 'a="'a set" and R="\<langle>Rv\<rangle>dflt_rs_rel"]
  assumes P_REF[autoref_rules]:
    "(succi,E)\<in>\<langle>Rv\<rangle>succg_rel"
    "(vdi,tgt::'a)\<in>Rv"
    "(v0i,src)\<in>Rv"
  shows "(RETURN (?f::?'c), dfs E src tgt)\<in>?R"
  unfolding dfs_def[abs_def]
  by autoref_monadic

(* With arbitrary cmpk' operator on abstract type, not forcing a linorder typeclass instance.
  Useful if there are multiple possible instantiations of a typeclass (eg for product ordering),
  and one does not want to commit to one.
*)
schematic_goal dfs_impl_refine_aux3':
  fixes succi and E :: "('a \<times> 'a) set"
    and Rv :: "('ai\<times>'a) set"
  assumes [autoref_ga_rules]: "eq_linorder cmpk'"
  assumes [autoref_rules_raw]: "(cmpk, cmpk')\<in>(Rv\<rightarrow>Rv\<rightarrow>comp_res_rel)"
  notes [autoref_tyrel] = ty_REL[where 'a="'a set" and R="\<langle>Rv\<rangle>map2set_rel (rbt_map_rel (comp2lt cmpk'))"]
  assumes P_REF[autoref_rules]:
    "(succi,E)\<in>\<langle>Rv\<rangle>succg_rel"
    "(vdi,tgt::'a)\<in>Rv"
    "(v0i,src)\<in>Rv"
  shows "(RETURN (?f::?'c), dfs E src tgt)\<in>?R"
  unfolding dfs_def[abs_def]
  by autoref_monadic

text \<open>We also generate code for the alternative implementations\<close>
concrete_definition dfs_impl2 for succi src tgt uses dfs_impl_refine_aux2
concrete_definition dfs_impl3 for cmpk succi v0i vdi uses dfs_impl_refine_aux3
concrete_definition dfs_impl3' for cmpk succi v0i vdi uses dfs_impl_refine_aux3'

prepare_code_thms dfs_impl2_def
prepare_code_thms dfs_impl3_def
prepare_code_thms dfs_impl3'_def

export_code dfs_impl dfs_impl2 dfs_impl3 dfs_impl3' checking SML OCaml? Haskell? Scala

text \<open>And we prove the alternative implementations correct \<close>

theorem dfs_code2_correct:
  assumes SUCCI: "(succi,E)\<in>\<langle>Id\<rangle>succg_rel"
  assumes FIN: "finite (E\<^sup>*``{src})"
  shows "dfs_impl2 succi src tgt \<longleftrightarrow> (src,tgt)\<in>E\<^sup>*"
proof -
  note dfs_impl2.refine[OF SUCCI, of src tgt, THEN nres_relD]
  also note dfs_correct[OF FIN]
  finally show ?thesis by (auto simp: split: dres.split)
qed

theorem dfs_code3_correct:
  fixes succi and succ :: "'a::linorder \<Rightarrow> 'a set"
    and Rv :: "('ai\<times>'a) set"
  assumes V0: "(v0i,src)\<in>Rv"
  assumes VD: "(vdi,tgt)\<in>Rv"
  assumes SUCCI: "(succi,E)\<in>\<langle>Rv\<rangle>succg_rel"
  assumes CMP: "(cmpk, dflt_cmp (\<le>) (<))\<in>(Rv\<rightarrow>Rv\<rightarrow>Id)"
  assumes FIN: "finite (E\<^sup>*``{src})"
  shows "dfs_impl3 cmpk succi v0i vdi \<longleftrightarrow> (src,tgt)\<in>E\<^sup>*"
proof -
  note dfs_impl3.refine[OF CMP SUCCI VD V0, THEN nres_relD]
  also note dfs_correct[OF FIN]
  finally show ?thesis by (auto simp: split: dres.split)
qed

theorem dfs_code3'_correct:
  fixes succi and succ :: "'a::linorder \<Rightarrow> 'a set"
    and Rv :: "('ai\<times>'a) set"
  assumes V0: "(v0i,src)\<in>Rv"
  assumes VD: "(vdi,tgt)\<in>Rv"
  assumes SUCCI: "(succi,E)\<in>\<langle>Rv\<rangle>succg_rel"
  assumes CGA: "eq_linorder cmpk'"
  assumes CMP: "(cmpk, cmpk') \<in> Rv\<rightarrow>Rv\<rightarrow>comp_res_rel"
  assumes FIN: "finite (E\<^sup>*``{src})"
  shows "dfs_impl3' cmpk succi v0i vdi \<longleftrightarrow> (src,tgt)\<in>E\<^sup>*"
proof -
  note dfs_impl3'.refine[OF CGA CMP SUCCI VD V0, THEN nres_relD]
  also note dfs_correct[OF FIN]
  finally show ?thesis by (auto simp: split: dres.split)
qed

(* Reachability *)

definition [simp]: "op_reachable E u v \<equiv> (u,v)\<in>E\<^sup>*"
context begin interpretation autoref_syn .
  lemma [autoref_op_pat]: "(u,v)\<in>E\<^sup>* \<equiv> op_reachable$E$u$v" by simp

  (* We use a quite general setup here, working with any linearly ordered
    abstract node type, refined by any relation. *)
  theorem dfs_code3_correct_rl[autoref_rules]:
    fixes succi and succ :: "'a::linorder \<Rightarrow> 'a set"
      and Rv :: "('ai\<times>'a) set"
    assumes V0: "(v0i,src)\<in>Rv"
    assumes VD: "(vdi,tgt)\<in>Rv"
    assumes SUCCI: "(succi,E)\<in>\<langle>Rv\<rangle>succg_rel"
    assumes CGA: "SIDE_GEN_ALGO (eq_linorder cmpk')"
    assumes CMP: "GEN_OP cmpk cmpk' (Rv\<rightarrow>Rv\<rightarrow>comp_res_rel)"
    assumes FIN: "SIDE_PRECOND (finite (E\<^sup>*``{src}))"
    shows "(dfs_impl3' cmpk succi v0i vdi,
          (OP op_reachable ::: \<langle>Rv\<rangle>succg_rel \<rightarrow> Rv \<rightarrow> Rv \<rightarrow> bool_rel)$E$src$tgt)
          \<in> bool_rel"
    using dfs_code3'_correct[OF V0 VD SUCCI, of cmpk' cmpk] CGA CMP FIN
    unfolding autoref_tag_defs by simp

end

end


theory week09B_demo_gcd
imports WhileLoopRule GCD
begin

definition gcd' :: "nat \<Rightarrow> nat \<Rightarrow> ('s,nat) nondet_monad" where
  "gcd' a b \<equiv>
   do {
     (a, b) \<leftarrow> whileLoop (\<lambda>(a, b) b. 0 < a)
                          (\<lambda>(a, b). return (b mod a, a))
                          (a, b);
      return b
   }"

lemma prod_case_valid:
  "\<lbrace>P\<rbrace> f (fst x) (snd x) \<lbrace>Q\<rbrace> \<Longrightarrow>
   \<lbrace>P\<rbrace> case x of (a,b) \<Rightarrow> f a b \<lbrace>Q\<rbrace>"
  apply (auto split: prod.splits)
  done

lemma gcd'_correct:
  "\<lbrace>\<lambda>_. True\<rbrace> gcd' a b \<lbrace>\<lambda>r s. r = gcd a b\<rbrace>"
  apply (unfold gcd'_def)
  thm whileLoop_wp
  apply (rule bind_wp)
  apply (rule prod_case_valid)
  apply (rule return_wp)
  apply (rule hoare_weaken_pre)
   apply (rule_tac I="\<lambda>(x,y) s. gcd x y = gcd a b " in whileLoop_wp)
    apply clarsimp
  apply (rule hoare_weaken_pre)
     apply (rule return_wp)
    apply clarsimp
    apply (metis gcd.commute gcd_red_nat)
   apply clarsimp
  apply clarsimp
  done

end