section \<open> Dwarf Signal \<close>

theory DwarfSignal_Fixed
  imports "Z_Machines.Z_Machine"
begin

subsection \<open> State Space \<close>

enumtype LampId = L1 | L2 | L3

type_synonym Signal = "LampId set"

enumtype ProperState = dark | stop | warning | drive

definition "ProperState = {dark, stop, warning, drive}"

fun signalLamps :: "ProperState \<Rightarrow> LampId set" where
"signalLamps dark = {}" |
"signalLamps stop = {L1, L2}" |
"signalLamps warning = {L1, L3}" |
"signalLamps drive = {L2, L3}"

lemma signalLamps: "signalLamps x \<in> {{}, {L1, L2}, {L1, L3}, {L2, L3}}"
  by (cases x; simp)

zstore Dwarf =
  last_proper_state :: "ProperState"
  turn_off :: "LampId set"
  turn_on  :: "LampId set"
  last_state :: "Signal"
  current_state :: "Signal"
  desired_proper_state :: "ProperState"
  where
    "signalLamps desired_proper_state = (current_state - turn_off) \<union> turn_on"
    "turn_on \<inter> turn_off = {}"

subsection \<open> Operations \<close>

zoperation SetNewProperState =
  over Dwarf
  params st\<in>"ProperState - {desired_proper_state}"
  pre "current_state = signalLamps desired_proper_state
       \<and> (desired_proper_state = stop \<longrightarrow> st \<noteq> drive)
       \<and> (desired_proper_state = dark \<longrightarrow> st = stop)
       \<and> (st = dark \<longrightarrow> desired_proper_state = stop)"
  update "[last_proper_state\<Zprime> = desired_proper_state
          ,turn_off\<Zprime> = current_state - signalLamps st
          ,turn_on\<Zprime> = signalLamps st - current_state
          ,last_state\<Zprime> = current_state
          ,desired_proper_state\<Zprime> = st]"

zoperation TurnOff =
  over Dwarf
  params l\<in>turn_off
  update "[turn_off\<Zprime> = turn_off - {l}
          ,turn_on\<Zprime> = turn_on - {l}
          ,last_state\<Zprime> = current_state
          ,current_state\<Zprime> = current_state - {l}]"

zoperation TurnOn =
  over Dwarf
  params l\<in>turn_on
  pre "turn_off = {}"
  update "[turn_off\<Zprime> = turn_off - {l}
          ,turn_on\<Zprime> = turn_on - {l}
          ,last_state\<Zprime> = current_state
          ,current_state\<Zprime> = current_state \<union> {l}]"

zoperation Shine =
  over Dwarf
  params l\<in>"{current_state}"

definition Init :: "Dwarf subst" where
  [z_defs]:
  "Init =
  [ last_proper_state \<leadsto> stop
  , turn_off \<leadsto> {}
  , turn_on \<leadsto> {}
  , last_state \<leadsto> signalLamps stop
  , current_state \<leadsto> signalLamps stop
  , desired_proper_state \<leadsto> stop ]"

zmachine DwarfSignal =
  init Init
  operations SetNewProperState TurnOn TurnOff Shine

animate DwarfSignal

subsection \<open> Structural Invariants \<close>

lemma "Init establishes Dwarf_inv"
  by zpog_full

lemma "(SetNewProperState p) preserves Dwarf_inv"
  by (zpog_full, auto)

lemma TurnOn_correct: "(TurnOn l) preserves Dwarf_inv"
  by (zpog_full, auto)

lemma TurnOff_correct: "(TurnOff l) preserves Dwarf_inv"
  by (zpog_full, auto)

lemma Shine_correct: "(Shine l) preserves Dwarf_inv"
  by (zpog_full)

subsection \<open> Requirements \<close>

subsubsection \<open> NeverShowAll \<close>

zexpr NeverShowAll
  is "current_state \<noteq> {L1, L2, L3}"

lemma SetNewProperState_NeverShowAll: "(SetNewProperState p) preserves NeverShowAll"
  by zpog_full

