theory DerefVars
  imports SafeSubRename
begin

fun deref_pairs where
  "deref_pairs (ConstExp c) = {}"
| "deref_pairs (OpExp xop) = {}"
| "deref_pairs (VarExp x a) = (case a of
    OtherRef y \<Rightarrow> {(x, y)}
    | r \<Rightarrow> {}
  )"
| "deref_pairs (PairExp e1 e2) = (deref_pairs e1 \<union> deref_pairs e2)"
| "deref_pairs (IfExp e1 e2 e3) = (deref_pairs e1 \<union> deref_pairs e2 \<union> deref_pairs e3)"
| "deref_pairs (LamExp x e) = deref_pairs e"
| "deref_pairs (AppExp e1 e2) = (deref_pairs e1 \<union> deref_pairs e2)"

    (* ##### given a perm set, we derive its "resource completion" by taking all of the resources that are reachable from it.
        in other words, for each permission z in s, we lookup its resource map, and take all of the resources in it, as well
        as recursing on each resource. #####
     *)

fun path_lookup where
  "path_lookup rs_map z Nil x = (z = x)"
| "path_lookup rs_map z (y # t) x = (case rs_map z of
    None \<Rightarrow> False
    | Some r_s \<Rightarrow> r_s y \<noteq> NoPerm \<and> path_lookup rs_map y t x
  )"

fun complete_vars where
  "complete_vars rs_map s = { x | x. \<exists> l z. z \<in> s \<and> path_lookup rs_map z l x}"

lemma path_lookup_parent: "\<lbrakk> l \<noteq> Nil; path_lookup rs_map z l x; valid_nres_map s rs_map \<rbrakk> \<Longrightarrow>
  (\<exists> l' y r_s. path_lookup rs_map z l' y \<and> rs_map y = Some r_s \<and> r_s x \<noteq> NoPerm )"
  apply (induct l arbitrary: z)
   apply (auto)
  apply (case_tac "rs_map z")
   apply (auto)
    (* case where we have reached x *)
  apply (case_tac "a = x")
   apply (rule_tac x="Nil" in exI)
   apply (auto)
    (* otherwise, induct *)
  apply (case_tac "l = []")
   apply (auto)
  apply (case_tac "\<exists>l' y. path_lookup rs_map a l' y \<and> (\<exists>r_s. rs_map y = Some r_s \<and> r_s x \<noteq> NoPerm)")
   apply (erule_tac exE)
   apply (auto)
  apply (rule_tac x="a # l'" in exI)
  apply (auto)
  done

    (* ##### proper expressions ##### *)

definition proper_exp where
  "proper_exp rs_map e = (\<forall> x y. (x, y) \<in> deref_pairs e \<longrightarrow> (\<exists> l. path_lookup rs_map x l y))"

lemma proper_pair: "\<lbrakk> proper_exp rs_map (PairExp e1 e2) \<rbrakk> \<Longrightarrow> proper_exp rs_map e1 \<and> proper_exp rs_map e2"
  apply (simp add: proper_exp_def)
  done

lemma proper_if: "\<lbrakk> proper_exp rs_map (IfExp e1 e2 e3) \<rbrakk> \<Longrightarrow> proper_exp rs_map e1 \<and> proper_exp rs_map e2 \<and> proper_exp rs_map e3"
  apply (simp add: proper_exp_def)
  done

lemma proper_app: "\<lbrakk> proper_exp rs_map (AppExp e1 e2) \<rbrakk> \<Longrightarrow> proper_exp rs_map e1 \<and> proper_exp rs_map e2"
  apply (simp add: proper_exp_def)
  done

lemma proper_subst_exp: "\<lbrakk> proper_exp rs_map e; proper_exp rs_map e'; x \<notin> ref_vars e \<rbrakk> \<Longrightarrow> proper_exp rs_map (subst_exp e x e')"
  apply (induct e)
        apply (auto)
     apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" in proper_pair)
      apply (auto)
     apply (simp add: proper_exp_def)
    apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" and ?e3.0="e3" in proper_if)
     apply (auto)
    apply (simp add: proper_exp_def)
   apply (simp add: proper_exp_def)
  apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" in proper_app)
   apply (auto)
  apply (simp add: proper_exp_def)
  done

lemma proper_alpha_rename: "\<lbrakk> proper_exp rs_map e; a \<notin> ref_vars e \<rbrakk> \<Longrightarrow> proper_exp rs_map (deep_alpha_rename e a b)"
  apply (induct e)
        apply (auto)
       apply (simp add: proper_exp_def)
       apply (auto)
       apply (case_tac x2a)
         apply (auto)
      apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" in proper_pair)
       apply (auto)
      apply (simp add: proper_exp_def)
     apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" and ?e3.0="e3" in proper_if)
      apply (auto)
     apply (simp add: proper_exp_def)
    apply (simp add: proper_exp_def)
   apply (simp add: proper_exp_def)
  apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" in proper_app)
   apply (auto)
  apply (simp add: proper_exp_def)
  done

lemma proper_lam_var_remove_ex: "\<lbrakk> proper_exp rs_map e; well_typed env r_s1 e tau r_s2 rx \<rbrakk> \<Longrightarrow> proper_exp rs_map (lam_var_remove e a b)"
  apply (induct e arbitrary: env r_s1 tau r_s2 rx)
        apply (auto)
      apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" in proper_pair)
       apply (auto)
      apply (simp add: proper_exp_def)
     apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" and ?e3.0="e3" in proper_if)
      apply (auto)
     apply (simp add: proper_exp_def)
    apply (cut_tac rs_map="rs_map" and e="e" and a="a" and b="b" in proper_alpha_rename)
      apply (simp add: proper_exp_def)
     apply (simp)
    apply (simp add: proper_exp_def)
   apply (simp add: proper_exp_def)
  apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" in proper_app)
   apply (auto)
  apply (simp add: proper_exp_def)
  done

lemma proper_lam_var_remove: "\<lbrakk> proper_exp rs_map e; a \<notin> ref_vars e \<rbrakk> \<Longrightarrow> proper_exp rs_map (lam_var_remove e a b)"
  apply (induct e)
        apply (auto)
      apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" in proper_pair)
       apply (auto)
      apply (simp add: proper_exp_def)
     apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" and ?e3.0="e3" in proper_if)
      apply (auto)
     apply (simp add: proper_exp_def)
    apply (cut_tac rs_map="rs_map" and e="e" and a="a" and b="b" in proper_alpha_rename)
      apply (simp add: proper_exp_def)
     apply (simp)
    apply (simp add: proper_exp_def)
   apply (simp add: proper_exp_def)
  apply (cut_tac rs_map="rs_map" and ?e1.0="e1" and ?e2.0="e2" in proper_app)
   apply (auto)
  apply (simp add: proper_exp_def)
  done

lemma lam_var_remove_eq: "\<lbrakk> a \<notin> lam_vars e \<rbrakk> \<Longrightarrow> lam_var_remove e a b = e"
  apply (induct e)
        apply (auto)
  done

lemma proper_lvlr_ex: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; proper_exp rs_map e; unique_post_vars vl;
  post_vars vl \<inter> (free_vars e \<union> lam_vars e \<union> ref_vars e) = {} \<rbrakk> \<Longrightarrow> proper_exp rs_map (lam_var_list_remove e vl)"
  apply (induct vl arbitrary: e)
   apply (auto)
  (*apply (case_tac "a \<notin> lam_vars e")
   apply (simp add: lam_var_remove_eq)*)
  apply (cut_tac rs_map="rs_map" and e="e" and a="a" and b="b" in proper_lam_var_remove_ex)
    apply (auto)
    (* we have to prove that the post vars are still disjoint from the lam_vars / ref_vars, which is true since
        the only new lam_var is b, which must be disjoint from the rest of the post_var list *)
  apply (case_tac "post_vars vl \<inter> (free_vars (lam_var_remove e a b) \<union> lam_vars (lam_var_remove e a b) \<union> ref_vars (lam_var_remove e a b)) \<noteq> {}")
   apply (auto)
     apply (cut_tac x="x" and e="e" and a="a" and b="b" in lam_var_remove_free_var_none)
      apply (auto)
    apply (case_tac "x = b")
     apply (auto)
    apply (cut_tac x="x" and e="e" and a="a" and b="b" in lam_var_remove_lam_var_none)
      apply (auto)
   apply (case_tac "x = b")
    apply (auto)
   apply (cut_tac z="x" and e="e" and x="a" and y="b" in lam_var_remove_ref_vars)
     apply (auto)
    (* the last part of the induction is to prove that e is still well-typed *)
  apply (cut_tac env="env" and ?r_s1.0="r_s1" and e="e" and x="a" and y="b" in lam_var_remove_type_preserve)
      apply (auto)
  done

    (* this lemma is predicated on the idea that after a lam_var_list removal, no new deref_pairs will be introduced.
        the intuition is that lvlr only changes lam_vars, and lam_vars don't overlap with ref_vars or free_vars,
        meaning they will not affect any deref_pairs.
    *)(*
lemma proper_lvlr: "\<lbrakk> proper_exp rs_map e; unique_post_vars vl; post_vars vl \<inter> (lam_vars e \<union> ref_vars e) = {};
  lam_vars e \<inter> ref_vars e = {} \<rbrakk> \<Longrightarrow> proper_exp rs_map (lam_var_list_remove e vl)"
  apply (induct vl arbitrary: e)
   apply (auto)
  apply (case_tac "a \<notin> lam_vars e")
   apply (simp add: lam_var_remove_eq)
  apply (cut_tac rs_map="rs_map" and e="e" and a="a" and b="b" in proper_lam_var_remove)
    apply (auto)
    (* we have to prove that the post vars are still disjoint from the lam_vars / ref_vars, which is true since
        the only new lam_var is b, which must be disjoint from the rest of the post_var list *)
  apply (case_tac "post_vars vl \<inter> (lam_vars (lam_var_remove e a b) \<union> ref_vars (lam_var_remove e a b)) \<noteq> {}")
   apply (auto)
    apply (case_tac "x = b")
     apply (auto)
    apply (cut_tac x="x" and e="e" and a="a" and b="b" in lam_var_remove_lam_var_none)
      apply (auto)
   apply (case_tac "x = b")
    apply (auto)
   apply (cut_tac z="x" and e="e" and x="a" and y="b" in lam_var_remove_ref_vars)
     apply (auto)
  apply (case_tac "lam_vars (lam_var_remove e a b) \<inter> ref_vars (lam_var_remove e a b) = {}")
   apply (auto)
    (* the main challenge of this lemma is proving that after each renaming, the lam_vars and ref_vars remain disjoint.
        - say that such an x was in the lam_vars e, but not in the ref_vars e. *)
  apply (case_tac "x \<in> lam_vars e")
    (* - we know that x \<noteq> b by post_var disjointness.
      then we can know that x \<in> ref_vars e, since otherwise x \<notin> ref_vars (lam_var_remove e a b) *)
   apply (case_tac "x \<noteq> b")
    apply (case_tac "x \<notin> ref_vars e")
     apply (cut_tac z="x" and e="e" and x="a" and y="b" in lam_var_remove_ref_vars)
       apply (auto)
    (* otherwise, x \<notin> lam_vars e. say that x \<noteq> b. then x \<notin> lam_vars (lam_var_remove e a b) either *)
  apply (case_tac "x \<noteq> b")
   apply (cut_tac e="e" and x="x" and a="a" and b="b" in lam_var_remove_lam_var_none)
     apply (auto)
  apply (case_tac "a \<notin> ref_vars e")
   apply (cut_tac y="b" and e="e" and x="a" in lam_var_remove_ref_vars2)
     apply (auto)
  done*)

lemma proper_safe_subst_exp: "\<lbrakk> proper_exp rs_map e; well_typed env r_s1 e tau r_s2 rx;
  proper_exp rs_map e'; safe_subst_exp e x e' e_f \<rbrakk> \<Longrightarrow> proper_exp rs_map e_f"
  apply (simp add: safe_subst_exp_def)
  apply (auto)
  apply (rule_tac proper_subst_exp)
    apply (rule_tac proper_lvlr_ex)
       apply (auto)
    (* we have to prove that x is not a ref var of the final result *)
  apply (cut_tac x="x" and e="e" and vl="vl" in lam_var_list_remove_ref_var)
      apply (auto)
  apply (simp add: disj_vars_def)
  apply (auto)
  done

end


theory SINVAR_SecGwExt
imports "../TopoS_Helper"
begin

subsection {* SecurityInvariant PolEnforcePointExtended*}
text {* A PolEnforcePoint is an application-level central policy enforcement point.
Legacy note: The old verions called it a SecurityGateway.

Hosts may belong to a certain domain.
Sometimes, a pattern where intra-domain communication between domain members must be approved by a central instance is required.

We call such a central instance PolEnforcePoint and present a template for this architecture.
Five host roles are distinguished:.
A PolEnforcePoint, aPolEnforcePointIN which accessible from the outside, a DomainMember,
a less-restricted AccessibleMember which is accessible from the outside world,
and a default value Unassigned that reflects none of these roles. *}

datatype secgw_member = PolEnforcePoint | PolEnforcePointIN | DomainMember  | AccessibleMember | Unassigned

definition default_node_properties :: "secgw_member"
  where  "default_node_properties \<equiv> Unassigned"

fun allowed_secgw_flow :: "secgw_member \<Rightarrow> secgw_member \<Rightarrow> bool" where
  "allowed_secgw_flow PolEnforcePoint _ = True" |
  "allowed_secgw_flow PolEnforcePointIN _ = True" |
  "allowed_secgw_flow DomainMember DomainMember = False" |
  "allowed_secgw_flow DomainMember _ = True" |
  "allowed_secgw_flow AccessibleMember DomainMember = False" |
  "allowed_secgw_flow AccessibleMember _ = True" |
  "allowed_secgw_flow Unassigned Unassigned = True" |
  "allowed_secgw_flow Unassigned PolEnforcePointIN = True" |
  "allowed_secgw_flow Unassigned AccessibleMember = True" |
  "allowed_secgw_flow Unassigned _ = False"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> secgw_member) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. e1 \<noteq> e2 \<longrightarrow> allowed_secgw_flow (nP e1) (nP e2))"

