theory sort_BubSortPermutes
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

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

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

datatype Nat = Z | S "Nat"

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

fun count :: "int => int list => Nat" where
"count x (Nil2) = Z"
| "count x (Cons2 z xs) =
     (if x = z then S (count x xs) else count x xs)"

fun bubble :: "int list => (bool, (int list)) Pair2" where
"bubble (Nil2) = Pair False (Nil2)"
| "bubble (Cons2 y (Nil2)) = Pair False (Cons2 y (Nil2))"
| "bubble (Cons2 y (Cons2 y2 xs)) =
     (if y <= y2 then
        case bubble (Cons2 y2 xs) of
          | Pair b6 ys5 =>
              (if y <= y2 then
                 (if y <= y2 then
                    case bubble (Cons2 y2 xs) of
                      | Pair b10 ys9 => Pair (or2 (~ (y <= y2)) b6) (Cons2 y ys9)
                    end
                    else
                    case bubble (Cons2 y xs) of
                      | Pair b9 ys8 => Pair (or2 (~ (y <= y2)) b6) (Cons2 y ys8)
                    end)
                 else
                 (if y <= y2 then
                    case bubble (Cons2 y2 xs) of
                      | Pair b8 ys7 => Pair (or2 (~ (y <= y2)) b6) (Cons2 y2 ys7)
                    end
                    else
                    case bubble (Cons2 y xs) of
                      | Pair b7 ys6 => Pair (or2 (~ (y <= y2)) b6) (Cons2 y2 ys6)
                    end))
        end
        else
        case bubble (Cons2 y xs) of
          | Pair c2 ys =>
              (if y <= y2 then
                 (if y <= y2 then
                    case bubble (Cons2 y2 xs) of
                      | Pair b5 ys4 => Pair (or2 (~ (y <= y2)) c2) (Cons2 y ys4)
                    end
                    else
                    case bubble (Cons2 y xs) of
                      | Pair b4 ys3 => Pair (or2 (~ (y <= y2)) c2) (Cons2 y ys3)
                    end)
                 else
                 (if y <= y2 then
                    case bubble (Cons2 y2 xs) of
                      | Pair b3 ys2 => Pair (or2 (~ (y <= y2)) c2) (Cons2 y2 ys2)
                    end
                    else
                    case bubble (Cons2 y xs) of
                      | Pair b2 zs => Pair (or2 (~ (y <= y2)) c2) (Cons2 y2 zs)
                    end))
        end)"

fun bubsort :: "int list => int list" where
"bubsort x =
   case bubble x of
     | Pair c ys =>
         (if c then
            case bubble x of | Pair b2 xs => bubsort xs
            end
            else
            x)
   end"

(*hipster or2 count bubble bubsort *)

theorem x0 :
  "!! (x :: int) (y :: int list) .
     (count x (bubsort y)) = (count x y)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


section {*An example on CTCS mode and level conversions.*}

theory CTCS_Conversion
  imports HHL
begin

(*First define the whole process, which is composed of a set of sub-processes.*)

type_synonym  segT = "exp * exp * exp * exp" (*Each segment contains v1, v2, s, and mode.*)
type_synonym  MAT = "segT list"

consts
chw :: "cname" (*Channel CH_win*)
chd :: "cname" (*Channel CH_DC*)
bw  :: "string"   (*Variable b_win*)
MA_n :: "MAT"
t_delay :: real
minA :: real (*Min acceleration, CONSTANT*)
maxA :: real (*Max acc, CONSTANT*)

axiomatization where
assumpMinA: "minA > 0" and
assumpMaxA: "maxA > 0"

(****************)
(* The variables*)
(****************)
(*Variable level*)
definition level :: "exp" where
"level == RVar ''le''"
 (*Displacement, variable s, the position of the train*)
definition sf :: "exp" where
"sf == RVar ''s''"
(*Variable x2*)
definition x2 :: "exp" where
"x2 == RVar ''x2''"
(*MA*)
definition seg1 :: "segT" where
"seg1 == (RVar ''v11'', RVar ''v12'', RVar ''x2'', String ''FS'')"
definition seg2 :: "segT" where
"seg2 == (RVar ''v21'', RVar ''v22'', RVar ''e2'', String ''CO'')"
definition MA :: "MAT" where
"MA == seg1#seg2#MA_n"
(*Temp_t0*)
definition Temp_t0 :: "exp" where
"Temp_t0 == RVar ''t0''"
(*Temp_t1*)
definition Temp_t1 :: "exp" where
"Temp_t1 == RVar ''t1''"
(*Temp_t2*)
definition Temp_t2 :: "exp" where
"Temp_t2 == RVar ''t2''"
(*clock time*)
definition ct :: "exp" where
"ct == RVar ''ct''"
 (*Velocity of the Train*)
definition vel :: "exp"
where "vel == RVar ''v''"
 (*Acceleation of the Train*)
definition acc :: "exp" where
"acc == RVar ''a''"
(*Mode of train*)
definition md :: "exp" where
"md == SVar ''md''"
(*Variable b_rConf*)
definition br :: "exp" where
"br == BVar ''br''"

(****************)
(* The driver process*)
(****************)
definition P :: "proc" where
"P ==  (IF ((BVar bw) [=] (Bool True))
      ((chd !! (Bool True)) [[ (chd !! (Bool False))))"

definition Driver :: "proc" where
"Driver ==  (Skip; (WTrue, l [=] Real 0); chw ?? (BVar bw));
     (((BVar bw) [=] (Bool False)), (l [=] Real 0) [|] (high (WTrue))); P"

(****************)
(* The train process*)
(****************)

(*checkV1, checkV2: check the given speed is less than all v1 and v2 of MAT.*)
primrec checkV1 :: "MAT => exp => fform" where
"checkV1 ([], v) = WTrue" |
"checkV1 ((a # ma), v) = ((v [<] (fst (a))) [&] (checkV1 (ma, v)))"
primrec checkV2 :: "MAT => exp => fform" where
"checkV2 ([], v) = WTrue" |
"checkV2 ((a # ma), v) = ((v [<] (fst (snd (a)))) [&] (checkV2 (ma, v)))"

(*checkS: checks the given speed is less than all the dynamic curves of MAT.*)
primrec checkS :: "MAT => exp => exp => fform" where
"checkS ([], v, s) = WTrue" |
"checkS (a#ma, v, s) = ((((v[*]v)[+](((Real 2)[*](Real minA))[*]s)) [<]
                   ( (((fst(a)))[*]((fst(a)))) [+]
                   (((Real 2)[*](Real minA))[*]((fst (snd (snd (a))))))))
                   [&] (checkS ((ma), v, s)))"

definition B0 :: "fform" where
"B0 == ((vel[>=] Real 0) [|] ((acc) [>=] Real 0) [|] (( ct) [<] (( Temp_t0) [+] (Real t_delay))))"

definition B1 :: "fform" where
"B1 == ( (checkV2 (MA, vel)) [|] ((acc) [<] Real 0) [|] (( ct) [<] (( Temp_t1) [+] (Real t_delay))))"

definition B2 :: "fform" where
"B2 ==  ((checkV1 (MA, vel)) [&] (checkS (MA, vel, sf))) [|]  (acc [=] Real (- (minA))) "

definition B4 :: "fform" where
"B4 == (([~](level [=] (Real 2.5))) [|] (sf [<=] x2))"

(*Use pre-defined function hd.*)
definition B5 :: "fform" where
"B5 == (md [=] (snd ( snd ( snd (hd(MA))))))"

definition B6 :: "fform" where
"B6 == (([~](level [=] (Real 3)))
    [|] ([~] (String ''CO'' [=]  (snd ( snd ( snd (hd( tl (MA))))))))
    [|] (br [=] Bool True)
    [|] ((((fst (snd (snd (hd (MA))))) [-] sf) [>] Real 0) [&]
           (((fst (snd (snd (hd (MA))))) [-] sf) [<] Real 300))
    [|] ((ct) [<] (Temp_t2 [+] Real t_delay)))"

definition B :: fform where
"B == (B1 [&] B2 [&] B4 [&] B5 [&] B6)"

(*Invariant for Train movement*)
definition inv :: fform where
"inv == (checkS (MA, vel, sf))"

(*Precondition*)
definition Pre :: fform where
"Pre == (level [=] Real 2.5)
      [&] (((fst (snd (snd (seg1))))) [=] x2)
      [&] (((snd (snd (snd (seg1))))) [=] (String ''FS''))
      [&] (((snd (snd (snd (seg2))))) [=] (String ''CO''))
      [&] (((fst (seg1))) [=] Real 0)"
definition Init :: fform where
"Init == (x2 [-] sf [>] Real 300) [&] B1 [&] B2
      [&] (checkS (MA, vel, sf)) "

(*The following presents the proof of the example.*)

(*The continuous part*)
definition Move :: proc where
"Move == <inv && B> : (l [>] Real 0)"

(*P_train includes six sub-processes in sequence.*)
definition P1 :: proc where
"P1 == (IF B6 chw !! (Bool False)); (WTrue, WTrue); (IF ([~] B6) chw!! (Bool True))"

(*For this case, B6 is True.*)
(*Add {*assert B6*} before this process. This is proved in Assert1*)
definition SP1 :: proc where
"SP1 ==  chw !! (Bool False)"

(*Variable c, used in Q12.*)
definition cv :: "exp" where
"cv == RVar ''cv''"
definition Q11 :: proc where
"Q11 == (IF ([~]B0) ( ((Temp_t0 := ct); (Pre [&] sf [<=] x2, l [=] (Real 0));
         NON R ''cv'' : (cv [>] Real 0 [&] (cv [<] Real maxA)) acc := cv) ))"

definition Q12 :: proc where
"Q12 == (IF ([~] B1) ((Temp_t1 := ct); (Pre [&] sf [<=] x2, l [=] (Real 0));
         NON R ''cv'' : ((cv [>] Real (-minA)) [&] (cv [<] Real maxA)) acc := (cv)) )"

definition Q13 :: proc where
"Q13 == (IF ([~] B2) acc := (Real (- minA)))"

definition Q3 :: proc where
"Q3 == (IF ([~] B4) level := (Real 3))"

definition Q4 :: proc where
"Q4 == (IF ([~] B5) ((md) := ((snd (snd (snd (hd (MA))))))))"

definition Q5 :: proc where
"Q5 == (IF ([~] B6) ((Temp_t2) := (ct); (WTrue, WTrue);chd ?? br; (WTrue, WTrue);
       (IF (br [=] Bool True) ((fst (hd (tl (MA)))) := (Real 40)))))"

definition Imd :: mid where
"Imd == (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))))"

definition Train :: proc where
"Train == ((Move; (Pre [&] sf [<=] x2,  (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
          (Q11; Imd; Q12; Imd; Q13; Imd; Q3; Imd; Q4)); Imd; SP1);
          (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));Q5"

definition System :: proc where
"System == (Train)* || (Driver)*"

(***********************************************************)
(***********************************************************)
(* Process definition finished, proof part starts. *)
(***********************************************************)
(***********************************************************)

(*********************************)
(**for differential equation**)

lemma assist_cont_1 : "|- Init [-->] inv"
apply (simp add:Init_def inv_def)
apply (rule impR)
apply fast
done

lemma assist_cont_2_a: "[|s <= t; t < (u::real)|] ==> (s < u)"
apply (auto)
done

lemma assist_cont_2_b: "[|s <= t; s ~=u; t = (u::real)|] ==> (s < u)"
apply (auto)
done

lemma assist_cont_2_c: "2 * minA * rvar(''s'') <= rvar(''v'') * rvar(''v'') + 2 * minA * rvar(''s'')"
apply (auto)
done

