theory goal
	imports "invGen"
begin

(*The safety property to prove.*)
definition safeProp :: fform where
"safeProp == (plant_v1_1 [+] Real 2) [<] Real 0.05 [&] (plant_v1_1 [+] Real 2) [>] Real -0.05"

(*The system clock is always positive.*)
axiomatization where
Clock : "|-t [>=] Real 0"

(*Some lemmas to be used in proving goal.*)
lemma constraint0a: "close(Inv) |- Inv"
apply (simp add: Inv_def equal_greater_def)
apply (rule Trans1, auto)
done

lemma constraint0b: "~ inPairForm
       ([(t, Real 0)],
        substF
         ([(control_1,
            plant_m1_1 [*]
            (Real 811 / 500 [-]
             Real 1 / 100 [*]
             (control_1 [**] plant_m1_1 [-] Real 811 / 500) [-]
             Real 3 / 5 [*] (plant_v1_1 [+] Real 2)))],
          Inv [&] t[=](Real 0)))"
apply (simp add: t_def control_1_def Inv_def equal_greater_def)
done

lemma constraint0c: "~ inPairForm
       ([(control_1,
          plant_m1_1 [*]
          (Real 811 / 500 [-]
           Real 1 / 100 [*] (control_1 [**] plant_m1_1 [-] Real 811 / 500) [-]
           Real 3 / 5 [*] (plant_v1_1 [+] Real 2)))],
        Inv [&] t [=] Real 0)"
apply (simp add: t_def control_1_def Inv_def equal_greater_def)
done

(*The following lists the constraints for solving the differential invariants for the
differential equations.*)
(*The invariant guarantees the postcondition.*)
definition cons1 :: fform where "cons1 \<equiv> ((t [>=] Real 0 [&] t [<=] Real 0.128 [&] Inv) [-->]  safeProp)"
(*Initialization:the initial state guarantees the invariant;
and Computation: the computation guarantees the invariant.*)
definition cons2 :: fform where "cons2 \<equiv> ((plant_v1_1[=](Real -2) [&] plant_m1_1[=](Real 1250) [&] control_1[=](Real 4055/2) [&] t[=](Real 0)) [-->] Inv)"
definition cons3 :: fform where "cons3 \<equiv> (((t[=](Real 16/125)) [&] Inv) [-->] (substF([(t, Real 0)], substF
        ([(control_1,
           plant_m1_1 [*]
           (Real 811 / 500 [-]
            Real 1 / 100 [*]
            (control_1 [**] plant_m1_1 [-]
             Real 811 / 500) [-]
            Real 3 / 5 [*] (plant_v1_1 [+] Real 2)))],
         Inv))))"
(*The core parts: the differential equations garantee the invariants. *)
definition cons4 :: fform where "cons4 \<equiv>  exeFlow(%''plant_v1_1, plant_m1_1, plant_r1_1, plant_t'',''(control_1/plant_m1_1) - 1.622, -(control_1/2548), plant_v1_1, 1''%,t [<] (Real 0.128), Inv)  [-->]  Inv"
definition cons5 :: fform where "cons5 \<equiv>  exeFlow(%''plant_v1_1, plant_m1_1, plant_r1_1, plant_t'',''(control_1/plant_m1_1) - 1.622, -(control_1/2842), plant_v1_1, 1''%, t [<] (Real 0.128),Inv) [-->]  Inv"

(*Put this whole constraint to the differential invariant generator.*)
lemma allCons: "|- cons1 [&] cons2 [&] cons3 [&] cons4 [&] cons5"
apply (simp add: cons1_def)
apply (simp add: cons2_def)
apply (simp add: cons3_def)
apply (simp add: cons4_def)
apply (simp add: cons5_def)
apply (simp add: safeProp_def)
apply (simp add: t_def)
apply (simp add: plant_v1_1_def)
apply (simp add: plant_m1_1_def)
apply (simp add: control_1_def)
(*apply inv_oracle_SOS
done
*)
(**You can uncomment the above lines, if you have  Mathematica, Matlab, Yalmip and SDPT3 installed. "Sorry" will go away.**)
sorry

lemma constraint11: "t [>=] Real 0 [&] t [<=] Real 16 / 125 [&] Inv |- safeProp"
apply (rule backwards_impR)
apply (cut_tac allCons)
apply (simp add:cons1_def)
apply (rule conjunct1, auto)
done

lemma constraint1: "t [<=] Real 16 / 125 [&] Inv |- safeProp"
apply (cut_tac P = "t [>=] Real 0 [&] t [<=] Real 16 / 125 [&] Inv" in cut, auto)
apply (rule thinR, rule conjR, rule thinL)
apply (rule Clock)
apply fast
apply (rule thinL, rule constraint11)
done

lemma constraint2: "(plant_v1_1[=](Real -2) [&] plant_m1_1[=](Real 1250) [&] control_1[=](Real 4055/2) [&] t[=](Real 0)) |- Inv"
apply (rule backwards_impR)
apply (subgoal_tac "|- cons2 [&] cons3 [&] cons4 [&] cons5")
apply (simp add:cons2_def)
apply (rule conjunct1, auto)
apply (cut_tac allCons)
apply (rule conjunct2, auto)
done

lemma constraint3: "(t[=](Real 16/125)) [&] Inv |- substF([(t, Real 0)], substF
        ([(control_1,
           plant_m1_1 [*]
           (Real 811 / 500 [-]
            Real 1 / 100 [*]
            (control_1 [**] plant_m1_1 [-]
             Real 811 / 500) [-]
            Real 3 / 5 [*] (plant_v1_1 [+] Real 2)))],
         Inv))"
apply (rule backwards_impR)
apply (subgoal_tac "|- cons3 [&] cons4 [&] cons5")
apply (simp add:cons3_def)
apply (rule conjunct1, auto)
apply (cut_tac allCons)
apply (rule conjunct2)
apply (rule conjunct2)
apply assumption
done

lemma constraint4: " exeFlow(%''plant_v1_1, plant_m1_1, plant_r1_1, plant_t'',''(control_1/plant_m1_1) - 1.622, -(control_1/2548), plant_v1_1, 1''%, t [<] (Real 16/125),Inv) |- Inv"
apply (rule backwards_impR)
apply (subgoal_tac "|- cons4 [&] cons5")
apply (simp add:cons4_def)
apply (rule conjunct1, auto)
apply (cut_tac allCons)
apply (rule conjunct2)
apply (rule conjunct2)
apply (rule conjunct2)
apply assumption
done

lemma constraint5: " exeFlow(%''plant_v1_1, plant_m1_1, plant_r1_1, plant_t'',''(control_1/plant_m1_1) - 1.622, -(control_1/2842), plant_v1_1, 1''%, t [<] (Real 16/125), Inv) |- Inv"
apply (rule backwards_impR)
apply (subgoal_tac "|- cons5")
apply (simp add:cons5_def)
apply (cut_tac allCons)
apply (rule conjunct2)
apply (rule conjunct2)
apply (rule conjunct2)
apply (rule conjunct2)
apply assumption
done

(*Goal for the whole process.*)
lemma goal : "{WTrue} PP {safeProp; (l[=](Real 0) [|] (high safeProp))}"
(*mono*)
apply (cut_tac px="WTrue" and qx="t [<=] Real 16 / 125 [&] Inv" and Hx="(l[=](Real 0)) [^] (l[=](Real 0) [|] (high (t [<=] Real 16 / 125 [&] Inv)))" in ConsequenceS,auto)
prefer 2
apply (rule conjR, rule impR, rule basic)
apply (rule conjR, rule impR, rule constraint1)
apply (rule impR, rule LL3a)
apply (rule disjL, rule disjR, rule basic)
apply (rule disjR, rule thinR, cut_tac Q="safeProp" in DCM, auto)
apply (rule basic)
apply (rule constraint1)
(*separate into intialization and repetitive control*)
apply (simp add: PP_def)
apply (simp add: assertion6_def)
apply (rule Sequence)
(*Init*)
apply (simp add: assertion4_def assertion2_def)
apply (cut_tac px="WTrue" and qx="(plant_v1_1[=](Real -2) [&] plant_m1_1[=](Real 1250) [&] control_1[=](Real 2027.5) [&] t[=](Real 0))" and Hx="(l[=](Real 0)) [^] (l[=](Real 0))" in ConsequenceS,auto)
prefer 2
apply (rule conjR, rule impR, rule basic)+
apply (rule impR, rule LL4, rule basic)
apply (rule Sequence)
apply (simp add: PC_Init_def assertion1_def assertion2_def)
apply (cut_tac px="WTrue" and qx="(plant_v1_1[=](Real -2) [&] plant_m1_1[=](Real 1250))" and Hx="(l[=](Real 0)) [^] (l[=](Real 0))" in ConsequenceS,auto)
prefer 2
apply (rule conjR, rule impR, rule basic)+
apply (rule impR, rule LL4, rule basic)
apply (rule Sequence)
apply (rule Assign)
apply (simp add: plant_v1_1_def)
apply (simp add: plant_v1_1_def, rule Trans, auto)
apply (cut_tac px="plant_v1_1[=](Real -2)" and qx="(plant_v1_1[=](Real -2) [&] plant_m1_1[=](Real 1250))" and Hx="(l[=](Real 0)) [^] (l[=](Real 0))" in ConsequenceS,auto)
prefer 2
apply (rule conjR, rule impR, rule basic)+
apply (rule impR, rule LL4, rule basic)
apply (rule Sequence)
apply (rule Assign)
apply (simp add: plant_v1_1_def)
apply (simp add: plant_v1_1_def plant_m1_1_def, rule Trans, auto)
apply (rule Assign)
apply (simp add: plant_v1_1_def plant_m1_1_def plant_r1_1_def)
apply (simp add: plant_v1_1_def plant_m1_1_def plant_r1_1_def, rule Trans, auto)
apply (simp add: PD_Init_def assertion5_def)
apply (cut_tac px="(plant_v1_1[=](Real -2) [&] plant_m1_1[=](Real 1250))" and qx="(plant_v1_1[=](Real -2) [&] plant_m1_1[=](Real 1250) [&] control_1[=](Real 2027.5) [&] t[=](Real 0))" and Hx="(l[=](Real 0)) [^] (l[=](Real 0))" in ConsequenceS,auto)
prefer 2
apply (rule conjR, rule impR, rule basic)+
apply (rule impR, rule LL4, rule basic)
apply (rule Sequence)
apply (rule Assign)
apply (simp add: plant_v1_1_def plant_m1_1_def plant_r1_1_def control_1_def)
apply (simp add: plant_v1_1_def plant_m1_1_def plant_r1_1_def control_1_def, rule Trans, auto)
apply (rule Assign)
apply (simp add: plant_v1_1_def plant_m1_1_def plant_r1_1_def control_1_def t_def)
apply (simp add: plant_v1_1_def plant_m1_1_def plant_r1_1_def control_1_def t_def, rule Trans, auto)
(*Rep*)
apply (cut_tac px="Inv [&] t[=](Real 0) [&] t [<=] Real 16 / 125" and qx="Inv [&] t[=](Real 0) [&] t [<=] Real 16 / 125" and Hx="(l[=](Real 0) [|] (high (t [<=] Real 16 / 125 [&] Inv)))" in ConsequenceS,auto)
prefer 2
apply (rule conjR, rule impR)
apply (rule conjR, rule constraint2)
apply (rule conjL)+ apply (rule thinL, rule thinL, rule thinL)
apply (simp add:t_def equal_less_def, rule Trans1, auto)
apply (rule conjR) apply fast
apply fast
apply (rule Rep)
prefer 2
apply (rule impR, rule LT1, rule LL3a, rule basic)
apply (rule LT1a, rule LL4, rule disjR, rule basic)
apply (rule disjR, rule thinR)
apply (rule DCR3, rule basic)
(*core of Rep*)
(*seperate Rep into two parts,
the first part is a sequence of differential equations,
the second part is a sequence of control which does not consume any time.*)
apply (cut_tac px="Inv [&] t[=](Real 0)  [&] t [<=] Real 16 / 125"
   and qx="Inv [&] t[=](Real 0) [&] t [<=] Real 16 / 125" and
     Hx="((l[=](Real 0) [|] (high (t [<=] Real 16 / 125 [&] Inv)))) [^] (l[=](Real 0))" in ConsequenceS,auto)