lemma TurnOn_NeverShowAll: "TurnOn l preserves NeverShowAll under Dwarf_inv"
proof (zpog_full)
  fix turn_on :: "\<bbbP> LampId" and current_state :: "\<bbbP> LampId" and desired_proper_state :: ProperState
  assume
    1: "signalLamps desired_proper_state = current_state \<union> turn_on" and
    2: "current_state \<noteq> {L1, L2, L3}" and
    3: "l \<in> turn_on"
  have "current_state \<union> turn_on \<in> {{}, {L1, L2}, {L1, L3}, {L2, L3}}"
    by (metis "1" signalLamps)

  with 2 3 show "insert l current_state \<noteq> {L1, L2, L3}"
    by (smt (verit, best) LampId.distinct(2) LampId.distinct(4) LampId.distinct(6) UnI2 Un_insert_left insertE insert_absorb insert_absorb2 insert_commute insert_ident singleton_insert_inj_eq)
qed

lemma TurnOff_NeverShowAll: "TurnOff l preserves NeverShowAll"
  by zpog_full
     (metis (full_types) Diff_empty Diff_insert0 LampId.exhaust insertCI insert_Diff insert_absorb)

subsubsection \<open> MaxOneLampChange \<close>

zexpr MaxOneLampChange
  is "\<exists> l. current_state - last_state = {l} \<or> last_state - current_state = {l} \<or> last_state = current_state"

lemma SetNewProperState_MaxOneLampChange: "(SetNewProperState p) preserves MaxOneLampChange"
  by zpog

lemma TurnOn_MaxOneLampChange: "(TurnOn l) preserves MaxOneLampChange"
  by (zpog_full; auto)

lemma TurnOff_MaxOneLampChange: "(TurnOff l) preserves MaxOneLampChange"
  by (zpog_full; auto)

subsubsection \<open> ForbidStopToDrive \<close>

zexpr ForbidStopToDrive
  is "last_proper_state = stop \<longrightarrow> desired_proper_state \<noteq> drive"

lemma SetNewProperState_ForbidStopToDrive: "(SetNewProperState p) preserves ForbidStopToDrive"
  by zpog

lemma "(TurnOn l) preserves ForbidStopToDrive"
  by zpog

lemma "(TurnOff l) preserves ForbidStopToDrive"
  by zpog

subsubsection \<open> DarkOnlyToStop \<close>

zexpr DarkOnlyToStop
  is "last_proper_state = dark \<longrightarrow> desired_proper_state = stop"

lemma SetNewProperState_DarkOnlyToStop: "(SetNewProperState p) preserves DarkOnlyToStop"
  by zpog

subsubsection \<open> DarkOnlyFromStop \<close>

zexpr DarkOnlyFromStop
  is "desired_proper_state = dark \<longrightarrow> last_proper_state = stop"

lemma SetNewProperState_DarkOnlyFromStop: "(SetNewProperState p) preserves DarkOnlyFromStop"
  by zpog

subsection \<open> All Requirements \<close>

zexpr DwarfReq
  is "NeverShowAll \<and> MaxOneLampChange \<and> ForbidStopToDrive \<and> DarkOnlyToStop \<and> DarkOnlyFromStop"

lemma SetNewProperState_DwarfReq: "(SetNewProperState p) preserves DwarfReq"
  by (auto intro!: hl_conj simp add: DwarfReq_def SetNewProperState_NeverShowAll
      SetNewProperState_MaxOneLampChange SetNewProperState_ForbidStopToDrive
      SetNewProperState_DarkOnlyToStop SetNewProperState_DarkOnlyFromStop)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_weird_nat_add3_spec
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3 :: "Nat => Nat => Nat => Nat" where
"add3 (Z) (Z) z = z"
| "add3 (Z) (S x3) z = plus (S Z) (add3 Z x3 z)"
| "add3 (S x2) y z = plus (S Z) (add3 x2 y z)"

theorem property0 :
  "((add3 x y z) = (plus x (plus y z)))"
  oops