lemma assist_cont_2: "close(checkS(MA, vel, sf)), Pre |- sf [<=] x2"
apply (unfold MA_def Pre_def,auto)
apply (rule conjL)+
apply (cut_tac P="vel [*] vel [+] (Real 2 [*] Real minA) [*] sf [<]
    fst(seg2) [*] fst(seg2) [+] (Real 2 [*] Real minA) [*] fst(snd(snd(seg2))) [|]
    vel [*] vel [+] (Real 2 [*] Real minA) [*] sf [=]
    fst(seg2) [*] fst(seg2) [+] (Real 2 [*] Real minA) [*] fst(snd(snd(seg2)))" in thinL,auto)
apply (cut_tac P="close(checkS(MA_n, vel, sf))" in thinL,auto)
apply (cut_tac P="level [=] Real (5 / 2)" in thinL,auto)
apply (cut_tac P="fst(snd(snd(seg1))) [=] x2" in thinL,auto)
apply (cut_tac P="snd(snd(snd(seg1))) [=] String ''FS''" in thinL,auto)
apply (cut_tac P="snd(snd(snd(seg2))) [=] String ''CO''" in thinL,auto)
apply (unfold seg1_def seg2_def level_def x2_def sf_def vel_def equal_less_def)
apply (rule Trans2,auto)
apply (subgoal_tac "2 * minA * rvar(''s'') < 2 * minA * rvar(''x2'') & minA >0",auto)
apply (cut_tac s="2 * minA * rvar(''s'')"
    and t="rvar(''v'') * rvar(''v'') + 2 * minA * rvar(''s'')"
    and u="2 * minA * rvar(''x2'')" in assist_cont_2_a,auto)
apply (rule assumpMinA)
apply (subgoal_tac "2 * minA * rvar(''s'') < 2 * minA * rvar(''x2'')")
apply (subgoal_tac "minA >0", simp)
apply (rule assumpMinA)
apply (cut_tac s="2 * minA * rvar(''s'')"
    and t="rvar(''v'') * rvar(''v'') + 2 * minA * rvar(''s'')"
    and u="2*minA * rvar(''x2'')" in assist_cont_2_b)
apply (rule assist_cont_2_c, auto)
apply (subgoal_tac "minA >0", simp)
apply (rule assumpMinA)
done

lemma step_continuous: "{Init [&] Pre} Move {Pre [&] sf [<=] x2; (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))}"
apply (simp add:Move_def)
apply (cut_tac Init = "Init" and p = "Pre" and FF = "inv" and b = "B" and
               Rg = "(l [>] Real 0)" and q = "Pre [&] sf [<=] x2" and
               G = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" in Continue,auto)
apply (rule conjR)
apply (rule assist_cont_1)
apply (rule conjR)
apply (rule impR)
apply (rule conjR)
apply fast
apply (rule conjL)+
apply (cut_tac P="NotForm(B)" in thinL,auto)
apply (simp add: inv_def)
apply (rule exchL)
apply (rule assist_cont_2)
apply (rule impR)
apply (rule conjL)
apply (rule disjL)
apply fast
apply (rule exchL)
apply (rule thinL)
apply (rule disjR)
apply (rule thinR)
apply (cut_tac s = "close(inv) [&] Pre [&] close(B)" and t= "Pre [&] sf [<=] x2" in DC18,auto)
apply (rule conjL)+
apply (rule conjR)
apply fast
apply (cut_tac P="close(B)" in thinL,auto)
apply (simp add:inv_def)
apply (rule assist_cont_2)
done

(**********************************)
(**for Q11****)

lemma assist_Q11_1_a : "substF([(Temp_t0, ct)], Pre) = Pre"
apply (simp add: Temp_t0_def ct_def Pre_def seg1_def)
apply (simp add: level_def x2_def seg2_def)
done

lemma assist_Q11_1_b : "substF([(Temp_t0, ct)], sf [<=] x2) = (sf [<=] x2)"
apply (simp add: Temp_t0_def ct_def equal_less_def)
apply (simp add: sf_def x2_def)
done

lemma assist_Q11_1 : "{Pre [&] sf [<=] x2}(Temp_t0) := (ct) {Pre [&] sf [<=] x2; l [=]Real 0}"
apply (cut_tac p = "(Pre [&] sf [<=] x2)" and e = "Temp_t0" and
               f = "ct" and q = "Pre [&] sf [<=] x2" and
               G = "l [=] Real 0" in Assign,auto)
prefer 3
apply (rule conjR)
apply (simp add: assist_Q11_1_a assist_Q11_1_b)
apply fast+
apply (unfold Pre_def sf_def x2_def equal_less_def inPairForm_def inPairL_def inPairR_def inExp_def,auto)
done

lemma assist_Q11_2_a : "substF([(acc, cv)], Pre) = Pre"
apply (simp add:acc_def cv_def Pre_def)
apply (simp add:level_def x2_def seg1_def seg2_def)
done

lemma assist_Q11_2_b : "substF([(acc, cv)], sf [<=] x2) = (sf [<=] x2)"
apply (simp add:acc_def cv_def equal_less_def)
apply (simp add:sf_def x2_def)
done

lemma assist_Q11_2 : "{Pre [&] sf [<=] x2} acc := (cv){Pre [&] sf [<=] x2; l [=] Real 0}"
apply (cut_tac p = "(Pre [&] sf [<=] x2)" and e = "acc" and
               f = "cv" and q = "Pre [&] sf [<=] x2" and G = "l [=] Real 0" in Assign,auto)
prefer 3
apply (simp add: assist_Q11_2_a assist_Q11_2_b)
apply fast
apply (unfold Pre_def sf_def x2_def equal_less_def inPairForm_def inPairL_def inPairR_def inExp_def,auto)
done

lemma assist_Q11_3 : "{Pre [&] sf [<=] x2} NON R ''cv'': (cv [>] Real 0 [&] cv [<]  Real maxA)
       CTCS_Conversion.acc := cv{Pre [&] sf [<=] x2;l [=] Real 0}"
apply (cut_tac p = "Pre [&] sf [<=] x2" and q = "Pre [&] sf [<=] x2" and
               G = "l [=] Real 0" and b = "cv [>] Real 0 [&] cv [<]  Real maxA"and
               P = "acc := (cv)" in Nondeterministic,auto)
apply (cut_tac p = "(Pre [&] sf [<=] x2) [&] cv [>] Real 0 [&] cv [<] Real maxA" and
               q = "Pre [&] sf [<=] x2" and H= "l [=] Real 0" and
               px = "(Pre [&] sf [<=] x2)" and qx = "Pre [&] sf [<=] x2" and
               Hx = "l [=] Real 0" and P = "acc := (cv)" in ConsequenceS, auto)
apply (rule assist_Q11_2)
apply fast
done

lemma step_Q11 : "{Pre [&] sf [<=] x2} Q11 {Pre [&] sf [<=] x2; (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))} "
apply (cut_tac p = "(Pre [&] sf [<=] x2)" and q = "Pre [&] sf [<=] x2" and
               H = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" and
               px = "(Pre [&] sf [<=] x2)" and qx = "Pre [&] sf [<=] x2" and
               Hx = "(l [=] Real 0)" and
               P = "Q11" in ConsequenceS, auto)
prefer 2
apply (fast)
apply (simp add:Q11_def)
apply (cut_tac p = "Pre [&] sf [<=] x2" and b = "[~] B0" and
P = "Temp_t0 := ct; (Pre [&] sf [<=] x2, l [=] Real 0) ; NON R ''cv'' : (cv [>]
        Real 0 [&] (cv [<] Real maxA)) CTCS_Conversion.acc := cv"
and q = "Pre [&] sf [<=] x2" and G = "l [=] Real 0" in Condition, auto)
apply (cut_tac p = "(Pre [&] sf [<=] x2) [&] [~] B0" and b = "[~] B0"
           and P = "(Temp_t0 := ct; (Pre [&] sf [<=] x2, l [=] Real 0);
             NON R ''cv'' : (cv [>] Real 0 [&] (cv [<] Real maxA)) CTCS_Conversion.acc := cv)"
           and q = "Pre [&] sf [<=] x2" and G = "l [=] Real 0" in ConditionT, auto)
apply fast
apply (cut_tac p = "(Pre [&] sf [<=] x2) [&] [~] B0" and q = "Pre [&] sf [<=] x2" and
               H = "l [=] Real 0" and px = "(Pre [&] sf [<=] x2)" and
               qx = "Pre [&] sf [<=] x2" and Hx = "l [=] Real 0" and
               P = "Temp_t0 := ct; (Pre [&] sf [<=] x2, l [=] Real 0) ;
                NON R ''cv'' : (cv [>] Real 0 [&] (cv [<] Real maxA)) CTCS_Conversion.acc := cv"
                in ConsequenceS, auto)
apply (cut_tac P = "(Temp_t0) := (ct)" and Q = "NON R ''cv'' : (cv [>] Real 0 [&] cv [<] Real maxA)
                 acc := (cv)" and p = "Pre [&] sf [<=] x2" and m = "Pre [&] sf [<=] x2" and
               H = "l [=] Real 0" and q = "Pre [&] sf [<=] x2" and
               G = "l [=] Real 0" in Sequence )
apply (rule assist_Q11_1)
apply (rule assist_Q11_3)
apply (cut_tac p = "(Pre [&] sf [<=] x2)" and q = "Pre [&] sf [<=] x2" and
               H = "l [=] Real 0" and px = "(Pre [&] sf [<=] x2)" and
               qx = "Pre [&] sf [<=] x2" and Hx = "l [=] Real 0 [^] l [=] Real 0" and
               P = "Temp_t0 := ct; (Pre [&] sf [<=] x2, l [=] Real 0) ;
                NON R ''cv'' : (cv [>] Real 0 [&] (cv [<] Real maxA)) CTCS_Conversion.acc := cv"
                in ConsequenceS, auto)
apply (rule conjR)
apply (rule impR)
apply (rule basic)
apply (rule conjR)
apply (rule impR)
apply (rule basic)
apply (rule impR)
apply (rule LL4)
apply (rule basic)
apply fast
apply (cut_tac p = "(Pre [&] sf [<=] x2) [&] [~] [~] B0" and b = "[~] B0"
           and P = "((Temp_t0) := (ct); (Pre [&] sf [<=] x2,l [=] Real 0) ;
                NON R ''cv'' : (cv [>] Real 0 [&] cv [<] Real maxA) acc := (cv))"
           and q = "Pre [&] sf [<=] x2" and G = "l [=] Real 0" in ConditionF, auto)
apply fast+
done

(*************************************)
(*for Q12*)

lemma assist_Q12_1_a : "substF([(Temp_t1, ct)], Pre) = Pre"
apply (simp add: Temp_t1_def ct_def Pre_def seg1_def)
apply (simp add: level_def x2_def seg2_def)
done

lemma assist_Q12_1_b : "substF([(Temp_t1, ct)], sf [<=] x2) = (sf [<=] x2)"
apply (simp add: Temp_t1_def ct_def equal_less_def)
apply (simp add: sf_def x2_def)
done

lemma assist_Q12_1 : "{Pre [&] sf [<=] x2}(Temp_t1) := (ct) {Pre [&] sf [<=] x2; l [=]Real 0}"
apply (cut_tac p = "(Pre [&] sf [<=] x2)" and e = "Temp_t1" and
               f = "ct" and q = "Pre [&] sf [<=] x2" and G = "l [=] Real 0" in Assign,auto)
prefer 3
apply (rule conjR)
apply (simp add: assist_Q12_1_a assist_Q12_1_b)
apply fast+
apply (unfold Pre_def sf_def x2_def equal_less_def inPairForm_def inPairL_def inPairR_def inExp_def,auto)
done

lemma assist_Q12_2 : "{Pre [&] sf [<=] x2} NON R ''cv'': (cv [>] Real - minA [&] cv [<] Real maxA) acc := (cv){Pre [&] sf [<=] x2;l [=] Real 0}"
apply (cut_tac p = "Pre [&] sf [<=] x2" and q = "Pre [&] sf [<=] x2" and
               G = "l [=] Real 0" and b = "cv [>] Real - minA [&] cv [<] Real maxA" and
               P = "acc := (cv)" in Nondeterministic,auto)
apply (cut_tac p = "(Pre [&] sf [<=] x2) [&] cv [>] Real - minA [&] cv [<] Real maxA" and
               q = "Pre [&] sf [<=] x2" and H= "l [=] Real 0" and
               px = "(Pre [&] sf [<=] x2)" and qx = "Pre [&] sf [<=] x2" and
               Hx = "l [=] Real 0" and P = "acc := (cv)" in ConsequenceS, auto)
apply (rule assist_Q11_2)
apply fast
done

lemma step_Q12 : "{Pre [&] sf [<=] x2} Q12 {Pre [&] sf [<=] x2; (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))} "
apply (cut_tac p = "(Pre [&] sf [<=] x2)" and q = "Pre [&] sf [<=] x2" and
               H = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" and
               px = "(Pre [&] sf [<=] x2)" and qx = "Pre [&] sf [<=] x2" and
               Hx = "(l [=] Real 0)" and
               P = "Q12" in ConsequenceS, auto)
prefer 2
apply (fast)
apply (simp add:Q12_def)
apply (cut_tac p = "Pre [&] sf [<=] x2" and b = "[~] B1" and P = "((Temp_t1) := (ct);
                 (Pre [&] sf [<=] x2, l [=] Real 0) ; NON R ''cv'': (cv [>] Real - minA [&]
                 cv [<] Real maxA) acc := cv)" and q = "Pre [&] sf [<=] x2" and
               G = "l [=] Real 0" in Condition, auto)
apply (cut_tac p = "(Pre [&] sf [<=] x2) [&] [~] B1" and b = "[~] B1" and
               P = "((Temp_t1) := (ct); (Pre [&] sf [<=] x2,l [=] Real 0);
                 NON R ''cv'': (cv [>] Real - minA [&] cv [<] Real maxA) acc := (cv))"
           and q = "Pre [&] sf [<=] x2" and G = "l [=] Real 0" in ConditionT, auto)
apply fast
apply (cut_tac p = "(Pre [&] sf [<=] x2) [&] [~] B1" and q = "Pre [&] sf [<=] x2" and
               H= "l [=] Real 0" and px = "(Pre [&] sf [<=] x2)" and
               qx = "Pre [&] sf [<=] x2" and Hx = "l [=] Real 0" and
               P = "(Temp_t1) := (ct); (Pre [&] sf [<=] x2,l [=] Real 0);
                 NON R ''cv'': (cv [>] Real - minA [&] cv [<] Real maxA) acc := (cv)"
                 in ConsequenceS, auto)
apply (cut_tac P = "(Temp_t1) := (ct)" and Q = "NON R ''cv'': (cv [>] Real - minA [&]
                 cv [<] Real maxA) acc := (cv)" and p = "Pre [&] sf [<=] x2" and
               m = "Pre [&] sf [<=] x2" and H = "l [=] Real 0" and
               q = "Pre [&] sf [<=] x2" and G = "l [=] Real 0" in Sequence )
apply (rule assist_Q12_1)
apply (rule assist_Q12_2)
apply (cut_tac p = "(Pre [&] sf [<=] x2)" and q = "Pre [&] sf [<=] x2" and
               H = "l [=] Real 0" and px = "(Pre [&] sf [<=] x2)" and
               qx = "Pre [&] sf [<=] x2" and Hx = "l [=] Real 0 [^] l [=] Real 0" and
               P = "Temp_t1 := ct; (Pre [&] sf [<=] x2, l [=] Real 0) ;
                NON R ''cv'' : (cv [>] Real - minA [&] (cv [<] Real maxA)) CTCS_Conversion.acc := cv"
                in ConsequenceS, auto)
apply (rule conjR)
apply (rule impR)
apply (rule basic)
apply (rule conjR)
apply (rule impR)
apply (rule basic)
apply (rule impR)
apply (rule LL4)
apply (rule basic)
apply fast
apply (cut_tac p = "(Pre [&] sf [<=] x2) [&] [~] [~] B1" and b = "[~] B1" and
               P = "((Temp_t1) := (ct); (Pre [&] sf [<=] x2,l [=] Real 0);
                 NON R ''cv'': (cv [>] Real - minA [&] cv [<] Real maxA) acc := (cv))" and
               q = "Pre [&] sf [<=] x2" and G = "l [=] Real 0" in ConditionF, auto)
apply fast+
done

(**********************************)
(**for Q13****)

lemma assist_Q13_1_a : "substF([(acc, Real - minA)], Pre) = Pre"
apply (simp add:acc_def Pre_def)
apply (simp add:level_def x2_def seg1_def seg2_def)
done

lemma assist_Q13_1_b : "substF([(acc, Real - minA)], sf [<=] x2) = (sf [<=] x2)"
apply (simp add:acc_def equal_less_def)
apply (simp add:sf_def x2_def)
done

lemma assist_Q13_1 : " {(Pre [&] sf [<=] x2)} acc := (Real - minA) {Pre [&] sf [<=] x2;l [=] Real 0}"
apply (cut_tac p = "(Pre [&] sf [<=] x2)" and e = "acc" and
               f = "(Real - minA)" and q = "Pre [&] sf [<=] x2" and
               G = "l [=] Real 0" in Assign)
apply (simp add: Pre_def sf_def x2_def equal_less_def inPairForm_def inPairL_def inPairR_def inExp_def)
apply (simp add: assist_Q13_1_a assist_Q13_1_b)
apply fast
apply assumption
done