prefer 2
apply (rule conjR, rule impR, rule basic)+
apply (rule impR, rule LL4, rule basic)
apply (simp add: assertion7_def)
apply (rule Sequence)
(*Deal with control part*)
prefer 2
apply (cut_tac px="t[=](Real 16/125) [&] Inv" and qx="Inv [&] t[=](Real 0)" and Hx="(l[=](Real 0)) [^] (l[=](Real 0))" in ConsequenceS,auto)
prefer 2
apply (rule conjR, rule impR, rule basic)+
apply (rule conjR, rule impR, rule conjR)
apply fast apply (simp add: t_def equal_less_def, rule Trans1, auto)
apply (rule impR, rule LL4, rule basic)
apply (unfold assertion8_def)
apply (rule Sequence)
apply (rule Assign)
apply (rule constraint0b)
apply (rule conjR)
apply (subgoal_tac "((t[=](Real 16/125)) [&] Inv) |- substF([(t, Real 0)], substF
        ([(control_1,
           plant_m1_1 [*]
           (Real 811 / 500 [-]
            Real 1 / 100 [*]
            (control_1 [**] plant_m1_1 [-]
             Real 811 / 500) [-]
            Real 3 / 5 [*] (plant_v1_1 [+] Real 2)))],
         Inv))")
prefer 2
apply (rule constraint3)
apply (simp add: t_def control_1_def)
apply (rule impR, rule conjR, simp)
apply (rule thinL, rule Trans, simp)
apply (rule impR, rule basic)
apply (simp add: PD_Rep_def)
apply (rule Assign)
apply (rule constraint0c)
apply (simp add: t_def control_1_def)
apply (rule conjR, rule impR, rule basic)
apply (rule impR, rule basic)
apply (simp add: PC_Difff_def)
apply (cut_tac px="Inv [&] t[=](Real 0) [&] t [<=] Real 16 / 125" and qx="(t[=](Real 16/125))[&]Inv" and Hx="((l[=](Real 0) [|] (high (t [<=] Real 16 / 125 [&] Inv)))) [^] (l[=](Real 0) [|] (high (t [<=] Real 16 / 125 [&] Inv)))" in ConsequenceS,auto)
prefer 2
apply (rule conjR, rule impR, rule basic)+
apply (rule impR, rule LT1, rule LL3a, rule basic)
apply (rule LT1a, rule LL4, rule disjR, rule basic)
apply (rule disjR, rule thinR)
apply (rule DCR3, rule basic)
(*Deal with plant part*)
apply (cut_tac b="control_1[>](Real 3000)" in Case, auto)
apply (cut_tac m="control_1[>](Real 3000) [&] t[=](Real 0.128) [&] Inv" and H="((l[=](Real 0) [|] (high (t [<=] Real 16 / 125 [&] Inv))))" in Sequence1, auto)
(*1*)
apply (simp add: PC_Diff11_def)
apply (rule Continue2T)
apply (rule conjR, rule impR)
apply (simp add: Inv1_def t_def, rule Trans1, auto)
apply (rule conjR, rule impR)
apply (rule conjR, simp add: Inv1_def t_def control_1_def, rule Trans1, auto)+
apply (cut_tac P="close(Inv)" in cut, auto)
apply (rule conjL)+
apply (simp add: Inv1_def, rule basic)
apply (rule thinL, rule constraint0a)
apply (rule conjR, rule impR, rule conjL, rule disjL, rule disjR, rule basic)
apply (cut_tac Q="t [<=] Real 16 / 125 [&] Inv" in DCM,auto)
apply (rule disjR, rule basic, simp add:Inv1_def equal_less_def)
apply (cut_tac P="t [<=] Real 16 / 125 [&] close(Inv)" in cut, auto)
apply (simp add:equal_less_def)
apply fast apply (rule conjR) apply fast
apply (rule thinL, rule thinL, rule conjL, rule thinL)
apply (rule constraint0a)
apply (simp add:Inv1_def, rule impR)
apply (rule constraint4)
(*2*)
apply (simp add:PC_Diff22_def)
apply (rule Continue2F)
apply (rule conjR, rule impR, rule Trans1, simp add:t_def)
apply (rule conjR, rule impR) apply fast+
(*The case for control_1 [<=] Real 3000*)
apply (cut_tac m="([~]control_1[>](Real 3000) [&] t[=](Real 0)) [&] Inv" and H="((l[=](Real 0) [|] (high (t [<=] Real 16 / 125 [&] Inv))))" in Sequence1, auto)
apply (simp add:PC_Diff11_def)
apply (rule Continue2F)
apply (rule conjR) apply fast
apply (rule conjR) apply fast+
apply (simp add:PC_Diff22_def)
apply (rule Continue2T)
apply (rule conjR, rule impR)
apply (simp add:equal_less_def Inv2_def)
apply (simp add:t_def, rule Trans1, auto)
apply (rule conjR, rule impR, rule conjL, rule conjL, rule conjL, rule thinL, rule thinL)
apply (rule conjR, rule thinL, rule Trans1, simp add:t_def, auto)
apply (simp add:Inv2_def)
apply (cut_tac P="close(Inv)" in cut, auto) apply fast
apply (rule thinL, rule thinL, rule constraint0a)
apply (rule conjR, rule impR, simp add:Inv2_def)
apply (rule conjL, simp add:equal_less_def) apply (rule disjL) apply fast
apply (rule disjR, rule thinR, rule exchL, rule thinL, rule DC18) apply fast
apply (simp add:Inv2_def)
apply (rule impR, rule constraint5)
done

end


