(*  Title:       Proving the Correctness of Disk Paxos

    Author:      Mauro J. Jaskelioff, Stephan Merz, 2005
    Maintainer:  Mauro J. Jaskelioff <mauro at fceia.unr.edu.ar>
*)

theory DiskPaxos_Inv3 imports DiskPaxos_Inv2  begin

subsection \<open>Invariant 3\<close>

text \<open>
  This invariant says that if two processes have read each other's block
  from disk $d$ during their current phases, then at least one of them
  has read the other's current block.
\<close>

definition HInv3_L :: "state \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> bool"
where
  "HInv3_L s p q d =  (phase s p \<in> {1,2}
                     \<and> phase s q \<in> {1,2}
                     \<and> hasRead s p d q
                     \<and> hasRead s q d p)"

definition HInv3_R :: "state \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> bool"
where
  "HInv3_R s p q d =  (\<lparr>block= dblock s q, proc= q\<rparr> \<in> blocksRead s p d
                     \<or> \<lparr>block= dblock s p, proc= p\<rparr> \<in> blocksRead s q d)"

definition HInv3_inner :: "state \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> bool"
  where "HInv3_inner s p q d = (HInv3_L s p q d \<longrightarrow> HInv3_R s p q d)"

definition HInv3 :: "state \<Rightarrow> bool"
  where "HInv3 s = (\<forall>p q d. HInv3_inner s p q d)"

subsubsection\<open>Proofs of Invariant 3\<close>

theorem HInit_HInv3: "HInit s \<Longrightarrow> HInv3 s"
  by(simp add: HInit_def Init_def HInv3_def
               HInv3_inner_def HInv3_L_def HInv3_R_def)

lemma InitPhase_HInv3_p:
  "\<lbrakk> InitializePhase s s' p; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: InitializePhase_def HInv3_inner_def
                    hasRead_def HInv3_L_def HInv3_R_def)

lemma InitPhase_HInv3_q:
  "\<lbrakk> InitializePhase s s' q ; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: InitializePhase_def HInv3_inner_def
                    hasRead_def HInv3_L_def HInv3_R_def)

lemma HInv3_L_sym: "HInv3_L s p q d \<Longrightarrow> HInv3_L s q p d"
  by(auto simp add: HInv3_L_def)

lemma HInv3_R_sym: "HInv3_R s p q d \<Longrightarrow> HInv3_R s q p d"
  by(auto simp add: HInv3_R_def)

lemma Phase1or2ReadThen_HInv3_pq:
  assumes act:  "Phase1or2ReadThen s s' p d q"
  and  inv_L':  "HInv3_L s' p q d"
  and      pq:  "p\<noteq>q"
  and   inv2b:  "Inv2b s"
  shows   "HInv3_R s' p q d"
proof -
  from inv_L' act pq
  have "phase s q \<in> {1,2} \<and> hasRead s q d p"
    by(auto simp add: Phase1or2ReadThen_def HInv3_L_def
            hasRead_def split: if_split_asm)
  with inv2b
  have "disk s d q = dblock s q"
    by(auto simp add: Inv2b_def Inv2b_inner_def
             hasRead_def)
  with act
  show ?thesis
    by(auto simp add: Phase1or2ReadThen_def HInv3_def
                       HInv3_inner_def HInv3_R_def)
qed

lemma Phase1or2ReadThen_HInv3_hasRead:
  "\<lbrakk> \<not>hasRead s pp dd qq;
     Phase1or2ReadThen s s' p d q;
     pp\<noteq>p \<or> qq\<noteq>q \<or> dd\<noteq>d\<rbrakk>
  \<Longrightarrow> \<not>hasRead s' pp dd qq"
  by(auto simp add: hasRead_def Phase1or2ReadThen_def)

theorem HPhase1or2ReadThen_HInv3:
  assumes act:  "HPhase1or2ReadThen s s' p d q"
  and     inv:  "HInv3 s"
  and      pq:  "p\<noteq>q"
  and   inv2b:  "Inv2b s"
  shows   "HInv3 s'"
proof(clarsimp simp add: HInv3_def HInv3_inner_def)
  fix pp qq dd
  assume h3l': "HInv3_L s' pp qq dd"
  show  "HInv3_R s' pp qq dd"
  proof(cases "HInv3_L s pp qq dd")
    case True
    with inv
    have "HInv3_R s pp qq dd"
      by(auto simp add: HInv3_def HInv3_inner_def)
    with act h3l'
    show ?thesis
      by(auto simp add: HInv3_R_def HInv3_L_def
                          Phase1or2ReadThen_def)
  next
    case False
    assume nh3l: "\<not> HInv3_L s pp qq dd"
    show " HInv3_R s' pp qq dd"
    proof(cases "((pp=p \<and> qq=q) \<or> (pp=q \<and> qq=p)) \<and> dd=d")
      case True
      with act pq inv2b h3l' HInv3_L_sym[OF h3l']
      show ?thesis
        by(auto dest: Phase1or2ReadThen_HInv3_pq HInv3_R_sym)
    next
      case False
      from nh3l h3l' act
      have "(\<not>hasRead s pp dd qq \<or> \<not>hasRead s qq dd pp)
            \<and> hasRead s' pp dd qq \<and> hasRead s' qq dd pp"
        by(auto simp add: HInv3_L_def Phase1or2ReadThen_def)
      with act False
      show ?thesis
        by(auto dest: Phase1or2ReadThen_HInv3_hasRead)
    qed
  qed
qed

lemma StartBallot_HInv3_p:
  "\<lbrakk> StartBallot s s' p; HInv3_L s' p q d \<rbrakk>
          \<Longrightarrow> HInv3_R s' p q d"
by(auto simp add: StartBallot_def dest: InitPhase_HInv3_p)

lemma StartBallot_HInv3_q:
  "\<lbrakk> StartBallot s s' q; HInv3_L s' p q d \<rbrakk>
           \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: StartBallot_def dest: InitPhase_HInv3_q)

lemma StartBallot_HInv3_nL:
  "\<lbrakk> StartBallot s s' t; \<not>HInv3_L s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
           \<Longrightarrow> \<not>HInv3_L s' p q d"
  by(auto simp add: StartBallot_def InitializePhase_def
                      HInv3_L_def hasRead_def)

lemma StartBallot_HInv3_R:
  "\<lbrakk> StartBallot s s' t; HInv3_R s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
              \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: StartBallot_def InitializePhase_def
                    HInv3_R_def hasRead_def)

lemma StartBallot_HInv3_t:
  "\<lbrakk> StartBallot s s' t; HInv3_inner s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                \<Longrightarrow> HInv3_inner s' p q d"
  by(auto simp add: HInv3_inner_def
        dest: StartBallot_HInv3_nL StartBallot_HInv3_R)

lemma StartBallot_HInv3:
  assumes act: "StartBallot s s' t"
  and     inv: "HInv3_inner s p q d"
  shows        "HInv3_inner s' p q d"
proof(cases "t=p \<or> t=q")
  case True
  with act inv
  show ?thesis
    by(auto simp add: HInv3_inner_def
         dest: StartBallot_HInv3_p StartBallot_HInv3_q)
next
  case False
  with inv act
  show ?thesis
    by(auto simp add: HInv3_inner_def dest: StartBallot_HInv3_t)
qed

theorem HStartBallot_HInv3:
  "\<lbrakk> HStartBallot s s' p; HInv3 s \<rbrakk> \<Longrightarrow> HInv3 s'"
  by(auto simp add: HInv3_def dest: StartBallot_HInv3)

theorem HPhase1or2ReadElse_HInv3:
  "\<lbrakk> HPhase1or2ReadElse s s' p d q; HInv3 s \<rbrakk> \<Longrightarrow> HInv3 s'"
  by(auto simp add: Phase1or2ReadElse_def HInv3_def
              dest: StartBallot_HInv3)

theorem HPhase1or2Write_HInv3:
  assumes act: "HPhase1or2Write s s' p d"
  and inv: "HInv3 s"
  shows "HInv3 s'"
proof(auto simp add: HInv3_def)
  fix pp qq dd
  show " HInv3_inner s' pp qq dd"
  proof(cases "HInv3_L s pp qq dd")
    case True
    with inv
    have "HInv3_R s pp qq dd"
      by(simp add: HInv3_def HInv3_inner_def)
    with act
    show ?thesis
      by(auto simp add: HInv3_inner_def HInv3_R_def
                      Phase1or2Write_def)
  next
    case False
    with act
    have "\<not>HInv3_L s' pp qq dd"
      by(auto simp add: HInv3_L_def hasRead_def Phase1or2Write_def)
    thus ?thesis
      by(simp add: HInv3_inner_def)
  qed
qed

lemma EndPhase1_HInv3_p:
  "\<lbrakk> EndPhase1 s s' p; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
by(auto simp add: EndPhase1_def dest: InitPhase_HInv3_p)

lemma EndPhase1_HInv3_q:
  "\<lbrakk> EndPhase1 s s' q; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: EndPhase1_def dest: InitPhase_HInv3_q)

lemma EndPhase1_HInv3_nL:
  "\<lbrakk> EndPhase1 s s' t; \<not>HInv3_L s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                    \<Longrightarrow> \<not>HInv3_L s' p q d"
  by(auto simp add: EndPhase1_def InitializePhase_def
                    HInv3_L_def hasRead_def)

lemma EndPhase1_HInv3_R:
  "\<lbrakk> EndPhase1 s s' t; HInv3_R s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                      \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: EndPhase1_def InitializePhase_def
                    HInv3_R_def hasRead_def)

lemma EndPhase1_HInv3_t:
  "\<lbrakk> EndPhase1 s s' t; HInv3_inner s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                \<Longrightarrow> HInv3_inner s' p q d"
  by(auto simp add: HInv3_inner_def dest: EndPhase1_HInv3_nL
                   EndPhase1_HInv3_R)

lemma EndPhase1_HInv3:
  assumes act: "EndPhase1 s s' t"
  and     inv: "HInv3_inner s p q d"
  shows        "HInv3_inner s' p q d"
proof(cases "t=p \<or> t=q")
  case True
  with act inv
  show ?thesis
    by(auto simp add: HInv3_inner_def
                dest: EndPhase1_HInv3_p EndPhase1_HInv3_q)
next
  case False
  with inv act
  show ?thesis
    by(auto simp add: HInv3_inner_def dest: EndPhase1_HInv3_t)
qed

theorem HEndPhase1_HInv3:
  "\<lbrakk> HEndPhase1 s s' p; HInv3 s \<rbrakk> \<Longrightarrow> HInv3 s'"
  by(auto simp add: HInv3_def dest: EndPhase1_HInv3)

lemma EndPhase2_HInv3_p:
  "\<lbrakk> EndPhase2 s s' p; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
by(auto simp add: EndPhase2_def dest: InitPhase_HInv3_p)

lemma EndPhase2_HInv3_q:
  "\<lbrakk> EndPhase2 s s' q; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: EndPhase2_def dest: InitPhase_HInv3_q)

lemma EndPhase2_HInv3_nL:
  "\<lbrakk> EndPhase2 s s' t; \<not>HInv3_L s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                     \<Longrightarrow> \<not>HInv3_L s' p q d"
  by(auto simp add: EndPhase2_def InitializePhase_def
                    HInv3_L_def hasRead_def)

lemma EndPhase2_HInv3_R:
  "\<lbrakk> EndPhase2 s s' t; HInv3_R s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                     \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: EndPhase2_def InitializePhase_def
                    HInv3_R_def hasRead_def)

lemma EndPhase2_HInv3_t:
  "\<lbrakk> EndPhase2 s s' t; HInv3_inner s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                    \<Longrightarrow> HInv3_inner s' p q d"
  by(auto simp add: HInv3_inner_def
              dest: EndPhase2_HInv3_nL EndPhase2_HInv3_R)

lemma EndPhase2_HInv3:
  assumes act: "EndPhase2 s s' t"
  and     inv: "HInv3_inner s p q d"
  shows        "HInv3_inner s' p q d"
proof(cases "t=p \<or> t=q")
  case True
  with act inv
  show ?thesis
    by(auto simp add: HInv3_inner_def
                dest: EndPhase2_HInv3_p EndPhase2_HInv3_q)
next
  case False
  with inv act
  show ?thesis
    by(auto simp add: HInv3_inner_def dest: EndPhase2_HInv3_t)
qed

theorem HEndPhase2_HInv3:
  "\<lbrakk> HEndPhase2 s s' p; HInv3 s \<rbrakk> \<Longrightarrow> HInv3 s'"
  by(auto simp add: HInv3_def dest: EndPhase2_HInv3)

lemma Fail_HInv3_p:
  "\<lbrakk> Fail s s' p; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
by(auto simp add: Fail_def dest: InitPhase_HInv3_p)

lemma Fail_HInv3_q:
  "\<lbrakk> Fail s s' q; HInv3_L s' p q d \<rbrakk> \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: Fail_def dest: InitPhase_HInv3_q)

lemma Fail_HInv3_nL:
  "\<lbrakk> Fail s s' t; \<not>HInv3_L s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
             \<Longrightarrow> \<not>HInv3_L s' p q d"
  by(auto simp add: Fail_def InitializePhase_def
                    HInv3_L_def hasRead_def)

lemma Fail_HInv3_R:
  "\<lbrakk> Fail s s' t; HInv3_R s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
             \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: Fail_def InitializePhase_def
                    HInv3_R_def hasRead_def)