lemma step_Q13 : "{Pre [&] sf [<=] x2} Q13 {Pre [&] sf [<=] x2; (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))} "
apply (cut_tac p = "(Pre [&] sf [<=] x2)" and q = "Pre [&] sf [<=] x2" and
               H = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" and
               px = "(Pre [&] sf [<=] x2)" and qx = "Pre [&] sf [<=] x2" and
               Hx = "(l [=] Real 0)" and
               P = "Q13" in ConsequenceS, auto)
prefer 2
apply (fast)
apply (simp add:Q13_def)
apply (cut_tac p = "Pre [&] sf [<=] x2" and b = "[~] B2" and P = "acc := (Real - minA)" and
               q = "Pre [&] sf [<=] x2" and G = "l [=] Real 0" in Condition, auto)
apply (cut_tac p = "(Pre [&] sf [<=] x2)  [&] [~] B2" and b = "[~] B2" and
               P = "acc := (Real - minA)" and q = "Pre [&] sf [<=] x2" and
               G = "l [=] Real 0" in ConditionT, auto)
apply fast
apply (cut_tac p = "(Pre [&] sf [<=] x2) [&] [~] B2" and q = "Pre [&] sf [<=] x2" and
               H= "l [=] Real 0" and px = "(Pre [&] sf [<=] x2)" and
               qx = "Pre [&] sf [<=] x2" and Hx = "l [=] Real 0" and
               P = "acc := (Real - minA)" in ConsequenceS, auto)
apply (rule assist_Q13_1)
apply fast
apply (cut_tac p = "(Pre [&] sf [<=] x2)  [&] [~] [~] B2" and b = "[~] B2" and
               P = "acc := (Real - minA)" and
               q = "Pre [&] sf [<=] x2" and G = "l [=] Real 0" in ConditionF,auto)
apply fast+
done

(**********************)
(* for Q3 *)

lemma assist_Q3 : "|- Pre [&] sf [<=] x2 [-->] [~] [~] B4"
apply (simp add:Pre_def B4_def)
apply (rule impR)
apply (rule notR)
apply (rule notL)
apply (rule disjR)
apply (rule thinR)
apply fast
done

lemma step_Q3 : "{Pre [&] sf [<=] x2} Q3 {Pre [&] sf [<=] x2; (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))}"
apply (cut_tac p = "(Pre [&] sf [<=] x2)" and q = "Pre [&] sf [<=] x2" and
               H = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" and
               px = "(Pre [&] sf [<=] x2)" and qx = "Pre [&] sf [<=] x2" and
               Hx = "(l [=] Real 0)" and
               P = "Q3" in ConsequenceS, auto)
prefer 2
apply (fast)
apply (simp add:Q3_def)
apply (cut_tac p = "Pre [&] sf [<=] x2" and b = "[~] B4" and P = "level := (Real 3)"
           and q = "Pre [&] sf [<=] x2" and G = "l [=] Real 0" in ConditionF)
apply (rule assist_Q3)
apply (fast)+
apply assumption
done

(**************)
(** for Q4**)

lemma assist_Q4_a : "(substF([(md, snd(snd(snd(hd(MA)))))], Pre)) = (Pre)"
apply (unfold Pre_def md_def)
apply (unfold level_def x2_def MA_def seg1_def seg2_def, auto)
done

lemma assist_Q4_b : "substF([(md, snd(snd(snd(hd(MA)))))], sf [<=] x2) = (sf [<=] x2)"
apply (unfold md_def equal_less_def)
apply (unfold sf_def x2_def MA_def, auto)
done

lemma assist_Q4 : "{(Pre [&] sf [<=] x2)} md := (snd(snd(snd(hd(MA)))))
                     {Pre [&] sf [<=] x2;l [=] Real 0}"
apply (cut_tac p = "(Pre [&] sf [<=] x2)" and e = "md" and
               f = "snd(snd(snd(hd(MA))))" and q = "Pre [&] sf [<=] x2" and
               G = "l [=] Real 0" in Assign)
apply (simp add: Pre_def sf_def x2_def equal_less_def inPairForm_def inPairL_def inPairR_def inExp_def)
apply (rule conjR)
apply (simp add: assist_Q4_a assist_Q4_b)
apply fast+
apply assumption
done

lemma step_Q4 : "{Pre [&] sf [<=] x2} Q4 {Pre [&] sf [<=] x2; (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))}"
apply (cut_tac p = "(Pre [&] sf [<=] x2)" and q = "Pre [&] sf [<=] x2" and
               H = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" and
               px = "(Pre [&] sf [<=] x2)" and qx = "Pre [&] sf [<=] x2" and
               Hx = "(l [=] Real 0)" and
               P = "Q4" in ConsequenceS, auto)
prefer 2
apply (fast)
apply (simp add:Q4_def)
apply (cut_tac p = "Pre [&] sf [<=] x2" and b = "[~] B5" and
               P = "(md) := (snd(snd(snd(hd(MA)))))" and q = "Pre [&] sf [<=] x2" and
               G = "l [=] Real 0" in Condition, auto)
apply (cut_tac p = "(Pre [&] sf [<=] x2)  [&] [~] B5" and b = "[~] B5" and
               P = "(md) := (snd(snd(snd(hd(MA)))))" and
               q = "Pre [&] sf [<=] x2" and G = "l [=] Real 0" in ConditionT, auto)
apply fast
apply (cut_tac p = "(Pre [&] sf [<=] x2) [&] [~] B5" and q = "Pre [&] sf [<=] x2" and
               H= "l [=] Real 0" and px = "(Pre [&] sf [<=] x2)" and
               qx = "Pre [&] sf [<=] x2" and Hx = "l [=] Real 0" and
               P = "md := (snd(snd(snd (hd(MA)))))" in ConsequenceS, auto)
apply (rule assist_Q4)
apply fast
apply (cut_tac p = "(Pre [&] sf [<=] x2)  [&] [~] [~] B5" and b = "[~] B5" and
               P = "(md) := (snd(snd(snd(hd(MA)))))" and
               q = "Pre [&] sf [<=] x2" and G = "l [=] Real 0" in ConditionF,auto)
apply fast+
done
(************************)
(** composite: move and Q11-Q4**)

lemma DCR3_assist: "(high D) [^] (high D) |- (high D) [^] (high D) ==> (high D) [^] (high D) |- (high D)"
  apply (rule DCR3)
  apply fast
  done

lemma step_part1_comp_assist: "|- (l [=] Real 0 [|] high(Pre [&] sf [<=] x2)) [^]
                      (l [=] Real 0 [|] high(Pre [&] sf [<=] x2))
                    [-->] l [=] Real 0 [|] high(Pre [&] sf [<=] x2)"
apply (rule impR)
apply (rule LT1)
apply (rule LT1a)
apply (rule LL4)
apply (rule disjR)
apply fast
apply (rule LL3a)
apply (rule disjR)
apply fast
apply (rule LT1a)
apply (rule LL4)
apply (rule disjR)
apply fast
apply (rule disjR)
apply (rule thinR)
apply (cut_tac D="(Pre [&] sf [<=] x2)" in DCR3_assist,auto)
apply fast
done

lemma step_part1_comp : "{Init [&] Pre}
        Move; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q11; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))) ;
        Q12; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q13; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q3; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q4 {Pre [&] sf [<=] x2; (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))}"
apply (cut_tac p = "Init [&] Pre" and P = "Move" and
        m = "Pre [&] sf [<=] x2" and
        H = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" and
        Q = "Q11; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))) ;
        Q12; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q13; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q3; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q4" and q = "Pre [&] sf [<=] x2" and
        G = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" in Sequence)
apply (rule step_continuous)
apply (cut_tac p = "Pre [&] sf [<=] x2" and P = "Q11" and
        m = "Pre [&] sf [<=] x2" and
        H = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" and
        Q = "Q12; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q13; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q3; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q4" and q = "Pre [&] sf [<=] x2" and
        G = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" in Sequence)
apply (rule step_Q11)
apply (cut_tac p = "Pre [&] sf [<=] x2" and P = "Q12" and
        m = "Pre [&] sf [<=] x2" and
        H = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" and
        Q = "Q13; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q3; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q4" and q = "Pre [&] sf [<=] x2" and
        G = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" in Sequence)
apply (rule step_Q12)
apply (cut_tac p = "Pre [&] sf [<=] x2" and P = "Q13" and
        m = "Pre [&] sf [<=] x2" and
        H = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" and
        Q = "Q3; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q4" and q = "Pre [&] sf [<=] x2" and
        G = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" in Sequence)
apply (rule step_Q13)
apply (cut_tac p = "Pre [&] sf [<=] x2" and P = "Q3" and
        m = "Pre [&] sf [<=] x2" and
        H = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" and
        Q = "Q4" and q = "Pre [&] sf [<=] x2" and
        G = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" in Sequence)
apply (rule step_Q3)
apply (rule step_Q4)
apply (rule ConsequenceS,auto)
apply (rule conjR)
apply (rule impR)
apply (rule basic)
apply (rule conjR)
apply (rule impR)
apply (rule basic)
apply (rule step_part1_comp_assist)
apply (rule ConsequenceS,auto)
apply (rule conjR)
apply (rule impR)
apply (rule basic)
apply (rule conjR)
apply (rule impR)
apply (rule basic)
apply (rule step_part1_comp_assist)
apply (rule ConsequenceS,auto)
apply (rule conjR)
apply (rule impR)
apply (rule basic)
apply (rule conjR)
apply (rule impR)
apply (rule basic)
apply (rule step_part1_comp_assist)
apply (rule ConsequenceS,auto)
apply (rule conjR)
apply (rule impR)
apply (rule basic)
apply (rule conjR)
apply (rule impR)
apply (rule basic)
apply (rule step_part1_comp_assist)
apply (rule ConsequenceS,auto)
apply (rule conjR)
apply (rule impR)
apply (rule basic)
apply (rule conjR)
apply (rule impR)
apply (rule basic)
apply (rule step_part1_comp_assist)
done

(*********************************)
(**with the communication**)

(*Assert B6 holds.*)
lemma Assert1 : "(Pre [&] sf [<=] x2)|- B6"
apply (rule conjL)
apply (rule exchL)
apply (rule thinL)
apply (simp add:Pre_def B6_def seg1_def level_def x2_def)
apply (rule conjL)
apply (rule exchL)
apply (rule thinL)
apply (rule disjR)
apply (rule exchR)
apply (rule thinR)
apply (rule Trans1,auto)
done

lemma step_parallel: "{Init [&] Pre, WTrue}
        ((Move; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q11; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))) ;
        Q12; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q13; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q3; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q4) || Skip) {Pre [&] sf [<=] x2, WTrue;
                 (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))), (l [=] Real 0)}"
apply (cut_tac px = "Init [&] Pre" and py = "WTrue" and
        Px = "(Move; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q11; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))) ;
        Q12; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q13; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q3; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q4)" and Py = "Skip" and
        qx = "Pre [&] sf [<=] x2" and qy = "WTrue" and
        Hx = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" and
        Hy = "(l [=] Real 0)" in Parallel2, auto)
apply (rule step_part1_comp)
apply (rule Skip)
  apply fast
    done

(*********************************)
(**communication with sequential composition**)

lemma assist_comm_sequential : "substF([((BVar bw), Bool False)], (BVar bw) [=] (Bool False)) = (Bool False [=] Bool False)"
apply (unfold substF_def, auto)
done

lemma step_comm_sequential: "{Init [&] Pre, WTrue}
        (((Move; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q11; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))) ;
        Q12; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q13; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q3; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q4); (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
       (chw !! (Bool False))) || (Skip; (WTrue, l [=] Real 0); chw ?? (BVar bw)))
       {Pre [&] sf [<=] x2, ((BVar bw) [=] (Bool False));
       (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))), (l [=] Real 0) [|] (high (WTrue))}"
apply (cut_tac
        Px = "((Move; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q11; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))) ;
        Q12; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q13; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q3; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q4); (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        (chw !! (Bool False)))" and
        Py = "Skip; (WTrue, l [=]  Real 0) ; chw??(BVar bw)" and
        p = "Init [&] Pre" and r = "WTrue" and
        q = "Pre [&] sf [<=] x2" and s = "BVar bw [=] Bool False" and
        H = "l [=] Real 0 [|] (high (Pre [&] sf [<=] x2))" and
        G = "l [=] Real 0 [|] high WTrue" and
        px = "Init [&] Pre" and py = "WTrue" and
        qx = "Pre [&] sf [<=] x2" and qy = "BVar bw [=] Bool False" and
        Hx = " (l [=] Real 0 [|] (high (Pre [&] sf [<=] x2))) [&] WTrue" and
        Hy = "(l [=] Real 0 [|] high WTrue) [&] WTrue" in ConsequenceP, auto)
apply (cut_tac px = "Init [&] Pre" and py = " WTrue" and
        Px = "Move; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q11; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))) ;
        Q12; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q13; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q3; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q4" and qx = "Pre [&] sf [<=] x2" and
        Hx = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" and
        Py = " Skip" and qy = "WTrue" and
        Hy = "l [=] Real 0" and ch = "chw" and x = "(BVar bw)" and e = "Bool False" and
        rx = "Pre [&] sf [<=] x2" and ry = "((BVar bw) [=] (Bool False))" and
        Gx = " (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" and
        Gy = "(l [=] Real 0) [|] (high (WTrue))" and
        H = "WTrue" in Communication)
defer
apply (rule step_parallel)
apply (rule conjR)
apply fast
apply (rule impR)
apply (simp add:assist_comm_sequential)
apply fast
apply (rule conjR)
apply (rule impR)
apply (rule disjR)
apply (rule thinR)
apply (rule LT1)
apply (rule LL3a)
apply fast
apply (cut_tac S = "Pre [&] sf [<=] x2" in DCL3,auto)
apply (rule basic)
apply (rule impR)
apply (rule disjR)
apply (rule LL3a)
apply (fast)
apply (rule impR)
apply fast
apply (rule conjR)
apply fast
apply (rule conjR)
apply fast
apply (rule conjR)
apply fast
apply (rule conjR)
apply fast
apply (rule conjR)
apply fast+
done

(**************)
(** for Q5**)

lemma assist_Q5 : "|- Pre [&] sf [<=] x2 [-->] [~] [~] B6"
apply (rule impR)
apply (rule notR)
apply (rule notL)
apply (simp add:Pre_def B6_def level_def)
apply (rule disjR)
apply (rule exchR)
apply (rule thinR)
apply (rule conjL)
apply (rule exchL)
apply (rule conjL)
apply (rule thinL)
apply (rule exchL)
apply (rule thinL)
apply (rule Trans1,auto)
done

