(* VDM to Isabelle Translation @2022-02-27T11:35:55.631536Z
   Copyright 2021, Leo Freitas, leo.freitas@newcastle.ac.uk

in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 14:7
files = [./src/test/resources/Examples/Traffic/traffic.vdmsl]
*)
theory traffic_PO
imports traffic
begin

\<comment>\<open>VDM source: Time = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 14:7\<close>
theorem Time_TOTAL_PO1:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (t :: VDMReal)  . ((((inv_VDMReal t))) \<longrightarrow> isTest ((inv_Time t)) (inv_bool))))"
	by simp

\<comment>\<open>VDM source: Time = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 13:3\<close>
theorem Time_INV_SATISFIABILITY_PO2:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<exists> (t :: VDMReal)  . ((((inv_VDMReal t))) \<longrightarrow> (t \<ge> (0::VDMNat)))))"
	by force

\<comment>\<open>VDM source: Conflict = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 20:7\<close>
theorem Conflict_TOTAL_PO3:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (dummy0 :: Conflict)  . (((inv_Conflict dummy0)) \<longrightarrow> (let path1 = (path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t dummy0); path2 = (path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t dummy0) in isTest ((inv_Conflict \<lparr>path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = path1, path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = path2\<rparr>)) (inv_bool)))))"

	by simp

\<comment>\<open>VDM source: Conflict = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 18:3\<close>
theorem Conflict_INV_SATISFIABILITY_PO4:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<exists> (dummy0 :: Conflict)  . (((inv_Conflict dummy0)) \<longrightarrow> (let path1 = (path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t dummy0); path2 = (path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t dummy0) in (path1 \<noteq> path2)))))"

	by (metis (full_types) Conflict.select_convs(1) Conflict.select_convs(2) VDMToken.simps(1) list.simps(3))

\<comment>\<open>VDM source: Kernel = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 29:7\<close>
theorem Kernel_TOTAL_PO5:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (dummy0 :: Kernel)  . (((inv_Kernel dummy0)) \<longrightarrow> (let ls = (lights\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0); cs = (conflicts\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0) in isTest ((inv_Kernel \<lparr>lights\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l = ls, conflicts\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l = cs\<rparr>)) (inv_bool)))))"

	by fastforce

\<comment>\<open>VDM source: Kernel = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 31:15\<close>
theorem Kernel_SUB_TYPE_PO6:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (dummy0 :: Kernel)  . (((inv_Kernel dummy0)) \<longrightarrow> (let ls = (lights\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0); cs = (conflicts\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0) in (\<forall> c \<in> cs  . (inv_Conflict \<lparr>path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = (path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c), path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = (path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c)\<rparr>))))))"

	by (meson inv_Kernel_def inv_SetElems_def inv_VDMSet'_def)

\<comment>\<open>VDM source: Kernel = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 34:16\<close>
theorem Kernel_MAP_APPLY_PO7:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (dummy0 :: Kernel)  . (((inv_Kernel dummy0)) \<longrightarrow> (let ls = (lights\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0); cs = (conflicts\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0) in (\<forall> c \<in> cs  . ((\<lparr>path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = (path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c), path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = (path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c)\<rparr> \<in> cs) \<longrightarrow> (((path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c) \<in> (dom ls)) \<longrightarrow> (((path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c) \<in> (dom ls)) \<longrightarrow> ((path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c) \<in> (dom ls))))))))))"

	by fastforce

\<comment>\<open>VDM source: Kernel = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 34:39\<close>
theorem Kernel_MAP_APPLY_PO8:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (dummy0 :: Kernel)  . (((inv_Kernel dummy0)) \<longrightarrow> (let ls = (lights\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0); cs = (conflicts\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0) in (\<forall> c \<in> cs  . ((\<lparr>path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = (path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c), path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = (path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c)\<rparr> \<in> cs) \<longrightarrow> (((path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c) \<in> (dom ls)) \<longrightarrow> (((path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c) \<in> (dom ls)) \<longrightarrow> ((\<not> (((the(ls (path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c)))) = Light.U_Red )) \<longrightarrow> ((path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c) \<in> (dom ls)))))))))))"

	by simp

\<comment>\<open>VDM source: Kernel = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 27:3\<close>
theorem Kernel_INV_SATISFIABILITY_PO9:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<exists> (dummy0 :: Kernel)  . (((inv_Kernel dummy0)) \<longrightarrow> (let ls = (lights\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0); cs = (conflicts\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0) in (\<forall> c \<in> cs  . ((\<lparr>path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = (path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c), path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = (path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c)\<rparr> \<in> cs) \<and> (((path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c) \<in> (dom ls)) \<and> (((path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c) \<in> (dom ls)) \<and> ((((the(ls (path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c)))) = Light.U_Red ) \<or> (((the(ls (path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t c)))) = Light.U_Red ))))))))))"

	by (metis Kernel.select_convs(2) empty_iff)

\<comment>\<open>VDM source: LIGHTS = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 62:12\<close>
theorem LIGHTS_MAP_SEQ_OF_COMPATIBLE_PO10:
	"((\<forall> m1 \<in> {[P1\<mapsto>Light.U_Red ] , [P2\<mapsto>Light.U_Red ] , [P3\<mapsto>Light.U_Green ] , [P4\<mapsto>Light.U_Green ]}  . (\<forall> m2 \<in> {[P1\<mapsto>Light.U_Red ] , [P2\<mapsto>Light.U_Red ] , [P3\<mapsto>Light.U_Green ] , [P4\<mapsto>Light.U_Green ]}  . (\<forall> d3 \<in> (dom m1)  . (\<forall> d4 \<in> (dom m2)  . ((d3 = d4) \<longrightarrow> ((m1 d3) = (m2 d4))))))))"

	by (simp add: insertE l_map_dom_ran option.discI singleton_iff)

\<comment>\<open>VDM source: CONFLICTS = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 68:16\<close>
theorem CONFLICTS_SUB_TYPE_PO11:
	"((inv_Conflict \<lparr>path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = P1, path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = P3\<rparr>))"
	unfolding inv_Conflict_defs by simp

\<comment>\<open>VDM source: CONFLICTS = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 69:16\<close>
theorem CONFLICTS_SUB_TYPE_PO12:
	"((inv_Conflict \<lparr>path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = P1, path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = P4\<rparr>))"
	unfolding inv_Conflict_defs by simp

\<comment>\<open>VDM source: CONFLICTS = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 70:16\<close>
theorem CONFLICTS_SUB_TYPE_PO13:
	"((inv_Conflict \<lparr>path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = P2, path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = P3\<rparr>))"
	unfolding inv_Conflict_defs by simp

\<comment>\<open>VDM source: CONFLICTS = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 71:16\<close>
theorem CONFLICTS_SUB_TYPE_PO14:
	"((inv_Conflict \<lparr>path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = P2, path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = P4\<rparr>))"
	unfolding inv_Conflict_defs by simp

\<comment>\<open>VDM source: CONFLICTS = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 72:16\<close>
theorem CONFLICTS_SUB_TYPE_PO15:
	"((inv_Conflict \<lparr>path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = P3, path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = P1\<rparr>))"
	unfolding inv_Conflict_defs by simp

\<comment>\<open>VDM source: CONFLICTS = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 73:16\<close>
theorem CONFLICTS_SUB_TYPE_PO16:
	"((inv_Conflict \<lparr>path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = P4, path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = P1\<rparr>))"
	unfolding inv_Conflict_defs by simp

\<comment>\<open>VDM source: CONFLICTS = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 74:16\<close>
theorem CONFLICTS_SUB_TYPE_PO17:
	"((inv_Conflict \<lparr>path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = P3, path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = P2\<rparr>))"
	unfolding inv_Conflict_defs by simp

\<comment>\<open>VDM source: CONFLICTS = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 75:16\<close>
theorem CONFLICTS_SUB_TYPE_PO18:
	"((inv_Conflict \<lparr>path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = P4, path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t = P2\<rparr>))"
	unfolding inv_Conflict_defs by simp

\<comment>\<open>VDM source: KERNEL = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 78:12\<close>
theorem KERNEL_SUB_TYPE_PO19:
	"((inv_Kernel \<lparr>lights\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l = LIGHTS, conflicts\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l = CONFLICTS\<rparr>))"
	unfolding inv_Kernel_defs by simp

\<comment>\<open>VDM source: ToGreen = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 91:7\<close>
theorem ToGreen_MAP_APPLY_PO20:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (p :: Path)   (dummy0 :: Kernel)  . ((((inv_Path p)))  \<and>  ((inv_Kernel dummy0)) \<longrightarrow> (let lights = (lights\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0); conflicts = (conflicts\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0) in ((p \<in> (dom lights)) \<longrightarrow> (p \<in> (dom lights)))))))"

	by presburger

\<comment>\<open>VDM source: ToGreen = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 93:25\<close>
theorem ToGreen_MAP_APPLY_PO21:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (p :: Path)   (dummy0 :: Kernel)  . ((((inv_Path p)))  \<and>  ((inv_Kernel dummy0)) \<longrightarrow> (let lights = (lights\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0); conflicts = (conflicts\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0) in ((p \<in> (dom lights)) \<longrightarrow> ((((the(lights p))) = Light.U_Red ) \<longrightarrow> (\<forall> dummy0 \<in> conflicts  . (let p1 = (path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t dummy0); p2 = (path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t dummy0) in ((p = p1) \<longrightarrow> (p2 \<in> (dom lights)))))))))))"

	by (meson inv_Kernel_def)

\<comment>\<open>VDM source: ToGreen = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 89:5\<close>
theorem ToGreen_SUB_TYPE_PO22:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (p :: Path)   (dummy0 :: Kernel)  . ((((inv_Path p)))  \<and>  ((inv_Kernel dummy0)) \<longrightarrow> (let lights = (lights\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0); conflicts = (conflicts\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0) in (((p \<in> (dom lights)) \<and> ((((the(lights p))) = Light.U_Red ) \<and> (\<forall> dummy0 \<in> conflicts  . (let p1 = (path1\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t dummy0); p2 = (path2\<^sub>C\<^sub>o\<^sub>n\<^sub>f\<^sub>l\<^sub>i\<^sub>c\<^sub>t dummy0) in ((p = p1) \<longrightarrow> (((the(lights p2))) = Light.U_Red )))))) \<longrightarrow> (inv_Kernel \<lparr>lights\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l = (ChgLight lights   p   Light.U_Green ), conflicts\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l = conflicts\<rparr>))))))"
	apply (safe, simp add: Let_def, safe)
  unfolding inv_Kernel_defs Let_def apply (simp, safe)
  \<comment> \<open>@LF cases below were sledgehammered\<close>
  apply (simp add: ChgLight_def dagger_finite)
  apply (smt (z3) ChgLight_def antirestr_then_dagger domIff dom_fun_upd l_dagger_apply option.simps(3))
  apply (simp add: ChgLight_def dagger_finite finite_ran)
    apply (simp add: ChgLight_def domD l_dagger_apply)
  apply (simp add: ChgLight_def domD l_dagger_apply)
  by (metis ChgLight_def Conflict.select_convs(1) Conflict.select_convs(2) dom_empty emptyE l_dagger_apply l_inmapupd_dom_iff)

\<comment>\<open>VDM source: ToRed = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 100:31\<close>
theorem ToRed_MAP_APPLY_PO23:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (p :: Path)   (dummy0 :: Kernel)  . ((((inv_Path p)))  \<and>  ((inv_Kernel dummy0)) \<longrightarrow> (let lights = (lights\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0); conflicts = (conflicts\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0) in ((p \<in> (dom lights)) \<longrightarrow> (p \<in> (dom lights)))))))"

	by presburger

\<comment>\<open>VDM source: ToRed = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 99:5\<close>
theorem ToRed_SUB_TYPE_PO24:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (p :: Path)   (dummy0 :: Kernel)  . ((((inv_Path p)))  \<and>  ((inv_Kernel dummy0)) \<longrightarrow> (let lights = (lights\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0); conflicts = (conflicts\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0) in (((p \<in> (dom lights)) \<and> (((the(lights p))) = Light.U_Amber )) \<longrightarrow> (inv_Kernel \<lparr>lights\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l = (ChgLight lights   p   Light.U_Red ), conflicts\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l = conflicts\<rparr>))))))"
	apply (safe, simp add: Let_def, safe)
  unfolding inv_Kernel_defs Let_def apply (simp, safe)
  \<comment> \<open>@LF cases below were sledgehammered\<close>
  apply (simp add: ChgLight_def dagger_finite)
  apply (smt (z3) ChgLight_def antirestr_then_dagger domIff dom_fun_upd l_dagger_apply option.simps(3))
  apply (simp add: ChgLight_def dagger_finite finite_ran)
    apply (simp add: ChgLight_def domD l_dagger_apply)
   apply (simp add: ChgLight_def domD l_dagger_apply)
  by (metis ChgLight_def Light.distinct(3) dom_eq_singleton_conv option.sel singleton_iff the_dagger_dom_left)

