section \<open>Operation semantics of HCSP.\<close>

theory Op_SL
  imports State_SL
begin

text \<open>Five kinds of events for HCSP processes\<close>
datatype event = Tau | In cname real | Out cname real | IO cname real | Delay time
type_synonym now = real

text \<open>Continuous evolution\<close>

datatype flow = Flow "string list" "exp list"
text \<open>Explicit solution\<close>
consts Solution :: "flow \<Rightarrow> state \<Rightarrow> real \<Rightarrow> real"

consts evalP :: "proc \<Rightarrow> now \<Rightarrow> history \<Rightarrow> event * proc * now * history"
consts evalPP :: "procP \<Rightarrow> now \<Rightarrow> history \<Rightarrow> history \<Rightarrow> event * procP * now * history * history"

text \<open>Parallel composition\<close>

text \<open>Auxiliary functions needed to be introduced first.\<close>

primrec compat :: "event \<Rightarrow> event \<Rightarrow> bool" where
  "compat Tau ev = False"
| "compat (In ch val) ev = (if ev = Out ch val then True else False)"
| "compat (Out ch val) ev = (if ev = In ch val then True else False)"
| "compat (IO ch val) ev = False"
| "compat (Delay d) ev = False"

primrec handshake :: "event \<Rightarrow> event \<Rightarrow> event" where
  "handshake Tau ev = Tau"
| "handshake (In ch val) ev = (if ev = Out ch val then IO ch val else Tau)"
| "handshake (Out ch val) ev = (if ev = In ch val then IO ch val else Tau)"
| "handshake (IO ch val) ev = Tau"
| "handshake (Delay d) ev = Tau"

text \<open>Set of channels of a procedure\<close>
primrec chansetC :: "comm => string set" where
  "chansetC (ch!!e) = {ch}"
| "chansetC (ch??e) = {ch}"

primrec chanset :: "proc \<Rightarrow> string set" where
  "chanset (Cm r) = chansetC r"
| "chanset Skip = {}"
| "chanset (e := f) = {}"
| "chanset (P; Q) = chanset P \<union> chanset Q"
| "chanset (IF b P) = chanset P"
| "chanset (C \<rightarrow> P) = chansetC C \<union> chanset P"
| "chanset (P [[ Q) = chanset P \<union> chanset Q"
| "chanset (P << Q) = chanset P \<union> chanset Q"
  (*"chanset (P || Q) = chanset P \<union> chanset Q" |*)
| "chanset (P *&& Inv) = chanset P"
| "chanset (<vl : el && Inv & b>) = {}"
| "chanset (P [[> Q) = chanset P \<union> chanset Q"

text \<open>Small step semantics for HCSP.\<close>

inductive semP :: "proc \<Rightarrow> now \<Rightarrow> history \<Rightarrow> (event * proc * now * history) \<Rightarrow> bool" where
  skip: "semP Skip now f (Tau, Skip, now, f)"
| assignR: "semP ((RVar x) := e) now f
    (Tau, Skip, now, (\<lambda>t. if t = now then (\<lambda> y. if y=x then evalE e (f t) else f t y) else f t))"
| continuousF: "([\<not>]b) (f now) \<Longrightarrow>
    semP (<[s]:E&&Inv&b>) now f (Tau, Skip, now, f)"