(*  Title:       Proving the Correctness of Disk Paxos

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

section "Disk Paxos Algorithm Specification"

theory DiskPaxos_Model imports Main begin

text\<open>This is the specification of the Disk Synod algorithm.\<close>

typedecl InputsOrNi
typedecl Disk
typedecl Proc

axiomatization
  Inputs :: "InputsOrNi set" and
  NotAnInput :: "InputsOrNi" and
  Ballot :: "Proc \<Rightarrow> nat set" and
  IsMajority :: "Disk set \<Rightarrow> bool"
where
  NotAnInput: "NotAnInput \<notin> Inputs" and
  InputsOrNi: "(UNIV :: InputsOrNi set) = Inputs \<union> {NotAnInput}" and
  Ballot_nzero: "\<forall>p. 0 \<notin> Ballot p" and
  Ballot_disj: "\<forall>p q. p \<noteq> q \<longrightarrow> (Ballot p) \<inter> (Ballot q) = {}" and
  Disk_isMajority: "IsMajority(UNIV)" and
  majorities_intersect:
    "\<forall>S T. IsMajority(S) \<and> IsMajority(T) \<longrightarrow> S \<inter> T \<noteq> {}"

lemma ballots_not_zero [simp]:
  "b \<in> Ballot p \<Longrightarrow> 0 < b"
proof (rule ccontr)
  assume b: "b \<in> Ballot p"
  and contr: "\<not> (0 < b)"
  from Ballot_nzero
  have "0 \<notin> Ballot p" ..
  with b contr
  show "False"
    by auto
qed

lemma majority_nonempty [simp]: "IsMajority(S) \<Longrightarrow> S \<noteq> {}"
proof(auto)
  from majorities_intersect
  have "IsMajority({}) \<and> IsMajority({}) \<longrightarrow> {} \<inter> {} \<noteq> {}"
    by auto
  thus "IsMajority {} \<Longrightarrow> False"
    by auto
qed

definition AllBallots :: "nat set"
  where "AllBallots = (UN p. Ballot p)"

record
  DiskBlock =
    mbal:: nat
    bal :: nat
    inp :: InputsOrNi

definition InitDB :: DiskBlock
  where "InitDB = \<lparr> mbal = 0, bal = 0, inp = NotAnInput \<rparr>"

record
  BlockProc =
    block :: DiskBlock
    proc  :: Proc

record
  state =
    inpt :: "Proc \<Rightarrow> InputsOrNi"
    outpt :: "Proc \<Rightarrow> InputsOrNi"
    disk :: "Disk \<Rightarrow> Proc \<Rightarrow> DiskBlock"
    dblock :: "Proc \<Rightarrow> DiskBlock"
    phase :: "Proc \<Rightarrow> nat"
    disksWritten :: "Proc \<Rightarrow> Disk set"
    blocksRead :: "Proc \<Rightarrow> Disk \<Rightarrow> BlockProc set"
  (* History Variables *)
    allInput  :: "InputsOrNi set"
    chosen    :: "InputsOrNi"

definition hasRead :: "state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> Proc \<Rightarrow> bool"
  where "hasRead s p d q = (\<exists> br \<in> blocksRead s p d. proc br = q)"

definition allRdBlks :: "state \<Rightarrow> Proc \<Rightarrow> BlockProc set"
  where "allRdBlks s p = (UN d. blocksRead s p d)"

definition allBlocksRead :: "state \<Rightarrow> Proc \<Rightarrow> DiskBlock set"
  where "allBlocksRead s p = block ` (allRdBlks s p)"

definition Init :: "state \<Rightarrow> bool"
  where
    "Init s =
      (range (inpt s) \<subseteq> Inputs
     & outpt s = (\<lambda>p. NotAnInput)
     & disk s = (\<lambda>d p. InitDB)
     & phase s = (\<lambda>p. 0)
     & dblock s = (\<lambda>p. InitDB)
     & disksWritten s = (\<lambda>p. {})
     & blocksRead s = (\<lambda>p d. {}))"

definition InitializePhase :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool"
  where
  "InitializePhase s s' p =
    (disksWritten s' = (disksWritten s)(p := {})
   & blocksRead s' = (blocksRead s)(p := (\<lambda>d. {})))"

definition StartBallot :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool"
where
  "StartBallot s s' p =
    (phase s p \<in> {1,2}
   & phase s' = (phase s)(p := 1)
   & (\<exists>b \<in> Ballot p.
         mbal (dblock s p) < b
       & dblock s' = (dblock s)(p := (dblock s p)\<lparr> mbal := b \<rparr>))
   & InitializePhase s s' p
   & inpt s' = inpt s & outpt s' = outpt s & disk s' = disk s)"

definition Phase1or2Write :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> bool"
where
  "Phase1or2Write s s' p d =
    (phase s p \<in> {1, 2}
   \<and> disk s' = (disk s) (d := (disk s d) (p := dblock s p))
   \<and> disksWritten s' = (disksWritten s) (p:= (disksWritten s p) \<union> {d})
   \<and> inpt s' = inpt s \<and> outpt s'= outpt s
   \<and> phase s' = phase s \<and> dblock s' = dblock s
   \<and> blocksRead s'= blocksRead s)"

definition Phase1or2ReadThen :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> Proc \<Rightarrow> bool"
where
  "Phase1or2ReadThen s s' p d q =
    (d \<in> disksWritten s p
   & mbal(disk s d q) < mbal(dblock s p)
   & blocksRead s' = (blocksRead s)(p := (blocksRead s p)(d :=
                       (blocksRead s p d) \<union> {\<lparr> block = disk s d q,
                                               proc = q \<rparr>}))
   & inpt s' = inpt s & outpt s' = outpt s
   & disk s' = disk s & phase s' = phase s
   & dblock s' = dblock s & disksWritten s' = disksWritten s)"

definition Phase1or2ReadElse :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> Proc \<Rightarrow> bool"
where
  "Phase1or2ReadElse s s' p d q =
    (d \<in> disksWritten s p
   \<and> StartBallot s s' p)"

definition Phase1or2Read :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> Proc \<Rightarrow> bool"
where
  "Phase1or2Read s s' p d q =
     (Phase1or2ReadThen s s' p d q
    \<or> Phase1or2ReadElse s s' p d q)"

definition blocksSeen :: "state \<Rightarrow> Proc \<Rightarrow> DiskBlock set"
  where "blocksSeen s p = allBlocksRead s p \<union> {dblock s p}"

definition nonInitBlks :: "state \<Rightarrow> Proc \<Rightarrow> DiskBlock set"
  where"nonInitBlks s p = {bs . bs \<in> blocksSeen s p \<and> inp bs \<in> Inputs}"

definition maxBlk :: "state \<Rightarrow> Proc \<Rightarrow> DiskBlock"
where
  "maxBlk s p =
     (SOME b. b \<in> nonInitBlks s p \<and> (\<forall>c \<in> nonInitBlks s p. bal c \<le> bal b))"

definition EndPhase1 :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool"
where
  "EndPhase1 s s' p =
    (IsMajority {d . d \<in> disksWritten s p
                     \<and> (\<forall>q \<in> UNIV - {p}. hasRead s p d q)}
   \<and> phase s p = 1
   \<and> dblock s' = (dblock s) (p := dblock s p
           \<lparr> bal := mbal(dblock s p),
             inp :=
              (if nonInitBlks s p = {}
               then inpt s p
               else inp (maxBlk s p))
           \<rparr> )
   \<and> outpt s' = outpt s
   \<and> phase s' = (phase s) (p := phase s p + 1)
   \<and> InitializePhase s s' p
   \<and> inpt s' = inpt s \<and> disk s' = disk s)"

definition EndPhase2 :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool"
where
  "EndPhase2 s s' p =
    (IsMajority {d . d \<in> disksWritten s p
                     \<and> (\<forall>q \<in> UNIV - {p}. hasRead s p d q)}
   \<and> phase s p = 2
   \<and> outpt s' = (outpt s) (p:= inp (dblock s p))
   \<and> dblock s' = dblock s
   \<and> phase s' = (phase s) (p := phase s p + 1)
   \<and> InitializePhase s s' p
   \<and> inpt s' = inpt s \<and> disk s' = disk s)"

definition EndPhase1or2 :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool"
  where "EndPhase1or2 s s' p = (EndPhase1 s s' p \<or> EndPhase2 s s' p)"

definition Fail :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool"
where
  "Fail s s' p =
    (\<exists>ip \<in> Inputs. inpt s' = (inpt s) (p := ip)
   \<and> phase s' = (phase s) (p := 0)
   \<and> dblock s'= (dblock s) (p := InitDB)
   \<and> outpt s' = (outpt s) (p := NotAnInput)
   \<and> InitializePhase s s' p
   \<and> disk s'= disk s)"

definition Phase0Read :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> bool"
where
  "Phase0Read s s' p d =
    (phase s p = 0
   \<and> blocksRead s' = (blocksRead s) (p := (blocksRead s p) (d := blocksRead s p d \<union> {\<lparr> block = disk s d p, proc = p \<rparr>}))
   \<and> inpt s' = inpt s & outpt s' = outpt s
   \<and> disk s' = disk s & phase s' = phase s
   \<and> dblock s' = dblock s & disksWritten s' = disksWritten s)"

definition EndPhase0 :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool"
where
  "EndPhase0 s s' p =
    (phase s p = 0
   \<and> IsMajority ({d. hasRead s p d p})
   \<and> (\<exists>b \<in> Ballot p.
       (\<forall>r \<in> allBlocksRead s p. mbal r < b)
     \<and> dblock s' = (dblock s) ( p:=
                    (SOME r.   r \<in> allBlocksRead s p
                            \<and> (\<forall>s \<in> allBlocksRead s p. bal s \<le>  bal r)) \<lparr> mbal := b \<rparr> ))
   \<and> InitializePhase s s' p
   \<and> phase s' = (phase s) (p:= 1)
   \<and> inpt s' = inpt s \<and> outpt s' = outpt s \<and> disk s' = disk s)"

definition Next :: "state \<Rightarrow> state \<Rightarrow> bool"
where
  "Next s s' = (\<exists>p.
                  StartBallot s s' p
                \<or> (\<exists>d.   Phase0Read s s' p d
                       \<or> Phase1or2Write s s' p d
                       \<or> (\<exists>q. q \<noteq> p \<and> Phase1or2Read s s' p d q))
                \<or> EndPhase1or2 s s' p
                \<or> Fail s s' p
                \<or> EndPhase0 s s' p)"

text \<open>
  In the following, for each action or state {\em name} we name
  {\em Hname} the corresponding action that includes
  the history part of the HNext action or state predicate that includes
  history variables.
\<close>

definition HInit :: "state \<Rightarrow> bool"
where
  "HInit s =
    (Init s
   & chosen s = NotAnInput
   & allInput s = range (inpt s))"

text \<open>HNextPart is the part of the Next action
        that is concerned with history variables.
\<close>

definition HNextPart :: "state \<Rightarrow> state => bool"
where
  "HNextPart s s' =
    (chosen s' =
       (if chosen s \<noteq> NotAnInput \<or> (\<forall>p. outpt s' p = NotAnInput )
            then chosen s
            else outpt s' (SOME p. outpt s' p \<noteq> NotAnInput))
   \<and> allInput s' = allInput s \<union> (range (inpt s')))"

definition HNext :: "state \<Rightarrow> state \<Rightarrow> bool"
where
  "HNext s s' =
     (Next s s'
   \<and> HNextPart s s')"

text \<open>
  We add HNextPart to every action (rather than proving that Next
  maintains the HInv invariant) to make proofs easier.
\<close>

definition
  HPhase1or2ReadThen :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> Proc \<Rightarrow> bool" where
  "HPhase1or2ReadThen s s' p d q = (Phase1or2ReadThen s s' p d q \<and> HNextPart s s')"

definition
  HEndPhase1 :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool" where
  "HEndPhase1 s s' p = (EndPhase1 s s' p \<and> HNextPart s s')"

definition
  HStartBallot :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool" where
  "HStartBallot s s' p = (StartBallot s s' p \<and> HNextPart s s')"

definition
  HPhase1or2Write :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> bool" where
  "HPhase1or2Write s s' p d = (Phase1or2Write s s' p d \<and> HNextPart s s')"

definition
  HPhase1or2ReadElse :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> Proc \<Rightarrow> bool" where
  "HPhase1or2ReadElse s s' p d q = (Phase1or2ReadElse s s' p d q \<and> HNextPart s s')"

definition
  HEndPhase2 :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool" where
  "HEndPhase2 s s' p = (EndPhase2 s s' p \<and> HNextPart s s')"

definition
  HFail :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool" where
  "HFail s s' p = (Fail s s' p  \<and> HNextPart s s')"

definition
  HPhase0Read :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> bool" where
  "HPhase0Read s s' p d = (Phase0Read s s' p d \<and> HNextPart s s')"

definition
  HEndPhase0 :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool" where
  "HEndPhase0 s s' p = (EndPhase0 s s' p \<and> HNextPart s s')"

text \<open>
  Since these definitions are the conjunction of two other definitions
  declaring them as simplification rules should be harmless.
\<close>

declare HPhase1or2ReadThen_def [simp]
declare HPhase1or2ReadElse_def [simp]
declare HEndPhase1_def  [simp]
declare HStartBallot_def  [simp]
declare HPhase1or2Write_def [simp]
declare HEndPhase2_def [simp]
declare HFail_def [simp]
declare HPhase0Read_def [simp]
declare HEndPhase0_def [simp]

end


theory propositional_AndIdempotent
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype ('a, 'b) Pair2 = Pair "'a" "'b"

datatype Form =  "Form" "Form" | Not "Form" | Var "int"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun or3 :: "bool list => bool" where
"or3 (Nil2) = False"
| "or3 (Cons2 y xs) = or2 y (or3 xs)"

fun null :: "'t list => bool" where
"null (Nil2) = True"
| "null (Cons2 y z) = False"

fun models4 :: "int => ((int, bool) Pair2) list => bool list" where
"models4 x (Nil2) = Nil2"
| "models4 x (Cons2 (Pair y2 True) x2) = models4 x x2"
| "models4 x (Cons2 (Pair y2 False) x2) =
     Cons2 (x = y2) (models4 x x2)"

fun models3 :: "int => ((int, bool) Pair2) list => bool list" where
"models3 x (Nil2) = Nil2"
| "models3 x (Cons2 (Pair y2 True) x2) =
     Cons2 (x = y2) (models3 x x2)"
| "models3 x (Cons2 (Pair y2 False) x2) = models3 x x2"

fun fst :: "('a, 'b) Pair2 => 'a" where
"fst (Pair y z) = y"

fun filter :: "('t => bool) => 't list => 't list" where
"filter p (Nil2) = Nil2"
| "filter p (Cons2 y z) =
     (if p y then Cons2 y (filter p z) else filter p z)"

fun dot :: "('b => 'c) => ('a => 'b) => 'a => 'c" where
"dot x y z = x (y z)"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

function models :: "Form => ((int, bool) Pair2) list =>
                  (((int, bool) Pair2) list) list"
         and
           models2 :: "Form => (((int, bool) Pair2) list) list =>
                     (((int, bool) Pair2) list) list"
         and
           models5 :: "Form => (((int, bool) Pair2) list) list =>
                     (((int, bool) Pair2) list) list =>
                     (((int, bool) Pair2) list) list" where
"models ( p q) y = models2 q (models p y)"
| "models (Not ( p2 q2)) y =
     append (models (Not p2) y) (models ( p2 (Not q2)) y)"
| "models (Not (Not p3)) y = models p3 y"
| "models (Not (Var x2)) y =
     (if ~ (or3 (models3 x2 y)) then
        Cons2
          (Cons2
             (Pair x2 False)
             (filter
                (% (x3 :: (int, bool) Pair2) =>
                   dot
                     (% (x4 :: int) => x2 ~= x4) (% (x5 :: (int, bool) Pair2) => fst x5)
                     x3)
                y))
          (Nil2)
        else
        Nil2)"
| "models (Var x6) y =
     (if ~ (or3 (models4 x6 y)) then
        Cons2
          (Cons2
             (Pair x6 True)
             (filter
                (% (x7 :: (int, bool) Pair2) =>
                   dot
                     (% (x8 :: int) => x6 ~= x8) (% (x9 :: (int, bool) Pair2) => fst x9)
                     x7)
                y))
          (Nil2)
        else
        Nil2)"
| "models2 q (Nil2) = Nil2"
| "models2 q (Cons2 y z) = models5 q z (models q y)"
| "models5 q x (Nil2) = models2 q x"
| "models5 q x (Cons2 z x2) = Cons2 z (models5 q x x2)"
by pat_completeness auto

fun valid :: "Form => bool" where
"valid x = null (models (Not x) (Nil2))"

(*hipster or2
          or3
          null
          models4
          models3
          fst
          filter
          dot
          append
          models
          models2
          models5
          valid *)

theorem x0 :
  "!! (p :: Form) . (valid ( p p)) = (valid p)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(* @LICENSE(NICTA_CORE) *)

(*  Author:     Rafal Kolanski, NICTA & UNSW

    Miscellaneous development support.
*)

theory Misc
imports
  Word_Lib.Word_Enum

begin

(* from l4v/lib/Lib: *)
definition
  pred_conj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixl "and" 35)
where
  "pred_conj P Q \<equiv> \<lambda>x. P x \<and> Q x"

definition
  pred_disj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixl "or" 30)
where
  "pred_disj P Q \<equiv> \<lambda>x. P x \<or> Q x"

definition
  pred_neg :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" ("not _" [40] 40)
where
  "pred_neg P \<equiv> \<lambda>x. \<not> P x"

definition "K \<equiv> \<lambda>x y. x"

text \<open>Reversed composition of partial functions\<close>
definition
  fun_rcomp_option :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('b \<rightharpoonup> 'c) \<Rightarrow> ('a \<rightharpoonup> 'c)" (infixl "\<rhd>o" 55)
where
  "fun_rcomp_option f g \<equiv> (\<lambda>x. case f x of Some y \<Rightarrow> g y | None \<Rightarrow> None)"

lemmas rco_def = fun_rcomp_option_def

lemma rco_middle_exists:
  "(a \<rhd>o b) x = Some y \<Longrightarrow> \<exists>z. a x = Some z \<and> b z = Some y"
  by (clarsimp simp add: rco_def split: option.splits)

lemma rco_dom_left: "(vs \<rhd>o hs) v = Some val \<Longrightarrow> v \<in> dom vs"
  by (clarsimp simp add: rco_def cong: option.case_cong split: option.splits)

text \<open>Option magic\<close>

lemma None_not_eq [simp]: "(None \<noteq> x) = (\<exists>y. x = Some y)" by (cases x) auto
lemma None_com: "(None = x) = (x = None)" by fast
lemma Some_com: "(Some y = x) = (x = Some y)" by fast

lemma option_case_None_Some [simp]:
  "case_option None Some P = P"
  by (simp split: option.splits)

lemma map_the_map_Some [simp]:
  "map the (map Some xs) = xs"
  by (induct xs, auto)

lemma theSome [simp]: "the \<circ> Some = id"
  by (auto intro!: ext)

lemma allE2: "\<lbrakk> \<forall>x y. P x y ; P x y \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R" by blast
lemma allE3: "\<lbrakk> \<forall>x y z. P x y z ; P x y z \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R" by blast

lemma exI2: "P x y \<Longrightarrow> \<exists>x y. P x y" by blast
lemma exI3: "P x y z \<Longrightarrow> \<exists>x y. P x y z" by blast

lemma pred_conj_com:
  "(P and Q) = (Q and P)"
  by (intro ext, simp add: pred_conj_def conj_commute) (*WTF:conj_commute?*)

lemma pred_conj_assoc:
  "(P and Q and R) = (P and (Q and R))"
  by (auto simp: pred_conj_def intro: ext)

lemma pred_conj_left_commute:
  "(P and (Q and R)) = (Q and (P and R))"
  by (intro ext, simp add: pred_conj_def conj_ac) (*WTF:conj_ac?*)

lemmas pred_conj_ac = pred_conj_assoc pred_conj_com pred_conj_left_commute

lemma set_double_minus:
  "A - B - C = A - (C \<union> B)"
  by blast

(* XXX: this should be in our word library somewhere *)

lemma twice_le_div:
  "n \<le> m div 2 \<Longrightarrow> 2 * n \<le> (m :: nat)"
  by simp

lemmas twice_le_div_trans = twice_le_div [OF order_trans]

lemma map_id [simp]: "map id xs = xs"
  by (induct xs, auto)

lemma length_obvious_assist:
  "xs = [] \<Longrightarrow> 0 < length xs \<Longrightarrow> False"
  by auto

lemma list_index_in_list:
  "lst ! i = v \<Longrightarrow> i < length lst \<Longrightarrow> v \<in> set lst"
  by auto

text \<open>Drop first or second part of pairs in the range of a map.\<close>

definition
  fst_all_opt :: "('a \<rightharpoonup> 'b \<times> 'c) \<Rightarrow> ('a \<rightharpoonup> 'b)" where
  "fst_all_opt m \<equiv> (map_option fst) \<circ> m"

definition
  snd_all_opt :: "('a \<rightharpoonup> 'b \<times> 'c) \<Rightarrow> ('a \<rightharpoonup> 'c)" where
  "snd_all_opt m \<equiv> (map_option snd) \<circ> m"

text \<open>List take/drop folding, useful when (un)serialising serialisables\<close>

lemma list_take_take_drop:
  "take i x @ take j (drop i x) = take (i+j) x"
proof (induct x arbitrary: i)
  case Cons thus ?case by (cases i, auto)
qed simp

lemma list_take_drop_drop:
  assumes k: "k = i + j"
  shows "take i (drop j x) @ (drop k x) = drop j x"
proof -
  have "take i (drop j x) @ drop (i + j) x = drop j x"
  proof (induct x arbitrary: j)
    case Cons thus ?case by (cases j, auto)
  qed auto
  thus ?thesis using k by simp
qed

end


theory Array_Set_Impl
imports
  "../Sep_Main" Imp_Set_Spec Array_Blit
  "~~/src/HOL/Library/Code_Target_Numeral"
begin
  subsection "Array Set"

  type_synonym array_set = "bool array"
  definition "ias_initial_size \<equiv> 8::nat"

  definition "ias_of_list l \<equiv> {i. i<length l \<and> l!i}"

  definition is_ias :: "(nat set) \<Rightarrow> array_set \<Rightarrow> assn" where
    "is_ias m a \<equiv> \<exists>\<^sub>Al. a\<mapsto>\<^sub>al * \<up>(m=ias_of_list l)"

  definition ias_new_sz :: "nat \<Rightarrow> array_set Heap"
    where "ias_new_sz sz \<equiv> Array.new sz False"

  definition ias_new :: "array_set Heap"
    where "ias_new \<equiv> ias_new_sz ias_initial_size"

  definition ias_memb
    :: "nat \<Rightarrow> array_set \<Rightarrow> bool Heap"
    where "ias_memb k a = do {
      l\<leftarrow>Array.len a;
      if k < l then Array.nth a k else return False
    }"

  definition ias_delete
    :: "nat \<Rightarrow> array_set \<Rightarrow> array_set Heap"
  where "ias_delete k a = do {
      l\<leftarrow>Array.len a;
      if k < l then Array.upd k False a else return a
    }"

  lemma [code]: "ias_delete k a \<equiv> upd_oo (return a) k False a"
    unfolding ias_delete_def upd_oo_def .

  definition ias_ins
    :: "nat \<Rightarrow> array_set \<Rightarrow> array_set Heap"
    where "ias_ins k a = do {
      l\<leftarrow>Array.len a;
      a\<leftarrow>if k>=l then do {
          let newsz = max (k+1) (2 * l + 3);
          array_grow a newsz False
        } else return a;

      Array.upd k True a
    }"

  lemma [code]: "ias_ins k a \<equiv> upd_oo (do {
      l\<leftarrow>Array.len a;
      let newsz = max (k+1) (2 * l + 3);
      a\<leftarrow>array_grow a newsz False;
      Array.upd k True a
    })
    k True a"
    unfolding ias_ins_def upd_oo_def
    apply (rule eq_reflection)
    apply (auto simp add: bind_def execute_len execute_return)
    done

  lemma precise_ias: "precise is_ias"
    apply rule
    by (auto simp add: is_ias_def dest: preciseD[OF snga_prec])

  lemma ias_new_abs: "ias_of_list (replicate n False) = {}"
    unfolding ias_of_list_def[abs_def]
    by auto

  lemma ias_new_sz_rule: "<emp> ias_new_sz n < is_ias {} >"
    unfolding ias_new_sz_def is_ias_def[abs_def]
    by (sep_auto simp: ias_new_abs)

  lemma ias_new_rule: "<emp> ias_new < is_ias {} >"
    unfolding ias_new_def by (sep_auto heap: ias_new_sz_rule)

  lemma ias_memb_abs1: "k<length l \<Longrightarrow> k\<in>ias_of_list l \<longleftrightarrow> l!k"
    by (simp add: ias_of_list_def)
  lemma ias_memb_abs2: "\<not>k<length l \<Longrightarrow> k\<notin>ias_of_list l"
    by (simp add: ias_of_list_def)

  lemma ias_memb_rule: "< is_ias m p >
    ias_memb k p
    <\<lambda>r. is_ias m p * \<up>(r\<longleftrightarrow>k\<in>m) >"
    unfolding ias_memb_def is_ias_def
    by (sep_auto simp: ias_memb_abs1 ias_memb_abs2)

  lemma ias_delete_abs1: "k<length l
    \<Longrightarrow> ias_of_list (l[k := False]) = ias_of_list l - {k}"
    unfolding ias_of_list_def[abs_def]
    by (auto simp: nth_list_update)

  lemma ias_delete_abs2: "\<not>k<length l
    \<Longrightarrow> ias_of_list l - {k} = ias_of_list l"
    unfolding ias_of_list_def[abs_def]
    by (auto)

  lemma ias_delete_rule: "< is_ias m p >
    ias_delete k p
    <\<lambda>r. is_ias (m-{k}) r>"
    unfolding is_ias_def ias_delete_def
    by (sep_auto simp: ias_delete_abs1 ias_delete_abs2)

  lemma ias_ins_abs1: "ias_of_list (l@replicate n False) = ias_of_list l"
    unfolding ias_of_list_def[abs_def]
    apply rule
    apply rule
    apply simp
    apply (elim conjE)
    apply (case_tac "x<length l")
    apply (simp_all add: nth_append) [2]
    apply rule
    apply (simp add: nth_append)
    done

  lemma ias_ins_abs2: "\<not> length l \<le> k
    \<Longrightarrow> ias_of_list (l[k := True]) = insert k (ias_of_list l)"
    unfolding ias_of_list_def[abs_def]
    by (auto simp: nth_list_update)

  lemma ias_ins_rule:
    "< is_ias m p > ias_ins k p <\<lambda>r. is_ias (insert k m) r>\<^sub>t"
    unfolding is_ias_def ias_ins_def
    by (sep_auto
      decon: decon_split_if
      simp: ias_ins_abs1 ias_ins_abs2)

  lemma ias_set_impl: "imp_set is_ias"
    apply unfold_locales
    by (rule precise_ias)
  interpretation ias: imp_set is_ias using ias_set_impl .

  lemma ias_empty_impl: "imp_set_empty is_ias ias_new"
    apply unfold_locales
    by (sep_auto heap: ias_new_rule)
  interpretation ias: imp_set_empty is_ias ias_new using ias_empty_impl .

  lemma ias_empty_sz_impl: "imp_set_empty is_ias (ias_new_sz sz)"
    apply unfold_locales
    by (sep_auto heap: ias_new_sz_rule)
  interpretation ias_sz: imp_set_empty is_ias "ias_new_sz sz"
    using ias_empty_sz_impl .

  lemma ias_memb_impl: "imp_set_memb is_ias ias_memb"
    apply unfold_locales
    by (sep_auto heap: ias_memb_rule)
  interpretation ias: imp_set_memb is_ias ias_memb
    using ias_memb_impl .

  lemma ias_delete_impl: "imp_set_delete is_ias ias_delete"
    apply unfold_locales
    by (sep_auto heap: ias_delete_rule)
  interpretation ias: imp_set_delete is_ias ias_delete
    using ias_delete_impl .

  lemma ias_ins_impl: "imp_set_ins is_ias ias_ins"
    apply unfold_locales
    by (sep_auto heap: ias_ins_rule)
  interpretation ias: imp_set_ins is_ias ias_ins
    using ias_ins_impl .

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
header {* \isaheader{Set Implementation by List with explicit invariants} *}
theory ListSetImpl_Invar
  imports
  "../spec/SetSpec"
  "../gen_algo/SetGA"
  "../../Lib/Dlist_add"