\<comment>\<open>VDM source: ToAmber = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 107:31\<close>
theorem ToAmber_MAP_APPLY_PO25:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (p :: Path)   (dummy0 :: Kernel)  . ((((inv_Path p)))  \<and>  ((inv_Kernel dummy0)) \<longrightarrow> (let lights = (lights\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0); conflicts = (conflicts\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0) in ((p \<in> (dom lights)) \<longrightarrow> (p \<in> (dom lights)))))))"

	by force

\<comment>\<open>VDM source: ToAmber = ?\<close>
\<comment>\<open>in 'traffic' (./src/test/resources/Examples/Traffic/traffic.vdmsl) at line 106:5\<close>
theorem ToAmber_SUB_TYPE_PO26:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (p :: Path)   (dummy0 :: Kernel)  . ((((inv_Path p)))  \<and>  ((inv_Kernel dummy0)) \<longrightarrow> (let lights = (lights\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0); conflicts = (conflicts\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l dummy0) in (((p \<in> (dom lights)) \<and> (((the(lights p))) = Light.U_Green )) \<longrightarrow> (inv_Kernel \<lparr>lights\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l = (ChgLight lights   p   Light.U_Amber ), conflicts\<^sub>K\<^sub>e\<^sub>r\<^sub>n\<^sub>e\<^sub>l = conflicts\<rparr>))))))"
	apply (safe, simp add: Let_def, safe)
  unfolding inv_Kernel_defs Let_def apply (simp, safe)
  \<comment> \<open>@LF cases below were sledgehammered\<close>
  apply (simp add: ChgLight_def dagger_finite)
  apply (smt (z3) ChgLight_def antirestr_then_dagger domIff dom_fun_upd l_dagger_apply option.simps(3))
  apply (simp add: ChgLight_def dagger_finite finite_ran)
    apply (simp add: ChgLight_def domD l_dagger_apply)
  apply (simp add: ChgLight_def domD l_dagger_apply)
  by (smt (z3) ChgLight_def Light.distinct(5) l_inmapupd_dom_iff l_map_non_empty_has_elem_conv option.sel the_dagger_dom_left)

\<comment>\<open>Processing VDM exports as Isabelle hidden declarations\<close>

\<comment> \<open>@LF 14 sledgehammered ; 9 simplified expansion; 3 proved by combination of specialised simplification and sledgehammer (1 for 3)\<close>

end


theory SmallStep
imports
  "~~/src/HOL/IMP/Star"
  "~~/src/HOL/Library/While_Combinator"
  Eval Type_Checker
begin

(* TODO: Move *)
definition init_map :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<rightharpoonup> 'b" where
  "init_map D f k \<equiv> if k\<in>D then Some (f k) else None"

lemma init_map_app_iff[simp]:
  "k\<in>D \<Longrightarrow> init_map D f k = Some (f k)"
  "k\<notin>D \<Longrightarrow> init_map D f k = None"
  unfolding init_map_def by auto

lemma init_map_dom[simp]: "dom (init_map D f) = D"
  unfolding init_map_def dom_def by auto

lemma init_map_ran[simp]: "ran (init_map D f) = f`D"
  unfolding init_map_def ran_def by auto

lemma init_map_set_simps[simp]:
  "init_map (D1 \<union> D2) f = init_map D1 f ++ init_map D2 f"
  "init_map (insert x D) f = (init_map D f) (x \<mapsto> f x)"
  unfolding init_map_def[abs_def]
  by (auto simp: map_add_def)

abbreviation "is_return m \<equiv> \<exists>x. is_res m x" (* TODO: Move*)
fun cp_err :: "('a,'err) error \<Rightarrow> ('b,'err) error" where
  "cp_err (EAssert e) = EAssert e"
| "cp_err (ENonterm) = ENonterm"
| "cp_err (return _) = undefined"

section \<open>Small Step Semantics\<close>

subsection \<open>CFG\<close>

text \<open>A CFG (Control Flow Graph) is a grahp representation of all paths that can be taken by a
  program during its execution.

  Here we define a CFG for our semantics with all the possible steps that it can take from one
  command to another.

  The nodes are defined as commands and the edges are labeled by an enabled and a transformer
  function. The enabled function indicates if the state is enabled to traverse this edge of the
  CFG from command1 to command2, and the transformer indicates the state that would result from
  taking this edge in the CFG.\<close>

subsection \<open>Type definitions\<close>

text \<open>An @{term enabled} is a partial function from @{term state} to @{term bool} that indicates whether
  an execution is enabled to continue.\<close>
type_synonym enabled = "state \<hookrightarrow> bool"

text \<open>A @{term transformer} is a partial function from @{term state} to @{term state} that
  applies a transformation to the first @{term state} and returns the second.\<close>
type_synonym transformer = "state \<hookrightarrow> state"

subsection \<open>Definition of initial state\<close>

text \<open>We proceed to define the components necessary to build the initial state. For it we need:
  * Initial stack: The initial stack is a stack that only contains the stack frame for the
      main function.
  * Initial globals: The initial globals is a valuation that returns None as the value for each
      of the globals of the program.
  * Initial memory: The initial memory is an empty list.

  Finally the initial state is the join of the initial stack, the initial globals and the
  initial memory.
\<close>
context program_loc begin

  definition "main_local_names \<equiv> map snd (fun_decl.locals main_decl)"
  definition "main_com \<equiv> fun_decl.body main_decl"

  definition initial_stack :: "stack_frame list" where
    "initial_stack \<equiv> [(main_com,map_of (map (\<lambda>x. (x,None)) main_local_names),Invalid)]"
  definition initial_glob :: valuation where
    "initial_glob \<equiv> map_of (map (\<lambda>x. (x,None)) (map snd (program.globals p)))"
  definition initial_mem :: mem where "initial_mem \<equiv> []"
  definition initial_state :: state
    where "initial_state \<equiv> (initial_stack, initial_glob, initial_mem)"

end

text \<open>id functions for enabled and transformer\<close>
abbreviation en_always :: enabled where "en_always \<equiv> \<lambda>_. return True"
abbreviation (input) tr_id :: transformer where "tr_id \<equiv> return"

subsection \<open>Enabled functions\<close>

text \<open>In this semantics the only reason why a node wouldn't be enabled to continue is if a
  condition would evaluate to True and we were trying to take the edge for the False branch
  or viceversa.\<close>

text \<open>We have no bool values in our semantics. Instead we have to interpret our values as
  True or False. Any value different from @{term NullVal} or @{term "I 0"} is True, on the other
  hand @{term NullVal} and @{term "I 0"} would both be False.\<close>
fun truth_value_of :: "val \<Rightarrow> bool" where
  "truth_value_of NullVal \<longleftrightarrow> False"
| "truth_value_of (I i) \<longleftrightarrow> i\<noteq>0"
| "truth_value_of (A _) \<longleftrightarrow> True"

text \<open>Given an expression, typically the condition for an if branch, we will evaluate the
  true value of that expression and then return that boolean value.
  We want to know if we're enabled to continue to the true branch of the conditional.\<close>
definition en_pos :: "exp \<Rightarrow> enabled" where
  "en_pos e s \<equiv> do {
    (v,_) \<leftarrow> lift_transformer (eval e) s;
    let b = truth_value_of v;
    return b
  }"

text \<open>Given an expression, typically the condition for an if branch, we will evaluate the
  true value of that expression and then return that boolean value.
  We want to know if we're enabled to continue to the false branch of the conditional, therefore
  we return the negation of the boolean value.\<close>
definition en_neg :: "exp \<Rightarrow> enabled" where
  "en_neg e s \<equiv> do {
    (v,_) \<leftarrow> lift_transformer (eval e) s;
    let b = truth_value_of v;
    return (\<not>b)
  }"

subsection \<open>Transformer functions\<close>

text \<open>A transformer function has return type @{term "state option"} It returns
  None if there's an error at some point in the execution. Otherwise it'll return Some state.\<close>

text \<open>The transformer for an assignment will evaluate the expression we want to assign
  and then proceed to write the value to the state, it returns the state resulting from
  doing this write.\<close>
definition "tr_assign x a \<equiv> lift_transformer_nr (\<lambda>s. do {
  (v,s) \<leftarrow> eval a s;
  s \<leftarrow> write_var x v s;
  return s
})"

text \<open>The transformer for an assignment to an address will first evaluate the l-expression to
  obtain the address in which we want to store the value, then it will evaluate the expression
  we want to store and then proceed to store the value, it returns the state resulting from
  doing this store.\<close>
definition tr_assignl :: "lexp \<Rightarrow> exp \<Rightarrow> transformer"
where "tr_assignl x a \<equiv> lift_transformer_nr (\<lambda>s. do {
  (addr,s) \<leftarrow> eval_l x s;
  (v,s) \<leftarrow> eval a s;
  store addr v s
})"

text \<open>The transformer for an evaluation will evaluate the expression and proceed to return the
  state resulting from evaluating this expression.\<close>
definition tr_eval :: "exp \<Rightarrow> transformer" where
  "tr_eval e \<equiv> lift_transformer_nr (\<lambda>s. do {
    (_,s) \<leftarrow> eval e s;
    return s
  })"

text \<open>The transformer for a free operation will evaluate the expression it receives to obtain
  the address it will free in memory and proceeds to execute the free operation.\<close>
definition tr_free :: "exp \<Rightarrow> transformer" where
  "tr_free e \<equiv> lift_transformer_nr (\<lambda>s. do {
    (v, s) \<leftarrow> eval e s;
    case v of
      A addr \<Rightarrow> free addr s
    | NullVal \<Rightarrow> pointer_error
    | _ \<Rightarrow> type_error
  })"

(* A function can be called if the number of parameters from the function and the actual parameters
   used when calling it match, otherwise it can't be called
   If the number of parameters is wrong we return None instead of False because we want it to stop
   executing \<rightarrow> it's an error. *)
(*definition en_callfun :: "fname \<Rightarrow> exp list \<Rightarrow> enabled" where
  "en_callfun f values _ \<equiv> do {
    (params, locals, _) \<leftarrow> proc_table f;
    if (list_size params) = (list_size values) then Some True else None
  }"*)

text \<open>We write some auxiliary functions for push, popping and returning the top of the stack.\<close>

definition push_stack :: "stack_frame \<Rightarrow> transformer" where
  "push_stack \<equiv> \<lambda>sf (\<sigma>,\<gamma>,\<mu>). return (sf#\<sigma>,\<gamma>,\<mu>)"

fun pop_stack :: "transformer" where
  "pop_stack (sf#\<sigma>,\<gamma>,\<mu>) = return (\<sigma>,\<gamma>,\<mu>)"
| "pop_stack _ = structural_error"

fun top_stack :: "state \<hookrightarrow> stack_frame" where
  "top_stack (sf#\<sigma>,_,_) = return sf"
| "top_stack _ = structural_error"

(* TODO: Move *)
primrec semap :: "('a \<Rightarrow> 's \<hookrightarrow> 'b\<times>'s) \<Rightarrow> 'a list \<Rightarrow> 's \<hookrightarrow> 'b list\<times>'s" where
  "semap _ [] s = return ([],s)"
| "semap f (x#xs) s = do {
    (y,s) \<leftarrow> f x s;
    (ys,s) \<leftarrow> semap f xs s;
    return (y#ys,s)
  }"

lemma semap_length: "semap f xs s = return (ys,s') \<Longrightarrow> length ys = length xs"
  by (induction xs arbitrary: s s' ys) (auto split: Error_Monad.bind_splits)

text \<open>When calling a function we make the call with the values instead of the expressions.
  @{term real_values} takes an expression list and transforms it into a value list by evaluating
  each expression.\<close>
definition real_values :: "exp list \<Rightarrow> visible_state \<hookrightarrow> (val list \<times> visible_state)" where
  "real_values xs s \<equiv> semap eval xs s"

(*
fun real_values :: "exp list \<Rightarrow> visible_state \<hookrightarrow> (val list \<times> visible_state)" where
  "real_values [] s = return ([], s)"
| "real_values (x#xs) s = do {
    (v,s) \<leftarrow> eval x s;
    (vals, s) \<leftarrow> real_values xs s;
    return ([v] @ vals, s)
  }" *)

text \<open>The difference between calling a function and a procedure is that a function returns
  a value whereas the procedure doesn't. A stack frame has a return location that indicates where
  the caller expects the result of a function call.

  When calling a function, independent from whether it returns or not we must make sure that
  the length of the parameters which we are using to call the function are the same length as
  the formal parameters, then we proceed to evaluate the parameters, this will be done from left
  to right, we set the parameters of the function with their values for the valuation and the
  rest of the locals we set to uninitialized (None).

  With the locals, the functions body and return location invalid we create a new stack frame,
  push it to the stack and return the state.\<close>

definition mk_locals :: "fun_decl \<Rightarrow> val list \<hookrightarrow> valuation" where
  "mk_locals fd vals \<equiv> do {
    assert (length (fun_decl_param_names fd) = length vals) (EStatic EType);
    return (map_of (zip (fun_decl_param_names fd) (map Some vals))
      ++ init_map (set (fun_decl_local_names fd)) (\<lambda>_. None))
  }"

lemma init_map_set[code_unfold]: "init_map (set l) f = map_of (map (\<lambda>x. (x, f x)) l)"
  by (induction l) auto

export_code mk_locals in SML
definition init_frame :: "fun_decl \<Rightarrow> exp list \<Rightarrow> visible_state \<hookrightarrow> (stack_frame \<times> visible_state)"
  where "init_frame fd pexps vs \<equiv> do {
    (pvals,vs) \<leftarrow> real_values pexps vs;
    locals \<leftarrow> mk_locals fd pvals;
    return ((fun_decl.body fd,locals,return_loc.Invalid),vs)
  }"

