(*  Title:      CCL/CCL.thy
    Author:     Martin Coen
    Copyright   1993  University of Cambridge
*)

section {* Classical Computational Logic for Untyped Lambda Calculus
  with reduction to weak head-normal form *}

theory CCL
imports Gfp
begin

text {*
  Based on FOL extended with set collection, a primitive higher-order
  logic.  HOL is too strong - descriptions prevent a type of programs
  being defined which contains only executable terms.
*}

class prog = "term"
default_sort prog

instance "fun" :: (prog, prog) prog ..

typedecl i
instance i :: prog ..

consts
  (*** Evaluation Judgement ***)
  Eval      ::       "[i,i]\<Rightarrow>prop"          (infixl "--->" 20)

  (*** Bisimulations for pre-order and equality ***)
  po          ::       "['a,'a]\<Rightarrow>o"           (infixl "[=" 50)

  (*** Term Formers ***)
  true        ::       "i"
  false       ::       "i"
  pair        ::       "[i,i]\<Rightarrow>i"             ("(1<_,/_>)")
  lambda      ::       "(i\<Rightarrow>i)\<Rightarrow>i"            (binder "lam " 55)
  "case"      ::       "[i,i,i,[i,i]\<Rightarrow>i,(i\<Rightarrow>i)\<Rightarrow>i]\<Rightarrow>i"
  "apply"     ::       "[i,i]\<Rightarrow>i"             (infixl "`" 56)
  bot         ::       "i"

  (******* EVALUATION SEMANTICS *******)

  (**  This is the evaluation semantics from which the axioms below were derived.  **)
  (**  It is included here just as an evaluator for FUN and has no influence on    **)
  (**  inference in the theory CCL.                                                **)

axiomatization where
  trueV:       "true ---> true" and
  falseV:      "false ---> false" and
  pairV:       "<a,b> ---> <a,b>" and
  lamV:        "\<And>b. lam x. b(x) ---> lam x. b(x)" and

  caseVtrue:   "\<lbrakk>t ---> true; d ---> c\<rbrakk> \<Longrightarrow> case(t,d,e,f,g) ---> c" and
  caseVfalse:  "\<lbrakk>t ---> false; e ---> c\<rbrakk> \<Longrightarrow> case(t,d,e,f,g) ---> c" and
  caseVpair:   "\<lbrakk>t ---> <a,b>; f(a,b) ---> c\<rbrakk> \<Longrightarrow> case(t,d,e,f,g) ---> c" and
  caseVlam:    "\<And>b. \<lbrakk>t ---> lam x. b(x); g(b) ---> c\<rbrakk> \<Longrightarrow> case(t,d,e,f,g) ---> c"

  (*** Properties of evaluation: note that "t ---> c" impies that c is canonical ***)

axiomatization where
  canonical:  "\<lbrakk>t ---> c; c==true \<Longrightarrow> u--->v;
                          c==false \<Longrightarrow> u--->v;
                    \<And>a b. c==<a,b> \<Longrightarrow> u--->v;
                      \<And>f. c==lam x. f(x) \<Longrightarrow> u--->v\<rbrakk> \<Longrightarrow>
             u--->v"

  (* Should be derivable - but probably a bitch! *)
axiomatization where
  substitute: "\<lbrakk>a==a'; t(a)--->c(a)\<rbrakk> \<Longrightarrow> t(a')--->c(a')"

  (************** LOGIC ***************)

  (*** Definitions used in the following rules ***)

axiomatization where
  bot_def:         "bot == (lam x. x`x)`(lam x. x`x)" and
  apply_def:     "f ` t == case(f, bot, bot, \<lambda>x y. bot, \<lambda>u. u(t))"