lemma Fail_HInv3_t:
  "\<lbrakk> Fail s s' t; HInv3_inner s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
              \<Longrightarrow> HInv3_inner s' p q d"
  by(auto simp add: HInv3_inner_def
              dest: Fail_HInv3_nL Fail_HInv3_R)

lemma Fail_HInv3:
  assumes act: "Fail s s' t"
  and     inv: "HInv3_inner s p q d"
  shows        "HInv3_inner s' p q d"
proof(cases "t=p \<or> t=q")
  case True
  with act inv
  show ?thesis
    by(auto simp add: HInv3_inner_def
                dest: Fail_HInv3_p Fail_HInv3_q)
next
  case False
  with inv act
  show ?thesis
    by(auto simp add: HInv3_inner_def dest: Fail_HInv3_t)
qed

theorem HFail_HInv3:
  "\<lbrakk> HFail s s' p; HInv3 s \<rbrakk> \<Longrightarrow> HInv3 s'"
  by(auto simp add: HInv3_def dest: Fail_HInv3)

theorem HPhase0Read_HInv3:
  assumes act: "HPhase0Read s s' p d"
  and inv: "HInv3 s"
  shows "HInv3 s'"
proof(auto simp add: HInv3_def)
  fix pp qq dd
  show " HInv3_inner s' pp qq dd"
  proof(cases "HInv3_L s pp qq dd")
    case True
    with inv
    have "HInv3_R s pp qq dd"
      by(simp add: HInv3_def HInv3_inner_def)
    with act
    show ?thesis
      by(auto simp add: HInv3_inner_def HInv3_R_def Phase0Read_def)
  next
    case False
    with act
    have "\<not>HInv3_L s' pp qq dd"
      by(auto simp add: HInv3_L_def hasRead_def Phase0Read_def)
    thus ?thesis
      by(simp add: HInv3_inner_def)
  qed
qed

lemma EndPhase0_HInv3_p:
  "\<lbrakk> EndPhase0 s s' p; HInv3_L s' p q d \<rbrakk>
              \<Longrightarrow> HInv3_R s' p q d"
by(auto simp add: EndPhase0_def dest: InitPhase_HInv3_p)

lemma EndPhase0_HInv3_q:
  "\<lbrakk> EndPhase0 s s' q; HInv3_L s' p q d \<rbrakk>
              \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: EndPhase0_def dest: InitPhase_HInv3_q)

lemma EndPhase0_HInv3_nL:
  "\<lbrakk> EndPhase0 s s' t; \<not>HInv3_L s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
               \<Longrightarrow> \<not>HInv3_L s' p q d"
  by(auto simp add: EndPhase0_def InitializePhase_def
                    HInv3_L_def hasRead_def)

lemma EndPhase0_HInv3_R:
  "\<lbrakk> EndPhase0 s s' t; HInv3_R s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                \<Longrightarrow> HInv3_R s' p q d"
  by(auto simp add: EndPhase0_def InitializePhase_def
                    HInv3_R_def hasRead_def)

lemma EndPhase0_HInv3_t:
  "\<lbrakk> EndPhase0 s s' t; HInv3_inner s p q d; t\<noteq>p; t\<noteq> q \<rbrakk>
                 \<Longrightarrow> HInv3_inner s' p q d"
  by(auto simp add: HInv3_inner_def
              dest: EndPhase0_HInv3_nL EndPhase0_HInv3_R)

lemma EndPhase0_HInv3:
  assumes act: "EndPhase0 s s' t"
  and     inv: "HInv3_inner s p q d"
  shows        "HInv3_inner s' p q d"
proof(cases "t=p \<or> t=q")
  case True
  with act inv
  show ?thesis
    by(auto simp add: HInv3_inner_def
                dest: EndPhase0_HInv3_p EndPhase0_HInv3_q)
next
  case False
  with inv act
  show ?thesis
    by(auto simp add: HInv3_inner_def dest: EndPhase0_HInv3_t)
qed

theorem HEndPhase0_HInv3:
  "\<lbrakk> HEndPhase0 s s' p; HInv3 s \<rbrakk> \<Longrightarrow> HInv3 s'"
  by(auto simp add: HInv3_def dest: EndPhase0_HInv3)

text\<open>$HInv1 \wedge HInv2 \wedge HInv3$ is an invariant of $HNext$.\<close>

lemma I2c:
  assumes nxt: "HNext s s'"
  and inv: "HInv1 s \<and> HInv2 s \<and> HInv3 s"
  shows "HInv3 s'" using assms
  by(auto simp add: HNext_def Next_def,
     auto intro: HStartBallot_HInv3,
     auto intro: HPhase0Read_HInv3,
     auto intro: HPhase1or2Write_HInv3,
     auto simp add: Phase1or2Read_def HInv2_def
          intro: HPhase1or2ReadThen_HInv3
                 HPhase1or2ReadElse_HInv3,
     auto simp add: EndPhase1or2_def
          intro: HEndPhase1_HInv3
                 HEndPhase2_HInv3,
     auto intro: HFail_HInv3,
     auto intro: HEndPhase0_HInv3)

end


theory Cycle
imports Main
"../../topoS/thy_lib/FiniteGraph"
"../../topoS/thy_lib/isabelle_afp/Graph_Theory/Pair_Digraph"
"../../topoS/thy_lib/Collections/Refine_Dflt"
"../../topoS/thy_lib/Collections/Examples/Autoref/Nested_DFS"
begin

definition graph_to_afp_graph :: "'v graph \<Rightarrow> 'v pair_pre_digraph" where
  "graph_to_afp_graph G \<equiv> \<lparr> pverts = nodes G, parcs = edges G \<rparr>"

lemma "\<lbrakk> valid_graph G \<rbrakk> \<Longrightarrow> pair_wf_digraph (graph_to_afp_graph G)"
  apply(unfold_locales)
  by(auto simp add: valid_graph_def graph_to_afp_graph_def)

lemma "\<lbrakk> valid_graph G \<rbrakk> \<Longrightarrow> pair_fin_digraph (graph_to_afp_graph G)"
  apply(unfold_locales)
  by(auto simp add: valid_graph_def graph_to_afp_graph_def)

lemma "with_proj (graph_to_afp_graph G) =  \<lparr> verts = nodes G, arcs = edges G, tail = fst, head = snd \<rparr>"
  by(simp add: graph_to_afp_graph_def)

definition "has_directed_cycle" :: "'v graph \<Rightarrow> ('v \<times> 'v) awalk \<Rightarrow> bool" where
  "has_directed_cycle G p \<equiv> pre_digraph.cycle (with_proj (graph_to_afp_graph G)) p"

lemma fixes G::"'v graph" and Gafp::"('v, 'v \<times> 'v) pre_digraph"
  assumes transl: "Gafp = with_proj (graph_to_afp_graph G)"
  shows "has_directed_cycle G p = (\<exists>u. pre_digraph.awalk Gafp u p u \<and> distinct (tl (pre_digraph.awalk_verts Gafp u p)) \<and> p \<noteq> [])"
  by(simp add: has_directed_cycle_def pre_digraph.cycle_def transl)

(*hmm, for my purposes, this almost looks executable enough! \<dots>*)
definition pcycle :: "'v set \<Rightarrow> ('v \<times> 'v) set \<Rightarrow> 'v \<Rightarrow> bool" where
  "pcycle V E v0 \<equiv> \<exists>v\<in>V. (v0,v)\<in>E\<^sup>* \<and> (v,v)\<in>E\<^sup>+"
(*for my purpose, it might be enough:
  \<forall> reachable v0 x. (x,x) \<notin> view^+ but this does not find undirected cycles! *)
(*is basic routing loop detection*)

hide_const(open) succ (*my succ in my graph*)

definition nodes_of :: "('v \<times> 'v) set \<Rightarrow> 'v set" where "nodes_of E \<equiv> (fst ` E \<union> snd ` E)"

(*Collections&Refinement tests*)