begin
text_raw {*\label{thy:ListSetImpl_Invar}*}

(*@impl Set
  @type 'a lsi
  @abbrv lsi,l
  Sets by lists with distinct elements. Version with explicit invariant that
  supports efficient @{text "insert_dj"} operation.
*)

type_synonym
  'a lsi = "'a list"

subsection "Definitions"

definition lsi_ins :: "'a \<Rightarrow> 'a lsi \<Rightarrow> 'a lsi" where "lsi_ins x l == if  List.member l x then l else x#l"

definition lsi_basic_ops :: "('a,'a lsi) set_basic_ops" where
  [icf_rec_def]: "lsi_basic_ops \<equiv> \<lparr>
    bset_op_\<alpha> = set,
    bset_op_invar = distinct,
    bset_op_empty = \<lambda>_. [],
    bset_op_memb = (\<lambda>x s. List.member s x),
    bset_op_ins = lsi_ins,
    bset_op_ins_dj = op #,
    bset_op_delete = \<lambda>x l. Dlist_add.dlist_remove1' x [] l,
    bset_op_list_it = foldli
    \<rparr>"

setup Locale_Code.open_block
interpretation lsi_basic!: StdBasicSet lsi_basic_ops
  apply unfold_locales
  unfolding lsi_basic_ops_def lsi_ins_def[abs_def]
  apply (auto simp: List.member_def set_dlist_remove1'
  distinct_remove1')
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "lsi_ops \<equiv> lsi_basic.dflt_ops \<lparr>
  set_op_union_dj := op @,
  set_op_to_list := id
\<rparr>"

setup Locale_Code.open_block
interpretation lsi!: StdSet lsi_ops
proof -
  interpret aux!: StdSet lsi_basic.dflt_ops by (rule lsi_basic.dflt_ops_impl)

  show "StdSet lsi_ops"
    unfolding lsi_ops_def
    apply (rule StdSet_intro)
    apply icf_locales
    apply (simp_all add: icf_rec_unf)
    apply (unfold_locales, auto)
    done
qed
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "lsi"*}