definition call_function :: "proc_table \<Rightarrow> fname \<Rightarrow> exp list \<Rightarrow> transformer"
where "call_function proc_table f params_exp s \<equiv> do {
  fdecl \<leftarrow> case proc_table f of
      Some fdecl \<Rightarrow> return fdecl
    | None \<Rightarrow> type_error;
  (sf,s) \<leftarrow> lift_transformer (init_frame fdecl params_exp) s;
  push_stack sf s
}"

text \<open>@{term set_rloc} and @{term get_rloc} will allow us to modify the return location of the
  current stack frame.\<close>
definition set_rloc :: "return_loc \<Rightarrow> transformer" where
  "set_rloc rloc \<equiv> \<lambda>((com,locals,_)#\<sigma>,\<gamma>,\<mu>) \<Rightarrow>
    return ((com,locals,rloc)#\<sigma>,\<gamma>,\<mu>)
  "

definition get_rloc :: "state \<Rightarrow> return_loc" where
  "get_rloc \<equiv> \<lambda>((com,locals,rloc)#\<sigma>,\<gamma>,\<mu>) \<Rightarrow> rloc"

text \<open>When a function returns to a l-expression, first of all we evaluate the l-expression
  to obtain the return address. This is the first evaluation we do because if we do it afterwards
  we might risk unwanted behaviour as the function might have changed the state.
  After that we update the return location indicating we expect the function to return to this
  address and we call @{term call_function}.\<close>
definition tr_callfunl :: "proc_table \<Rightarrow> lexp \<Rightarrow> fname \<Rightarrow> exp list \<Rightarrow> transformer" where
  "tr_callfunl proc_table x f args s \<equiv> do {
    (addr,s) \<leftarrow> lift_transformer (eval_l x) s;
    s \<leftarrow> set_rloc (Ar addr) s;
    call_function proc_table f args s
  }"

text \<open>When a function returns to a variable, we set the return location to that variable
  indicating we expect the function to return to this variable and we call
  @{term call_function}.\<close>
definition tr_callfun :: "proc_table \<Rightarrow> vname \<Rightarrow> fname \<Rightarrow> exp list \<Rightarrow> transformer" where
  "tr_callfun proc_table x f args s \<equiv> do {
    s \<leftarrow> set_rloc (Vr x) s;
    call_function proc_table f args s
  }"

text \<open>When a function returns to a variable, we set the return location to invalid
  indicating we expect the function to return void and we call @{term call_function}.\<close>
definition tr_callfunv :: "proc_table \<Rightarrow> fname \<Rightarrow> exp list \<Rightarrow> transformer" where
  "tr_callfunv proc_table f args s \<equiv> do {
    s \<leftarrow> set_rloc Invalid s;
    call_function proc_table f args s
  }"

text \<open>The transformer for return will pop the last stack frame in the stack belonging to the
  returning function, evaluate the value returned by the function and if the stack is not empty
  then proceed to get the return location and depending on if it's a an address, a variable or
  invalid it will store, write or return the state as it is respectively.\<close>
definition tr_return :: "exp \<Rightarrow> transformer" where
  "tr_return a s = do {
    (v,s) \<leftarrow> lift_transformer (eval a) s;
    s \<leftarrow> pop_stack s;
    if \<not>is_empty_stack s then
      case get_rloc s of
        Ar addr \<Rightarrow> lift_transformer_nr (store addr v) s
      | Vr x \<Rightarrow> lift_transformer_nr (write_var x v) s
      | Invalid \<Rightarrow> return s
    else
      return s
  }"

text \<open>The transformer for return will pop the last stack frame in the stack belonging to the
  returning function and if the stack is not empty then proceed to get the return location and
  if it's a variable or an address this is an error and returns None, if, on the other hand,
  it's Invalid then it will return the state.\<close>
definition tr_return_void :: "transformer" where
  "tr_return_void s = do {
    s \<leftarrow> pop_stack s;
    if \<not>is_empty_stack s then
      case get_rloc s of
        Ar addr \<Rightarrow> type_error
      | Vr x \<Rightarrow> type_error
      | Invalid \<Rightarrow> return s
    else
      return s
  }"

subsection \<open>Definition of the CFG\<close>

text \<open>The CFG offers a relation that shows the edges that can occur in the context of our
  semantics.

  The following are the relationships permitted in the CFG. In other words they're the possible
  small steps that can be taken when executing a program.
  Each of these rules have the form:

  cfg c\<^sub>1 (enabled, transformer) c\<^sub>2

  This means that in our CFG we would have an edge from c\<^sub>1 to c\<^sub>2 labeled with (enabled, transformer).
  The enabled and transformers used in the CFG definitions are the ones described previously.
\<close>
context program_loc begin

datatype cfg_edge_type = ET_Intra | ET_Call | ET_Return

text \<open>A CFG label consists of a pair containing an @{term enabled} and a @{term state}.\<close>
type_synonym cfg_label = "cfg_edge_type \<times> enabled \<times> transformer"

inductive cfg :: "com \<Rightarrow> cfg_label \<Rightarrow> com \<Rightarrow> bool" where
  Assign: "cfg (x ::= a) (ET_Intra,en_always,tr_assign x a) SKIP"
| Assignl: "cfg (x ::== a) (ET_Intra,en_always,tr_assignl x a) SKIP"
| Seq1: "cfg (SKIP;; c\<^sub>2) (ET_Intra,en_always, tr_id) c\<^sub>2"
| Seq2: "\<lbrakk>cfg c\<^sub>1 a c\<^sub>1'\<rbrakk> \<Longrightarrow> cfg (c\<^sub>1;; c\<^sub>2) a (c\<^sub>1';; c\<^sub>2)"
| IfTrue: "cfg (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (ET_Intra,en_pos b, tr_eval b) c\<^sub>1"
| IfFalse: "cfg (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (ET_Intra,en_neg b, tr_eval b) c\<^sub>2"
| While: "cfg (WHILE b DO c) (ET_Intra,en_always, tr_id) (IF b THEN c;; WHILE b DO c ELSE SKIP)"
| Free: "cfg (FREE x) (ET_Intra,en_always, tr_free x) SKIP"

| Return: "cfg (Return a) (ET_Return,en_always, tr_return a) SKIP"
| Returnv: "cfg Returnv (ET_Return,en_always, tr_return_void) SKIP"

| Callfunl: "cfg (Callfunl e f params) (ET_Call,en_always, tr_callfunl proc_table e f params) SKIP"
| Callfun: "cfg (Callfun x f params) (ET_Call,en_always, tr_callfun proc_table x f params) SKIP"
| Callfunv: "cfg (Callfunv f params) (ET_Call,en_always, tr_callfunv proc_table f params) SKIP"

subsection \<open>Definition of the Small Step Semantics\<close>

text \<open>Each stack frame of the stack contains a command, these are the instructions that are
  executed. The initial stack has only one stack frame that has the body of main.

  Since the code we need to execute is there our small step semantics goes from state to state
  option.

  A step in the small step semantics can be taken if the stack is not empty, there's a cfg rule
  from c\<^sub>1 to c\<^sub>2,  the command of the state is c\<^sub>1, the enabled is true and applying the transformer
  to the state with the command updated from c\<^sub>1 to c\<^sub>2 yields a Some s\<^sub>2. If all these conditions
  are met then a small step can go from s to s\<^sub>2.

  If either the enabled or the transformer yield None, there was an error during the execution
  and we take a small step from s to None which is a special error state.

  If the command at the top of the stack is SKIP, the stack is not empty and calling
  @{term tr_return_void} on s yields a new state s\<^sub>2, then we can take a small step from s to s\<^sub>2.

  Finally if the command at the top of the stack is SKIP, the stack is not empty but calling
  @{term tr_return_void} returns None, then we take a small step from s to None, which is a
  special error state.
\<close>
inductive
  small_step :: "state \<Rightarrow> state ce \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
  Base: "\<lbrakk> \<not>is_empty_stack s; c\<^sub>1=com_of s; cfg c\<^sub>1 (_, en, tr) c\<^sub>2; en s = return True; s'= tr (upd_com c\<^sub>2 s)\<rbrakk> \<Longrightarrow> s \<rightarrow> s'"
| En_fail: "\<lbrakk> \<not>is_empty_stack s; c\<^sub>1=com_of s; cfg c\<^sub>1 (_, en, tr) c\<^sub>2; \<not>is_return (en s); s'=cp_err (en s)\<rbrakk> \<Longrightarrow> s \<rightarrow> s'"
| Return_void: "\<lbrakk> \<not>is_empty_stack s; com_of s = SKIP; s'= tr_return_void s\<rbrakk> \<Longrightarrow> s \<rightarrow> s'"

text \<open>We lift our definition of small step to state option in order to be able to take
  more than one step in the semantics.\<close>
inductive
  small_step' :: "(state) ce \<Rightarrow> (state) ce \<Rightarrow> bool" (infix "\<rightarrow>' " 55)
where
  "cs \<rightarrow> cs' \<Longrightarrow> return cs \<rightarrow>' cs'"