definition receiver_violation :: "bool" where "receiver_violation = False"

subsubsection {*Preliminaries*}

subsubsection{*ENF*}
  lemma PolEnforcePoint_ENFnr: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_not_refl sinvar allowed_secgw_flow"
    by(simp add: SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_not_refl_def)
  lemma Unassigned_botdefault: "\<forall> e1 e2. e2 \<noteq> Unassigned \<longrightarrow> \<not> allowed_secgw_flow e1 e2 \<longrightarrow> \<not> allowed_secgw_flow Unassigned e2"
    apply(rule allI)+
    apply(case_tac e2)
        apply(simp_all)
     apply(case_tac e1)
          apply(simp_all)
    apply(case_tac e1)
        apply(simp_all)
    done
  lemma Unassigned_not_to_Member: "\<not> allowed_secgw_flow Unassigned DomainMember"
    by(simp)
  lemma All_to_Unassigned: "\<forall> e1. allowed_secgw_flow e1 Unassigned"
    by (rule allI, case_tac e1, simp_all)

  definition PolEnforcePointExtended_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> secgw_member) \<Rightarrow> ('v \<times> 'v) set set" where
  "PolEnforcePointExtended_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> e1 \<noteq> e2 \<and> \<not> allowed_secgw_flow (nP e1) (nP e2)} })"
  lemma PolEnforcePointExtended_offending_set: "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = PolEnforcePointExtended_offending_set"
    apply(simp only: fun_eq_iff ENFnr_offending_set[OF PolEnforcePoint_ENFnr] PolEnforcePointExtended_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(auto)
  done

interpretation PolEnforcePointExtended: SecurityInvariant_ACS
where default_node_properties = default_node_properties
and sinvar = sinvar
rewrites "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = PolEnforcePointExtended_offending_set"
  unfolding default_node_properties_def
  apply unfold_locales
    apply(rule ballI)
    apply (rule SecurityInvariant_withOffendingFlows.ENFnr_fsts_weakrefl_instance[OF PolEnforcePoint_ENFnr Unassigned_botdefault All_to_Unassigned])[1]
     apply(simp)
    apply(simp)
   apply(erule default_uniqueness_by_counterexample_ACS)
   apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
   apply (simp add:graph_ops)
   apply (simp split: prod.split_asm prod.split)
   apply(rule_tac x="\<lparr> nodes={vertex_1,vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
   apply(rule conjI)
    apply(simp add: wf_graph_def)
   apply(case_tac otherbot, simp_all)
      apply(rename_tac secgwcase)
      apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := Unassigned, vertex_2 := DomainMember)" in exI, simp)
      apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
     apply(rename_tac secgwINcase)
     apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := Unassigned, vertex_2 := DomainMember)" in exI, simp)
     apply(rule_tac x="vertex_1" in exI, simp)
     apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
    apply(rename_tac membercase)
    apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := Unassigned, vertex_2 := PolEnforcePoint)" in exI, simp)
    apply(rule_tac x="vertex_1" in exI, simp)
    apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
   apply(rule_tac x="(\<lambda> x. Unassigned)(vertex_1 := Unassigned, vertex_2 := PolEnforcePoint)" in exI, simp)
   apply(rule_tac x="vertex_1" in exI, simp)
   apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)

  apply(fact PolEnforcePointExtended_offending_set)
 done

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

hide_const (open) sinvar receiver_violation

end


(*  Title:       CoreC++
    Author:      Daniel Wasserrab
    Maintainer:  Daniel Wasserrab <wasserra at fmi.uni-passau.de>

    Based on the Jinja theory Common/Decl.thy by David von Oheimb and Tobias Nipkow
*)

section \<open>CoreC++ types\<close>

theory Type imports Auxiliary begin

type_synonym cname = string \<comment> \<open>class names\<close>
type_synonym mname = string \<comment> \<open>method name\<close>
type_synonym vname = string \<comment> \<open>names for local/field variables\<close>

definition this :: vname where
  "this \<equiv> ''this''"

\<comment> \<open>types\<close>
datatype ty
  = Void          \<comment> \<open>type of statements\<close>
  | Boolean
  | Integer
  | NT            \<comment> \<open>null type\<close>
  | Class cname   \<comment> \<open>class type\<close>

datatype base  \<comment> \<open>superclass\<close>
  = Repeats cname  \<comment> \<open>repeated (nonvirtual) inheritance\<close>
  | Shares cname   \<comment> \<open>shared (virtual) inheritance\<close>

primrec getbase :: "base \<Rightarrow> cname" where
  "getbase (Repeats C) = C"
| "getbase (Shares C)  = C"

primrec isRepBase :: "base \<Rightarrow> bool" where
  "isRepBase (Repeats C) = True"
| "isRepBase (Shares C) = False"

primrec isShBase :: "base \<Rightarrow> bool" where
  "isShBase(Repeats C) = False"
| "isShBase(Shares C) = True"

definition is_refT :: "ty \<Rightarrow> bool" where
  "is_refT T  \<equiv>  T = NT \<or> (\<exists>C. T = Class C)"

lemma [iff]: "is_refT(Class C)"
by(simp add:is_refT_def)

lemma refTE:
  "\<lbrakk>is_refT T; T = NT \<Longrightarrow> Q; \<And>C. T = Class C \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
by (auto simp add: is_refT_def)

lemma not_refTE:
  "\<lbrakk> \<not>is_refT T; T = Void \<or> T = Boolean \<or> T = Integer \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
by (cases T, auto simp add: is_refT_def)

type_synonym
  env  = "vname \<rightharpoonup> ty"

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2005         |
            |               December 2005               |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_law_SKIP_DIV
imports CSP_T_law_SKIP CSP_T_law_DIV
begin

(*********************************************************
                   (SKIP [+] DIV)
 *********************************************************)

lemma cspT_SKIP_DIV_Ext_choice1: "(SKIP [+] DIV) =T[M1,M2] SKIP"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule, simp add: in_traces)
 apply (force)

(* <= *)
 apply (rule, simp add: in_traces)
done

lemma cspT_SKIP_DIV_Ext_choice2: "(DIV [+] SKIP) =T[M1,M2] SKIP"
apply (simp add: cspT_semantics)
apply (rule order_antisym)
apply (rule, simp add: in_traces)+
done

lemmas cspT_SKIP_DIV_Ext_choice =
       cspT_SKIP_DIV_Ext_choice1
       cspT_SKIP_DIV_Ext_choice2

(*********************************************************
                    SKIP |[X]| DIV
 *********************************************************)

lemma cspT_SKIP_DIV_Parallel1:
   "SKIP |[X]| DIV =T[M1,M2] DIV"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule)
 apply (simp add: in_traces)
 apply (elim disjE conjE exE)
 apply (simp_all)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
done

lemma cspT_SKIP_DIV_Parallel2:
   "DIV |[X]| SKIP =T[M1,M2] DIV"
apply (rule cspT_rw_left)
apply (rule cspT_commut)
apply (rule cspT_rw_left)
apply (rule cspT_SKIP_DIV_Parallel1)
apply (rule cspT_reflex)
done

lemmas cspT_SKIP_DIV_Parallel =
       cspT_SKIP_DIV_Parallel1
       cspT_SKIP_DIV_Parallel2
       cspT_Parallel_term
       cspT_DIV_Parallel

(*********************************************************
                 DIV and Parallel-SKIP
 *********************************************************)

(*** SKIP and DIV ***)

lemma cspT_DIV_Parallel_Ext_choice_SKIP_l:
  "(P [+] SKIP) |[X]| DIV =T[M,M] (P |[X]| DIV)"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule, simp add: in_traces)
 apply (elim conjE exE disjE)
 apply (simp_all)
  apply (simp add: par_tr_nil_right)
  apply (elim conjE)
  apply (simp add: image_iff)

(* <= *)
 apply (rule, simp add: in_traces)
 apply (elim conjE exE disjE)
  apply (simp add: par_tr_nil_right)
  apply (elim conjE)
  apply (simp add: image_iff)
done

lemma cspT_DIV_Parallel_Ext_choice_SKIP_r:
  "DIV |[X]| (P [+] SKIP) =T[M,M] (DIV |[X]| P)"
apply (rule cspT_rw_left)
apply (rule cspT_commut)
apply (rule cspT_rw_left)
apply (rule cspT_DIV_Parallel_Ext_choice_SKIP_l)
apply (rule cspT_commut)
done

lemmas cspT_DIV_Parallel_Ext_choice_SKIP =
       cspT_DIV_Parallel_Ext_choice_SKIP_l
       cspT_DIV_Parallel_Ext_choice_SKIP_r

lemmas cspT_DIV_Parallel_Ext_choice =
       cspT_DIV_Parallel_Ext_choice_SKIP
       cspT_DIV_Parallel_Ext_choice_DIV

(*********************************************************
                 SKIP and Parallel-DIV
 *********************************************************)

(*** DIV and SKIP ***)

lemma cspT_SKIP_Parallel_Ext_choice_DIV_l:
  "((? :Y -> Pf) [+] DIV) |[X]| SKIP =T[M,M]
   (? x:(Y - X) -> (Pf x |[X]| SKIP)) [+] DIV"
apply (simp add: cspT_semantics)
apply (rule order_antisym)

(* => *)
 apply (rule, simp add: in_traces)
 apply (elim conjE exE disjE)
 apply (simp_all)

  apply (rule disjI2)
  apply (simp add: par_tr_nil_right)
  apply (elim conjE)
  apply (simp add: image_iff)
  apply (rule_tac x="sa" in exI)
  apply (rule_tac x="<>" in exI)
  apply (simp add: par_tr_nil_right)

  apply (rule disjI2)
  apply (simp add: par_tr_Tick_right)
  apply (elim conjE)
  apply (simp add: image_iff)
  apply (rule_tac x="sa" in exI)
  apply (rule_tac x="<Tick>" in exI)
  apply (simp add: par_tr_Tick_right)

(* <= *)
 apply (rule, simp add: in_traces)
 apply (elim conjE exE disjE)
 apply (simp_all)

  apply (simp add: par_tr_nil_right)
  apply (elim conjE)
  apply (rule_tac x="<Ev a> ^^^ sa" in exI)
  apply (rule_tac x="<>" in exI)
  apply (simp add: par_tr_nil_right)
  apply (simp add: image_iff)

  apply (simp add: par_tr_Tick_right)
  apply (elim conjE)
  apply (rule_tac x="<Ev a> ^^^ sa" in exI)
  apply (rule_tac x="<Tick>" in exI)
  apply (simp add: par_tr_Tick_right)
  apply (simp add: image_iff)
done

lemma cspT_SKIP_Parallel_Ext_choice_DIV_r:
  "SKIP |[X]| ((? :Y -> Pf) [+] DIV) =T[M,M]
   (? x:(Y - X) -> (SKIP |[X]| Pf x)) [+] DIV"