| continuousT: "d\<ge>0 \<Longrightarrow>
       let f' = (\<lambda>t. if t \<le> now+d \<and> t > now then
                       (\<lambda> y. if y = s then Solution (Flow [s] E) (f now) (t-now) else f now y)
                     else f t)
       in \<forall>m. m \<le> now+d \<and> m \<ge> now \<longrightarrow> b (f' m) \<Longrightarrow>
    semP (<[s]:E&&Inv&b>) now f
      (Delay d, <[s]:E&&Inv&b>, now+d,
       (\<lambda>t. if t \<le> now+d \<and> t > now then
              (\<lambda> y. if y = s then Solution (Flow [s] E) (f now) (t-now) else f now y)
            else f t))"
| sequenceL: "semP P now f (ev, P', now', f') \<and> P'\<noteq>Skip \<Longrightarrow>
              semP (P; Q) now f (ev, P';Q, now', f')"
| sequenceR: "semP P now f (ev, P', now', f') \<and> P'=Skip \<Longrightarrow>
              semP (P; Q) now f (ev, Q, now', f')"
| conditionT: " b (f now) \<Longrightarrow> semP (IF b P) now f (Tau, P, now, f)"
| conditionF: "\<not>b (f now) \<Longrightarrow> semP (IF b P) now f (Tau, Skip, now, f)"
| joinL: "semP (P[[Q) now f (Tau, P, now, f)"
| joinR: "semP (P[[Q) now f (Tau, Q, now, f)"
| repetition0: "semP (P*&&Inv) now f (Tau, Skip, now, f)"
| repetitionk: "semP P now f (ev, P', now', f') \<and> P'\<noteq>Skip \<Longrightarrow>
                semP (P*&&Inv) now f (ev, (P'; P*&&Inv), now', f')"
| repetitionk1: "semP P now f (ev, P', now', f') \<and> P'=Skip \<Longrightarrow>
                  semP (P*&&Inv) now f (ev, P*&&Inv, now',f')"
| outputC : "semP (Cm (ch!!e)) now f (Out ch (evalE e (f now)), Skip, now, f)"
| outputW : "d\<ge>0 \<Longrightarrow> semP (Cm (ch!!e)) now f
            (Delay d, Cm (ch!!e), now+d, \<lambda>t. if t \<le> now+d \<and> t > now then f now else f t)"
| inputC : "semP (Cm (ch??x)) now f (In ch c, x := (Real c), now, f)"
| inputW : "d\<ge>0 \<Longrightarrow> semP (Cm (ch??x)) now f
            (Delay d, Cm (ch??x), now+d, \<lambda>t. if t \<le> now+d \<and> t > now then f now else f t)"

inductive semPP :: "procP \<Rightarrow> now \<Rightarrow> history \<Rightarrow> history \<Rightarrow> (event * procP * now * history * history) \<Rightarrow> bool" where
  parallel0: "semPP (P||Q) now f g (eve, P'||Q', now', f', g') \<Longrightarrow> semPP (Q||P) now g f (eve, Q'||P', now', g', f')"
| parallel1: "semP P now f (evp, P', now, f') \<and> semP Q now g (evq, Q', now, g') \<and> compat evp evq \<Longrightarrow>
              semPP (P||Q) now f g (handshake evp evq, P'||Q', now, f', g')"
| parallel2 : "semP P now f (evp, P', now', f')
             \<and> ((evp = Tau) \<or>
                (\<exists>ch c. evp = Out ch c \<and> \<not>(ch \<in> chanset P \<inter> chanset Q)) \<or>
                (\<exists>ch c. evp = In ch c \<and> \<not>(ch \<in> chanset P \<inter> chanset Q)) \<or>
                (\<exists>ch c. evp = IO ch c \<and> \<not>(ch \<in> chanset P \<inter> chanset Q))) \<Longrightarrow>
             semPP (P||Q) now f g (evp, P'||Q, now', f', g)"
| parallel3 : "semP P now f (Delay d, P', now+d, f')
              \<and> semP Q now g (Delay d, Q', now+d, g') \<Longrightarrow>
             semPP (P||Q) now f g (Delay d, P'||Q', now+d, (\<lambda>t. if t \<le> now+d \<and> t \<ge> now then f' t else f t),
                   (\<lambda>t. if t \<le> now+d \<and> t \<ge> now then g' t else g t))"
(*| parallel4: "semP (Skip||Skip) now f (Tau, Skip, now, f)"*)

text \<open>Big-step semantics\<close>

inductive semB :: "proc \<Rightarrow> now \<Rightarrow> history \<Rightarrow> now \<Rightarrow> history \<Rightarrow> bool" where
  skipB: "semB Skip now f now f"
| assignBR: "semB ((RVar x) := e) now f
    now (\<lambda>t. if t = now then (\<lambda> y. if y = x then evalE e (f t) else f t y) else f t)"
| continuousBF: "([\<not>]b) (f now) \<Longrightarrow> semB (<[s]:E&&Inv&b>) now f now f"
| continuousBT: "d>0 \<Longrightarrow>
       let f' = (\<lambda>t. if t \<le> now+d \<and> t > now then
                       (\<lambda> y. if y = s then (Solution (Flow [s] E) (f now) (t-now)) else f now y)
                     else f t)
       in (\<forall>m. m < now+d \<and> m \<ge> now \<longrightarrow> b (f' m)) \<and> ([\<not>]b) (f' (now+d)) \<Longrightarrow>
    semB (<[s]:E&&Inv&b>) now f (now+d)
      (\<lambda>t. if t \<le> now+d \<and> t > now then
             (\<lambda> y. if y = s then (Solution (Flow [s] E) (f now) (t-now)) else f now y)
           else f t)"
| sequenceB: "semB P now f now' f' \<and> semB Q now' f' now'' f'' \<Longrightarrow> semB (P; Q) now f now'' f''"
| conditionBT: " b (f now) \<Longrightarrow> semB P now f now_d f_d \<Longrightarrow> semB (IF b P) now f now_d f_d"
| conditionBF: "\<not>b (f now) \<Longrightarrow> semB (IF b P) now f now f"
| conditionGBT: " b (f now) \<Longrightarrow> semB P now f now_d f_d \<Longrightarrow> semB (IFELSE b P Q) now f now_d f_d"
| conditionGBF: "\<not>b (f now) \<Longrightarrow> semB Q now f now_d f_d \<Longrightarrow> semB (IFELSE b P Q) now f now_d f_d"
| joinBL: "semB P now f now_d f_d \<Longrightarrow> semB (P[[Q) now f now_d f_d"
| joinBR: "semB Q now f now_d f_d \<Longrightarrow> semB (P[[Q) now f now_d f_d"
| repetitionB: "\<exists>N. semB (P * NUM N) now f now_dd f_dd \<Longrightarrow> semB (P*&&Inv) now f now_dd f_dd"
| repetitionN0B: "N = (0::nat) \<Longrightarrow> semB (P * NUM N) now f now f"
| repetitionNkB: "N > (0::nat) \<Longrightarrow> semB P now f now_d f_d \<Longrightarrow> semB (P * NUM (N-1)) now_d f_d now_dd f_dd \<Longrightarrow>
                  semB (P * NUM N) now f now_dd f_dd"
| outputBC: "d\<ge>0 \<Longrightarrow> semB (Cm (ch!!e)) now f (now+d) (\<lambda>t. if t \<le> now+d \<and> t > now then f now else f t)"
| inputBC: "d\<ge>0 \<Longrightarrow> semB (Cm (ch??(RVar x))) now f (now + d)
            (\<lambda>t. if t < now+d \<and> t > now then f now
                 else if t = now+d then \<lambda> y. if y=x  then c else f now y
                 else f t)"

text \<open>There are four cases for semantics of parallel composition.\<close>
inductive semBP :: "procP \<Rightarrow> now \<Rightarrow> history \<Rightarrow> now \<Rightarrow> history \<Rightarrow> now \<Rightarrow> history \<Rightarrow> now \<Rightarrow> history \<Rightarrow> bool" where
  parallelB1: "semB P nowp fp nowp' fp' \<Longrightarrow> semB Q nowq fq nowq' fq' \<Longrightarrow> chanset P = {} \<and> chanset Q = {} \<Longrightarrow>
               semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq'"
| parallelB2: "semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
               semB U nowp' fp' nowu' fu' \<Longrightarrow> semB V nowq' fq' nowv' fv' \<Longrightarrow> chanset P \<noteq> {} \<and> chanset Q \<noteq> {} \<Longrightarrow>
               chanset U = {} \<and> chanset V = {} \<Longrightarrow>
               semBP ((P; U) || (Q; V)) nowp fp nowq fq  nowu' fu' nowv' fv'"
| parallelB3:
 "semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
  semBP (P; Cm (ch??(RVar x)) || Q; Cm (ch!!e)) nowp fp nowq fq (max nowp' nowq')
   (\<lambda>t. if nowp' < t \<and> t < max nowp' nowq' then fp' nowp'
         else if t = max nowp' nowq' then \<lambda> y. if y = x then evalE e (fp' nowp') else fp' nowp' y
              else fp' t)
   (max nowp' nowq') (\<lambda>t. if nowq' < t \<and> t \<le> max nowp' nowq' then fq' nowq' else fq' t)"
| parallelB4:
 "semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
  semBP (P; Cm (ch!!e) || Q; Cm (ch??(RVar x))) nowp fp nowq fq (max nowp' nowq')
   (\<lambda>t. if nowp' < t \<and> t \<le> max nowp' nowq' then fp' nowp' else fp' t) (max nowp' nowq')
   (\<lambda>t. if nowq' < t \<and> t < max nowp' nowq' then fq' nowq'
         else if t = max nowp' nowq' then \<lambda> y. if y = x then evalE e (fq' nowq') else fq' nowq' y
              else fq' t)"

inductive_cases [elim!]:
  "semB Skip now f now' f'"
  "semB ((RVar x) := e) now f now' f'"
  "semB ((SVar x) := e) now f now' f'"
  "semB ((BVar x) := e) now f now' f'"
  "semB (P; Q) now f now' f'"
  "semB (IF be P) now f  now' f'"
  "semB (IFELSE be P Q) now f now' f'"
  "semB (P[[Q) now f now' f'"
  "semB (<[s]:E&&Inv&b>) now f now' f'"
  "semB (P*&&Inv) now f now' f'"
  "semB (P* NUM N) now f now' f'"
  "semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq'"

subsection \<open>Continuous evolution\<close>

(*Differential invariant: Now the invariant is annotated in the equation directly.*)
(*consts Invariant :: "proc \<Rightarrow> fform"*)

text \<open>exeFlow defines the execution of a continuous process from a state satisfying a given property\<close>
definition exeFlow :: "proc \<Rightarrow> fform \<Rightarrow> fform" where
  "exeFlow P p s \<equiv> (\<exists>now f now' f'. semB P now f now' f' \<and> p (f now) \<and> (\<exists>t. t \<le> now' \<and> t \<ge> now \<and> f' t = s))"

subsection \<open>Properties related to semantics\<close>

lemma sem1:
  "semB P now f now' f' \<Longrightarrow> now \<le> now'"
  by (induct rule: semB.induct, auto)

lemma semB1:
  "semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow> nowp \<le> nowp' \<and> nowq \<le> nowq'"
proof (induct rule: semBP.induct)
  case (parallelB1 P nowp fp nowp' fp' Q nowq fq nowq' fq')
  then show ?case by (auto intro: sem1)
next
  case (parallelB2 P Q nowp fp nowq fq nowp' fp' nowq' fq' U nowu' fu' V nowv' fv')
  then show ?case by (metis order_trans sem1)
qed (metis le_max_iff_disj)+

lemma sem2:
  "semB P now f now' f' \<Longrightarrow> \<forall>t. t < now \<or> t > now' \<longrightarrow> f t = f' t"
proof (induct rule: semB.induct)
  case (sequenceB P now f now' f' Q now'' f'')
  then show ?case
    by (metis (full_types) le_less_trans not_le sem1)
next
  case (repetitionNkB N P now f now_d f_d now_dd f_dd)
  then show ?case
    by (metis (full_types) le_less_trans less_eq_real_def sem1)
qed auto

lemma semB2:
  "semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
    (\<forall>t. t < nowp \<or> t > nowp' \<longrightarrow> (fp t = fp' t)) \<and>
    (\<forall>t. t < nowq \<or> t > nowq' \<longrightarrow> (fq t = fq' t))"
proof (induct rule: semBP.induct)
  case (parallelB1 P nowp fp nowp' fp' Q nowq fq nowq' fq')
  then show ?case by (auto simp add: sem2)
next
  case (parallelB2 P Q nowp fp nowq fq nowp' fp' nowq' fq' U nowu' fu' V nowv' fv')
  then show ?case  by (smt sem1 sem2 semB1)

next
  case (parallelB3 P Q nowp fp nowq fq nowp' fp' nowq' fq' ch x e)
  then show ?case by (smt semB1)
next
  case (parallelB4 P Q nowp fp nowq fq nowp' fp' nowq' fq' ch e x)
  then show ?case by (smt semB1)
qed

lemma semB3:
  "semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
   chanset P = {} \<and> chanset Q = {} \<Longrightarrow>
   semB P nowp fp nowp' fp' \<and> semB Q nowq fq nowq' fq'"
  by (induct rule: semBP.cases; simp add: chanset_def)

end


(*  Title:      HOL/Auth/NS_Public_Bad.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Inductive relation "ns_public" for the Needham-Schroeder Public-Key protocol.
Flawed version, vulnerable to Lowe's attack.

From page 260 of
  Burrows, Abadi and Needham.  A Logic of Authentication.
  Proc. Royal Soc. 426 (1989)
*)

section\<open>Verifying the Needham-Schroeder Public-Key Protocol\<close>

theory NS_Public_Bad imports Public begin

inductive_set ns_public :: "event list set"
  where
         (*Initial trace is empty*)
   Nil:  "[] \<in> ns_public"

         (*The spy MAY say anything he CAN say.  We do not expect him to
           invent new nonces here, but he can also use NS1.  Common to
           all similar protocols.*)
 | Fake: "\<lbrakk>evsf \<in> ns_public;  X \<in> synth (analz (spies evsf))\<rbrakk>
          \<Longrightarrow> Says Spy B X  # evsf \<in> ns_public"

         (*Alice initiates a protocol run, sending a nonce to Bob*)
 | NS1:  "\<lbrakk>evs1 \<in> ns_public;  Nonce NA \<notin> used evs1\<rbrakk>
          \<Longrightarrow> Says A B (Crypt (pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace>)
                # evs1  \<in>  ns_public"

         (*Bob responds to Alice's message with a further nonce*)
 | NS2:  "\<lbrakk>evs2 \<in> ns_public;  Nonce NB \<notin> used evs2;
           Says A' B (Crypt (pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs2\<rbrakk>
          \<Longrightarrow> Says B A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>)
                # evs2  \<in>  ns_public"

         (*Alice proves her existence by sending NB back to Bob.*)
 | NS3:  "\<lbrakk>evs3 \<in> ns_public;
           Says A  B (Crypt (pubEK B) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs3;
           Says B' A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs3\<rbrakk>
          \<Longrightarrow> Says A B (Crypt (pubEK B) (Nonce NB)) # evs3 \<in> ns_public"

declare knows_Spy_partsEs [elim]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un [dest]

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

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

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

(*Spy never sees another agent's private key! (unless it's bad at start)*)
lemma Spy_see_priEK [simp]:
      "evs \<in> ns_public \<Longrightarrow> (Key (priEK A) \<in> parts (spies evs)) = (A \<in> bad)"
by (erule ns_public.induct, auto)

lemma Spy_analz_priEK [simp]:
      "evs \<in> ns_public \<Longrightarrow> (Key (priEK A) \<in> analz (spies evs)) = (A \<in> bad)"
by auto

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

(*It is impossible to re-use a nonce in both NS1 and NS2, provided the nonce
  is secret.  (Honest users generate fresh nonces.)*)

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

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

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

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

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

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

(*Unicity for NS2: nonce NB identifies nonce NA and agent A
  [proof closely follows that for unique_NA] *)
lemma unique_NB [dest]:
     "\<lbrakk>Crypt(pubEK A)  \<lbrace>Nonce NA, Nonce NB\<rbrace> \<in> parts(spies evs);
       Crypt(pubEK A') \<lbrace>Nonce NA', Nonce NB\<rbrace> \<in> parts(spies evs);
       Nonce NB \<notin> analz (spies evs); evs \<in> ns_public\<rbrakk>
     \<Longrightarrow> A=A' \<and> NA=NA'"
apply (erule rev_mp, erule rev_mp, erule rev_mp)
apply (erule ns_public.induct, simp_all)
(*Fake, NS2*)
apply (blast intro!: analz_insertI)+
done

(*NB remains secret PROVIDED Alice never responds with round 3*)
theorem Spy_not_see_NB [dest]:
     "\<lbrakk>Says B A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs;
       \<forall>C. Says A C (Crypt (pubEK C) (Nonce NB)) \<notin> set evs;
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
     \<Longrightarrow> Nonce NB \<notin> analz (spies evs)"
apply (erule rev_mp, erule rev_mp)
apply (erule ns_public.induct, simp_all, spy_analz)
apply (simp_all add: all_conj_distrib) (*speeds up the next step*)
apply (blast intro: no_nonce_NS1_NS2)+
done

(*Authentication for B: if he receives message 3 and has used NB
  in message 2, then A has sent message 3--to somebody....*)

lemma B_trusts_NS3_lemma [rule_format]:
     "\<lbrakk>A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
      \<Longrightarrow> Crypt (pubEK B) (Nonce NB) \<in> parts (spies evs) \<longrightarrow>
          Says B A  (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs \<longrightarrow>
          (\<exists>C. Says A C (Crypt (pubEK C) (Nonce NB)) \<in> set evs)"
apply (erule ns_public.induct, auto)
by (blast intro: no_nonce_NS1_NS2)+

theorem B_trusts_NS3:
     "\<lbrakk>Says B A  (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs;
       Says A' B (Crypt (pubEK B) (Nonce NB)) \<in> set evs;
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
      \<Longrightarrow> \<exists>C. Says A C (Crypt (pubEK C) (Nonce NB)) \<in> set evs"
by (blast intro: B_trusts_NS3_lemma)

(*Can we strengthen the secrecy theorem Spy_not_see_NB?  NO*)
lemma "\<lbrakk>A \<notin> bad;  B \<notin> bad;  evs \<in> ns_public\<rbrakk>
       \<Longrightarrow> Says B A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs
           \<longrightarrow> Nonce NB \<notin> analz (spies evs)"
apply (erule ns_public.induct, simp_all, spy_analz)
(*NS1: by freshness*)
apply blast
(*NS2: by freshness and unicity of NB*)
apply (blast intro: no_nonce_NS1_NS2)
(*NS3: unicity of NB identifies A and NA, but not B*)
apply clarify
apply (frule_tac A' = A in
       Says_imp_knows_Spy [THEN parts.Inj, THEN unique_NB], auto)
apply (rename_tac evs3 B' C)
txt\<open>This is the attack!
@{subgoals[display,indent=0,margin=65]}
\<close>
oops

(*
THIS IS THE ATTACK!
Level 8
!!evs. \<lbrakk>A \<notin> bad; B \<notin> bad; evs \<in> ns_public\<rbrakk>
       \<Longrightarrow> Says B A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs \<longrightarrow>
           Nonce NB \<notin> analz (spies evs)
 1. !!C B' evs3.
       \<lbrakk>A \<notin> bad; B \<notin> bad; evs3 \<in> ns_public
        Says A C (Crypt (pubEK C) \<lbrace>Nonce NA, Agent A\<rbrace>) \<in> set evs3;
        Says B' A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs3;
        C \<in> bad;
        Says B A (Crypt (pubEK A) \<lbrace>Nonce NA, Nonce NB\<rbrace>) \<in> set evs3;
        Nonce NB \<notin> analz (spies evs3)\<rbrakk>
       \<Longrightarrow> False
*)

end


section \<open>CFG\<close>

theory CFG imports BasicDefs begin

subsection \<open>The abstract CFG\<close>

locale CFG =
  fixes sourcenode :: "'edge \<Rightarrow> 'node"
  fixes targetnode :: "'edge \<Rightarrow> 'node"
  fixes kind :: "'edge \<Rightarrow> 'state edge_kind"
  fixes valid_edge :: "'edge \<Rightarrow> bool"
  fixes Entry::"'node" ("'('_Entry'_')")
  assumes Entry_target [dest]: "\<lbrakk>valid_edge a; targetnode a = (_Entry_)\<rbrakk> \<Longrightarrow> False"
  and edge_det:
  "\<lbrakk>valid_edge a; valid_edge a'; sourcenode a = sourcenode a';
    targetnode a = targetnode a'\<rbrakk> \<Longrightarrow> a = a'"

begin

definition valid_node :: "'node \<Rightarrow> bool"
  where "valid_node n \<equiv>
  (\<exists>a. valid_edge a \<and> (n = sourcenode a \<or> n = targetnode a))"

lemma [simp]: "valid_edge a \<Longrightarrow> valid_node (targetnode a)"
  by(fastforce simp:valid_node_def)

subsection \<open>CFG paths and lemmas\<close>

inductive path :: "'node \<Rightarrow> 'edge list \<Rightarrow> 'node \<Rightarrow> bool"
  ("_ -_\<rightarrow>* _" [51,0,0] 80)
where
  empty_path:"valid_node n \<Longrightarrow> n -[]\<rightarrow>* n"

  | Cons_path:
  "\<lbrakk>n'' -as\<rightarrow>* n'; valid_edge a; sourcenode a = n; targetnode a = n''\<rbrakk>
    \<Longrightarrow> n -a#as\<rightarrow>* n'"

lemma path_valid_node:
  assumes "n -as\<rightarrow>* n'" shows "valid_node n" and "valid_node n'"
  using \<open>n -as\<rightarrow>* n'\<close>
  by(induct rule:path.induct,auto)

lemma empty_path_nodes [dest]:"n -[]\<rightarrow>* n' \<Longrightarrow> n = n'"
  by(fastforce elim:path.cases)

lemma path_valid_edges:"n -as\<rightarrow>* n' \<Longrightarrow> \<forall>a \<in> set as. valid_edge a"
by(induct rule:path.induct) auto

lemma path_edge:"valid_edge a \<Longrightarrow> sourcenode a -[a]\<rightarrow>* targetnode a"
  by(fastforce intro:Cons_path empty_path)

lemma path_Entry_target [dest]:
  assumes "n -as\<rightarrow>* (_Entry_)"
  shows "n = (_Entry_)" and "as = []"
using \<open>n -as\<rightarrow>* (_Entry_)\<close>
proof(induct n as n'\<equiv>"(_Entry_)" rule:path.induct)
  case (Cons_path n'' as a n)
  from \<open>targetnode a = n''\<close> \<open>valid_edge a\<close> \<open>n'' = (_Entry_)\<close> have False
    by -(rule Entry_target,simp_all)
  { case 1
    with \<open>False\<close> show ?case ..
  next
    case 2
    with \<open>False\<close> show ?case ..
  }
qed simp_all

lemma path_Append:"\<lbrakk>n -as\<rightarrow>* n''; n'' -as'\<rightarrow>* n'\<rbrakk>
  \<Longrightarrow> n -as@as'\<rightarrow>* n'"
by(induct rule:path.induct,auto intro:Cons_path)

lemma path_split:
  assumes "n -as@a#as'\<rightarrow>* n'"
  shows "n -as\<rightarrow>* sourcenode a" and "valid_edge a" and "targetnode a -as'\<rightarrow>* n'"
  using \<open>n -as@a#as'\<rightarrow>* n'\<close>
proof(induct as arbitrary:n)
  case Nil case 1
  thus ?case by(fastforce elim:path.cases intro:empty_path)
next
  case Nil case 2
  thus ?case by(fastforce elim:path.cases intro:path_edge)
next
  case Nil case 3
  thus ?case by(fastforce elim:path.cases)
next
  case (Cons ax asx)
  note IH1 = \<open>\<And>n. n -asx@a#as'\<rightarrow>* n' \<Longrightarrow> n -asx\<rightarrow>* sourcenode a\<close>
  note IH2 = \<open>\<And>n. n -asx@a#as'\<rightarrow>* n' \<Longrightarrow> valid_edge a\<close>
  note IH3 = \<open>\<And>n. n -asx@a#as'\<rightarrow>* n' \<Longrightarrow> targetnode a -as'\<rightarrow>* n'\<close>
  { case 1
    hence "sourcenode ax = n" and "targetnode ax -asx@a#as'\<rightarrow>* n'" and "valid_edge ax"
      by(auto elim:path.cases)
    from IH1[OF \<open> targetnode ax -asx@a#as'\<rightarrow>* n'\<close>]
    have "targetnode ax -asx\<rightarrow>* sourcenode a" .
    with \<open>sourcenode ax = n\<close> \<open>valid_edge ax\<close> show ?case by(fastforce intro:Cons_path)
  next
    case 2 hence "targetnode ax -asx@a#as'\<rightarrow>* n'" by(auto elim:path.cases)
    from IH2[OF this] show ?case .
  next
    case 3 hence "targetnode ax -asx@a#as'\<rightarrow>* n'" by(auto elim:path.cases)
    from IH3[OF this] show ?case .
  }
qed

lemma path_split_Cons:
  assumes "n -as\<rightarrow>* n'" and "as \<noteq> []"
  obtains a' as' where "as = a'#as'" and "n = sourcenode a'"
  and "valid_edge a'" and "targetnode a' -as'\<rightarrow>* n'"
proof -
  from \<open>as \<noteq> []\<close> obtain a' as' where "as = a'#as'" by(cases as) auto
  with \<open>n -as\<rightarrow>* n'\<close> have "n -[]@a'#as'\<rightarrow>* n'" by simp
  hence "n -[]\<rightarrow>* sourcenode a'" and "valid_edge a'" and "targetnode a' -as'\<rightarrow>* n'"
    by(rule path_split)+
  from \<open>n -[]\<rightarrow>* sourcenode a'\<close> have "n = sourcenode a'" by fast
  with \<open>as = a'#as'\<close> \<open>valid_edge a'\<close> \<open>targetnode a' -as'\<rightarrow>* n'\<close> that show ?thesis
    by fastforce
qed

lemma path_split_snoc:
  assumes "n -as\<rightarrow>* n'" and "as \<noteq> []"
  obtains a' as' where "as = as'@[a']" and "n -as'\<rightarrow>* sourcenode a'"
  and "valid_edge a'" and "n' = targetnode a'"
proof -
  from \<open>as \<noteq> []\<close> obtain a' as' where "as = as'@[a']" by(cases as rule:rev_cases) auto
  with \<open>n -as\<rightarrow>* n'\<close> have "n -as'@a'#[]\<rightarrow>* n'" by simp
  hence "n -as'\<rightarrow>* sourcenode a'" and "valid_edge a'" and "targetnode a' -[]\<rightarrow>* n'"
    by(rule path_split)+
  from \<open>targetnode a' -[]\<rightarrow>* n'\<close> have "n' = targetnode a'" by fast
  with \<open>as = as'@[a']\<close> \<open>valid_edge a'\<close> \<open>n -as'\<rightarrow>* sourcenode a'\<close> that show ?thesis
    by fastforce
qed

lemma path_split_second:
  assumes "n -as@a#as'\<rightarrow>* n'" shows "sourcenode a -a#as'\<rightarrow>* n'"
proof -
  from \<open>n -as@a#as'\<rightarrow>* n'\<close> have "valid_edge a" and "targetnode a -as'\<rightarrow>* n'"
    by(auto intro:path_split)
  thus ?thesis by(fastforce intro:Cons_path)
qed

lemma path_Entry_Cons:
  assumes "(_Entry_) -as\<rightarrow>* n'" and "n' \<noteq> (_Entry_)"
  obtains n a where "sourcenode a = (_Entry_)" and "targetnode a = n"
  and "n -tl as\<rightarrow>* n'" and "valid_edge a" and "a = hd as"
proof -
  from \<open>(_Entry_) -as\<rightarrow>* n'\<close> \<open>n' \<noteq> (_Entry_)\<close> have "as \<noteq> []"
    by(cases as,auto elim:path.cases)
  with \<open>(_Entry_) -as\<rightarrow>* n'\<close> obtain a' as' where "as = a'#as'"
    and "(_Entry_) = sourcenode a'" and "valid_edge a'" and "targetnode a' -as'\<rightarrow>* n'"
    by(erule path_split_Cons)
  with that show ?thesis by fastforce
qed

lemma path_det:
  "\<lbrakk>n -as\<rightarrow>* n'; n -as\<rightarrow>* n''\<rbrakk> \<Longrightarrow> n' = n''"
proof(induct as arbitrary:n)
  case Nil thus ?case by(auto elim:path.cases)
next
  case (Cons a' as')
  note IH = \<open>\<And>n. \<lbrakk>n -as'\<rightarrow>* n'; n -as'\<rightarrow>* n''\<rbrakk> \<Longrightarrow> n' = n''\<close>
  from \<open>n -a'#as'\<rightarrow>* n'\<close> have "targetnode a' -as'\<rightarrow>* n'"
    by(fastforce elim:path_split_Cons)
  from \<open>n -a'#as'\<rightarrow>* n''\<close> have "targetnode a' -as'\<rightarrow>* n''"
    by(fastforce elim:path_split_Cons)
  from IH[OF \<open>targetnode a' -as'\<rightarrow>* n'\<close> this] show ?thesis .
qed

definition
  sourcenodes :: "'edge list \<Rightarrow> 'node list"
  where "sourcenodes xs \<equiv> map sourcenode xs"

definition
  kinds :: "'edge list \<Rightarrow> 'state edge_kind list"
  where "kinds xs \<equiv> map kind xs"

definition
  targetnodes :: "'edge list \<Rightarrow> 'node list"
  where "targetnodes xs \<equiv> map targetnode xs"

lemma path_sourcenode:
  "\<lbrakk>n -as\<rightarrow>* n'; as \<noteq> []\<rbrakk> \<Longrightarrow> hd (sourcenodes as) = n"
by(fastforce elim:path_split_Cons simp:sourcenodes_def)

lemma path_targetnode:
  "\<lbrakk>n -as\<rightarrow>* n'; as \<noteq> []\<rbrakk> \<Longrightarrow> last (targetnodes as) = n'"
by(fastforce elim:path_split_snoc simp:targetnodes_def)

lemma sourcenodes_is_n_Cons_butlast_targetnodes:
  "\<lbrakk>n -as\<rightarrow>* n'; as \<noteq> []\<rbrakk> \<Longrightarrow>
  sourcenodes as = n#(butlast (targetnodes as))"
proof(induct as arbitrary:n)
  case Nil thus ?case by simp
next
  case (Cons a' as')
  note IH = \<open>\<And>n. \<lbrakk>n -as'\<rightarrow>* n'; as' \<noteq> []\<rbrakk>
            \<Longrightarrow> sourcenodes as' = n#(butlast (targetnodes as'))\<close>
  from \<open>n -a'#as'\<rightarrow>* n'\<close> have "n = sourcenode a'" and "targetnode a' -as'\<rightarrow>* n'"
    by(auto elim:path_split_Cons)
  show ?case
  proof(cases "as' = []")
    case True
    with \<open>targetnode a' -as'\<rightarrow>* n'\<close> have "targetnode a' = n'" by fast
    with True \<open>n = sourcenode a'\<close> show ?thesis
      by(simp add:sourcenodes_def targetnodes_def)
  next
    case False
    from IH[OF \<open>targetnode a' -as'\<rightarrow>* n'\<close> this]
    have "sourcenodes as' = targetnode a' # butlast (targetnodes as')" .
    with \<open>n = sourcenode a'\<close> False show ?thesis
      by(simp add:sourcenodes_def targetnodes_def)
  qed
qed

lemma targetnodes_is_tl_sourcenodes_App_n':
  "\<lbrakk>n -as\<rightarrow>* n'; as \<noteq> []\<rbrakk> \<Longrightarrow>
    targetnodes as = (tl (sourcenodes as))@[n']"
proof(induct as arbitrary:n' rule:rev_induct)
  case Nil thus ?case by simp
next
  case (snoc a' as')
  note IH = \<open>\<And>n'. \<lbrakk>n -as'\<rightarrow>* n'; as' \<noteq> []\<rbrakk>
    \<Longrightarrow> targetnodes as' = tl (sourcenodes as') @ [n']\<close>
  from \<open>n -as'@[a']\<rightarrow>* n'\<close> have "n -as'\<rightarrow>* sourcenode a'" and "n' = targetnode a'"
    by(auto elim:path_split_snoc)
  show ?case
  proof(cases "as' = []")
    case True
    with \<open>n -as'\<rightarrow>* sourcenode a'\<close> have "n = sourcenode a'" by fast
    with True \<open>n' = targetnode a'\<close> show ?thesis
      by(simp add:sourcenodes_def targetnodes_def)
  next
    case False
    from IH[OF \<open>n -as'\<rightarrow>* sourcenode a'\<close> this]
    have "targetnodes as' = tl (sourcenodes as')@[sourcenode a']" .
    with \<open>n' = targetnode a'\<close> False show ?thesis
      by(simp add:sourcenodes_def targetnodes_def)
  qed
qed

lemma Entry_sourcenode_hd:
  assumes "n -as\<rightarrow>* n'" and "(_Entry_) \<in> set (sourcenodes as)"
  shows "n = (_Entry_)" and "(_Entry_) \<notin> set (sourcenodes (tl as))"
  using \<open>n -as\<rightarrow>* n'\<close> \<open>(_Entry_) \<in> set (sourcenodes as)\<close>
proof(induct rule:path.induct)
  case (empty_path n) case 1
  thus ?case by(simp add:sourcenodes_def)
next
  case (empty_path n) case 2
  thus ?case by(simp add:sourcenodes_def)
next
  case (Cons_path n'' as n' a n)
  note IH1 = \<open>(_Entry_) \<in> set(sourcenodes as) \<Longrightarrow> n'' = (_Entry_)\<close>
  note IH2 = \<open>(_Entry_) \<in> set(sourcenodes as) \<Longrightarrow> (_Entry_) \<notin> set(sourcenodes(tl as))\<close>
  have "(_Entry_) \<notin> set (sourcenodes(tl(a#as)))"
  proof
    assume "(_Entry_) \<in> set (sourcenodes (tl (a#as)))"
    hence "(_Entry_) \<in> set (sourcenodes as)" by simp
    from IH1[OF this] have "n'' = (_Entry_)" by simp
    with \<open>targetnode a = n''\<close> \<open>valid_edge a\<close> show False by -(erule Entry_target,simp)
  qed
  hence "(_Entry_) \<notin> set (sourcenodes(tl(a#as)))" by fastforce
  { case 1
    with \<open>(_Entry_) \<notin> set (sourcenodes(tl(a#as)))\<close> \<open>sourcenode a = n\<close>
    show ?case by(simp add:sourcenodes_def)
  next
    case 2
    with \<open>(_Entry_) \<notin> set (sourcenodes(tl(a#as)))\<close> \<open>sourcenode a = n\<close>
    show ?case by(simp add:sourcenodes_def)
  }
qed

end

end


(*  Title:      Bits_Integer.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter \<open>Bit operations for target language integers\<close>

theory Bits_Integer imports
  More_Bits_Int
  Code_Symbolic_Bits_Int
begin

lemmas [transfer_rule] =
  identity_quotient
  fun_quotient
  Quotient_integer[folded integer.pcr_cr_eq]

lemma undefined_transfer:
  assumes "Quotient R Abs Rep T"
  shows "T (Rep undefined) undefined"
using assms unfolding Quotient_alt_def by blast

bundle undefined_transfer = undefined_transfer[transfer_rule]

section \<open>More lemmas about @{typ integer}s\<close>

context
includes integer.lifting
begin

lemma bitval_integer_transfer [transfer_rule]:
  "(rel_fun (=) pcr_integer) of_bool of_bool"
by(auto simp add: of_bool_def integer.pcr_cr_eq cr_integer_def)

lemma integer_of_nat_less_0_conv [simp]: "\<not> integer_of_nat n < 0"
by(transfer) simp

lemma int_of_integer_pow: "int_of_integer (x ^ n) = int_of_integer x ^ n"
by(induct n) simp_all

lemma pow_integer_transfer [transfer_rule]:
  "(rel_fun pcr_integer (rel_fun (=) pcr_integer)) (^) (^)"
by(auto 4 3 simp add: integer.pcr_cr_eq cr_integer_def int_of_integer_pow)

lemma sub1_lt_0_iff [simp]: "Code_Numeral.sub n num.One < 0 \<longleftrightarrow> False"
by(cases n)(simp_all add: Code_Numeral.sub_code)

lemma nat_of_integer_numeral [simp]: "nat_of_integer (numeral n) = numeral n"
by transfer simp

lemma nat_of_integer_sub1_conv_pred_numeral [simp]:
  "nat_of_integer (Code_Numeral.sub n num.One) = pred_numeral n"
by(cases n)(simp_all add: Code_Numeral.sub_code)

lemma nat_of_integer_1 [simp]: "nat_of_integer 1 = 1"
by transfer simp

lemma dup_1 [simp]: "Code_Numeral.dup 1 = 2"
by transfer simp

section \<open>Bit operations on @{typ integer}\<close>

text \<open>Bit operations on @{typ integer} are the same as on @{typ int}\<close>

lift_definition bin_rest_integer :: "integer \<Rightarrow> integer" is bin_rest .
lift_definition bin_last_integer :: "integer \<Rightarrow> bool" is bin_last .
lift_definition Bit_integer :: "integer \<Rightarrow> bool \<Rightarrow> integer" is Bit .

end

instantiation integer :: bit_operations begin
context includes integer.lifting begin

lift_definition bitAND_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" is "bitAND" .
lift_definition bitOR_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" is "bitOR" .
lift_definition bitXOR_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" is "bitXOR" .
lift_definition bitNOT_integer :: "integer \<Rightarrow> integer" is "bitNOT" .

lift_definition test_bit_integer :: "integer \<Rightarrow> nat \<Rightarrow> bool" is test_bit .
lift_definition lsb_integer :: "integer \<Rightarrow> bool" is lsb .
lift_definition set_bit_integer :: "integer \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> integer" is set_bit .
lift_definition shiftl_integer :: "integer \<Rightarrow> nat \<Rightarrow> integer" is shiftl .
lift_definition shiftr_integer :: "integer \<Rightarrow> nat \<Rightarrow> integer" is shiftr .

lift_definition msb_integer :: "integer \<Rightarrow> bool" is msb .
instance ..
end
end

abbreviation (input) wf_set_bits_integer
where "wf_set_bits_integer \<equiv> wf_set_bits_int"

section \<open>Target language implementations\<close>

text \<open>
  Unfortunately, this is not straightforward,
  because these API functions have different signatures and preconditions on the parameters:

  \begin{description}
  \item[Standard ML] Shifts in IntInf are given as word, but not IntInf.
  \item[Haskell] In the Data.Bits.Bits type class, shifts and bit indices are given as Int rather than Integer.
  \end{description}

  Additional constants take only parameters of type @{typ integer} rather than @{typ nat}
  and check the preconditions as far as possible (e.g., being non-negative) in a portable way.
  Manual implementations inside code\_printing perform the remaining range checks and convert
  these @{typ integer}s into the right type.

  For normalisation by evaluation, we derive custom code equations, because NBE
  does not know these code\_printing serialisations and would otherwise loop.
\<close>

code_identifier code_module Bits_Integer \<rightharpoonup>
  (SML) Bits_Int and (OCaml) Bits_Int and (Haskell) Bits_Int and (Scala) Bits_Int

code_printing code_module Bits_Integer \<rightharpoonup> (SML)
\<open>structure Bits_Integer : sig
  val set_bit : IntInf.int -> IntInf.int -> bool -> IntInf.int
  val shiftl : IntInf.int -> IntInf.int -> IntInf.int
  val shiftr : IntInf.int -> IntInf.int -> IntInf.int
  val test_bit : IntInf.int -> IntInf.int -> bool
end = struct

val maxWord = IntInf.pow (2, Word.wordSize);

fun set_bit x n b =
  if n < maxWord then
    if b then IntInf.orb (x, IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n)))
    else IntInf.andb (x, IntInf.notb (IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n))))
  else raise (Fail ("Bit index too large: " ^ IntInf.toString n));

fun shiftl x n =
  if n < maxWord then IntInf.<< (x, Word.fromLargeInt (IntInf.toLarge n))
  else raise (Fail ("Shift operand too large: " ^ IntInf.toString n));

fun shiftr x n =
  if n < maxWord then IntInf.~>> (x, Word.fromLargeInt (IntInf.toLarge n))
  else raise (Fail ("Shift operand too large: " ^ IntInf.toString n));

fun test_bit x n =
  if n < maxWord then IntInf.andb (x, IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n))) <> 0
  else raise (Fail ("Bit index too large: " ^ IntInf.toString n));

end; (*struct Bits_Integer*)\<close>
code_reserved SML Bits_Integer

code_printing code_module Bits_Integer \<rightharpoonup> (OCaml)
\<open>module Bits_Integer : sig
  val shiftl : Z.t -> Z.t -> Z.t
  val shiftr : Z.t -> Z.t -> Z.t
  val test_bit : Z.t -> Z.t -> bool
end = struct

(* We do not need an explicit range checks here,
   because Big_int.int_of_big_int raises Failure
   if the argument does not fit into an int. *)
let shiftl x n = Z.shift_left x (Z.to_int n);;

let shiftr x n = Z.shift_right x (Z.to_int n);;

let test_bit x n =  Z.testbit x (Z.to_int n);;

end;; (*struct Bits_Integer*)\<close>
code_reserved OCaml Bits_Integer

code_printing code_module Data_Bits \<rightharpoonup> (Haskell)
\<open>
module Data_Bits where {

import qualified Data.Bits;

{-
  The ...Bounded functions assume that the Integer argument for the shift
  or bit index fits into an Int, is non-negative and (for types of fixed bit width)
  less than bitSize
-}

infixl 7 .&.;
infixl 6 `xor`;
infixl 5 .|.;

(.&.) :: Data.Bits.Bits a => a -> a -> a;
(.&.) = (Data.Bits..&.);

xor :: Data.Bits.Bits a => a -> a -> a;
xor = Data.Bits.xor;

(.|.) :: Data.Bits.Bits a => a -> a -> a;
(.|.) = (Data.Bits..|.);

complement :: Data.Bits.Bits a => a -> a;
complement = Data.Bits.complement;

testBitUnbounded :: Data.Bits.Bits a => a -> Integer -> Bool;
testBitUnbounded x b
  | b <= toInteger (Prelude.maxBound :: Int) = Data.Bits.testBit x (fromInteger b)
  | otherwise = error ("Bit index too large: " ++ show b)
;

testBitBounded :: Data.Bits.Bits a => a -> Integer -> Bool;
testBitBounded x b = Data.Bits.testBit x (fromInteger b);

setBitUnbounded :: Data.Bits.Bits a => a -> Integer -> Bool -> a;
setBitUnbounded x n b
  | n <= toInteger (Prelude.maxBound :: Int) =
    if b then Data.Bits.setBit x (fromInteger n) else Data.Bits.clearBit x (fromInteger n)
  | otherwise = error ("Bit index too large: " ++ show n)
;

setBitBounded :: Data.Bits.Bits a => a -> Integer -> Bool -> a;
setBitBounded x n True = Data.Bits.setBit x (fromInteger n);
setBitBounded x n False = Data.Bits.clearBit x (fromInteger n);

shiftlUnbounded :: Data.Bits.Bits a => a -> Integer -> a;
shiftlUnbounded x n
  | n <= toInteger (Prelude.maxBound :: Int) = Data.Bits.shiftL x (fromInteger n)
  | otherwise = error ("Shift operand too large: " ++ show n)
;

shiftlBounded :: Data.Bits.Bits a => a -> Integer -> a;
shiftlBounded x n = Data.Bits.shiftL x (fromInteger n);

shiftrUnbounded :: Data.Bits.Bits a => a -> Integer -> a;
shiftrUnbounded x n
  | n <= toInteger (Prelude.maxBound :: Int) = Data.Bits.shiftR x (fromInteger n)
  | otherwise = error ("Shift operand too large: " ++ show n)
;

shiftrBounded :: (Ord a, Data.Bits.Bits a) => a -> Integer -> a;
shiftrBounded x n = Data.Bits.shiftR x (fromInteger n);

}\<close>

  and \<comment> \<open>@{theory HOL.Quickcheck_Narrowing} maps @{typ integer} to
            Haskell's Prelude.Int type instead of Integer. For compatibility
            with the Haskell target, we nevertheless provide bounded and
            unbounded functions.\<close>
  (Haskell_Quickcheck)
\<open>
module Data_Bits where {

import qualified Data.Bits;

{-
  The functions assume that the Int argument for the shift or bit index is
  non-negative and (for types of fixed bit width) less than bitSize
-}

infixl 7 .&.;
infixl 6 `xor`;
infixl 5 .|.;

(.&.) :: Data.Bits.Bits a => a -> a -> a;
(.&.) = (Data.Bits..&.);

xor :: Data.Bits.Bits a => a -> a -> a;
xor = Data.Bits.xor;

(.|.) :: Data.Bits.Bits a => a -> a -> a;
(.|.) = (Data.Bits..|.);

complement :: Data.Bits.Bits a => a -> a;
complement = Data.Bits.complement;

testBitUnbounded :: Data.Bits.Bits a => a -> Prelude.Int -> Bool;
testBitUnbounded = Data.Bits.testBit;

testBitBounded :: Data.Bits.Bits a => a -> Prelude.Int -> Bool;
testBitBounded = Data.Bits.testBit;

setBitUnbounded :: Data.Bits.Bits a => a -> Prelude.Int -> Bool -> a;
setBitUnbounded x n True = Data.Bits.setBit x n;
setBitUnbounded x n False = Data.Bits.clearBit x n;

setBitBounded :: Data.Bits.Bits a => a -> Prelude.Int -> Bool -> a;
setBitBounded x n True = Data.Bits.setBit x n;
setBitBounded x n False = Data.Bits.clearBit x n;

shiftlUnbounded :: Data.Bits.Bits a => a -> Prelude.Int -> a;
shiftlUnbounded = Data.Bits.shiftL;

shiftlBounded :: Data.Bits.Bits a => a -> Prelude.Int -> a;
shiftlBounded = Data.Bits.shiftL;

shiftrUnbounded :: Data.Bits.Bits a => a -> Prelude.Int -> a;
shiftrUnbounded = Data.Bits.shiftR;

shiftrBounded :: (Ord a, Data.Bits.Bits a) => a -> Prelude.Int -> a;
shiftrBounded = Data.Bits.shiftR;

}\<close>
code_reserved Haskell Data_Bits

code_printing code_module Bits_Integer \<rightharpoonup> (Scala)
\<open>object Bits_Integer {

def setBit(x: BigInt, n: BigInt, b: Boolean) : BigInt =
  if (n.isValidInt)
    if (b)
      x.setBit(n.toInt)
    else
      x.clearBit(n.toInt)
  else
    sys.error("Bit index too large: " + n.toString)

def shiftl(x: BigInt, n: BigInt) : BigInt =
  if (n.isValidInt)
    x << n.toInt
  else
    sys.error("Shift index too large: " + n.toString)

def shiftr(x: BigInt, n: BigInt) : BigInt =
  if (n.isValidInt)
    x << n.toInt
  else
    sys.error("Shift index too large: " + n.toString)

def testBit(x: BigInt, n: BigInt) : Boolean =
  if (n.isValidInt)
    x.testBit(n.toInt)
  else
    sys.error("Bit index too large: " + n.toString)

} /* object Bits_Integer */\<close>

code_printing
  constant "bitAND :: integer \<Rightarrow> integer \<Rightarrow> integer" \<rightharpoonup>
  (SML) "IntInf.andb ((_),/ (_))" and
  (OCaml) "Z.logand" and
  (Haskell) "((Data'_Bits..&.) :: Integer -> Integer -> Integer)" and
  (Haskell_Quickcheck) "((Data'_Bits..&.) :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
  (Scala) infixl 3 "&"
| constant "bitOR :: integer \<Rightarrow> integer \<Rightarrow> integer" \<rightharpoonup>
  (SML) "IntInf.orb ((_),/ (_))" and
  (OCaml) "Z.logor" and
  (Haskell) "((Data'_Bits..|.) :: Integer -> Integer -> Integer)" and
  (Haskell_Quickcheck) "((Data'_Bits..|.) :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
  (Scala) infixl 1 "|"
| constant "bitXOR :: integer \<Rightarrow> integer \<Rightarrow> integer" \<rightharpoonup>
  (SML) "IntInf.xorb ((_),/ (_))" and
  (OCaml) "Z.logxor" and
  (Haskell) "(Data'_Bits.xor :: Integer -> Integer -> Integer)" and
  (Haskell_Quickcheck) "(Data'_Bits.xor :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
  (Scala) infixl 2 "^"
| constant "bitNOT :: integer \<Rightarrow> integer" \<rightharpoonup>
  (SML) "IntInf.notb" and
  (OCaml) "Z.lognot" and
  (Haskell) "(Data'_Bits.complement :: Integer -> Integer)" and
  (Haskell_Quickcheck) "(Data'_Bits.complement :: Prelude.Int -> Prelude.Int)" and
  (Scala) "_.unary'_~"

code_printing constant bin_rest_integer \<rightharpoonup>
  (SML) "IntInf.div ((_), 2)" and
  (OCaml) "Z.shift'_right/ _/ 1" and
  (Haskell) "(Data'_Bits.shiftrUnbounded _ 1 :: Integer)" and
  (Haskell_Quickcheck) "(Data'_Bits.shiftrUnbounded _ 1 :: Prelude.Int)" and
  (Scala) "_ >> 1"

context
includes integer.lifting
begin

lemma bitNOT_integer_code [code]:
  fixes i :: integer shows
  "NOT i = - i - 1"
by transfer(simp add: int_not_def)

lemma bin_rest_integer_code [code nbe]:
  "bin_rest_integer i = i div 2"
by transfer(simp add: bin_rest_def)

lemma bin_last_integer_code [code]:
  "bin_last_integer i \<longleftrightarrow> i AND 1 \<noteq> 0"
by transfer(rule bin_last_conv_AND)

lemma bin_last_integer_nbe [code nbe]:
  "bin_last_integer i \<longleftrightarrow> i mod 2 \<noteq> 0"
by transfer(simp add: bin_last_def)

lemma bitval_bin_last_integer [code_unfold]:
  "of_bool (bin_last_integer i) = i AND 1"
by transfer(rule bitval_bin_last)

end

definition integer_test_bit :: "integer \<Rightarrow> integer \<Rightarrow> bool"
  where "integer_test_bit x n = (if n < 0 then undefined x n else x !! nat_of_integer n)"

lemma test_bit_integer_code [code]:
  "x !! n \<longleftrightarrow> integer_test_bit x (integer_of_nat n)"
by(simp add: integer_test_bit_def)

lemma integer_test_bit_code [code]:
  "integer_test_bit x (Code_Numeral.Neg n) = undefined x (Code_Numeral.Neg n)"
  "integer_test_bit 0 0 = False"
  "integer_test_bit 0 (Code_Numeral.Pos n) = False"
  "integer_test_bit (Code_Numeral.Pos num.One)      0 = True"
  "integer_test_bit (Code_Numeral.Pos (num.Bit0 n)) 0 = False"
  "integer_test_bit (Code_Numeral.Pos (num.Bit1 n)) 0 = True"
  "integer_test_bit (Code_Numeral.Pos num.One)      (Code_Numeral.Pos n') = False"
  "integer_test_bit (Code_Numeral.Pos (num.Bit0 n)) (Code_Numeral.Pos n') =
   integer_test_bit (Code_Numeral.Pos n) (Code_Numeral.sub n' num.One)"
  "integer_test_bit (Code_Numeral.Pos (num.Bit1 n)) (Code_Numeral.Pos n') =
   integer_test_bit (Code_Numeral.Pos n) (Code_Numeral.sub n' num.One)"
  "integer_test_bit (Code_Numeral.Neg num.One)      0 = True"
  "integer_test_bit (Code_Numeral.Neg (num.Bit0 n)) 0 = False"
  "integer_test_bit (Code_Numeral.Neg (num.Bit1 n)) 0 = True"
  "integer_test_bit (Code_Numeral.Neg num.One)      (Code_Numeral.Pos n') = True"
  "integer_test_bit (Code_Numeral.Neg (num.Bit0 n)) (Code_Numeral.Pos n') =
   integer_test_bit (Code_Numeral.Neg n) (Code_Numeral.sub n' num.One)"
  "integer_test_bit (Code_Numeral.Neg (num.Bit1 n)) (Code_Numeral.Pos n') =
   integer_test_bit (Code_Numeral.Neg (n + num.One)) (Code_Numeral.sub n' num.One)"
by(simp_all add: integer_test_bit_def test_bit_integer_def)

code_printing constant integer_test_bit \<rightharpoonup>
  (SML) "Bits'_Integer.test'_bit" and
  (OCaml) "Bits'_Integer.test'_bit" and
  (Haskell) "(Data'_Bits.testBitUnbounded :: Integer -> Integer -> Bool)" and
  (Haskell_Quickcheck) "(Data'_Bits.testBitUnbounded :: Prelude.Int -> Prelude.Int -> Bool)" and
  (Scala) "Bits'_Integer.testBit"

context
includes integer.lifting
begin

lemma lsb_integer_code [code]:
  fixes x :: integer shows
  "lsb x = x !! 0"
by transfer(simp add: lsb_int_def)

definition integer_set_bit :: "integer \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> integer"
where [code del]: "integer_set_bit x n b = (if n < 0 then undefined x n b else set_bit x (nat_of_integer n) b)"

lemma set_bit_integer_code [code]:
  "set_bit x i b = integer_set_bit x (integer_of_nat i) b"
by(simp add: integer_set_bit_def)

lemma set_bit_integer_conv_masks:
  fixes x :: integer shows
  "set_bit x i b = (if b then x OR (1 << i) else x AND NOT (1 << i))"
by transfer(simp add: int_set_bit_conv_ops)

end

code_printing constant integer_set_bit \<rightharpoonup>
  (SML) "Bits'_Integer.set'_bit" and
  (Haskell) "(Data'_Bits.setBitUnbounded :: Integer -> Integer -> Bool -> Integer)" and
  (Haskell_Quickcheck) "(Data'_Bits.setBitUnbounded :: Prelude.Int -> Prelude.Int -> Bool -> Prelude.Int)" and
  (Scala) "Bits'_Integer.setBit"

text \<open>
  OCaml.Big\_int does not have a method for changing an individual bit, so we emulate that with masks.
  We prefer an Isabelle implementation, because this then takes care of the signs for AND and OR.
\<close>
lemma integer_set_bit_code [code]:
  "integer_set_bit x n b =
  (if n < 0 then undefined x n b else
   if b then x OR (1 << nat_of_integer n)
   else x AND NOT (1 << nat_of_integer n))"
by(auto simp add: integer_set_bit_def set_bit_integer_conv_masks)

definition integer_shiftl :: "integer \<Rightarrow> integer \<Rightarrow> integer"
where [code del]: "integer_shiftl x n = (if n < 0 then undefined x n else x << nat_of_integer n)"

lemma shiftl_integer_code [code]:
  fixes x :: integer shows
  "x << n = integer_shiftl x (integer_of_nat n)"
by(auto simp add: integer_shiftl_def)

context
includes integer.lifting
begin

lemma shiftl_integer_conv_mult_pow2:
  fixes x :: integer shows
  "x << n = x * 2 ^ n"
by transfer(simp add: shiftl_int_def)

lemma integer_shiftl_code [code]:
  "integer_shiftl x (Code_Numeral.Neg n) = undefined x (Code_Numeral.Neg n)"
  "integer_shiftl x 0 = x"
  "integer_shiftl x (Code_Numeral.Pos n) = integer_shiftl (Code_Numeral.dup x) (Code_Numeral.sub n num.One)"
  "integer_shiftl 0 (Code_Numeral.Pos n) = 0"
  by (simp_all add: integer_shiftl_def shiftl_integer_def shiftl_int_def numeral_eq_Suc)
    (transfer, simp)

end

code_printing constant integer_shiftl \<rightharpoonup>
  (SML) "Bits'_Integer.shiftl" and
  (OCaml) "Bits'_Integer.shiftl" and
  (Haskell) "(Data'_Bits.shiftlUnbounded :: Integer -> Integer -> Integer)" and
  (Haskell_Quickcheck) "(Data'_Bits.shiftlUnbounded :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
  (Scala) "Bits'_Integer.shiftl"

definition integer_shiftr :: "integer \<Rightarrow> integer \<Rightarrow> integer"
where [code del]: "integer_shiftr x n = (if n < 0 then undefined x n else x >> nat_of_integer n)"

lemma shiftr_integer_conv_div_pow2:
  includes integer.lifting fixes x :: integer shows
  "x >> n = x div 2 ^ n"
by transfer(simp add: shiftr_int_def)

lemma shiftr_integer_code [code]:
  fixes x :: integer shows
  "x >> n = integer_shiftr x (integer_of_nat n)"
by(auto simp add: integer_shiftr_def)

code_printing constant integer_shiftr \<rightharpoonup>
  (SML) "Bits'_Integer.shiftr" and
  (OCaml) "Bits'_Integer.shiftr" and
  (Haskell) "(Data'_Bits.shiftrUnbounded :: Integer -> Integer -> Integer)" and
  (Haskell_Quickcheck) "(Data'_Bits.shiftrUnbounded :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
  (Scala) "Bits'_Integer.shiftr"

lemma integer_shiftr_code [code]:
  "integer_shiftr x (Code_Numeral.Neg n) = undefined x (Code_Numeral.Neg n)"
  "integer_shiftr x 0 = x"
  "integer_shiftr 0 (Code_Numeral.Pos n) = 0"
  "integer_shiftr (Code_Numeral.Pos num.One) (Code_Numeral.Pos n) = 0"
  "integer_shiftr (Code_Numeral.Pos (num.Bit0 n')) (Code_Numeral.Pos n) =
   integer_shiftr (Code_Numeral.Pos n') (Code_Numeral.sub n num.One)"
  "integer_shiftr (Code_Numeral.Pos (num.Bit1 n')) (Code_Numeral.Pos n) =
   integer_shiftr (Code_Numeral.Pos n') (Code_Numeral.sub n num.One)"
  "integer_shiftr (Code_Numeral.Neg num.One) (Code_Numeral.Pos n) = -1"
  "integer_shiftr (Code_Numeral.Neg (num.Bit0 n')) (Code_Numeral.Pos n) =
   integer_shiftr (Code_Numeral.Neg n') (Code_Numeral.sub n num.One)"
  "integer_shiftr (Code_Numeral.Neg (num.Bit1 n')) (Code_Numeral.Pos n) =
   integer_shiftr (Code_Numeral.Neg (Num.inc n')) (Code_Numeral.sub n num.One)"
by(simp_all add: integer_shiftr_def shiftr_integer_def)

context
includes integer.lifting
begin

lemma Bit_integer_code [code]:
  "Bit_integer i False = i << 1"
  "Bit_integer i True = (i << 1) + 1"
by(transfer, simp add: Bit_def shiftl_int_def)+

lemma msb_integer_code [code]:
  "msb (x :: integer) \<longleftrightarrow> x < 0"
by transfer(simp add: msb_int_def)

end

context
includes integer.lifting natural.lifting
begin

lemma bitAND_integer_unfold [code]:
  "x AND y =
   (if x = 0 then 0
    else if x = - 1 then y
    else Bit_integer (bin_rest_integer x AND bin_rest_integer y) (bin_last_integer x \<and> bin_last_integer y))"
  by transfer (fact bitAND_int.simps)

lemma bitOR_integer_unfold [code]:
  "x OR y =
   (if x = 0 then y
    else if x = - 1 then - 1
    else Bit_integer (bin_rest_integer x OR bin_rest_integer y) (bin_last_integer x \<or> bin_last_integer y))"
proof transfer
  fix x y :: int
  from int_or_Bits [of "bin_rest x" "bin_last x" "bin_rest y" "bin_last y"]
  have "(bin_rest x OR bin_rest y) BIT (bin_last x \<or> bin_last y) = x OR y"
    by simp
  then show "x OR y =
    (if x = 0 then y
     else if x = - 1 then - 1
     else Bit (bin_rest x OR bin_rest y) (bin_last x \<or> bin_last y))"
    by simp
qed

lemma bitXOR_integer_unfold [code]:
  "x XOR y =
   (if x = 0 then y
    else if x = - 1 then NOT y
    else Bit_integer (bin_rest_integer x XOR bin_rest_integer y)
      (\<not> bin_last_integer x \<longleftrightarrow> bin_last_integer y))"
proof transfer
  fix x y :: int
  from int_xor_Bits [of "bin_rest x" "bin_last x" "bin_rest y" "bin_last y"]
  have "(bin_rest x XOR bin_rest y) BIT
    ((bin_last x \<or> bin_last y) \<and> (bin_last x \<longrightarrow> \<not> bin_last y)) = x XOR y"
    by simp
  also have "(bin_last x \<or> bin_last y) \<and> (bin_last x \<longrightarrow> \<not> bin_last y) \<longleftrightarrow> (\<not> bin_last x \<longleftrightarrow> bin_last y)"
    by auto
  finally show "x XOR y =
   (if x = 0 then y
    else if x = - 1 then NOT y
    else Bit (bin_rest x XOR bin_rest y)
      (\<not> bin_last x \<longleftrightarrow> bin_last y))"
    by simp
qed

end

section \<open>Test code generator setup\<close>

definition bit_integer_test :: "bool" where
  "bit_integer_test =
  (([ -1 AND 3, 1 AND -3, 3 AND 5, -3 AND (- 5)
    , -3 OR 1, 1 OR -3, 3 OR 5, -3 OR (- 5)
    , NOT 1, NOT (- 3)
    , -1 XOR 3, 1 XOR (- 3), 3 XOR 5, -5 XOR (- 3)
    , set_bit 5 4 True, set_bit (- 5) 2 True, set_bit 5 0 False, set_bit (- 5) 1 False
    , 1 << 2, -1 << 3
    , 100 >> 3, -100 >> 3] :: integer list)
  = [ 3, 1, 1, -7
    , -3, -3, 7, -1
    , -2, 2
    , -4, -4, 6, 6
    , 21, -1, 4, -7
    , 4, -8
    , 12, -13] \<and>
    [ (5 :: integer) !! 4, (5 :: integer) !! 2, (-5 :: integer) !! 4, (-5 :: integer) !! 2
    , lsb (5 :: integer), lsb (4 :: integer), lsb (-1 :: integer), lsb (-2 :: integer),
      msb (5 :: integer), msb (0 :: integer), msb (-1 :: integer), msb (-2 :: integer)]
  = [ False, True, True, False,
      True, False, True, False,
      False, False, True, True])"

export_code bit_integer_test checking SML Haskell? Haskell_Quickcheck? OCaml? Scala

notepad begin
have bit_integer_test by eval
have bit_integer_test by normalization
have bit_integer_test by code_simp
end
ML_val \<open>val true = @{code bit_integer_test}\<close>

lemma "x AND y = x OR (y :: integer)"
quickcheck[random, expect=counterexample]
quickcheck[exhaustive, expect=counterexample]
oops

lemma "(x :: integer) AND x = x OR x"
quickcheck[narrowing, expect=no_counterexample]
oops

lemma "(f :: integer \<Rightarrow> unit) = g"
quickcheck[narrowing, size=3, expect=no_counterexample]
by(simp add: fun_eq_iff)

hide_const bit_integer_test
hide_fact bit_integer_test_def

end


theory DP_CRelSS
  imports "./DP_CRelVS" "./DP_CPredS"
begin
term int
term fold

locale dp_cong =
  fixes cmem :: "('param \<rightharpoonup> 'result) \<Rightarrow> bool"
begin
context
  includes lifting_syntax
begin
term 0 (**)

definition crel_ss :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('param \<rightharpoonup> 'result, 'a) state \<Rightarrow> ('param \<rightharpoonup> 'result, 'b) state \<Rightarrow> bool" where
  "crel_ss R s0 s1 \<equiv> (eq_onp cmem ===> rel_prod R (eq_onp cmem)) (runState s0) (runState s1)"

lemma crel_ss_intro:
  fixes R s0 s1
  assumes "\<And>M v0 M0 v1 M1. \<lbrakk>cmem M; runState s0 M = (v0,M0); runState s1 M = (v1,M1)\<rbrakk> \<Longrightarrow> R v0 v1 \<and> M0=M1 \<and> cmem M1"
  shows "crel_ss R s0 s1"
  unfolding crel_ss_def eq_onp_def rel_fun_def rel_prod_conv by (auto split: prod.split dest: assms)
term 0 (**)

lemma crel_ss_elim:
  fixes R s0 s1
  assumes "crel_ss R s0 s1" "cmem M"
  obtains v0 M0 v1 M1 where "runState s0 M = (v0, M0)" "runState s1 M = (v1, M1)" "R v0 v1" "M0=M1" "cmem M1"
  using assms unfolding crel_ss_def eq_onp_def rel_fun_def by (blast elim: rel_prod.cases)

term 0 (**)

lemma id\<^sub>T_cong[transfer_rule]:
  fixes R x y
  shows "(R ===> crel_ss R) return return"
  unfolding rel_fun_def return_def by (fastforce intro: crel_ss_intro)
thm id\<^sub>T_cong[THEN rel_funD]
term 0 (**)

lemma bind_cong[transfer_rule]:
  fixes R0 R1
  shows "(crel_ss R0 ===> (R0 ===> crel_ss R1) ===> crel_ss R1) (op \<bind>) (op \<bind>)"
  unfolding rel_fun_def bind_def by (fastforce intro!: crel_ss_intro elim!: crel_ss_elim)
thm bind_cong[THEN rel_funD, THEN rel_funD]
term 0 (**)

lemma app\<^sub>T_cong[transfer_rule]:
  fixes R0 R1
  shows "(crel_ss (R0 ===> crel_ss R1) ===> crel_ss R0 ===> crel_ss R1) (op .) (op .)"
  unfolding fun_app_lifted_def by transfer_prover
thm app\<^sub>T_cong[THEN rel_funD, THEN rel_funD]
term 0 (**)

lemma lift_33_cong[transfer_rule]:
  fixes R0 R1 R2
  shows "((R0 ===> R1 ===> R2) ===> crel_ss (R0 ===> crel_ss (R1 ===> crel_ss R2))) lift_33 lift_33"
  unfolding lift_33_def by transfer_prover
term 0 (**)

lemma Cons\<^sub>T_cong[transfer_rule]:
  fixes R
  shows "(crel_ss (R ===> crel_ss ((list_all2 R) ===> crel_ss (list_all2 R)))) Cons\<^sub>T Cons\<^sub>T"
  unfolding Cons\<^sub>T_def by transfer_prover

term 0 (**)
lemma map\<^sub>T_cong:
  assumes "crel_ss (list_all2 R0) xs\<^sub>T ys\<^sub>T"
  assumes "crel_ss (\<lambda>f g. crel_ss (list_all2 (\<lambda>x y. R0 x y \<longrightarrow> crel_ss R1 (f x) (g y))) xs\<^sub>T ys\<^sub>T) f\<^sub>T g\<^sub>T"
  shows "crel_ss (list_all2 R1) (map\<^sub>T . f\<^sub>T . xs\<^sub>T) (map\<^sub>T . g\<^sub>T . ys\<^sub>T)"
proof -
  {
    fix M assume "cmem M"
    have map\<^sub>T': "runState map\<^sub>T M = (\<lambda>f. \<langle>map\<^sub>T' f\<rangle>, M)"
      unfolding map\<^sub>T_def lift_3_def return_def by auto
    obtain f Mf g Mg where
      crel_xs_ys: "crel_ss (list_all2 (\<lambda>x y. R0 x y \<longrightarrow> crel_ss R1 (f x) (g y))) xs\<^sub>T ys\<^sub>T"
      and f_g: "runState f\<^sub>T M = (f, Mf)" "runState g\<^sub>T M = (g, Mg)" "Mf = Mg" "cmem Mg"
      using crel_ss_elim[OF assms(2) \<open>cmem M\<close>] .
    obtain xs Mxs ys Mys where
      crel_x_y: "list_all2 (\<lambda>x y. R0 x y \<longrightarrow> crel_ss R1 (f x) (g y)) xs ys"
      and xs_ys: "runState xs\<^sub>T Mf = (xs, Mxs)" "runState ys\<^sub>T Mg = (ys, Mys)" "Mxs = Mys" "cmem Mys"
      unfolding \<open>Mf = Mg\<close> using crel_ss_elim[OF crel_xs_ys \<open>cmem Mg\<close>] .
    have "list_all2 R0 xs ys"
      using assms(1) \<open>cmem Mg\<close> xs_ys \<open>Mf = Mg\<close> by (auto elim: crel_ss_elim)
    with crel_x_y have "list_all2 (\<lambda>x y. crel_ss R1 (f x) (g y)) xs ys"
      by (simp add: list_all2_conv_all_nth)
    hence *:"crel_ss (list_all2 R1) (map\<^sub>T' f xs) (map\<^sub>T' g ys)"
      proof (induction xs ys rule: list_all2_induct)
        case Nil
        then show ?case by (auto intro: crel_ss_intro simp: return_def)
      next
        case (Cons x xs y ys)
        show ?case unfolding map\<^sub>T'.simps supply [transfer_rule]=Cons by transfer_prover
      qed
    obtain mxs Mmxs mys Mmys where
      rel_mxs_mys: "list_all2 R1 mxs mys"
      and mxs_mys: "runState (map\<^sub>T' f xs) Mxs = (mxs, Mmxs)"
                   "runState (map\<^sub>T' g ys) Mys = (mys, Mmys)"
                   "Mmxs = Mmys" "cmem Mmys"
      unfolding \<open>Mxs = Mys\<close> using crel_ss_elim[OF * \<open>cmem Mys\<close>] .

    fix mxs' Mmxs' mys' Mmys'
    assume "runState (map\<^sub>T . f\<^sub>T . xs\<^sub>T) M = (mxs', Mmxs')" "runState (map\<^sub>T . g\<^sub>T . ys\<^sub>T) M = (mys', Mmys')"
    then have "mxs = mxs'" "mys = mys'" "Mmxs = Mmxs'" "Mmys = Mmys'"
      unfolding
        map\<^sub>T'[THEN fun_app_lifted_dest, OF f_g(1) runState_return, THEN fun_app_lifted_dest, OF xs_ys(1) mxs_mys(1)]
        map\<^sub>T'[THEN fun_app_lifted_dest, OF f_g(2) runState_return, THEN fun_app_lifted_dest, OF xs_ys(2) mxs_mys(2)]
      by auto
    hence "list_all2 R1 mxs' mys' \<and> Mmxs' = Mmys' \<and> cmem Mmys'"
      using rel_mxs_mys mxs_mys by auto
  } from this[THEN crel_ss_intro] show ?thesis .
qed

thm map\<^sub>T_cong

interpretation cpred: dp_pred cmem .

lemma crel_ss_cpred_s:
  "cpred.cpred_s (list_all (\<lambda>x. R x x)) xs\<^sub>T \<longleftrightarrow> crel_ss (list_all2 (\<lambda>x y. x = y \<longrightarrow> R x y)) xs\<^sub>T xs\<^sub>T"
  unfolding crel_ss_def cpred.cpred_s_def_alt
  unfolding rel_fun_def
  unfolding rel_prod_conv
  unfolding list.pred_rel eq_onp_def list_all2_conv_all_nth
  by auto

corollary wtf: "cpred.cpred_s (list_all (\<lambda>x. R (f x) (g x))) xs\<^sub>T \<longleftrightarrow> crel_ss (list_all2 (\<lambda>x y. x = y \<longrightarrow> R (f x) (g y))) xs\<^sub>T xs\<^sub>T"
  using crel_ss_cpred_s .

corollary map\<^sub>T_cong':
  assumes "crel_ss (op =) xs\<^sub>T xs\<^sub>T"
  assumes "crel_ss (\<lambda>f g. cpred.cpred_s (\<lambda>xs. \<forall>x\<in>set xs. crel_ss R1 (f x) (g x)) xs\<^sub>T) f\<^sub>T g\<^sub>T"
  shows "crel_ss (list_all2 R1) (map\<^sub>T . f\<^sub>T . xs\<^sub>T) (map\<^sub>T . g\<^sub>T . xs\<^sub>T)"
  using assms(1)[folded list.rel_eq] assms(2)
  unfolding list_all_iff[symmetric]
  unfolding wtf
  by (fact map\<^sub>T_cong)

    term 0 (**
fun test :: "nat \<Rightarrow> nat" where
  "test 0 = 0"
| "test (Suc n) = fold (op +) (map test [0..<Suc n]) 0"

(*
fun test\<^sub>T :: "nat \<Rightarrow>\<^sub>T nat" where
  "test\<^sub>T 0 = \<langle>0\<rangle>"
| "test\<^sub>T (Suc n) = fold\<^sub>T (map\<^sub>T . \<langle>test\<^sub>T\<rangle> . \<langle>[0..<Suc n]\<rangle>)"
*)

function test\<^sub>T :: "nat \<Rightarrow> ((nat \<rightharpoonup> nat) \<Rightarrow> (nat \<times> (nat \<rightharpoonup> nat)))" where
  "test\<^sub>T 0 M = runState (checkmem 0 \<langle>0\<rangle>) M"
| "test\<^sub>T (Suc n) M = runState (checkmem (Suc n) (fold\<^sub>T . plus\<^sub>T . (map\<^sub>T . \<langle>\<lambda>x. State (test\<^sub>T x)\<rangle> . \<langle>[0..<Suc n]\<rangle>) . \<langle>0\<rangle>)) M"
  by pat_completeness auto

    lemma ""
  *)

end
end

fun test :: "nat \<Rightarrow> nat" where
  "test 0 = 0"
| "test (Suc n) = fold (op +) (map test [0..<Suc n]) 0"

function (domintros) test\<^sub>T :: "nat \<Rightarrow> ((nat \<rightharpoonup> nat) \<Rightarrow> (nat \<times> (nat \<rightharpoonup> nat)))" where
  "test\<^sub>T 0 M = runState (checkmem 0 \<langle>0\<rangle>) M"
| "test\<^sub>T (Suc n) M = runState (checkmem (Suc n) (fold\<^sub>T . plus\<^sub>T . (map\<^sub>T . \<langle>\<lambda>x. State (test\<^sub>T x)\<rangle> . \<langle>[0..<Suc n]\<rangle>) . \<langle>0\<rangle>)) M"
  by pat_completeness auto

interpretation dp: dp_consistency test .

lemma
  fixes n M
  assumes "dp.cmem M"
  shows "test\<^sub>T_dom (n, M)"
  apply (induction n)
  subgoal using  test\<^sub>T.domintros(1)  by simp
  subgoal for m
    oops

lemma xx:
  fixes a P
  assumes "P 0"
  assumes "\<And>n. (\<And>x. x < Suc n \<Longrightarrow> P x) \<Longrightarrow> P (Suc n)"
  shows "\<And>x. x\<le>a \<Longrightarrow> P x"
  apply (induction a)
  subgoal using assms(1) by simp
  subgoal for a x
    apply (cases "x = Suc a")
    subgoal using assms(2) by simp
    subgoal by simp
    done
  done

corollary
  fixes a P
  assumes "P 0"
  assumes "\<And>n. (\<And>x. x < Suc n \<Longrightarrow> P x) \<Longrightarrow> P (Suc n)"
  shows "P a"
proof -
  from assms xx have "\<And>x. x\<le>a \<Longrightarrow> P x"
    by blast
  thus ?thesis by auto
qed

lemma "set_state s = fst ` (range (runState s))"
  find_theorems set_state
end


subsection "Heuristic Proofs"
theory HeuristicProofs
  imports VSQuad Heuristic OptimizationProofs
begin

lemma the_real_step_augment:
  assumes  steph : "\<And>xs var L F \<Gamma>. length xs = var \<Longrightarrow> (\<exists>x. eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>)) = (\<exists>x. eval (step var L F) (xs @ x # \<Gamma>))"
  shows "(\<exists>xs. (length xs = amount \<and> eval (list_disj (map(\<lambda>(L,F,n). ExN n (list_conj (map fm.Atom L @ F))) F))  (xs @ \<Gamma>))) = (eval (the_real_step_augment step amount F)  \<Gamma>)"
proof(induction amount arbitrary: F \<Gamma>)
  case 0
  then show ?case by auto
next
  case (Suc amount)
  have h1 : "\<And>F. (\<exists>x xs. length xs = amount \<and> F (xs @ x # \<Gamma>)) = (\<exists>xs. length xs = Suc amount \<and> F (xs @  \<Gamma>))"
    by (smt (z3) Suc_inject append.assoc append_Cons append_Nil2 append_eq_conv_conj length_append_singleton lessI self_append_conv2 take_hd_drop)

  have h2: "\<And>X x \<Gamma>. (\<exists>f\<in>set (dnf_modified X).
         eval (case f of (L, F, n) \<Rightarrow> ExN n (list_conj (map fm.Atom L @ F))) (x @ \<Gamma>)) = (\<exists>(al, fl, n)\<in>set (dnf_modified X). \<exists>L. length L = n \<and> (\<forall>a\<in>set al. aEval a (L @ (x @ \<Gamma>))) \<and> (\<forall>f\<in>set fl. eval f (L @ (x @ \<Gamma>))))"
    subgoal for X x \<Gamma>
      apply(rule bex_cong)
      apply simp_all
      subgoal for f
        apply(cases f)
        apply(auto simp add:eval_list_conj)
        by (metis Un_iff eval.simps(1) imageI)
      done
    done
  have h3 : "\<And>G. (\<exists>x. \<exists>f\<in>set F. G x f) = (\<exists>f\<in>set F. \<exists>x. G x f)"
    by blast
  show ?case
    apply simp
    unfolding Suc[symmetric]
    unfolding eval_list_disj
    apply simp
    unfolding h1[symmetric, of "\<lambda>x. (\<exists>f\<in>set F. eval (case f of (L, F, n) \<Rightarrow> ExN n (list_conj (map fm.Atom L @ F))) x)"]
    unfolding HOL.ex_comm[of "\<lambda>x xs. length xs = amount \<and> (\<exists>f\<in>set F. eval (case f of (L, F, n) \<Rightarrow> ExN n (list_conj (map fm.Atom L @ F))) (xs @ x # \<Gamma>))"]
    unfolding HOL.ex_comm[of "\<lambda>x xs. length xs = amount \<and>
        (\<exists>f\<in>set (dnf_modified (push_forall
                     (nnf (unpower 0
                            (groupQuantifiers
                              (clearQuantifiers(list_disj (map (\<lambda>(L, F, n). ExN n (step (n + amount) L F)) F)))))))).
            eval (case f of (L, F, n) \<Rightarrow> ExN n (list_conj (map fm.Atom L @ F))) (xs @ x # \<Gamma>))"]
    apply(rule ex_cong1)
    apply simp
    subgoal for xs
      unfolding h2
      unfolding dnf_modified_eval
      unfolding opt'
      unfolding eval_list_disj
      unfolding List.set_map Set.bex_simps(7)
      unfolding h3
      apply(cases "length xs = amount")
      apply (simp_all add:opt)
      apply(rule bex_cong)
      apply simp_all
      subgoal for f
        apply(cases f)
        apply simp
        subgoal for a b c
          unfolding HOL.ex_comm[of "\<lambda>x l. length l = c \<and> eval (list_conj (map fm.Atom a @ b)) (l @ xs @ x # \<Gamma>)"]
          unfolding HOL.ex_comm[of "\<lambda>x l. length l = c \<and> eval (step (c + amount) a b) (l @ xs @ x # \<Gamma>)"]
          apply(rule ex_cong1)
          apply simp
          subgoal for l
            apply(cases "length l = c")
            apply simp_all
            using steph[of "l @ xs" "c + amount" a b \<Gamma>]
            by simp
          done
        done
      done
    done
qed

lemma step_converter :
  assumes  steph : "\<And>xs var L F \<Gamma>. length xs = var \<Longrightarrow> (\<exists>x. eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>)) = (\<exists>x. eval (step var L F) (xs @ x # \<Gamma>))"
  shows "\<And>var L F \<Gamma>. (\<exists>xs. length xs = var + 1 \<and> eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)) =
      (\<exists>xs. (length xs = (var + 1)) \<and> eval (step var L F) (xs @ \<Gamma>))"
proof safe
  fix var L F \<Gamma> xs
  assume h : "length xs = var + 1"
    "eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)"
  have h1 : "length (take var xs) = var" using h by auto
  have h2 : "(\<exists>x. eval (step var L F) (take var xs @ x # \<Gamma>))"
    using h steph[OF h1]
    by (metis Cons_nth_drop_Suc One_nat_def add.right_neutral add_Suc_right append.assoc append_Cons append_Nil append_take_drop_id drop_all lessI order_refl)
  then obtain x where h3: "eval (step var L F) (take var xs @ x # \<Gamma>)" by auto
  show "\<exists>xs. length xs = var + 1 \<and> eval (step var L F) (xs @ \<Gamma>)"
    apply(rule exI[where x="take var xs @[x]"])
    apply (auto)
    using h(1) apply simp
    using h3 by simp
next
  fix var L F \<Gamma> xs
  assume h: "length xs = var + 1"
    "eval (step var L F) (xs @ \<Gamma>)"
  have h1 : "length (take var xs) = var" using h by auto
  have h2 : "(\<exists>x. eval (list_conj (map fm.Atom L @ F)) (take var xs @ x # \<Gamma>))"
    using h steph[OF h1]
    by (metis Cons_nth_drop_Suc One_nat_def add.right_neutral add_Suc_right append.assoc append_Cons append_Nil append_take_drop_id drop_all lessI order_refl)
  then obtain x where h3: "eval (list_conj (map fm.Atom L @ F)) (take var xs @ x # \<Gamma>)" by auto
  show "\<exists>xs. length xs = var + 1 \<and> eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)"
    apply(rule exI[where x="take var xs @[x]"])
    apply (auto)
    using h(1) apply simp
    using h3 by simp
qed

lemma step_augmenter_eval :
  assumes  steph : "\<And>xs var L F \<Gamma>. length xs = var \<Longrightarrow> (\<exists>x. eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>)) = (\<exists>x. eval (step var L F) (xs @ x # \<Gamma>))"
  assumes heuristic: "\<And>n var L F. heuristic n L F = var \<Longrightarrow> var \<le> n"
  shows "\<And>var amount L F \<Gamma>.
      amount \<le> var + 1 \<Longrightarrow>
      (\<exists>xs. length xs = var + 1 \<and> eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)) =
      (\<exists>xs. (length xs = (var + 1)) \<and> eval (step_augment step heuristic amount var L F) (xs @ \<Gamma>))"
  subgoal for var amount L F \<Gamma>
  proof(induction var arbitrary: L F \<Gamma> amount)
    case 0
    then have "amount = 0 \<or> amount = Suc 0" by auto
    then show ?case apply simp using steph[of "[]" 0 L F \<Gamma>] apply auto
      apply (metis append_Cons length_Cons list.size(3) self_append_conv2)
      apply (metis append_Cons length_Cons list.size(3) self_append_conv2)
      apply (metis Suc_length_conv append_Cons length_0_conv self_append_conv2)
      by (metis Suc_length_conv append_Cons append_self_conv2 length_0_conv)
  next
    case (Suc var)
    define heu where "heu = heuristic (Suc var) L F"
    have heurange : "heu \<le> Suc var" unfolding heu_def
      by (simp add: heuristic)
    have lessThan1 : "1 \<le> var + 1" by auto

    {
      fix amount
      assume amountLessThan: "amount \<le> var + 1"
      have "(\<exists>xs. length xs = Suc (Suc var) \<and>
          eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)) = (\<exists>xs. length xs = Suc (Suc var) \<and>
          eval
           (step (Suc var) (map (swap_atom (Suc var) heu) L)
             (map (swap_fm (Suc var) heu) F))
           (xs @ \<Gamma>))"
      proof(safe)
        fix xs
        assume h: "length (xs::real list) = Suc (Suc var)" "eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)"
        then have length : "length (take (Suc var) (swap_list (Suc var) heu xs)) = Suc var" by auto
        have take: "(take (Suc var) (swap_list (Suc var) heu xs) @ xs ! heu # \<Gamma>) = (swap_list (Suc var) heu (xs @ \<Gamma>)) " using h(1)
          unfolding swap_list.simps
          by (smt (verit, ccfv_threshold) Cons_nth_drop_Suc append.right_neutral append_Nil2 append_assoc append_eq_conv_conj append_self_conv2 append_take_drop_id drop0 heu_def heurange le_imp_less_Suc length_greater_0_conv length_list_update lessI list.sel(1) list.sel(3) list.simps(3) list.size(3) list_update_append nth_Cons_0 nth_append nth_append_length nth_list_update_eq take0 take_hd_drop)
        have length1 : "Suc var < length (xs @ \<Gamma>)" using h by auto
        have length2 : "heu < length (xs @ \<Gamma>)" using h heurange by auto
        have h1: "(\<exists>x. eval
        (step (Suc var) (map (swap_atom (Suc var) heu) L)
          (map (swap_fm (Suc var) heu) F))
        (take (Suc var) (swap_list (Suc var) heu xs) @ x # \<Gamma>))"
          unfolding steph[OF length, symmetric]
          apply(rule exI[where x="nth xs heu"])
          using h unfolding eval_list_conj take apply (auto simp del:swap_list.simps)
          unfolding swap_fm[OF length1 length2,symmetric] swap_atom[OF length1 length2,symmetric]
          by (meson UnCI eval.simps(1) imageI)+
        then obtain x where heval: "eval
       (step (Suc var) (map (swap_atom (Suc var) heu) L)
         (map (swap_fm (Suc var) heu) F))
       (take (Suc var) (swap_list (Suc var) heu xs) @ x # \<Gamma>)" by auto
        show "\<exists>xs. length xs = Suc (Suc var) \<and>
               eval
                (step (Suc var) (map (swap_atom (Suc var) heu) L)
                  (map (swap_fm (Suc var) heu) F))
                (xs @ \<Gamma>)"
          apply(rule exI[where x="take (Suc var) (swap_list (Suc var) heu xs) @ [x]"])
          apply auto
          using h apply simp
          using heval by auto
      next
        fix xs
        assume h : "length xs = Suc (Suc var)""
          eval
           (step (Suc var) (map (swap_atom (Suc var) heu) L)
             (map (swap_fm (Suc var) heu) F))
           (xs @ \<Gamma>)"
        define choppedXS where "choppedXS = take (Suc var) xs"
        then have length : "length choppedXS = Suc var"
          using h(1) by force
        have "(\<exists>x. eval (step (Suc var) (map (swap_atom (Suc var) heu) L) (map (swap_fm (Suc var) heu) F)) (choppedXS @ x # \<Gamma>))"
          using h(2) choppedXS_def
          by (metis append.assoc append_Cons append_Nil2 append_eq_conv_conj h(1) lessI take_hd_drop)
        then have "\<exists>x. (\<forall>l\<in> set L. aEval (swap_atom (Suc var) heu l) (choppedXS@x#\<Gamma>)) \<and> (\<forall>f\<in> set F. eval (swap_fm (Suc var) heu f) (choppedXS@x#\<Gamma>))"
          unfolding steph[symmetric, OF length, of "(map (swap_atom (Suc var) heu) L)" "(map (swap_fm (Suc var) heu) F)" \<Gamma>] eval_list_conj apply auto
          by (metis Un_iff eval.simps(1) imageI)
        then obtain x where x : "(\<forall>l\<in>set L. aEval (swap_atom (Suc var) heu l) (choppedXS @ x # \<Gamma>)) \<and>
      (\<forall>f\<in>set F. eval (swap_fm (Suc var) heu f) (choppedXS @ x # \<Gamma>))" by auto
        have length1 : "Suc var < length (swap_list (Suc var) heu (choppedXS @ [x]) @ \<Gamma>)"
          by (simp add: length)
        have length2 : "heu < length (swap_list (Suc var) heu (choppedXS @ [x]) @ \<Gamma>)"
          using \<open>Suc var < length (swap_list (Suc var) heu (choppedXS @ [x]) @ \<Gamma>)\<close> heurange by linarith
        have swapswap : "(swap_list (Suc var) heu (swap_list (Suc var) heu (choppedXS @ [x]) @ \<Gamma>)) = (choppedXS @ [x]) @ \<Gamma>" apply auto
          by (smt (z3) Cons_nth_drop_Suc append_eq_conv_conj append_same_eq heurange id_take_nth_drop le_neq_implies_less length length1 length_append_singleton lessI list.sel(1) list_update_append1 list_update_length list_update_swap nth_append nth_append_length nth_list_update_neq swap_list.simps take_hd_drop take_update_swap upd_conv_take_nth_drop)
        show "\<exists>xs. length xs = Suc (Suc var) \<and>
               eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)"
          apply(rule exI[where x="swap_list (Suc var) heu (choppedXS @ [x])"])
          apply(auto simp add: eval_list_conj simp del: swap_list.simps)
          apply(simp add :length)
          unfolding swap_atom[OF length1 length2] swap_fm[OF length1 length2] swapswap
          using x by auto
      qed
      also have "... = (\<exists>xs. length xs = Suc (Suc var) \<and>
          (\<exists>f\<in>set (dnf ((push_forall \<circ> nnf \<circ> unpower 0 o groupQuantifiers o clearQuantifiers)(step (Suc var) (map (swap_atom (Suc var) heu) L)
                          (map (swap_fm (Suc var) heu) F)))).
              eval (case f of (x, xa) \<Rightarrow> step_augment step heuristic amount var x xa)
               (xs @ \<Gamma>)))"
        unfolding opt[of "(step (Suc var) (map (swap_atom (Suc var) heu) L) (map (swap_fm (Suc var) heu) F))", symmetric]
        unfolding dnf_eval[of "(push_forall \<circ> nnf \<circ> unpower 0 o groupQuantifiers o clearQuantifiers)(step (Suc var) (map (swap_atom (Suc var) heu) L)
             (map (swap_fm (Suc var) heu) F))", symmetric]
      proof(safe)
        fix xs a b
        assume h: "length xs = Suc (Suc var)""
       (a, b)
       \<in> set (dnf ((push_forall \<circ> nnf \<circ> unpower 0 o groupQuantifiers o clearQuantifiers)(step (Suc var) (map (swap_atom (Suc var) heu) L)
                     (map (swap_fm (Suc var) heu) F)))) ""
       \<forall>a\<in>set a. aEval a (xs @ \<Gamma>) ""
       \<forall>f\<in>set b. eval f (xs @ \<Gamma>)"
        have "(\<exists>xs'. length xs' = var + 1 \<and>
        eval (step_augment step heuristic amount var a b) (xs' @ xs ! Suc var # \<Gamma>))"
          unfolding Suc(1)[of amount a b "nth xs (Suc var)#\<Gamma>", OF amountLessThan, symmetric]
          apply(rule exI[where x="take (Suc var) xs"])
          using h(1) h(3-4) apply(auto simp add: eval_list_conj)
          apply (metis Cons_nth_drop_Suc append_Cons append_eq_append_conv2 append_eq_conv_conj append_take_drop_id lessI)
          by (metis Cons_nth_drop_Suc append_Cons append_eq_append_conv2 append_eq_conv_conj append_take_drop_id lessI)
        then obtain xs' where xs': "length xs' = var + 1" "eval (step_augment step heuristic amount var a b) (xs' @ xs ! Suc var # \<Gamma>)"
          by auto

        show "\<exists>xs. length xs = Suc (Suc var) \<and>
            (\<exists>f\<in>set (dnf ((push_forall \<circ> nnf \<circ> unpower 0 o groupQuantifiers o clearQuantifiers)(step (Suc var) (map (swap_atom (Suc var) heu) L)
                            (map (swap_fm (Suc var) heu) F)))).
                eval (case f of (x, xa) \<Rightarrow> step_augment step heuristic amount var x xa)
                 (xs @ \<Gamma>))"
          apply(rule exI[where x="xs' @[ xs ! Suc var]"])
          apply auto
          using xs' apply simp
          apply(rule bexI[where x="(a,b)"])
          using xs' h apply(cases amount) apply (simp_all add:eval_list_conj)
          using h(2) by auto
      next
        fix xs a b
        assume h: "length xs = Suc (Suc var) ""
       (a, b)
       \<in> set (dnf ((push_forall \<circ> nnf \<circ> unpower 0 o groupQuantifiers o clearQuantifiers)(step (Suc var) (map (swap_atom (Suc var) heu) L)
                     (map (swap_fm (Suc var) heu) F)))) ""
       eval (step_augment step heuristic amount var a b) (xs @ \<Gamma>)"
        have "(\<exists>xs'. length xs' = var + 1 \<and>
        eval (list_conj (map fm.Atom a @ b)) (xs' @ xs ! Suc var # \<Gamma>))"
          unfolding Suc(1)[of amount a b "nth xs (Suc var)#\<Gamma>", OF amountLessThan]
          apply(rule exI[where x="take (Suc var) xs"])
          using h(1) h(3) apply auto
          by (metis Cons_nth_drop_Suc append.right_neutral append_Cons append_assoc append_eq_conv_conj append_self_conv2 append_take_drop_id lessI)
        then obtain xs' where xs': "length xs' = var + 1" " eval (list_conj (map fm.Atom a @ b)) (xs' @ xs ! Suc var # \<Gamma>)"
          by auto
        show "\<exists>xs. length xs = Suc (Suc var) \<and>
            (\<exists>(al, fl)
              \<in>set (dnf ((push_forall \<circ> nnf \<circ> unpower 0 o groupQuantifiers o clearQuantifiers)(step (Suc var) (map (swap_atom (Suc var) heu) L)
                           (map (swap_fm (Suc var) heu) F)))).
                (\<forall>a\<in>set al. aEval a (xs @ \<Gamma>)) \<and>
                (\<forall>f\<in>set fl. eval f (xs @ \<Gamma>)))"
          apply(rule exI[where x="xs' @[ xs ! Suc var]"])
          apply auto
          using xs' apply simp
          apply(rule bexI[where x="(a,b)"])
          using xs' h apply (simp_all add: eval_list_conj)
        proof -
          assume "\<forall>f\<in>fm.Atom ` set a \<union> set b. eval f (xs' @ xs ! Suc var # \<Gamma>)"
          then have "\<forall>f. f \<in> fm.Atom ` set a \<union> set b \<longrightarrow> eval f (xs' @ xs ! Suc var # \<Gamma>)"
            by meson
          then have f1: "v \<notin> set a \<or> eval (fm.Atom v) (xs' @ xs ! Suc var # \<Gamma>)" for v
            by blast
          obtain aa :: atom where
            "(\<exists>v0. v0 \<in> set a \<and> \<not> eval (fm.Atom v0) (xs' @ xs ! Suc var # \<Gamma>)) = (aa \<in> set a \<and> \<not> eval (fm.Atom aa) (xs' @ xs ! Suc var # \<Gamma>))"
            by blast
          then show "\<forall>a\<in>set a. aEval a (xs' @ xs ! Suc var # \<Gamma>)"
            using f1 eval.simps(1) by auto
        qed

      qed
      finally have "(\<exists>xs. length xs = Suc (Suc var) \<and> eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)) =
  (\<exists>xs. length xs = Suc (Suc var) \<and>
        (\<exists>f\<in>set (dnf ((push_forall \<circ> nnf \<circ> unpower 0 o groupQuantifiers o clearQuantifiers) (step (Suc var) (map (swap_atom (Suc var) heu) L) (map (swap_fm (Suc var) heu) F)))).
            eval (case f of (x, xa) \<Rightarrow> step_augment step heuristic amount var x xa) (xs @ \<Gamma>)))"
        by auto
    }then show ?case apply(cases amount) using Suc(2)  by (simp_all add:eval_list_disj heu_def[symmetric])
  qed
  done

lemma qe_eq_repeat_eval_augment : "amount \<le> var+1 \<Longrightarrow>
      (\<exists>xs. (length xs = var + 1) \<and> eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)) =
      (\<exists>xs. (length xs = var + 1) \<and> eval (step_augment qe_eq_repeat IdentityHeuristic amount var L F) (xs @ \<Gamma>))"
  apply(rule step_augmenter_eval[of qe_eq_repeat IdentityHeuristic amount var L F \<Gamma>])
  using qe_eq_repeat_eval apply blast by auto

lemma qe_eq_repeat_eval' : "
      (\<exists>xs. (length xs = var + 1) \<and> eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)) =
      (\<exists>xs. (length xs = var + 1) \<and> eval (qe_eq_repeat var L F) (xs @ \<Gamma>))"
  apply(rule step_converter[of qe_eq_repeat var L F \<Gamma>])
  using qe_eq_repeat_eval by blast

lemma gen_qe_eval_augment : "amount \<le> var+1 \<Longrightarrow>
      (\<exists>xs. (length xs = var + 1) \<and> eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)) =
      (\<exists>xs. (length xs = var + 1) \<and> eval (step_augment gen_qe IdentityHeuristic amount var L F) (xs @ \<Gamma>))"
  apply(rule step_augmenter_eval[of gen_qe IdentityHeuristic amount var L F \<Gamma>])
  using gen_qe_eval apply blast by auto

lemma gen_qe_eval' : "
      (\<exists>xs. (length xs = var + 1) \<and> eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)) =
      (\<exists>xs. (length xs = var + 1) \<and> eval (gen_qe var L F) (xs @ \<Gamma>))"
  apply(rule step_converter[of gen_qe var L F \<Gamma>])
  using gen_qe_eval by blast

lemma luckyFind_eval_augment : "amount \<le> var+1 \<Longrightarrow>
      (\<exists>xs. (length xs = var + 1) \<and> eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)) =
      (\<exists>xs. (length xs = var + 1) \<and> eval (step_augment luckyFind' IdentityHeuristic amount var L F) (xs @ \<Gamma>))"
  apply(rule step_augmenter_eval[of luckyFind' IdentityHeuristic amount var L F \<Gamma>])
  using luckyFind'_eval apply blast by auto

lemma luckyFind_eval' : "
      (\<exists>xs. (length xs = var + 1) \<and> eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)) =
      (\<exists>xs. (length xs = var + 1) \<and> eval (luckyFind' var L F) (xs @ \<Gamma>))"
  apply(rule step_converter[of luckyFind' var L F \<Gamma>])
  using luckyFind'_eval by blast

lemma luckiestFind_eval' : "
      (\<exists>xs. (length xs = var + 1) \<and> eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)) =
      (\<exists>xs. (length xs = var + 1) \<and> eval (luckiestFind var L F) (xs @ \<Gamma>))"
  apply(rule step_converter[of luckiestFind var L F \<Gamma>])
  using luckiestFind_eval by blast

lemma sortedListMember : "sorted_list_of_fset b = var # list \<Longrightarrow> fmember var b "
  by (metis fset_of_list_elem list.set_intros(1) sorted_list_of_fset_simps(2))

lemma rangeHeuristic :
  assumes "heuristicPicker n L F = Some (var, step)"
  shows "var\<le>n"
proof(cases "aquireData n L")
  case (fields a b c)
  then show ?thesis using assms apply(simp_all del: aquireData.simps getBest.simps)
    apply(cases "getBest a L")
    apply(simp_all del: aquireData.simps getBest.simps)
    apply(cases F) apply(simp_all del: aquireData.simps getBest.simps)
    apply(cases "getBest c L") apply(simp_all del: aquireData.simps getBest.simps)
    apply(cases "getBest b L")apply(simp_all del: aquireData.simps getBest.simps)
    apply (metis not_le_imp_less option.distinct(1) option.inject prod.inject)
    apply (metis not_le_imp_less option.distinct(1) option.inject prod.inject)
    apply(cases "getBest b L")apply(simp_all del: aquireData.simps getBest.simps)
    by (metis not_le_imp_less option.distinct(1) option.inject prod.inject)+
qed

lemma pickedOneOfThem :
  assumes "heuristicPicker n L F = Some (var, step)"
  shows "step = qe_eq_repeat \<or> step = gen_qe \<or> step = luckyFind'"
  using assms
  apply(cases "aquireData n L")
  subgoal for l e g
    using assms apply(simp_all del: aquireData.simps getBest.simps)
    apply(cases "getBest l L")
    apply(simp_all del: aquireData.simps getBest.simps)
    apply(cases F) apply(simp_all del: aquireData.simps getBest.simps)
    apply(cases "getBest g L") apply(simp_all del: aquireData.simps getBest.simps)
    apply(cases "getBest e L")apply(simp_all del: aquireData.simps getBest.simps)
    apply (metis option.distinct(1) option.inject prod.inject)
    apply (metis option.distinct(1) option.inject prod.inject)
    apply(cases "getBest e L")apply(simp_all del: aquireData.simps getBest.simps)
    by (metis  option.distinct(1) option.inject prod.inject)+
  done

lemma superPicker_eval :
  "amount\<le> var+1 \<Longrightarrow> (\<exists>xs. length xs = var + 1 \<and> eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)) =
      (\<exists>xs. (length xs = (var + 1)) \<and> eval (superPicker amount var L F) (xs @ \<Gamma>))"
proof(induction var arbitrary : L F \<Gamma> amount)
  case 0
  then show ?case apply(simp del:heuristicPicker.simps)
    apply(cases "heuristicPicker 0 L F") apply(cases amount)
    apply (simp_all del:heuristicPicker.simps)
    subgoal for a
      apply(cases a)
      apply (simp_all del:heuristicPicker.simps)
      subgoal for var step
        apply(cases var) apply(cases amount)
        apply(simp_all del:heuristicPicker.simps)
      proof-
        assume h: "heuristicPicker 0 L F = Some (0, step)"
        show "(\<exists>xs. length xs = Suc 0 \<and> eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)) =
    (\<exists>xs. length xs = Suc 0 \<and> eval (step 0 L F) (xs @ \<Gamma>)) "
          using pickedOneOfThem[OF h]
          using  qe_eq_repeat_eval'[of 0 L F \<Gamma>] gen_qe_eval'[of 0 L F \<Gamma>] luckyFind_eval'[of 0 L F \<Gamma>]
          by auto
      next
        show "\<And>nat. amount \<le> Suc 0 \<Longrightarrow>
           heuristicPicker 0 L F = Some (Suc nat, step) \<Longrightarrow>
           a = (Suc nat, step) \<Longrightarrow>
           var = Suc nat \<Longrightarrow>
           (\<exists>xs. length xs = Suc 0 \<and> eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)) =
           (\<exists>xs. length xs = Suc 0 \<and> eval (superPicker amount 0 L F) (xs @ \<Gamma>)) "
          apply(cases amount) by(simp_all del:heuristicPicker.simps)
      qed
      done
    done
next
  case (Suc i)
  then show ?case apply(cases "heuristicPicker (Suc i) L F") apply(cases amount)
    apply(simp_all del:heuristicPicker.simps)
    subgoal for a
      apply(cases a)
      apply(simp_all del:heuristicPicker.simps) apply(cases amount) apply simp
      apply(cases amount) apply(simp_all del:heuristicPicker.simps)
      subgoal for var step amountPred amountPred'
      proof-
        assume amountPred : "amountPred \<le> Suc i"
        assume ih: "(\<And>amount L F \<Gamma>.
        amount \<le> Suc i \<Longrightarrow>
        (\<exists>xs. length xs = Suc i \<and> eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)) =
        (\<exists>xs. length xs = Suc i \<and> eval (superPicker amount i L F) (xs @ \<Gamma>)))"
        assume h0 : "heuristicPicker (Suc i) L F = Some (var, step)"
        have h1: "\<And>xs X F. (\<exists>f\<in>set (map (\<lambda>(x, y). F x y)
                     (dnf X)).
              eval f (xs)) = (\<exists>(al,fl)\<in>set(dnf X).
              eval (F al fl) (xs))"
          subgoal for xs X F
            apply auto
            subgoal for a b
              apply(rule bexI[where x="(a,b)"])
              apply simp_all
              done
            done
          done
        have eval_map : "\<And>al fl xs \<Gamma>.(\<forall>f\<in>set (map fm.Atom al @ fl). eval f (xs @ \<Gamma>)) = ((\<forall>a\<in>set al. aEval a (xs @ \<Gamma>)) \<and> (\<forall>f\<in>set fl. eval f (xs @ \<Gamma>)))"
          apply auto
          by (meson Un_iff eval.simps(1) imageI)
        have rearangeExists :  "\<And> X F.((\<exists>xs. length xs = Suc (Suc i) \<and>
               (\<exists>(al, fl)\<in>set (dnf X). F al fl xs)) =
            (\<exists>(al,fl)\<in>set (dnf X).(\<exists>xs. length xs = Suc (Suc i) \<and>
                F al fl xs)))"
          by blast
        have dropTheEnd : "\<And>F \<Gamma>.(\<exists>xs. length xs = Suc (Suc i) \<and> F (xs @ \<Gamma>)) = (\<exists>x. (\<exists>xs. length xs = i+1 \<and> F (xs @ x#\<Gamma>)))"
          apply(safe)
          subgoal for F \<Gamma> xs
            apply(rule exI[where x="nth xs (i+1)"])
            apply(rule exI[where x="take (i+1) xs"]) apply auto
            by (metis Cons_nth_drop_Suc append.right_neutral append_Cons append_assoc append_eq_conv_conj append_self_conv2 append_take_drop_id lessI)
          subgoal for F \<Gamma> x xs
            apply(rule exI[where x="xs@[x]"])
            by auto
          done
        have h2 : "\<And>X \<Gamma> amount. amount\<le> Suc i \<Longrightarrow>((\<exists>xs. length xs = Suc (Suc i) \<and>
          (\<exists>(al, fl)\<in>set (dnf X).
              eval (superPicker amount i al fl) (xs @ \<Gamma>)))
          = (\<exists>xs. length xs = Suc (Suc i) \<and>
          (\<exists>(al, fl)\<in>set (dnf X).
              (\<forall>a\<in>set al. aEval a (xs@\<Gamma>))\<and>(\<forall>f\<in>set fl. eval f (xs@\<Gamma>)))))"
          subgoal for X \<Gamma> amount
            unfolding rearangeExists
            apply(rule bex_cong)
            apply simp
            subgoal for x
              apply (cases x)
              apply simp
              subgoal for al fl
                unfolding dropTheEnd
                unfolding dropTheEnd[of"\<lambda>xs. (\<forall>a\<in>set al. aEval a xs) \<and> (\<forall>f\<in>set fl. eval f xs)"]
                apply simp
                unfolding ih[of amount al fl "_#\<Gamma>",symmetric]
                unfolding eval_list_conj
                apply(rule ex_cong1)
                subgoal for xa
                  apply(rule ex_cong1)
                  subgoal for xab apply auto
                    by (meson Un_iff eval.simps(1) image_eqI)
                  done
                done
              done
            done
          done
        have h3 : "\<And>L F. (\<exists>xs. length xs = Suc (Suc i) \<and> eval (step (Suc i) L F) (xs@\<Gamma>)) = (\<exists>xs. length xs = Suc (Suc i) \<and> eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>))"
          subgoal for L F
            using pickedOneOfThem[OF h0]
            using  qe_eq_repeat_eval'[of "Suc i" L F \<Gamma>] gen_qe_eval'[of "Suc i" L F \<Gamma>] luckyFind_eval'[of "Suc i" L F \<Gamma>]
            by auto
          done
        have heurange : "var\<le> Suc i" using rangeHeuristic[OF h0] by auto
        show ?thesis
          unfolding eval_list_disj
          unfolding h1
          unfolding h2[OF amountPred]
          unfolding dnf_eval
          unfolding opt'
          unfolding h3
        proof(safe)
          fix xs
          assume h : "length xs = Suc (Suc i)" "eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)"
          have h3 : "var < length (xs @ \<Gamma>)"  using h heurange by auto
          have h1: "(swap_list (Suc i) var (xs @ \<Gamma>)) = (swap_list (Suc i) var xs @ \<Gamma>)"
            using h(1) heurange apply simp
            by (simp add: list_update_append nth_append)
          have h2 : "Suc i < length (xs @ \<Gamma>)" using h by auto

          show "\<exists>xs. length xs = Suc (Suc i) \<and>
               eval (list_conj (map fm.Atom (map (swap_atom (Suc i) var) L) @ map (swap_fm (Suc i) var) F)) (xs @ \<Gamma>)"
            apply(rule exI[where x="swap_list (Suc i) var xs"])
            apply(auto simp add:h eval_list_conj simp del:swap_list.simps)
            apply(simp add: h)
            using swap_fm[OF h2 h3] swap_atom[OF h2 h3] unfolding h1
            using h(2) unfolding eval_list_conj
            apply auto

            by (meson Un_iff eval.simps(1) imageI)
        next
          fix xs
          assume h : "length xs = Suc (Suc i)""eval (list_conj (map fm.Atom (map (swap_atom (Suc i) var) L) @ map (swap_fm (Suc i) var) F)) (xs @ \<Gamma>)"
          have h3 : "var < length (swap_list (Suc i) var xs @ \<Gamma>)"  using h heurange by auto
          have h1: "swap_list (Suc i) var (swap_list (Suc i) var xs @ \<Gamma>) = xs @ \<Gamma>"
            apply auto
            using h(1) heurange
            by (smt (z3) le_imp_less_Suc length_list_update lessI list_update_append list_update_id list_update_overwrite list_update_swap nth_append nth_list_update_eq)
          have h2 : "Suc i < length (swap_list (Suc i) var xs @ \<Gamma>)" using h by auto
          show "\<exists>xs. length xs = Suc (Suc i) \<and> eval (list_conj (map fm.Atom L @ F)) (xs @ \<Gamma>)"
            apply(rule exI[where x="swap_list (Suc i) var xs"])
            apply(auto simp add:eval_list_conj simp del:swap_list.simps)
            apply(simp add: h)
            unfolding swap_fm[OF h2 h3] swap_atom[OF h2 h3]
            unfolding h1
            using h(2) unfolding eval_list_conj
            apply auto
            apply (meson Un_iff eval.simps(1) imageI)
            done
        qed
      qed
      done
    done
qed

lemma brownHueristic_less_than: "brownsHeuristic n L F = var \<Longrightarrow> var\<le> n"
  apply simp
  apply(cases "sorted_list_of_fset
           ((\<lambda>x. case foldl
                        (\<lambda>(maxdeg, totaldeg, appearancecount) l.
                            let deg = MPoly_Type.degree (case l of Less p \<Rightarrow> p | Eq p \<Rightarrow> p | Leq p \<Rightarrow> p | Neq p \<Rightarrow> p) x
                            in (max maxdeg deg, totaldeg + deg, appearancecount + (if 0 < deg then 1 else 0)))
                        (0, 0, 0) L of
                  (a, b, c) \<Rightarrow> Quad (a, b, c, x)) |`|
            fset_of_list [0..<n])")
  apply auto
  subgoal for a apply(cases a)
    by auto
  done
end