text \<open>We can define the execution of a program as the reflexive transitive closure of
  @{term small_step'} by using the star operator.\<close>
abbreviation
  small_steps :: "(state) ce \<Rightarrow> (state) ce \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step' x y"

subsection \<open>Lemmas regarding the semantics\<close>

text \<open>If a command is not SKIP we prove that there will always be an enabled action it can
  take or an error would occur when executing enabled (a None is returned). The proof for this
  lemma has two interesting cases, namely @{term Seq} and @{term If}.

  In the @{term Seq} case we only have to do a case distinction on whether the first command
  of the sequential composition is SKIP or not. When making that case distinction is clear that
  for both cases there's a cfg rule that ensures an enabled action.

  The @{term If} case is a bit more complicated. We need to make a case distinction over the
  value of @{term "en_pos b s"}, if it's None then the lemma is true. If the value of
  @{term "en_pos b s"} is true then the lemma is also true. The tricky part about
  this proof is that when @{term "en_pos b s"} is False, this in our CFG means that the
  else branch should be taken, therefore when @{term "en_pos b s"} is False, @{term "en_neg b s"}
  will always evaluate to True. Once we prove this the command has an enabled action
  (@{term "en_neg b s"} \<equiv> True) and the proof of the lemma is complete.
\<close>
lemma cfg_has_enabled_action:
  assumes "c\<noteq>SKIP"
  shows "\<exists>c' et en tr. cfg c (et,en,tr) c' \<and> (\<not>is_return (en s) \<or> en s = return True)"
  using assms
proof (induction c)
  case (Seq c\<^sub>1 c\<^sub>2)
  show ?case
  proof (cases "c\<^sub>1 = SKIP")
    case True
    thus ?thesis by (force intro: cfg.intros)
  next
    case False
    from Seq.IH(1)[OF this] show ?thesis by (force intro: cfg.intros)
  qed
next
  case (If b c\<^sub>1 c\<^sub>2)
  show ?case
  proof (cases "en_pos b s")
    case (EAssert e)[simp]
    thus ?thesis by (fastforce intro: cfg.intros)
  next
    case (ENonterm)[simp]
    thus ?thesis by (fastforce intro: cfg.intros)
  next
    case (return a)[simp]
      show ?thesis
      proof (cases a)
        case True
        thus ?thesis by (fastforce intro: cfg.intros)
      next
        case False[simp]
        have "en_pos b s = return False" by simp
        hence "en_neg b s = return True"
          unfolding en_pos_def en_neg_def
          by (auto split: Error_Monad.bind_splits)
        thus ?thesis by (fastforce intro: cfg.intros)
      qed
  qed
qed (fastforce intro: cfg.intros)+

(* TODO: Move *)
lemma assert_simps[simp]:
  "assert \<Phi> e = EAssert e' \<longleftrightarrow> \<not>\<Phi> \<and> e'=e"
  "assert \<Phi> e \<noteq> ENonterm"
  "assert \<Phi> e = return u \<longleftrightarrow> \<Phi>"
  unfolding assert_def by auto

text \<open>The following lemma states that as long as the stack is not empty we can always take a
  small step.\<close>
lemma can_take_step:
  assumes [simp, intro!]: "\<not>is_empty_stack s"
  shows "\<exists>x. s \<rightarrow> x"
  using assms
proof -
  from assms obtain c locals rloc \<sigma> \<gamma> \<mu> where
    [simp]: "s = ((c,locals,rloc)#\<sigma>, \<gamma>,\<mu>)"
    unfolding is_empty_stack_def
    apply (simp add: neq_Nil_conv split: prod.splits)
    by auto

  show ?thesis proof (cases "c=SKIP")
    case True[simp]
    show ?thesis apply auto
      by (metis Base En_fail Return_void True
        `s = ((c, locals, rloc) # \<sigma>, \<gamma>, \<mu>)` assms cfg_has_enabled_action )
  next
    case False
    from cfg_has_enabled_action[OF False] obtain c' et en tr
      where "cfg c (et, en, tr) c' \<and> (\<not>is_return (en s) \<or> en s = return True)" by blast
    thus ?thesis proof safe
      assume "cfg c (et, en, tr) c'" "\<not>is_return (en s)"
      thus ?thesis apply - apply (rule exI) apply (rule small_step.En_fail)
      by auto
    next
      assume A: "cfg c (et, en, tr) c'" "en s = return True"
      thus ?thesis by (force intro: small_step.Base)
    qed
  qed
qed

text \<open>cfg gets stuck at SKIP\<close>
lemma cfg_SKIP_stuck[simp]: "\<not> cfg SKIP a c"
  by (auto elim: cfg.cases)

text \<open>An execution is done when we can't take any more steps, this happens when the stack is empty.\<close>
lemma ss_empty_stack_stuck[simp]: "is_empty_stack s \<Longrightarrow> \<not>( s \<rightarrow> cs')"
  by (auto elim: small_step.cases)

lemma ss'_SKIP_stuck[simp]: "is_empty_stack s \<Longrightarrow> \<not>( return s \<rightarrow>' cs')"
  by (auto elim: small_step'.cases)

text \<open>the result of @{term "en_neg e s"} will always be the negation of the result of
  @{term "en_pos e s"}.\<close>
lemma en_neg_by_pos: "en_neg e s = map_error (HOL.Not) id (en_pos e s)"
  unfolding en_pos_def en_neg_def
  by (auto split: Error_Monad.bind_splits)

subsection \<open>Determinism\<close>

text \<open>We prove that cfg is deterministic.\<close>
lemma cfg_determ:
  assumes "cfg c a1 c'"
  assumes "cfg c a2 c''"
  obtains
      "a1=a2" "c' = c''"
    | b where "a1 = (ET_Intra,en_pos b,tr_eval b)" "a2 = (ET_Intra,en_neg b,tr_eval b)"
    | b where "a1 = (ET_Intra,en_neg b,tr_eval b)" "a2 = (ET_Intra,en_pos b,tr_eval b)"
  using assms
  apply (induction arbitrary: c'')
  apply (erule cfg.cases, auto) []
  apply (erule cfg.cases, auto) []
  apply (erule cfg.cases, auto) []
  apply (rotate_tac)
  apply (erule cfg.cases, auto) []
  apply (erule cfg.cases, auto) []
  apply (erule cfg.cases, auto) []
  apply (erule cfg.cases, auto) []
  apply (erule cfg.cases, auto) []
  apply (erule cfg.cases, auto) []
  apply (rotate_tac)
  apply (erule cfg.cases, auto) []
  apply (rotate_tac)
  apply (erule cfg.cases, auto) []
  apply (erule cfg.cases, auto) []
  apply (erule cfg.cases, auto) []
  done

text \<open>We prove that if the stack is not empty it doesn't matter if we update the command first
  and then apply the transformer or the other way around since the transformer works in the
  visible state level and doesn't temper with the command in the top of the stack.\<close>
lemma lift_upd_com: "\<not>is_empty_stack s \<Longrightarrow>
  lift_transformer_nr tr (upd_com c s) =
  map_error (upd_com c) id (lift_transformer_nr tr s)"
  unfolding lift_transformer_nr_def
  by (auto split: prod.splits list.splits Error_Monad.bind_split)

text \<open>We prove that if the stack is not empty it doesn't matter if we update the command first
  and then apply the eval transformer or the other way around since the eval transformer works
  in the visible state level and doesn't temper with the command in the top of the stack.\<close>
lemma tr_eval_upd_com: "\<not>is_empty_stack s \<Longrightarrow>
  tr_eval e (upd_com c s) = map_error (upd_com c) id (tr_eval e s)"
  unfolding tr_eval_def
  by (auto simp: lift_upd_com)

(* TODO: Move *)
lemma no_return_conv: "(\<forall>x. \<not>is_res m x) \<longleftrightarrow> (m=ENonterm) \<or> (\<exists>e. m=EAssert e)"
  by (cases m) auto

lemma [simp]: "\<not>is_nonterm (mem_get_block \<mu> addr)"
  unfolding mem_get_block_def by (auto split: prod.splits)

lemma [simp]: "\<not>is_nonterm (assert_valid_addr \<mu> addr)"
  unfolding assert_valid_addr_def by (auto split: prod.splits)

lemma [simp]: "\<not>is_nonterm (plus_val \<mu> v1 v2)"
  by (cases "(\<mu>,v1,v2)" rule: plus_val.cases) (auto simp: Let_def)

lemma [simp]: "\<not>is_nonterm (subst_val \<mu> v1 v2)"
  by (cases "(\<mu>,v1,v2)" rule: subst_val.cases) (auto simp: Let_def)

lemma [simp]: "\<not>is_nonterm (minus_val v1)"
  by (cases "(v1)" rule: minus_val.cases) auto

lemma [simp]: "\<not>is_nonterm (div_val v1 v2)"
  by (cases "(v1,v2)" rule: div_val.cases) auto

lemma [simp]: "\<not>is_nonterm (mod_val v1 v2)"
  by (cases "(v1,v2)" rule: mod_val.cases) auto

lemma [simp]: "\<not>is_nonterm (mult_val v1 v2)"
  by (cases "(v1,v2)" rule: mult_val.cases) auto

lemma [simp]: "\<not>is_nonterm (less_val \<mu> v1 v2)"
  by (cases "(\<mu>,v1,v2)" rule: less_val.cases) auto

lemma [simp]: "\<not>is_nonterm (to_bool v)"
  by (cases v rule: to_bool.cases) (auto)

lemma [simp]: "\<not>is_nonterm (not_val v1)"
  unfolding not_val_def by auto

lemma [simp]: "\<not>is_nonterm (eq_val \<mu> v1 v2)"
  by (cases "(\<mu>,v1,v2)" rule: eq_val.cases) auto

lemma [simp]: "\<not>is_nonterm (new_block v1 v2)"
  by (cases "(v1,v2)" rule: new_block.cases) auto

lemma [simp]: "\<not>is_nonterm (load v1 v2)"
  unfolding load_def
  by (auto split: prod.splits option.splits)

lemma [simp]: "\<not>is_nonterm (eval e s)" "\<not>is_nonterm (eval_l le s)"
  apply (induction e and le arbitrary: s and s)
  apply (auto split: option.splits val.splits simp: Let_def read_var_def)
  done

lemma [simp]: "\<not>is_empty_stack s \<Longrightarrow> \<not>is_nonterm (en_pos e s)"
  by (simp add: en_pos_def)

lemma [simp]: "\<not>is_empty_stack s \<Longrightarrow> \<not>is_nonterm (en_neg e s)"
  by (simp add: en_neg_def)

text \<open>We prove that small step is deterministic.\<close>
lemma small_step_determ:
  assumes "s \<rightarrow> s'"
  assumes "s \<rightarrow> s''"
  shows "s'=s''"
  using assms
  apply (cases)
  apply (erule small_step.cases)
  apply simp
  apply (erule (1) cfg_determ, auto simp: en_neg_by_pos tr_eval_upd_com; fail) []
  apply simp
  apply (erule (1) cfg_determ, auto simp: no_return_conv en_neg_by_pos tr_eval_upd_com; fail) []
  apply simp+

  apply (erule small_step.cases; simp?)
  apply (erule (1) cfg_determ, auto simp: no_return_conv en_neg_by_pos tr_eval_upd_com; fail) []
  apply (erule (1) cfg_determ; auto simp add: no_return_conv pw_nt_iff en_neg_by_pos; fail)

  apply (erule small_step.cases)
  apply simp+
  done

end

section \<open>Executing the semantics\<close>

subsection \<open>Taking a single step in the semantics\<close>

text \<open>We represent two kinds of edges in the cfg. A Base edge that has a transformer,
  is always enabled and takes us to a new command and a Cond edge that apart from the
  transformer also has an enabled and two commands, the enabled indicates whether the
  execution goes to the first or the second command.\<close>
datatype cfg_edge = Base transformer com | Cond enabled transformer com com

context fixes proc_table :: proc_table begin

text \<open>For every command in the semantics we return what kind of step we take in the cfg.\<close>
fun cfg_step :: "com \<Rightarrow> cfg_edge" where
  "cfg_step SKIP = undefined"
| "cfg_step (x ::= a) = Base (tr_assign x a) SKIP"
| "cfg_step (x ::== a) = Base (tr_assignl x a) SKIP"
| "cfg_step (SKIP;; c2) = Base tr_id c2"
| "cfg_step (c1;;c2) = (case cfg_step c1 of
    Base tr c \<Rightarrow> Base tr (c;;c2)
  | Cond en tr ca cb \<Rightarrow> Cond en tr (ca;;c2) (cb;;c2)
   )"
| "cfg_step (IF b THEN c1 ELSE c2) = Cond (en_pos b) (tr_eval b) c1 c2"
| "cfg_step (WHILE b DO c) = Base tr_id (IF b THEN c;; WHILE b DO c ELSE SKIP)"
| "cfg_step (FREE x) = Base (tr_free x) SKIP"
| "cfg_step (Return a) = Base (tr_return a) SKIP"
| "cfg_step Returnv = Base (tr_return_void) SKIP"
| "cfg_step (Callfunl e f params) = Base (tr_callfunl proc_table e f params) SKIP"
| "cfg_step (Callfun x f params) = Base (tr_callfun proc_table x f params) SKIP"
| "cfg_step (Callfunv f params) = Base (tr_callfunv proc_table f params) SKIP"

end

context program_loc begin

text \<open>If we have a command different from SKIP and the cfg_step function returns a Base step
  as the kind of step we can take in the CFG then there will be a definition matching this in
  the cfg definition.\<close>
  lemma step_to_cfg_base: "c \<noteq> SKIP \<Longrightarrow> (cfg_step proc_table c = Base tr c') \<Longrightarrow>
      \<exists>et. cfg c (et,en_always,tr) c'"
    apply (induction c arbitrary: tr c' rule: cfg_step.induct)
    apply (auto intro: cfg.intros elim: cfg.cases split: cfg_edge.splits)
    apply (force intro: cfg.intros elim: cfg.cases split: cfg_edge.splits)
    done

lemma map_en_posneg_conv[simp]:
  "map_error HOL.Not id o en_pos e = en_neg e"
  "map_error HOL.Not id o en_neg e = en_pos e"
  unfolding en_pos_def[abs_def] en_neg_def[abs_def]
  by (auto intro!: ext split: Error_Monad.bind_splits)

text \<open>Also, if we have a command different from SKIP and the cfg_step function returns a Cond
  step as the kind of step we can take in the CFG then there will be a definition matching
  this in the cfg definition.\<close>
  lemma step_to_cfg_cond: "c \<noteq> SKIP \<Longrightarrow> (cfg_step proc_table c = Cond en tr c1' c2') \<Longrightarrow>
    (cfg c (ET_Intra,en,tr) c1' \<and> cfg c (ET_Intra,map_error HOL.Not id o en, tr) c2' )"
    apply (induction c arbitrary: tr c1' c2' rule: cfg_step.induct)
    apply (auto
      intro: cfg.intros elim: cfg.cases split: cfg_edge.splits simp: en_neg_by_pos)
    done

text \<open>If we have a cfg rule and the first command is different from SKIP then we will always
  obtain from cfg_step a Base or a Cond step.\<close>
  lemma cfg_to_stepE:
    assumes "cfg c a c'"
    assumes "c\<noteq>SKIP"
    obtains
      et tr where "a = (et,en_always, tr)" "cfg_step proc_table c = Base tr c'"
    | b c2' where "a = (ET_Intra, en_pos b, tr_eval b)" "cfg_step proc_table c = Cond (en_pos b) (tr_eval b) c' c2'"
    | b c1' where "a = (ET_Intra, en_neg b, tr_eval b)" "cfg_step proc_table c = Cond (en_pos b) (tr_eval b) c1' c'"
    using assms
    apply (induction)
    apply auto
    apply (case_tac "c\<^sub>1")
    apply auto
    done

end

text \<open>This is how we take a single step in an execution.
  If the command we need to execute is a SKIP we call the return void transformer.
  Otherwise we will check which kind of step we should take from the @{term cfg_step} function
  and based on that if it's a Base step we will call the transformer with the updated command
  or if it's a Cond we will evaluate the condition and call the transformer with the correct
  updated command.\<close>
definition fstep :: "proc_table \<Rightarrow> state \<hookrightarrow> state" where
  "fstep proc_table s \<equiv>
    if com_of s = SKIP then
      tr_return_void s
    else
      case cfg_step proc_table (com_of s) of
          Base tr c' \<Rightarrow> tr (upd_com c' s)
        | Cond en tr c1 c2 \<Rightarrow> do {
            b \<leftarrow> en s;
            if b then
              tr (upd_com c1 s)
            else
              tr (upd_com c2 s)
          }"

subsection \<open>Equality between small semantics and single execution\<close>

context program_loc begin

text \<open>@{term fstep1} shows the first direction of this equality. If we can take a step in the
  small step semantics from a state s to a state s' then, executing fstep on that state s will
  yield the same s'.\<close>
  lemma fstep1:
    assumes "s \<rightarrow> s'"
    shows "fstep proc_table s = s'"
    using assms
    apply induction
    apply (auto simp: fstep_def)

    apply (erule cfg_to_stepE)
    apply (auto split: Error_Monad.bind_split simp: en_neg_by_pos)

    apply (erule cfg_to_stepE)
    apply (auto split: Error_Monad.bind_split simp: en_neg_by_pos)
    done

text \<open>@{term fstep2} shows the other direction of this equality. Assuming the stack is not
  empty then taking a step in the small step semantics from a state s will lead us to a
  to a state s' that is the result of executing fstep on that state s.\<close>
lemma fstep2: "\<not>is_empty_stack s \<Longrightarrow> s \<rightarrow> (fstep proc_table s)"
  unfolding fstep_def
  apply simp apply safe
  apply (rule small_step.Return_void; simp)

  apply (simp split: cfg_edge.splits, safe)
  apply (frule (1) step_to_cfg_base)
  apply (metis (no_types, lifting) can_take_step cfg_edge.simps(5) fstep1 fstep_def)
  apply (frule (1) step_to_cfg_cond)
  apply (auto split: Error_Monad.bind_splits)
  apply (rule small_step.En_fail, simp+) []
  apply (rule small_step.En_fail, simp+) []
  apply (rule small_step.Base, simp+) []
  apply (rule small_step.Base[where en="map_error _ _ o _"], simp+; fail) []
  done

lemma ss_fstep_equiv: "\<not>is_empty_stack s \<Longrightarrow> s \<rightarrow> s' \<longleftrightarrow> fstep proc_table s = s'"
  using fstep1 fstep2
  by blast

end

subsection \<open>Interpreter for the semantics\<close>

text \<open>A state is considered final if the stack in that state is empty or if it's None.\<close>
fun is_term :: "state ce \<Rightarrow> bool" where
  "is_term (return s) = is_empty_stack s"
| "is_term _ = True"

text \<open>The interpreter for our semantics works as follows:
  As long as we don't reach a final state then we execute @{term fstep}.\<close>
definition interp :: "proc_table \<Rightarrow> state \<hookrightarrow> state" where
  "interp proc_table cs \<equiv> (while
    (HOL.Not o is_term)
    (\<lambda>return cs \<Rightarrow> fstep proc_table cs)
    (return cs))"