lemma step_Q5 : "{Pre [&] sf [<=] x2} Q5 {Pre [&] sf [<=] x2; (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))} "
apply (cut_tac p = "(Pre [&] sf [<=] x2)" and q = "Pre [&] sf [<=] x2" and
               H = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" and
               px = "(Pre [&] sf [<=] x2)" and qx = "Pre [&] sf [<=] x2" and
               Hx = "(l [=] Real 0)" and
               P = "Q5" in ConsequenceS, auto)
prefer 2
apply (fast)
apply (simp add:Q5_def)
apply (cut_tac p = "Pre [&] sf [<=] x2" and b = "[~] B6" and
               P = "((Temp_t2) := (ct); (WTrue, WTrue) ; chd??br; (WTrue,
                       WTrue) ; IF (br [=] Bool True) (fst(hd(tl(MA)))) := (Real 40))"
           and q = "Pre [&] sf [<=] x2" and G = "l [=] Real 0" in ConditionF,auto)
apply (rule assist_Q5)
apply fast+
done

(*************************)
(**for driver process**)

lemma step_driver : "{BVar bw [=] (Bool False)} P {BVar bw [=] (Bool False); (l [=] Real 0) [|] (high WTrue)}"
apply (cut_tac p = "BVar bw [=] (Bool False)" and q = "BVar bw [=] (Bool False)" and
               H = "(l [=] Real 0) [|] (high WTrue)" and
               px = "BVar bw [=] (Bool False)" and qx = "BVar bw [=] (Bool False)" and
               Hx = "(l [=] Real 0)" and
               P = "P" in ConsequenceS, auto)
prefer 2
apply (fast)
apply (simp add:P_def)
apply (cut_tac p = "BVar bw [=] Bool False" and b = "(BVar bw [=] Bool True)" and
               P = "(chd!!(Bool True)[[chd!!(Bool False))" and
               q = "BVar bw [=] Bool False" and G = "l [=] Real 0" in ConditionF)
apply (rule impR)
apply (rule Trans1,auto)
apply fast+
done

(***************************)
(**for once, repetition in the following**)

lemma assist_System_proof : "|- (l [=] Real 0 [|] high (p)) [^] (l [=] Real 0 [|] high (p)) [-->] (l [=] Real 0 [|] high (p))"
apply (rule impR)
apply (rule LT1)
apply (rule LT1a)
apply (rule LL4)
apply fast
apply (rule LL3a)
apply fast
apply (rule LT1a)
apply (rule LL4)
apply fast
apply (rule disjR)
apply (rule thinR)
apply (cut_tac S = "p" in DCL3,auto)
apply (rule basic)
done

lemma step_System_once : "{Init [&] Pre, WTrue} Train||Driver {Pre [&] sf [<=] x2, WTrue;
                     (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))), (l [=] Real 0) [|] (high (WTrue))}"
apply (cut_tac p = "Init [&] Pre" and r = "WTrue" and
               Px = "Train" and Py = "Driver" and
               q = "Pre [&] sf [<=] x2" and s = "WTrue" and
               H = "l [=] Real 0 [|] high (Pre [&] sf [<=] x2)" and
               G = "l [=] Real 0 [|] high (WTrue)" and px = "Init [&] Pre" and
               py = "WTrue" and qx = "Pre [&] sf [<=] x2" and
               qy = "BVar bw [=] Bool False" and
               Hx = "(l [=] Real 0 [|] high (Pre [&] sf [<=] x2)) [^]
                     (l [=] Real 0 [|] high (Pre [&] sf [<=] x2))" and
               Hy = "(l [=] Real 0 [|] high (WTrue)) [^] (l [=] Real 0 [|] high (WTrue))"
               in ConsequenceP,auto)
apply (simp add:Train_def Driver_def Imd_def SP1_def)
apply (cut_tac px = "Init [&] Pre" and py = "WTrue" and
        Px = "((Move; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q11; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q12; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q13; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q3; (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
        Q4); (Pre [&] sf [<=] x2, (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))));
       (chw !! (Bool False)))" and
        qx = "Pre [&] sf [<=] x2" and
        Hx = "l [=] Real 0 [|] high (Pre [&] sf [<=] x2)" and Qx = "Q5" and
        Py = "Skip; (WTrue, l [=] Real 0) ; chw??(BVar bw)" and
        qy = "BVar bw [=] Bool False" and
               Hy = " l [=] Real 0 [|] high (WTrue)" and Qy = "P" and
               rx = "Pre [&] sf [<=] x2" and ry = "BVar bw [=] Bool False" and
               Gx = "l [=] Real 0 [|] high (Pre [&] sf [<=] x2)" and
               Gy = " l [=] Real 0 [|] high (WTrue)" in Parallel1)
apply (rule step_comm_sequential)
apply (rule step_Q5)
apply (rule step_driver)
apply assumption
apply (rule conjR)
apply fast
apply (rule conjR)
apply fast
apply (rule conjR)
apply fast
apply (rule conjR)
apply fast
apply (rule conjR)
apply (rule assist_System_proof)
apply (rule assist_System_proof)
done

(***************************)
(**for repetition**)

(* All the fact* are create to support the steps, and all the 10 steps fforms the proof.*)
lemma System_proof : "{Init [&] Pre, WTrue} System {Pre [&] sf [<=] x2,
       WTrue; (l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2))),
       (l [=] Real 0) [|] (high (WTrue))}"
  apply (simp add:System_def)
  (*  {px, py}Px* || Py*{px, py ; Hx, Hy} *)
  thm Repetition[no_vars]
apply (cut_tac px = "Init [&] Pre" and py = "WTrue" and
               Px = "Train" and Py = "Driver" and
               qx = "Pre [&] sf [<=] x2" and qy = "WTrue" and
               Hx = "(l [=] Real 0) [|] (high (Pre [&] (sf [<=] x2)))" and
               Hy = "l [=] Real 0 [|] (high WTrue)" in Repetition,auto)
apply (rule step_System_once)
apply (rule assist_System_proof)
apply (rule assist_System_proof)
done

end


(*  Title:      HOL/HOLCF/IOA/ex/TrivEx2.thy
    Author:     Olaf Müller
*)

section {* Trivial Abstraction Example with fairness *}

theory TrivEx2
imports IOA Abstraction
begin

datatype action = INC

definition
  C_asig :: "action signature" where
  "C_asig = ({},{INC},{})"
definition
  C_trans :: "(action, nat)transition set" where
  "C_trans =
   {tr. let s = fst(tr);
            t = snd(snd(tr))
        in case fst(snd(tr))
        of
        INC       => t = Suc(s)}"
definition
  C_ioa :: "(action, nat)ioa" where
  "C_ioa = (C_asig, {0}, C_trans,{},{})"
definition
  C_live_ioa :: "(action, nat)live_ioa" where
  "C_live_ioa = (C_ioa, WF C_ioa {INC})"

definition
  A_asig :: "action signature" where
  "A_asig = ({},{INC},{})"
definition
  A_trans :: "(action, bool)transition set" where
  "A_trans =
   {tr. let s = fst(tr);
            t = snd(snd(tr))
        in case fst(snd(tr))
        of
        INC       => t = True}"
definition
  A_ioa :: "(action, bool)ioa" where
  "A_ioa = (A_asig, {False}, A_trans,{},{})"
definition
  A_live_ioa :: "(action, bool)live_ioa" where
  "A_live_ioa = (A_ioa, WF A_ioa {INC})"

definition
  h_abs :: "nat => bool" where
  "h_abs n = (n~=0)"

axiomatization where
  MC_result: "validLIOA (A_ioa,WF A_ioa {INC}) (<>[] <%(b,a,c). b>)"

lemma h_abs_is_abstraction:
"is_abstraction h_abs C_ioa A_ioa"
apply (unfold is_abstraction_def)
apply (rule conjI)
txt {* start states *}
apply (simp (no_asm) add: h_abs_def starts_of_def C_ioa_def A_ioa_def)
txt {* step case *}
apply (rule allI)+
apply (rule imp_conj_lemma)
apply (simp (no_asm) add: trans_of_def C_ioa_def A_ioa_def C_trans_def A_trans_def)
apply (induct_tac "a")
apply (simp (no_asm) add: h_abs_def)
done

lemma Enabled_implication:
    "!!s. Enabled A_ioa {INC} (h_abs s) ==> Enabled C_ioa {INC} s"
  apply (unfold Enabled_def enabled_def h_abs_def A_ioa_def C_ioa_def A_trans_def
    C_trans_def trans_of_def)
  apply auto
  done

lemma h_abs_is_liveabstraction:
"is_live_abstraction h_abs (C_ioa, WF C_ioa {INC}) (A_ioa, WF A_ioa {INC})"
apply (unfold is_live_abstraction_def)
apply auto
txt {* is_abstraction *}
apply (rule h_abs_is_abstraction)
txt {* temp_weakening *}
apply abstraction
apply (erule Enabled_implication)
done

lemma TrivEx2_abstraction:
  "validLIOA C_live_ioa (<>[] <%(n,a,m). n~=0>)"
apply (unfold C_live_ioa_def)
apply (rule AbsRuleT2)
apply (rule h_abs_is_liveabstraction)
apply (rule MC_result)
apply abstraction
apply (simp add: h_abs_def)
done

end


theory dfs
imports
Main
Simpl.StateSpace
Simpl.Vcg
Graph_Theory.Digraph
"HOL-Statespace.StateSpaceSyntax"
begin

hoarestate ('a, 'b) vars =
  G :: "('a, 'b) pre_digraph"
  root :: 'a
  discovered :: "'a set"

  stack :: "'a list"
  v :: 'a

context vars
begin

definition dfs where
"dfs G \<equiv>
  \<acute>discovered :== {};;
  \<acute>stack :== [\<acute>root];;
  WHILE \<acute>stack \<noteq> []
  INV \<lbrace> \<acute>G = G
        \<and> fin_digraph \<acute>G
        \<and> set \<acute>stack \<subseteq> verts \<acute>G
        \<and> {v. reachable \<acute>G \<acute>root v} = \<acute>discovered \<union> (\<Union>v \<in> set \<acute>stack. {w. reachable \<acute>G v w})
        \<and> (\<forall>v \<in> \<acute>discovered. \<forall>w. dominates \<acute>G v w \<longrightarrow> w \<in> \<acute>discovered \<union> set \<acute>stack)
      \<rbrace>
  VAR (card ({v. reachable \<acute>G \<acute>root v} - \<acute>discovered) <*MLEX*> (MEASURE length \<acute>stack))
  DO
    \<acute>v :== hd \<acute>stack;;
    \<acute>stack :== tl \<acute>stack;;
    IF \<acute>v \<notin> \<acute>discovered THEN
      \<acute>discovered :== insert \<acute>v \<acute>discovered;;
      \<acute>stack :== (SOME ws. set ws = {head \<acute>G e | e. e \<in> out_arcs \<acute>G \<acute>v}) @ \<acute>stack
    FI
  OD
"