lemma pi_lsi[proper_it]:
  "proper_it' foldli foldli"
  by (intro icf_proper_iteratorI proper_it'I)

interpretation pi_lsi: proper_it_loc foldli foldli
  apply unfold_locales by (rule pi_lsi)

definition test_codegen where "test_codegen \<equiv> (
  lsi.empty,
  lsi.memb,
  lsi.ins,
  lsi.delete,
  lsi.list_it,
  lsi.sng,
  lsi.isEmpty,
  lsi.isSng,
  lsi.ball,
  lsi.bex,
  lsi.size,
  lsi.size_abort,
  lsi.union,
  lsi.union_dj,
  lsi.diff,
  lsi.filter,
  lsi.inter,
  lsi.subset,
  lsi.equal,
  lsi.disjoint,
  lsi.disjoint_witness,
  lsi.sel,
  lsi.to_list,
  lsi.from_list
)"

export_code test_codegen in SML

end


 (*  Title:      AuxiliaryFunctions.thy
    Author:     Ludovic Henrio and Florian Kammuller
                2014
    Note:       Functions on Maps for Multi-active object formalisation
                Plus generic lemmas (not related to MAO)
*)

chapter {* Auxiliary functions for Multi-ASP *}

theory AuxiliaryFunctions imports Main begin

section{*generic lemmas*}
lemma map_of_zip_empty[rule_format,simp]: "ran (map_of (zip [] Y)) = {}"
by auto
lemma map_of_zip_replicate[rule_format,intro]: "x\<in>set vl \<longrightarrow>map_of (zip vl (replicate (length vl) Y)) x = Some Y"
by (induct_tac vl, auto)

lemma map_of_zip_outside_dom[rule_format,intro]: "x\<notin>set vl \<longrightarrow>map_of (zip vl (replicate (length vl) Y)) x = None"
by (induct_tac vl, auto)

lemma map_of_zip_replicate_simp[rule_format,simp]:
    "map_of (zip vl (replicate (length vl) Y)) x = (if (x\<in>set vl) then Some Y else None)"
by (case_tac "(x\<in>set vl)",  auto simp: map_of_zip_replicate map_of_zip_outside_dom)

lemma map_of_zip_replicate_map_simp[rule_format,simp]:
    "map_of (zip (map f vl) (replicate (length vl) Y)) x = (if (x\<in>set (map f vl)) then Some Y else None)"
apply (subgoal_tac "length vl = length (map f vl)")
apply (erule ssubst)
apply (simp only: map_of_zip_replicate_simp)
apply simp
done

lemma ran_map_of_zip_repl: "ran (map_of (zip (v#vl) (replicate (length (v#vl)) Y))) = {Y}"
by (auto simp: ran_def)
lemma ran_map_of_zip_2: "N=length L\<Longrightarrow>if (N=0) then ran (map_of (zip L (replicate N Y))) = {} else ran (map_of (zip L (replicate N Y))) = {Y}"
by (cases, auto simp: ran_def)

lemma ran_update: "ran (M(x\<mapsto>V)) \<subseteq> ran M \<union> {V}"
by (auto simp: ran_def)

lemma map_of_zip: "length xs=length ys \<Longrightarrow>(x \<in> set xs) = (\<exists>y\<in>set ys. map_of (zip xs ys) x = Some y)"
apply (induct rule: list_induct2)
apply (auto)
apply (drule Map.map_of_zip_is_None,auto)
done

lemma ran_map_of_zip: "map_of (zip xs ys) x = Some y \<Longrightarrow>length xs=length ys \<Longrightarrow>y\<in>set ys"
by (frule map_of_zip_is_Some, drule map_of_zip, auto)

primrec allTrue_list
where
  "allTrue_list Nil = True" |
  "allTrue_list (a#L) = (a\<and>allTrue_list L)"

lemma allTrue_list_nth: "allTrue_list L =(\<forall>n<length L. L!n)"
apply (induct_tac L)
apply auto
apply (case_tac n, auto)
done
(* abbreviation allTrue_list
where
"allTrue_list L \<equiv>\<forall>n<length L. L!n" *)

lemma allTrue_list_set: "allTrue_list L \<Longrightarrow>a\<in>set L \<Longrightarrow> a"
by (induct L,auto)
lemma allTrue_list_set_map: "allTrue_list (map f L) \<Longrightarrow>a\<in>set L \<Longrightarrow> f a"
by (induct L,auto)

lemma foldr_Un_larger: "x\<in> foldr (op \<union>) L (L') \<Longrightarrow> x \<in> foldr (op \<union>) L (a \<union> L')"
by (induct L, auto)
lemma foldr_Un_mapI[intro]: " {N} \<in> f ` set L \<Longrightarrow> N \<in> foldr op \<union> (map f L) S"
by (induct L, auto)

lemma foldr_Un_other: "x\<in> a \<Longrightarrow> x \<in> foldr (op \<union>) L (a \<union> L')"
by (induct L, auto)

lemma foldr_Un_init[rule_format]: "\<forall> L . x\<in>L \<longrightarrow>x\<in> fold (\<lambda>x S. S \<union> F x S) list L"
by (induct list, auto)

lemma foldr_Un_mapD :
"x \<in> foldr op \<union> (map f L) {} \<Longrightarrow> \<exists>y\<in>set L. x\<in>f y"
by (induct L, auto)

lemma foldr_Un_Union[simp] :
"foldr op \<union> (map f L) {} = \<Union>(set (map f L))"
by (induct L, auto)
(*SIMPLIFY ? ? ?  *)

lemma Map_restrict_Some: "(m|`A) x = Some y \<Longrightarrow> x\<in>A"
apply (erule contrapos_pp)
apply force
done

lemma ran_and_dom: "ran f = the`f`dom f  "
apply (auto simp: ran_def dom_def)
apply (subgoal_tac "x=the (f a) ")
apply blast
apply force
done

lemma sorted_list_of_set_card_length: " finite S \<Longrightarrow> card S = length (sorted_list_of_set S)"
apply (erule Finite_Set.finite_induct)
apply auto
done

lemma insortI_x: "x\<in>set (insort x L)"
apply (induct_tac L)
apply auto
done

lemma insortI_L[rule_format]: "x\<in>set L \<longrightarrow>x\<in>set (insort y L)"
apply (induct_tac L)
apply auto
done

lemma insortD[rule_format]: "y\<in>set (insort x L)\<longrightarrow>(y=x\<or>y\<in>set L)"
apply (induct_tac L)
apply auto
done

lemma sorted_list_of_set_nthI[rule_format]: " finite S \<Longrightarrow>x\<in>S \<longrightarrow>(\<exists> n<card S . (sorted_list_of_set S)!n = x) "
apply (erule Finite_Set.finite_induct)
apply (force)
apply (case_tac "x=xa",simp)
apply (insert insortI_x [of x])
apply (drule_tac x="(sorted_list_of_set F)" in meta_spec)
apply (drule sorted_list_of_set_card_length)
apply ( clarsimp simp: set_conv_nth)
apply force
apply clarsimp
apply (insert insortI_L)
apply (drule_tac x=x in meta_spec)+
apply (drule_tac x="(sorted_list_of_set F)" in meta_spec)+
apply (drule_tac x=xa in meta_spec)+
apply (erule meta_impE)
apply (clarsimp simp: set_conv_nth)
apply (rule_tac x=n in exI,simp)
apply (drule sorted_list_of_set_card_length,simp)
apply (clarsimp simp: set_conv_nth)
apply (rule_tac x=ia in exI,simp)
apply (drule sorted_list_of_set_card_length,simp)
done

lemma sorted_list_of_set_nthD[rule_format]: " finite S \<Longrightarrow> n<card S \<longrightarrow>(sorted_list_of_set S)!n = x \<longrightarrow>x\<in>S "
apply (erule Finite_Set.finite_induct)
apply clarsimp
apply clarsimp
apply (case_tac "x=xa")
apply simp
apply simp
apply (subgoal_tac "x \<in> set (insort xa (sorted_list_of_set F) )")
apply (drule insortD)
apply force
apply (clarsimp simp: set_conv_nth)
apply (rule_tac x=n in exI,simp)
apply (drule sorted_list_of_set_card_length,simp)
done

lemma UNION_eqI: " \<forall>x\<in>A.  \<exists>z\<in>C. B x = D z \<Longrightarrow> \<forall>z\<in>C. \<exists>x\<in>A.  B x = D z \<Longrightarrow>(\<Union>x\<in>A. B x) = (\<Union>z\<in>C. D z)"
apply auto
apply (drule_tac x=xa in bspec)
apply auto
apply (drule_tac x=z in bspec)
apply auto
done

lemma UNION_UNION_eqI: " \<forall>x\<in>A. \<forall> y\<in>F x. \<exists>z\<in>C. B y = D z \<Longrightarrow> \<forall>z\<in>C. \<exists>x\<in>A. \<exists> y\<in> F x. B y = D z \<Longrightarrow>(\<Union>x\<in>A.\<Union>y\<in>F x. B y) = (\<Union>z\<in>C. D z)"
apply auto
apply (drule_tac x=xa in bspec)
apply simp
apply (drule_tac x=y in bspec)
apply auto
apply (drule_tac x=z in bspec)
apply auto
apply blast
done