apply (rule cspT_rw_left)
apply (rule cspT_commut)
apply (rule cspT_rw_left)
apply (rule cspT_SKIP_Parallel_Ext_choice_DIV_l)
apply (rule cspT_rw_left)
apply (rule cspT_decompo)
apply (rule cspT_decompo)
apply (simp)
apply (rule cspT_commut)
apply (rule cspT_reflex)
apply (rule cspT_reflex)
done

lemmas cspT_SKIP_Parallel_Ext_choice_DIV =
       cspT_SKIP_Parallel_Ext_choice_DIV_l
       cspT_SKIP_Parallel_Ext_choice_DIV_r

lemmas cspT_SKIP_Parallel_Ext_choice =
       cspT_SKIP_Parallel_Ext_choice_SKIP
       cspT_SKIP_Parallel_Ext_choice_DIV

(*---------------------------------------------*
 |                 SKIP , DIV                  |
 *---------------------------------------------*)

lemmas cspT_SKIP_DIV_Parallel_step =
       cspT_Parallel_preterm
       cspT_DIV_Parallel_step

lemmas cspT_SKIP_DIV_Parallel_Ext_choice =
       cspT_SKIP_Parallel_Ext_choice
       cspT_DIV_Parallel_Ext_choice

lemmas cspT_SKIP_DIV_Hiding_Id =
       cspT_SKIP_Hiding_Id
       cspT_DIV_Hiding_Id

lemmas cspT_SKIP_DIV_Hiding_step =
       cspT_DIV_Hiding_step
       cspT_SKIP_Hiding_step

lemmas cspT_SKIP_DIV_Renaming_Id =
       cspT_SKIP_Renaming_Id
       cspT_DIV_Renaming_Id

lemmas cspT_SKIP_DIV_Seq_compo =
       cspT_Seq_compo_unit
       cspT_DIV_Seq_compo

lemmas cspT_SKIP_DIV_Seq_compo_step =
       cspT_SKIP_Seq_compo_step
       cspT_DIV_Seq_compo_step

lemmas cspT_SKIP_DIV_Depth_rest =
       cspT_SKIP_Depth_rest
       cspT_DIV_Depth_rest

lemmas cspT_SKIP_DIV =
       cspT_SKIP_DIV_Parallel_step
       cspT_SKIP_DIV_Ext_choice
       cspT_SKIP_DIV_Parallel
       cspT_SKIP_DIV_Parallel_Ext_choice
       cspT_SKIP_DIV_Hiding_Id
       cspT_SKIP_DIV_Hiding_step
       cspT_SKIP_DIV_Renaming_Id
       cspT_SKIP_DIV_Seq_compo
       cspT_SKIP_DIV_Seq_compo_step
       cspT_SKIP_DIV_Depth_rest

(*** resolve ***)

lemmas cspT_Ext_choice_SKIP_DIV_resolve =
       cspT_Ext_choice_SKIP_resolve
       cspT_Ext_choice_DIV_resolve

(*----------------------------------------------*
 |                                              |
 |        for convenienve  (SKIP or DIV)        |
 |                                              |
 *----------------------------------------------*)

(*********************************************************
            (SKIP or DIV [+] SKIP or DIV)
 *********************************************************)

lemma cspT_SKIP_or_DIV_Ext_choice:
  "[| P = SKIP | P = DIV ; Q = SKIP | Q = DIV |] ==>
   (P [+] Q) =T[M1,M2] (if (P = SKIP | Q = SKIP) then SKIP else DIV)"
apply (elim disjE)
apply (simp_all)
apply (rule cspT_rw_left)
apply (rule cspT_Ext_choice_idem)
apply (simp)
apply (simp add: cspT_SKIP_DIV)
apply (simp add: cspT_SKIP_DIV)
apply (rule cspT_rw_left)
apply (rule cspT_Ext_choice_idem)
apply (simp)
done

(*********************************************************
            (SKIP or DIV |[X]| SKIP or DIV)
 *********************************************************)

lemma cspT_SKIP_or_DIV_Parallel:
  "[| P = SKIP | P = DIV ; Q = SKIP | Q = DIV |] ==>
   (P |[X]| Q) =T[M1,M2] (if (P = SKIP & Q = SKIP) then SKIP else DIV)"
apply (elim disjE)
apply (simp_all add: cspT_SKIP_DIV)
done

(*********************************************************
                  (SKIP or DIV) and Hiding
 *********************************************************)

lemma cspT_SKIP_or_DIV_Hiding_step:
  "Q = SKIP | Q = DIV ==>
   ((? :Y -> Pf) [+] Q) -- X =T[M,M]
   (((? x:(Y-X) -> (Pf x -- X)) [+] Q) |~| (! x:(Y Int X) .. (Pf x -- X)))"
apply (erule disjE)
apply (simp_all add: cspT_SKIP_DIV)
done

(*********************************************************
                  SKIP or DIV |. Suc n
 *********************************************************)

lemma cspT_SKIP_or_DIV_Depth_rest:
   "Q = SKIP | Q = DIV ==> Q |. (Suc n) =T[M1,M2] Q"
apply (erule disjE)
apply (simp_all add: cspT_SKIP_DIV)
done

(*********************************************************
                    P [+] (SKIP or DIV)
 *********************************************************)

lemma cspT_Ext_choice_SKIP_or_DIV_resolve:
  "Q = SKIP | Q = DIV ==> P [+] Q =T[M,M] P [> Q"
apply (erule disjE)
apply (simp_all add: cspT_Ext_choice_SKIP_DIV_resolve)
done

lemmas cspT_SKIP_or_DIV =
       cspT_SKIP_or_DIV_Ext_choice
       cspT_SKIP_or_DIV_Parallel
       cspT_SKIP_or_DIV_Hiding_step
       cspT_SKIP_or_DIV_Depth_rest

       (* no resolve *)

end


(* Author: Joshua Schneider, ETH Zurich *)

section \<open>Regression tests for applicative lifting\<close>

theory Applicative_Test imports
  Stream_Algebra
  Applicative_Environment
  Applicative_List
  Applicative_Option
  Applicative_Set
  Applicative_Sum
  Abstract_AF
begin

interpretation applicative_syntax .

subsection {* Normal form conversion *}

notepad
begin
  have "\<forall>x. x = af_pure (\<lambda>x. x) \<diamondop> x" by applicative_nf rule
  have "\<forall>x. af_pure x = af_pure x" by applicative_nf rule
  have "\<forall>f x. af_pure f \<diamondop> x = af_pure f \<diamondop> x" by applicative_nf rule
  have "\<forall>f x y. af_pure f \<diamondop> x \<diamondop> y = af_pure f \<diamondop> x \<diamondop> y" by applicative_nf rule
  have "\<forall>g f x. af_pure g \<diamondop> (f \<diamondop> x) = af_pure (\<lambda>f x. g (f x)) \<diamondop> f \<diamondop> x" by applicative_nf rule
  have "\<forall>f x y. f \<diamondop> x \<diamondop> y = af_pure (\<lambda>f x y. f x y) \<diamondop> f \<diamondop> x \<diamondop> y" by applicative_nf rule
  have "\<forall>g f x. g \<diamondop> (f \<diamondop> x) = af_pure (\<lambda>g f x. g (f x)) \<diamondop> g \<diamondop> f \<diamondop> x" by applicative_nf rule
  have "\<forall>f x. f \<diamondop> af_pure x = af_pure (\<lambda>f. f x) \<diamondop> f" by applicative_nf rule
  have "\<forall>x y. af_pure x \<diamondop> af_pure y = af_pure (x y)" by applicative_nf rule
  have "\<forall>f x y. f \<diamondop> x \<diamondop> af_pure y = af_pure (\<lambda>f x. f x y) \<diamondop> f \<diamondop> x" by applicative_nf rule
  have "\<forall>f x y. af_pure f \<diamondop> x \<diamondop> af_pure y = af_pure (\<lambda>x. f x y) \<diamondop> x" by applicative_nf rule
  have "\<forall>f x y z. af_pure f \<diamondop> x \<diamondop> af_pure y \<diamondop> z = af_pure (\<lambda>x z. f x y z) \<diamondop> x \<diamondop> z" by applicative_nf rule
  have "\<forall>f x g y. af_pure f \<diamondop> x \<diamondop> (af_pure g \<diamondop> y) = af_pure (\<lambda>x y. f x (g y)) \<diamondop> x \<diamondop> y" by applicative_nf rule
  have "\<forall>f g x y. f \<diamondop> (g \<diamondop> x) \<diamondop> y = af_pure (\<lambda>f g x y. f (g x) y) \<diamondop> f \<diamondop> g \<diamondop> x \<diamondop> y" by applicative_nf rule
  have "\<forall>f g x y z. f \<diamondop> (g \<diamondop> x \<diamondop> y) \<diamondop> z = af_pure (\<lambda>f g x y z. f (g x y) z) \<diamondop> f \<diamondop> g \<diamondop> x \<diamondop> y \<diamondop> z" by applicative_nf rule
  have "\<forall>f g x y z. f \<diamondop> (g \<diamondop> (x \<diamondop> af_pure y)) \<diamondop> z = af_pure (\<lambda>f g x z. f (g (x y)) z) \<diamondop> f \<diamondop> g \<diamondop> x \<diamondop> z" by applicative_nf rule
  have "\<forall>f g x. f \<diamondop> (g \<diamondop> x \<diamondop> x) = af_pure (\<lambda>f g x x'. f (g x x')) \<diamondop> f \<diamondop> g \<diamondop> x \<diamondop> x" by applicative_nf rule
  have "\<forall>f x y. f x \<diamondop> y = af_pure (\<lambda>f x. f x) \<diamondop> f x \<diamondop> y" by applicative_nf rule
next
  fix f :: "('a \<Rightarrow> 'b) af" and g :: "('b \<Rightarrow> 'c) af" and x
  have "g \<diamondop> (f \<diamondop> x) = af_pure (\<lambda>g f x. g (f x)) \<diamondop> g \<diamondop> f \<diamondop> x" by applicative_nf rule
end
(* TODO automatic test for names of new variables *)

lemma "\<And>f x::'a af. f \<diamondop> x = x"
apply applicative_nf
oops

subsection {* Sets *}

instantiation set :: (plus) plus
begin
  definition set_plus_def[applicative_unfold]: "(X::('a::plus)set) + Y = {plus} \<diamondop> X \<diamondop> Y"
  instance ..
end

lemma "(X :: _ :: semigroup_add set) + Y + Z = X + (Y + Z)"
by (fact add.assoc[applicative_lifted set])

instantiation set :: (semigroup_add) semigroup_add begin
instance proof
  fix X Y Z :: "'a set"
  from add.assoc
  show "X + Y + Z = X + (Y + Z)" by applicative_lifting
qed
end

instantiation set :: (ab_semigroup_add) ab_semigroup_add begin
instance proof
  fix X Y :: "'a set"
  from add.commute
  show "X + Y = Y + X" by applicative_lifting
qed
end

subsection {* Sum type (a.k.a. either) *}

lemma "Inl plus \<diamondop> (x :: nat + 'e list) \<diamondop> x = Inl (\<lambda>x. 2 * x) \<diamondop> x"
by applicative_lifting simp

lemma "rel_sum (op \<le>) (op \<le>) (x :: nat + nat) (Inl Suc \<diamondop> x)"
proof -
  interpret either_af "op \<le> :: nat \<Rightarrow> _" by unfold_locales (rule reflpI, simp)
  show ?thesis by applicative_lifting simp
qed

subsection {* Streams *}

lemma "(x::int stream) * sconst 0 = sconst 0"
by applicative_lifting simp

lemma "(x::int stream) * (y + z) = x * y + x * z"
by applicative_lifting algebra

definition "lift_streams xs = foldr (smap2 Cons) xs (sconst [])"

lemma lift_streams_Nil[applicative_unfold]: "lift_streams [] = sconst []"
unfolding lift_streams_def
by simp

lemma lift_streams_Cons[applicative_unfold]:
  "lift_streams (x # xs) = smap2 Cons x (lift_streams xs)"
unfolding lift_streams_def
by applicative_unfold

lemma stream_append_Cons: "smap2 append (smap2 Cons x ys) zs = smap2 Cons x (smap2 append ys zs)"
by applicative_lifting simp

lemma lift_streams_append[applicative_unfold]:
  "lift_streams (xs @ ys) = smap2 append (lift_streams xs) (lift_streams ys)"
proof (induction xs)
  case Nil
  (*
    case could be proved directly if "lift_streams ([] @ ys) = lift_streams ys" is solved
    in head_cong_tac (invoke simplifier?) -- but only with applicative_nf
  *)
  have "lift_streams ys = sconst append \<diamondop> lift_streams [] \<diamondop> lift_streams ys"
    by applicative_lifting simp
  thus ?case by applicative_unfold