lemma interp_unfold: "interp proc_table cs = (
    if is_term (return cs) then
      return cs
    else do {
      cs \<leftarrow> fstep proc_table cs;
      interp proc_table cs
    }
  )"
  unfolding interp_def
  apply (subst while_unfold)
  apply (auto split: Error_Monad.bind_split)
  apply (subst while_unfold)
  apply auto
  apply (subst while_unfold)
  apply auto
  done

text \<open>If the state is final, it is the result of the interpretation.\<close>
lemma interp_term: "is_term (return cs) \<Longrightarrow> interp proc_table cs = return cs"
  apply (subst interp_unfold)
  by simp

subsection \<open>Correctness\<close>

context program_loc begin

text \<open>An execution of a state cs yields cs' if we can take steps from cs to cs' and cs' is
  a final state.\<close>
  definition "yields == \<lambda>cs cs'. return cs \<rightarrow>* cs' \<and> is_term cs'"
text \<open>An execution of a state cs terminates with cs' if it yields cs'.\<close>
  definition "terminates == \<lambda>cs. \<exists>cs'. yields cs cs'"

text \<open>The star operator preserves a None state. If we reach a None in our execution we will
  get stuck in a None state.\<close>
  lemma None_star_preserved[simp]:
    assumes "\<not>is_return m"
    shows "m \<rightarrow>* z \<longleftrightarrow> z=m"
  proof
    assume "m \<rightarrow>* z"
    thus "z=m"
    using assms
      apply (induction m z rule: star.induct)
      apply (auto elim!: small_step'.cases)
      done
  qed auto

text \<open>We prove that @{term small_step'} is deterministic.\<close>
  lemma small_step'_determ:
    assumes "s \<rightarrow>' s'"
    assumes "s \<rightarrow>' s''"
    shows "s'=s''"
    using assms(1)
    apply cases
    using assms(2)
    apply (cases)
    apply (auto simp: small_step_determ)
    done

text \<open>We want to prove our interpreter is correct, this is: given that the execution terminates
  the execution yields cs' if and only if cs' is the result of interpreting cs.\<close>
  theorem interp_correct:
    assumes TERM: "terminates cs"
    shows "(yields cs cs') \<longleftrightarrow> (cs' = interp proc_table cs)"
  proof safe
    assume "yields cs cs'"
    hence a: "return cs \<rightarrow>* cs'" and b: "is_term cs'" unfolding yields_def by auto
    thus "cs' = interp proc_table cs"
    proof (induction _ "return cs::_ ce" cs' arbitrary: cs rule: star.induct)
      case refl with interp_term show ?case by simp
    next
      case (step csh cs')
      from \<open>return cs \<rightarrow>'  csh\<close> have [simp]: "fstep proc_table cs = csh"
        apply (cases)
        apply (cases cs, cases csh)
        apply (auto intro: fstep1)
        done

      from \<open>return cs \<rightarrow>'  csh\<close> have [simp]: "\<not>is_term (return cs)"
        apply (cases "return cs::_ ce" rule: is_term.cases)
        by auto

      from \<open>return cs \<rightarrow>'  csh\<close> have [simp]: "\<not>is_empty_stack cs"
        apply (cases "return cs::_ ce" rule: is_term.cases)
        by auto

      show ?case
      proof (cases "is_return csh")
        case (True)[simp]
        then obtain cst where [simp]: "csh = return cst" by (cases csh) auto

        have "interp proc_table cs = interp proc_table cst"
          by (subst interp_unfold) simp
        thus ?thesis using step.hyps(3)[OF _ step.prems]
          by simp
      next
        case False with \<open>csh \<rightarrow>* cs'\<close> have [simp]: "cs'=csh" by simp
        show ?thesis using False
          apply (subst interp_unfold)
          apply (auto simp: pw_eq_iff)
          done
      qed
    qed
  next
    from TERM obtain cs' where
      1: "return cs \<rightarrow>* cs'" "is_term cs'"
      unfolding yields_def terminates_def by auto
    hence "cs'=interp proc_table cs"
    proof (induction "return cs::_ ce" _ arbitrary: cs rule: star.induct)
      case refl thus ?case by (simp add: interp_term)
    next
      case (step csh cs')

      from \<open>return cs \<rightarrow>'  csh\<close> have [simp]: "fstep proc_table cs = csh"
        apply (cases)
        apply (cases cs, cases csh)
        apply (auto intro: fstep1)
        done

      from \<open>return cs \<rightarrow>'  csh\<close> have [simp]: "\<not>is_term (return cs)"
        apply (cases "return cs::_ ce" rule: is_term.cases)
        by auto

      from \<open>return cs \<rightarrow>'  csh\<close> have [simp]: "\<not>is_empty_stack cs"
        apply (cases "return cs :: _ ce" rule: is_term.cases)
        by auto

      show ?case
      proof (cases "is_return csh")
        case False
        with \<open>csh \<rightarrow>* cs'\<close> have [simp]: "cs'=csh" by simp
        show ?thesis using False
          by (subst interp_unfold) (auto simp: pw_eq_iff)
      next
        case True then obtain cst where [simp]: "csh=return cst" by (cases csh) auto

        have "interp proc_table cs = interp proc_table cst"
          by (subst interp_unfold) simp
        thus ?thesis using step.hyps(3)[OF _ step.prems]
          by simp
      qed
    qed
    with 1 have "return cs \<rightarrow>* interp proc_table cs" "is_term (interp proc_table cs)" by simp_all
    thus "yields cs (interp proc_table cs)" by (auto simp: yields_def)
  qed

lemmas [code] = interp_unfold

export_code interp checking SML

end

subsection \<open>Execution of a program\<close>

text \<open>In order to execute a program we will assert that it's valid following the previously
  defined @{term valid_program} definition, and proceed to interpret the initial state of the
  program p.\<close>
definition execute :: "program \<hookrightarrow> state" where
  "execute p \<equiv> do {
    assert (program_loc.wt_prog p) (EChecker EWf);
    interp (proc_table_of p) (program_loc.initial_state p)
  }"

(*
  interpretation program_loc__!: program_loc p for p .
  interpretation stackframe__!: stackframe p fd for p fd .

  export_code execute checking SML
*)

end


theory Test_Harness
imports SmallStep Pretty "~~/src/HOL/ex/Cartouche_Examples"
begin

section \<open>Test Harness\<close>

  datatype test_instr =
    Discover string nat
  | Assert_Eq string int_val
  | Assert_Eq_Null string
  | Assert_Eq_Ptr string nat

  fun adjust_addr :: "int \<Rightarrow> string \<Rightarrow> string"
    -- \<open>Adjust address to beginning of its block\<close>
    where
    "adjust_addr ofs ca = shows_binop (shows ca) (''-'') (shows ofs) ''''"

  definition ofs_addr :: "int \<Rightarrow> string \<Rightarrow> string"
    where
    "ofs_addr ofs ca = (shows ''*'' o shows_paren (shows_binop (shows ca) (''+'') (shows ofs))) ''''"

  definition base_var_name :: "nat \<Rightarrow> string" where
    "base_var_name i \<equiv> ''__test_harness_x_'' @ show i"

  term fold

  term list_size
  thm fold.simps

  partial_function (option) fold_option :: "('a \<Rightarrow> 's \<rightharpoonup> 's) \<Rightarrow> 'a list \<Rightarrow> 's \<rightharpoonup> 's" where
    "fold_option f l s = (case l of
        [] \<Rightarrow> Some s
      | x#xs \<Rightarrow> do {
          s \<leftarrow> f x s;
          fold_option f xs s
        })"

  lemma fold_option_simps[code,simp]:
    "fold_option f [] s = Some s"
    "fold_option f (x#xs) s = do {
          s \<leftarrow> f x s;
          fold_option f xs s
        }"
    by (subst fold_option.simps; simp)+

  lemma fold_option_mono[partial_function_mono]:
  assumes [partial_function_mono]: "\<And>x \<sigma>. mono_option (\<lambda>fa. f fa x \<sigma>)"
  shows "mono_option (\<lambda>x. fold_option (f x) l \<sigma>)"
    apply (induction l arbitrary: \<sigma>)
    apply simp
    apply (tactic \<open>Partial_Function.mono_tac @{context} 1\<close>)
    apply simp
    apply (tactic \<open>Partial_Function.mono_tac @{context} 1\<close>)
    apply simp
    done

  context fixes \<mu> :: mem begin

  partial_function (option) dfs
    :: "nat set \<Rightarrow> addr \<Rightarrow> string \<Rightarrow> (nat set \<times> test_instr list) option"
    where
    [code]: "dfs D a ca = do {
      let (base,ofs) = a;

      case \<mu>!base of
        None \<Rightarrow> Some (D,[])
      | Some b \<Rightarrow> do {
          let ca = adjust_addr ofs ca;
          if base \<notin> D then do {
            let D = insert base D;
            let emit = [Discover ca base];

            fold_option (\<lambda>i (D,emit). do {
              let i=int i;
              let cval = (ofs_addr i (base_var_name base));
              case b!nat i of
                None \<Rightarrow> Some (D,emit)
              | Some (I v) \<Rightarrow> Some (D,emit @ [Assert_Eq cval v])
              | Some (NullVal) \<Rightarrow> Some (D,emit @ [Assert_Eq_Null cval] )
              | Some (A addr) \<Rightarrow> do {
                  (D,emit')\<leftarrow>dfs D addr cval;
                  Some (D,emit@emit')
                }
            })
              [0..<length b]
              (D,emit)

          } else do {
            Some (D,[Assert_Eq_Ptr ca base])
          }
        }
    }"

  end

  definition emit_globals_tests :: "vname list \<Rightarrow> state \<rightharpoonup> (nat set \<times> test_instr list)" where
    "emit_globals_tests \<equiv> \<lambda>vnames (\<sigma>,\<gamma>,\<mu>).
      fold_option (\<lambda>x (D,emit). do {
        case \<gamma> x of
          Some vo \<Rightarrow> do {
            let cai = x;
            case vo of
                None \<Rightarrow> Some (D,emit)
              | Some (I v) \<Rightarrow> Some (D,emit @ [Assert_Eq cai v])
              | Some (NullVal) \<Rightarrow> Some (D,emit @ [Assert_Eq_Null cai] )
              | Some (A addr) \<Rightarrow> do {
                  (D,emit')\<leftarrow>dfs \<mu> D addr cai;
                  Some (D,emit@emit')
                }
          }
        | _ \<Rightarrow> Some (D,emit)
      }
      ) vnames ({},[])"

  definition tests_variables :: "test_instr list \<Rightarrow> nat \<Rightarrow> shows" where
    "tests_variables l ind \<equiv> foldr (\<lambda>
      (Discover _ i) \<Rightarrow> indent_basic ind (shows dflt_type o shows '' *'' o shows (base_var_name i))
      | _ \<Rightarrow> id
      ) l"

  definition tests_instructions :: "test_instr list \<Rightarrow> nat \<Rightarrow> shows" where
    "tests_instructions l ind \<equiv> foldr (\<lambda>
        (Discover ca i) \<Rightarrow> indent_basic ind (shows ''__TEST_HARNESS_DISCOVER '' o shows_paren ( shows ca o shows '', '' o shows (base_var_name i)))
      | (Assert_Eq ca v) \<Rightarrow> indent_basic ind (shows ''__TEST_HARNESS_ASSERT_EQ '' o shows_paren ( shows ca o shows '', '' o shows v))
      | (Assert_Eq_Null ca) \<Rightarrow> indent_basic ind (shows ''__TEST_HARNESS_ASSERT_EQ_NULL '' o shows_paren ( shows ca ))
      | (Assert_Eq_Ptr ca i) \<Rightarrow> indent_basic ind (shows ''__TEST_HARNESS_ASSERT_EQ_PTR '' o shows_paren ( shows ca o shows '', '' o shows (base_var_name i)))
      ) l"

  definition init_discovered_shows :: "nat \<Rightarrow> shows" where
    "init_discovered_shows ind \<equiv> indent_basic ind (shows ''__test_harness_discovered = hashset_create()'')"

  definition failed_check_shows :: "string \<Rightarrow> nat \<Rightarrow> shows" where
    "failed_check_shows program_name ind \<equiv> indent ind (
      shows ''if (__test_harness_failed > 0)'' o shows_nl o
        (indent_basic (ind + 1) (
          shows \<open>printf(\"Failed %d test(s) in file \<close> o shows program_name o shows \<open>.c (passed %d)\\n\", __test_harness_failed, __test_harness_passed)\<close>
        )) o shows_nl o
      shows ''else'' o shows_nl o
      (indent_basic (ind + 1) (
          shows \<open>printf(\"Passed all %d test(s) in file \<close> o shows program_name o shows \<open>.c\\n\", __test_harness_passed)\<close>
        )) o shows_nl
    )"

    definition "init_disc \<equiv> init_discovered_shows 1 ''''"

    definition "failed_check p' \<equiv> failed_check_shows (program.name p') 1 ''''"

definition prepare_test_export :: "program \<Rightarrow> (string \<times> string) option"
where "prepare_test_export prog \<equiv> do {
  code \<leftarrow> prepare_export prog;
  s \<leftarrow> execute prog;
  let vnames = program.globals prog;
  (_,tests) \<leftarrow> emit_globals_tests vnames s;
  let vars = tests_variables tests 1 '''';
  let instrs = tests_instructions tests 1 '''';
  let failed_check = failed_check prog;
  let init_hash = init_disc;
  let nl = ''\<newline>'';
  let test_code = nl @ vars @ nl @ init_hash @ nl @ instrs @ nl @ failed_check @ nl @ ''}'';
  Some (code,test_code)
}"

ML \<open>
  fun generate_c_test_code (SOME (code,test_code)) rel_path name thy =
    let
      val code = code |> String.implode
      val test_code = test_code |> String.implode
    in
      if rel_path="" orelse name="" then
        (writeln (code ^ " <rem last line> " ^ test_code); thy)
      else let
        val base_path = Resources.master_directory thy
        val rel_path = Path.explode rel_path
        val name_path = Path.basic name |> Path.ext "c"

        val abs_path = Path.appends [base_path, rel_path, name_path]
        val abs_path = Path.implode abs_path

        val _ = writeln ("Writing to file " ^ abs_path)

        val os = TextIO.openOut abs_path;
        val _ = TextIO.output (os, code);
        val _ = TextIO.flushOut os;
        val _ = TextIO.closeOut os;

        val _ = Isabelle_System.bash ("sed -i '$d ' " ^ abs_path);

        val os = TextIO.openAppend abs_path;
        val _ = TextIO.output (os, test_code);
        val _ = TextIO.flushOut os;
        val _ = TextIO.closeOut os;
      in thy end
    end
  | generate_c_test_code NONE _ _ _ =
      error "Invalid program or failed execution"

  fun expect_failed_test (SOME _) = error "Expected Failed test"
    | expect_failed_test NONE = ()

\<close>

end


(* Preliminaries on the tag and guard encodings  *)
theory T_G_Prelim
imports Mcalc
begin

(* Copy of ProblemIk, together with a partitioning of the types.
O stands for the original---this copy shall be used
as ``the original problem: *)

locale ProblemIkTpart =
Ik? : ProblemIk wtFsym wtPsym arOf resOf parOf \<Phi> infTp
for wtFsym :: "'fsym \<Rightarrow> bool"
and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp +
fixes
    prot :: "'tp \<Rightarrow> bool" (* types aimed to be protected (with tags or guards) *)
and protFw :: "'tp \<Rightarrow> bool" (* types aimed to be protected in a featherweight fashion  *)
assumes
    tp_disj: "\<And> \<sigma>. \<not> prot \<sigma> \<or> \<not> protFw \<sigma>"
and tp_mcalc: "\<And> \<sigma>. prot \<sigma> \<or> protFw \<sigma> \<or> (\<forall> c \<in> \<Phi>. \<sigma> \<turnstile> c)"
begin

(* The notion of being a result type of some operation symbol: *)
definition isRes where "isRes \<sigma> \<equiv> \<exists> f. wtFsym f \<and> resOf f = \<sigma>"

(* Types meant to be left unprotected:
-- in the case of tags, terms of these type are not tagged;
-- in the case of guards, no guards are added for these types  *)
definition "unprot \<sigma> \<equiv> \<not> prot \<sigma> \<and> \<not> protFw \<sigma>"

lemma unprot_mcalc[simp]: "\<lbrakk>unprot \<sigma>; c \<in> \<Phi>\<rbrakk> \<Longrightarrow> \<sigma> \<turnstile> c "
using tp_mcalc unfolding unprot_def by auto

end (* context ProblemIkTpart *)

(* Problem with type partition and model: *)
locale ModelIkTpart =
Ik? : ProblemIkTpart wtFsym wtPsym arOf resOf parOf \<Phi> infTp prot protFw +
Ik? : Model wtFsym wtPsym arOf resOf parOf \<Phi> intT intF intP
for wtFsym :: "'fsym \<Rightarrow> bool"
and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp and prot and protFw
and intT and intF and intP

end


chapter \<open>Symbolic Primitives for Building Runs\<close>

theory SymbolicPrimitive
  imports Run

begin

text\<open>
  We define here the primitive constraints on runs, towards which we translate
  TESL specifications in the operational semantics.
  These constraints refer to a specific symbolic run and can therefore access
  properties of the run at particular instants (for instance, the fact that a clock
  ticks at instant @{term \<open>n\<close>} of the run, or the time on a given clock at
  that instant).

  In the previous chapters, we had no reference to particular instants of a run
  because the TESL language should be invariant by stuttering in order to allow
  the composition of specifications: adding an instant where no clock ticks to
  a run that satisfies a formula should yield another run that satisfies the
  same formula. However, when constructing runs that satisfy a formula, we
  need to be able to refer to the time or hamlet of a clock at a given instant.
\<close>

text\<open>
  Counter expressions are used to get the number of ticks of a clock up to
  (strictly or not) a given instant index.
\<close>
datatype cnt_expr =
  TickCountLess \<open>clock\<close> \<open>instant_index\<close> (\<open>#\<^sup><\<close>)
| TickCountLeq \<open>clock\<close> \<open>instant_index\<close>  (\<open>#\<^sup>\<le>\<close>)

subsection\<open> Symbolic Primitives for Runs \<close>

text\<open>
  Tag values are used to refer to the time on a clock at a given instant index.
\<close>
datatype tag_val =
  TSchematic \<open>clock * instant_index\<close> (\<open>\<tau>\<^sub>v\<^sub>a\<^sub>r\<close>)

datatype '\<tau> constr =
\<comment> \<open>@{term \<open>c \<Down> n @ \<tau>\<close>} constrains clock @{term \<open>c\<close>} to have time @{term \<open>\<tau>\<close>}
    at instant @{term \<open>n\<close>} of the run.\<close>
  Timestamp     \<open>clock\<close>   \<open>instant_index\<close> \<open>'\<tau> tag_const\<close>         (\<open>_ \<Down> _ @ _\<close>)
\<comment> \<open>@{term \<open>m @ n \<oplus> \<delta>t \<Rightarrow> s\<close>} constrains clock @{term \<open>s\<close>} to tick at the
    first instant at which the time on @{term \<open>m\<close>} has increased by @{term \<open>\<delta>t\<close>}
    from the value it had at instant @{term \<open>n\<close>} of the run.\<close>
| TimeDelay     \<open>clock\<close>   \<open>instant_index\<close> \<open>'\<tau> tag_const\<close> \<open>clock\<close> (\<open>_ @ _ \<oplus> _ \<Rightarrow> _\<close>)
\<comment> \<open>@{term \<open>c \<Up> n\<close>} constrains clock @{term \<open>c\<close>} to tick
    at instant @{term \<open>n\<close>} of the run.\<close>
| Ticks         \<open>clock\<close>   \<open>instant_index\<close>                        (\<open>_ \<Up> _\<close>)
\<comment> \<open>@{term \<open>c \<not>\<Up> n\<close>} constrains clock @{term \<open>c\<close>} not to tick
    at instant @{term \<open>n\<close>} of the run.\<close>
| NotTicks      \<open>clock\<close>   \<open>instant_index\<close>                        (\<open>_ \<not>\<Up> _\<close>)
\<comment> \<open>@{term \<open>c \<not>\<Up> < n\<close>} constrains clock @{term \<open>c\<close>} not to tick
    before instant @{term \<open>n\<close>} of the run.\<close>
| NotTicksUntil \<open>clock\<close>   \<open>instant_index\<close>                        (\<open>_ \<not>\<Up> < _\<close>)
\<comment> \<open>@{term \<open>c \<not>\<Up> \<ge> n\<close>} constrains clock @{term \<open>c\<close>} not to tick
    at and after instant @{term \<open>n\<close>} of the run.\<close>
| NotTicksFrom  \<open>clock\<close>   \<open>instant_index\<close>                        (\<open>_ \<not>\<Up> \<ge> _\<close>)
\<comment> \<open>@{term \<open>\<lfloor>\<tau>\<^sub>1, \<tau>\<^sub>2\<rfloor> \<in> R\<close>} constrains tag variables @{term \<open>\<tau>\<^sub>1\<close>} and  @{term \<open>\<tau>\<^sub>2\<close>}
    to be in relation @{term \<open>R\<close>}.\<close>
| TagArith      \<open>tag_val\<close> \<open>tag_val\<close> \<open>('\<tau> tag_const \<times> '\<tau> tag_const) \<Rightarrow> bool\<close> (\<open>\<lfloor>_, _\<rfloor> \<in> _\<close>)
\<comment> \<open>@{term \<open>\<lceil>k\<^sub>1, k\<^sub>2\<rceil> \<in> R\<close>} constrains counter expressions @{term \<open>k\<^sub>1\<close>} and  @{term \<open>k\<^sub>2\<close>}
    to be in relation @{term \<open>R\<close>}.\<close>
| TickCntArith  \<open>cnt_expr\<close> \<open>cnt_expr\<close> \<open>(nat \<times> nat) \<Rightarrow> bool\<close>      (\<open>\<lceil>_, _\<rceil> \<in> _\<close>)
\<comment> \<open>@{term \<open>k\<^sub>1 \<preceq> k\<^sub>2\<close>} constrains counter expression @{term \<open>k\<^sub>1\<close>} to be less or equal
    to counter expression @{term \<open>k\<^sub>2\<close>}.\<close>
| TickCntLeq    \<open>cnt_expr\<close> \<open>cnt_expr\<close>                            (\<open>_ \<preceq> _\<close>)

type_synonym '\<tau> system = \<open>'\<tau> constr list\<close>

text \<open>
  The abstract machine has configurations composed of:
  \<^item> the past @{term\<open>\<Gamma>\<close>}, which captures choices that have already be made as a
    list of symbolic primitive constraints on the run;
  \<^item> the current index @{term \<open>n\<close>}, which is the index of the present instant;
  \<^item> the present @{term\<open>\<Psi>\<close>}, which captures the formulae that must be satisfied
    in the current instant;
  \<^item> the future @{term\<open>\<Phi>\<close>}, which captures the constraints on the future of the run.
\<close>
type_synonym '\<tau> config =
                \<open>'\<tau> system * instant_index * '\<tau> TESL_formula * '\<tau> TESL_formula\<close>

section \<open>Semantics of Primitive Constraints \<close>

text\<open>
  The semantics of the primitive constraints is defined in a way similar to
  the semantics of TESL formulae.
\<close>
fun counter_expr_eval :: \<open>('\<tau>::linordered_field) run \<Rightarrow> cnt_expr \<Rightarrow> nat\<close>
  (\<open>\<lbrakk> _ \<turnstile> _ \<rbrakk>\<^sub>c\<^sub>n\<^sub>t\<^sub>e\<^sub>x\<^sub>p\<^sub>r\<close>)
where
  \<open>\<lbrakk> \<rho> \<turnstile> #\<^sup>< clk indx \<rbrakk>\<^sub>c\<^sub>n\<^sub>t\<^sub>e\<^sub>x\<^sub>p\<^sub>r = run_tick_count_strictly \<rho> clk indx\<close>
| \<open>\<lbrakk> \<rho> \<turnstile> #\<^sup>\<le> clk indx \<rbrakk>\<^sub>c\<^sub>n\<^sub>t\<^sub>e\<^sub>x\<^sub>p\<^sub>r = run_tick_count \<rho> clk indx\<close>

fun symbolic_run_interpretation_primitive
  ::\<open>('\<tau>::linordered_field) constr \<Rightarrow> '\<tau> run set\<close> (\<open>\<lbrakk> _ \<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>)
where
  \<open>\<lbrakk> K \<Up> n  \<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m     = {\<rho>. hamlet ((Rep_run \<rho>) n K) }\<close>
| \<open>\<lbrakk> K @ n\<^sub>0 \<oplus> \<delta>t \<Rightarrow> K' \<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m =
                  {\<rho>. \<forall>n \<ge> n\<^sub>0. first_time \<rho> K n (time ((Rep_run \<rho>) n\<^sub>0 K) + \<delta>t)
                               \<longrightarrow> hamlet ((Rep_run \<rho>) n K')}\<close>
| \<open>\<lbrakk> K \<not>\<Up> n \<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m     = {\<rho>. \<not>hamlet ((Rep_run \<rho>) n K) }\<close>
| \<open>\<lbrakk> K \<not>\<Up> < n \<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m   = {\<rho>. \<forall>i < n. \<not> hamlet ((Rep_run \<rho>) i K)}\<close>
| \<open>\<lbrakk> K \<not>\<Up> \<ge> n \<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m   = {\<rho>. \<forall>i \<ge> n. \<not> hamlet ((Rep_run \<rho>) i K) }\<close>
| \<open>\<lbrakk> K \<Down> n @ \<tau> \<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = {\<rho>. time ((Rep_run \<rho>) n K) = \<tau> }\<close>
| \<open>\<lbrakk> \<lfloor>\<tau>\<^sub>v\<^sub>a\<^sub>r(K\<^sub>1, n\<^sub>1), \<tau>\<^sub>v\<^sub>a\<^sub>r(K\<^sub>2, n\<^sub>2)\<rfloor> \<in> R \<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m =
    { \<rho>. R (time ((Rep_run \<rho>) n\<^sub>1 K\<^sub>1), time ((Rep_run \<rho>) n\<^sub>2 K\<^sub>2)) }\<close>
| \<open>\<lbrakk> \<lceil>e\<^sub>1, e\<^sub>2\<rceil> \<in> R \<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = { \<rho>. R (\<lbrakk> \<rho> \<turnstile> e\<^sub>1 \<rbrakk>\<^sub>c\<^sub>n\<^sub>t\<^sub>e\<^sub>x\<^sub>p\<^sub>r, \<lbrakk> \<rho> \<turnstile> e\<^sub>2 \<rbrakk>\<^sub>c\<^sub>n\<^sub>t\<^sub>e\<^sub>x\<^sub>p\<^sub>r) }\<close>
| \<open>\<lbrakk> cnt_e\<^sub>1 \<preceq> cnt_e\<^sub>2 \<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = { \<rho>. \<lbrakk> \<rho> \<turnstile> cnt_e\<^sub>1 \<rbrakk>\<^sub>c\<^sub>n\<^sub>t\<^sub>e\<^sub>x\<^sub>p\<^sub>r \<le> \<lbrakk> \<rho> \<turnstile> cnt_e\<^sub>2 \<rbrakk>\<^sub>c\<^sub>n\<^sub>t\<^sub>e\<^sub>x\<^sub>p\<^sub>r }\<close>

text\<open>
  The composition of primitive constraints is their conjunction, and we get the
  set of satisfying runs by intersection.
\<close>
fun symbolic_run_interpretation
  ::\<open>('\<tau>::linordered_field) constr list \<Rightarrow> ('\<tau>::linordered_field) run set\<close>
  (\<open>\<lbrakk>\<lbrakk> _ \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>)
where
  \<open>\<lbrakk>\<lbrakk> [] \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = {\<rho>. True }\<close>
| \<open>\<lbrakk>\<lbrakk> \<gamma> # \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk> \<gamma> \<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m \<inter> \<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>

lemma symbolic_run_interp_cons_morph:
  \<open>\<lbrakk> \<gamma> \<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m \<inter> \<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk>\<lbrakk> \<gamma> # \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
by auto

definition consistent_context :: \<open>('\<tau>::linordered_field) constr list \<Rightarrow> bool\<close>
where
  \<open>consistent_context \<Gamma> \<equiv> ( \<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m \<noteq> {}) \<close>

subsection \<open>Defining a method for witness construction\<close>

text\<open>
  In order to build a run, we can start from an initial run in which no clock
  ticks and the time is always 0 on any clock.
\<close>
abbreviation initial_run :: \<open>('\<tau>::linordered_field) run\<close> (\<open>\<rho>\<^sub>\<odot>\<close>) where
  \<open>\<rho>\<^sub>\<odot> \<equiv> Abs_run ((\<lambda>_ _. (False, \<tau>\<^sub>c\<^sub>s\<^sub>t 0)) ::nat \<Rightarrow> clock \<Rightarrow> (bool \<times> '\<tau> tag_const))\<close>

text\<open>
  To help avoiding that time flows backward, setting the time on a clock at a given
  instant sets it for the future instants too.
\<close>
fun time_update
  :: \<open>nat \<Rightarrow> clock \<Rightarrow> ('\<tau>::linordered_field) tag_const \<Rightarrow> (nat \<Rightarrow> '\<tau> instant)
      \<Rightarrow> (nat \<Rightarrow> '\<tau> instant)\<close>
where
  \<open>time_update n K \<tau> \<rho> = (\<lambda>n' K'. if K = K' \<and> n \<le> n'
                                  then (hamlet (\<rho> n K), \<tau>)
                                  else \<rho> n' K')\<close>

section \<open>Rules and properties of consistence\<close>

lemma context_consistency_preservationI:
  \<open>consistent_context ((\<gamma>::('\<tau>::linordered_field) constr)#\<Gamma>) \<Longrightarrow> consistent_context \<Gamma>\<close>
unfolding consistent_context_def by auto

\<comment> \<open>This is very restrictive\<close>
inductive context_independency
  ::\<open>('\<tau>::linordered_field) constr \<Rightarrow> '\<tau> constr list \<Rightarrow> bool\<close> (\<open>_ \<bowtie> _\<close>)
where
  NotTicks_independency:
  \<open>(K \<Up> n) \<notin> set \<Gamma> \<Longrightarrow> (K \<not>\<Up> n) \<bowtie> \<Gamma>\<close>
| Ticks_independency:
  \<open>(K \<not>\<Up> n) \<notin> set \<Gamma> \<Longrightarrow> (K \<Up> n) \<bowtie> \<Gamma>\<close>
| Timestamp_independency:
  \<open>(\<nexists>\<tau>'. \<tau>' = \<tau> \<and> (K \<Down> n @ \<tau>) \<in> set \<Gamma>) \<Longrightarrow> (K \<Down> n @ \<tau>) \<bowtie> \<Gamma>\<close>

section\<open>Major Theorems\<close>
subsection \<open>Interpretation of a context\<close>

text\<open>
  The interpretation of a context is the intersection of the interpretation
  of its components.
\<close>
theorem symrun_interp_fixpoint:
  \<open>\<Inter> ((\<lambda>\<gamma>. \<lbrakk> \<gamma> \<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m) ` set \<Gamma>) = \<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
by (induction \<Gamma>, simp+)

subsection \<open>Expansion law\<close>
text \<open>Similar to the expansion laws of lattices\<close>

theorem symrun_interp_expansion:
  \<open>\<lbrakk>\<lbrakk> \<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk>\<lbrakk> \<Gamma>\<^sub>1 \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m \<inter> \<lbrakk>\<lbrakk> \<Gamma>\<^sub>2 \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
by (induction \<Gamma>\<^sub>1, simp, auto)

section \<open>Equations for the interpretation of symbolic primitives\<close>
subsection \<open>General laws\<close>

lemma symrun_interp_assoc:
  \<open>\<lbrakk>\<lbrakk> (\<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2) @ \<Gamma>\<^sub>3 \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk>\<lbrakk> \<Gamma>\<^sub>1 @ (\<Gamma>\<^sub>2 @ \<Gamma>\<^sub>3) \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
by auto

lemma symrun_interp_commute:
  \<open>\<lbrakk>\<lbrakk> \<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk>\<lbrakk> \<Gamma>\<^sub>2 @ \<Gamma>\<^sub>1 \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
by (simp add: symrun_interp_expansion inf_sup_aci(1))

lemma symrun_interp_left_commute:
  \<open>\<lbrakk>\<lbrakk> \<Gamma>\<^sub>1 @ (\<Gamma>\<^sub>2 @ \<Gamma>\<^sub>3) \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk>\<lbrakk> \<Gamma>\<^sub>2 @ (\<Gamma>\<^sub>1 @ \<Gamma>\<^sub>3) \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
unfolding symrun_interp_expansion by auto

lemma symrun_interp_idem:
  \<open>\<lbrakk>\<lbrakk> \<Gamma> @ \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
using symrun_interp_expansion by auto

lemma symrun_interp_left_idem:
  \<open>\<lbrakk>\<lbrakk> \<Gamma>\<^sub>1 @ (\<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2) \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk>\<lbrakk> \<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
using symrun_interp_expansion by auto

lemma symrun_interp_right_idem:
  \<open>\<lbrakk>\<lbrakk> (\<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2) @ \<Gamma>\<^sub>2 \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk>\<lbrakk> \<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
unfolding symrun_interp_expansion by auto

lemmas symrun_interp_aci =  symrun_interp_commute
                            symrun_interp_assoc
                            symrun_interp_left_commute
                            symrun_interp_left_idem

\<comment> \<open>Identity element\<close>
lemma symrun_interp_neutral1:
  \<open>\<lbrakk>\<lbrakk> [] @ \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
by simp

lemma symrun_interp_neutral2:
  \<open>\<lbrakk>\<lbrakk> \<Gamma> @ [] \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
by simp

subsection \<open>Decreasing interpretation of symbolic primitives\<close>

text\<open>
  Adding constraints to a context reduces the number of satisfying runs.
\<close>
lemma TESL_sem_decreases_head:
  \<open>\<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m \<supseteq> \<lbrakk>\<lbrakk> \<gamma> # \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
by simp

lemma TESL_sem_decreases_tail:
  \<open>\<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m \<supseteq> \<lbrakk>\<lbrakk> \<Gamma> @ [\<gamma>] \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
by (simp add: symrun_interp_expansion)

text\<open>
  Adding a constraint that is already in the context does not change the
  interpretation of the context.
\<close>
lemma symrun_interp_formula_stuttering:
  assumes \<open>\<gamma> \<in> set \<Gamma>\<close>
    shows \<open>\<lbrakk>\<lbrakk> \<gamma> # \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
proof -
  have \<open>\<gamma> # \<Gamma> = [\<gamma>] @ \<Gamma>\<close> by simp
  hence \<open>\<lbrakk>\<lbrakk> \<gamma> # \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk>\<lbrakk> [\<gamma>] \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m \<inter> \<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
    using symrun_interp_expansion by simp
  thus ?thesis using assms symrun_interp_fixpoint by fastforce
qed

text\<open>
  Removing duplicate constraints from a context does not change the
  interpretation of the context.
\<close>
lemma symrun_interp_remdups_absorb:
  \<open>\<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk>\<lbrakk> remdups \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
proof (induction \<Gamma>)
  case Cons
    thus ?case using symrun_interp_formula_stuttering by auto
qed simp

text\<open>
  Two identical sets of constraints have the same interpretation,
  the order in the context does not matter.
\<close>
lemma symrun_interp_set_lifting:
  assumes \<open>set \<Gamma> = set \<Gamma>'\<close>
    shows \<open>\<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk>\<lbrakk> \<Gamma>' \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
proof -
  have \<open>set (remdups \<Gamma>) = set (remdups \<Gamma>')\<close>
    by (simp add: assms)
  moreover have fxpnt\<Gamma>: \<open>\<Inter> ((\<lambda>\<gamma>. \<lbrakk> \<gamma> \<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m) ` set \<Gamma>) = \<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
    by (simp add: symrun_interp_fixpoint)
  moreover have fxpnt\<Gamma>': \<open>\<Inter> ((\<lambda>\<gamma>. \<lbrakk> \<gamma> \<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m) ` set \<Gamma>') = \<lbrakk>\<lbrakk> \<Gamma>' \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
    by (simp add: symrun_interp_fixpoint)
  moreover have \<open>\<Inter> ((\<lambda>\<gamma>. \<lbrakk> \<gamma> \<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m) ` set \<Gamma>) = \<Inter> ((\<lambda>\<gamma>. \<lbrakk> \<gamma> \<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m) ` set \<Gamma>')\<close>
    by (simp add: assms)
  ultimately show ?thesis using symrun_interp_remdups_absorb by auto
qed

text\<open>
  The interpretation of contexts is contravariant with regard to set inclusion.
\<close>
theorem symrun_interp_decreases_setinc:
  assumes \<open>set \<Gamma> \<subseteq> set \<Gamma>'\<close>
    shows \<open>\<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m \<supseteq> \<lbrakk>\<lbrakk> \<Gamma>' \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
proof -
  obtain \<Gamma>\<^sub>r where decompose: \<open>set (\<Gamma> @ \<Gamma>\<^sub>r) = set \<Gamma>'\<close> using assms by auto
  hence \<open>set (\<Gamma> @ \<Gamma>\<^sub>r) = set \<Gamma>'\<close> using assms by blast
  moreover have \<open>(set \<Gamma>) \<union> (set \<Gamma>\<^sub>r) = set \<Gamma>'\<close> using assms decompose by auto
  moreover have \<open>\<lbrakk>\<lbrakk> \<Gamma>' \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk>\<lbrakk> \<Gamma> @ \<Gamma>\<^sub>r \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
    using symrun_interp_set_lifting decompose by blast
  moreover have \<open>\<lbrakk>\<lbrakk> \<Gamma> @ \<Gamma>\<^sub>r \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m \<inter> \<lbrakk>\<lbrakk> \<Gamma>\<^sub>r \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
    by (simp add: symrun_interp_expansion)
  moreover have \<open>\<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m \<supseteq> \<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m \<inter> \<lbrakk>\<lbrakk> \<Gamma>\<^sub>r \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close> by simp
  ultimately show ?thesis by simp
qed

lemma symrun_interp_decreases_add_head:
  assumes \<open>set \<Gamma> \<subseteq> set \<Gamma>'\<close>
    shows \<open>\<lbrakk>\<lbrakk> \<gamma> # \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m \<supseteq> \<lbrakk>\<lbrakk> \<gamma> # \<Gamma>' \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
using symrun_interp_decreases_setinc assms by auto

lemma symrun_interp_decreases_add_tail:
  assumes \<open>set \<Gamma> \<subseteq> set \<Gamma>'\<close>
    shows \<open>\<lbrakk>\<lbrakk> \<Gamma> @ [\<gamma>] \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m \<supseteq> \<lbrakk>\<lbrakk> \<Gamma>' @ [\<gamma>] \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
proof -
  from symrun_interp_decreases_setinc[OF assms] have \<open>\<lbrakk>\<lbrakk> \<Gamma>' \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m \<subseteq> \<lbrakk>\<lbrakk> \<Gamma> \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close> .
  thus ?thesis by (simp add: symrun_interp_expansion dual_order.trans)
qed

lemma symrun_interp_absorb1:
  assumes \<open>set \<Gamma>\<^sub>1 \<subseteq> set \<Gamma>\<^sub>2\<close>
    shows \<open>\<lbrakk>\<lbrakk> \<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk>\<lbrakk> \<Gamma>\<^sub>2 \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
by (simp add: Int_absorb1 symrun_interp_decreases_setinc
                          symrun_interp_expansion assms)

lemma symrun_interp_absorb2:
  assumes \<open>set \<Gamma>\<^sub>2 \<subseteq> set \<Gamma>\<^sub>1\<close>
    shows \<open>\<lbrakk>\<lbrakk> \<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m = \<lbrakk>\<lbrakk> \<Gamma>\<^sub>1 \<rbrakk>\<rbrakk>\<^sub>p\<^sub>r\<^sub>i\<^sub>m\<close>
using symrun_interp_absorb1 symrun_interp_commute assms by blast

end


theory PartialityTest_PartMinus_E1
imports "$HETS_ISABELLE_LIB/MainHC" "$HETS_LIB/Isabelle/RestrictOpProps"
uses "$HETS_ISABELLE_LIB/prelude"
begin

ML "Header.initialize
    [\"ga_select_pre\", \"Ax3\", \"Ax4\", \"Ax5\", \"Ax6\", \"Ax1\",
     \"Ax2\", \"Ax3_10\", \"Ax4_7\", \"Ax5_9\", \"Ax6_8\", \"Ax7\",
     \"Ax8\", \"Ax9\"]"

consts
X__XMinusXQuest__X :: "nat => nat => nat partial" ("(_/ -?/ _)" [54,54] 52)
X_pre :: "nat => nat partial" ("pre/'(_')" [3] 999)

axioms
ga_select_pre [rule_format] :
"ALL (x_1 :: nat). pre(Suc(x_1)) = makePartial x_1"

Ax3 [rule_format] : "0 -? 0 = makePartial 0"

(* Might be easier with a recursive definition *)

Ax3 [rule_format] :
"ALL (a :: X_Nat). ALL (b :: X_Nat). a +' b = b +' a"

Ax4 [rule_format] :
"ALL (x :: nat). Suc(x) -? 0 = makePartial (Suc(x))"

Ax5 [rule_format] : "ALL (x :: nat). ~ defOp (0 -? Suc(x))"

Ax6 [rule_format] :
"ALL (x :: nat). ALL (y :: nat). Suc(x) -? Suc(y) = x -? y"

declare ga_select_pre [simp]
declare Ax3 [simp]
declare Ax4 [simp]
declare Ax5 [simp]
declare Ax6 [simp]

theorem Ax1 :
"ALL (a :: nat).
 ALL (b :: nat).
 ALL (c :: nat).
 defOp
 (restrictOp (a -? makeTotal (b -? makeTotal (c -? a)))
  (defOp (b -? makeTotal (c -? a)) & defOp (c -? a))) -->
 defOp (c -? a)"
by (auto)

ML "Header.record \"Ax1\""

theorem Ax2 :
"ALL (a :: nat).
 ALL (b :: nat).
 ALL (c :: nat).
 defOp
 (restrictOp (a -? makeTotal (b -? makeTotal (c -? a)))
  (defOp (b -? makeTotal (c -? a)) & defOp (c -? a))) -->
 defOp (restrictOp (b -? makeTotal (c -? a)) (defOp (c -? a)))"
by (auto)
ML "Header.record \"Ax2\""

theorem Ax3_10 :
"ALL (a :: nat).
 ALL (b :: nat).
 ALL (c :: nat).
 defOp (restrictOp (a -? makeTotal (b -? c)) (defOp (b -? c))) -->
 defOp (b -? c)"
by (auto)

ML "Header.record \"Ax3_10\""

theorem Ax4_7 : "ALL (a :: nat). a -? a = makePartial 0"
apply (rule allI)
apply (induct_tac a)
by (auto)

ML "Header.record \"Ax4_7\""

lemma sucneutr [simp]: "(a -? 0) = makePartial a"
apply (induct_tac a)
apply (simp)
apply (simp)
done

lemma partminusundef [simp]: "~(defOp(a-?Suc(a)))"
apply (induct_tac a)
apply (simp)
apply (simp)
done

lemma test2 [simp]: "((z+a)-?a)=makePartial z"
apply (induct_tac a)
apply (auto)
done

lemma test4 [rule_format]:  "(!n.(defOp(a-? Suc(n)) --> (defOp(a -? n)))) & (!n.(defOp(a-?n) --> defOp(Suc(a)-?n)))"
apply (induct_tac a)
apply (simp)
apply (rule allI)
apply (case_tac n)
apply (simp)
apply (simp)
apply (induct_tac n)
apply (rule conjI, rule allI)
apply (simp)
apply (case_tac na)
apply (simp)
apply (simp)
apply (rule allI)
apply (case_tac na)
apply (simp)
apply (simp)
apply (case_tac nat)
apply (simp)
apply (simp)
apply (simp)
apply (rule allI)
apply (case_tac nb)
apply (simp)
apply (simp)
done

lemma test3: "defOp(a-?b) = (a>=b)"
apply (induct_tac b)
apply (simp)
apply (case_tac "n>a")
apply (simp add: test4)

apply (simp)
apply (case_tac "defOp(a -? Suc(n))")
apply (subst (asm) test4)
apply (simp)
apply (case_tac "n=a")
apply (simp)
apply (simp)
apply (case_tac "n=a")
apply (simp)
apply (simp)

theorem Ax5_9 :
"ALL (a :: nat).
 ALL (b :: nat).
 ALL (c :: nat).
 defOp (a -? b) -->
 restrictOp (makePartial (c + makeTotal (a -? b)))
 (defOp (a -? b)) =
 (c + a) -? b"

apply (rule allI)+
apply (simp)
apply (induct_tac b)
apply (simp add: sucneutr)
apply (induct_tac a)
apply (simp)
apply (simp)
apply (auto)

by (auto)

ML "Header.record \"Ax5_9\""

theorem Ax6_8 :
"ALL (a :: nat).
 ALL (b :: nat).
 ALL (c :: nat).
 defOp (a -? b) & defOp (b -? c) -->
 restrictOp (makePartial (makeTotal (a -? b) +' makeTotal (b -? c)))
 (defOp (a -? b) & defOp (b -? c)) =
 a -? c"
by (auto)

ML "Header.record \"Ax6_8\""

theorem Ax7 :
"ALL (a :: nat).
 ALL (b :: nat).
 ALL (c :: nat).
 defOp (restrictOp (a -? makeTotal (b -? c)) (defOp (b -? c))) -->
 restrictOp (a -? makeTotal (b -? c)) (defOp (b -? c)) =
 (a +' c) -? b"
by (auto)

ML "Header.record \"Ax7\""

theorem Ax8 :
"ALL (a :: nat).
 ALL (b :: nat).
 ALL (c :: nat).
 defOp
 (restrictOp (a -? makeTotal (b -? makeTotal (c -? a)))
  (defOp (b -? makeTotal (c -? a)) & defOp (c -? a))) -->
 defOp (c -? b)"
by (auto)

ML "Header.record \"Ax8\""

theorem Ax9 :
"ALL (a :: nat).
 ALL (b :: nat).
 ALL (c :: nat).
 defOp
 (restrictOp (a -? makeTotal (b -? makeTotal (c -? a)))
  (defOp (b -? makeTotal (c -? a)) & defOp (c -? a))) -->
 restrictOp (a -? makeTotal (b -? makeTotal (c -? a)))
 (defOp (b -? makeTotal (c -? a)) & defOp (c -? a)) =
 c -? b"
by (auto)

ML "Header.record \"Ax9\""

end