lemma map_le_eq: "dom \<sigma> \<subseteq> dom \<sigma>'\<Longrightarrow> \<sigma>=(\<sigma>'|`(dom \<sigma>) )  \<Longrightarrow> \<sigma> \<subseteq>\<^sub>m \<sigma>'"
apply  (auto simp: map_le_def Map.restrict_map_def)
apply (drule_tac x=a in  fun_cong)
apply (auto split: split_if_asm)
done

section{* Specific functions*}

definition
  remove_from_map :: "('a\<rightharpoonup> 'b) => 'a  => ('a \<rightharpoonup> 'b)"  (infixl "|``"  110) where
  "m|``x = m|`(dom m - {x})"

definition listunionMap:: "('a \<Rightarrow> 'b set) \<Rightarrow> ('a list) \<Rightarrow> 'b set"
where
  "listunionMap f l \<equiv> (foldr (op  \<union>) (map f l) {})"

lemma listunionMap_Empty[simp]: "listunionMap f [] = {}"
by (auto simp: listunionMap_def)

(*
lemma listunionMap_Empty_fun[simp]: "listunionMap (\<lambda>x.{}) (L::'a list) = {}"
apply (induct_tac L)
apply (auto simp: listunionMap_def)
done
*)

lemma listunionMap_Empty_fun[simp]: "listunionMap (\<lambda>x.{}) (L::'a list) = {}"
by (induct L, auto simp: listunionMap_def)
lemma listunionMap_Single[simp]: "listunionMap f [x] = f x"
by ( auto simp: listunionMap_def)

lemma listunionMap_Cons[simp]: "listunionMap f (x#L) = (f x) \<union> (listunionMap f L)"
by ( auto simp: listunionMap_def)

lemma find_Some[rule_format]:
"find (P) X = Some M \<longrightarrow> M \<in> set X"
by (induct_tac X,auto)
lemma find_Some_P[rule_format]:
"find (P) X = Some M \<longrightarrow> P M"
by (induct_tac X,auto)

end


(*  Title:      HOL/Library/AList.thy
    Author:     Norbert Schirmer, Tobias Nipkow, Martin Wildmoser, TU Muenchen
*)

section \<open>Implementation of Association Lists\<close>

theory AList
  imports "MainRLT"
begin

context
begin

text \<open>
  The operations preserve distinctness of keys and
  function \<^term>\<open>clearjunk\<close> distributes over them. Since
  \<^term>\<open>clearjunk\<close> enforces distinctness of keys it can be used
  to establish the invariant, e.g. for inductive proofs.
\<close>

subsection \<open>\<open>update\<close> and \<open>updates\<close>\<close>

qualified primrec update :: "'key \<Rightarrow> 'val \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where
    "update k v [] = [(k, v)]"
  | "update k v (p # ps) = (if fst p = k then (k, v) # ps else p # update k v ps)"

lemma update_conv': "map_of (update k v al)  = (map_of al)(k\<mapsto>v)"
  by (induct al) (auto simp add: fun_eq_iff)