next
  case (Cons x xs)
  with stream_append_Cons  (* the actual lifted fact *)
  show ?case by applicative_unfold (rule sym)
qed

lemma "lift_streams (rev x) = smap rev (lift_streams x)"
proof (induction x)
  case Nil
  have "lift_streams [] = smap rev (lift_streams [])"
    by applicative_lifting simp
  thus ?case by simp
next
  case (Cons x xs)
  have "\<forall>y ys. rev ys @ [y] = rev (y # ys)" by simp
  hence "\<forall>y ys. smap2 append (smap rev ys) (smap2 Cons y (sconst [])) = smap rev (smap2 Cons y ys)"
    by applicative_lifting simp
  with Cons.IH show ?case by applicative_unfold blast
qed

definition [applicative_unfold]: "sconcat xs = smap concat xs"

lemma "sconcat (lift_streams [sconst ''Hello '', sconst ''world!'']) = sconst ''Hello world!''"
by applicative_lifting simp

subsection {* Relators *}

lemma "rel_fun (op =) (op \<le>) (const (0::nat)) x"
by applicative_lifting simp

lemma "list_all2 (op \<subseteq>) (map (\<lambda>_. {}) x) (map set x)"
by applicative_nf simp

lemma "x = Some a \<Longrightarrow> rel_option (op \<le>) (map_option (\<lambda>_. a) x) (map_option Suc x)"
by applicative_lifting simp

schematic_goal "\<forall>g f x. rel_sum ?R (op =) (ap_either f x) (ap_either (ap_either (Inl g) f) x)"
apply applicative_lifting
oops

schematic_goal "stream_all2 ?R (?f \<diamondop> (pure ?g \<diamondop> ?x + ?y)) (?x + ?z)"
apply applicative_lifting
oops

print_applicative

end


(*  Title:    HOL/IMPP/Com.thy
    Author:   David von Oheimb (based on a theory by Tobias Nipkow et al), TUM
*)

section \<open>Semantics of arithmetic and boolean expressions, Syntax of commands\<close>

theory Com
imports MainRLT
begin

type_synonym val = nat
  (* for the meta theory, this may be anything, but types cannot be refined later *)

typedecl glb
typedecl loc

axiomatization
  Arg :: loc and
  Res :: loc

datatype vname  = Glb glb | Loc loc
type_synonym globs = "glb => val"
type_synonym locals = "loc => val"
datatype state  = st globs locals
(* for the meta theory, the following would be sufficient:
typedecl state
consts   st :: "[globs , locals] => state"
*)
type_synonym aexp = "state => val"
type_synonym bexp = "state => bool"

typedecl pname

datatype com
      = SKIP
      | Ass   vname aexp        ("_:==_"                [65, 65    ] 60)
      | Local loc aexp com      ("LOCAL _:=_ IN _"      [65,  0, 61] 60)
      | Semi  com  com          ("_;; _"                [59, 60    ] 59)
      | Cond  bexp com com      ("IF _ THEN _ ELSE _"   [65, 60, 61] 60)
      | While bexp com          ("WHILE _ DO _"         [65,     61] 60)
      | BODY  pname
      | Call  vname pname aexp  ("_:=CALL _'(_')"       [65, 65,  0] 60)

consts bodies :: "(pname  *  com) list"(* finitely many procedure definitions *)
definition
  body :: " pname \<rightharpoonup> com" where
  "body = map_of bodies"

(* Well-typedness: all procedures called must exist *)

inductive WT  :: "com => bool" where

    Skip:    "WT SKIP"

  | Assign:  "WT (X :== a)"

  | Local:   "WT c ==>
              WT (LOCAL Y := a IN c)"

  | Semi:    "[| WT c0; WT c1 |] ==>
              WT (c0;; c1)"

  | If:      "[| WT c0; WT c1 |] ==>
              WT (IF b THEN c0 ELSE c1)"

  | While:   "WT c ==>
              WT (WHILE b DO c)"

  | Body:    "body pn ~= None ==>
              WT (BODY pn)"

  | Call:    "WT (BODY pn) ==>
              WT (X:=CALL pn(a))"

inductive_cases WTs_elim_cases:
  "WT SKIP"  "WT (X:==a)"  "WT (LOCAL Y:=a IN c)"
  "WT (c1;;c2)"  "WT (IF b THEN c1 ELSE c2)"  "WT (WHILE b DO c)"
  "WT (BODY P)"  "WT (X:=CALL P(a))"

definition
  WT_bodies :: bool where
  "WT_bodies = (\<forall>(pn,b) \<in> set bodies. WT b)"

ML \<open>
  fun make_imp_tac ctxt =
    EVERY' [resolve_tac ctxt [mp], fn i => assume_tac ctxt (i + 1), eresolve_tac ctxt [thin_rl]]
\<close>

lemma finite_dom_body: "finite (dom body)"
apply (unfold body_def)
apply (rule finite_dom_map_of)
done

lemma WT_bodiesD: "[| WT_bodies; body pn = Some b |] ==> WT b"
apply (unfold WT_bodies_def body_def)
apply (drule map_of_SomeD)
apply fast
done

declare WTs_elim_cases [elim!]

end


(*  Title:       Lifting Definition Option
    Author:      René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  René Thiemann
    License:     LGPL
*)

(*
Copyright 2014 René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)
theory Lifting_Definition_Option_Explanation
imports
  Lifting_Definition_Option
  Rat
begin

section \<open>Introduction\<close>

text \<open>Often algorithms expect that their input satisfies some specific property @{term P}.
For example, some algorithms require lists as input which have to be sorted,
or numbers which have to be positive,
or programs which have to be well-typed, etc.
Here, there are at least two approaches how one can reason
about these algorithms.

The first approach is to guard all soundness properties of the algorithm
by the additional precondition @{term "P input"}.
So, as an example, a binary search algorithm might take arbitrary lists as input, but only
if the input list is sorted, then the result of the search is meaningful.
Whereas for binary search, this approach is reasonable, there might be problems that the
restriction on the input is even crucial for actually defining the algorithm, since without
the restriction the algorithm might be non-terminating, and thus, cannot be easily defined
using Isabelle's function-package \cite{DBLP:journals/jar/Krauss10}.
As an example, consider an approximation algorithm for
$\sqrt{x}$, where the algorithm should stop once the current approximation $y$ satisfies
@{term "abs(x^2 - y^2) < \<delta>"}. Imagine now, that @{term \<delta>} is a negative number.

To this end, in the second approach the idea is to declare restricted types,
so that the algorithms are only invoked with inputs which satisfy the property @{term P}.
For example, using Isabelle's lifting- and transfer-package
\cite{DBLP:conf/cpp/HuffmanK13},
one can easily define a dedicated type for positive numbers,
and a function which accesses the internal number,
which is then guaranteed to be positive.
\<close>

typedef 'a pos_num = "{ x :: 'a :: linordered_field. x > 0}" morphisms num pos
  by (rule exI[of _ 1], auto)

setup_lifting type_definition_pos_num

lemma num_positive: "num x > 0"
  by (transfer, simp)

text \<open>Using these restricted types, it is often possible to define the desired algorithms
where non-termination because of invalid inputs is no longer possible,
and where soundness properties
can be stated without additional preconditions. E.g., for the approximation algorithm, one
takes @{term "\<delta> :: rat pos_num"} as input, and the approximation stops, once
@{term "abs(x^2 - y^2) < num \<delta>"} is satisfied.

One question in the second approach is how to actually generate elements of the restricted type.
Although one can perform the following definition,
\<close>

lift_definition create_pos_1 :: "'a :: linordered_field \<Rightarrow> 'a pos_num option" is
  "\<lambda> x. if x > 0 then Some x else None"
  by auto

text \<open>\noindent the problem is that corresponding defining equation
@{thm create_pos_1.abs_eq} is not amenable for code-generation,
as it uses the abstraction function @{term pos} in a way which
is not admitted for code-equations
\cite{DBLP:conf/itp/HaftmannKKN13, DBLP:conf/flops/HaftmannN10}.

To overcome this problem, Joachim Breitner proposed the following
workaround\footnote{\url{http://stackoverflow.com/questions/16273812/working-with-isabelles-code-generator-data-refinement-and-higher-order-functio}},
which requires an additional type definition, and some auxiliary definitions,
to in the end define @{term create_pos} in a way that is amenable for code-generation.
\<close>

typedef 'a num_bit = "{ (x :: 'a :: linordered_field, b). b \<longrightarrow> x > 0}" by auto

setup_lifting type_definition_num_bit

lift_definition num_bit_bit :: "('a :: linordered_field) num_bit \<Rightarrow> bool" is snd .
lift_definition num_bit_num :: "('a :: linordered_field) num_bit \<Rightarrow> 'a pos_num" is
  "\<lambda> (x,b). if b then x else 42" by auto

lift_definition num_bit :: "'a :: linordered_field \<Rightarrow> 'a num_bit" is
  "\<lambda> x. if x > 0 then (x, True) else (42, False)" by auto

definition create_pos_2 :: "'a :: linordered_field \<Rightarrow> 'a pos_num option" where
  "create_pos_2 x \<equiv> let nb = num_bit x
    in if num_bit_bit nb then Some (num_bit_num nb) else None"

lemma create_pos_2: "create_pos_2 x = Some p \<Longrightarrow> num p = x"
  unfolding create_pos_2_def Let_def by (transfer, simp split: if_splits)

export_code create_pos_2 in Haskell

text \<open>Breitner's construction has the advantage that the invariant @{term "x > 0"} only
  has to be evaluated once (when invoking @{term num_bit}).
  Hence, the construction allows to create data for types with
  invariants in an efficient, executable, and canonical way.

In this AFP entry we now turned this canonical way into a dedicated method
(\ldo) which automatically
generates the types and auxiliary functions of Breitner's construction. As a result it suffices
to write:\<close>

lift_definition_option create_pos :: "'a :: linordered_field \<Rightarrow> 'a pos_num option" is
  "\<lambda> x :: 'a. if x > 0 then Some x else None"
  by auto

text \<open>Afterwards, we can directly generate code.\<close>

export_code create_pos in Haskell

text \<open>Moreover, we automatically generate two soundness theorems,
that the generated number is the intended one:
@{thm create_pos} and @{thm create_pos_Some}. Here, the morphisms from the type-definitions
reappear, i.e., @{term num} and @{term pos} in the example.\<close>

section \<open>Usage and limitations\<close>