definition "fix" :: "(i\<Rightarrow>i)\<Rightarrow>i"
  where "fix(f) == (lam x. f(x`x))`(lam x. f(x`x))"

  (*  The pre-order ([=) is defined as a simulation, and behavioural equivalence (=) *)
  (*  as a bisimulation.  They can both be expressed as (bi)simulations up to        *)
  (*  behavioural equivalence (ie the relations PO and EQ defined below).            *)

definition SIM :: "[i,i,i set]\<Rightarrow>o"
  where
  "SIM(t,t',R) ==  (t=true \<and> t'=true) | (t=false \<and> t'=false) |
                  (\<exists>a a' b b'. t=<a,b> \<and> t'=<a',b'> \<and> <a,a'> : R \<and> <b,b'> : R) |
                  (\<exists>f f'. t=lam x. f(x) \<and> t'=lam x. f'(x) \<and> (ALL x.<f(x),f'(x)> : R))"

definition POgen :: "i set \<Rightarrow> i set"
  where "POgen(R) == {p. \<exists>t t'. p=<t,t'> \<and> (t = bot | SIM(t,t',R))}"

definition EQgen :: "i set \<Rightarrow> i set"
  where "EQgen(R) == {p. \<exists>t t'. p=<t,t'> \<and> (t = bot \<and> t' = bot | SIM(t,t',R))}"

definition PO :: "i set"
  where "PO == gfp(POgen)"

definition EQ :: "i set"
  where "EQ == gfp(EQgen)"

  (*** Rules ***)

  (** Partial Order **)

axiomatization where
  po_refl:        "a [= a" and
  po_trans:       "\<lbrakk>a [= b;  b [= c\<rbrakk> \<Longrightarrow> a [= c" and
  po_cong:        "a [= b \<Longrightarrow> f(a) [= f(b)" and

  (* Extend definition of [= to program fragments of higher type *)
  po_abstractn:   "(\<And>x. f(x) [= g(x)) \<Longrightarrow> (\<lambda>x. f(x)) [= (\<lambda>x. g(x))"

  (** Equality - equivalence axioms inherited from FOL.thy   **)
  (**          - congruence of "=" is axiomatised implicitly **)

axiomatization where
  eq_iff:         "t = t' \<longleftrightarrow> t [= t' \<and> t' [= t"

  (** Properties of canonical values given by greatest fixed point definitions **)

axiomatization where
  PO_iff:         "t [= t' \<longleftrightarrow> <t,t'> : PO" and
  EQ_iff:         "t =  t' \<longleftrightarrow> <t,t'> : EQ"

  (** Behaviour of non-canonical terms (ie case) given by the following beta-rules **)

axiomatization where
  caseBtrue:            "case(true,d,e,f,g) = d" and
  caseBfalse:          "case(false,d,e,f,g) = e" and
  caseBpair:           "case(<a,b>,d,e,f,g) = f(a,b)" and
  caseBlam:       "\<And>b. case(lam x. b(x),d,e,f,g) = g(b)" and
  caseBbot:              "case(bot,d,e,f,g) = bot"           (* strictness *)

  (** The theory is non-trivial **)
axiomatization where
  distinctness:   "\<not> lam x. b(x) = bot"

  (*** Definitions of Termination and Divergence ***)

definition Dvg :: "i \<Rightarrow> o"
  where "Dvg(t) == t = bot"

definition Trm :: "i \<Rightarrow> o"
  where "Trm(t) == \<not> Dvg(t)"

text {*
Would be interesting to build a similar theory for a typed programming language:
    ie.     true :: bool,      fix :: ('a\<Rightarrow>'a)\<Rightarrow>'a  etc......

This is starting to look like LCF.
What are the advantages of this approach?
        - less axiomatic
        - wfd induction / coinduction and fixed point induction available
*}

lemmas ccl_data_defs = apply_def fix_def

declare po_refl [simp]

subsection {* Congruence Rules *}

(*similar to AP_THM in Gordon's HOL*)
lemma fun_cong: "(f::'a\<Rightarrow>'b) = g \<Longrightarrow> f(x)=g(x)"
  by simp

(*similar to AP_TERM in Gordon's HOL and FOL's subst_context*)
lemma arg_cong: "x=y \<Longrightarrow> f(x)=f(y)"
  by simp

lemma abstractn: "(\<And>x. f(x) = g(x)) \<Longrightarrow> f = g"
  apply (simp add: eq_iff)
  apply (blast intro: po_abstractn)
  done

lemmas caseBs = caseBtrue caseBfalse caseBpair caseBlam caseBbot

subsection {* Termination and Divergence *}

lemma Trm_iff: "Trm(t) \<longleftrightarrow> \<not> t = bot"
  by (simp add: Trm_def Dvg_def)

lemma Dvg_iff: "Dvg(t) \<longleftrightarrow> t = bot"
  by (simp add: Trm_def Dvg_def)

subsection {* Constructors are injective *}

lemma eq_lemma: "\<lbrakk>x=a; y=b; x=y\<rbrakk> \<Longrightarrow> a=b"
  by simp

ML {*
  fun inj_rl_tac ctxt rews i =
    let
      fun mk_inj_lemmas r = [@{thm arg_cong}] RL [r RS (r RS @{thm eq_lemma})]
      val inj_lemmas = maps mk_inj_lemmas rews
    in
      CHANGED (REPEAT (ares_tac [@{thm iffI}, @{thm allI}, @{thm conjI}] i ORELSE
        eresolve_tac inj_lemmas i ORELSE
        asm_simp_tac (ctxt addsimps rews) i))
    end;
*}

method_setup inj_rl = {*
  Attrib.thms >> (fn rews => fn ctxt => SIMPLE_METHOD' (inj_rl_tac ctxt rews))
*}

lemma ccl_injs:
  "<a,b> = <a',b'> \<longleftrightarrow> (a=a' \<and> b=b')"
  "\<And>b b'. (lam x. b(x) = lam x. b'(x)) \<longleftrightarrow> ((ALL z. b(z)=b'(z)))"
  by (inj_rl caseBs)

lemma pair_inject: "<a,b> = <a',b'> \<Longrightarrow> (a = a' \<Longrightarrow> b = b' \<Longrightarrow> R) \<Longrightarrow> R"
  by (simp add: ccl_injs)

subsection {* Constructors are distinct *}

lemma lem: "t=t' \<Longrightarrow> case(t,b,c,d,e) = case(t',b,c,d,e)"
  by simp

ML {*
local
  fun pairs_of f x [] = []
    | pairs_of f x (y::ys) = (f x y) :: (f y x) :: (pairs_of f x ys)

  fun mk_combs ff [] = []
    | mk_combs ff (x::xs) = (pairs_of ff x xs) @ mk_combs ff xs

  (* Doesn't handle binder types correctly *)
  fun saturate thy sy name =
       let fun arg_str 0 a s = s
         | arg_str 1 a s = "(" ^ a ^ "a" ^ s ^ ")"
         | arg_str n a s = arg_str (n-1) a ("," ^ a ^ (chr((ord "a")+n-1)) ^ s)
           val T = Sign.the_const_type thy (Sign.intern_const thy sy);
           val arity = length (binder_types T)
       in sy ^ (arg_str arity name "") end

  fun mk_thm_str thy a b = "\<not> " ^ (saturate thy a "a") ^ " = " ^ (saturate thy b "b")

  val lemma = @{thm lem};
  val eq_lemma = @{thm eq_lemma};
  val distinctness = @{thm distinctness};
  fun mk_lemma (ra,rb) =
    [lemma] RL [ra RS (rb RS eq_lemma)] RL
    [distinctness RS @{thm notE}, @{thm sym} RS (distinctness RS @{thm notE})]
in
  fun mk_lemmas rls = maps mk_lemma (mk_combs pair rls)
  fun mk_dstnct_rls thy xs = mk_combs (mk_thm_str thy) xs
end
*}

ML {*
val caseB_lemmas = mk_lemmas @{thms caseBs}

val ccl_dstncts =
  let
    fun mk_raw_dstnct_thm rls s =
      Goal.prove_global @{theory} [] [] (Syntax.read_prop_global @{theory} s)
        (fn _ => rtac @{thm notI} 1 THEN eresolve_tac rls 1)
  in map (mk_raw_dstnct_thm caseB_lemmas)
    (mk_dstnct_rls @{theory} ["bot","true","false","pair","lambda"]) end

fun mk_dstnct_thms ctxt defs inj_rls xs =
  let
    val thy = Proof_Context.theory_of ctxt;
    fun mk_dstnct_thm rls s =
      Goal.prove_global thy [] [] (Syntax.read_prop ctxt s)
        (fn _ =>
          rewrite_goals_tac ctxt defs THEN
          simp_tac (ctxt addsimps (rls @ inj_rls)) 1)
  in map (mk_dstnct_thm ccl_dstncts) (mk_dstnct_rls thy xs) end

fun mkall_dstnct_thms ctxt defs i_rls xss = maps (mk_dstnct_thms ctxt defs i_rls) xss

(*** Rewriting and Proving ***)

fun XH_to_I rl = rl RS @{thm iffD2}
fun XH_to_D rl = rl RS @{thm iffD1}
val XH_to_E = make_elim o XH_to_D
val XH_to_Is = map XH_to_I
val XH_to_Ds = map XH_to_D
val XH_to_Es = map XH_to_E;

ML_Thms.bind_thms ("ccl_rews", @{thms caseBs} @ @{thms ccl_injs} @ ccl_dstncts);
ML_Thms.bind_thms ("ccl_dstnctsEs", ccl_dstncts RL [@{thm notE}]);
ML_Thms.bind_thms ("ccl_injDs", XH_to_Ds @{thms ccl_injs});
*}

lemmas [simp] = ccl_rews
  and [elim!] = pair_inject ccl_dstnctsEs
  and [dest!] = ccl_injDs

subsection {* Facts from gfp Definition of @{text "[="} and @{text "="} *}

lemma XHlemma1: "\<lbrakk>A=B; a:B \<longleftrightarrow> P\<rbrakk> \<Longrightarrow> a:A \<longleftrightarrow> P"
  by simp

lemma XHlemma2: "(P(t,t') \<longleftrightarrow> Q) \<Longrightarrow> (<t,t'> : {p. \<exists>t t'. p=<t,t'> \<and>  P(t,t')} \<longleftrightarrow> Q)"
  by blast

subsection {* Pre-Order *}

lemma POgen_mono: "mono(\<lambda>X. POgen(X))"
  apply (unfold POgen_def SIM_def)
  apply (rule monoI)
  apply blast
  done

lemma POgenXH:
  "<t,t'> : POgen(R) \<longleftrightarrow> t= bot | (t=true \<and> t'=true)  | (t=false \<and> t'=false) |
           (EX a a' b b'. t=<a,b> \<and> t'=<a',b'>  \<and> <a,a'> : R \<and> <b,b'> : R) |
           (EX f f'. t=lam x. f(x) \<and> t'=lam x. f'(x) \<and> (ALL x. <f(x),f'(x)> : R))"
  apply (unfold POgen_def SIM_def)
  apply (rule iff_refl [THEN XHlemma2])
  done

lemma poXH:
  "t [= t' \<longleftrightarrow> t=bot | (t=true \<and> t'=true) | (t=false \<and> t'=false) |
                 (EX a a' b b'. t=<a,b> \<and> t'=<a',b'>  \<and> a [= a' \<and> b [= b') |
                 (EX f f'. t=lam x. f(x) \<and> t'=lam x. f'(x) \<and> (ALL x. f(x) [= f'(x)))"
  apply (simp add: PO_iff del: ex_simps)
  apply (rule POgen_mono
    [THEN PO_def [THEN def_gfp_Tarski], THEN XHlemma1, unfolded POgen_def SIM_def])
  apply (rule iff_refl [THEN XHlemma2])
  done

lemma po_bot: "bot [= b"
  apply (rule poXH [THEN iffD2])
  apply simp
  done

lemma bot_poleast: "a [= bot \<Longrightarrow> a=bot"
  apply (drule poXH [THEN iffD1])
  apply simp
  done

lemma po_pair: "<a,b> [= <a',b'> \<longleftrightarrow>  a [= a' \<and> b [= b'"
  apply (rule poXH [THEN iff_trans])
  apply simp
  done

lemma po_lam: "lam x. f(x) [= lam x. f'(x) \<longleftrightarrow> (ALL x. f(x) [= f'(x))"
  apply (rule poXH [THEN iff_trans])
  apply fastforce
  done

lemmas ccl_porews = po_bot po_pair po_lam

lemma case_pocong:
  assumes 1: "t [= t'"
    and 2: "a [= a'"
    and 3: "b [= b'"
    and 4: "\<And>x y. c(x,y) [= c'(x,y)"
    and 5: "\<And>u. d(u) [= d'(u)"
  shows "case(t,a,b,c,d) [= case(t',a',b',c',d')"
  apply (rule 1 [THEN po_cong, THEN po_trans])
  apply (rule 2 [THEN po_cong, THEN po_trans])
  apply (rule 3 [THEN po_cong, THEN po_trans])
  apply (rule 4 [THEN po_abstractn, THEN po_abstractn, THEN po_cong, THEN po_trans])
  apply (rule_tac f1 = "\<lambda>d. case (t',a',b',c',d)" in
    5 [THEN po_abstractn, THEN po_cong, THEN po_trans])
  apply (rule po_refl)
  done

lemma apply_pocong: "\<lbrakk>f [= f'; a [= a'\<rbrakk> \<Longrightarrow> f ` a [= f' ` a'"
  unfolding ccl_data_defs
  apply (rule case_pocong, (rule po_refl | assumption)+)
  apply (erule po_cong)
  done

lemma npo_lam_bot: "\<not> lam x. b(x) [= bot"
  apply (rule notI)
  apply (drule bot_poleast)
  apply (erule distinctness [THEN notE])
  done

lemma po_lemma: "\<lbrakk>x=a; y=b; x[=y\<rbrakk> \<Longrightarrow> a[=b"
  by simp

lemma npo_pair_lam: "\<not> <a,b> [= lam x. f(x)"
  apply (rule notI)
  apply (rule npo_lam_bot [THEN notE])
  apply (erule case_pocong [THEN caseBlam [THEN caseBpair [THEN po_lemma]]])
  apply (rule po_refl npo_lam_bot)+
  done

lemma npo_lam_pair: "\<not> lam x. f(x) [= <a,b>"
  apply (rule notI)
  apply (rule npo_lam_bot [THEN notE])
  apply (erule case_pocong [THEN caseBpair [THEN caseBlam [THEN po_lemma]]])
  apply (rule po_refl npo_lam_bot)+
  done

lemma npo_rls1:
  "\<not> true [= false"
  "\<not> false [= true"
  "\<not> true [= <a,b>"
  "\<not> <a,b> [= true"
  "\<not> true [= lam x. f(x)"
  "\<not> lam x. f(x) [= true"
  "\<not> false [= <a,b>"
  "\<not> <a,b> [= false"
  "\<not> false [= lam x. f(x)"
  "\<not> lam x. f(x) [= false"
  by (rule notI, drule case_pocong, erule_tac [5] rev_mp, simp_all,
    (rule po_refl npo_lam_bot)+)+

lemmas npo_rls = npo_pair_lam npo_lam_pair npo_rls1

subsection {* Coinduction for @{text "[="} *}

lemma po_coinduct: "\<lbrakk><t,u> : R; R <= POgen(R)\<rbrakk> \<Longrightarrow> t [= u"
  apply (rule PO_def [THEN def_coinduct, THEN PO_iff [THEN iffD2]])
   apply assumption+
  done

subsection {* Equality *}

lemma EQgen_mono: "mono(\<lambda>X. EQgen(X))"
  apply (unfold EQgen_def SIM_def)
  apply (rule monoI)
  apply blast
  done

lemma EQgenXH:
  "<t,t'> : EQgen(R) \<longleftrightarrow> (t=bot \<and> t'=bot)  | (t=true \<and> t'=true)  |
                                             (t=false \<and> t'=false) |
                 (EX a a' b b'. t=<a,b> \<and> t'=<a',b'>  \<and> <a,a'> : R \<and> <b,b'> : R) |
                 (EX f f'. t=lam x. f(x) \<and> t'=lam x. f'(x) \<and> (ALL x.<f(x),f'(x)> : R))"
  apply (unfold EQgen_def SIM_def)
  apply (rule iff_refl [THEN XHlemma2])
  done

lemma eqXH:
  "t=t' \<longleftrightarrow> (t=bot \<and> t'=bot)  | (t=true \<and> t'=true)  | (t=false \<and> t'=false) |
                     (EX a a' b b'. t=<a,b> \<and> t'=<a',b'>  \<and> a=a' \<and> b=b') |
                     (EX f f'. t=lam x. f(x) \<and> t'=lam x. f'(x) \<and> (ALL x. f(x)=f'(x)))"
  apply (subgoal_tac "<t,t'> : EQ \<longleftrightarrow>
    (t=bot \<and> t'=bot) | (t=true \<and> t'=true) | (t=false \<and> t'=false) |
    (EX a a' b b'. t=<a,b> \<and> t'=<a',b'> \<and> <a,a'> : EQ \<and> <b,b'> : EQ) |
    (EX f f'. t=lam x. f (x) \<and> t'=lam x. f' (x) \<and> (ALL x. <f (x) ,f' (x) > : EQ))")
  apply (erule rev_mp)
  apply (simp add: EQ_iff [THEN iff_sym])
  apply (rule EQgen_mono [THEN EQ_def [THEN def_gfp_Tarski], THEN XHlemma1,
    unfolded EQgen_def SIM_def])
  apply (rule iff_refl [THEN XHlemma2])
  done

lemma eq_coinduct: "\<lbrakk><t,u> : R; R <= EQgen(R)\<rbrakk> \<Longrightarrow> t = u"
  apply (rule EQ_def [THEN def_coinduct, THEN EQ_iff [THEN iffD2]])
   apply assumption+
  done

lemma eq_coinduct3:
  "\<lbrakk><t,u> : R;  R <= EQgen(lfp(\<lambda>x. EQgen(x) Un R Un EQ))\<rbrakk> \<Longrightarrow> t = u"
  apply (rule EQ_def [THEN def_coinduct3, THEN EQ_iff [THEN iffD2]])
  apply (rule EQgen_mono | assumption)+
  done

method_setup eq_coinduct3 = {*
  Scan.lift Args.name_inner_syntax >> (fn s => fn ctxt =>
    SIMPLE_METHOD' (res_inst_tac ctxt [(("R", 0), s)] @{thm eq_coinduct3}))
*}

subsection {* Untyped Case Analysis and Other Facts *}

lemma cond_eta: "(EX f. t=lam x. f(x)) \<Longrightarrow> t = lam x.(t ` x)"
  by (auto simp: apply_def)

lemma exhaustion: "(t=bot) | (t=true) | (t=false) | (EX a b. t=<a,b>) | (EX f. t=lam x. f(x))"
  apply (cut_tac refl [THEN eqXH [THEN iffD1]])
  apply blast
  done

lemma term_case:
  "\<lbrakk>P(bot); P(true); P(false); \<And>x y. P(<x,y>); \<And>b. P(lam x. b(x))\<rbrakk> \<Longrightarrow> P(t)"
  using exhaustion [of t] by blast

end


section{* Verification Component Based on KAD *}

theory VC_KAD

imports "$AFP/KAD//Modal_Kleene_Algebra_Models" "../P2S2R"

begin

no_notation Archimedean_Field.ceiling ("\<lceil>_\<rceil>")
no_notation Archimedean_Field.floor ("\<lfloor>_\<rfloor>")

notation p2r ("\<lceil>_\<rceil>")
notation r2p ("\<lfloor>_\<rfloor>")

context antidomain_kleene_algebra
begin

subsection {* Additional Facts for Antidomain Kleene Algebras *}

lemma fbox_shunt: "d p \<cdot> d q \<le> |x] t \<longleftrightarrow> d p \<le> ad q + |x] t"
  by (metis a_6 a_antitone' a_loc add_commute addual.ars_r_def am_d_def da_shunt2 fbox_def)

subsection {* Syntax for While Programs *}

definition cond :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("if _ then _ else _ fi" [64,64,64] 63) where
  "if p then x else y fi = d p \<cdot> x + ad p \<cdot> y"

definition while :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ do _ od" [64,64] 63) where
  "while p do x od = (d p \<cdot> x)\<^sup>\<star> \<cdot> ad p"

definition whilei :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ inv _ do _ od" [64,64,64] 63) where
  "while p inv i do x od = while p do x od"

subsection {* Basic w(l)p Calculus *}

text {* In the setting of modal Kleene algebras, the wlp operator is the forward modal box operator
of antidomain Kleene algebra. *}

lemma fbox_export1: "ad p + |x] q = |d p \<cdot> x] q"
  using a_d_add_closure addual.ars_r_def fbox_def fbox_mult by auto

lemma fbox_export2: "|x] p \<le> |x \<cdot> ad q] (d p \<cdot> ad q)"
proof -
  {fix t
   have "d t \<cdot> x \<le> x \<cdot> d p \<Longrightarrow> d t \<cdot> x \<cdot> ad q \<le> x \<cdot> ad q \<cdot> d p \<cdot> ad q"
     by (metis (full_types) a_comm_var a_mult_idem ads_d_def am2 ds.ddual.mult_assoc phl_export2)
   hence "d t \<le> |x] p \<Longrightarrow> d t \<le> |x \<cdot> ad q] (d p \<cdot> ad q)"
     by (metis a_closure' addual.ars_r_def ans_d_def dka.dsg3 ds.ddual.mult_assoc fbox_def fbox_demodalisation3)
  }
  thus ?thesis
    by (metis a_closure' addual.ars_r_def ans_d_def fbox_def order_refl)
qed

lemma fbox_export3: "|x \<cdot> ad p] q = |x] (d p + d q)"
  using local.a_de_morgan_var_3 local.ds.ddual.mult_assoc local.fbox_def by auto

lemma fbox_seq [simp]: "|x \<cdot> y] q = |x] |y] q"
  by (simp add: fbox_mult)

lemma fbox_seq_var: "p' \<le> |y] q \<Longrightarrow> p \<le> |x] p' \<Longrightarrow> p \<le> |x \<cdot> y] q"
proof -
  assume h1: "p \<le> |x] p'" and h2: "p' \<le> |y] q"
  hence "|x] p' \<le> |x] |y] q"
    by (simp add: dka.dom_iso fbox_iso)
  thus ?thesis
    by (metis h1 dual_order.trans fbox_seq)
qed

lemma fbox_cond_var [simp]: "|if p then x else y fi] q = (ad p + |x] q) \<cdot> (d p + |y] q)"
  using cond_def a_closure' ads_d_def ans_d_def fbox_add2 fbox_export1 by auto

lemma fbox_cond_aux1 [simp]: "d p \<cdot> |if p then x else y fi] q = d p \<cdot> |x] q"
proof -
  have "d p \<cdot> |if p then x else y fi] q = d p \<cdot> |x] q \<cdot> (d p + d ( |y] q))"
    using a_d_add_closure addual.ars_r_def ds.ddual.mult_assoc fbox_def fbox_cond_var by auto
  thus ?thesis
    by (metis addual.ars_r_def am2 dka.dns5 ds.ddual.mult_assoc fbox_def)
qed

lemma fbox_cond_aux2 [simp]: "ad p \<cdot> |if p then x else y fi] q = ad p \<cdot> |y] q"
  by (metis cond_def a_closure' add_commute addual.ars_r_def ans_d_def fbox_cond_aux1)

lemma fbox_cond [simp]: "|if p then x else y fi] q = (d p \<cdot> |x] q) + (ad p \<cdot> |y] q)"
proof -
  have "|if p then x else y fi] q = (d p + ad p) \<cdot> |if p then x else y fi] q"
    by (simp add: addual.ars_r_def)
  thus ?thesis
    by (metis  distrib_right' fbox_cond_aux1 fbox_cond_aux2)
qed

lemma fbox_cond_var2 [simp]: "|if p then x else y fi] q = if p then |x] q else |y] q fi"
  using cond_def fbox_cond by auto

lemma fbox_while_unfold: "|while t do x od] p = (d t + d p) \<cdot> (ad t + |x] |while t do x od] p)"
  by (metis fbox_export1 fbox_export3 local.dka.dom_add_closed local.fbox_star_unfold_var while_def)

lemma fbox_while_var1: "d t \<cdot> |while t do x od] p = d t \<cdot> |x] |while t do x od] p"
  by (metis fbox_while_unfold local.a_mult_add local.ads_d_def local.dka.dns5 local.ds.ddual.mult_assoc local.join.sup_commute)

lemma fbox_while_var2: "ad t \<cdot> |while t do x od] p \<le> d p"
proof -
  have "ad t \<cdot> |while t do x od] p = ad t \<cdot> (d t + d p) \<cdot> (ad t + |x] |while t do x od] p)"
    by (metis fbox_while_unfold local.ds.ddual.mult_assoc)
  also have "... =  ad t \<cdot> d p \<cdot> (ad t + |x] |while t do x od] p)"
    by (metis local.a_de_morgan_var_3 local.addual.ars_r_def local.dka.dom_add_closed local.s4)
  also have "... \<le> d p \<cdot> (ad t + |x] |while t do x od] p)"
    using local.a_subid_aux1' local.mult_isor by blast
  finally show ?thesis
    by (metis local.a_de_morgan_var_3 local.a_mult_idem local.addual.ars_r_def local.ans4 local.dka.dsr5 local.dpdz.domain_1'' local.dual_order.trans local.fbox_def)
qed

lemma fbox_while: "d p \<cdot> d t \<le> |x] p \<Longrightarrow> d p \<le> |while t do x od] (d p \<cdot> ad t)"
proof -
  assume "d p \<cdot> d t \<le> |x] p"
  hence "d p \<le> |d t \<cdot> x] p"
    by (simp add: fbox_export1 fbox_shunt)
  hence "d p \<le> |(d t \<cdot> x)\<^sup>\<star>] p"
    by (simp add: fbox_star_induct_var)
  thus ?thesis
    using order_trans while_def fbox_export2 by presburger
qed

lemma fbox_while_var: "d p = |d t \<cdot> x] p \<Longrightarrow> d p \<le> |while t do x od] (d p \<cdot> ad t)"
  by (metis eq_refl fbox_export1 fbox_shunt fbox_while)

lemma fbox_whilei: "d p \<le> d i \<Longrightarrow> d i \<cdot> ad t \<le> d q \<Longrightarrow> d i \<cdot> d t \<le> |x] i \<Longrightarrow> d p \<le> |while t inv i do x od] q"
proof -
  assume a1: "d p \<le> d i" and a2: "d i \<cdot> ad t \<le> d q" and "d i \<cdot> d t \<le> |x] i"
  hence "d i \<le> |while t inv i do x od] (d i \<cdot> ad t)"
    by (simp add: fbox_while whilei_def)
  also have "... \<le> |while t inv i do x od] q"
    using a2 local.dka.dom_iso local.fbox_iso by fastforce
  finally show ?thesis
    using a1 dual_order.trans by blast
qed

text {* The next rule is used for dealing with while loops after a series of sequential steps. *}

lemma fbox_whilei_break: "d p \<le> |y] i \<Longrightarrow> d i \<cdot> ad t \<le> d q \<Longrightarrow> d i \<cdot> d t \<le> |x] i \<Longrightarrow> d p \<le> |y \<cdot> (while t inv i do x od)] q"
  apply (rule fbox_seq_var, rule fbox_whilei, simp_all, blast)
  using local.fbox_simp by auto

text {* Finally we derive a frame rule. *}

lemma fbox_frame: "d p \<cdot> x \<le> x \<cdot> d p \<Longrightarrow> d q \<le> |x] t \<Longrightarrow> d p \<cdot> d q \<le> |x] (d p \<cdot> d t)"
  using local.dual.mult_isol_var local.fbox_add1 local.fbox_demodalisation3 local.fbox_simp by auto

lemma fbox_frame_var: "d p \<le> |x] p \<Longrightarrow> d q \<le> |x] t \<Longrightarrow> d p \<cdot> d q \<le> |x] (d p \<cdot> d t)"
  using fbox_frame local.fbox_demodalisation3 local.fbox_simp by auto

end

subsection {* Store and Assignment *}

type_synonym 'a store = "string  \<Rightarrow> 'a"

notation rel_antidomain_kleene_algebra.fbox ("wp")
and rel_antidomain_kleene_algebra.fdia ("relfdia")

definition gets :: "string \<Rightarrow> ('a store \<Rightarrow> 'a) \<Rightarrow> 'a store rel" ("_ ::= _" [70, 65] 61) where
   "v ::= e = {(s,s (v := e s)) |s. True}"

lemma assign_prop: "\<lceil>\<lambda>s. P (s (v := e s))\<rceil> ; (v ::= e) = (v ::= e) ; \<lceil>P\<rceil>"
  by (auto simp add: p2r_def gets_def)

lemma wp_assign [simp]: "wp (v ::= e) \<lceil>Q\<rceil> = \<lceil>\<lambda>s. Q (s (v := e s))\<rceil>"
  by (auto simp: rel_antidomain_kleene_algebra.fbox_def gets_def rel_ad_def p2r_def)

lemma wp_assign_var [simp]: "\<lfloor>wp (v ::= e) \<lceil>Q\<rceil>\<rfloor> = (\<lambda>s. Q (s (v := e s)))"
  by (simp, auto simp: r2p_def p2r_def)

lemma wp_assign_det: "wp (v ::= e) \<lceil>Q\<rceil> = relfdia (v ::= e) \<lceil>Q\<rceil>"
  by (auto simp add: rel_antidomain_kleene_algebra.fbox_def rel_antidomain_kleene_algebra.fdia_def gets_def p2r_def rel_ad_def, fast)

subsection {* Simplifications *}

notation rel_antidomain_kleene_algebra.ads_d ("rdom")

abbreviation spec_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a pred \<Rightarrow> bool" ("PRE _ _ POST _" [64,64,64] 63) where
  "PRE P X POST Q \<equiv> rdom \<lceil>P\<rceil> \<subseteq> wp X \<lceil>Q\<rceil>"

abbreviation cond_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("IF _ THEN _ ELSE _ FI" [64,64,64] 63) where
  "IF P THEN X ELSE Y FI \<equiv> rel_antidomain_kleene_algebra.cond \<lceil>P\<rceil> X Y"

abbreviation whilei_sugar :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("WHILE _ INV _ DO _ OD" [64,64,64] 63) where
  "WHILE P INV I DO X OD \<equiv> rel_antidomain_kleene_algebra.whilei \<lceil>P\<rceil> \<lceil>I\<rceil> X"

lemma d_p2r [simp]: "rdom \<lceil>P\<rceil> = \<lceil>P\<rceil>"
  by (simp add: p2r_def rel_antidomain_kleene_algebra.ads_d_def rel_ad_def)

lemma p2r_conj_hom_var_symm [simp]: "\<lceil>P\<rceil> ; \<lceil>Q\<rceil> = \<lceil>P \<sqinter> Q\<rceil>"
  by (simp add: p2r_conj_hom_var)

lemma p2r_neg_hom [simp]: "rel_ad \<lceil>P\<rceil> = \<lceil>- P\<rceil>"
  by (simp add: rel_ad_def p2r_def)

lemma wp_trafo: "\<lfloor>wp X \<lceil>Q\<rceil>\<rfloor> = (\<lambda>s. \<forall>s'. (s,s') \<in> X \<longrightarrow> Q s')"
  by (auto simp: rel_antidomain_kleene_algebra.fbox_def rel_ad_def p2r_def r2p_def)

lemma wp_trafo_var: "\<lfloor>wp X \<lceil>Q\<rceil>\<rfloor> s = (\<forall>s'. (s,s') \<in> X \<longrightarrow> Q s')"
  by (simp add: wp_trafo)

lemma wp_simp: "rdom \<lceil>\<lfloor>wp X Q\<rfloor>\<rceil> = wp X Q"
  by (metis d_p2r rel_antidomain_kleene_algebra.a_subid' rel_antidomain_kleene_algebra.addual.bbox_def rpr)

lemma impl_prop: "\<lceil>P\<rceil> \<subseteq> \<lceil>Q\<rceil> \<longleftrightarrow> (\<forall>s. P s \<longrightarrow>  Q s)"
  by (auto simp: p2r_def)

lemma impl_prop_var: "rdom \<lceil>P\<rceil> \<subseteq> rdom \<lceil>Q\<rceil> \<longleftrightarrow> (\<forall>s. P s \<longrightarrow>  Q s)"
  by (simp add: impl_prop)

lemma wp_whilei: "(\<forall>s. P s \<longrightarrow> I s) \<Longrightarrow> (\<forall>s. (I \<sqinter> -T) s \<longrightarrow> Q s) \<Longrightarrow> (\<forall>s. (I \<sqinter> T) s \<longrightarrow> \<lfloor>wp X \<lceil>I\<rceil>\<rfloor> s)
                  \<Longrightarrow> (\<forall>s. P s \<longrightarrow> \<lfloor>wp (WHILE T INV I DO X OD) \<lceil>Q\<rceil>\<rfloor> s)"
  apply (simp only: impl_prop_var[symmetric] wp_simp)
  by (rule rel_antidomain_kleene_algebra.fbox_whilei, simp_all, simp_all add: p2r_def)

end


(*  Title:      HOL/Wfrec.thy
    Author:     Tobias Nipkow
    Author:     Lawrence C Paulson
    Author:     Konrad Slind
*)

section \<open>Well-Founded Recursion Combinator\<close>

theory Wfrec
  imports Wellfounded
begin

inductive wfrec_rel :: "('a \<times> 'a) set \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool" for R F
  where wfrecI: "(\<And>z. (z, x) \<in> R \<Longrightarrow> wfrec_rel R F z (g z)) \<Longrightarrow> wfrec_rel R F x (F g x)"

definition cut :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b"
  where "cut f R x = (\<lambda>y. if (y, x) \<in> R then f y else undefined)"

definition adm_wf :: "('a \<times> 'a) set \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)) \<Rightarrow> bool"
  where "adm_wf R F \<longleftrightarrow> (\<forall>f g x. (\<forall>z. (z, x) \<in> R \<longrightarrow> f z = g z) \<longrightarrow> F f x = F g x)"

definition wfrec :: "('a \<times> 'a) set \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)) \<Rightarrow> ('a \<Rightarrow> 'b)"
  where "wfrec R F = (\<lambda>x. THE y. wfrec_rel R (\<lambda>f x. F (cut f R x) x) x y)"

lemma cuts_eq: "(cut f R x = cut g R x) \<longleftrightarrow> (\<forall>y. (y, x) \<in> R \<longrightarrow> f y = g y)"
  by (simp add: fun_eq_iff cut_def)

lemma cut_apply: "(x, a) \<in> R \<Longrightarrow> cut f R a x = f x"
  by (simp add: cut_def)

text \<open>
  Inductive characterization of \<open>wfrec\<close> combinator; for details see:
  John Harrison, "Inductive definitions: automation and application".
\<close>

lemma theI_unique: "\<exists>!x. P x \<Longrightarrow> P x \<longleftrightarrow> x = The P"
  by (auto intro: the_equality[symmetric] theI)

lemma wfrec_unique:
  assumes "adm_wf R F" "wf R"
  shows "\<exists>!y. wfrec_rel R F x y"
  using \<open>wf R\<close>
proof induct
  define f where "f y = (THE z. wfrec_rel R F y z)" for y
  case (less x)
  then have "\<And>y z. (y, x) \<in> R \<Longrightarrow> wfrec_rel R F y z \<longleftrightarrow> z = f y"
    unfolding f_def by (rule theI_unique)
  with \<open>adm_wf R F\<close> show ?case
    by (subst wfrec_rel.simps) (auto simp: adm_wf_def)
qed

lemma adm_lemma: "adm_wf R (\<lambda>f x. F (cut f R x) x)"
  by (auto simp: adm_wf_def intro!: arg_cong[where f="\<lambda>x. F x y" for y] cuts_eq[THEN iffD2])

lemma wfrec: "wf R \<Longrightarrow> wfrec R F a = F (cut (wfrec R F) R a) a"
  apply (simp add: wfrec_def)
  apply (rule adm_lemma [THEN wfrec_unique, THEN the1_equality])
   apply assumption
  apply (rule wfrec_rel.wfrecI)
  apply (erule adm_lemma [THEN wfrec_unique, THEN theI'])
  done

text \<open>This form avoids giant explosions in proofs.  NOTE USE OF \<open>\<equiv>\<close>.\<close>
lemma def_wfrec: "f \<equiv> wfrec R F \<Longrightarrow> wf R \<Longrightarrow> f a = F (cut f R a) a"
  by (auto intro: wfrec)

subsubsection \<open>Well-founded recursion via genuine fixpoints\<close>

lemma wfrec_fixpoint:
  assumes wf: "wf R"
    and adm: "adm_wf R F"
  shows "wfrec R F = F (wfrec R F)"
proof (rule ext)
  fix x
  have "wfrec R F x = F (cut (wfrec R F) R x) x"
    using wfrec[of R F] wf by simp
  also
  have "\<And>y. (y, x) \<in> R \<Longrightarrow> cut (wfrec R F) R x y = wfrec R F y"
    by (auto simp add: cut_apply)
  then have "F (cut (wfrec R F) R x) x = F (wfrec R F) x"
    using adm adm_wf_def[of R F] by auto
  finally show "wfrec R F x = F (wfrec R F) x" .
qed

lemma wfrec_def_adm: "f \<equiv> wfrec R F \<Longrightarrow> wf R \<Longrightarrow> adm_wf R F \<Longrightarrow> f = F f"
  using wfrec_fixpoint by simp

subsection \<open>Wellfoundedness of \<open>same_fst\<close>\<close>

definition same_fst :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('b \<times> 'b) set) \<Rightarrow> (('a \<times> 'b) \<times> ('a \<times> 'b)) set"
  where "same_fst P R = {((x', y'), (x, y)) . x' = x \<and> P x \<and> (y',y) \<in> R x}"
   \<comment> \<open>For \<^const>\<open>wfrec\<close> declarations where the first n parameters
       stay unchanged in the recursive call.\<close>

lemma same_fstI [intro!]: "P x \<Longrightarrow> (y', y) \<in> R x \<Longrightarrow> ((x, y'), (x, y)) \<in> same_fst P R"
  by (simp add: same_fst_def)

lemma wf_same_fst:
  assumes "\<And>x. P x \<Longrightarrow> wf (R x)"
  shows "wf (same_fst P R)"
proof -
  have "\<And>a b Q. \<forall>a b. (\<forall>x. P a \<and> (x, b) \<in> R a \<longrightarrow> Q (a, x)) \<longrightarrow> Q (a, b) \<Longrightarrow> Q (a, b)"
  proof -
    fix Q a b
    assume *: "\<forall>a b. (\<forall>x. P a \<and> (x,b) \<in> R a \<longrightarrow> Q (a,x)) \<longrightarrow> Q (a,b)"
    show "Q(a,b)"
    proof (cases "wf (R a)")
      case True
      then show ?thesis
        by (induction b rule: wf_induct_rule) (use * in blast)
    qed (use * assms in blast)
  qed
  then show ?thesis
    by (clarsimp simp add: wf_def same_fst_def)
qed

end


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

Many proofs are borrowed from pair.thy and sum.thy

Do we EVER have rank(a) < rank(<a;b>) ?  Perhaps if the latter rank
is not a limit ordinal?
*)

section\<open>Quine-Inspired Ordered Pairs and Disjoint Sums\<close>

theory QPair imports Sum func begin

text\<open>For non-well-founded data
structures in ZF.  Does not precisely follow Quine's construction.  Thanks
to Thomas Forster for suggesting this approach!

W. V. Quine, On Ordered Pairs and Relations, in Selected Logic Papers,
1966.
\<close>

definition
  QPair     :: "[i, i] => i"                      (\<open><(_;/ _)>\<close>)  where
    "<a;b> == a+b"

definition
  qfst :: "i => i"  where
    "qfst(p) == THE a. \<exists>b. p=<a;b>"

definition
  qsnd :: "i => i"  where
    "qsnd(p) == THE b. \<exists>a. p=<a;b>"

definition
  qsplit    :: "[[i, i] => 'a, i] => 'a::{}"  (*for pattern-matching*)  where
    "qsplit(c,p) == c(qfst(p), qsnd(p))"

definition
  qconverse :: "i => i"  where
    "qconverse(r) == {z. w \<in> r, \<exists>x y. w=<x;y> & z=<y;x>}"

definition
  QSigma    :: "[i, i => i] => i"  where
    "QSigma(A,B)  ==  \<Union>x\<in>A. \<Union>y\<in>B(x). {<x;y>}"

syntax
  "_QSUM"   :: "[idt, i, i] => i"               (\<open>(3QSUM _ \<in> _./ _)\<close> 10)
translations
  "QSUM x \<in> A. B"  => "CONST QSigma(A, %x. B)"

abbreviation
  qprod  (infixr \<open><*>\<close> 80) where
  "A <*> B == QSigma(A, %_. B)"

definition
  qsum    :: "[i,i]=>i"                         (infixr \<open><+>\<close> 65)  where
    "A <+> B      == ({0} <*> A) \<union> ({1} <*> B)"

definition
  QInl :: "i=>i"  where
    "QInl(a)      == <0;a>"

definition
  QInr :: "i=>i"  where
    "QInr(b)      == <1;b>"

definition
  qcase     :: "[i=>i, i=>i, i]=>i"  where
    "qcase(c,d)   == qsplit(%y z. cond(y, d(z), c(z)))"

subsection\<open>Quine ordered pairing\<close>

(** Lemmas for showing that <a;b> uniquely determines a and b **)

lemma QPair_empty [simp]: "<0;0> = 0"
by (simp add: QPair_def)

lemma QPair_iff [simp]: "<a;b> = <c;d> \<longleftrightarrow> a=c & b=d"
apply (simp add: QPair_def)
apply (rule sum_equal_iff)
done

lemmas QPair_inject = QPair_iff [THEN iffD1, THEN conjE, elim!]

lemma QPair_inject1: "<a;b> = <c;d> ==> a=c"
by blast

lemma QPair_inject2: "<a;b> = <c;d> ==> b=d"
by blast

subsubsection\<open>QSigma: Disjoint union of a family of sets
     Generalizes Cartesian product\<close>

lemma QSigmaI [intro!]: "[| a \<in> A;  b \<in> B(a) |] ==> <a;b> \<in> QSigma(A,B)"
by (simp add: QSigma_def)

(** Elimination rules for <a;b>:A*B -- introducing no eigenvariables **)

lemma QSigmaE [elim!]:
    "[| c \<in> QSigma(A,B);
        !!x y.[| x \<in> A;  y \<in> B(x);  c=<x;y> |] ==> P
     |] ==> P"
by (simp add: QSigma_def, blast)

lemma QSigmaE2 [elim!]:
    "[| <a;b>: QSigma(A,B); [| a \<in> A;  b \<in> B(a) |] ==> P |] ==> P"
by (simp add: QSigma_def)

lemma QSigmaD1: "<a;b> \<in> QSigma(A,B) ==> a \<in> A"
by blast

lemma QSigmaD2: "<a;b> \<in> QSigma(A,B) ==> b \<in> B(a)"
by blast

lemma QSigma_cong:
    "[| A=A';  !!x. x \<in> A' ==> B(x)=B'(x) |] ==>
     QSigma(A,B) = QSigma(A',B')"
by (simp add: QSigma_def)

lemma QSigma_empty1 [simp]: "QSigma(0,B) = 0"
by blast

lemma QSigma_empty2 [simp]: "A <*> 0 = 0"
by blast

subsubsection\<open>Projections: qfst, qsnd\<close>

lemma qfst_conv [simp]: "qfst(<a;b>) = a"
by (simp add: qfst_def)

lemma qsnd_conv [simp]: "qsnd(<a;b>) = b"
by (simp add: qsnd_def)

lemma qfst_type [TC]: "p \<in> QSigma(A,B) ==> qfst(p) \<in> A"
by auto

lemma qsnd_type [TC]: "p \<in> QSigma(A,B) ==> qsnd(p) \<in> B(qfst(p))"
by auto

lemma QPair_qfst_qsnd_eq: "a \<in> QSigma(A,B) ==> <qfst(a); qsnd(a)> = a"
by auto

subsubsection\<open>Eliminator: qsplit\<close>

(*A META-equality, so that it applies to higher types as well...*)
lemma qsplit [simp]: "qsplit(%x y. c(x,y), <a;b>) == c(a,b)"
by (simp add: qsplit_def)

lemma qsplit_type [elim!]:
    "[|  p \<in> QSigma(A,B);
         !!x y.[| x \<in> A; y \<in> B(x) |] ==> c(x,y):C(<x;y>)
     |] ==> qsplit(%x y. c(x,y), p) \<in> C(p)"
by auto

lemma expand_qsplit:
 "u \<in> A<*>B ==> R(qsplit(c,u)) \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>B. u = <x;y> \<longrightarrow> R(c(x,y)))"
apply (simp add: qsplit_def, auto)
done

subsubsection\<open>qsplit for predicates: result type o\<close>

lemma qsplitI: "R(a,b) ==> qsplit(R, <a;b>)"
by (simp add: qsplit_def)

lemma qsplitE:
    "[| qsplit(R,z);  z \<in> QSigma(A,B);
        !!x y. [| z = <x;y>;  R(x,y) |] ==> P
    |] ==> P"
by (simp add: qsplit_def, auto)

lemma qsplitD: "qsplit(R,<a;b>) ==> R(a,b)"
by (simp add: qsplit_def)

subsubsection\<open>qconverse\<close>

lemma qconverseI [intro!]: "<a;b>:r ==> <b;a>:qconverse(r)"
by (simp add: qconverse_def, blast)

lemma qconverseD [elim!]: "<a;b> \<in> qconverse(r) ==> <b;a> \<in> r"
by (simp add: qconverse_def, blast)

lemma qconverseE [elim!]:
    "[| yx \<in> qconverse(r);
        !!x y. [| yx=<y;x>;  <x;y>:r |] ==> P
     |] ==> P"
by (simp add: qconverse_def, blast)

lemma qconverse_qconverse: "r<=QSigma(A,B) ==> qconverse(qconverse(r)) = r"
by blast

lemma qconverse_type: "r \<subseteq> A <*> B ==> qconverse(r) \<subseteq> B <*> A"
by blast

lemma qconverse_prod: "qconverse(A <*> B) = B <*> A"
by blast

lemma qconverse_empty: "qconverse(0) = 0"
by blast

subsection\<open>The Quine-inspired notion of disjoint sum\<close>

lemmas qsum_defs = qsum_def QInl_def QInr_def qcase_def

(** Introduction rules for the injections **)

lemma QInlI [intro!]: "a \<in> A ==> QInl(a) \<in> A <+> B"
by (simp add: qsum_defs, blast)

lemma QInrI [intro!]: "b \<in> B ==> QInr(b) \<in> A <+> B"
by (simp add: qsum_defs, blast)

(** Elimination rules **)

lemma qsumE [elim!]:
    "[| u \<in> A <+> B;
        !!x. [| x \<in> A;  u=QInl(x) |] ==> P;
        !!y. [| y \<in> B;  u=QInr(y) |] ==> P
     |] ==> P"
by (simp add: qsum_defs, blast)

(** Injection and freeness equivalences, for rewriting **)

lemma QInl_iff [iff]: "QInl(a)=QInl(b) \<longleftrightarrow> a=b"
by (simp add: qsum_defs )

lemma QInr_iff [iff]: "QInr(a)=QInr(b) \<longleftrightarrow> a=b"
by (simp add: qsum_defs )

lemma QInl_QInr_iff [simp]: "QInl(a)=QInr(b) \<longleftrightarrow> False"
by (simp add: qsum_defs )

lemma QInr_QInl_iff [simp]: "QInr(b)=QInl(a) \<longleftrightarrow> False"
by (simp add: qsum_defs )

lemma qsum_empty [simp]: "0<+>0 = 0"
by (simp add: qsum_defs )

(*Injection and freeness rules*)

lemmas QInl_inject = QInl_iff [THEN iffD1]
lemmas QInr_inject = QInr_iff [THEN iffD1]
lemmas QInl_neq_QInr = QInl_QInr_iff [THEN iffD1, THEN FalseE, elim!]
lemmas QInr_neq_QInl = QInr_QInl_iff [THEN iffD1, THEN FalseE, elim!]

lemma QInlD: "QInl(a): A<+>B ==> a \<in> A"
by blast

lemma QInrD: "QInr(b): A<+>B ==> b \<in> B"
by blast

(** <+> is itself injective... who cares?? **)

lemma qsum_iff:
     "u \<in> A <+> B \<longleftrightarrow> (\<exists>x. x \<in> A & u=QInl(x)) | (\<exists>y. y \<in> B & u=QInr(y))"
by blast

lemma qsum_subset_iff: "A <+> B \<subseteq> C <+> D \<longleftrightarrow> A<=C & B<=D"
by blast

lemma qsum_equal_iff: "A <+> B = C <+> D \<longleftrightarrow> A=C & B=D"
apply (simp (no_asm) add: extension qsum_subset_iff)
apply blast
done

subsubsection\<open>Eliminator -- qcase\<close>

lemma qcase_QInl [simp]: "qcase(c, d, QInl(a)) = c(a)"
by (simp add: qsum_defs )

lemma qcase_QInr [simp]: "qcase(c, d, QInr(b)) = d(b)"
by (simp add: qsum_defs )

lemma qcase_type:
    "[| u \<in> A <+> B;
        !!x. x \<in> A ==> c(x): C(QInl(x));
        !!y. y \<in> B ==> d(y): C(QInr(y))
     |] ==> qcase(c,d,u) \<in> C(u)"
by (simp add: qsum_defs, auto)

(** Rules for the Part primitive **)

lemma Part_QInl: "Part(A <+> B,QInl) = {QInl(x). x \<in> A}"
by blast

lemma Part_QInr: "Part(A <+> B,QInr) = {QInr(y). y \<in> B}"
by blast

lemma Part_QInr2: "Part(A <+> B, %x. QInr(h(x))) = {QInr(y). y \<in> Part(B,h)}"
by blast

lemma Part_qsum_equality: "C \<subseteq> A <+> B ==> Part(C,QInl) \<union> Part(C,QInr) = C"
by blast

subsubsection\<open>Monotonicity\<close>

lemma QPair_mono: "[| a<=c;  b<=d |] ==> <a;b> \<subseteq> <c;d>"
by (simp add: QPair_def sum_mono)

lemma QSigma_mono [rule_format]:
     "[| A<=C;  \<forall>x\<in>A. B(x) \<subseteq> D(x) |] ==> QSigma(A,B) \<subseteq> QSigma(C,D)"
by blast

lemma QInl_mono: "a<=b ==> QInl(a) \<subseteq> QInl(b)"
by (simp add: QInl_def subset_refl [THEN QPair_mono])

lemma QInr_mono: "a<=b ==> QInr(a) \<subseteq> QInr(b)"
by (simp add: QInr_def subset_refl [THEN QPair_mono])

lemma qsum_mono: "[| A<=C;  B<=D |] ==> A <+> B \<subseteq> C <+> D"
by blast

end


(*
 * Copyright 2021, Florian Haftmann
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Singleton_Bit_Shifts
  imports
    "HOL-Library.Word"
    Bit_Shifts_Infix_Syntax
begin

definition shiftl1 :: \<open>'a::len word \<Rightarrow> 'a word\<close>
  where \<open>shiftl1 = push_bit 1\<close>

lemma bit_shiftl1_iff [bit_simps]:
  \<open>bit (shiftl1 w) n \<longleftrightarrow> 0 < n \<and> n < LENGTH('a) \<and> bit w (n - 1)\<close>
  for w :: \<open>'a::len word\<close>
  by (simp only: shiftl1_def bit_push_bit_iff) auto

definition shiftr1 :: \<open>'a::len word \<Rightarrow> 'a word\<close>
  where \<open>shiftr1 = drop_bit 1\<close>

lemma bit_shiftr1_iff [bit_simps]:
  \<open>bit (shiftr1 w) n \<longleftrightarrow> bit w (Suc n)\<close>
  for w :: \<open>'a::len word\<close>
  by (simp add: shiftr1_def bit_drop_bit_eq)

definition sshiftr1 :: \<open>'a::len word \<Rightarrow> 'a word\<close>
  where \<open>sshiftr1 \<equiv> signed_drop_bit 1\<close>

lemma bit_sshiftr1_iff [bit_simps]:
  \<open>bit (sshiftr1 w) n \<longleftrightarrow> bit w (if n = LENGTH('a) - 1 then LENGTH('a) - 1 else Suc n)\<close>
  for w :: \<open>'a::len word\<close>
  by (auto simp add: sshiftr1_def bit_signed_drop_bit_iff)

lemma shiftr1_1: "shiftr1 (1::'a::len word) = 0"
  by (simp add: shiftr1_def)

lemma sshiftr1_eq:
  \<open>sshiftr1 w = word_of_int (sint w div 2)\<close>
  by (rule bit_word_eqI) (auto simp add: bit_simps min_def simp flip: bit_Suc elim: le_SucE)

lemma shiftl1_eq:
  \<open>shiftl1 w = word_of_int (2 * uint w)\<close>
  by (rule bit_word_eqI) (auto simp add: bit_simps)

lemma shiftr1_eq:
  \<open>shiftr1 w = word_of_int (uint w div 2)\<close>
  by (rule bit_word_eqI) (simp add: bit_simps flip: bit_Suc)

lemma shiftl1_rev:
  "shiftl1 w = word_reverse (shiftr1 (word_reverse w))"
  by (rule bit_word_eqI) (auto simp add: bit_simps Suc_diff_Suc simp flip: bit_Suc)

lemma shiftl1_p:
  "shiftl1 w = w + w"
  for w :: "'a::len word"
  by (simp add: shiftl1_def)

lemma shiftr1_bintr:
  "(shiftr1 (numeral w) :: 'a::len word) =
    word_of_int (take_bit LENGTH('a) (numeral w) div 2)"
  by (rule bit_word_eqI) (simp add: bit_simps bit_numeral_iff [where ?'a = int] flip: bit_Suc)

lemma sshiftr1_sbintr:
  "(sshiftr1 (numeral w) :: 'a::len word) =
    word_of_int (signed_take_bit (LENGTH('a) - 1) (numeral w) div 2)"
  apply (cases \<open>LENGTH('a)\<close>)
  apply simp_all
  apply (rule bit_word_eqI)
  apply (auto simp add: bit_simps min_def simp flip: bit_Suc elim: le_SucE)
  done

lemma shiftl1_wi:
  "shiftl1 (word_of_int w) = word_of_int (2 * w)"
  by (rule bit_word_eqI) (auto simp add: bit_simps)

lemma shiftl1_numeral:
  "shiftl1 (numeral w) = numeral (Num.Bit0 w)"
  unfolding word_numeral_alt shiftl1_wi by simp

lemma shiftl1_neg_numeral:
  "shiftl1 (- numeral w) = - numeral (Num.Bit0 w)"
  unfolding word_neg_numeral_alt shiftl1_wi by simp

lemma shiftl1_0:
  "shiftl1 0 = 0"
  by (simp add: shiftl1_def)

lemma shiftl1_def_u:
  "shiftl1 w = word_of_int (2 * uint w)"
  by (fact shiftl1_eq)

lemma shiftl1_def_s:
  "shiftl1 w = word_of_int (2 * sint w)"
  by (simp add: shiftl1_def)

lemma shiftr1_0:
  "shiftr1 0 = 0"
  by (simp add: shiftr1_def)

lemma sshiftr1_0:
  "sshiftr1 0 = 0"
  by (simp add: sshiftr1_def)

lemma sshiftr1_n1:
  "sshiftr1 (- 1) = - 1"
  by (simp add: sshiftr1_def)

lemma uint_shiftr1:
  "uint (shiftr1 w) = uint w div 2"
  by (rule bit_eqI) (simp add: bit_simps flip: bit_Suc)

lemma shiftr1_div_2:
  "uint (shiftr1 w) = uint w div 2"
  by (fact uint_shiftr1)

lemma sshiftr1_div_2:
  "sint (sshiftr1 w) = sint w div 2"
  by (rule bit_eqI) (auto simp add: bit_simps ac_simps min_def simp flip: bit_Suc elim: le_SucE)

lemma nth_shiftl1:
  "bit (shiftl1 w) n \<longleftrightarrow> n < size w \<and> n > 0 \<and> bit w (n - 1)"
  by (auto simp add: word_size bit_simps)

lemma nth_shiftr1:
  "bit (shiftr1 w) n = bit w (Suc n)"
  by (fact bit_shiftr1_iff)

lemma nth_sshiftr1: "bit (sshiftr1 w) n = (if n = size w - 1 then bit w n else bit w (Suc n))"
  by (auto simp add: word_size bit_simps)

lemma shiftl_power:
  "(shiftl1 ^^ x) (y::'a::len word) = 2 ^ x * y"
  by (induction x) (simp_all add: shiftl1_def)

lemma le_shiftr1:
  \<open>shiftr1 u \<le> shiftr1 v\<close> if \<open>u \<le> v\<close>
  using that by (simp add: word_le_nat_alt unat_div div_le_mono shiftr1_def drop_bit_Suc)

lemma le_shiftr1':
  "\<lbrakk> shiftr1 u \<le> shiftr1 v ; shiftr1 u \<noteq> shiftr1 v \<rbrakk> \<Longrightarrow> u \<le> v"
  by (meson dual_order.antisym le_cases le_shiftr1)

lemma sshiftr_eq_funpow_sshiftr1:
  \<open>w >>> n = (sshiftr1 ^^ n) w\<close>
  apply (rule sym)
  apply (simp add: sshiftr1_def sshiftr_def)
  apply (induction n)
   apply simp_all
  done

end