(*requires: no loops (x,x) \<in> E*)
(*V=worklist, (vertex, parent)*)
definition cycles_dfs_imp :: "('a \<times>'a) set \<Rightarrow> 'a \<Rightarrow> bool nres"
  where
  "cycles_dfs_imp E v0 \<equiv>  do {
      (_,_,cycle) \<leftarrow> WHILE (\<lambda> (W,Discovered,cycle). W \<noteq> {} \<and> \<not> cycle) (\<lambda> (W,Discovered,cycle). do {
        (vparent,v) \<leftarrow> SPEC (\<lambda>v. v\<in>W);
        if v \<in> snd ` Discovered (* \<or> v \<in> fst ` Discovered evtl auch fst`?? test in python first!*)
        then
          RETURN (W,Discovered,True)
        else do {
          let succs = {v'. (v,v')\<in>E \<or> (v',v)\<in>E} - {vparent,v}; (*exclude self-loops*)
          let W = W - {(vparent,v)};
          let Discovered = insert (vparent,v) Discovered;
          let W = W \<union> ({v} \<times> succs);
          RETURN (W,Discovered,cycle)
        }
      }) ({(v0,v0 (*probably: succs v0????*))},{},False);
      RETURN cycle
  }"

lemma pcas_append: "pcas a p b \<Longrightarrow> pcas a (p @ [(b, c)]) c"
  by(induction a p b rule: pcas.induct, simp_all)

lemma pcas_iff_trancl: assumes "x \<noteq> y" shows "(\<exists> p. set p \<subseteq> D \<and> pcas x p y) \<longleftrightarrow> (x,y) \<in> D\<^sup>+"
proof
  assume "\<exists>p. set p \<subseteq> D \<and> pcas x p y"
  from this obtain p where pset: "set p \<subseteq> D" and pcas: "pcas x p y" by auto
  have "x \<noteq> y \<longrightarrow> set p \<subseteq> D \<longrightarrow> pcas x p y \<longrightarrow> (x, y) \<in> D\<^sup>+"
    apply(induction p arbitrary: x y)
    apply(simp)
    apply(clarify)
    apply(simp)
    using trancl_into_trancl2 by (metis r_into_trancl')
  from this assms pset pcas
  show "(x, y) \<in> D\<^sup>+" by simp
next
  show "(x,y) \<in> D\<^sup>+ \<Longrightarrow> (\<exists> p. set p \<subseteq> D \<and> pcas x p y)"
  apply(induction rule: trancl_induct)
  apply(rule_tac x="[(x,y)]" in exI)
  apply(simp)
  apply(erule exE)
  apply(rule_tac x="p@[(y,z)]" in exI)
  apply(simp add: pcas_append)
  done
qed

lemma pcas_start_in_pawalkvert: "pcas a p b \<Longrightarrow> a \<in> set (pawalk_verts a p)"
  by(induction p, simp_all)
lemma pcas_end_in_pawalkvert: "pcas a p b \<Longrightarrow> b \<in> set (pawalk_verts a p)"
  by(induction p arbitrary: a, simp_all)
lemma pcas_distinct_len: "pcas a p b \<Longrightarrow>  a \<noteq> b \<Longrightarrow> length p \<ge> 1"
  by(induction a p b rule:pcas.induct, simp_all)
lemma pawalk_verts_length: "length (pawalk_verts a p) = Suc (length p)"
  by(induction p arbitrary: a, simp_all)

lemma takeWhile_append_split: "\<lbrakk>\<exists>x\<in>set X. \<not> P x \<Longrightarrow> Q (takeWhile P X);
       (\<And>x. x\<in>set X \<Longrightarrow> P x) \<Longrightarrow> Q (X@takeWhile P Y) \<rbrakk> \<Longrightarrow>
      Q (takeWhile P (X@Y) )"
using takeWhile_append1 takeWhile_append2 by metis

fun lastRemove :: "('a\<times>'a) \<Rightarrow>  ('a \<times> 'a) list \<Rightarrow> ('a \<times> 'a) list" where
  "lastRemove (a,b) l = rev (takeWhile (\<lambda>(x,y). y \<noteq> b) (rev l))"
value "lastRemove (0::nat,1) [(0,1), (1::nat,2), (2,3), (3,2), (2,4), (4,5)]"
value "lastRemove (1::nat,2) [(1::nat,2), (2,3), (3,2), (2,4), (4,5), (5,6)]"
value "lastRemove (2::nat,3) [(2,3), (3,2), (2,4), (4,5)]"
value "lastRemove (2::nat,3) [(2,3), (3,2), (2,4), (4,5), (5,3), (3,6)]"
value "lastRemove (2::nat,1) [(2,1)]"
value "lastRemove (1::nat,2) [(4,5)]"
value "lastRemove (1::nat,1) [(1,1), (1,2), (2,2)]"
value "lastRemove (1::nat,1) [(1,1), (2,2)]"
lemma lastRemove_empty: "lastRemove c [] = []" by(cases c, simp)
lemma lastRemove_drop: "\<exists>n. lastRemove c l = drop n l"
  apply(induction l, simp_all)
  apply(simp add: lastRemove_empty)
  apply(cases c, clarsimp)
  apply(drule_tac f="rev" in HOL.arg_cong)
  apply(simp)
  apply(rename_tac h n)
  apply(case_tac "h = b")
  apply(simp_all add: List.takeWhile_tail)
  apply(rule_tac x="Suc n" in exI)
  apply(simp)
  apply(rule takeWhile_append_split)
  apply(simp_all)
  apply(rule_tac x="Suc n" in exI, simp)
  apply(rule_tac x="0" in exI)
  apply(simp)
  done

lemma lastRemove_length: "length (lastRemove c l) \<le> length l"
  using lastRemove_drop by (metis Nat.diff_le_self length_drop)
lemma lastRemove_set: "set (lastRemove c p) \<subseteq> set p"
  apply(induction p, simp_all add: lastRemove_empty)
  apply(cases c, clarsimp)
  by (metis prod.inject rev.simps(2) set_ConsD set_rev set_takeWhileD)

lemma "\<lbrakk>lastRemove (x,y) p \<noteq> []; pcas x p y\<rbrakk> \<Longrightarrow> y = fst (hd (lastRemove (x,y) p))"
  apply(induction p arbitrary: x y)
  apply(simp_all)
  apply(rule takeWhile_append_split)
  apply(simp_all)
  apply force

  oops
lemma "\<lbrakk>pcas z p y\<rbrakk> \<Longrightarrow> pcas x ((x,z)#(lastRemove (x,z) p)) y"
oops

lemma "\<lbrakk>pcas x p y\<rbrakk> \<Longrightarrow> (p = [] \<longrightarrow> pcas x (lastRemove c p) y) \<and> (p \<noteq> [] \<longrightarrow> pcas x ((hd p)#(lastRemove (hd p) p)) y)"
proof(induction p arbitrary: x y)
  case Nil thus ?case by(simp add: lastRemove_empty)
  next
  case (Cons a p)
  from lastRemove_drop obtain n where s: "(lastRemove a (a#p)) = drop n (a#p)" by blast
  from Cons show ?case
  apply(simp add: s)
  apply(case_tac "p=[]")
  apply(simp_all)
oops

lemma "\<forall> (x,y) \<in> set (lastRemove (a,b) l). b \<notin> snd `  set (lastRemove (a,b) l)"
  apply(simp) by (metis (lifting, mono_tags) in_snd_imageE set_takeWhileD split_conv)

(* [(1,2), (2,3), (3,2), (2,4)] \<longrightarrow> [(1,2), (2,4)] *)
function kreisentfernung :: "('a \<times> 'a) list \<Rightarrow> ('a \<times> 'a) list" where
  "kreisentfernung [] = []" |
  "kreisentfernung (c#cs) = c#kreisentfernung (lastRemove c cs)"
by pat_completeness auto
termination sorry
value "kreisentfernung [(0,1), (1::nat,2), (2,3), (3,2), (2,4), (4,5)]"
value "kreisentfernung [(1::nat,2), (2,3), (3,2), (2,4), (4,4), (4,1), (1::nat,2), (2,3), (3,2), (2,4), (4,4)]"
value "kreisentfernung [(1::nat,2), (2,3), (3,2), (2,4), (4,5), (5,3)]"
value "kreisentfernung [(1::nat,2), (2,3), (3,2), (2,4), (4,5), (5,3), (3,1)]"
value "kreisentfernung [(1::nat,1), (2,1)]"
value "kreisentfernung [(2::nat,1)]"
value "kreisentfernung [(2::nat,3), (3,2), (2,4), (4,5), (5,3)]"

lemma "set (kreisentfernung (drop x p)) \<subseteq> set p"
  proof(induction p arbitrary: x)
  case Nil thus ?case by(simp add: lastRemove_empty)
  next
  case (Cons a p)
  assume Cons: "\<And>x. set (kreisentfernung (drop x p)) \<subseteq> set p"
  from lastRemove_drop obtain n where s: "lastRemove a p = drop n p" by blast
  from Cons have "set (kreisentfernung (drop n p)) \<subseteq> set p" by simp
  hence "set (kreisentfernung (lastRemove a p)) \<subseteq> insert a (set p)"
    by(simp add: s subset_insertI2)
  from this Cons show ?case
  by(case_tac x, auto)
qed
lemma "drop 0 l = l" by simp

lemma "pcas x p y \<Longrightarrow> pcas x (kreisentfernung p) y"
apply(induction p)
  apply(simp)
  apply(simp)
oops
value "pawalk_verts 1 [(1::nat,2), (2,3), (3,2), (2,4), (4,5), (5,3), (3,1)]"
lemma "pcas x p y \<Longrightarrow> distinct (tl (pawalk_verts x (kreisentfernung (filter (\<lambda>(x,y). x\<noteq>y) p))))"
nitpicks
oops
(*aber erstmal pcas zeigen*)

lemma "pcas x p y \<Longrightarrow> \<exists>p'. pcas x p' y \<and> set (pawalk_verts x p') \<subseteq> set (pawalk_verts x p) \<and> distinct (tl (pawalk_verts x p'))"
  apply(induction x p y rule: pcas.induct)
  apply(simp)
  apply(rule_tac x="[]" in exI)
  apply(simp)
  apply(simp)
  apply(erule_tac exE)
  apply(clarsimp)
  apply(case_tac "a = b")
  apply(rule_tac x="p'" in exI)
  apply(simp)
  using pcas_start_in_pawalkvert apply fast
  apply(case_tac "b \<notin> (set (pawalk_verts b p'))")
  apply(rule_tac x="(a,b)#p'" in exI)
  apply(simp)
  apply (metis pcas_start_in_pawalkvert)
  apply(rule_tac x="dropWhile (\<lambda>(x1,x2). x1 \<noteq> b) p'" in exI) (*TODO need to cut out circle ....*)
  apply(simp)
  nitpick
sorry (*TODOTODO*)

(*everything reachable from V'*)
lemma "{y. \<exists>x \<in> V'. (x,y) \<in> E\<^sup>*} = E\<^sup>*``V'" by blast

definition restrict_to :: "('v \<times> 'v) set \<Rightarrow> 'v set \<Rightarrow> ('v \<times> 'v) set" where
  "restrict_to E V \<equiv> {(a,b)\<in>E. a\<in>V \<and> b\<in>V}"

definition bi :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set" where
  "bi E = E \<union> backflows E"

lemma bi_insert: "bi (insert (x,y) X) = {(x,y), (y,x)} \<union> bi X"
  by(auto simp add: bi_def backflows_def)
lemma bi_sym: "sym (bi X)"
  by(simp add: sym_def bi_def backflows_def)
lemma bi_union: "bi A \<union> bi B = bi (A \<union> B)"
  by(auto simp add: sym_def bi_def backflows_def)

definition uni_restrict_to :: "('v \<times> 'v) set \<Rightarrow> 'v set \<Rightarrow> ('v \<times> 'v) set" where
  "uni_restrict_to E V \<equiv> restrict_to (bi E) V"

lemma uni_restrict_to_mono: "D' \<subseteq> D \<Longrightarrow> uni_restrict_to E D' \<subseteq> uni_restrict_to E D"
  by(simp add: uni_restrict_to_def restrict_to_def, fast)

definition has_undirected_cycle_in :: "('a \<times> 'a) set \<Rightarrow> bool" where
  "has_undirected_cycle_in E \<equiv>
  \<exists> u \<in> nodes_of E. \<exists> p. set p \<subseteq> bi E \<and> pcas u p u \<and> distinct (tl (Pair_Digraph.pawalk_verts u p)) \<and> length p \<ge> 3"

definition cycles_dfs_imp_WHILE_invar :: "('v \<times> 'v) set \<Rightarrow> 'v \<Rightarrow> ('v\<times>'v) set \<times> ('v\<times>'v) set \<times> bool \<Rightarrow> bool" where
  "cycles_dfs_imp_WHILE_invar E v0 \<sigma> \<equiv> let (W,D,cycle) = \<sigma> in
        W \<subseteq> bi E \<and> D \<subseteq> bi E
        \<and> (\<forall> (a,_) \<in> W. \<exists> (_,d) \<in> D. (d,a) \<in> D)
        \<and> W \<inter> D = {}
        \<and> (\<forall> x\<in>snd`D. \<forall> y\<in>snd`D. x \<noteq> y \<longrightarrow> (x,y) \<in> (bi D)\<^sup>+)
        \<and> (cycle \<longrightarrow> has_undirected_cycle_in (D \<union> W))
        (*\<and> (\<forall> x\<in>Discovered. \<forall> y\<in>Discovered. x \<noteq> y \<longrightarrow>
            (\<exists> p. set p \<subseteq> uni_restrict_to E (Discovered) \<and> pcas x p y \<and> distinct (Pair_Digraph.pawalk_verts x p)))*)
        (*E\<^sup>*``(fst ` V') \<union> fst ` Discovered = E\<^sup>*``{v0} \<and> *)"

lemma "(\<forall> x\<in>snd`(bi D). \<forall> y\<in>snd`D. x \<noteq> y \<longrightarrow> (x,y) \<in> (bi D)\<^sup>+) \<Longrightarrow> (\<forall> x\<in>fst`D. \<forall> y\<in>snd`D. x \<noteq> y \<longrightarrow> (x,y) \<in> (bi D)\<^sup>+)"
  apply(clarsimp)
  apply(rename_tac a b x y)
  apply(erule_tac x="(b,a)" in ballE)
  apply(erule_tac x="(x,y)" in ballE)
  apply(simp_all)
  by(simp add: bi_def backflows_def)

lemma distinct_xyz_length: "distinct [x,y,z] \<Longrightarrow> x \<in> set X \<Longrightarrow> y \<in> set X \<Longrightarrow> z \<in> set X \<Longrightarrow> length X \<ge> 3"
by (smt distinct_length_2_or_more length_pos_if_in_set list.size(4) list_decomp_2 list_tail_coinc set_ConsD)

lemma assumes D_path: "(\<forall> x\<in>nodes_of D. \<forall> y\<in>snd`D. x \<noteq> y \<longrightarrow> (x,y) \<in> (bi D)\<^sup>+)" (*replace snd with nodes_of*)
    and ad2W: "(a, d2) \<in> W" and d1d2D: "(d1, d2) \<in> D"
    and WD_edge: "(\<forall> (a,_) \<in> W. \<exists> (_,d) \<in> D. (d,a) \<in> D)"
    and nreflW: "\<forall> (x,y) \<in> W. x \<noteq> y"
    (*and nreflD: "\<forall> (x,y) \<in> D. x \<noteq> y"*)
    and disjunct: "bi W \<inter> bi D = {}"
   shows "has_undirected_cycle_in (D \<union> {(a,d2)})"
   proof(unfold has_undirected_cycle_in_def)
    from ad2W WD_edge have "\<exists> (x,y) \<in> D. (y, a) \<in> D" by fast
    from this obtain y where yD: "(y, a) \<in> D" by blast
    have "a \<noteq> d2" using ad2W nreflW by blast
    have "y \<noteq> a" sorry (*does not hold, y might be v0*)
    from `y \<noteq> a` `a \<noteq> d2` disjunct ad2W yD have "y \<noteq> d2" by(simp add: bi_def backflows_def, blast)
    (* d2 \<longrightarrow> y \<longrightarrow> (y,a) \<longrightarrow> a,d2 <-- in W*) (*need d2 \<noteq> y*)
    (*from yD have "set [(y,a)] \<subseteq> bi D \<and> pcas y [(y,a)] a" by (auto simp: bi_def)*)
    from yD d1d2D D_path have "y \<noteq> d2 \<longrightarrow> (y, d2) \<in> (bi D)\<^sup>+"
      by(simp add: nodes_of_def, force)
    from this `y \<noteq> d2` have "(d2, y) \<in> (bi D)\<^sup>+" using bi_sym by (metis symD sym_trancl)
    from this pcas_iff_trancl[symmetric] `y \<noteq> d2` have "\<exists>p. set p \<subseteq> (bi D) \<and> pcas d2 p y" by metis
    from this obtain p where p: "set p \<subseteq> (bi D) \<and> pcas d2 p y" and pdist: "distinct (pawalk_verts d2 p)" sorry
    from pcas_distinct_len p `y \<noteq> d2` have plength: "length p \<ge> 1" by metis
    let ?pa = "p@[(y,a)]"
    from p yD have pa: "set ?pa \<subseteq> (bi D) \<and> pcas d2 ?pa a" by(simp add: bi_def pcas_append)
    have "pcas d2 p y \<Longrightarrow> pawalk_verts d2 (p @ [(y, a)]) = (pawalk_verts d2 p)@[a]"
      by(induction p arbitrary: d2, simp_all)
    from this p have pawalk_verts_simp: "pawalk_verts d2 (p @ [(y, a)]) = (pawalk_verts d2 p)@[a]" by simp
    have a_in_path_length: "a \<in> set (pawalk_verts d2 p) \<Longrightarrow> length p \<ge> 2"
    proof -
      assume 0: "a \<in> set (pawalk_verts d2 p)"
      from `y \<noteq> a` `a \<noteq> d2` `y \<noteq> d2` have 1: "distinct [d2, y, a]" by auto
      from p have 2: "d2 \<in> set (pawalk_verts d2 p)" by (metis pcas_start_in_pawalkvert)
      from p have 3: "y \<in> set (pawalk_verts d2 p)" using pcas_end_in_pawalkvert by metis
      from distinct_xyz_length 0 1 2 3 have "length (pawalk_verts d2 p) \<ge> 3" by fast
      from this pawalk_verts_length show "length p \<ge> 2" by (metis le_numeral_Suc pred_numeral_simps(3))
    qed
    from pdist have padist: "a \<notin> set (pawalk_verts d2 p) \<Longrightarrow> distinct (pawalk_verts d2 ?pa)"
      by(simp add: pawalk_verts_simp)
    (*if a in pa: let ?pa = p*)
    from plength have palength: "length ?pa \<ge> 2" by simp
    from ad2W have ad2biW: "(d2,a) \<in> bi W" by(simp add: bi_def backflows_def)
    hence "set [(a, d2)] \<subseteq> bi {(a,d2)} \<and> pcas a [(a, d2)] d2" by (simp add: bi_def)
    from this pa have 1: "set ((a, d2)#?pa) \<subseteq> bi {(a,d2)} \<union> bi D \<and> pcas a ((a, d2)#?pa) a" by auto
    from padist have 2: "distinct (tl (pawalk_verts a ((a, d2)#?pa)))" by simp

   show "\<exists>u\<in>nodes_of (D \<union> {(a, d2)}). \<exists>p. set p \<subseteq> bi (D \<union> {(a, d2)}) \<and> pcas u p u \<and> distinct (tl (pawalk_verts u p)) \<and> 3 \<le> length p"
    apply(case_tac "a \<notin> set (pawalk_verts d2 p)")
    apply(rule_tac x=a in bexI)
    apply(rule_tac x="(a, d2)#?pa" in exI)
    apply(rule conjI)
    using bi_union 1 apply blast
    apply(rule conjI)
    using 1 apply blast
    apply(rule conjI)
    using padist apply simp
    apply(simp add: plength[simplified])
    apply(simp add: nodes_of_def)
oops

lemma cycles_dfs_imp_WHILE_invar_step1:
  assumes "cycles_dfs_imp_WHILE_invar E v0 (W, Discovered, cycle)"
       "(a, snd (d1, d2)) \<in> W" "(d1, d2) \<in> Discovered" "W \<noteq> {}" "\<not> cycle"
  shows "cycles_dfs_imp_WHILE_invar E v0 (W, Discovered, True)"
  using assms unfolding cycles_dfs_imp_WHILE_invar_def
  apply(simp)
  (*a is snd`discovered \<longrightarrow> (d2,a) \<in> D^+ \<longrightarrow> need W disjunct D \<longrightarrow> path: d2,a + (a,d2)*)
  (*TODO*)
  apply(simp add: has_undirected_cycle_in_def)
  proof -
  show "\<exists>u\<in>nodes_of (Discovered \<union> W). \<exists>p. set p \<subseteq> bi (Discovered \<union> W) \<and> pcas u p u \<and> distinct (tl (pawalk_verts u p)) \<and> 3 \<le> length p"
oops

lemma nodes_of_backflows_snd: "nodes_of E = snd ` E \<union> snd ` (backflows E)"
    apply(simp add: nodes_of_def backflows_alt_fstsnd) by force
lemma nodes_of_subset_backflows_b: "v0 \<in> nodes_of E \<Longrightarrow> V \<subseteq> insert (v0,v0) (E \<union> backflows E) \<Longrightarrow> (a, b) \<in> V \<Longrightarrow> b \<in> nodes_of E"
    apply(simp add: nodes_of_backflows_snd) by force

lemma "y \<in> snd ` (V - {(a, b)} \<union> {b} \<times> ({v'. (b, v') \<in> E \<or> (v', b) \<in> E} - {a, b})) \<Longrightarrow>
         b \<noteq> y \<Longrightarrow>  y \<notin> snd ` V \<Longrightarrow> False" oops

lemma cycles_dfs_imp_WHILE_invar_step2:
  assumes "v0 \<in> nodes_of E" and "cycles_dfs_imp_WHILE_invar E v0 (W, Discovered, False)"
       "(w1, w2) \<in> W"
       "w2 \<notin> snd ` Discovered"
       "W \<noteq> {}"
       "\<not> cycle"
  shows "cycles_dfs_imp_WHILE_invar E v0 (W - {(w1, w2)} \<union> {w2} \<times> ({v'. (w2, v') \<in> E \<or> (v', w2) \<in> E} - {w1, w2}), insert (w1, w2) Discovered, False)"
  using assms unfolding cycles_dfs_imp_WHILE_invar_def
  apply(simp)
  apply(rule conjI)
  apply(auto)[1]
  apply(rule conjI)
  apply(auto simp add: bi_def backflows_def)[1]
  apply(rule conjI)
  apply(auto simp add: bi_def backflows_def)[1]
  apply(rule conjI)
  apply blast
  apply(rule conjI)
  nitpick (*dis*)
  apply(simp add: bi_insert)[1]
  apply(clarsimp)
  apply(erule_tac x="(w1,w2)" in ballE, simp)
  prefer 2 apply simp
  apply(erule bexE)
  apply(clarify)
  (*holds but needs proof ...*)
    using nodes_of_subset_backflows_b
oops

lemma cycles_dfs_imp_sound:
  fixes succ and v0
  assumes F: "finite E"
  shows "cycles_dfs_imp E v0 \<le> SPEC (\<lambda>r. r \<longleftrightarrow> has_undirected_cycle_in (uni_restrict_to E (E\<^sup>*``{v0})))"
proof -

  from F show ?thesis
    unfolding cycles_dfs_imp_def
    apply(intro WHILE_rule[where I="cycles_dfs_imp_WHILE_invar E v0"] refine_vcg)
    apply(auto simp add: cycles_dfs_imp_WHILE_invar_def restrict_to_def has_undirected_cycle_in_def nodes_of_def)[1]
    apply(clarify, rename_tac A W C V Discovered cycle I J a L d1 d2)
    apply(simp add: cycles_dfs_imp_WHILE_invar_step1)
    apply(clarsimp)
    apply(rename_tac W Discovered cycle w1 w2)
    apply(auto simp add: cycles_dfs_imp_WHILE_invar_def)[1]
    apply(simp add: cycles_dfs_imp_WHILE_invar_def)[1]
    apply(rule conjI)
    apply(auto)[1]
    apply(rule conjI)
    apply(auto)[1]
    apply(rule conjI)
    apply(auto)[1]
    apply clarify
    using v0 try0
    oops

(*no idea what's wrong here*)
definition cycles_dfs_recX :: "('a \<Rightarrow>'a set) \<Rightarrow> 'a \<Rightarrow> bool nres"
  where
  "cycles_dfs_recX succ v0 \<equiv> REC (\<lambda>D (V,v).
    if v \<in> V then RETURN True
    else do {
      let V=insert v V;
      FOREACH (succ v) (\<lambda>v' _. D (V,v')) False }
  ) ({},v0)"
lemma cycles_dfs_rec_sound:
  fixes succ and v0
  defines "E \<equiv> {(v,v'). v'\<in>succ v}"
  defines "V \<equiv> {v. (v0,v)\<in>E\<^sup>*}"
  assumes F: "finite V"
  shows "cycles_dfs_recX succ v0 \<le> SPEC (\<lambda>r. r \<longrightarrow> (\<forall>x\<in>V. (v0,x)\<in>E\<^sup>* \<longrightarrow> (x,x)\<notin>E\<^sup>+))"
proof -
  have S: "\<And>v. succ v = E``{v}"
    by (auto simp: E_def)

  from F show ?thesis
    unfolding cycles_dfs_recX_def S
    apply(intro REC_rule[where \<Phi>="\<lambda>(V',v'). (v0,v')\<in>E\<^sup>* \<and> V'\<subseteq>V \<and> (\<forall>x\<in>V'. (v0,x)\<in>E\<^sup>* \<longrightarrow> (x,x)\<notin>E\<^sup>+)"]
        FOREACH_rule[where I="\<lambda>Succs r. XXX"] refine_vcg) (*r \<longrightarrow> (\<forall>v\<in>V. (v0,v)\<in>E\<^sup>* \<longrightarrow> (v,v)\<notin>E\<^sup>+)*)
    apply(refine_mono) (*REC is somehow undocumented*)
    apply(simp)
    apply(simp_all)
    apply(rename_tac V' v')
    oops

fun fibdef :: "nat \<Rightarrow> nat" where
  "fibdef 0 = 1" |
  "fibdef (Suc 0) = 1" |
  "fibdef (Suc (Suc n)) = fibdef (Suc n) + fibdef n"
value "fibdef 4"

definition fibref :: "nat \<Rightarrow> nat nres"
  where
  "fibref n \<equiv> REC (\<lambda>D (n).
    if n = 0 then RETURN 1
    else if n = 1 then RETURN 1
    else do {
      x \<leftarrow> (D (n - 1));
      y \<leftarrow> (D (n - 2));
      RETURN (x + y)
      }
    ) (n)"

lemma fibref:
  shows "fibref n \<le> SPEC (\<lambda>r. r = fibdef n)"
proof -
  show ?thesis
    unfolding fibref_def
    apply (refine_rcg refine_vcg REC_rule[where \<Phi>="\<lambda>n. n \<ge> 0"])
    apply(simp_all)[3]
    apply(simp add: RETURN_def)
    apply(auto)
    oops

section{*TEST TEST TES TEST of UNIO*}
  lemma "UNION {1::nat,2,3} (\<lambda>n. {n+1}) = {2,3,4}" by eval
  lemma "(\<Union>n\<in>{1::nat, 2, 3}. {n + 1}) = {2, 3, 4}" by eval
  lemma "UNION {1::nat,2,3} (\<lambda>n. {n+1}) = set (map (\<lambda>n. n+1) [1,2,3])" by eval

(*
  locale X =
    fixes N1 N2
    assumes well_n1: "wellformed_network N1"
    assumes well_n2: "wellformed_network N2"
  begin
  end

  sublocale X \<subseteq> n1!: wellformed_network N1
    by (rule well_n1)
  sublocale X \<subseteq> n2!: wellformed_network N2
    by (rule well_n2)

    context X
    begin

    end
*)

end


theory Decentralised_Model imports
  CryptHOL.CryptHOL
begin

type_synonym ('token_pub', 'token_sec') token = "('token_pub' \<times> 'token_sec')"

type_synonym ('user', 'query_out') query = "'user' \<Rightarrow> 'query_out'"

type_synonym ('store_non_sens_attrs', 'store_sens_attrs') govt_store_data = "'store_non_sens_attrs' set \<times> 'store_sens_attrs' set"

locale decentralised_id =
  fixes reg :: "'user \<Rightarrow> (('token_pub, 'token_sec) token \<times> ('store_non_sens_attrs, 'store_sens_attrs) govt_store_data) spmf"
    and auth :: "('token_pub, 'token_sec) token \<Rightarrow> ('user, 'query_out) query  \<Rightarrow> 'query_out spmf"
    and valid_user :: "'user \<Rightarrow> bool"
    and valid_query :: "('user, 'query_out) query \<Rightarrow> bool"
  assumes lossless_reg: "lossless_spmf (reg user)"
begin

definition correct_game :: "'user \<Rightarrow> ('user, 'query_out) query  \<Rightarrow> bool spmf"
  where
    "correct_game user query = do {
      (token, govt_output) \<leftarrow> reg user;
      result \<leftarrow> auth token query;
      return_spmf (result = query user)}"

definition "correct \<longleftrightarrow> (\<forall> user query. valid_user user \<longrightarrow> valid_query query
                            \<longrightarrow> spmf (correct_game user query) True = 1)"

primrec sens_attrs_hiding_game :: "((('user \<times> 'user) \<times> 'state) spmf \<times> ('state \<Rightarrow> 'store_sens_attrs set \<Rightarrow> bool spmf)) \<Rightarrow> bool spmf"
  where
    "sens_attrs_hiding_game (\1, \2) = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b \<leftarrow> coin_spmf;
      (card, (non_sens_attrs, sens_attrs)) \<leftarrow> reg (if b then user0 else user1);
      b' \<leftarrow> \2 \<sigma> sens_attrs;
      return_spmf (b' = b)} ELSE coin_spmf"

definition "sens_attrs_hiding_advantage \ = \<bar>spmf (sens_attrs_hiding_game \) True - 1/2\<bar>"

definition "perfect_sens_attrs_hiding \ \<longleftrightarrow> sens_attrs_hiding_advantage \ = 0"

lemma no_sens_attrs_imp_perfect_sens_attrs_hiding:
  assumes "\<forall> user token store_non_sens_attr store_sens_attr. (token, store_non_sens_attr, store_sens_attr) \<in> set_spmf (reg user) \<longrightarrow> store_sens_attr = {}"
  shows "perfect_sens_attrs_hiding \"
proof-
  note [simp] = Let_def split_def
  have "\<bar>spmf (sens_attrs_hiding_game \) True - 1/2\<bar> = 0"
  proof-
    obtain \1 and \2 where \ [simp]: "\ = (\1, \2)" by(cases \)
    have "sens_attrs_hiding_game (\1, \2) = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b :: bool \<leftarrow> coin_spmf;
      (card, (store_non_sens_attrs, store_sens_attrs)) \<leftarrow> reg (if b then user0 else user1);
      b' \<leftarrow> \2 \<sigma> store_sens_attrs;
      return_spmf (b' = b)} ELSE coin_spmf"
      by(simp add: sens_attrs_hiding_game_def)
    also have "... = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b :: bool \<leftarrow> coin_spmf;
      (card, (store_non_sens_attrs, store_sens_attrs)) \<leftarrow> reg (if b then user0 else user1);
      b' \<leftarrow> \2 \<sigma> {};
      return_spmf (b' = b)} ELSE coin_spmf"
      apply auto
      apply(intro try_spmf_cong bind_spmf_cong[OF refl]; clarsimp?)+
      apply(intro bind_spmf_cong bind_spmf_cong[OF refl]; clarsimp?)
      using assms by blast
    also have "... = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b' \<leftarrow> \2 \<sigma> {};
      map_spmf((=) b') coin_spmf} ELSE coin_spmf"
      including monad_normalisation
      by(simp add: bind_spmf_const lossless_reg lossless_weight_spmfD map_spmf_conv_bind_spmf)
    also have "... = coin_spmf"
      by(auto simp add: bind_spmf_const map_eq_const_coin_spmf try_bind_spmf_lossless2' scale_bind_spmf weight_spmf_le_1 scale_scale_spmf)
    ultimately show ?thesis
      by(simp add: spmf_of_set)
  qed
  thus ?thesis
    by(simp add: perfect_sens_attrs_hiding_def sens_attrs_hiding_advantage_def)
qed

primrec token_sec_hiding_game :: "((('user \<times> 'user) \<times> 'state) spmf) \<times> ('state \<Rightarrow> 'token_sec \<Rightarrow> bool spmf) \<Rightarrow> bool spmf"
  where
    "token_sec_hiding_game (\1, \2) = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      b \<leftarrow> coin_spmf;
      ((token_pubb, token_secb), govt_storeb) \<leftarrow> reg (if b then user0 else user1);
      b' \<leftarrow> \2 \<sigma> token_secb;
      return_spmf (b' = b)} ELSE coin_spmf"

definition "token_sec_hiding_advantage \ = \<bar>spmf (token_sec_hiding_game \) True - 1/2\<bar>"

definition "perfect_token_sec_hiding \ \<longleftrightarrow> token_sec_hiding_advantage \ = 0"

end

end


(*<*)
\<comment>\<open> ********************************************************************
 * Project         : AGM Theory
 * Version         : 1.0
 *
 * Authors         : Valentin Fouillard, Safouan Taha, Frederic Boulanger
                     and Nicolas Sabouret
 *
 * This file       : AGM logics
 *
 * Copyright (c) 2021 Université Paris Saclay, France
 *
 ******************************************************************************\<close>

theory AGM_Logic

imports Main

begin
(*>*)

section \<open>Introduction\<close>

text\<open>
The 1985 paper by Carlos Alchourrón, Peter Gärdenfors,
and David Makinson (AGM), ``On the Logic of Theory Change: Partial Meet
Contraction and Revision Functions'' \<^cite>\<open>"alchourron1985logic"\<close> launches a large and
rapidly growing literature that employs formal models and logics to handle changing beliefs of a rational agent
and to take into account new piece of information observed by this agent.
In 2011, a review book titled "AGM 25 Years: Twenty-Five Years of Research in Belief Change"
was edited to summarize the first twenty five years of works based on AGM
\<^cite>\<open>"Ferme2011"\<close>.

According to Google Scholar, the original AGM paper was cited 4000 times!
This AFP entry is HOL-based and it is a faithful formalization of the logic operators (e.g. contraction, revision, remainder \dots )
axiomatized in the AGM paper. It also contains the proofs of all the theorems stated in the paper that show how these operators combine.
Both proofs of Harper and Levi identities are established.
\<close>

text\<open>A belief state can be considered as a consistent set of beliefs (logical propositions) closed under logical reasoning.
Belief changes represent the operations that apply on a belief state to remove some of it and/or to add new beliefs (propositions).
In the latter case, it is possible that other beliefs are affected by these changes (to preserve consistency for example).
AGM define several postulates to guarantee that such operations preserve consistency meaning that the agent keeps rational.
Three kinds of operators are defined :
\<^item> The contraction @{text \<open>\<div>\<close>} : where a proposition is removed from a belief set
\<^item> The expansion @{text \<open>\<oplus>\<close>} : where a proposition is added to a belief set
\<^item> The revision @{text \<open>\<^bold>*\<close>} : where a proposition is added to a belief set such that the belief set remains consistent
\<close>

text\<open>In this AFP entry, there are three theory files:
\<^enum> The AGM Logic file contains a classification of logics used in the AGM framework.
\<^enum> The AGM Remainder defines a important operator used in the AGM framework.
\<^enum> The AGM Contraction file contains the postulates of the AGM contraction and its relation with the meet contraction.
\<^enum> The AGM Revision file contains the postulates of the AGM revision and its relation with the meet revision.
\<close>

section \<open>Logics\<close>

text\<open>The AGM framework depends on the underlying logic used to express beliefs. AGM requires at least a Tarskian propositional calculus.
If this logic is also supra-classical and/or compact, new properties are established and the main theorems of AGM are strengthened.
To model AGM it is therefore important to start by formalizing this underlying logic and its various extensions.
We opted for a deep embedding in HOL which required the redefinition of all the logical operators and an axiomatization of their rules.
This is certainly not efficient in terms of proof but it gives a total control of our formalization and an assurance
that the logic used has no hidden properties depending on the Isabelle/HOL implementation.
We use the Isabelle \<^emph>\<open>locales\<close> feature and we take advantage of the inheritance/extension mechanisms between locales.\<close>

subsection \<open>Tarskian Logic\<close>

text \<open>
The first locale formalizes a Tarskian logic based on the famous Tarski's consequence operator: @{term \<open>Cn(A)\<close>}
which gives the set of all propositions (\<^bold>\<open>closure\<close>) that can be inferred from the set of propositions @{term \<open>A\<close>},
Exactly as it is classically axiomatized in the literature, three assumptions of the locale define the consequence operator.
\<close>
locale Tarskian_logic =
fixes Cn::\<open>'a set \<Rightarrow> 'a set\<close>
assumes monotonicity_L:     \<open>A \<subseteq> B \<Longrightarrow> Cn(A) \<subseteq> Cn(B)\<close>
    and inclusion_L:        \<open>A \<subseteq> Cn(A)\<close>
    and transitivity_L:     \<open>Cn(Cn(A)) \<subseteq> Cn(A)\<close>

\<comment> \<open>
  Short notation for ``@{term \<open>\<phi>\<close>} can be inferred from the propositions in @{term \<open>A\<close>}''.
\<close>
fixes infer::\<open>'a set \<Rightarrow> 'a \<Rightarrow> bool\<close>  (infix \<open>\<turnstile>\<close> 50)
defines \<open>A \<turnstile> \<phi> \<equiv> \<phi> \<in> Cn(A)\<close>

\<comment> \<open>
  @{term \<open>\<phi>\<close>} is valid (a tautology) if it can be inferred from nothing.
\<close>
fixes valid::\<open>'a \<Rightarrow> bool\<close>            (\<open>\<tturnstile>\<close>)
defines \<open>\<tturnstile> \<phi> \<equiv> {} \<turnstile> \<phi>\<close>

\<comment> \<open>
  @{term \<open>A \<oplus> \<phi>\<close>} is all that can be infered from  @{term \<open>A\<close>} and  @{term \<open>\<phi>\<close>}.
\<close>
fixes expansion::\<open>'a set \<Rightarrow> 'a \<Rightarrow> 'a set\<close> (infix \<open>\<oplus>\<close> 57)
defines \<open>A \<oplus> \<phi> \<equiv> Cn(A \<union> {\<phi>})\<close>

begin

lemma idempotency_L: \<open>Cn(Cn(A)) = Cn(A)\<close>
  by (simp add: inclusion_L transitivity_L subset_antisym)

lemma assumption_L: \<open>\<phi> \<in> A \<Longrightarrow> A \<turnstile> \<phi>\<close>
  using inclusion_L infer_def by blast

lemma validD_L: \<open>\<tturnstile> \<phi> \<Longrightarrow> \<phi> \<in> Cn(A)\<close>
  using monotonicity_L valid_def infer_def by fastforce

lemma valid_expansion: \<open>K = Cn(A) \<Longrightarrow> \<tturnstile> \<phi> \<Longrightarrow> K \<oplus> \<phi> = K\<close>
  by (simp add: idempotency_L insert_absorb validD_L valid_def expansion_def)

lemma transitivity2_L:
  assumes \<open>\<forall>\<phi> \<in> B. A \<turnstile> \<phi>\<close>
      and \<open>B \<turnstile> \<psi>\<close>
    shows \<open>A \<turnstile> \<psi>\<close>
proof -
  from assms(1) have \<open>B \<subseteq> Cn(A)\<close> by (simp add: infer_def subsetI)
  hence \<open>Cn(B) \<subseteq> Cn(A)\<close>  using idempotency_L monotonicity_L by blast
  moreover from assms(2) have \<open>\<psi> \<in> Cn(B)\<close> by (simp add: infer_def)
  ultimately show ?thesis using infer_def by blast
qed

lemma Cn_same: \<open>(Cn(A) = Cn(B)) \<longleftrightarrow> (\<forall>C. A \<subseteq> Cn(C) \<longleftrightarrow> B \<subseteq> Cn(C))\<close>
proof
  { assume h:\<open>Cn(A) = Cn(B)\<close>
    from h have \<open>\<forall>\<phi> \<in> B. A \<turnstile> \<phi>\<close>
      by (simp add: Tarskian_logic.assumption_L Tarskian_logic_axioms infer_def)
    moreover from h[symmetric] have \<open>\<forall>\<phi> \<in> A. B \<turnstile> \<phi>\<close>
      by (simp add: Tarskian_logic.assumption_L Tarskian_logic_axioms infer_def)
    ultimately have \<open>\<forall>C. A \<subseteq> Cn(C) \<longleftrightarrow> B \<subseteq> Cn(C)\<close>
      using h idempotency_L inclusion_L monotonicity_L by blast
  } thus \<open>Cn(A) = Cn(B) \<Longrightarrow> \<forall>C. (A \<subseteq> Cn(C)) = (B \<subseteq> Cn(C))\<close> .
next
  { assume h:\<open>\<forall>C. (A \<subseteq> Cn(C)) = (B \<subseteq> Cn(C))\<close>
    from h have \<open>(A \<subseteq> Cn(A)) = (B \<subseteq> Cn(A))\<close> and \<open>(A \<subseteq> Cn(B)) = (B \<subseteq> Cn(B))\<close> by simp+
    hence \<open>B \<subseteq> Cn(A)\<close> and \<open>A \<subseteq> Cn(B)\<close> by (simp add: inclusion_L)+
    hence \<open>Cn(A) = Cn(B)\<close>
      using idempotency_L monotonicity_L by blast
  } thus \<open>(\<forall>C. (A \<subseteq> Cn(C)) = (B \<subseteq> Cn(C))) \<Longrightarrow> Cn(A) = Cn(B)\<close> .
qed

\<comment> \<open>
The closure of the union of two consequence closures.
\<close>
lemma Cn_union: \<open>Cn(Cn(A) \<union> Cn(B)) = Cn(A \<union> B)\<close>
proof
  have \<open>Cn(Cn(A) \<union> Cn(B)) \<subseteq> Cn(Cn (A \<union> B))\<close> by (simp add: monotonicity_L)
  thus \<open>Cn(Cn(A) \<union> Cn(B)) \<subseteq> Cn(A \<union> B)\<close> by (simp add: idempotency_L)
next
  have \<open>(A \<union> B) \<subseteq> (Cn(A) \<union> Cn(B))\<close> using inclusion_L by blast
  thus \<open>Cn(A \<union> B) \<subseteq> Cn(Cn(A) \<union> Cn(B))\<close> by (simp add: monotonicity_L)
qed

\<comment> \<open>
The closure of an infinite union of consequence closures.
\<close>
lemma Cn_Union: \<open>Cn(\<Union>{Cn(B)|B. P B}) = Cn(\<Union>{B. P B})\<close> (is \<open>?A = ?B\<close>)
proof
  have \<open>?A \<subseteq> Cn ?B\<close>
    apply(rule monotonicity_L, rule Union_least, auto)
    by (metis Sup_upper in_mono mem_Collect_eq monotonicity_L)
  then show \<open>?A \<subseteq> ?B\<close>
    by (simp add: idempotency_L)
next
  show \<open>?B \<subseteq> ?A\<close>
    by (metis (mono_tags, lifting) Union_subsetI inclusion_L mem_Collect_eq monotonicity_L)
qed

\<comment> \<open>
The intersection of two closures is closed.
\<close>
lemma Cn_inter: \<open>K = Cn(A) \<inter> Cn(B) \<Longrightarrow> K = Cn(K)\<close>
proof -
  { fix K assume h:\<open>K = Cn(A) \<inter> Cn(B)\<close>
    from h have \<open>K \<subseteq> Cn(A)\<close> and \<open>K \<subseteq> Cn(B)\<close> by simp+
    hence \<open>Cn(K) \<subseteq> Cn(A)\<close> and \<open>Cn(K) \<subseteq> Cn(B)\<close> using idempotency_L monotonicity_L by blast+
    hence \<open>Cn(K) \<subseteq> Cn(A) \<inter> Cn(B)\<close> by simp
    with h have \<open>K = Cn(K)\<close> by (simp add: inclusion_L subset_antisym)
  } thus \<open>K = Cn(A) \<inter> Cn(B) \<Longrightarrow> K = Cn(K)\<close> .
qed

\<comment> \<open>
An infinite intersection of closures is closed.
\<close>
lemma Cn_Inter: \<open>K = \<Inter>{Cn(B)|B. P B} \<Longrightarrow> K = Cn(K)\<close>
proof -
  { fix K assume h:\<open>K = \<Inter>{Cn(B)|B. P B}\<close>
    from h have \<open>\<forall>B. P B \<longrightarrow> K \<subseteq> Cn(B)\<close> by blast
    hence \<open>\<forall>B. P B \<longrightarrow> Cn(K) \<subseteq> Cn(B)\<close> using idempotency_L monotonicity_L by blast
    hence \<open>Cn(K) \<subseteq> \<Inter>{Cn(B)|B. P B}\<close> by blast
    with h have \<open>K = Cn(K)\<close> by (simp add: inclusion_L subset_antisym)
  } thus \<open>K = \<Inter>{Cn(B)|B. P B} \<Longrightarrow> K = Cn(K)\<close> .
qed

end

subsection \<open>Supraclassical Logic\<close>

text \<open>
A Tarskian logic has only one abstract operator catching the notion of consequence. A basic case of such a logic is a \<^bold>\<open>Supraclassical\<close> logic that
is a logic with all classical propositional operators (e.g. conjunction (\<open>\<and>\<close>), implication(\<open>\<longrightarrow>\<close>), negation (\<open>\<not>\<close>) \dots ) together with their classical semantics.

We define a new locale. In order to distinguish the propositional operators of our supraclassical logic from those of Isabelle/HOL, we use dots (e.g. \<open>.\<and>.\<close> stands for conjunction).
We axiomatize the introduction and elimination rules of each operator as it is commonly established in the classical literature. As explained before,
we give priority to a complete control of our logic instead of an efficient shallow embedding in Isabelle/HOL.
\<close>

locale Supraclassical_logic = Tarskian_logic +

fixes true_PL::   \<open>'a\<close>             (\<open>\<top>\<close>)
  and false_PL::  \<open>'a\<close>             (\<open>\<bottom>\<close>)
  and imp_PL::    \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close> (infix \<open>.\<longrightarrow>.\<close> 55)
  and not_PL::    \<open>'a \<Rightarrow> 'a\<close>       (\<open>.\<not>\<close>)
  and conj_PL::   \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close> (infix \<open>.\<and>.\<close> 55)
  and disj_PL::   \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close> (infix \<open>.\<or>.\<close> 55)
  and equiv_PL::  \<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close> (infix \<open>.\<longleftrightarrow>.\<close> 55)

assumes true_PL:     \<open>A \<turnstile> \<top>\<close>

    and false_PL:    \<open>{\<bottom>} \<turnstile> p\<close>

    and impI_PL:     \<open>A \<union> {p} \<turnstile> q \<Longrightarrow> A \<turnstile> (p .\<longrightarrow>. q)\<close>
    and mp_PL:       \<open>A \<turnstile> p .\<longrightarrow>. q \<Longrightarrow> A \<turnstile> p \<Longrightarrow> A \<turnstile> q\<close>

    and notI_PL:     \<open>A \<turnstile> p .\<longrightarrow>. \<bottom> \<Longrightarrow> A \<turnstile> .\<not> p\<close>
    and notE_PL:     \<open>A \<turnstile> .\<not> p \<Longrightarrow> A \<turnstile> (p .\<longrightarrow>. \<bottom>)\<close>

    and conjI_PL:    \<open>A \<turnstile> p \<Longrightarrow> A \<turnstile> q \<Longrightarrow> A \<turnstile> (p .\<and>. q)\<close>
    and conjE1_PL:   \<open>A \<turnstile> p .\<and>. q \<Longrightarrow> A \<turnstile> p\<close>
    and conjE2_PL:   \<open>A \<turnstile> p .\<and>. q \<Longrightarrow> A \<turnstile> q\<close>

    and disjI1_PL:   \<open>A \<turnstile> p \<Longrightarrow> A \<turnstile> (p .\<or>. q)\<close>
    and disjI2_PL:   \<open>A \<turnstile> q \<Longrightarrow> A \<turnstile> (p .\<or>. q)\<close>
    and disjE_PL:    \<open>A \<turnstile> p .\<or>. q \<Longrightarrow> A \<turnstile> p .\<longrightarrow>. r \<Longrightarrow> A \<turnstile> q.\<longrightarrow>. r \<Longrightarrow> A \<turnstile> r\<close>

    and equivI_PL:   \<open>A \<turnstile> p .\<longrightarrow>. q \<Longrightarrow> A \<turnstile> q .\<longrightarrow>. p \<Longrightarrow> A \<turnstile> (p .\<longleftrightarrow>. q)\<close>
    and equivE1_PL:  \<open>A \<turnstile> p .\<longleftrightarrow>. q \<Longrightarrow> A \<turnstile> p .\<longrightarrow>. q\<close>
    and equivE2_PL:  \<open>A \<turnstile> p .\<longleftrightarrow>. q \<Longrightarrow> A \<turnstile> q .\<longrightarrow>. p\<close>

\<comment> \<open>non intuitionistic rules\<close>
    and absurd_PL:   \<open>A \<turnstile> .\<not> (.\<not> p) \<Longrightarrow> A \<turnstile> p\<close>
    and ex_mid_PL:   \<open>A \<turnstile> p .\<or>. (.\<not> p)\<close>

begin

text \<open>In the following, we will first retrieve the classical logic operators semantics coming from previous introduction and elimination rules\<close>

lemma non_consistency:
  assumes \<open>A \<turnstile> .\<not> p\<close>
      and \<open>A \<turnstile> p\<close>
    shows \<open>A \<turnstile> q\<close>
  by (metis assms(1) assms(2) false_PL mp_PL notE_PL singleton_iff transitivity2_L)

\<comment> \<open>this direct result brings directly many remarkable properties of implication (i.e. transitivity)\<close>
lemma imp_PL: \<open>A \<turnstile> p .\<longrightarrow>. q \<longleftrightarrow> A \<union> {p} \<turnstile> q\<close>
  apply (intro iffI impI_PL)
   apply(rule mp_PL[where p=p], meson UnI1 assumption_L transitivity2_L)
  using assumption_L by auto

lemma not_PL: \<open>A \<turnstile> .\<not> p \<longleftrightarrow> A \<union> {p} \<turnstile> \<bottom>\<close>
  using notE_PL notI_PL imp_PL by blast

\<comment> \<open>Classical logic result\<close>
lemma notnot_PL: \<open>A \<turnstile> .\<not> (.\<not> p) \<longleftrightarrow> A \<turnstile> p\<close>
  apply(rule iffI, simp add:absurd_PL)
  by (meson mp_PL notE_PL Un_upper1 Un_upper2 assumption_L infer_def monotonicity_L not_PL singletonI subsetD)

lemma conj_PL: \<open>A \<turnstile> p .\<and>. q \<longleftrightarrow> (A \<turnstile> p \<and> A \<turnstile> q)\<close>
  using conjE1_PL conjE2_PL conjI_PL by blast

lemma disj_PL: \<open>A \<turnstile> p .\<or>. q \<longleftrightarrow> A \<union> {.\<not> p} \<turnstile> q\<close>
proof
  assume a:\<open>A \<turnstile> p .\<or>. q\<close>
  have b:\<open>A \<turnstile> p .\<longrightarrow>. (.\<not> p .\<longrightarrow>. q)\<close>
    by (intro impI_PL) (meson Un_iff assumption_L insertI1 non_consistency)
  have c:\<open>A \<turnstile> q .\<longrightarrow>. (.\<not> p .\<longrightarrow>. q)\<close>
    by (simp add: assumption_L impI_PL)
  from a b c have \<open>A \<turnstile> .\<not> p .\<longrightarrow>. q\<close>
    by (erule_tac disjE_PL) simp_all
  then show \<open>A \<union> {.\<not> p} \<turnstile> q\<close>
    using imp_PL by blast
next
  assume a:\<open>A \<union> {.\<not> p} \<turnstile> q\<close>
  hence b:\<open>A \<turnstile> .\<not> p .\<longrightarrow>. q\<close> by (simp add: impI_PL)
  then show \<open>A \<turnstile> p .\<or>. q\<close>
    apply(rule_tac disjE_PL[OF ex_mid_PL, of A p \<open>p .\<or>. q\<close>])
    by (auto simp add: assumption_L disjI2_PL disjI1_PL impI_PL imp_PL)
qed

lemma equiv_PL:\<open>A \<turnstile> p .\<longleftrightarrow>. q \<longleftrightarrow> (A \<union> {p} \<turnstile> q \<and> A \<union> {q} \<turnstile> p)\<close>
  using imp_PL equivE1_PL equivE2_PL equivI_PL by blast

corollary valid_imp_PL:  \<open>\<tturnstile> (p .\<longrightarrow>. q) = ({p} \<turnstile> q)\<close>
      and valid_not_PL:  \<open>\<tturnstile> (.\<not> p) = ({p} \<turnstile> \<bottom>)\<close>
      and valid_conj_PL: \<open>\<tturnstile> (p .\<and>. q) = (\<tturnstile> p \<and> \<tturnstile> q)\<close>
      and valid_disj_PL: \<open>\<tturnstile> (p .\<or>. q) = ({.\<not> p} \<turnstile> q)\<close>
      and valid_equiv_PL:\<open>\<tturnstile> (p .\<longleftrightarrow>. q) = ({p} \<turnstile> q \<and> {q} \<turnstile> p)\<close>
  using imp_PL not_PL conj_PL disj_PL equiv_PL valid_def by auto

text\<open>Second, we will combine each logical operator with the consequence operator \<open>Cn\<close>: it is a trick to profit from set theory to get many essential
lemmas without complex inferences\<close>
declare infer_def[simp]

lemma nonemptyCn: \<open>Cn(A) \<noteq> {}\<close>
  using true_PL by auto

lemma Cn_true: \<open>Cn({\<top>}) = Cn({})\<close>
  using Cn_same true_PL by auto

lemma Cn_false: \<open>Cn({\<bottom>}) = UNIV\<close>
  using false_PL by auto

lemma Cn_imp:     \<open>A \<turnstile> (p .\<longrightarrow>. q) \<longleftrightarrow> Cn({q}) \<subseteq> Cn(A \<union> {p})\<close>
  and Cn_imp_bis: \<open>A \<turnstile> (p .\<longrightarrow>. q) \<longleftrightarrow> Cn(A \<union> {q}) \<subseteq> Cn(A \<union> {p})\<close>
  using Cn_same imp_PL idempotency_L inclusion_L infer_def subset_insertI by force+

lemma Cn_not: \<open>A \<turnstile> .\<not> p \<longleftrightarrow> Cn(A \<union> {p}) = UNIV\<close>
  using Cn_false Cn_imp notE_PL not_PL by fastforce

lemma Cn_conj: \<open>A \<turnstile> (p .\<and>. q) \<longleftrightarrow> Cn({p}) \<union> Cn({q}) \<subseteq> Cn(A)\<close>
  apply(intro iffI conjI_PL, frule conjE1_PL, frule conjE2_PL)
  using Cn_same Un_insert_right bot.extremum idempotency_L inclusion_L by auto

lemma Cn_conj_bis: \<open>Cn({p .\<and>. q}) = Cn({p, q})\<close>
  by (unfold Cn_same)
     (meson Supraclassical_logic.conj_PL Supraclassical_logic_axioms insert_subset)

lemma Cn_disj:     \<open>A \<turnstile> (p .\<or>. q) \<longleftrightarrow> Cn({q}) \<subseteq> Cn(A \<union> {.\<not> p})\<close>
  and Cn_disj_bis: \<open>A \<turnstile> (p .\<or>. q) \<longleftrightarrow> Cn(A \<union> {q}) \<subseteq> Cn(A \<union> {.\<not> p})\<close>
  using disj_PL Cn_same imp_PL idempotency_L inclusion_L infer_def subset_insertI by force+

lemma Cn_equiv: \<open>A \<turnstile> (p .\<longleftrightarrow>. q) \<longleftrightarrow> Cn(A \<union> {p}) = Cn(A \<union> {q})\<close>
  by (metis Cn_imp_bis equivE1_PL equivE2_PL equivI_PL set_eq_subset)

corollary valid_nonemptyCn: \<open>Cn({}) \<noteq> {}\<close>
      and valid_Cn_imp:     \<open>\<tturnstile> (p .\<longrightarrow>. q) \<longleftrightarrow> Cn({q}) \<subseteq> Cn({p})\<close>
      and valid_Cn_not:     \<open>\<tturnstile> (.\<not> p) \<longleftrightarrow> Cn({p}) = UNIV\<close>
      and valid_Cn_conj:    \<open>\<tturnstile> (p .\<and>. q) \<longleftrightarrow> Cn({p}) \<union> Cn({q}) \<subseteq> Cn({})\<close>
      and valid_Cn_disj:    \<open>\<tturnstile> (p .\<or>. q) \<longleftrightarrow> Cn({q}) \<subseteq> Cn({.\<not> p})\<close>
      and valid_Cn_equiv:   \<open>\<tturnstile> (p .\<longleftrightarrow>. q) \<longleftrightarrow> Cn({p}) = Cn({q})\<close>
  using nonemptyCn Cn_imp Cn_not Cn_conj Cn_disj Cn_equiv valid_def by auto

\<comment> \<open>Finally, we group additional lemmas that were essential in further proofs\<close>
lemma consistency: \<open>Cn({p}) \<inter> Cn({.\<not> p}) = Cn({})\<close>
proof
  { fix q
    assume \<open>{p} \<turnstile> q\<close> and \<open>{.\<not> p} \<turnstile> q\<close>
    hence "{} \<turnstile> p .\<longrightarrow>. q" and "{} \<turnstile> (.\<not> p) .\<longrightarrow>. q"
      using impI_PL by auto
    hence \<open>{} \<turnstile> q\<close>
      using ex_mid_PL by (rule_tac disjE_PL[where p=p and q=\<open>.\<not> p\<close>]) blast
  }
  then show \<open>Cn({p}) \<inter> Cn({.\<not> p}) \<subseteq> Cn({})\<close> by (simp add: subset_iff)
next
  show \<open>Cn({}) \<subseteq> Cn({p}) \<inter> Cn({.\<not> p})\<close> by (simp add: monotonicity_L)
qed

lemma Cn_notnot: \<open>Cn({.\<not> (.\<not> \<phi>)}) = Cn({\<phi>})\<close>
  by (metis (no_types, opaque_lifting) notnot_PL valid_Cn_equiv valid_equiv_PL)

lemma conj_com: \<open>A \<turnstile> p .\<and>. q \<longleftrightarrow> A \<turnstile> q .\<and>. p\<close>
  using conj_PL by auto

lemma conj_com_Cn: \<open>Cn({p .\<and>. q}) = Cn({q .\<and>. p})\<close>
  by (simp add: Cn_conj_bis insert_commute)

lemma disj_com: \<open>A \<turnstile> p .\<or>. q \<longleftrightarrow> A \<turnstile> q .\<or>. p\<close>
proof -
  { fix p q
    have \<open>A \<turnstile> p .\<or>. q \<Longrightarrow> A \<turnstile> q .\<or>. p\<close>
      apply(erule disjE_PL)
      using assumption_L disjI2_PL disjI1_PL impI_PL by auto
  }
  then show ?thesis by auto
qed

lemma disj_com_Cn: \<open>Cn({p .\<or>. q}) = Cn({q .\<or>. p})\<close>
  unfolding Cn_same using disj_com by simp

lemma imp_contrapos: \<open>A \<turnstile> p .\<longrightarrow>. q \<longleftrightarrow> A \<turnstile> .\<not> q .\<longrightarrow>. .\<not> p\<close>
  by (metis Cn_not Un_insert_left Un_insert_right imp_PL notnot_PL)

lemma equiv_negation: \<open>A \<turnstile> p .\<longleftrightarrow>. q \<longleftrightarrow> A \<turnstile> .\<not> p .\<longleftrightarrow>. .\<not> q\<close>
  using equivE1_PL equivE2_PL equivI_PL imp_contrapos by blast

lemma imp_trans: \<open>A \<turnstile> p .\<longrightarrow>.q \<Longrightarrow> A \<turnstile> q .\<longrightarrow>.r \<Longrightarrow> A \<turnstile> p .\<longrightarrow>.r\<close>
  using Cn_imp_bis by auto

lemma imp_recovery0: \<open>A \<turnstile> p .\<or>. (p .\<longrightarrow>. q)\<close>
  apply(subst disj_PL, subst imp_contrapos)
  using assumption_L impI_PL by auto

lemma imp_recovery1: \<open>A \<union> {p .\<longrightarrow>. q} \<turnstile> p \<Longrightarrow> A \<turnstile> p\<close>
  using disjE_PL[OF imp_recovery0, of A p p q] assumption_L imp_PL by auto

lemma imp_recovery2: \<open>A \<turnstile> p .\<longrightarrow>. q \<Longrightarrow> A \<turnstile> (q .\<longrightarrow>. p) .\<longrightarrow>. p \<Longrightarrow> A \<turnstile> q\<close>
  using imp_PL imp_recovery1 imp_trans by blast

lemma impI2: \<open>A \<turnstile> q \<Longrightarrow> A \<turnstile> p .\<longrightarrow>. q\<close>
  by (meson assumption_L impI_PL in_mono sup_ge1 transitivity2_L)

lemma conj_equiv: \<open>A \<turnstile> p \<Longrightarrow> A \<turnstile> ((p .\<and>. q) .\<longleftrightarrow>. q)\<close>
  by (metis Un_insert_right assumption_L conjE2_PL conjI_PL equiv_PL impI2 imp_PL insertI1 sup_bot.right_neutral)

lemma conj_imp: \<open>A \<turnstile> (p .\<and>. q) .\<longrightarrow>. r \<longleftrightarrow> A \<turnstile> p .\<longrightarrow>. (q .\<longrightarrow>. r)\<close>
proof
  assume "A \<turnstile> (p .\<and>. q) .\<longrightarrow>. r"
  then have "Cn (A \<union> {r}) \<subseteq> Cn (A \<union> {p, q})"
    by (metis (no_types) Cn_conj_bis Cn_imp_bis Cn_union Un_insert_right sup_bot.right_neutral)
  then show \<open>A \<turnstile> p .\<longrightarrow>. (q .\<longrightarrow>. r)\<close>
    by (metis Un_insert_right impI_PL inclusion_L infer_def insert_commute insert_subset subset_eq sup_bot.right_neutral)
next
   assume "A \<turnstile> p .\<longrightarrow>. (q .\<longrightarrow>. r)"
  then have "A \<union> {p} \<union> {q} \<turnstile> r"
    using imp_PL by auto
  then show "A \<turnstile> (p .\<and>. q) .\<longrightarrow>. r"
    by (metis (full_types) Cn_conj_bis Cn_union impI_PL infer_def insert_is_Un sup_assoc)
qed

lemma conj_not_impE_PL: \<open>A \<turnstile> (p .\<and>. q) .\<longrightarrow>. r \<Longrightarrow> A \<turnstile> (p .\<and>. .\<not> q) .\<longrightarrow>. r \<Longrightarrow> A \<turnstile> p .\<longrightarrow>. r\<close>
  by (meson conj_imp disjE_PL ex_mid_PL imp_PL)

lemma disj_notE_PL: \<open>A \<turnstile> q \<Longrightarrow> A \<turnstile> p .\<or>. .\<not> q \<Longrightarrow> A \<turnstile> p\<close>
  using Cn_imp Cn_imp_bis Cn_not disjE_PL notnot_PL by blast

lemma disj_not_impE_PL: \<open>A \<turnstile> (p .\<or>. q) .\<longrightarrow>. r \<Longrightarrow> A \<turnstile> (p .\<or>. .\<not> q) .\<longrightarrow>. r \<Longrightarrow> A \<turnstile> r\<close>
  by (metis Un_insert_right disjE_PL disj_PL disj_com ex_mid_PL insert_commute sup_bot.right_neutral)

lemma imp_conj: \<open>A \<turnstile> p .\<longrightarrow>. q \<Longrightarrow> A \<turnstile> r .\<longrightarrow>. s \<Longrightarrow> A \<turnstile> (p .\<and>. r) .\<longrightarrow>. (q .\<and>. s)\<close>
  apply(intro impI_PL conjI_PL, unfold imp_PL[symmetric])
  by (meson assumption_L conjE1_PL conjE2_PL imp_trans infer_def insertI1 validD_L valid_imp_PL)+

lemma conj_overlap: \<open>A \<turnstile> (p .\<and>. q) \<longleftrightarrow> A \<turnstile> (p .\<and>. ((.\<not> p) .\<or>. q))\<close>
  by (meson conj_PL disjI2_PL disj_com disj_notE_PL)

lemma morgan: \<open>A \<turnstile> .\<not> (p .\<and>. q) \<longleftrightarrow> A \<turnstile> (.\<not> p) .\<or>. (.\<not> q)\<close>
  by (meson conj_imp disj_PL disj_com imp_PL imp_contrapos notE_PL notI_PL)

lemma conj_superexpansion1: \<open>A \<turnstile> .\<not> (p .\<and>. q) .\<and>. .\<not> p \<longleftrightarrow> A \<turnstile> .\<not> p\<close>
  using conj_PL disjI1_PL morgan by auto

lemma conj_superexpansion2: \<open>A \<turnstile> (p .\<or>. q) .\<and>. p \<longleftrightarrow> A \<turnstile> p\<close>
  using conj_PL disjI1_PL by auto

end

subsection \<open>Compact Logic\<close>
text\<open>If the logic is compact, which means that any result is based on a finite set of hypothesis\<close>
locale Compact_logic = Tarskian_logic +
  assumes compactness_L: \<open>A \<turnstile> \<phi> \<Longrightarrow> (\<exists>A'. A'\<subseteq> A \<and> finite A' \<and> A'\<turnstile> \<phi>)\<close>

begin

text \<open>Very important lemma preparing the application of the Zorn's lemma. It states that in a compact logic, we can not deduce \<open>\<phi>\<close>
if we accumulate an infinity of hypothesis groups which locally do not deduce phi\<close>
lemma chain_closure: \<open>\<not> \<tturnstile> \<phi> \<Longrightarrow> subset.chain {B. \<not> B \<turnstile> \<phi>} C \<Longrightarrow> \<not> \<Union>C \<turnstile> \<phi>\<close>
proof
  assume a:\<open>subset.chain {B. \<not> B \<turnstile> \<phi>} C\<close> and b:\<open>\<not> \<tturnstile> \<phi>\<close> and \<open>\<Union> C \<turnstile> \<phi>\<close>
  then obtain A' where c:\<open>A'\<subseteq> \<Union> C\<close> and d:\<open>finite A'\<close>  and e:\<open>A' \<turnstile> \<phi>\<close> using compactness_L by blast
  define f where f:\<open>f \<equiv> \<lambda>a. SOME B. B \<in> C \<and> a \<in> B\<close>
  have g:\<open>finite (f ` A')\<close> using f d by simp
  have h:\<open>(f ` A') \<subseteq> C\<close>
    unfolding f by auto (metis (mono_tags, lifting) Union_iff c someI_ex subset_eq)
  have i:\<open>subset.chain {B. \<not> B \<turnstile> \<phi>} (f ` A')\<close> using a h
    using a h by (meson subsetD subset_chain_def subset_trans)
  have \<open>A' \<noteq> {} \<Longrightarrow> \<Union> (f ` A') \<in> {B. \<not> B \<turnstile> \<phi>}\<close> using g i
    by (meson Union_in_chain image_is_empty subset_chain_def subset_eq)
  hence j:\<open>A' \<noteq> {} \<Longrightarrow> \<not> \<Union>(f ` A') \<turnstile> \<phi>\<close> by simp
  have \<open>A' \<subseteq> \<Union>(f ` A')\<close>
    unfolding f by auto (metis (no_types, lifting) Union_iff c someI_ex subset_iff)
  with j e b show False
    by (metis infer_def monotonicity_L subsetD valid_def)
qed

end

end


(*  Title:      HOL/Imperative_HOL/ex/Imperative_Reverse.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section \<open>An imperative in-place reversal on arrays\<close>

theory Imperative_Reverse
imports Subarray "~~/src/HOL/Imperative_HOL/Imperative_HOL"
begin

fun swap :: "'a::heap array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "swap a i j = do {
     x \<leftarrow> Array.nth a i;
     y \<leftarrow> Array.nth a j;
     Array.upd i y a;
     Array.upd j x a;
     return ()
   }"

fun rev :: "'a::heap array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "rev a i j = (if (i < j) then do {
     swap a i j;
     rev a (i + 1) (j - 1)
   }
   else return ())"

declare swap.simps [simp del] rev.simps [simp del]

lemma swap_pointwise: assumes "effect (swap a i j) h h' r"
  shows "Array.get h' a ! k = (if k = i then Array.get h a ! j
      else if k = j then Array.get h a ! i
      else Array.get h a ! k)"
using assms unfolding swap.simps
by (elim effect_elims)
 (auto simp: length_def)

lemma rev_pointwise: assumes "effect (rev a i j) h h' r"
  shows "Array.get h' a ! k = (if k < i then Array.get h a ! k
      else if j < k then Array.get h a ! k
      else Array.get h a ! (j - (k - i)))" (is "?P a i j h h'")
using assms proof (induct a i j arbitrary: h h' rule: rev.induct)
  case (1 a i j h h'')
  thus ?case
  proof (cases "i < j")
    case True
    with 1[unfolded rev.simps[of a i j]]
    obtain h' where
      swp: "effect (swap a i j) h h' ()"
      and rev: "effect (rev a (i + 1) (j - 1)) h' h'' ()"
      by (auto elim: effect_elims)
    from rev 1 True
    have eq: "?P a (i + 1) (j - 1) h' h''" by auto

    have "k < i \<or> i = k \<or> (i < k \<and> k < j) \<or> j = k \<or> j < k" by arith
    with True show ?thesis
      by (elim disjE) (auto simp: eq swap_pointwise[OF swp])
  next
    case False
    with 1[unfolded rev.simps[of a i j]]
    show ?thesis
      by (cases "k = j") (auto elim: effect_elims)
  qed
qed

lemma rev_length:
  assumes "effect (rev a i j) h h' r"
  shows "Array.length h a = Array.length h' a"
using assms
proof (induct a i j arbitrary: h h' rule: rev.induct)
  case (1 a i j h h'')
  thus ?case
  proof (cases "i < j")
    case True
    with 1[unfolded rev.simps[of a i j]]
    obtain h' where
      swp: "effect (swap a i j) h h' ()"
      and rev: "effect (rev a (i + 1) (j - 1)) h' h'' ()"
      by (auto elim: effect_elims)
    from swp rev 1 True show ?thesis
      unfolding swap.simps
      by (elim effect_elims) fastforce
  next
    case False
    with 1[unfolded rev.simps[of a i j]]
    show ?thesis
      by (auto elim: effect_elims)
  qed
qed

lemma rev2_rev': assumes "effect (rev a i j) h h' u"
  assumes "j < Array.length h a"
  shows "subarray i (j + 1) a h' = List.rev (subarray i (j + 1) a h)"
proof -
  {
    fix k
    assume "k < Suc j - i"
    with rev_pointwise[OF assms(1)] have "Array.get h' a ! (i + k) = Array.get h a ! (j - k)"
      by auto
  }
  with assms(2) rev_length[OF assms(1)] show ?thesis
  unfolding subarray_def Array.length_def
  by (auto simp add: length_sublist' rev_nth min_def nth_sublist' intro!: nth_equalityI)
qed

lemma rev2_rev:
  assumes "effect (rev a 0 (Array.length h a - 1)) h h' u"
  shows "Array.get h' a = List.rev (Array.get h a)"
  using rev2_rev'[OF assms] rev_length[OF assms] assms
    by (cases "Array.length h a = 0", auto simp add: Array.length_def
      subarray_def rev.simps[where j=0] elim!: effect_elims)
  (drule sym[of "List.length (Array.get h a)"], simp)

definition "example = (Array.make 10 id \<bind> (\<lambda>a. rev a 0 9))"

export_code example checking SML SML_imp OCaml? OCaml_imp? Haskell? Scala Scala_imp

end


theory Sulzmann
  imports "Lexer"
begin

section {* Bit-Encodings *}

datatype bit = Z | S

fun
  code :: "val \<Rightarrow> bit list"
where
  "code Void = []"
| "code (Char c) = []"
| "code (Left v) = Z # (code v)"
| "code (Right v) = S # (code v)"
| "code (Seq v1 v2) = (code v1) @ (code v2)"
| "code (Stars []) = [S]"
| "code (Stars (v # vs)) =  (Z # code v) @ code (Stars vs)"

fun
  Stars_add :: "val \<Rightarrow> val \<Rightarrow> val"
where
  "Stars_add v (Stars vs) = Stars (v # vs)"

function
  decode' :: "bit list \<Rightarrow> rexp \<Rightarrow> (val * bit list)"
where
  "decode' ds ZERO = (Void, [])"
| "decode' ds ONE = (Void, ds)"
| "decode' ds (CHAR d) = (Char d, ds)"
| "decode' [] (ALT r1 r2) = (Void, [])"
| "decode' (Z # ds) (ALT r1 r2) = (let (v, ds') = decode' ds r1 in (Left v, ds'))"
| "decode' (S # ds) (ALT r1 r2) = (let (v, ds') = decode' ds r2 in (Right v, ds'))"
| "decode' ds (SEQ r1 r2) = (let (v1, ds') = decode' ds r1 in
                             let (v2, ds'') = decode' ds' r2 in (Seq v1 v2, ds''))"
| "decode' [] (STAR r) = (Void, [])"
| "decode' (S # ds) (STAR r) = (Stars [], ds)"
| "decode' (Z # ds) (STAR r) = (let (v, ds') = decode' ds r in
                                    let (vs, ds'') = decode' ds' (STAR r)
                                    in (Stars_add v vs, ds''))"
by pat_completeness auto

lemma decode'_smaller:
  assumes "decode'_dom (ds, r)"
  shows "length (snd (decode' ds r)) \<le> length ds"
using assms
apply(induct ds r)
apply(auto simp add: decode'.psimps split: prod.split)
using dual_order.trans apply blast
by (meson dual_order.trans le_SucI)

termination "decode'"
apply(relation "inv_image (measure(%cs. size cs) <*lex*> measure(%s. size s)) (%(ds,r). (r,ds))")
apply(auto dest!: decode'_smaller)
by (metis less_Suc_eq_le snd_conv)

definition
  decode :: "bit list \<Rightarrow> rexp \<Rightarrow> val option"
where
  "decode ds r \<equiv> (let (v, ds') = decode' ds r
                  in (if ds' = [] then Some v else None))"

lemma decode'_code_Stars:
  assumes "\<forall>v\<in>set vs. \<Turnstile> v : r \<and> (\<forall>x. decode' (code v @ x) r = (v, x)) \<and> flat v \<noteq> []"
  shows "decode' (code (Stars vs) @ ds) (STAR r) = (Stars vs, ds)"
  using assms
  apply(induct vs)
  apply(auto)
  done

lemma decode'_code:
  assumes "\<Turnstile> v : r"
  shows "decode' ((code v) @ ds) r = (v, ds)"
using assms
  apply(induct v r arbitrary: ds)
  apply(auto)
  using decode'_code_Stars by blast

lemma decode_code:
  assumes "\<Turnstile> v : r"
  shows "decode (code v) r = Some v"
  using assms unfolding decode_def
  by (smt append_Nil2 decode'_code old.prod.case)

datatype arexp =
  AZERO
| AONE "bit list"
| ACHAR "bit list" char
| ASEQ "bit list" arexp arexp
| AALT "bit list" arexp arexp
| ASTAR "bit list" arexp

fun fuse :: "bit list \<Rightarrow> arexp \<Rightarrow> arexp" where
  "fuse bs AZERO = AZERO"
| "fuse bs (AONE cs) = AONE (bs @ cs)"
| "fuse bs (ACHAR cs c) = ACHAR (bs @ cs) c"
| "fuse bs (AALT cs r1 r2) = AALT (bs @ cs) r1 r2"
| "fuse bs (ASEQ cs r1 r2) = ASEQ (bs @ cs) r1 r2"
| "fuse bs (ASTAR cs r) = ASTAR (bs @ cs) r"

fun intern :: "rexp \<Rightarrow> arexp" where
  "intern ZERO = AZERO"
| "intern ONE = AONE []"
| "intern (CHAR c) = ACHAR [] c"
| "intern (ALT r1 r2) = AALT [] (fuse [Z] (intern r1))
                                     (fuse [S]  (intern r2))"
| "intern (SEQ r1 r2) = ASEQ [] (intern r1) (intern r2)"
| "intern (STAR r) = ASTAR [] (intern r)"

fun retrieve :: "arexp \<Rightarrow> val \<Rightarrow> bit list" where
  "retrieve (AONE bs) Void = bs"
| "retrieve (ACHAR bs c) (Char d) = bs"
| "retrieve (AALT bs r1 r2) (Left v) = bs @ retrieve r1 v"
| "retrieve (AALT bs r1 r2) (Right v) = bs @ retrieve r2 v"
| "retrieve (ASEQ bs r1 r2) (Seq v1 v2) = bs @ retrieve r1 v1 @ retrieve r2 v2"
| "retrieve (ASTAR bs r) (Stars []) = bs @ [S]"
| "retrieve (ASTAR bs r) (Stars (v#vs)) =
     bs @ [Z] @ retrieve r v @ retrieve (ASTAR [] r) (Stars vs)"

fun
  erase :: "arexp \<Rightarrow> rexp"
where
  "erase AZERO = ZERO"
| "erase (AONE _) = ONE"
| "erase (ACHAR _ c) = CHAR c"
| "erase (AALT _ r1 r2) = ALT (erase r1) (erase r2)"
| "erase (ASEQ _ r1 r2) = SEQ (erase r1) (erase r2)"
| "erase (ASTAR _ r) = STAR (erase r)"

fun
 bnullable :: "arexp \<Rightarrow> bool"
where
  "bnullable (AZERO) = False"
| "bnullable (AONE bs) = True"
| "bnullable (ACHAR bs c) = False"
| "bnullable (AALT bs r1 r2) = (bnullable r1 \<or> bnullable r2)"
| "bnullable (ASEQ bs r1 r2) = (bnullable r1 \<and> bnullable r2)"
| "bnullable (ASTAR bs r) = True"

fun
  bmkeps :: "arexp \<Rightarrow> bit list"
where
  "bmkeps(AONE bs) = bs"
| "bmkeps(ASEQ bs r1 r2) = bs @ (bmkeps r1) @ (bmkeps r2)"
| "bmkeps(AALT bs r1 r2) = (if bnullable(r1) then bs @ (bmkeps r1) else bs @ (bmkeps r2))"
| "bmkeps(ASTAR bs r) = bs @ [S]"

fun
 bder :: "char \<Rightarrow> arexp \<Rightarrow> arexp"
where
  "bder c (AZERO) = AZERO"
| "bder c (AONE bs) = AZERO"
| "bder c (ACHAR bs d) = (if c = d then AONE bs else AZERO)"
| "bder c (AALT bs r1 r2) = AALT bs (bder c r1) (bder c r2)"
| "bder c (ASEQ bs r1 r2) =
     (if bnullable r1
      then AALT bs (ASEQ [] (bder c r1) r2) (fuse (bmkeps r1) (bder c r2))
      else ASEQ bs (bder c r1) r2)"
| "bder c (ASTAR bs r) = ASEQ bs (fuse [Z] (bder c r)) (ASTAR [] r)"

fun
  bders :: "arexp \<Rightarrow> string \<Rightarrow> arexp"
where
  "bders r [] = r"
| "bders r (c#s) = bders (bder c r) s"

lemma bders_append:
  "bders r (s1 @ s2) = bders (bders r s1) s2"
  apply(induct s1 arbitrary: r s2)
  apply(simp_all)
  done

lemma bnullable_correctness:
  shows "nullable (erase r) = bnullable r"
  apply(induct r)
  apply(simp_all)
  done

lemma erase_fuse:
  shows "erase (fuse bs r) = erase r"
  apply(induct r)
  apply(simp_all)
  done

lemma erase_intern[simp]:
  shows "erase (intern r) = r"
  apply(induct r)
  apply(simp_all add: erase_fuse)
  done

lemma erase_bder[simp]:
  shows "erase (bder a r) = der a (erase r)"
  apply(induct r)
  apply(simp_all add: erase_fuse bnullable_correctness)
  done

lemma erase_bders[simp]:
  shows "erase (bders r s) = ders s (erase r)"
  apply(induct s arbitrary: r )
  apply(simp_all)
  done

lemma retrieve_encode_STARS:
  assumes "\<forall>v\<in>set vs. \<Turnstile> v : r \<and> code v = retrieve (intern r) v"
  shows "code (Stars vs) = retrieve (ASTAR [] (intern r)) (Stars vs)"
  using assms
  apply(induct vs)
  apply(simp_all)
  done

lemma retrieve_fuse2:
  assumes "\<Turnstile> v : (erase r)"
  shows "retrieve (fuse bs r) v = bs @ retrieve r v"
  using assms
  apply(induct r arbitrary: v bs)
  using retrieve_encode_STARS
  apply(auto elim!: Prf_elims)
  apply(case_tac vs)
  apply(simp)
  apply(simp)
  done

lemma retrieve_fuse:
  assumes "\<Turnstile> v : r"
  shows "retrieve (fuse bs (intern r)) v = bs @ retrieve (intern r) v"
  using assms
  by (simp_all add: retrieve_fuse2)

lemma retrieve_code:
  assumes "\<Turnstile> v : r"
  shows "code v = retrieve (intern r) v"
  using assms
  apply(induct v r)
  apply(simp_all add: retrieve_fuse retrieve_encode_STARS)
  done

lemma bmkeps_retrieve:
  assumes "nullable (erase r)"
  shows "bmkeps r = retrieve r (mkeps (erase r))"
  using assms
  apply(induct r)
  apply(auto simp add: bnullable_correctness)
  done

lemma bder_retrieve:
  assumes "\<Turnstile> v : der c (erase r)"
  shows "retrieve (bder c r) v = retrieve r (injval (erase r) c v)"
  using assms
  apply(induct r arbitrary: v)
  apply(auto elim!: Prf_elims simp add: retrieve_fuse2 bnullable_correctness bmkeps_retrieve)
  done

lemma MAIN_decode:
  assumes "\<Turnstile> v : ders s r"
  shows "Some (flex r id s v) = decode (retrieve (bders (intern r) s) v) r"
  using assms
proof (induct s arbitrary: v rule: rev_induct)
  case Nil
  have "\<Turnstile> v : ders [] r" by fact
  then have "\<Turnstile> v : r" by simp
  then have "Some v = decode (retrieve (intern r) v) r"
    using decode_code retrieve_code by auto
  then show "Some (flex r id [] v) = decode (retrieve (bders (intern r) []) v) r"
    by simp
next
  case (snoc c s v)
  have IH: "\<And>v. \<Turnstile> v : ders s r \<Longrightarrow>
     Some (flex r id s v) = decode (retrieve (bders (intern r) s) v) r" by fact
  have asm: "\<Turnstile> v : ders (s @ [c]) r" by fact
  then have asm2: "\<Turnstile> injval (ders s r) c v : ders s r"
    by(simp add: Prf_injval ders_append)
  have "Some (flex r id (s @ [c]) v) = Some (flex r id s (injval (ders s r) c v))"
    by (simp add: flex_append)
  also have "... = decode (retrieve (bders (intern r) s) (injval (ders s r) c v)) r"
    using asm2 IH by simp
  also have "... = decode (retrieve (bder c (bders (intern r) s)) v) r"
    using asm by(simp_all add: bder_retrieve ders_append)
  finally show "Some (flex r id (s @ [c]) v) =
                 decode (retrieve (bders (intern r) (s @ [c])) v) r" by (simp add: bders_append)
qed

definition blexer where
 "blexer r s \<equiv> if bnullable (bders (intern r) s) then
                decode (bmkeps (bders (intern r) s)) r else None"

lemma blexer_correctness:
  shows "blexer r s = lexer r s"
proof -
  { define bds where "bds \<equiv> bders (intern r) s"
    define ds  where "ds \<equiv> ders s r"
    assume asm: "nullable ds"
    have era: "erase bds = ds"
      unfolding ds_def bds_def by simp
    have mke: "\<Turnstile> mkeps ds : ds"
      using asm by (simp add: mkeps_nullable)
    have "decode (bmkeps bds) r = decode (retrieve bds (mkeps ds)) r"
      using bmkeps_retrieve
      using asm era by (simp add: bmkeps_retrieve)
    also have "... =  Some (flex r id s (mkeps ds))"
      using mke by (simp_all add: MAIN_decode ds_def bds_def)
    finally have "decode (bmkeps bds) r = Some (flex r id s (mkeps ds))"
      unfolding bds_def ds_def .
  }
  then show "blexer r s = lexer r s"
    unfolding blexer_def lexer_flex
    by(auto simp add: bnullable_correctness[symmetric])
qed

unused_thms

end