text \<open>The command \ldo{}
is useful to generate elements of
some restricted type (say @{typ 'restricted}) which has been defined as
@{term "{x. P x}"} for some property @{term P} of type @{typ "'base \<Rightarrow> bool"}.
It expects three arguments, namely
\begin{itemize}
\item The name of the definition, e.g., @{term create_pos}.
\item The type of the definition, which must be of the form
  @{typ "'a1 \<Rightarrow> 'a2 \<Rightarrow> 'a_dots \<Rightarrow> 'a_n \<Rightarrow> 'restricted option"}
\item The right-hand side of the definition which must be of the shape
  @{term "\<lambda> x1 x2 x_dots x_n. if check x1 x2 x_dots x_n then Some (generate x1 x2 x_dots x_n) else None"}
  where @{term generate} is of type @{typ "'a1 \<Rightarrow> 'a2 \<Rightarrow> 'a_dots \<Rightarrow> 'a_n \<Rightarrow> 'base option"}
\end{itemize}

After providing the three arguments, a proof of
  @{term "check x1 x2 x_dots x_n \<Longrightarrow> P (generate x1 x2 x_dots x_n)"} has to be provided.
Then, code-equations will be derived and registered, and in addition two
soundness theorems are generated. These are accessible under the names @{term "def_name"}
and @{term "def_name_Some"},
provided that the lifting definition uses @{term "def_name"} as first argument.

Note, that @{term P} is automatically extracted from the type-definition
of @{typ 'restricted}. Similarly, the default value (42 in the @{typ "'a pos_num"}-example)
is generated automatically.

To mention a further limitation besides the strict syntactic structure for the right-hand side,
it is sometimes required,
to add explicit type-annotations in the right-hand-side and the selector, e.g.,
the @{typ "'a"} in @{term   "\<lambda> x :: 'a :: linordered_field. if x > 0 then Some x else None"}.
\<close>

end


theory Tagged_Packet
imports "../../Simple_Firewall/Simple_Packet" Conntrack_State
begin

section\<open>Tagged Simple Packet\<close>
  text\<open>Packet constants are prefixed with @{text p}\<close>

  text\<open>A packet tagged with the following phantom fields:
             conntrack connection state\<close>

  text\<open>The idea to tag the connection state into the packet is sound.
       See @{file "../Semantics_Stateful.thy"}\<close>

  record (overloaded) 'i tagged_packet = "'i::len simple_packet" +
                         p_tag_ctstate :: ctstate

  value "\<lparr>
          p_iiface = ''eth1'', p_oiface = '''',
          p_src = 0, p_dst = 0,
          p_proto = TCP, p_sport = 0, p_dport = 0,
          p_tcp_flags = {TCP_SYN},
          p_payload = ''arbitrary payload'',
          p_tag_ctstate = CT_New
         \<rparr>:: 32 tagged_packet"

  definition simple_packet_tag
    :: "ctstate \<Rightarrow> ('i::len, 'a) simple_packet_scheme \<Rightarrow> ('i::len, 'a) tagged_packet_scheme" where
    "simple_packet_tag ct_state p \<equiv>
      \<lparr>p_iiface = p_iiface p, p_oiface = p_oiface p, p_src = p_src p, p_dst = p_dst p, p_proto = p_proto p,
       p_sport = p_sport p, p_dport = p_dport p, p_tcp_flags = p_tcp_flags p,
       p_payload = p_payload p,
       p_tag_ctstate = ct_state,
       \<dots> = simple_packet.more p\<rparr>"

  definition tagged_packet_untag
    :: "('i::len, 'a) tagged_packet_scheme \<Rightarrow> ('i::len, 'a) simple_packet_scheme" where
    "tagged_packet_untag p \<equiv>
      \<lparr>p_iiface = p_iiface p, p_oiface = p_oiface p, p_src = p_src p, p_dst = p_dst p, p_proto = p_proto p,
       p_sport = p_sport p, p_dport = p_dport p, p_tcp_flags = p_tcp_flags p,
       p_payload = p_payload p,
       \<dots> = tagged_packet.more p\<rparr>"

  lemma "tagged_packet_untag (simple_packet_tag ct_state p) = p"
        "simple_packet_tag ct_state (tagged_packet_untag p) = p\<lparr>p_tag_ctstate := ct_state\<rparr>"
    apply(case_tac [!] p)
     by(simp add: tagged_packet_untag_def simple_packet_tag_def)+

end


section \<open>\<open>Extra_General\<close> -- General missing things\<close>

theory Extra_General
  imports
    "HOL-Library.Cardinality"
    "HOL-Analysis.Elementary_Topology"
    "HOL-Analysis.Uniform_Limit"
    "HOL-Library.Set_Algebras"
    "HOL-Types_To_Sets.Types_To_Sets"
    "HOL-Library.Complex_Order"
    "HOL-Analysis.Infinite_Sum"
    "HOL-Cardinals.Cardinals"
    "HOL-Library.Complemented_Lattices"
begin

subsection \<open>Misc\<close>

lemma reals_zero_comparable:
  fixes x::complex
  assumes "x\<in>\<real>"
  shows "x \<le> 0 \<or> x \<ge> 0"
  using assms unfolding complex_is_real_iff_compare0 by assumption

lemma unique_choice: "\<forall>x. \<exists>!y. Q x y \<Longrightarrow> \<exists>!f. \<forall>x. Q x (f x)"
  apply (auto intro!: choice ext) by metis

lemma image_set_plus:
  assumes \<open>linear U\<close>
  shows \<open>U ` (A + B) = U ` A + U ` B\<close>
  unfolding image_def set_plus_def
  using assms by (force simp: linear_add)

consts heterogenous_identity :: \<open>'a \<Rightarrow> 'b\<close>
overloading heterogenous_identity_id \<equiv> "heterogenous_identity :: 'a \<Rightarrow> 'a" begin
definition heterogenous_identity_def[simp]: \<open>heterogenous_identity_id = id\<close>
end

lemma L2_set_mono2:
  assumes a1: "finite L" and a2: "K \<le> L"
  shows "L2_set f K \<le> L2_set f L"
proof-
  have "(\<Sum>i\<in>K. (f i)\<^sup>2) \<le> (\<Sum>i\<in>L. (f i)\<^sup>2)"
    apply (rule sum_mono2)
    using assms by auto
  hence "sqrt (\<Sum>i\<in>K. (f i)\<^sup>2) \<le> sqrt (\<Sum>i\<in>L. (f i)\<^sup>2)"
    by (rule real_sqrt_le_mono)
  thus ?thesis
    unfolding L2_set_def.
qed

lemma Sup_real_close:
  fixes e :: real
  assumes "0 < e"
    and S: "bdd_above S" "S \<noteq> {}"
  shows "\<exists>x\<in>S. Sup S - e < x"
proof -
  have \<open>Sup (ereal ` S) \<noteq> \<infinity>\<close>
    by (metis assms(2) bdd_above_def ereal_less_eq(3) less_SUP_iff less_ereal.simps(4) not_le)
  moreover have \<open>Sup (ereal ` S) \<noteq> -\<infinity>\<close>
    by (simp add: SUP_eq_iff assms(3))
  ultimately have Sup_bdd: \<open>\<bar>Sup (ereal ` S)\<bar> \<noteq> \<infinity>\<close>
    by auto
  then have \<open>\<exists>x'\<in>ereal ` S. Sup (ereal ` S) - ereal e < x'\<close>
    apply (rule_tac Sup_ereal_close)
    using assms by auto
  then obtain x where \<open>x \<in> S\<close> and Sup_x: \<open>Sup (ereal ` S) - ereal e < ereal x\<close>
    by auto
  have \<open>Sup (ereal ` S) = ereal (Sup S)\<close>
    using Sup_bdd by (rule ereal_Sup[symmetric])
  with Sup_x have \<open>ereal (Sup S - e) < ereal x\<close>
    by auto
  then have \<open>Sup S - e < x\<close>
    by auto
  with \<open>x \<in> S\<close> show ?thesis
    by auto
qed

text \<open>Improved version of @{attribute internalize_sort}: It is not necessary to specify the sort of the type variable.\<close>
attribute_setup internalize_sort' = \<open>let
fun find_tvar thm v = let
  val tvars = Term.add_tvars (Thm.prop_of thm) []
  val tv = case find_first (fn (n,sort) => n=v) tvars of
              SOME tv => tv | NONE => raise THM ("Type variable " ^ string_of_indexname v ^ " not found", 0, [thm])
in
TVar tv
end

fun internalize_sort_attr (tvar:indexname) =
  Thm.rule_attribute [] (fn context => fn thm =>
    (snd (Internalize_Sort.internalize_sort (Thm.ctyp_of (Context.proof_of context) (find_tvar thm tvar)) thm)));
in
  Scan.lift Args.var >> internalize_sort_attr
end\<close>
  "internalize a sort"

lemma card_prod_omega: \<open>X *c natLeq =o X\<close> if \<open>Cinfinite X\<close>
  by (simp add: Cinfinite_Cnotzero cprod_infinite1' natLeq_Card_order natLeq_cinfinite natLeq_ordLeq_cinfinite that)

lemma countable_leq_natLeq: \<open>|X| \<le>o natLeq\<close> if \<open>countable X\<close>
  using subset_range_from_nat_into[OF that]
  by (meson card_of_nat ordIso_iff_ordLeq ordLeq_transitive surj_imp_ordLeq)

lemma set_Times_plus_distrib: \<open>(A \<times> B) + (C \<times> D) = (A + C) \<times> (B + D)\<close>
  by (auto simp: Sigma_def set_plus_def)

subsection \<open>Not singleton\<close>

class not_singleton =
  assumes not_singleton_card: "\<exists>x y. x \<noteq> y"

lemma not_singleton_existence[simp]:
  \<open>\<exists> x::('a::not_singleton). x \<noteq> t\<close>
  using not_singleton_card[where ?'a = 'a] by (metis (full_types))

lemma UNIV_not_singleton[simp]: "(UNIV::_::not_singleton set) \<noteq> {x}"
  using not_singleton_existence[of x] by blast

lemma UNIV_not_singleton_converse:
  assumes"\<And>x::'a. UNIV \<noteq> {x}"
  shows "\<exists>x::'a. \<exists>y. x \<noteq> y"
  using assms
  by fastforce

subclass (in card2) not_singleton
  apply standard using two_le_card
  by (meson card_2_iff' obtain_subset_with_card_n)

subclass (in perfect_space) not_singleton
  apply intro_classes
  by (metis (mono_tags) Collect_cong Collect_mem_eq UNIV_I local.UNIV_not_singleton local.not_open_singleton local.open_subopen)

lemma class_not_singletonI_monoid_add:
  assumes "(UNIV::'a set) \<noteq> {0}"
  shows "class.not_singleton TYPE('a::monoid_add)"
proof intro_classes
  let ?univ = "UNIV :: 'a set"
  from assms obtain x::'a where "x \<noteq> 0"
    by auto
  thus "\<exists>x y :: 'a. x \<noteq> y"
    by auto
qed

lemma not_singleton_vs_CARD_1:
  assumes \<open>\<not> class.not_singleton TYPE('a)\<close>
  shows \<open>class.CARD_1 TYPE('a)\<close>
  using assms unfolding class.not_singleton_def class.CARD_1_def
  by (metis (full_types) One_nat_def UNIV_I card.empty card.insert empty_iff equalityI finite.intros(1) insert_iff subsetI)

subsection \<open>\<^class>\<open>CARD_1\<close>\<close>

context CARD_1 begin

lemma everything_the_same[simp]: "(x::'a)=y"
  by (metis (full_types) UNIV_I card_1_singletonE empty_iff insert_iff local.CARD_1)

lemma CARD_1_UNIV: "UNIV = {x::'a}"
  by (metis (full_types) UNIV_I card_1_singletonE local.CARD_1 singletonD)

lemma CARD_1_ext: "x (a::'a) = y b \<Longrightarrow> x = y"
proof (rule ext)
  show "x t = y t"
    if "x a = y b"
    for t :: 'a
    using that  apply (subst (asm) everything_the_same[where x=a])
    apply (subst (asm) everything_the_same[where x=b])
    by simp
qed

end

instance unit :: CARD_1
  apply standard by auto

instance prod :: (CARD_1, CARD_1) CARD_1
  apply intro_classes
  by (simp add: CARD_1)

instance "fun" :: (CARD_1, CARD_1) CARD_1
  apply intro_classes
  by (auto simp add: card_fun CARD_1)

lemma enum_CARD_1: "(Enum.enum :: 'a::{CARD_1,enum} list) = [a]"
proof -
  let ?enum = "Enum.enum :: 'a::{CARD_1,enum} list"
  have "length ?enum = 1"
    apply (subst card_UNIV_length_enum[symmetric])
    by (rule CARD_1)
  then obtain b where "?enum = [b]"
    apply atomize_elim
    apply (cases ?enum, auto)
    by (metis length_0_conv length_Cons nat.inject)
  thus "?enum = [a]"
    by (subst everything_the_same[of _ b], simp)
qed

lemma card_not_singleton: \<open>CARD('a::not_singleton) \<noteq> 1\<close>
  by (simp add: card_1_singleton_iff)

subsection \<open>Topology\<close>

lemma cauchy_filter_metricI:
  fixes F :: "'a::metric_space filter"
  assumes "\<And>e. e>0 \<Longrightarrow> \<exists>P. eventually P F \<and> (\<forall>x y. P x \<and> P y \<longrightarrow> dist x y < e)"
  shows "cauchy_filter F"
proof (unfold cauchy_filter_def le_filter_def, auto)
  fix P :: "'a \<times> 'a \<Rightarrow> bool"
  assume "eventually P uniformity"
  then obtain e where e: "e > 0" and P: "dist x y < e \<Longrightarrow> P (x, y)" for x y
    unfolding eventually_uniformity_metric by auto

  obtain P' where evP': "eventually P' F" and P'_dist: "P' x \<and> P' y \<Longrightarrow> dist x y < e" for x y
    apply atomize_elim using assms e by auto

  from evP' P'_dist P
  show "eventually P (F \<times>\<^sub>F F)"
    unfolding eventually_uniformity_metric eventually_prod_filter eventually_filtermap by metis
qed

lemma cauchy_filter_metric_filtermapI:
  fixes F :: "'a filter" and f :: "'a\<Rightarrow>'b::metric_space"
  assumes "\<And>e. e>0 \<Longrightarrow> \<exists>P. eventually P F \<and> (\<forall>x y. P x \<and> P y \<longrightarrow> dist (f x) (f y) < e)"
  shows "cauchy_filter (filtermap f F)"
proof (rule cauchy_filter_metricI)
  fix e :: real assume e: "e > 0"
  with assms obtain P where evP: "eventually P F" and dist: "P x \<and> P y \<Longrightarrow> dist (f x) (f y) < e" for x y
    by atomize_elim auto
  define P' where "P' y = (\<exists>x. P x \<and> y = f x)" for y
  have "eventually P' (filtermap f F)"
    unfolding eventually_filtermap P'_def
    using evP
    by (smt eventually_mono)
  moreover have "P' x \<and> P' y \<longrightarrow> dist x y < e" for x y
    unfolding P'_def using dist by metis
  ultimately show "\<exists>P. eventually P (filtermap f F) \<and> (\<forall>x y. P x \<and> P y \<longrightarrow> dist x y < e)"
    by auto
qed

lemma tendsto_add_const_iff:
  \<comment> \<open>This is a generalization of \<open>Limits.tendsto_add_const_iff\<close>,
      the only difference is that the sort here is more general.\<close>
  "((\<lambda>x. c + f x :: 'a::topological_group_add) \<longlongrightarrow> c + d) F \<longleftrightarrow> (f \<longlongrightarrow> d) F"
  using tendsto_add[OF tendsto_const[of c], of f d]
    and tendsto_add[OF tendsto_const[of "-c"], of "\<lambda>x. c + f x" "c + d"] by auto

lemma finite_subsets_at_top_minus:
  assumes "A\<subseteq>B"
  shows "finite_subsets_at_top (B - A) \<le> filtermap (\<lambda>F. F - A) (finite_subsets_at_top B)"
proof (rule filter_leI)
  fix P assume "eventually P (filtermap (\<lambda>F. F - A) (finite_subsets_at_top B))"
  then obtain X where "finite X" and "X \<subseteq> B"
    and P: "finite Y \<and> X \<subseteq> Y \<and> Y \<subseteq> B \<longrightarrow> P (Y - A)" for Y
    unfolding eventually_filtermap eventually_finite_subsets_at_top by auto

  hence "finite (X-A)" and "X-A \<subseteq> B - A"
    by auto
  moreover have "finite Y \<and> X-A \<subseteq> Y \<and> Y \<subseteq> B - A \<longrightarrow> P Y" for Y
    using P[where Y="Y\<union>X"] \<open>finite X\<close> \<open>X \<subseteq> B\<close>
    by (metis Diff_subset Int_Diff Un_Diff finite_Un inf.orderE le_sup_iff sup.orderE sup_ge2)
  ultimately show "eventually P (finite_subsets_at_top (B - A))"
    unfolding eventually_finite_subsets_at_top by meson
qed

lemma finite_subsets_at_top_inter:
  assumes "A\<subseteq>B"
  shows "filtermap (\<lambda>F. F \<inter> A) (finite_subsets_at_top B) = finite_subsets_at_top A"
proof (subst filter_eq_iff, intro allI iffI)
  fix P :: "'a set \<Rightarrow> bool"
  assume "eventually P (finite_subsets_at_top A)"
  then show "eventually P (filtermap (\<lambda>F. F \<inter> A) (finite_subsets_at_top B))"
    unfolding eventually_filtermap
    unfolding eventually_finite_subsets_at_top
    by (metis Int_subset_iff assms finite_Int inf_le2 subset_trans)
next
  fix P :: "'a set \<Rightarrow> bool"
  assume "eventually P (filtermap (\<lambda>F. F \<inter> A) (finite_subsets_at_top B))"
  then obtain X where \<open>finite X\<close> \<open>X \<subseteq> B\<close> and P: \<open>finite Y \<Longrightarrow> X \<subseteq> Y \<Longrightarrow> Y \<subseteq> B \<Longrightarrow> P (Y \<inter> A)\<close> for Y
    unfolding eventually_filtermap eventually_finite_subsets_at_top by metis
  have *: \<open>finite Y \<Longrightarrow> X \<inter> A \<subseteq> Y \<Longrightarrow> Y \<subseteq> A \<Longrightarrow> P Y\<close> for Y
    using P[where Y=\<open>Y \<union> (B-A)\<close>]
    apply (subgoal_tac \<open>(Y \<union> (B - A)) \<inter> A = Y\<close>)
    apply (smt (verit, best) Int_Un_distrib2 Int_Un_eq(4) P Un_subset_iff \<open>X \<subseteq> B\<close> \<open>finite X\<close> assms finite_UnI inf.orderE sup_ge2)
    by auto
  show "eventually P (finite_subsets_at_top A)"
    unfolding eventually_finite_subsets_at_top
    apply (rule exI[of _ \<open>X\<inter>A\<close>])
    by (auto simp: \<open>finite X\<close> intro!: *)
qed

lemma tendsto_principal_singleton:
  shows "(f \<longlongrightarrow> f x) (principal {x})"
  unfolding tendsto_def eventually_principal by simp

lemma complete_singleton:
  "complete {s::'a::uniform_space}"
proof-
  have "F \<le> principal {s} \<Longrightarrow>
         F \<noteq> bot \<Longrightarrow> cauchy_filter F \<Longrightarrow> F \<le> nhds s" for F
    by (metis eventually_nhds eventually_principal le_filter_def singletonD)
  thus ?thesis
    unfolding complete_uniform
    by simp
qed

lemma on_closure_eqI:
  fixes f g :: \<open>'a::topological_space \<Rightarrow> 'b::t2_space\<close>
  assumes eq: \<open>\<And>x. x \<in> S \<Longrightarrow> f x = g x\<close>
  assumes xS: \<open>x \<in> closure S\<close>
  assumes cont: \<open>continuous_on UNIV f\<close> \<open>continuous_on UNIV g\<close>
  shows \<open>f x = g x\<close>
proof -
  define X where \<open>X = {x. f x = g x}\<close>
  have \<open>closed X\<close>
    using cont by (simp add: X_def closed_Collect_eq)
  moreover have \<open>S \<subseteq> X\<close>
    by (simp add: X_def eq subsetI)
  ultimately have \<open>closure S \<subseteq> X\<close>
    using closure_minimal by blast
  with xS have \<open>x \<in> X\<close>
    by auto
  then show ?thesis
    using X_def by blast
qed

lemma on_closure_leI:
  fixes f g :: \<open>'a::topological_space \<Rightarrow> 'b::linorder_topology\<close>
  assumes eq: \<open>\<And>x. x \<in> S \<Longrightarrow> f x \<le> g x\<close>
  assumes xS: \<open>x \<in> closure S\<close>
  assumes cont: \<open>continuous_on UNIV f\<close> \<open>continuous_on UNIV g\<close> (* Is "isCont f x" "isCont g x" sufficient? *)
  shows \<open>f x \<le> g x\<close>
proof -
  define X where \<open>X = {x. f x \<le> g x}\<close>
  have \<open>closed X\<close>
    using cont by (simp add: X_def closed_Collect_le)
  moreover have \<open>S \<subseteq> X\<close>
    by (simp add: X_def eq subsetI)
  ultimately have \<open>closure S \<subseteq> X\<close>
    using closure_minimal by blast
  with xS have \<open>x \<in> X\<close>
    by auto
  then show ?thesis
    using X_def by blast
qed

lemma tendsto_compose_at_within:
  assumes f: "(f \<longlongrightarrow> y) F" and g: "(g \<longlongrightarrow> z) (at y within S)"
    and fg: "eventually (\<lambda>w. f w = y \<longrightarrow> g y = z) F"
    and fS: \<open>\<forall>\<^sub>F w in F. f w \<in> S\<close>
  shows "((g \<circ> f) \<longlongrightarrow> z) F"
proof (cases \<open>g y = z\<close>)
  case False
  then have 1: "(\<forall>\<^sub>F a in F. f a \<noteq> y)"
    using fg by force
  have 2: "(g \<longlongrightarrow> z) (filtermap f F) \<or> \<not> (\<forall>\<^sub>F a in F. f a \<noteq> y)"
    by (smt (verit, best) eventually_elim2 f fS filterlim_at filterlim_def g tendsto_mono)
  show ?thesis
    using "1" "2" tendsto_compose_filtermap by blast
next
  case True
  have *: ?thesis if \<open>(g \<longlongrightarrow> z) (filtermap f F)\<close>
    using that by (simp add: tendsto_compose_filtermap)
  from g
  have \<open>(g \<longlongrightarrow> g y) (inf (nhds y) (principal (S-{y})))\<close>
    by (simp add: True at_within_def)
  then have g': \<open>(g \<longlongrightarrow> g y) (inf (nhds y) (principal S))\<close>
    using True g tendsto_at_iff_tendsto_nhds_within by blast
  from f have \<open>filterlim f (nhds y) F\<close>
    by -
  then have f': \<open>filterlim f (inf (nhds y) (principal S)) F\<close>
    using fS
    by (simp add: filterlim_inf filterlim_principal)
  from f' g' show ?thesis
    by (simp add: * True filterlim_compose filterlim_filtermap)
qed

subsection \<open>Sums\<close>

lemma sum_single:
  assumes "finite A"
  assumes "\<And>j. j \<noteq> i \<Longrightarrow> j\<in>A \<Longrightarrow> f j = 0"
  shows "sum f A = (if i\<in>A then f i else 0)"
  apply (subst sum.mono_neutral_cong_right[where S=\<open>A \<inter> {i}\<close> and h=f])
  using assms by auto

lemma has_sum_comm_additive_general:
  \<comment> \<open>This is a strengthening of @{thm [source] has_sum_comm_additive_general}.\<close>
  fixes f :: \<open>'b :: {comm_monoid_add,topological_space} \<Rightarrow> 'c :: {comm_monoid_add,topological_space}\<close>
  assumes f_sum: \<open>\<And>F. finite F \<Longrightarrow> F \<subseteq> S \<Longrightarrow> sum (f o g) F = f (sum g F)\<close>
      \<comment> \<open>Not using \<^const>\<open>additive\<close> because it would add sort constraint \<^class>\<open>ab_group_add\<close>\<close>
  assumes inS: \<open>\<And>F. finite F \<Longrightarrow> sum g F \<in> T\<close>
  assumes cont: \<open>(f \<longlongrightarrow> f x) (at x within T)\<close>
    \<comment> \<open>For \<^class>\<open>t2_space\<close> and \<^term>\<open>T=UNIV\<close>, this is equivalent to \<open>isCont f x\<close> by @{thm [source] isCont_def}.\<close>
  assumes infsum: \<open>(g has_sum x) S\<close>
  shows \<open>((f o g) has_sum (f x)) S\<close>
proof -
  have \<open>(sum g \<longlongrightarrow> x) (finite_subsets_at_top S)\<close>
    using infsum has_sum_def by blast
  then have \<open>((f o sum g) \<longlongrightarrow> f x) (finite_subsets_at_top S)\<close>
    apply (rule tendsto_compose_at_within[where S=T])
    using assms by auto
  then have \<open>(sum (f o g) \<longlongrightarrow> f x) (finite_subsets_at_top S)\<close>
    apply (rule tendsto_cong[THEN iffD1, rotated])
    using f_sum by fastforce
  then show \<open>((f o g) has_sum (f x)) S\<close>
    using has_sum_def by blast
qed

lemma summable_on_comm_additive_general:
  \<comment> \<open>This is a strengthening of @{thm [source] summable_on_comm_additive_general}.\<close>
  fixes g :: \<open>'a \<Rightarrow> 'b :: {comm_monoid_add,topological_space}\<close> and f :: \<open>'b \<Rightarrow> 'c :: {comm_monoid_add,topological_space}\<close>
  assumes \<open>\<And>F. finite F \<Longrightarrow> F \<subseteq> S \<Longrightarrow> sum (f o g) F = f (sum g F)\<close>
    \<comment> \<open>Not using \<^const>\<open>additive\<close> because it would add sort constraint \<^class>\<open>ab_group_add\<close>\<close>
  assumes inS: \<open>\<And>F. finite F \<Longrightarrow> sum g F \<in> T\<close>
  assumes cont: \<open>\<And>x. (g has_sum x) S \<Longrightarrow> (f \<longlongrightarrow> f x) (at x within T)\<close>
    \<comment> \<open>For \<^class>\<open>t2_space\<close> and \<^term>\<open>T=UNIV\<close>, this is equivalent to \<open>isCont f x\<close> by @{thm [source] isCont_def}.\<close>
  assumes \<open>g summable_on S\<close>
  shows \<open>(f o g) summable_on S\<close>
  by (meson assms summable_on_def has_sum_comm_additive_general has_sum_def infsum_tendsto)

lemma has_sum_metric:
  fixes l :: \<open>'a :: {metric_space, comm_monoid_add}\<close>
  shows \<open>(f has_sum l) A \<longleftrightarrow> (\<forall>e. e > 0 \<longrightarrow> (\<exists>X. finite X \<and> X \<subseteq> A \<and> (\<forall>Y. finite Y \<and> X \<subseteq> Y \<and> Y \<subseteq> A \<longrightarrow> dist (sum f Y) l < e)))\<close>
  unfolding has_sum_def
  apply (subst tendsto_iff)
  unfolding eventually_finite_subsets_at_top
  by simp

lemma summable_on_product_finite_left:
  fixes f :: \<open>'a\<times>'b \<Rightarrow> 'c::{topological_comm_monoid_add}\<close>
  assumes sum: \<open>\<And>x. x\<in>X \<Longrightarrow> (\<lambda>y. f(x,y)) summable_on Y\<close>
  assumes \<open>finite X\<close>
  shows \<open>f summable_on (X\<times>Y)\<close>
  using \<open>finite X\<close> subset_refl[of X]
proof (induction rule: finite_subset_induct')
  case empty
  then show ?case
    by simp
next
  case (insert x F)
  have *: \<open>bij_betw (Pair x) Y ({x} \<times> Y)\<close>
    apply (rule bij_betwI')
    by auto
  from sum[of x]
  have \<open>f summable_on {x} \<times> Y\<close>
    apply (rule summable_on_reindex_bij_betw[THEN iffD1, rotated])
    by (simp_all add: * insert.hyps(2))
  then have \<open>f summable_on {x} \<times> Y \<union> F \<times> Y\<close>
    apply (rule summable_on_Un_disjoint)
    using insert by auto
  then show ?case
    by (metis Sigma_Un_distrib1 insert_is_Un)
qed

lemma summable_on_product_finite_right:
  fixes f :: \<open>'a\<times>'b \<Rightarrow> 'c::{topological_comm_monoid_add}\<close>
  assumes sum: \<open>\<And>y. y\<in>Y \<Longrightarrow> (\<lambda>x. f(x,y)) summable_on X\<close>
  assumes \<open>finite Y\<close>
  shows \<open>f summable_on (X\<times>Y)\<close>
proof -
  have \<open>(\<lambda>(y,x). f(x,y)) summable_on (Y\<times>X)\<close>
    apply (rule summable_on_product_finite_left)
    using assms by auto
  then show ?thesis
    apply (subst summable_on_reindex_bij_betw[where g=prod.swap and A=\<open>Y\<times>X\<close>, symmetric])
    apply (simp add: bij_betw_def product_swap)
    by (metis (mono_tags, lifting) case_prod_unfold prod.swap_def summable_on_cong)
qed

subsection \<open>Complex numbers\<close>

lemma cmod_Re:
  assumes "x \<ge> 0"
  shows "cmod x = Re x"
  using assms unfolding less_eq_complex_def cmod_def
  by auto

lemma abs_complex_real[simp]: "abs x \<in> \<real>" for x :: complex
  by (simp add: abs_complex_def)

lemma Im_abs[simp]: "Im (abs x) = 0"
  using abs_complex_real complex_is_Real_iff by blast

lemma cnj_x_x: "cnj x * x = (abs x)\<^sup>2"
proof (cases x)
  show "cnj x * x = \<bar>x\<bar>\<^sup>2"
    if "x = Complex x1 x2"
    for x1 :: real
      and x2 :: real
    using that
    by (auto simp: complex_cnj complex_mult abs_complex_def
        complex_norm power2_eq_square complex_of_real_def)
qed

lemma cnj_x_x_geq0[simp]: \<open>cnj x * x \<ge> 0\<close>
  by (simp add: less_eq_complex_def)

lemma complex_of_real_leq_1_iff[iff]: \<open>complex_of_real x \<le> 1 \<longleftrightarrow> x \<le> 1\<close>
  by (simp add: less_eq_complex_def)

lemma x_cnj_x: \<open>x * cnj x = (abs x)\<^sup>2\<close>
  by (metis cnj_x_x mult.commute)

subsection \<open>List indices and enum\<close>

fun index_of where
  "index_of x [] = (0::nat)"
| "index_of x (y#ys) = (if x=y then 0 else (index_of x ys + 1))"

definition "enum_idx (x::'a::enum) = index_of x (enum_class.enum :: 'a list)"

lemma index_of_length: "index_of x y \<le> length y"
  apply (induction y) by auto

lemma index_of_correct:
  assumes "x \<in> set y"
  shows "y ! index_of x y = x"
  using assms apply (induction y arbitrary: x)
  by auto

lemma enum_idx_correct:
  "Enum.enum ! enum_idx i = i"
proof-
  have "i \<in> set enum_class.enum"
    using UNIV_enum by blast
  thus ?thesis
    unfolding enum_idx_def
    using index_of_correct by metis
qed

lemma index_of_bound:
  assumes "y \<noteq> []" and "x \<in> set y"
  shows "index_of x y < length y"
  using assms proof(induction y arbitrary: x)
  case Nil
  thus ?case by auto
next
  case (Cons a y)
  show ?case
  proof(cases "a = x")
    case True
    thus ?thesis by auto
  next
    case False
    moreover have "a \<noteq> x \<Longrightarrow> index_of x y < length y"
      using Cons.IH Cons.prems(2) by fastforce
    ultimately show ?thesis by auto
  qed
qed

lemma enum_idx_bound: "enum_idx x < length (Enum.enum :: 'a list)" for x :: "'a::enum"
proof-
  have p1: "False"
    if "(Enum.enum :: 'a list) = []"
  proof-
    have "(UNIV::'a set) = set ([]::'a list)"
      using that UNIV_enum by metis
    also have "\<dots> = {}"
      by blast
    finally have "(UNIV::'a set) = {}".
    thus ?thesis by simp
  qed
  have p2: "x \<in> set (Enum.enum :: 'a list)"
    using UNIV_enum by auto
  moreover have "(enum_class.enum::'a list) \<noteq> []"
    using p2 by auto
  ultimately show ?thesis
    unfolding enum_idx_def
    using index_of_bound [where x = x and y = "(Enum.enum :: 'a list)"]
    by auto
qed

lemma index_of_nth:
  assumes "distinct xs"
  assumes "i < length xs"
  shows "index_of (xs ! i) xs = i"
  using assms
  by (metis gr_implies_not_zero index_of_bound index_of_correct length_0_conv nth_eq_iff_index_eq nth_mem)

lemma enum_idx_enum:
  assumes \<open>i < CARD('a::enum)\<close>
  shows \<open>enum_idx (enum_class.enum ! i :: 'a) = i\<close>
  unfolding enum_idx_def apply (rule index_of_nth)
  using assms by (simp_all add: card_UNIV_length_enum enum_distinct)

subsection \<open>Filtering lists/sets\<close>

lemma map_filter_map: "List.map_filter f (map g l) = List.map_filter (f o g) l"
proof (induction l)
  show "List.map_filter f (map g []) = List.map_filter (f \<circ> g) []"
    by (simp add: map_filter_simps)
  show "List.map_filter f (map g (a # l)) = List.map_filter (f \<circ> g) (a # l)"
    if "List.map_filter f (map g l) = List.map_filter (f \<circ> g) l"
    for a :: 'c
      and l :: "'c list"
    using that  map_filter_simps(1)
    by (metis comp_eq_dest_lhs list.simps(9))
qed

lemma map_filter_Some[simp]: "List.map_filter (\<lambda>x. Some (f x)) l = map f l"
proof (induction l)
  show "List.map_filter (\<lambda>x. Some (f x)) [] = map f []"
    by (simp add: map_filter_simps)
  show "List.map_filter (\<lambda>x. Some (f x)) (a # l) = map f (a # l)"
    if "List.map_filter (\<lambda>x. Some (f x)) l = map f l"
    for a :: 'b
      and l :: "'b list"
    using that by (simp add: map_filter_simps(1))
qed

lemma filter_Un: "Set.filter f (x \<union> y) = Set.filter f x \<union> Set.filter f y"
  unfolding Set.filter_def by auto

lemma Set_filter_unchanged: "Set.filter P X = X" if "\<And>x. x\<in>X \<Longrightarrow> P x" for P and X :: "'z set"
  using that unfolding Set.filter_def by auto

subsection \<open>Maps\<close>

definition "inj_map \<pi> = (\<forall>x y. \<pi> x = \<pi> y \<and> \<pi> x \<noteq> None \<longrightarrow> x = y)"

definition "inv_map \<pi> = (\<lambda>y. if Some y \<in> range \<pi> then Some (inv \<pi> (Some y)) else None)"

lemma inj_map_total[simp]: "inj_map (Some o \<pi>) = inj \<pi>"
  unfolding inj_map_def inj_def by simp

lemma inj_map_Some[simp]: "inj_map Some"
  by (simp add: inj_map_def)

lemma inv_map_total:
  assumes "surj \<pi>"
  shows "inv_map (Some o \<pi>) = Some o inv \<pi>"
proof-
  have "(if Some y \<in> range (\<lambda>x. Some (\<pi> x))
          then Some (SOME x. Some (\<pi> x) = Some y)
          else None) =
         Some (SOME b. \<pi> b = y)"
    if "surj \<pi>"
    for y
    using that by auto
  hence  "surj \<pi> \<Longrightarrow>
    (\<lambda>y. if Some y \<in> range (\<lambda>x. Some (\<pi> x))
         then Some (SOME x. Some (\<pi> x) = Some y) else None) =
    (\<lambda>x. Some (SOME xa. \<pi> xa = x))"
    by (rule ext)
  thus ?thesis
    unfolding inv_map_def o_def inv_def
    using assms by linarith
qed

lemma inj_map_map_comp[simp]:
  assumes a1: "inj_map f" and a2: "inj_map g"
  shows "inj_map (f \<circ>\<^sub>m g)"
  using a1 a2
  unfolding inj_map_def
  by (metis (mono_tags, lifting) map_comp_def option.case_eq_if option.expand)

lemma inj_map_inv_map[simp]: "inj_map (inv_map \<pi>)"
proof (unfold inj_map_def, rule allI, rule allI, rule impI, erule conjE)
  fix x y
  assume same: "inv_map \<pi> x = inv_map \<pi> y"
    and pix_not_None: "inv_map \<pi> x \<noteq> None"
  have x_pi: "Some x \<in> range \<pi>"
    using pix_not_None unfolding inv_map_def apply auto
    by (meson option.distinct(1))
  have y_pi: "Some y \<in> range \<pi>"
    using pix_not_None unfolding same unfolding inv_map_def apply auto
    by (meson option.distinct(1))
  have "inv_map \<pi> x = Some (Hilbert_Choice.inv \<pi> (Some x))"
    unfolding inv_map_def using x_pi by simp
  moreover have "inv_map \<pi> y = Some (Hilbert_Choice.inv \<pi> (Some y))"
    unfolding inv_map_def using y_pi by simp
  ultimately have "Hilbert_Choice.inv \<pi> (Some x) = Hilbert_Choice.inv \<pi> (Some y)"
    using same by simp
  thus "x = y"
    by (meson inv_into_injective option.inject x_pi y_pi)
qed

subsection \<open>Lattices\<close>

unbundle lattice_syntax

text \<open>The following lemma is identical to @{thm [source] Complete_Lattices.uminus_Inf}
  except for the more general sort.\<close>
lemma uminus_Inf: "- (\<Sqinter>A) = \<Squnion>(uminus ` A)" for A :: \<open>'a::complete_orthocomplemented_lattice set\<close>
proof (rule order.antisym)
  show "- \<Sqinter>A \<le> \<Squnion>(uminus ` A)"
    by (rule compl_le_swap2, rule Inf_greatest, rule compl_le_swap2, rule Sup_upper) simp
  show "\<Squnion>(uminus ` A) \<le> - \<Sqinter>A"
    by (rule Sup_least, rule compl_le_swap1, rule Inf_lower) auto
qed

text \<open>The following lemma is identical to @{thm [source] Complete_Lattices.uminus_INF}
  except for the more general sort.\<close>
lemma uminus_INF: "- (INF x\<in>A. B x) = (SUP x\<in>A. - B x)" for B :: \<open>'a \<Rightarrow> 'b::complete_orthocomplemented_lattice\<close>
  by (simp add: uminus_Inf image_image)

text \<open>The following lemma is identical to @{thm [source] Complete_Lattices.uminus_Sup}
  except for the more general sort.\<close>
lemma uminus_Sup: "- (\<Squnion>A) = \<Sqinter>(uminus ` A)" for A :: \<open>'a::complete_orthocomplemented_lattice set\<close>
  by (metis (no_types, lifting) uminus_INF image_cong image_ident ortho_involution)

text \<open>The following lemma is identical to @{thm [source] Complete_Lattices.uminus_SUP}
  except for the more general sort.\<close>
lemma uminus_SUP: "- (SUP x\<in>A. B x) = (INF x\<in>A. - B x)" for B :: \<open>'a \<Rightarrow> 'b::complete_orthocomplemented_lattice\<close>
  by (simp add: uminus_Sup image_image)

end


subsection \<open>IMO 2006 SL - A2\<close>

theory IMO_2006_SL_A2
imports Complex_Main
begin

theorem IMO_2006_SL_A2:
  fixes a :: "nat \<Rightarrow> real"
  assumes "a 0 = -1" "\<forall> n \<ge> 1. (\<Sum> k < n + 1. a (n - k) / (k + 1)) = 0" "n \<ge> 1"
  shows "a n > 0"
  sorry

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory HaskellLemmaBucket
imports
  HaskellLib_H
  NonDetMonadLemmaBucket
begin

lemma map_bits_to_bl:
  "map ((!!) x) [0..<size x] = reverse (to_bl x)"
  by (simp add: map_bits_rev_to_bl)

lemma not_orList_is_replicate:
  "\<not> orList ls \<Longrightarrow> ls = replicate (length ls) False"
proof (induct ls rule: rev_induct)
  case Nil thus ?case unfolding orList_def by simp
next
  case (snoc l ls)

  from snoc.prems have ol: "\<not> orList ls" and nl: "\<not> l" unfolding orList_def by auto
  have "ls = replicate (length ls) False" by (rule snoc.hyps [OF ol])
  thus ?case
    by (rule ssubst) (simp add: nl replicate_app_Cons_same [where xs = "[]", simplified])
qed

lemma andList_Cons:
  assumes al: "andList $ map P (y # ys)"
  shows   "P y"
  using al unfolding andList_def
  by simp (induct rule: rev_induct, simp+)

lemma andList_mapE:
  assumes al: "andList $ map P xs"
  and     xv: "x \<in> set xs"
  shows   "P x"
  using al xv
proof (induct xs arbitrary: x rule: rev_induct)
  case Nil thus ?case by simp
next
  case (snoc y ys)

  show ?case
  proof (cases "x = y")
    case True
    with snoc.prems show ?thesis by (simp add: andList_def)
  next
    case False
    with snoc.prems show ?thesis
      by (auto simp: andList_def intro!: snoc.hyps)
  qed
qed

lemma andList_to_aligned:
  assumes al: "andList $ map (\<lambda>x. x && mask pageBits = 0) xs"
  and     xv: "x \<in> set xs"
  shows   "is_aligned x pageBits"
proof (subst is_aligned_mask)
  from al show "x && mask pageBits = 0" by (rule andList_mapE) fact
qed

(* minimum/maximum *)

lemma maximum_ge: "x \<in> set b \<Longrightarrow> x \<le> maximum b"
  unfolding maximum_def by (auto intro: Max_ge)

lemma less_minimum_not_in:
  "\<lbrakk> ls \<noteq> []; x < minimum ls \<rbrakk> \<Longrightarrow> x \<notin> set ls"
  unfolding minimum_def by auto

lemma minimum_le_member:
  "\<lbrakk> x \<in> set ls; ls \<noteq> []\<rbrakk> \<Longrightarrow> minimum ls \<le> x"
  unfolding minimum_def
  apply (rule Min_le)
    apply simp
   apply simp
  done

lemma minimum_map_distrib:
  fixes f :: "('a :: linorder) \<Rightarrow> 'a" and ls :: "'a list"
  assumes minf: "\<And>x y. \<lbrakk>x \<in> set ls; y \<in> set ls\<rbrakk> \<Longrightarrow> min (f x) (f y) = f (min x y)"
  and      lsn: "ls \<noteq> []"
  shows "minimum (map f ls) = f (minimum ls)"
  unfolding minimum_def
  apply simp
  apply (rule Min_image_distrib)
    apply (erule (1) minf)
   apply simp
  apply (simp add: lsn)
  done

lemma minimum_enum_upto:
  fixes x :: "'a::len word"
  assumes le: "x \<le> y"
  shows   "minimum [x .e. y] = x"
  unfolding minimum_def using le by (auto intro!: MinI)

lemma break_subsetsD:
  "break f xs = (ys, zs) \<Longrightarrow> set ys \<subseteq> set xs \<and> set zs \<subseteq> set xs"
  apply (induct xs arbitrary: ys zs)
   apply simp
  apply (case_tac "break f xs")
  apply (elim meta_allE, drule(1) meta_mp)
  apply (fastforce simp: split_def split: if_split_asm)
  done

lemma distinct_prop_breakD:
  "\<lbrakk> distinct_prop P xs; break f xs = (ys, zs) \<rbrakk>
    \<Longrightarrow> \<forall>y \<in> set ys. \<forall>z \<in> set zs. P y z"
  apply (induct xs arbitrary: ys zs)
   apply simp
  apply (simp add: split_def split: if_split_asm)
  apply (case_tac "break f xs")
  apply (elim meta_allE, drule(1) meta_mp)
  apply (frule break_subsetsD)
  apply fastforce
  done

lemma stateAssert_wp:
  "\<lbrace>\<lambda>s. P s \<longrightarrow> Q () s\<rbrace> stateAssert P e \<lbrace>Q\<rbrace>"
  by (clarsimp simp: stateAssert_def) wp

lemma empty_fail_stateAssert[intro!, simp]:
  "empty_fail (stateAssert P l)"
  unfolding stateAssert_def by simp

lemma haskell_assert_wp:
  "\<lbrace>\<lambda>s. Q \<longrightarrow> P s\<rbrace> haskell_assert Q xs \<lbrace>\<lambda>_. P\<rbrace>"
  by simp wp

lemma init_append_last:
  "xs \<noteq> [] \<Longrightarrow> init xs @ [last xs] = xs"
  apply (induct xs rule: rev_induct)
   apply simp
  apply (simp add: init_def)
  done

lemma init_Snoc[simp]:
  "init (xs @ [x]) = xs"
  by (induct xs) (auto simp: init_def)

lemma init_upto_enum_upt[simp]:
  "init [0.e.n] = [0..<n]"
  by (induct n) (auto simp: init_def)

lemma no_fail_stateAssert:
  "no_fail P (stateAssert P xs)"
  apply (simp add: stateAssert_def)
  apply (rule no_fail_pre, wp no_fail_bind)
  apply simp
  done

lemma haskell_fail_wp:
  "\<lbrace>\<top>\<rbrace> haskell_fail x \<lbrace>P\<rbrace>"
  by simp

lemma no_fail_haskell_fail [simp, wp]:
  "no_fail \<bottom> (haskell_fail xs)"
  by simp

lemma in_assocs_is_fun:
  "(x \<in> set (assocs f)) = (f (fst x) = snd x)"
  by (cases x) (auto simp add: assocs_def)

lemma fun_is_in_assocs:
  "(f x = y) = ((x,y) \<in> set (assocs f))"
  by (simp add: in_assocs_is_fun)

lemma empty_set_is_null:
  "(set xs = {}) = null xs"
  by (clarsimp simp: null_def)

lemma assert_into_when:
  "(assert P) = (when (\<not> P) (haskell_fail []))"
  by (simp add: assert_def when_def)

lemma const_apply:
  "const x y = x"
  by (simp add: const_def)

lemma const_None_empty:
  "const None = Map.empty"
  by (rule ext, simp add: const_apply)

lemma headM_tailM_Cons:
  "headM (x # xs) = return x"
  "tailM (x # xs) = return xs"
  by (simp add: headM_def tailM_def)+

lemma replicateM_mapM:
  "replicateM n f = mapM (\<lambda>x. f) (replicate n ())"
  by (simp add: replicateM_def mapM_def)

lemma orList_False:
  "(\<not> orList bs) = (set bs \<subseteq> {False})"
  apply (induct bs)
  apply (simp_all add: orList_def foldl_True)
  apply (case_tac a)
  apply (simp_all add: orList_def foldl_True)
  done

lemma Cons_eq_tails:
  "((xs # xxs) = tails ys) = (ys = xs \<and> xxs = tl (tails ys))"
  by (case_tac ys, auto)

lemma findM_on_outcome':
  assumes x: "\<And>x xs. \<lbrace>\<lambda>s. Q None s \<and> x \<in> fn s \<and> set xs \<subseteq> fn s\<rbrace> f x
                     \<lbrace>\<lambda>rv s. (rv \<longrightarrow> Q (Some x) s) \<and> (\<not> rv \<longrightarrow> Q None s \<and> set xs \<subseteq> fn s)\<rbrace>"
  shows      "\<lbrace>\<lambda>s. Q None s \<and> set xs \<subseteq> fn s\<rbrace> findM f xs \<lbrace>Q\<rbrace>"
  apply (induct xs)
   apply (simp, wp)
  apply (simp, wp)
   apply (rule x)
  apply simp
  done

lemma findM_on_outcome:
  assumes x: "\<And>x ys. x \<in> set xs \<Longrightarrow> \<lbrace>Q None and I\<rbrace> f x \<lbrace>\<lambda>rv s. (rv \<longrightarrow> Q (Some x) s) \<and> (\<not> rv \<longrightarrow> Q None s \<and> I s)\<rbrace>"
  shows      "\<lbrace>Q None and I\<rbrace> findM f xs \<lbrace>Q\<rbrace>"
  apply (rule hoare_vcg_precond_imp)
   apply (rule findM_on_outcome' [where fn="\<lambda>s. if I s then set xs else {}"])
   apply (case_tac "x \<notin> set xs")
    apply simp
   apply (simp cong: rev_conj_cong)
   apply (case_tac "\<not> set xsa \<subseteq> set xs")
    apply simp
   apply simp
   apply (rule hoare_vcg_precond_imp)
    apply (rule hoare_post_imp [OF _ x])
     apply clarsimp
    apply assumption
   apply simp
  apply simp
  done

lemma in_set_tailsD: "xs \<in> set (tails ys) \<Longrightarrow> set xs \<subseteq> set ys"
  apply (induct ys)
   apply simp
  apply simp
  apply (erule disjE)
   apply simp
  apply simp
  apply blast
  done

lemma notin_set_tails_set:
  "x \<notin> set xs \<Longrightarrow> \<forall>xs' \<in> set (tails xs). \<forall>x' \<in> set xs'. x \<noteq> x'"
  by (fastforce dest!: in_set_tailsD)

lemma set_tails_set: "(set (tails v) \<subseteq> {x. set x \<subseteq> S}) = (set v \<subseteq> S)"
  apply (induct v, simp_all)
  done

lemma filter_assocs_Cons:
  fixes v :: "('a :: len) word" shows
  "\<lbrakk> f (v, g v); \<forall>x < v. \<not> f (x, g x) \<rbrakk> \<Longrightarrow>
     filter f (assocs g) = (v, g v) # tl (filter f (assocs g))"
  apply (simp add: assocs_def)
  apply (cut_tac v=v in enum_word_div)
  apply clarsimp
  apply (subst map_cong [OF _ refl], assumption)+
  apply (simp(no_asm))
  apply simp
  done

lemmas stateAssert_def = stateAssert_def[unfolded state_assert_def]

lemma snd_stateAssert_after:
  "\<not> snd ((do _ \<leftarrow> f; stateAssert R vs od) s) \<Longrightarrow>
  \<not>snd (f s) \<and> (\<forall>(rv, s') \<in> fst (f s). R s')"
  apply (clarsimp simp: bind_def stateAssert_def get_def assert_def
      return_def fail_def split_def split: if_split_asm)
  done

lemma oblivious_stateAssert [simp]:
  "oblivious f (stateAssert g xs) = (\<forall>s. g (f s) = g s)"
  apply (simp add: oblivious_def stateAssert_def exec_get
                   assert_def return_def fail_def split: if_split)
  apply auto
  done

lemma stateAssert_def2:
  "stateAssert f xs = do v \<leftarrow> gets f; if v then return () else fail od"
  by (simp add: stateAssert_def gets_def assert_def)

lemma findM_is_mapME:
  "(findM f xs >>= g)
   = liftM (\<lambda>_. ())
      (doE ys \<leftarrow> mapME_x (\<lambda>x. do v \<leftarrow> f x;
                             if v then do g (Some x); throwError () od
                             else returnOk () od) xs;
              liftE (g None) odE)"
  apply (induct xs)
   apply (simp add: mapME_x_def sequenceE_x_def liftM_def returnOk_bind)
   apply (simp add: liftE_def)
  apply (simp add: mapME_x_Cons bindE_assoc liftE_bindE[symmetric]
                   liftM_def cong: if_cong)
  apply (simp add: liftE_bindE bind_assoc)
  apply (rule bind_cong[OF refl])
  apply (simp add: bindE_assoc split: if_split)
  apply (simp add: liftE_bindE bind_assoc throwError_bind)
  done

(* FIXME word_eqI: move up *)
add_try_method word_eqI_solve

end