lemma dfs_partial1:
assumes a1: "wf_digraph G"
and a2: "reachable G v x"
shows
"\<lbrakk> \<forall>v\<in>discovered. \<forall>w. v \<rightarrow>\<^bsub>G\<^esub> w \<longrightarrow> w \<in> discovered \<or> w \<in> set stack
; \<forall>xa\<in>set (tl stack). \<not> xa \<rightarrow>\<^sup>*\<^bsub>G\<^esub> x
; v \<in> discovered
; v = hd stack
\<rbrakk> \<Longrightarrow> (v, x) \<in> rtrancl {(u, v). (u, v) \<in> arcs_ends G \<and> {u, v} \<subseteq> discovered}"
  apply (induct rule: wf_digraph.reachable_induct[where G=G and u=v])
  using a1 a2 apply blast+
  apply clarsimp
  apply (subgoal_tac "\<forall>xa\<in>set (tl stack). \<not> xa \<rightarrow>\<^sup>*\<^bsub>G\<^esub> x")
   apply clarsimp
   apply (subgoal_tac "x \<in> discovered")
    apply (frule_tac x=x in bspec, simp)
    apply (erule_tac x=y in allE)
    apply (metis (no_types, lifting) a1 case_prod_conv insert_iff list.collapse list.sel(2) list.simps(15) mem_Collect_eq rtrancl.simps wf_digraph.adj_in_verts(2) wf_digraph.reachable_conv')
  using rtrancl.cases apply fastforce
  apply (meson a1 wf_digraph.reachable_adjI wf_digraph.reachable_trans)
  done

lemma dfs_total: "\<Gamma> \<turnstile>\<^sub>t \<lbrace> \<acute>G = G \<and> \<acute>root \<in> verts \<acute>G \<and> fin_digraph \<acute>G \<rbrace> dfs G \<lbrace> \<acute>G = G \<and> \<acute>discovered = {v. reachable \<acute>G \<acute>root v} \<rbrace>"
(*
apply (rule TerminationPartial)
*)
unfolding dfs_def apply (vcg; clarsimp simp add: fin_digraph.axioms(1) wf_digraph.reachable_refl)
  apply (subgoal_tac "set (SOME ws. set ws = {pre_digraph.head G e |e. e \<in> arcs G \<and> tail G e = hd stack})
  = {pre_digraph.head G e |e. e \<in> arcs G \<and> tail G e = hd stack}")
  apply clarsimp
  apply (thin_tac "set (SOME ws. set ws = {pre_digraph.head G e |e. e \<in> arcs G \<and> tail G e = hd stack}) =
          {pre_digraph.head G e |e. e \<in> arcs G \<and> tail G e = hd stack}")
  apply (safe; clarsimp?)
              apply (metis Diff_insert0 card_Diff_insert diff_le_self nat_less_le)
             apply (subgoal_tac "hd stack \<in> discovered")
              apply blast
             apply (subgoal_tac "discovered \<union> (\<Union>v\<in>set stack. Collect (reachable G v)) - insert (hd stack) discovered
                        \<subseteq> discovered \<union> (\<Union>v\<in>set stack. Collect (reachable G v)) - discovered")
              apply (subgoal_tac "discovered \<union> (\<Union>v\<in>set stack. Collect (reachable G v)) - insert (hd stack) discovered
                         = discovered \<union> (\<Union>v\<in>set stack. Collect (reachable G v)) - discovered")
               apply (smt (verit, del_insts) Diff_iff UN_insert Un_iff fin_digraph.axioms(1) insertI1 list.collapse list.simps(15) mem_Collect_eq subsetD wf_digraph.reachable_refl)
              apply (subgoal_tac "finite (discovered \<union> (\<Union>v\<in>set stack. Collect (reachable G v)) - discovered)")
               apply (meson psubsetI psubset_card_mono)
              apply (subgoal_tac "finite (Collect (reachable G root))")
               apply (metis finite_Diff)
              apply (metis fin_digraph_axioms_def fin_digraph_def finite_subset mem_Collect_eq reachable_in_vertsE subsetI)
             apply fastforce
            apply (simp add: fin_digraph.axioms(1) wf_digraph.head_in_verts)
           apply (meson in_mono list.set_sel(2))
          apply (metis insertE list.collapse list.simps(15) pre_digraph.converse_reachable_cases reachableE)
         apply (meson fin_digraph_def in_mono list.set_sel(1) wf_digraph.reachable_refl)
        apply (metis arc_to_ends_def fin_digraph.axioms(1) hd_in_set wf_digraph.adj_reachable_trans wf_digraph.dominatesI)
       apply (meson list.set_sel(2))
      apply auto[1]
     apply (metis insertE list.collapse list.simps(15))
    apply (meson in_mono list.set_sel(2))
   apply (subgoal_tac "v = hd stack")
    apply clarsimp
    apply (subgoal_tac "(hd stack, x) \<in> rtrancl {(u, v). (u, v) \<in> arcs_ends G \<and> {u, v} \<subseteq> discovered}")
     apply (erule_tac ?a1.0="hd stack" in rtrancl.cases; clarsimp)
    apply (subgoal_tac "wf_digraph G")
     apply (rule dfs_partial1; blast)
  using fin_digraph.axioms(1) apply fastforce
     apply (metis insertE list.collapse list.simps(15))
    apply (meson list.set_sel(2))
   apply (metis insertE list.collapse list.simps(15))
  apply (subgoal_tac "finite {pre_digraph.head G e |e. e \<in> arcs G \<and> tail G e = hd stack}")
   apply (meson finite_list someI_ex)
  using finite_image_set fin_digraph.finite_arcs finite_subset apply fastforce
  done

definition dfs' where
"dfs' G \<equiv>
  \<acute>discovered :== {};;
  \<acute>stack :== [\<acute>root];;
  WHILE \<acute>stack \<noteq> []
  INV \<lbrace> \<acute>G = G
        \<and> fin_digraph \<acute>G
        \<and> set \<acute>stack \<subseteq> verts \<acute>G
        \<and> {v. reachable \<acute>G \<acute>root v} = \<acute>discovered \<union> (\<Union>v \<in> set \<acute>stack. {w. reachable \<acute>G v w})
        \<and> (\<forall>v \<in> \<acute>discovered. \<forall>w. dominates \<acute>G v w \<longrightarrow> w \<in> \<acute>discovered \<union> set \<acute>stack)
      \<rbrace>
  VAR (card ({v. reachable \<acute>G \<acute>root v} - \<acute>discovered) <*MLEX*> (MEASURE length \<acute>stack))
  DO
    \<acute>v :== hd \<acute>stack;;
    \<acute>stack :== tl \<acute>stack;;
    IF \<acute>v \<notin> \<acute>discovered THEN
      \<acute>discovered :== insert \<acute>v \<acute>discovered;;
      Spec {(s, s'). \<exists>ws. s' = s\<lparr>locals := locals s<stack_' := ws @ (locals s\<cdot>stack_')>\<rparr>}
    FI
  OD
"

lemma dfs'_total: "\<Gamma> \<turnstile>\<^sub>t \<lbrace> \<acute>G = G \<and> \<acute>root \<in> verts \<acute>G \<and> fin_digraph \<acute>G \<rbrace> dfs' G \<lbrace> \<acute>G = G \<and> \<acute>discovered = {v. reachable \<acute>G \<acute>root v} \<rbrace>"
unfolding dfs'_def apply vcg
end

end


theory Benchmark_Set
imports
  "HOL-Word.Word"
  "HOL-Library.Cardinality"
begin

instantiation word :: (len) card_UNIV begin
definition "finite_UNIV = Phantom('a word) True"
definition "card_UNIV = Phantom('a word) (2 ^ LENGTH('a))"
instance by(intro_classes)(simp_all add: card_UNIV_word_def card_word finite_UNIV_word_def)
end

definition word_of_integer :: "integer \<Rightarrow> 'a::len0 word"
where "word_of_integer = word_of_int \<circ> int_of_integer"

lemma word_of_integer_code [code]:
  "word_of_integer k =
  (if k < 0 then - word_of_integer (- k)
   else if k = 0 then 0
   else let (q, r) = divmod_integer k 2
        in if r = 0 then 2 * word_of_integer q else 2 * word_of_integer q + 1)"
apply(unfold word_of_integer_def o_def)
apply(subst int_of_integer_code)
apply(clarsimp simp add: divmod_integer_def)
by (metis minus_minus plus_word.abs_eq times_word.abs_eq wi_hom_neg word_1_wi word_numeral_alt)

definition word_of :: "natural \<Rightarrow> 'a::len0 word"
where "word_of = word_of_integer o integer_of_natural"

text \<open>randomly generate a set of (up to) n elements drawn from 0 to bound\<close>

fun gen_build1 :: "natural \<Rightarrow> nat \<Rightarrow> (32 word set \<times> Random.seed) \<Rightarrow> (32 word set \<times> Random.seed)"
where
  "gen_build1 bound n (A, seed) =
  (if n = 0 then (A, seed)
   else let (x, seed') = Random.range bound seed in gen_build1 bound (n - 1) (insert (word_of x) A, seed'))"

declare gen_build1.simps[simp del]

definition build1 :: "natural \<Rightarrow> Random.seed \<Rightarrow> (32 word set \<times> Random.seed)"
where
  "build1 bound seed =
  (let (n', seed') = Random.range bound seed;
       (compl, seed'') = Random.range 2 seed;
       (x, seed''') = gen_build1 bound (Code_Numeral.nat_of_natural n') ({}, seed'')
   in (if compl = 0 then x else - x, seed'''))"

text \<open>randomly generate a set of (up to) n sets each with a random number between 0 and bound of elements between 0 and bound\<close>

fun gen_build2 :: "natural \<Rightarrow> nat \<Rightarrow> (32 word set set \<times> Random.seed) \<Rightarrow> (32 word set set \<times> Random.seed)"
where
  "gen_build2 bound n (A, seed) =
  (if n = 0 then (A, seed)
   else let (x, seed') = build1 bound seed
        in gen_build2 bound (n - 1) (insert x A, seed'))"

declare gen_build2.simps[simp del]

definition build :: "nat \<Rightarrow> nat \<Rightarrow> Random.seed \<Rightarrow> 32 word set set \<times> Random.seed"
where "build n m seed = gen_build2 (of_nat m) n ({}, seed)"

fun gen_lookup :: "32 word set set \<Rightarrow> natural \<Rightarrow> nat \<Rightarrow> (nat \<times> Random.seed) \<Rightarrow> (nat \<times> Random.seed)"
where
  "gen_lookup A bound n (hits, seed) =
  (if n = 0 then (hits, seed)
   else let (x, seed') = build1 bound seed
        in gen_lookup A bound (n - 1) (if x : A then hits + 1 else hits, seed'))"

declare gen_lookup.simps [simp del]

primrec lookup :: "nat \<Rightarrow> nat \<Rightarrow> (32 word set set \<times> Random.seed) \<Rightarrow> (nat \<times> Random.seed)"
where "lookup n m (A, seed) = gen_lookup A (of_nat m) 100 (0, seed)"

definition covered :: "32 word set set \<Rightarrow> nat"
where "covered A = card (\<Union>A)"

definition complete :: "nat \<Rightarrow> nat \<Rightarrow> Random.seed \<Rightarrow> (nat \<times> nat)"
where "complete n m seed = (let (A, seed') = build n m seed in (fst (lookup n m (A, seed)), covered A))"

end


(*  Title:      HOL/UNITY/Simple/Lift.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

The Lift-Control Example.
*)

theory Lift
imports "../UNITY_Main"
begin

record state =
  floor :: "int"            \<comment> \<open>current position of the lift\<close>
  "open" :: "bool"          \<comment> \<open>whether the door is opened at floor\<close>
  stop  :: "bool"           \<comment> \<open>whether the lift is stopped at floor\<close>
  req   :: "int set"        \<comment> \<open>for each floor, whether the lift is requested\<close>
  up    :: "bool"           \<comment> \<open>current direction of movement\<close>
  move  :: "bool"           \<comment> \<open>whether moving takes precedence over opening\<close>

axiomatization
  Min :: "int" and   \<comment> \<open>least and greatest floors\<close>
  Max :: "int"       \<comment> \<open>least and greatest floors\<close>
where
  Min_le_Max [iff]: "Min \<le> Max"

  \<comment> \<open>Abbreviations: the "always" part\<close>

definition
  above :: "state set"
  where "above = {s. \<exists>i. floor s < i & i \<le> Max & i \<in> req s}"

definition
  below :: "state set"
  where "below = {s. \<exists>i. Min \<le> i & i < floor s & i \<in> req s}"

definition
  queueing :: "state set"
  where "queueing = above \<union> below"

definition
  goingup :: "state set"
  where "goingup = above \<inter> ({s. up s}  \<union> -below)"

definition
  goingdown :: "state set"
  where "goingdown = below \<inter> ({s. ~ up s} \<union> -above)"

definition
  ready :: "state set"
  where "ready = {s. stop s & ~ open s & move s}"

  \<comment> \<open>Further abbreviations\<close>

definition
  moving :: "state set"
  where "moving = {s. ~ stop s & ~ open s}"

definition
  stopped :: "state set"
  where "stopped = {s. stop s  & ~ open s & ~ move s}"

definition
  opened :: "state set"
  where "opened = {s. stop s  &  open s  &  move s}"

definition
  closed :: "state set"  \<comment> \<open>but this is the same as ready!!\<close>
  where "closed = {s. stop s  & ~ open s &  move s}"

definition
  atFloor :: "int => state set"
  where "atFloor n = {s. floor s = n}"

definition
  Req :: "int => state set"
  where "Req n = {s. n \<in> req s}"

  \<comment> \<open>The program\<close>

definition
  request_act :: "(state*state) set"
  where "request_act = {(s,s'). s' = s (|stop:=True, move:=False|)
                                  & ~ stop s & floor s \<in> req s}"

definition
  open_act :: "(state*state) set"
  where "open_act =
         {(s,s'). s' = s (|open :=True,
                           req  := req s - {floor s},
                           move := True|)
                       & stop s & ~ open s & floor s \<in> req s
                       & ~(move s & s \<in> queueing)}"

definition
  close_act :: "(state*state) set"
  where "close_act = {(s,s'). s' = s (|open := False|) & open s}"

definition
  req_up :: "(state*state) set"
  where "req_up =
         {(s,s'). s' = s (|stop  :=False,
                           floor := floor s + 1,
                           up    := True|)
                       & s \<in> (ready \<inter> goingup)}"

definition
  req_down :: "(state*state) set"
  where "req_down =
         {(s,s'). s' = s (|stop  :=False,
                           floor := floor s - 1,
                           up    := False|)
                       & s \<in> (ready \<inter> goingdown)}"

definition
  move_up :: "(state*state) set"
  where "move_up =
         {(s,s'). s' = s (|floor := floor s + 1|)
                       & ~ stop s & up s & floor s \<notin> req s}"

definition
  move_down :: "(state*state) set"
  where "move_down =
         {(s,s'). s' = s (|floor := floor s - 1|)
                       & ~ stop s & ~ up s & floor s \<notin> req s}"

definition
  button_press  :: "(state*state) set"
      \<comment> \<open>This action is omitted from prior treatments, which therefore are
        unrealistic: nobody asks the lift to do anything!  But adding this
        action invalidates many of the existing progress arguments: various
        "ensures" properties fail. Maybe it should be constrained to only
        allow button presses in the current direction of travel, like in a
        real lift.\<close>
  where "button_press =
         {(s,s'). \<exists>n. s' = s (|req := insert n (req s)|)
                        & Min \<le> n & n \<le> Max}"

definition
  Lift :: "state program"
    \<comment> \<open>for the moment, we OMIT \<open>button_press\<close>\<close>
  where "Lift = mk_total_program
                ({s. floor s = Min & ~ up s & move s & stop s &
                          ~ open s & req s = {}},
                 {request_act, open_act, close_act,
                  req_up, req_down, move_up, move_down},
                 UNIV)"

  \<comment> \<open>Invariants\<close>

definition
  bounded :: "state set"
  where "bounded = {s. Min \<le> floor s & floor s \<le> Max}"

definition
  open_stop :: "state set"
  where "open_stop = {s. open s --> stop s}"

definition
  open_move :: "state set"
  where "open_move = {s. open s --> move s}"

definition
  stop_floor :: "state set"
  where "stop_floor = {s. stop s & ~ move s --> floor s \<in> req s}"

definition
  moving_up :: "state set"
  where "moving_up = {s. ~ stop s & up s -->
                   (\<exists>f. floor s \<le> f & f \<le> Max & f \<in> req s)}"

definition
  moving_down :: "state set"
  where "moving_down = {s. ~ stop s & ~ up s -->
                     (\<exists>f. Min \<le> f & f \<le> floor s & f \<in> req s)}"

definition
  metric :: "[int,state] => int"
  where "metric =
       (%n s. if floor s < n then (if up s then n - floor s
                                  else (floor s - Min) + (n-Min))
             else
             if n < floor s then (if up s then (Max - floor s) + (Max-n)
                                  else floor s - n)
             else 0)"

locale Floor =
  fixes n
  assumes Min_le_n [iff]: "Min \<le> n"
      and n_le_Max [iff]: "n \<le> Max"

lemma not_mem_distinct: "[| x \<notin> A;  y \<in> A |] ==> x \<noteq> y"
by blast

declare Lift_def [THEN def_prg_Init, simp]

declare request_act_def [THEN def_act_simp, simp]
declare open_act_def [THEN def_act_simp, simp]
declare close_act_def [THEN def_act_simp, simp]
declare req_up_def [THEN def_act_simp, simp]
declare req_down_def [THEN def_act_simp, simp]
declare move_up_def [THEN def_act_simp, simp]
declare move_down_def [THEN def_act_simp, simp]
declare button_press_def [THEN def_act_simp, simp]

(*The ALWAYS properties*)
declare above_def [THEN def_set_simp, simp]
declare below_def [THEN def_set_simp, simp]
declare queueing_def [THEN def_set_simp, simp]
declare goingup_def [THEN def_set_simp, simp]
declare goingdown_def [THEN def_set_simp, simp]
declare ready_def [THEN def_set_simp, simp]

(*Basic definitions*)
declare bounded_def [simp]
        open_stop_def [simp]
        open_move_def [simp]
        stop_floor_def [simp]
        moving_up_def [simp]
        moving_down_def [simp]

lemma open_stop: "Lift \<in> Always open_stop"
apply (rule AlwaysI, force)
apply (unfold Lift_def, safety)
done

lemma stop_floor: "Lift \<in> Always stop_floor"
apply (rule AlwaysI, force)
apply (unfold Lift_def, safety)
done

(*This one needs open_stop, which was proved above*)
lemma open_move: "Lift \<in> Always open_move"
apply (cut_tac open_stop)
apply (rule AlwaysI, force)
apply (unfold Lift_def, safety)
done

lemma moving_up: "Lift \<in> Always moving_up"
apply (rule AlwaysI, force)
apply (unfold Lift_def, safety)
apply (auto dest: order_le_imp_less_or_eq simp add: add1_zle_eq)
done

lemma moving_down: "Lift \<in> Always moving_down"
apply (rule AlwaysI, force)
apply (unfold Lift_def, safety)
apply (blast dest: order_le_imp_less_or_eq)
done

lemma bounded: "Lift \<in> Always bounded"
apply (cut_tac moving_up moving_down)
apply (rule AlwaysI, force)
apply (unfold Lift_def, safety, auto)
apply (drule not_mem_distinct, assumption, arith)+
done

subsection\<open>Progress\<close>

declare moving_def [THEN def_set_simp, simp]
declare stopped_def [THEN def_set_simp, simp]
declare opened_def [THEN def_set_simp, simp]
declare closed_def [THEN def_set_simp, simp]
declare atFloor_def [THEN def_set_simp, simp]
declare Req_def [THEN def_set_simp, simp]

text\<open>The HUG'93 paper mistakenly omits the Req n from these!\<close>

(** Lift_1 **)
lemma E_thm01: "Lift \<in> (stopped \<inter> atFloor n) LeadsTo (opened \<inter> atFloor n)"
apply (cut_tac stop_floor)
apply (unfold Lift_def, ensures_tac "open_act")
done  (*lem_lift_1_5*)

lemma E_thm02: "Lift \<in> (Req n \<inter> stopped - atFloor n) LeadsTo
                       (Req n \<inter> opened - atFloor n)"
apply (cut_tac stop_floor)
apply (unfold Lift_def, ensures_tac "open_act")
done  (*lem_lift_1_1*)

lemma E_thm03: "Lift \<in> (Req n \<inter> opened - atFloor n) LeadsTo
                       (Req n \<inter> closed - (atFloor n - queueing))"
apply (unfold Lift_def, ensures_tac "close_act")
done  (*lem_lift_1_2*)

lemma E_thm04: "Lift \<in> (Req n \<inter> closed \<inter> (atFloor n - queueing))
                       LeadsTo (opened \<inter> atFloor n)"
apply (unfold Lift_def, ensures_tac "open_act")
done  (*lem_lift_1_7*)

(** Lift 2.  Statements of thm05a and thm05b were wrong! **)

lemmas linorder_leI = linorder_not_less [THEN iffD1]

context Floor
begin

lemmas le_MinD = Min_le_n [THEN order_antisym]
  and Max_leD = n_le_Max [THEN [2] order_antisym]

declare le_MinD [dest!]
  and linorder_leI [THEN le_MinD, dest!]
  and Max_leD [dest!]
  and linorder_leI [THEN Max_leD, dest!]

(*lem_lift_2_0
  NOT an ensures_tac property, but a mere inclusion
  don't know why script lift_2.uni says ENSURES*)
lemma E_thm05c:
    "Lift \<in> (Req n \<inter> closed - (atFloor n - queueing))
             LeadsTo ((closed \<inter> goingup \<inter> Req n)  \<union>
                      (closed \<inter> goingdown \<inter> Req n))"
by (auto intro!: subset_imp_LeadsTo simp add: linorder_neq_iff)

(*lift_2*)
lemma lift_2: "Lift \<in> (Req n \<inter> closed - (atFloor n - queueing))
             LeadsTo (moving \<inter> Req n)"
apply (rule LeadsTo_Trans [OF E_thm05c LeadsTo_Un])
apply (unfold Lift_def)
apply (ensures_tac [2] "req_down")
apply (ensures_tac "req_up", auto)
done

(** Towards lift_4 ***)

declare if_split_asm [split]

(*lem_lift_4_1 *)
lemma E_thm12a:
     "0 < N ==>
      Lift \<in> (moving \<inter> Req n \<inter> {s. metric n s = N} \<inter>
              {s. floor s \<notin> req s} \<inter> {s. up s})
             LeadsTo
               (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (cut_tac moving_up)
apply (unfold Lift_def, ensures_tac "move_up", safe)
(*this step consolidates two formulae to the goal  metric n s' \<le> metric n s*)
apply (erule linorder_leI [THEN order_antisym, symmetric])
apply (auto simp add: metric_def)
done

(*lem_lift_4_3 *)
lemma E_thm12b: "0 < N ==>
      Lift \<in> (moving \<inter> Req n \<inter> {s. metric n s = N} \<inter>
              {s. floor s \<notin> req s} - {s. up s})
             LeadsTo (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (cut_tac moving_down)
apply (unfold Lift_def, ensures_tac "move_down", safe)
(*this step consolidates two formulae to the goal  metric n s' \<le> metric n s*)
apply (erule linorder_leI [THEN order_antisym, symmetric])
apply (auto simp add: metric_def)
done

(*lift_4*)
lemma lift_4:
     "0<N ==> Lift \<in> (moving \<inter> Req n \<inter> {s. metric n s = N} \<inter>
                            {s. floor s \<notin> req s}) LeadsTo
                           (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (rule LeadsTo_Trans [OF subset_imp_LeadsTo
                              LeadsTo_Un [OF E_thm12a E_thm12b]], auto)
done

(** towards lift_5 **)

(*lem_lift_5_3*)
lemma E_thm16a: "0<N
  ==> Lift \<in> (closed \<inter> Req n \<inter> {s. metric n s = N} \<inter> goingup) LeadsTo
             (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (cut_tac bounded)
apply (unfold Lift_def, ensures_tac "req_up")
apply (auto simp add: metric_def)
done

(*lem_lift_5_1 has ~goingup instead of goingdown*)
lemma E_thm16b: "0<N ==>
      Lift \<in> (closed \<inter> Req n \<inter> {s. metric n s = N} \<inter> goingdown) LeadsTo
                   (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (cut_tac bounded)
apply (unfold Lift_def, ensures_tac "req_down")
apply (auto simp add: metric_def)
done

(*lem_lift_5_0 proves an intersection involving ~goingup and goingup,
  i.e. the trivial disjunction, leading to an asymmetrical proof.*)
lemma E_thm16c:
     "0<N ==> Req n \<inter> {s. metric n s = N} \<subseteq> goingup \<union> goingdown"
by (force simp add: metric_def)

(*lift_5*)
lemma lift_5:
     "0<N ==> Lift \<in> (closed \<inter> Req n \<inter> {s. metric n s = N}) LeadsTo
                     (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (rule LeadsTo_Trans [OF subset_imp_LeadsTo
                              LeadsTo_Un [OF E_thm16a E_thm16b]])
apply (drule E_thm16c, auto)
done

(** towards lift_3 **)

(*lemma used to prove lem_lift_3_1*)
lemma metric_eq_0D [dest]:
     "[| metric n s = 0;  Min \<le> floor s;  floor s \<le> Max |] ==> floor s = n"
by (force simp add: metric_def)

(*lem_lift_3_1*)
lemma E_thm11: "Lift \<in> (moving \<inter> Req n \<inter> {s. metric n s = 0}) LeadsTo
                       (stopped \<inter> atFloor n)"
apply (cut_tac bounded)
apply (unfold Lift_def, ensures_tac "request_act", auto)
done

(*lem_lift_3_5*)
lemma E_thm13:
  "Lift \<in> (moving \<inter> Req n \<inter> {s. metric n s = N} \<inter> {s. floor s \<in> req s})
  LeadsTo (stopped \<inter> Req n \<inter> {s. metric n s = N} \<inter> {s. floor s \<in> req s})"
apply (unfold Lift_def, ensures_tac "request_act")
apply (auto simp add: metric_def)
done

(*lem_lift_3_6*)
lemma E_thm14: "0 < N ==>
      Lift \<in>
        (stopped \<inter> Req n \<inter> {s. metric n s = N} \<inter> {s. floor s \<in> req s})
        LeadsTo (opened \<inter> Req n \<inter> {s. metric n s = N})"
apply (unfold Lift_def, ensures_tac "open_act")
apply (auto simp add: metric_def)
done

(*lem_lift_3_7*)
lemma E_thm15: "Lift \<in> (opened \<inter> Req n \<inter> {s. metric n s = N})
             LeadsTo (closed \<inter> Req n \<inter> {s. metric n s = N})"
apply (unfold Lift_def, ensures_tac "close_act")
apply (auto simp add: metric_def)
done

(** the final steps **)

lemma lift_3_Req: "0 < N ==>
      Lift \<in>
        (moving \<inter> Req n \<inter> {s. metric n s = N} \<inter> {s. floor s \<in> req s})
        LeadsTo (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (blast intro!: E_thm13 E_thm14 E_thm15 lift_5 intro: LeadsTo_Trans)
done

(*Now we observe that our integer metric is really a natural number*)
lemma Always_nonneg: "Lift \<in> Always {s. 0 \<le> metric n s}"
apply (rule bounded [THEN Always_weaken])
apply (auto simp add: metric_def)
done

lemmas R_thm11 = Always_LeadsTo_weaken [OF Always_nonneg E_thm11]

lemma lift_3: "Lift \<in> (moving \<inter> Req n) LeadsTo (stopped \<inter> atFloor n)"
apply (rule Always_nonneg [THEN integ_0_le_induct])
apply (case_tac "0 < z")
(*If z \<le> 0 then actually z = 0*)
prefer 2 apply (force intro: R_thm11 order_antisym simp add: linorder_not_less)
apply (rule LeadsTo_weaken_R [OF asm_rl Un_upper1])
apply (rule LeadsTo_Trans [OF subset_imp_LeadsTo
                              LeadsTo_Un [OF lift_4 lift_3_Req]], auto)
done

lemma lift_1: "Lift \<in> (Req n) LeadsTo (opened \<inter> atFloor n)"
apply (rule LeadsTo_Trans)
 prefer 2
 apply (rule LeadsTo_Un [OF E_thm04 LeadsTo_Un_post])
 apply (rule E_thm01 [THEN [2] LeadsTo_Trans_Un])
 apply (rule lift_3 [THEN [2] LeadsTo_Trans_Un])
 apply (rule lift_2 [THEN [2] LeadsTo_Trans_Un])
 apply (rule LeadsTo_Trans_Un [OF E_thm02 E_thm03])
apply (rule open_move [THEN Always_LeadsToI])
apply (rule Always_LeadsToI [OF open_stop subset_imp_LeadsTo], clarify)
(*The case split is not essential but makes the proof much faster.*)
apply (case_tac "open x", auto)
done

end

end


theory Correctness
  imports "CorrectnessStacked" "Launchbury-Unstack"
begin

text {*
As a corollary of the correctness of the stacked semantics and its equivalence to the original
semantics we obtaim Theorem 2 from \cite{launchbury}.
*}

theorem correctness:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
  and [simp]:"distinctVars \<Gamma>"
  shows "\<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<^esub> = \<lbrakk>z\<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<^esub>" and "\<lbrace>\<Gamma>\<rbrace> \<le> \<lbrace>\<Delta>\<rbrace>"
proof-
  obtain x :: var where fresh: "atom x \<sharp> (\<Gamma>,e,\<Delta>,z)"
    by (rule obtain_fresh)

  have "\<Gamma> : e \<Down>\<^bsub>x#L\<^esub> \<Delta> : z"
    by (rule reds_add_var_L[OF assms(1) fresh], simp)
  hence "\<Gamma> : [(x, e)] \<Down> \<Delta> : [(x, z)]"
    by (rule add_stack, simp_all add: supp_Nil)
  moreover
  from fresh
  have "x \<notin> heapVars \<Gamma>"
    by (metis heapVars_not_fresh fresh_Pair)
  hence "distinctVars ([(x, e)] @ \<Gamma>)"
    by (simp add: distinctVars_append distinctVars_Cons)
  ultimately
  have le: "\<lbrace>[(x, e)] @ \<Gamma>\<rbrace> \<le> \<lbrace>[(x, z)] @ \<Delta>\<rbrace>"
    by (rule CorrectnessStacked.correctness)

  have "\<lbrace>\<Gamma>\<rbrace> = fmap_restr (heapVars \<Gamma>) (\<lbrace>(x, e) # \<Gamma>\<rbrace>)"
    apply (rule HSem_add_fresh[OF fempty_is_HSem_cond fempty_is_HSem_cond, simplified (no_asm), symmetric])
    using fresh apply (simp add: fresh_Pair)
    done
  also have "... \<le> fmap_restr (heapVars \<Delta>) (\<lbrace>(x, z) # \<Delta>\<rbrace>)"
    by (rule fmap_restr_le[OF le Launchbury.reds_doesnt_forget[OF assms(1)], simplified])
  also have "... = \<lbrace>\<Delta>\<rbrace>"
    apply (rule HSem_add_fresh[OF fempty_is_HSem_cond fempty_is_HSem_cond, simplified (no_asm)])
    using fresh apply (simp add: fresh_Pair)
    done
  finally show "\<lbrace>\<Gamma>\<rbrace> \<le> \<lbrace>\<Delta>\<rbrace>".

  have "\<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<^esub> = \<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>(x, e) # \<Gamma>\<rbrace>\<^esub>"
    apply (rule ESem_add_fresh[OF fempty_is_HSem_cond fempty_is_HSem_cond, symmetric])
    using fresh by (simp add: fresh_Pair)
  also have "... = \<lbrace>(x, e) # \<Gamma>\<rbrace> f! x"
    apply (rule the_lookup_HSem_heap[of _ "(x, e) # \<Gamma>" x, simplified (no_asm), symmetric])
    apply (rule fempty_is_HSem_cond)
    apply simp_all
    done
  also have "... = \<lbrace>(x, z) # \<Delta>\<rbrace> f! x"
    apply (rule arg_cong[OF fmap_less_eqD[OF le, simplified]])
    apply simp
    done
  also have "... = \<lbrakk>z\<rbrakk>\<^bsub>\<lbrace>(x, z) # \<Delta>\<rbrace>\<^esub>"
    apply (rule the_lookup_HSem_heap[of _ "(x, z) # \<Delta>" x, OF fempty_is_HSem_cond, simplified (no_asm)])
    apply simp_all
    done
  also have "... =  \<lbrakk>z\<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<^esub>"
    apply (rule ESem_add_fresh[OF fempty_is_HSem_cond fempty_is_HSem_cond])
    using fresh by (simp add: fresh_Pair)
  finally show "\<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<^esub> = \<lbrakk> z \<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<^esub>".
qed
end


theory week03B_demo_HOL imports Pure begin

text \<open>Defining HOL\<close>

text \<open>Technical Setup, introducing a new logic\<close>

class type
default_sort type

typedecl bool
typedecl ind

axiomatization where bool_arity: "OFCLASS(bool, type_class)"
instance "bool" :: type by (rule bool_arity)

axiomatization where ind_arity: "OFCLASS(ind, type_class)"
instance "ind" :: type by (rule ind_arity)

axiomatization where fun_arity: "OFCLASS('a \<Rightarrow> 'b, type_class)"
instance "fun" :: (type, type) type by (rule fun_arity)

judgment
  Trueprop      :: "bool \<Rightarrow> prop"  ("(_)" 5)

\<comment> \<open>---------------------------------\<close>

axiomatization
  Eq            :: "'a \<Rightarrow> 'a \<Rightarrow> bool"      (infixl "=" 50) and
  Imp           :: "bool \<Rightarrow> bool \<Rightarrow> bool"  (infixr "\<longrightarrow>" 25) and
  Eps           :: "('a \<Rightarrow> bool) \<Rightarrow> 'a"    (binder "SOME" 10)

definition True :: bool
  where "True \<equiv> ((\<lambda>x::bool. x) = (\<lambda>x. x))"

definition All :: "('a \<Rightarrow> bool) \<Rightarrow> bool"  (binder "\<forall>" 10)
  where "All P \<equiv> (P = (\<lambda>x. True))"

definition Ex :: "('a \<Rightarrow> bool) \<Rightarrow> bool"  (binder "\<exists>" 10)
  where "Ex P \<equiv> \<forall>Q. (\<forall>x. P x \<longrightarrow> Q) \<longrightarrow> Q"

definition False :: bool
  where "False \<equiv> (\<forall>P. P)"

definition Not :: "bool \<Rightarrow> bool"  ("\<not> _" [40] 40)
  where "\<not> P \<equiv> P \<longrightarrow> False"

definition And :: "[bool, bool] \<Rightarrow> bool"  (infixr "\<and>" 35)
  where "P \<and> Q \<equiv> \<forall>R. (P \<longrightarrow> Q \<longrightarrow> R) \<longrightarrow> R"

definition Or :: "[bool, bool] \<Rightarrow> bool"  (infixr "\<or>" 30)
  where "P \<or> Q \<equiv> \<forall>R. (P \<longrightarrow> R) \<longrightarrow> (Q \<longrightarrow> R) \<longrightarrow> R"

definition If:: "bool \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("(if (_)/ then (_)/ else (_))" 10)
  where "If P x y \<equiv> SOME z. (P=True \<longrightarrow> z=x) \<and> (P=False \<longrightarrow> z=y)"

definition inj:: "('a \<Rightarrow> 'b) \<Rightarrow> bool"
  where "inj f  \<equiv> \<forall>x y. f x = f y \<longrightarrow> x = y"

definition  surj:: "('a \<Rightarrow> 'b) \<Rightarrow> bool"
  where "surj f \<equiv> \<forall>y. \<exists>x. y = f x"

text \<open>Additional concrete syntax\<close>

syntax
  "_not_equal"  :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<noteq>" 50)
translations
  "x \<noteq> y"  == "\<not>(x = y)"

text \<open>Axioms and basic definitions\<close>

axiomatization where
  refl:  "t = t"  and
  subst: "\<lbrakk> s = t; P s \<rbrakk> \<Longrightarrow> P t" and
  ext:   "(\<And>x. f x = g x) \<Longrightarrow> (\<lambda>x. f x) = (\<lambda>x. g x)"

axiomatization where
  impI:  "(P \<Longrightarrow> Q) \<Longrightarrow> P \<longrightarrow> Q" and
  mp:    "\<lbrakk> P\<longrightarrow>Q;  (P::bool) \<rbrakk> \<Longrightarrow> Q" and
  iff:   "(P\<longrightarrow>Q) \<longrightarrow> (Q\<longrightarrow>P) \<longrightarrow> (P=Q)" and
  True_or_False: "(P=True) \<or> (P=False)" and
  infinity: "\<exists>f :: ind \<Rightarrow> ind. inj f \<and> \<not>surj f"

axiomatization where
  someI: "P x \<Longrightarrow> P (SOME x. P x)"

text \<open>Deriving the standard proof rules in HOL\<close>

text \<open>Implication\<close>

thm mp

\<comment> \<open>we want to show @{text "\<lbrakk> P \<longrightarrow> Q; P; Q \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"}\<close>
lemma impE:
  assumes PQ: "P \<longrightarrow> Q"
  assumes P: "P"
  assumes QR: "Q \<Longrightarrow> R"
  shows "R"
  apply (rule QR)
  apply (insert PQ) thm mp
  apply (drule mp)
   apply (rule P)
  apply assumption
  done

\<comment> \<open>-------------------------------\<close>

text \<open>True\<close>

lemma TrueI: "True"
  apply (unfold True_def)
  apply (rule refl)
  done

text \<open>side track: Equality\<close>

lemma sym: "s = t \<Longrightarrow> t = s" thm subst
  apply (erule subst)
  apply (rule refl)
  done

lemma fun_cong: "f = g \<Longrightarrow> f x = g x" thm subst
  apply (erule subst)
  apply (rule refl)
  done

thm mp
thm iff
lemma iffI:
  assumes PQ: "P \<Longrightarrow> Q"
  assumes QP: "Q \<Longrightarrow> P"
  shows "P = Q"
  apply (rule mp)
   apply (rule mp)
    apply (insert iff [where P=P and Q=Q])
    apply assumption
   apply (rule impI)
   apply (rule PQ)
   apply assumption
  apply (rule impI)
  apply (rule QP)
  apply assumption
  done

lemma iffD1: "Q = P \<Longrightarrow> Q \<Longrightarrow> P"
  apply (rule subst)
   apply assumption
  apply assumption
  done

lemma iffD2: "P = Q \<Longrightarrow> Q \<Longrightarrow> P" thm sym
  apply (drule sym)
  apply (erule iffD1)
   apply assumption
  done

text \<open>back to True\<close>

lemma eqTrueI: "P \<Longrightarrow> P = True"
  apply (rule iffI)
   apply (rule TrueI)
  apply assumption
  done

lemma eqTrueE: "P = True \<Longrightarrow> P" thm iffD2
  apply (drule iffD2)
   apply (rule TrueI)
  apply assumption
  done

\<comment> \<open>-------------------------------\<close>

text \<open>Universal Quantifier\<close>

lemma allI:
  assumes P: "\<And>x. P x"
  shows "\<forall>x. P x"
  apply (unfold All_def)
  apply (rule ext) thm eqTrueI
  apply (rule eqTrueI)
  apply (rule P)
  done

lemma spec: "\<forall>x. P x \<Longrightarrow> P x"
  apply (unfold All_def) thm eqTrueE
  apply (rule eqTrueE) thm fun_cong
  apply (drule fun_cong)
  apply assumption
  done

lemma allE:
  assumes all: "\<forall>x. P x"
  assumes R: "P x \<Longrightarrow> R"
  shows "R"
  apply (rule R)
  apply (insert all)
  apply (erule spec)
  done

\<comment> \<open>-------------------------------\<close>

text \<open>False\<close>

lemma FalseE:
  "False \<Longrightarrow> P"
  apply (unfold False_def)
  apply (erule_tac x=P in allE)
  apply assumption
  done

lemma False_neq_True:
  "False = True \<Longrightarrow> P"  thm eqTrueE
  apply (drule eqTrueE)
  apply (erule FalseE)
  done

\<comment> \<open>-------------------------------\<close>

text \<open>Negation\<close>

lemma notI:
  assumes P: "P \<Longrightarrow> False"
  shows "\<not>P"
  apply (unfold Not_def)
  apply (rule impI)
  apply (rule P)
  apply assumption
  done

lemma notE: "\<lbrakk> \<not>P; P \<rbrakk> \<Longrightarrow> R"
  apply (unfold Not_def)
  apply (erule impE)
   apply assumption
  apply (erule FalseE)
  done

lemma False_not_True: "False \<noteq> True"
  apply (rule notI) thm False_neq_True
  apply (erule False_neq_True)
  done

\<comment> \<open>-------------------------------\<close>

text \<open>Existential Quantifier\<close>

lemma exI:
  "P x \<Longrightarrow> \<exists>x. P x"
  apply (unfold Ex_def)
  apply (rule allI)
  apply (rule impI)
  apply (erule_tac x=x in allE)
  apply (erule impE)
   apply assumption
  apply assumption
  done

lemma exE:
  assumes ex: "\<exists>x. P x"
  assumes R: "\<And>x. P x \<Longrightarrow> R"
  shows "R"
  apply (insert ex)
  apply (unfold Ex_def) thm spec
  apply (drule spec) thm mp
  apply (drule mp)
   apply (rule allI)
   apply (rule impI)
   apply (rule R)
   apply assumption
  apply assumption
  done

\<comment> \<open>-------------------------------\<close>

text \<open>Conjunction\<close>

lemma conjI: "\<lbrakk> P; Q \<rbrakk> \<Longrightarrow> P \<and> Q"
  apply (unfold And_def)
  apply (rule allI)
  apply (rule impI)
  apply (erule impE)
   apply assumption
  apply (erule impE)
   apply assumption
  apply assumption
  done

lemma conjE:
  assumes PQ: "P \<and> Q"
  assumes R: "\<lbrakk> P; Q \<rbrakk> \<Longrightarrow> R"
  shows R
  apply (insert PQ)
  apply (unfold And_def)
  apply (erule allE)
  apply (erule impE)
   apply (rule impI)
   apply (rule impI)
   apply (rule R)
    apply assumption
   apply assumption
  apply assumption
  done

\<comment> \<open>-------------------------------\<close>

text \<open>Disjunction\<close>

lemma disjI1:
  "P \<Longrightarrow> P \<or> Q"
  apply (unfold Or_def)
  apply (rule allI)
  apply (rule impI)
  apply (rule impI)
  apply (erule impE)
   apply assumption
  apply assumption
  done

lemma disjI2:
  "Q \<Longrightarrow> P \<or> Q"
  apply (unfold Or_def)
  apply (rule allI)
  apply (rule impI)
  apply (rule impI)
  apply (erule impE, assumption, assumption)
  done

lemma disjE:
  assumes PQ: "P \<or> Q"
  assumes P: "P \<Longrightarrow> R"
  assumes Q: "Q \<Longrightarrow> R"
  shows "R"
  apply (insert PQ)
  apply (unfold Or_def)
  apply (erule allE)
  apply (erule impE)
   apply (rule impI)
   apply (rule P)
   apply assumption
  apply (erule impE)
   apply (rule impI)
   apply (rule Q)
   apply assumption
  apply assumption
  done

\<comment> \<open>-------------------------------\<close>

text \<open>Classical Logic\<close>

lemma classical:
  assumes P: "\<not>P \<Longrightarrow> P"
  shows P
  apply (insert True_or_False [where P=P])
  apply (erule disjE)
   apply (erule eqTrueE)
  apply (rule P)
  apply (rule notI)
  apply (rule subst)
   apply assumption
  apply assumption
  done

lemma notnotD:
  "\<not>\<not>P \<Longrightarrow> P"
  apply (rule classical)
  apply (erule notE)
  apply assumption
  done

lemma disjCI:
  assumes P: "\<not>Q \<Longrightarrow> P"
  shows "P \<or> Q"
  apply (rule classical)
  apply (rule disjI1)
  apply (rule P)
  apply (rule notI)
  apply (erule notE)
  apply (rule disjI2)
  apply assumption
  done

lemma tertium_non_datur:
  "P \<or> \<not>P"
  apply (rule disjCI)
  apply (drule notnotD)
  apply assumption
  done

\<comment> \<open>-------------------------------\<close>

text \<open>Choice\<close>

lemma someI_ex: "\<exists>x. P x \<Longrightarrow> P (SOME x. P x)"
  apply (erule exE)
  apply (erule someI)
  done

lemma someI2:
  assumes a: "P a"
  assumes PQ: "\<And>x. P x \<Longrightarrow> Q x"
  shows "Q (SOME x. P x)"
  apply (insert a)
  apply (drule someI, drule PQ)
  apply assumption
  done

lemma some_equality:
  assumes a: "P a"
  assumes P: "\<And>x. P x \<Longrightarrow> x=a"
  shows "(SOME x. P x) = a"
  apply (rule someI2)
   apply (rule a)
  apply (rule P)
  apply assumption
  done

lemma some_eq_ex:
  "P (SOME x. P x) = (\<exists>x. P x)"
  apply (rule iffI)
   apply (rule exI)
   apply assumption
  apply (erule someI_ex)
  done

\<comment> \<open>-------------------------------\<close>

text \<open>if-then-else\<close>
thm some_equality

lemma if_True:
  "(if True then s else t) = s"
  apply (unfold If_def)
  apply (rule some_equality)
   apply (rule conjI)
    apply (rule impI)
    apply (rule refl)
   apply (rule impI)
   apply (drule sym)
   apply (erule False_neq_True)
  apply (erule conjE)
  apply (erule impE)
   apply (rule refl)
  apply assumption
  done

lemma if_False:
  "(if False then s else t) = t"
  apply (unfold If_def) thm some_equality
  apply (rule some_equality)
   apply (rule conjI)
    apply (rule impI)
    apply (erule False_neq_True)
   apply (rule impI)
   apply (rule refl)
  apply (erule conjE)
  apply (erule impE, rule refl)
  apply assumption
  done

end


theory Proof_1_6
  imports HandDryer VCTheoryLemmas Extra
begin

theorem proof_1_6:
"VC6 inv1 s0 hands_value"
  apply(simp only: VC6_def inv1_def R1_def dryer_def)
  apply(rule impI; rule conjI)
proof -
  print_state
  assume VC: "((toEnvP s0 \<and>
      (\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          getVarBool s1 hands = OFF \<and>
          getVarBool s1 (Suc (Suc 0)) = OFF \<and>
          getVarBool s2 hands = ON \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> hands \<and>
                getVarBool s4 (Suc (Suc 0)) = ON \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 hands = ON)))) \<and>
     extraInv s0) \<and>
    env (setVarAny s0 hands_value) hands_value \<and>
    getPstate (setVarAny s0 hands_value) Ctrl =
    drying \<and>
    getVarBool (setVarAny s0 hands_value) hands \<noteq>
    ON \<and>
    10 \<le> ltimeEnv (setVarAny s0 hands_value)
           Ctrl"
  show " toEnvP
     (toEnv
       (setPstate (setVarAny s0 hands_value) Ctrl
         waiting)) \<and>
    (\<forall>s1 s2.
        substate s1 s2 \<and>
        substate s2
         (toEnv
           (setPstate (setVarAny s0 hands_value) Ctrl
             waiting)) \<and>
        toEnvP s1 \<and>
        toEnvP s2 \<and>
        toEnvNum s1 s2 = hands \<and>
        getVarBool s1 hands = OFF \<and>
        getVarBool s1 (Suc (Suc 0)) = OFF \<and>
        getVarBool s2 hands = ON \<longrightarrow>
        (\<exists>s4. toEnvP s4 \<and>
              substate s2 s4 \<and>
              substate s4
               (toEnv
                 (setPstate
                   (setVarAny s0 hands_value) Ctrl
                   waiting)) \<and>
              toEnvNum s2 s4 \<le> hands \<and>
              getVarBool s4 (Suc (Suc 0)) = ON \<and>
              (\<forall>s3. toEnvP s3 \<and>
                    substate s2 s3 \<and>
                    substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                    getVarBool s3 hands = ON)))"
    apply(rule conjI)
     apply(simp)
  proof(rule allI; rule allI; rule impI)
    fix s1 s2
    assume req_prems: " substate s1 s2 \<and>
       substate s2
        (toEnv
                 (setPstate
                   (setVarAny s0 hands_value) Ctrl
                   waiting)) \<and>
       toEnvP s1 \<and>
       toEnvP s2 \<and>
       toEnvNum s1 s2 = hands \<and>
       getVarBool s1 hands = OFF \<and>
       getVarBool s1 (Suc (Suc 0)) = OFF \<and>
       getVarBool s2 hands = ON "
    show " \<exists>s4. toEnvP s4 \<and>
            substate s2 s4 \<and>
            substate s4
            (toEnv
                 (setPstate
                   (setVarAny s0 hands_value) Ctrl
                   waiting)) \<and>
            toEnvNum s2 s4 \<le> hands \<and>
            getVarBool s4 (Suc (Suc 0)) = ON \<and>
            (\<forall>s3. toEnvP s3 \<and>
                  substate s2 s3 \<and>
                  substate s3 s4 \<and>
                  s3 \<noteq> s4 \<longrightarrow>
                  getVarBool s3 hands = ON)"
    proof cases
      assume 1: "s2 =  (toEnv
                 (setPstate
                   (setVarAny s0 hands_value) Ctrl
                   waiting))"
      have " (toEnvP s2 \<and>
         substate s2 s2 \<and>
         substate s2
         (toEnv
                 (setPstate
                   (setVarAny s0 hands_value) Ctrl
                   waiting)) \<and>
         toEnvNum s2 s2 \<le> hands \<and>
         getVarBool s2 (Suc (Suc 0)) = ON) \<and>
         (\<forall>s3. toEnvP s3 \<and>
               substate s2 s3 \<and>
               substate s3 s2 \<and>
               s3 \<noteq> s2 \<longrightarrow>
               getVarBool s3 hands = ON)"
      proof
        from 1  VC req_prems show "toEnvP s2 \<and>
    substate s2 s2 \<and>
    substate s2
    (toEnv
                 (setPstate
                   (setVarAny s0 hands_value) Ctrl
                   waiting)) \<and>
    toEnvNum s2 s2 \<le> hands \<and>
    getVarBool s2 (Suc (Suc 0)) = ON" by auto
      next
        from substate_asym show " \<forall>s3. toEnvP s3 \<and>
         substate s2 s3 \<and>
         substate s3 s2 \<and> s3 \<noteq> s2 \<longrightarrow>
         getVarBool s3 hands = ON"
          by auto
      qed
      thus ?thesis by blast
    next
       assume 1: "s2 \<noteq>  (toEnv
                 (setPstate
                   (setVarAny s0 hands_value) Ctrl
                   waiting))"
       with req_prems have 2: "substate s2 s0"
         by (simp split: if_splits)
       from VC req_prems 2 obtain "\<exists>s4. toEnvP s4 \<and>
           substate s2 s4 \<and>
           substate s4 s0 \<and>
           toEnvNum s2 s4 \<le> hands \<and>
           getVarBool s4 (Suc (Suc 0)) = ON \<and>
           (\<forall>s3. toEnvP s3 \<and>
                 substate s2 s3 \<and>
                 substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                 getVarBool s3 hands = ON)"by auto
       then obtain s4 where 3: "toEnvP s4 \<and>
           substate s2 s4 \<and>
           substate s4 s0 \<and>
           toEnvNum s2 s4 \<le> hands \<and>
           getVarBool s4 (Suc (Suc 0)) = ON \<and>
           (\<forall>s3. toEnvP s3 \<and>
                 substate s2 s3 \<and>
                 substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                 getVarBool s3 hands = ON)" ..
       have "toEnvP s4 \<and>
      substate s2 s4 \<and>
      substate s4
       (toEnv
                 (setPstate
                   (setVarAny s0 hands_value) Ctrl
                   waiting)) \<and>
      toEnvNum s2 s4 \<le> hands \<and>
      getVarBool s4 (Suc (Suc 0)) = ON \<and>
      (\<forall>s3. toEnvP s3 \<and>
            substate s2 s3 \<and>
            substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
            getVarBool s3 hands = ON)"
         using 3 by auto
       thus ?thesis ..
     qed
   qed
 next
   assume VC: "((toEnvP s0 \<and>
      (\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          getVarBool s1 hands = OFF \<and>
          getVarBool s1 (Suc (Suc 0)) = OFF \<and>
          getVarBool s2 hands = ON \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> hands \<and>
                getVarBool s4 (Suc (Suc 0)) = ON \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 hands = ON)))) \<and>
     extraInv s0) \<and>
    env (setVarAny s0 hands_value) hands_value \<and>
    getPstate (setVarAny s0 hands_value) Ctrl =
    drying \<and>
    getVarBool (setVarAny s0 hands_value) hands \<noteq>
    ON \<and>
    10 \<le> ltimeEnv (setVarAny s0 hands_value)
           Ctrl"
   print_state
   with extra6 show "extraInv
     (toEnv
       (setPstate (setVarAny s0 hands_value) Ctrl
         waiting))"
     by (auto simp add: VC6_def)
 qed

end


section \<open>Examples using ML-level VCG for Total Correctness\<close>

theory examples_vcg_total
  imports "../../../hoare/HoareLogic/TotalCorrectness/Abrupt/VCG/VCG_total_ML"
begin

subsection Increment

lemma increment_manual:
  assumes "vwb_lens x" and "x \<bowtie> y"
  shows
  "\<lbrace>&y =\<^sub>u \<guillemotleft>5::int\<guillemotright>\<rbrace>
  x \<Midarrow> 0;;
  (&x =\<^sub>u 0 \<and> &y =\<^sub>u 5)\<^sup>\<top>\<^sup>C;;
  while &x <\<^sub>u &y
  invr &x \<le>\<^sub>u &y \<and> &y =\<^sub>u 5
  do x \<Midarrow> &x + 1 od
  \<lbrace>&x =\<^sub>u 5\<rbrace>\<^sub>A\<^sub>B\<^sub>R"
  apply (insert assms)
  apply (rule seq_hoare_r_t)
   apply (rule seq_hoare_r_t[of _ _ true])
    apply rel_auto (* seq rule gives us a value of true in postcondition, which is trivial *)
   apply (rule assume_hoare_r_t)
    apply (rule skip_abr_hoare_r_t)
   apply rel_auto
  apply (rule while_invr_hoare_r_t)
    apply (rule assigns_abr_hoare_r_t)
    unfolding lens_indep_def
    apply pred_auto
   apply pred_auto
  apply pred_auto
  done

lemma increment_tactic1:
  assumes "vwb_lens x" and "x \<bowtie> y"
  shows
  "\<lbrace>&y =\<^sub>u \<guillemotleft>5::int\<guillemotright>\<rbrace>
  x \<Midarrow> 0;;
  x \<Midarrow> 0;;
  (&x =\<^sub>u 0 \<and> &y =\<^sub>u 5)\<^sup>\<top>\<^sup>C;;
  while &x <\<^sub>u &y
  invr &x \<le>\<^sub>u &y \<and> &y =\<^sub>u 5
  do x \<Midarrow> &x + 1 od
  \<lbrace>&x =\<^sub>u 5\<rbrace>\<^sub>A\<^sub>B\<^sub>R"
  apply (tactic \<open>vcg_seq_split @{context} 1\<close>)+
  apply (tactic \<open>vcg_rule_tac @{context} 1\<close>)+
  defer
  apply (tactic \<open>vcg_rule_tac @{context} 1\<close>)+
  apply rel_auto
  defer
  apply rel_auto
  apply (tactic \<open>vcg_rule_tac @{context} 1\<close>)+
  apply (tactic \<open>vcg_insert_assms_tac @{context}\<close>)
  apply (tactic \<open>vcg_unfold_tac @{context}\<close>)
  apply pred_auto+
  done

lemma increment_tactic2:
  assumes "vwb_lens x" and "x \<bowtie> y"
  shows
  "\<lbrace>&y =\<^sub>u \<guillemotleft>5::int\<guillemotright>\<rbrace>
  x \<Midarrow> 0;;
  x \<Midarrow> 0;;
  (&x =\<^sub>u 0 \<and> &y =\<^sub>u 5)\<^sup>\<top>\<^sup>C;;
  while &x <\<^sub>u &y
  invr &x \<le>\<^sub>u &y \<and> &y =\<^sub>u 5
  do x \<Midarrow> &x + 1 od
  \<lbrace>&x =\<^sub>u 5\<rbrace>\<^sub>A\<^sub>B\<^sub>R"
  apply (tactic \<open>vcg_rules_all_tac @{context}\<close>)
  apply (tactic \<open>vcg_pre_tac @{context}\<close>)
  apply vcg_autos+
  done

subsection \<open>Even count\<close>

lemma even_count_tactic1:
  assumes "vwb_lens i" and "weak_lens start" and "vwb_lens j" and "weak_lens endd"
  and "i \<bowtie> start" and "i \<bowtie> j" and "i \<bowtie> endd" and "start \<bowtie> j" and "start \<bowtie> endd" and "j \<bowtie> endd"
  shows
  "\<lbrace>&start =\<^sub>u \<guillemotleft>0::int\<guillemotright> \<and> &endd =\<^sub>u 1\<rbrace>
    i \<Midarrow> &start;;
    j \<Midarrow> 0;;
    (&start =\<^sub>u 0 \<and> &endd =\<^sub>u 1 \<and> &j =\<^sub>u 0 \<and> &i =\<^sub>u &start)\<^sup>\<top>\<^sup>C;;
    while &i <\<^sub>u &endd
    invr &start =\<^sub>u 0 \<and> &endd =\<^sub>u 1 \<and> &j =\<^sub>u (((&i + 1) - &start) div 2) \<and> &i \<le>\<^sub>u &endd \<and> &i \<ge>\<^sub>u &start
    do
      bif &i mod 2 =\<^sub>u 0 then
        j \<Midarrow> &j + 1
      else
        SKIP\<^sub>A\<^sub>B\<^sub>R
      eif;;
      i \<Midarrow> &i + 1
    od
  \<lbrace>&j =\<^sub>u 1\<rbrace>\<^sub>A\<^sub>B\<^sub>R"
  apply (tactic \<open>vcg_rules_all_tac @{context}\<close>)
  apply vcg_autos
  apply (tactic \<open>vcg_rules_all_tac' @{context}\<close>)
  apply (tactic \<open>vcg_rules_all_tac' @{context}\<close>)
  apply (tactic \<open>vcg_pre_tac @{context}\<close>)
  apply vcg_autos+
  done

lemma even_count_tactic2:
  assumes "vwb_lens i" and "weak_lens start" and "vwb_lens j" and "weak_lens endd"
  and "i \<bowtie> start" and "i \<bowtie> j" and "i \<bowtie> endd" and "start \<bowtie> j" and "start \<bowtie> endd" and "j \<bowtie> endd"
  shows
  "\<lbrace>&start =\<^sub>u \<guillemotleft>0::int\<guillemotright> \<and> &endd =\<^sub>u 1\<rbrace>
    i \<Midarrow> &start;;
    j \<Midarrow> 0;;
    (&start =\<^sub>u 0 \<and> &endd =\<^sub>u 1 \<and> &j =\<^sub>u 0 \<and> &i =\<^sub>u &start)\<^sup>\<top>\<^sup>C;;
    while &i <\<^sub>u &endd
    invr &start =\<^sub>u 0 \<and> &endd =\<^sub>u 1 \<and> &j =\<^sub>u (((&i + 1) - &start) div 2) \<and> &i \<le>\<^sub>u &endd \<and> &i \<ge>\<^sub>u &start
    do
      bif &i mod 2 =\<^sub>u 0 then
        j \<Midarrow> &j + 1
      else
        SKIP\<^sub>A\<^sub>B\<^sub>R
      eif;;
      i \<Midarrow> &i + 1
    od
  \<lbrace>&j =\<^sub>u 1\<rbrace>\<^sub>A\<^sub>B\<^sub>R"
  apply (tactic \<open>vcg_rules_tac' @{context}\<close>)
  defer
  apply (tactic \<open>vcg_rules_tac' @{context}\<close>)
  apply vcg_autos
  apply (tactic \<open>vcg_rules_tac' @{context}\<close>)
  defer
  apply (tactic \<open>vcg_rules_tac' @{context}\<close>)
  apply (tactic \<open>vcg_pre_tac @{context}\<close>)
  apply vcg_autos
  done

end