corollary update_conv: "map_of (update k v al) k' = ((map_of al)(k\<mapsto>v)) k'"
  by (simp add: update_conv')

lemma dom_update: "fst ` set (update k v al) = {k} \<union> fst ` set al"
  by (induct al) auto

lemma update_keys:
  "map fst (update k v al) =
    (if k \<in> set (map fst al) then map fst al else map fst al @ [k])"
  by (induct al) simp_all

lemma distinct_update:
  assumes "distinct (map fst al)"
  shows "distinct (map fst (update k v al))"
  using assms by (simp add: update_keys)

lemma update_filter:
  "a \<noteq> k \<Longrightarrow> update k v [q\<leftarrow>ps. fst q \<noteq> a] = [q\<leftarrow>update k v ps. fst q \<noteq> a]"
  by (induct ps) auto

lemma update_triv: "map_of al k = Some v \<Longrightarrow> update k v al = al"
  by (induct al) auto

lemma update_nonempty [simp]: "update k v al \<noteq> []"
  by (induct al) auto

lemma update_eqD: "update k v al = update k v' al' \<Longrightarrow> v = v'"
proof (induct al arbitrary: al')
  case Nil
  then show ?case
    by (cases al') (auto split: if_split_asm)
next
  case Cons
  then show ?case
    by (cases al') (auto split: if_split_asm)
qed

lemma update_last [simp]: "update k v (update k v' al) = update k v al"
  by (induct al) auto

text \<open>Note that the lists are not necessarily the same:
        \<^term>\<open>update k v (update k' v' []) = [(k', v'), (k, v)]\<close> and
        \<^term>\<open>update k' v' (update k v []) = [(k, v), (k', v')]\<close>.\<close>

lemma update_swap:
  "k \<noteq> k' \<Longrightarrow> map_of (update k v (update k' v' al)) = map_of (update k' v' (update k v al))"
  by (simp add: update_conv' fun_eq_iff)

lemma update_Some_unfold:
  "map_of (update k v al) x = Some y \<longleftrightarrow>
    x = k \<and> v = y \<or> x \<noteq> k \<and> map_of al x = Some y"
  by (simp add: update_conv' map_upd_Some_unfold)

lemma image_update [simp]: "x \<notin> A \<Longrightarrow> map_of (update x y al) ` A = map_of al ` A"
  by (auto simp add: update_conv')

qualified definition updates ::
    "'key list \<Rightarrow> 'val list \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where "updates ks vs = fold (case_prod update) (zip ks vs)"

lemma updates_simps [simp]:
  "updates [] vs ps = ps"
  "updates ks [] ps = ps"
  "updates (k#ks) (v#vs) ps = updates ks vs (update k v ps)"
  by (simp_all add: updates_def)

lemma updates_key_simp [simp]:
  "updates (k # ks) vs ps =
    (case vs of [] \<Rightarrow> ps | v # vs \<Rightarrow> updates ks vs (update k v ps))"
  by (cases vs) simp_all

lemma updates_conv': "map_of (updates ks vs al) = (map_of al)(ks[\<mapsto>]vs)"
proof -
  have "map_of \<circ> fold (case_prod update) (zip ks vs) =
      fold (\<lambda>(k, v) f. f(k \<mapsto> v)) (zip ks vs) \<circ> map_of"
    by (rule fold_commute) (auto simp add: fun_eq_iff update_conv')
  then show ?thesis
    by (auto simp add: updates_def fun_eq_iff map_upds_fold_map_upd foldl_conv_fold split_def)
qed

lemma updates_conv: "map_of (updates ks vs al) k = ((map_of al)(ks[\<mapsto>]vs)) k"
  by (simp add: updates_conv')

lemma distinct_updates:
  assumes "distinct (map fst al)"
  shows "distinct (map fst (updates ks vs al))"
proof -
  have "distinct (fold
       (\<lambda>(k, v) al. if k \<in> set al then al else al @ [k])
       (zip ks vs) (map fst al))"
    by (rule fold_invariant [of "zip ks vs" "\<lambda>_. True"]) (auto intro: assms)
  moreover have "map fst \<circ> fold (case_prod update) (zip ks vs) =
      fold (\<lambda>(k, v) al. if k \<in> set al then al else al @ [k]) (zip ks vs) \<circ> map fst"
    by (rule fold_commute) (simp add: update_keys split_def case_prod_beta comp_def)
  ultimately show ?thesis
    by (simp add: updates_def fun_eq_iff)
qed

lemma updates_append1[simp]: "size ks < size vs \<Longrightarrow>
    updates (ks@[k]) vs al = update k (vs!size ks) (updates ks vs al)"
  by (induct ks arbitrary: vs al) (auto split: list.splits)

lemma updates_list_update_drop[simp]:
  "size ks \<le> i \<Longrightarrow> i < size vs \<Longrightarrow>
    updates ks (vs[i:=v]) al = updates ks vs al"
  by (induct ks arbitrary: al vs i) (auto split: list.splits nat.splits)

lemma update_updates_conv_if:
  "map_of (updates xs ys (update x y al)) =
    map_of
     (if x \<in> set (take (length ys) xs)
      then updates xs ys al
      else (update x y (updates xs ys al)))"
  by (simp add: updates_conv' update_conv' map_upd_upds_conv_if)

lemma updates_twist [simp]:
  "k \<notin> set ks \<Longrightarrow>
    map_of (updates ks vs (update k v al)) = map_of (update k v (updates ks vs al))"
  by (simp add: updates_conv' update_conv')

lemma updates_apply_notin [simp]:
  "k \<notin> set ks \<Longrightarrow> map_of (updates ks vs al) k = map_of al k"
  by (simp add: updates_conv)

lemma updates_append_drop [simp]:
  "size xs = size ys \<Longrightarrow> updates (xs @ zs) ys al = updates xs ys al"
  by (induct xs arbitrary: ys al) (auto split: list.splits)

lemma updates_append2_drop [simp]:
  "size xs = size ys \<Longrightarrow> updates xs (ys @ zs) al = updates xs ys al"
  by (induct xs arbitrary: ys al) (auto split: list.splits)

subsection \<open>\<open>delete\<close>\<close>

qualified definition delete :: "'key \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where delete_eq: "delete k = filter (\<lambda>(k', _). k \<noteq> k')"

lemma delete_simps [simp]:
  "delete k [] = []"
  "delete k (p # ps) = (if fst p = k then delete k ps else p # delete k ps)"
  by (auto simp add: delete_eq)

lemma delete_conv': "map_of (delete k al) = (map_of al)(k := None)"
  by (induct al) (auto simp add: fun_eq_iff)

corollary delete_conv: "map_of (delete k al) k' = ((map_of al)(k := None)) k'"
  by (simp add: delete_conv')

lemma delete_keys: "map fst (delete k al) = removeAll k (map fst al)"
  by (simp add: delete_eq removeAll_filter_not_eq filter_map split_def comp_def)

lemma distinct_delete:
  assumes "distinct (map fst al)"
  shows "distinct (map fst (delete k al))"
  using assms by (simp add: delete_keys distinct_removeAll)

lemma delete_id [simp]: "k \<notin> fst ` set al \<Longrightarrow> delete k al = al"
  by (auto simp add: image_iff delete_eq filter_id_conv)

lemma delete_idem: "delete k (delete k al) = delete k al"
  by (simp add: delete_eq)

lemma map_of_delete [simp]: "k' \<noteq> k \<Longrightarrow> map_of (delete k al) k' = map_of al k'"
  by (simp add: delete_conv')

lemma delete_notin_dom: "k \<notin> fst ` set (delete k al)"
  by (auto simp add: delete_eq)

lemma dom_delete_subset: "fst ` set (delete k al) \<subseteq> fst ` set al"
  by (auto simp add: delete_eq)

lemma delete_update_same: "delete k (update k v al) = delete k al"
  by (induct al) simp_all

lemma delete_update: "k \<noteq> l \<Longrightarrow> delete l (update k v al) = update k v (delete l al)"
  by (induct al) simp_all

lemma delete_twist: "delete x (delete y al) = delete y (delete x al)"
  by (simp add: delete_eq conj_commute)

lemma length_delete_le: "length (delete k al) \<le> length al"
  by (simp add: delete_eq)

subsection \<open>\<open>update_with_aux\<close> and \<open>delete_aux\<close>\<close>

qualified primrec update_with_aux ::
    "'val \<Rightarrow> 'key \<Rightarrow> ('val \<Rightarrow> 'val) \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where
    "update_with_aux v k f [] = [(k, f v)]"
  | "update_with_aux v k f (p # ps) =
      (if (fst p = k) then (k, f (snd p)) # ps else p # update_with_aux v k f ps)"

text \<open>
  The above \<^term>\<open>delete\<close> traverses all the list even if it has found the key.
  This one does not have to keep going because is assumes the invariant that keys are distinct.
\<close>
qualified fun delete_aux :: "'key \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where
    "delete_aux k [] = []"
  | "delete_aux k ((k', v) # xs) = (if k = k' then xs else (k', v) # delete_aux k xs)"

lemma map_of_update_with_aux':
  "map_of (update_with_aux v k f ps) k' =
    ((map_of ps)(k \<mapsto> (case map_of ps k of None \<Rightarrow> f v | Some v \<Rightarrow> f v))) k'"
  by (induct ps) auto

lemma map_of_update_with_aux:
  "map_of (update_with_aux v k f ps) =
    (map_of ps)(k \<mapsto> (case map_of ps k of None \<Rightarrow> f v | Some v \<Rightarrow> f v))"
  by (simp add: fun_eq_iff map_of_update_with_aux')

lemma dom_update_with_aux: "fst ` set (update_with_aux v k f ps) = {k} \<union> fst ` set ps"
  by (induct ps) auto

lemma distinct_update_with_aux [simp]:
  "distinct (map fst (update_with_aux v k f ps)) = distinct (map fst ps)"
  by (induct ps) (auto simp add: dom_update_with_aux)

lemma set_update_with_aux:
  "distinct (map fst xs) \<Longrightarrow>
    set (update_with_aux v k f xs) =
      (set xs - {k} \<times> UNIV \<union> {(k, f (case map_of xs k of None \<Rightarrow> v | Some v \<Rightarrow> v))})"
  by (induct xs) (auto intro: rev_image_eqI)

lemma set_delete_aux: "distinct (map fst xs) \<Longrightarrow> set (delete_aux k xs) = set xs - {k} \<times> UNIV"
  apply (induct xs)
   apply simp_all
  apply clarsimp
  apply (fastforce intro: rev_image_eqI)
  done

lemma dom_delete_aux: "distinct (map fst ps) \<Longrightarrow> fst ` set (delete_aux k ps) = fst ` set ps - {k}"
  by (auto simp add: set_delete_aux)

lemma distinct_delete_aux [simp]: "distinct (map fst ps) \<Longrightarrow> distinct (map fst (delete_aux k ps))"
proof (induct ps)
  case Nil
  then show ?case by simp
next
  case (Cons a ps)
  obtain k' v where a: "a = (k', v)"
    by (cases a)
  show ?case
  proof (cases "k' = k")
    case True
    with Cons a show ?thesis by simp
  next
    case False
    with Cons a have "k' \<notin> fst ` set ps" "distinct (map fst ps)"
      by simp_all
    with False a have "k' \<notin> fst ` set (delete_aux k ps)"
      by (auto dest!: dom_delete_aux[where k=k])
    with Cons a show ?thesis
      by simp
  qed
qed

lemma map_of_delete_aux':
  "distinct (map fst xs) \<Longrightarrow> map_of (delete_aux k xs) = (map_of xs)(k := None)"
  apply (induct xs)
   apply (fastforce simp add: map_of_eq_None_iff fun_upd_twist)
  apply (auto intro!: ext)
  apply (simp add: map_of_eq_None_iff)
  done

lemma map_of_delete_aux:
  "distinct (map fst xs) \<Longrightarrow> map_of (delete_aux k xs) k' = ((map_of xs)(k := None)) k'"
  by (simp add: map_of_delete_aux')

lemma delete_aux_eq_Nil_conv: "delete_aux k ts = [] \<longleftrightarrow> ts = [] \<or> (\<exists>v. ts = [(k, v)])"
  by (cases ts) (auto split: if_split_asm)

subsection \<open>\<open>restrict\<close>\<close>

qualified definition restrict :: "'key set \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where restrict_eq: "restrict A = filter (\<lambda>(k, v). k \<in> A)"

lemma restr_simps [simp]:
  "restrict A [] = []"
  "restrict A (p#ps) = (if fst p \<in> A then p # restrict A ps else restrict A ps)"
  by (auto simp add: restrict_eq)

lemma restr_conv': "map_of (restrict A al) = ((map_of al)|` A)"
proof
  show "map_of (restrict A al) k = ((map_of al)|` A) k" for k
    apply (induct al)
     apply simp
    apply (cases "k \<in> A")
     apply auto
    done
qed

corollary restr_conv: "map_of (restrict A al) k = ((map_of al)|` A) k"
  by (simp add: restr_conv')

lemma distinct_restr: "distinct (map fst al) \<Longrightarrow> distinct (map fst (restrict A al))"
  by (induct al) (auto simp add: restrict_eq)

lemma restr_empty [simp]:
  "restrict {} al = []"
  "restrict A [] = []"
  by (induct al) (auto simp add: restrict_eq)

lemma restr_in [simp]: "x \<in> A \<Longrightarrow> map_of (restrict A al) x = map_of al x"
  by (simp add: restr_conv')

lemma restr_out [simp]: "x \<notin> A \<Longrightarrow> map_of (restrict A al) x = None"
  by (simp add: restr_conv')

lemma dom_restr [simp]: "fst ` set (restrict A al) = fst ` set al \<inter> A"
  by (induct al) (auto simp add: restrict_eq)

lemma restr_upd_same [simp]: "restrict (-{x}) (update x y al) = restrict (-{x}) al"
  by (induct al) (auto simp add: restrict_eq)

lemma restr_restr [simp]: "restrict A (restrict B al) = restrict (A\<inter>B) al"
  by (induct al) (auto simp add: restrict_eq)

lemma restr_update[simp]:
  "map_of (restrict D (update x y al)) =
    map_of ((if x \<in> D then (update x y (restrict (D-{x}) al)) else restrict D al))"
  by (simp add: restr_conv' update_conv')

lemma restr_delete [simp]:
  "delete x (restrict D al) = (if x \<in> D then restrict (D - {x}) al else restrict D al)"
  apply (simp add: delete_eq restrict_eq)
  apply (auto simp add: split_def)
proof -
  have "y \<noteq> x \<longleftrightarrow> x \<noteq> y" for y
    by auto
  then show "[p \<leftarrow> al. fst p \<in> D \<and> x \<noteq> fst p] = [p \<leftarrow> al. fst p \<in> D \<and> fst p \<noteq> x]"
    by simp
  assume "x \<notin> D"
  then have "y \<in> D \<longleftrightarrow> y \<in> D \<and> x \<noteq> y" for y
    by auto
  then show "[p \<leftarrow> al . fst p \<in> D \<and> x \<noteq> fst p] = [p \<leftarrow> al . fst p \<in> D]"
    by simp
qed

lemma update_restr:
  "map_of (update x y (restrict D al)) = map_of (update x y (restrict (D - {x}) al))"
  by (simp add: update_conv' restr_conv') (rule fun_upd_restrict)

lemma update_restr_conv [simp]:
  "x \<in> D \<Longrightarrow>
    map_of (update x y (restrict D al)) = map_of (update x y (restrict (D - {x}) al))"
  by (simp add: update_conv' restr_conv')

lemma restr_updates [simp]:
  "length xs = length ys \<Longrightarrow> set xs \<subseteq> D \<Longrightarrow>
    map_of (restrict D (updates xs ys al)) =
      map_of (updates xs ys (restrict (D - set xs) al))"
  by (simp add: updates_conv' restr_conv')

lemma restr_delete_twist: "(restrict A (delete a ps)) = delete a (restrict A ps)"
  by (induct ps) auto

subsection \<open>\<open>clearjunk\<close>\<close>

qualified function clearjunk  :: "('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where
    "clearjunk [] = []"
  | "clearjunk (p#ps) = p # clearjunk (delete (fst p) ps)"
  by pat_completeness auto
termination
  by (relation "measure length") (simp_all add: less_Suc_eq_le length_delete_le)

lemma map_of_clearjunk: "map_of (clearjunk al) = map_of al"
  by (induct al rule: clearjunk.induct) (simp_all add: fun_eq_iff)

lemma clearjunk_keys_set: "set (map fst (clearjunk al)) = set (map fst al)"
  by (induct al rule: clearjunk.induct) (simp_all add: delete_keys)

lemma dom_clearjunk: "fst ` set (clearjunk al) = fst ` set al"
  using clearjunk_keys_set by simp

lemma distinct_clearjunk [simp]: "distinct (map fst (clearjunk al))"
  by (induct al rule: clearjunk.induct) (simp_all del: set_map add: clearjunk_keys_set delete_keys)

lemma ran_clearjunk: "ran (map_of (clearjunk al)) = ran (map_of al)"
  by (simp add: map_of_clearjunk)

lemma ran_map_of: "ran (map_of al) = snd ` set (clearjunk al)"
proof -
  have "ran (map_of al) = ran (map_of (clearjunk al))"
    by (simp add: ran_clearjunk)
  also have "\<dots> = snd ` set (clearjunk al)"
    by (simp add: ran_distinct)
  finally show ?thesis .
qed

lemma graph_map_of: "Map.graph (map_of al) = set (clearjunk al)"
  by (metis distinct_clearjunk graph_map_of_if_distinct_dom map_of_clearjunk)

lemma clearjunk_update: "clearjunk (update k v al) = update k v (clearjunk al)"
  by (induct al rule: clearjunk.induct) (simp_all add: delete_update)

lemma clearjunk_updates: "clearjunk (updates ks vs al) = updates ks vs (clearjunk al)"
proof -
  have "clearjunk \<circ> fold (case_prod update) (zip ks vs) =
      fold (case_prod update) (zip ks vs) \<circ> clearjunk"
    by (rule fold_commute) (simp add: clearjunk_update case_prod_beta o_def)
  then show ?thesis
    by (simp add: updates_def fun_eq_iff)
qed

lemma clearjunk_delete: "clearjunk (delete x al) = delete x (clearjunk al)"
  by (induct al rule: clearjunk.induct) (auto simp add: delete_idem delete_twist)

lemma clearjunk_restrict: "clearjunk (restrict A al) = restrict A (clearjunk al)"
  by (induct al rule: clearjunk.induct) (auto simp add: restr_delete_twist)

lemma distinct_clearjunk_id [simp]: "distinct (map fst al) \<Longrightarrow> clearjunk al = al"
  by (induct al rule: clearjunk.induct) auto

lemma clearjunk_idem: "clearjunk (clearjunk al) = clearjunk al"
  by simp

lemma length_clearjunk: "length (clearjunk al) \<le> length al"
proof (induct al rule: clearjunk.induct [case_names Nil Cons])
  case Nil
  then show ?case by simp
next
  case (Cons kv al)
  moreover have "length (delete (fst kv) al) \<le> length al"
    by (fact length_delete_le)
  ultimately have "length (clearjunk (delete (fst kv) al)) \<le> length al"
    by (rule order_trans)
  then show ?case
    by simp
qed

lemma delete_map:
  assumes "\<And>kv. fst (f kv) = fst kv"
  shows "delete k (map f ps) = map f (delete k ps)"
  by (simp add: delete_eq filter_map comp_def split_def assms)

lemma clearjunk_map:
  assumes "\<And>kv. fst (f kv) = fst kv"
  shows "clearjunk (map f ps) = map f (clearjunk ps)"
  by (induct ps rule: clearjunk.induct [case_names Nil Cons])
    (simp_all add: clearjunk_delete delete_map assms)

subsection \<open>\<open>map_ran\<close>\<close>

definition map_ran :: "('key \<Rightarrow> 'val1 \<Rightarrow> 'val2) \<Rightarrow> ('key \<times> 'val1) list \<Rightarrow> ('key \<times> 'val2) list"
  where "map_ran f = map (\<lambda>(k, v). (k, f k v))"

lemma map_ran_simps [simp]:
  "map_ran f [] = []"
  "map_ran f ((k, v) # ps) = (k, f k v) # map_ran f ps"
  by (simp_all add: map_ran_def)

lemma map_ran_Cons_sel: "map_ran f (p # ps) = (fst p, f (fst p) (snd p)) # map_ran f ps"
  by (simp add: map_ran_def case_prod_beta)

lemma length_map_ran[simp]: "length (map_ran f al) = length al"
  by (simp add: map_ran_def)

lemma map_fst_map_ran[simp]: "map fst (map_ran f al) = map fst al"
  by (simp add: map_ran_def case_prod_beta)

lemma dom_map_ran: "fst ` set (map_ran f al) = fst ` set al"
  by (simp add: map_ran_def image_image split_def)

lemma map_ran_conv: "map_of (map_ran f al) k = map_option (f k) (map_of al k)"
  by (induct al) auto

lemma distinct_map_ran: "distinct (map fst al) \<Longrightarrow> distinct (map fst (map_ran f al))"
  by simp

lemma map_ran_filter: "map_ran f [p\<leftarrow>ps. fst p \<noteq> a] = [p\<leftarrow>map_ran f ps. fst p \<noteq> a]"
  by (simp add: map_ran_def filter_map split_def comp_def)

lemma clearjunk_map_ran: "clearjunk (map_ran f al) = map_ran f (clearjunk al)"
  by (simp add: map_ran_def split_def clearjunk_map)

subsection \<open>\<open>merge\<close>\<close>

qualified definition merge :: "('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where "merge qs ps = foldr (\<lambda>(k, v). update k v) ps qs"

lemma merge_simps [simp]:
  "merge qs [] = qs"
  "merge qs (p#ps) = update (fst p) (snd p) (merge qs ps)"
  by (simp_all add: merge_def split_def)

lemma merge_updates: "merge qs ps = updates (rev (map fst ps)) (rev (map snd ps)) qs"
  by (simp add: merge_def updates_def foldr_conv_fold zip_rev zip_map_fst_snd)

lemma dom_merge: "fst ` set (merge xs ys) = fst ` set xs \<union> fst ` set ys"
  by (induct ys arbitrary: xs) (auto simp add: dom_update)

lemma distinct_merge: "distinct (map fst xs) \<Longrightarrow> distinct (map fst (merge xs ys))"
  by (simp add: merge_updates distinct_updates)

lemma clearjunk_merge: "clearjunk (merge xs ys) = merge (clearjunk xs) ys"
  by (simp add: merge_updates clearjunk_updates)

lemma merge_conv': "map_of (merge xs ys) = map_of xs ++ map_of ys"
proof -
  have "map_of \<circ> fold (case_prod update) (rev ys) =
      fold (\<lambda>(k, v) m. m(k \<mapsto> v)) (rev ys) \<circ> map_of"
    by (rule fold_commute) (simp add: update_conv' case_prod_beta split_def fun_eq_iff)
  then show ?thesis
    by (simp add: merge_def map_add_map_of_foldr foldr_conv_fold fun_eq_iff)
qed

corollary merge_conv: "map_of (merge xs ys) k = (map_of xs ++ map_of ys) k"
  by (simp add: merge_conv')

lemma merge_empty: "map_of (merge [] ys) = map_of ys"
  by (simp add: merge_conv')

lemma merge_assoc [simp]: "map_of (merge m1 (merge m2 m3)) = map_of (merge (merge m1 m2) m3)"
  by (simp add: merge_conv')

lemma merge_Some_iff:
  "map_of (merge m n) k = Some x \<longleftrightarrow>
    map_of n k = Some x \<or> map_of n k = None \<and> map_of m k = Some x"
  by (simp add: merge_conv' map_add_Some_iff)

lemmas merge_SomeD [dest!] = merge_Some_iff [THEN iffD1]

lemma merge_find_right [simp]: "map_of n k = Some v \<Longrightarrow> map_of (merge m n) k = Some v"
  by (simp add: merge_conv')

lemma merge_None [iff]: "(map_of (merge m n) k = None) = (map_of n k = None \<and> map_of m k = None)"
  by (simp add: merge_conv')

lemma merge_upd [simp]: "map_of (merge m (update k v n)) = map_of (update k v (merge m n))"
  by (simp add: update_conv' merge_conv')

lemma merge_updatess [simp]:
  "map_of (merge m (updates xs ys n)) = map_of (updates xs ys (merge m n))"
  by (simp add: updates_conv' merge_conv')

lemma merge_append: "map_of (xs @ ys) = map_of (merge ys xs)"
  by (simp add: merge_conv')

subsection \<open>\<open>compose\<close>\<close>

qualified function compose :: "('key \<times> 'a) list \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('key \<times> 'b) list"
  where
    "compose [] ys = []"
  | "compose (x # xs) ys =
      (case map_of ys (snd x) of
        None \<Rightarrow> compose (delete (fst x) xs) ys
      | Some v \<Rightarrow> (fst x, v) # compose xs ys)"
  by pat_completeness auto
termination
  by (relation "measure (length \<circ> fst)") (simp_all add: less_Suc_eq_le length_delete_le)

lemma compose_first_None [simp]: "map_of xs k = None \<Longrightarrow> map_of (compose xs ys) k = None"
  by (induct xs ys rule: compose.induct) (auto split: option.splits if_split_asm)

lemma compose_conv: "map_of (compose xs ys) k = (map_of ys \<circ>\<^sub>m map_of xs) k"
proof (induct xs ys rule: compose.induct)
  case 1
  then show ?case by simp
next
  case (2 x xs ys)
  show ?case
  proof (cases "map_of ys (snd x)")
    case None
    with 2 have hyp: "map_of (compose (delete (fst x) xs) ys) k =
        (map_of ys \<circ>\<^sub>m map_of (delete (fst x) xs)) k"
      by simp
    show ?thesis
    proof (cases "fst x = k")
      case True
      from True delete_notin_dom [of k xs]
      have "map_of (delete (fst x) xs) k = None"
        by (simp add: map_of_eq_None_iff)
      with hyp show ?thesis
        using True None
        by simp
    next
      case False
      from False have "map_of (delete (fst x) xs) k = map_of xs k"
        by simp
      with hyp show ?thesis
        using False None by (simp add: map_comp_def)
    qed
  next
    case (Some v)
    with 2
    have "map_of (compose xs ys) k = (map_of ys \<circ>\<^sub>m map_of xs) k"
      by simp
    with Some show ?thesis
      by (auto simp add: map_comp_def)
  qed
qed

lemma compose_conv': "map_of (compose xs ys) = (map_of ys \<circ>\<^sub>m map_of xs)"
  by (rule ext) (rule compose_conv)

lemma compose_first_Some [simp]: "map_of xs k = Some v \<Longrightarrow> map_of (compose xs ys) k = map_of ys v"
  by (simp add: compose_conv)

lemma dom_compose: "fst ` set (compose xs ys) \<subseteq> fst ` set xs"
proof (induct xs ys rule: compose.induct)
  case 1
  then show ?case by simp
next
  case (2 x xs ys)
  show ?case
  proof (cases "map_of ys (snd x)")
    case None
    with "2.hyps" have "fst ` set (compose (delete (fst x) xs) ys) \<subseteq> fst ` set (delete (fst x) xs)"
      by simp
    also have "\<dots> \<subseteq> fst ` set xs"
      by (rule dom_delete_subset)
    finally show ?thesis
      using None by auto
  next
    case (Some v)
    with "2.hyps" have "fst ` set (compose xs ys) \<subseteq> fst ` set xs"
      by simp
    with Some show ?thesis
      by auto
  qed
qed

lemma distinct_compose:
  assumes "distinct (map fst xs)"
  shows "distinct (map fst (compose xs ys))"
  using assms
proof (induct xs ys rule: compose.induct)
  case 1
  then show ?case by simp
next
  case (2 x xs ys)
  show ?case
  proof (cases "map_of ys (snd x)")
    case None
    with 2 show ?thesis by simp
  next
    case (Some v)
    with 2 dom_compose [of xs ys] show ?thesis
      by auto
  qed
qed

lemma compose_delete_twist: "compose (delete k xs) ys = delete k (compose xs ys)"
proof (induct xs ys rule: compose.induct)
  case 1
  then show ?case by simp
next
  case (2 x xs ys)
  show ?case
  proof (cases "map_of ys (snd x)")
    case None
    with 2 have hyp: "compose (delete k (delete (fst x) xs)) ys =
        delete k (compose (delete (fst x) xs) ys)"
      by simp
    show ?thesis
    proof (cases "fst x = k")
      case True
      with None hyp show ?thesis
        by (simp add: delete_idem)
    next
      case False
      from None False hyp show ?thesis
        by (simp add: delete_twist)
    qed
  next
    case (Some v)
    with 2 have hyp: "compose (delete k xs) ys = delete k (compose xs ys)"
      by simp
    with Some show ?thesis
      by simp
  qed
qed

lemma compose_clearjunk: "compose xs (clearjunk ys) = compose xs ys"
  by (induct xs ys rule: compose.induct)
    (auto simp add: map_of_clearjunk split: option.splits)

lemma clearjunk_compose: "clearjunk (compose xs ys) = compose (clearjunk xs) ys"
  by (induct xs rule: clearjunk.induct)
    (auto split: option.splits simp add: clearjunk_delete delete_idem compose_delete_twist)

lemma compose_empty [simp]: "compose xs [] = []"
  by (induct xs) (auto simp add: compose_delete_twist)

lemma compose_Some_iff:
  "(map_of (compose xs ys) k = Some v) \<longleftrightarrow>
    (\<exists>k'. map_of xs k = Some k' \<and> map_of ys k' = Some v)"
  by (simp add: compose_conv map_comp_Some_iff)

lemma map_comp_None_iff:
  "map_of (compose xs ys) k = None \<longleftrightarrow>
    (map_of xs k = None \<or> (\<exists>k'. map_of xs k = Some k' \<and> map_of ys k' = None))"
  by (simp add: compose_conv map_comp_None_iff)

subsection \<open>\<open>map_entry\<close>\<close>

qualified fun map_entry :: "'key \<Rightarrow> ('val \<Rightarrow> 'val) \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where
    "map_entry k f [] = []"
  | "map_entry k f (p # ps) =
      (if fst p = k then (k, f (snd p)) # ps else p # map_entry k f ps)"

lemma map_of_map_entry:
  "map_of (map_entry k f xs) =
    (map_of xs)(k := case map_of xs k of None \<Rightarrow> None | Some v' \<Rightarrow> Some (f v'))"
  by (induct xs) auto

lemma dom_map_entry: "fst ` set (map_entry k f xs) = fst ` set xs"
  by (induct xs) auto

lemma distinct_map_entry:
  assumes "distinct (map fst xs)"
  shows "distinct (map fst (map_entry k f xs))"
  using assms by (induct xs) (auto simp add: dom_map_entry)

subsection \<open>\<open>map_default\<close>\<close>

fun map_default :: "'key \<Rightarrow> 'val \<Rightarrow> ('val \<Rightarrow> 'val) \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where
    "map_default k v f [] = [(k, v)]"
  | "map_default k v f (p # ps) =
      (if fst p = k then (k, f (snd p)) # ps else p # map_default k v f ps)"

lemma map_of_map_default:
  "map_of (map_default k v f xs) =
    (map_of xs)(k := case map_of xs k of None \<Rightarrow> Some v | Some v' \<Rightarrow> Some (f v'))"
  by (induct xs) auto

lemma dom_map_default: "fst ` set (map_default k v f xs) = insert k (fst ` set xs)"
  by (induct xs) auto

lemma distinct_map_default:
  assumes "distinct (map fst xs)"
  shows "distinct (map fst (map_default k v f xs))"
  using assms by (induct xs) (auto simp add: dom_map_default)

end

end