end


           (*-------------------------------------------*
            |  The Dining Mathematicians in CSP-Prover  |
            |               August 2004                 |
            |             December 2004 (modified)      |
            |             November 2005 (modified)      |
            |                April 2006 (modified)      |
            |                  May 2016  (modified)     |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory DM1_Imp_def
imports CSP_F
begin

(*****************************************************************

         1. defines Imp
         2.
         3.
         4.

 *****************************************************************)

(*********************************************************
                    ODD and EVEN
 *********************************************************)

definition
  EVEN :: "int => bool"
  where
  EVEN_def : "EVEN n == (n mod 2 = 0)"

definition
  ODD  :: "int => bool"
  where
  ODD_def  : "ODD n  == (n mod 2 = 1)"

abbreviation
  EVENs :: "int set" ("EVENs")
where
  "EVENs == Collect EVEN"

abbreviation
  ODDs  :: "int set" ("ODDs")
where
  "ODDs == Collect ODD"

(*********************************************************
                         event
 *********************************************************)

datatype Event = Eat0 | Back0 | End0 | RD0 int | WR0 int
               | Eat1 | Back1 | End1 | RD1 int | WR1 int
               | NUM int

lemma expand_Event_fun[simp]:
  "ALL Ef Eg. ((Ef::int => Event) = Eg) = (ALL n. Ef n = Eg n)"
apply (simp add: fun_eq_iff)
done

abbreviation CH0 :: "Event set"
where "CH0 == (range RD0) Un (range WR0)"

abbreviation CH1 :: "Event set"
where "CH1 == (range RD1) Un (range WR1)"

abbreviation OBS :: "Event set"
where "OBS == {Eat0, Back0, End0, Eat1, Back1, End1}"

(*********************************************************
                     function
 *********************************************************)

primrec
  getInt :: "Event => int"
where
  "getInt (Eat0)   = 0"
 |"getInt (Eat1)   = 0"
 |"getInt (Back0)  = 0"
 |"getInt (Back1)  = 0"
 |"getInt (End0)   = 0"
 |"getInt (End1)   = 0"
 |"getInt (RD0 n)  = n"
 |"getInt (RD1 n)  = n"
 |"getInt (WR0 n)  = n"
 |"getInt (WR1 n)  = n"
 |"getInt (NUM n)  = n"

(*********************************************************
                Parallel system definition
 *********************************************************)
(*
defs FPmode_def [simp]: "FPmode == CMSmode"
*)
overloading FPmode ==
  "FPmode :: fpmode"
begin
  definition "FPmode == CMSmode"
end

declare FPmode_def [simp]

datatype ImpName = VAR int | TH0 | EAT0 int | TH1 | EAT1 int

primrec
  Impfun :: "ImpName => (ImpName, Event) proc"
where
  "Impfun   (TH0) = RD0 ? n -> IF (EVEN n)
                                  THEN (Eat0  -> $(EAT0 n))
                                  ELSE (Back0 -> $(TH0))"

 |"Impfun   (TH1) = RD1 ? n -> IF (ODD n)
                                  THEN (Eat1  -> $(EAT1 n))
                                  ELSE (Back1 -> $(TH1))"

 |"Impfun (EAT0 n) = End0 -> WR0 ! (n div 2) -> $(TH0)"

 |"Impfun (EAT1 n) = End1 -> WR1 ! (3 * n + 1) -> $(TH1)"

 |"Impfun (VAR n) = WR0 ? n -> $(VAR n)
                   [+] WR1 ? n -> $(VAR n)
                   [+] RD0 ! n -> $(VAR n)
                   [+] RD1 ! n -> $(VAR n)"
(*
defs (overloaded)
Set_Impfun_def [simp]: "PNfun == Impfun"
*)

overloading Set_Impfun ==
  "PNfun :: (ImpName, Event) pnfun"
begin
  definition "PNfun == Impfun"
end

declare Set_Impfun_def [simp]

definition
  Imp :: "int => (ImpName, Event) proc"
  where
  Imp_def: "Imp == (%n. ($TH0 |[CH0]| $(VAR n) |[CH1]| $TH1) -- (CH0 Un CH1))"

(*********************************************************
         To unfold "range" and "syntactic sugar", ...
 *********************************************************)

declare image_iff         [simp]
declare inj_on_def        [simp]
declare csp_prefix_ss_def [simp]

(*********************************************************
                gProc lemmas (routine work)
 *********************************************************)

lemma guarded_Imp[simp]:
      "guardedfun Impfun"
by (simp add: guardedfun_def, rule allI, induct_tac p, simp_all)+

(*********************************************************
                        Lemmas
 *********************************************************)

(*** int lemmas ***)

lemma int_le_inc: "ALL (n::int) m. n <= m --> n = m | n+1 <= m"
by (auto)

lemma mod_2_not_le: "ALL (n::int). ~(2 <= n mod 2)"
by (simp add: linorder_not_le)

lemma mod_2_or: "ALL (n::int). n mod 2 = 0 | n mod 2 =1"
apply (intro allI)
apply (insert int_le_inc)
apply (drule_tac x="0" in spec)
apply (drule_tac x="n mod 2" in spec)
apply (simp)
apply (erule disjE)
apply (simp)

apply (insert int_le_inc)
apply (drule_tac x="1" in spec)
apply (drule_tac x="n mod 2" in spec)
apply (simp)
done

(*** ODD and EVEN lemmas ***)

lemma EVEN_not_ODD[simp]: "ALL n. EVEN n = (~ ODD n)"
apply (auto simp add: EVEN_def ODD_def )
done

lemma ODD_add_1: "ALL n. (n mod 2 = 1) --> ((n + 1) mod 2 = (0::int))"
apply (simp add: mod_add_eq[THEN sym])
(*
apply (simp add: mod_add_eq)          (in Isabelle 2016)
*)
(*
apply (simp add: zmod_zadd_left_eq)   (in Isabelle 2008)
*)
done

lemma ODD_EX: "ALL m. ODD m --> (EX n. m = 2 * n + 1)"
apply (intro allI impI)
apply (simp add: ODD_def)
apply (insert ODD_add_1)
apply (drule_tac x="m" in spec)
apply (simp)
apply (simp add: zmod_eq_0_iff)
apply (erule exE)
apply (rule_tac x="q - 1" in exI)
apply (simp)
done

lemma ODD_to_EVEN[simp]: "ODD n ==> EVEN (3 * n + 1)"
apply (insert ODD_EX)
apply (drule_tac x="n" in spec)
apply (simp add: ODD_def EVEN_def)
apply (erule exE)
(*
apply (simp add: zmod_zadd_left_eq)
apply (simp add: zmod_zmult1_eq')
*)
apply (simp add: mod_add_eq)
(* apply (simp add: mod_mult_eq) *)
done

lemma ODD_to_notODD[simp]: "ODD n ==> ~ ODD (3 * n + 1)"
apply (insert ODD_to_EVEN[of n])
apply (simp)
done

(*** range ***)

lemma fold_range: "(EX a. x = f a) = (x : range f)"
apply (auto)
done

(*********************************************************
           unfolding & folding process names
 *********************************************************)

(*** unfold VAR ***)

lemma VAR:
     "$(VAR n)
    =F ? x:insert (RD1 n) (insert (RD0 n) ((range WR0) Un (range WR1)))
         -> IF (x : (range WR0) | x : (range WR1))
            THEN $(VAR (getInt x)) ELSE $(VAR n)"
apply (cspF_unwind_left)
apply (cspF_step_left)+
apply (auto)
apply (cspF_simp)+
done

lemmas VAR_simp = VAR[simplified]
(*
lemmas unfold_Imp_rules = VAR_simp
lemmas fold_Imp_rules = VAR_simp[THEN cspF_sym]
*)

(*** unfold TH0 ***)

lemma TH0:
     "($TH0)
   =F RD0 ? n -> IF (EVEN n) THEN (Eat0  -> ($(EAT0 n)))
                             ELSE (Back0 -> ($TH0))"
apply (cspF_unwind_left)
done

lemmas TH0_simp = TH0[simplified]
lemmas unfold_Imp_rules0 = VAR_simp TH0_simp
lemmas fold_Imp_rules0 = VAR_simp[THEN cspF_sym] TH0_simp[THEN cspF_sym]

(*** unfold TH1 ***)

lemma TH1:
     "($TH1)
   =F RD1 ? n -> IF (ODD n) THEN (Eat1  ->  ($(EAT1 n)))
                            ELSE (Back1 -> ($TH1))"
by (cspF_unwind_left)

lemmas TH1_simp = TH1[simplified]
lemmas unfold_Imp_rules1 = unfold_Imp_rules0 TH1_simp
lemmas fold_Imp_rules1 = fold_Imp_rules0 TH1_simp[THEN cspF_sym]

(*** unfold EAT0 ***)

lemma EAT0:
     "($(EAT0 n))
   =F ? x:{End0} -> WR0 (n div 2) -> ($TH0)"
by (cspF_unwind_left)

lemmas EAT0_simp = EAT0[simplified]
lemmas unfold_Imp_rules2 = unfold_Imp_rules1 EAT0_simp
lemmas fold_Imp_rules2 = fold_Imp_rules1 EAT0_simp[THEN cspF_sym]

(*** unfold EAT1 ***)

lemma EAT1:
     "($(EAT1 n))
   =F ? x:{End1} -> WR1 ! (3 * n + 1) -> ($TH1)"
by (cspF_unwind_left)

lemmas EAT1_simp = EAT1[simplified]
lemmas unfold_Imp_rules3 = unfold_Imp_rules2 EAT1_simp
lemmas fold_Imp_rules3 = fold_Imp_rules2 EAT1_simp[THEN cspF_sym]

end


(*  Title:      HOL/HOLCF/IMP/HoareEx.thy
    Author:     Tobias Nipkow, TUM
    Copyright   1997 TUM
*)

section "Correctness of Hoare by Fixpoint Reasoning"

theory HoareEx imports Denotational begin

text \<open>
  An example from the HOLCF paper by Müller, Nipkow, Oheimb, Slotosch
  \<^cite>\<open>MuellerNvOS99\<close>.  It demonstrates fixpoint reasoning by showing
  the correctness of the Hoare rule for while-loops.
\<close>

type_synonym assn = "state \<Rightarrow> bool"

definition
  hoare_valid :: "[assn, com, assn] \<Rightarrow> bool"  ("|= {(1_)}/ (_)/ {(1_)}" 50) where
  "|= {P} c {Q} = (\<forall>s t. P s \<and> D c\<cdot>(Discr s) = Def t \<longrightarrow> Q t)"

lemma WHILE_rule_sound:
    "|= {A} c {A} \<Longrightarrow> |= {A} WHILE b DO c {\<lambda>s. A s \<and> \<not> bval b s}"
  apply (unfold hoare_valid_def)
  apply (simp (no_asm))
  apply (rule fix_ind)
    apply (simp (no_asm)) \<comment> \<open>simplifier with enhanced \<open>adm\<close>-tactic\<close>
   apply (simp (no_asm))
  apply (simp (no_asm))
  apply blast
  done

end


theory Prelude_Bool
imports "$HETS_ISABELLE_LIB/MainHC"
uses "$HETS_ISABELLE_LIB/prelude"
begin

setup "Header.initialize
       [\"NotFalse\", \"NotTrue\", \"AndFalse\", \"AndTrue\", \"AndSym\",
        \"OrDef\", \"OtherwiseDef\", \"NotFalse1\", \"NotTrue1\",
        \"notNot1\", \"notNot2\"]"

datatype Bool = X_False ("False''") | X_True ("True''")

consts
X__XAmpXAmp__X :: "Bool => Bool => Bool" ("(_/ &&/ _)" [54,54] 52)
X__XVBarXVBar__X :: "Bool => Bool => Bool" ("(_/ ||/ _)" [54,54] 52)
notH__X :: "Bool => Bool" ("(notH/ _)" [56] 56)
otherwiseH :: "Bool"

axioms
NotFalse [rule_format] : "notH False' = True'"

NotTrue [rule_format] : "notH True' = False'"

AndFalse [rule_format] : "ALL (x :: Bool). False' && x = False'"

AndTrue [rule_format] : "ALL (x :: Bool). True' && x = x"

AndSym [rule_format] :
"ALL (x :: Bool). ALL (y :: Bool). x && y = y && x"

OrDef [rule_format] :
"ALL (x :: Bool).
 ALL (y :: Bool). x || y = notH (notH x && notH y)"

OtherwiseDef [rule_format] : "otherwiseH = True'"

declare NotFalse [simp]
declare NotTrue [simp]
declare AndFalse [simp]
declare AndTrue [simp]

theorem NotFalse1 :
"ALL (x :: Bool). notH x = True' = (x = False')"
apply auto
apply(case_tac x)
apply auto
done

setup "Header.record \"NotFalse1\""

theorem NotTrue1 : "ALL (x :: Bool). notH x = False' = (x = True')"
apply auto
apply(case_tac x)
apply auto
done

setup "Header.record \"NotTrue1\""

theorem notNot1 :
"ALL (x :: Bool). (~ x = True') = (notH x = True')"
apply auto
apply(case_tac x)
apply auto
done

setup "Header.record \"notNot1\""

theorem notNot2 :
"ALL (x :: Bool). (~ x = False') = (notH x = False')"
apply auto
apply(case_tac x)
apply auto
done

setup "Header.record \"notNot2\""

end