header {* Stream Iterators *}

theory Stream
imports LazyList
begin

subsection {* Type definitions for streams *}

text {* Note that everything is strict in the state type. *}

domain ('a,'s) Step = Done | Skip 's | Yield (lazy 'a) 's

type_synonym ('a, 's) Stepper = "'s \<rightarrow> ('a, 's) Step"

domain ('a,'s) Stream = Stream (lazy "('a, 's) Stepper") 's

subsection {* Converting from streams to lists *}

fixrec
  unfold :: "('a, 's) Stepper -> ('s -> 'a LList)"
where
  "unfold\<cdot>h\<cdot>\<bottom> = \<bottom>"
| "s \<noteq> \<bottom> \<Longrightarrow>
    unfold\<cdot>h\<cdot>s =
      (case h\<cdot>s of
        Done \<Rightarrow> LNil
      | Skip\<cdot>s' \<Rightarrow> unfold\<cdot>h\<cdot>s'
      | Yield\<cdot>x\<cdot>s' \<Rightarrow> LCons\<cdot>x\<cdot>(unfold\<cdot>h\<cdot>s'))"

fixrec
  unfoldF :: "('a, 's) Stepper \<rightarrow> ('s \<rightarrow> 'a LList) \<rightarrow> ('s \<rightarrow> 'a LList)"
where
  "unfoldF\<cdot>h\<cdot>u\<cdot>\<bottom> = \<bottom>"
| "s \<noteq> \<bottom> \<Longrightarrow>
    unfoldF\<cdot>h\<cdot>u\<cdot>s =
      (case h\<cdot>s of
        Done \<Rightarrow> LNil
      | Skip\<cdot>s' \<Rightarrow> u\<cdot>s'
      | Yield\<cdot>x\<cdot>s' \<Rightarrow> LCons\<cdot>x\<cdot>(u\<cdot>s'))"

lemma unfold_eq_fix: "unfold\<cdot>h = fix\<cdot>(unfoldF\<cdot>h)"
proof (rule below_antisym)
  show "unfold\<cdot>h \<sqsubseteq> fix\<cdot>(unfoldF\<cdot>h)"
    apply (rule unfold.induct, simp, simp)
    apply (subst fix_eq)
    apply (rule cfun_belowI, rename_tac s)
    apply (case_tac "s = \<bottom>", simp, simp)
    apply (intro monofun_cfun monofun_LAM below_refl, simp_all)
    done
  show "fix\<cdot>(unfoldF\<cdot>h) \<sqsubseteq> unfold\<cdot>h"
    apply (rule fix_ind, simp, simp)
    apply (subst unfold.unfold)
    apply (rule cfun_belowI, rename_tac s)
    apply (case_tac "s = \<bottom>", simp, simp)
    apply (intro monofun_cfun monofun_LAM below_refl, simp_all)
    done
qed

lemma unfold_ind:
    fixes P :: "('s \<rightarrow> 'a LList) \<Rightarrow> bool"
    assumes "adm P" and "P \<bottom>" and "\<And>u. P u \<Longrightarrow> P (unfoldF\<cdot>h\<cdot>u)"
    shows "P (unfold\<cdot>h)"
unfolding unfold_eq_fix by (rule fix_ind [of P, OF assms])

fixrec
  unfold2 :: "('s \<rightarrow> 'a LList) \<rightarrow> ('a, 's) Step \<rightarrow> 'a LList"
where
  "unfold2\<cdot>u\<cdot>Done = LNil"
| "s \<noteq> \<bottom> \<Longrightarrow> unfold2\<cdot>u\<cdot>(Skip\<cdot>s) = u\<cdot>s"
| "s \<noteq> \<bottom> \<Longrightarrow> unfold2\<cdot>u\<cdot>(Yield\<cdot>x\<cdot>s) = LCons\<cdot>x\<cdot>(u\<cdot>s)"

lemma unfold2_strict [simp]: "unfold2\<cdot>u\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma unfold: "s \<noteq> \<bottom> \<Longrightarrow> unfold\<cdot>h\<cdot>s = unfold2\<cdot>(unfold\<cdot>h)\<cdot>(h\<cdot>s)"
by (case_tac "h\<cdot>s", simp_all)

lemma unfoldF: "s \<noteq> \<bottom> \<Longrightarrow> unfoldF\<cdot>h\<cdot>u\<cdot>s = unfold2\<cdot>u\<cdot>(h\<cdot>s)"
by (case_tac "h\<cdot>s", simp_all)

declare unfold.simps(2) [simp del]
declare unfoldF.simps(2) [simp del]
declare unfoldF [simp]

fixrec
  unstream :: "('a, 's) Stream \<rightarrow> 'a LList"
where
  "s \<noteq> \<bottom> \<Longrightarrow> unstream\<cdot>(Stream\<cdot>h\<cdot>s) = unfold\<cdot>h\<cdot>s"

lemma unstream_strict [simp]: "unstream\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

subsection {* Converting from lists to streams *}

fixrec
  streamStep :: "('a LList)\<^sub>\<bottom> \<rightarrow> ('a, ('a LList)\<^sub>\<bottom>) Step"
where
  "streamStep\<cdot>(up\<cdot>LNil) = Done"
| "streamStep\<cdot>(up\<cdot>(LCons\<cdot>x\<cdot>xs)) = Yield\<cdot>x\<cdot>(up\<cdot>xs)"

lemma streamStep_strict [simp]: "streamStep\<cdot>(up\<cdot>\<bottom>) = \<bottom>"
by fixrec_simp

fixrec
  stream :: "'a LList \<rightarrow> ('a, ('a LList)\<^sub>\<bottom>) Stream"
where
  "stream\<cdot>xs = Stream\<cdot>streamStep\<cdot>(up\<cdot>xs)"

lemma stream_defined [simp]: "stream\<cdot>xs \<noteq> \<bottom>"
  by simp

lemma unstream_stream [simp]:
  fixes xs :: "'a LList"
  shows "unstream\<cdot>(stream\<cdot>xs) = xs"
by (induct xs, simp_all add: unfold)

declare stream.simps [simp del]

subsection {* Bisimilarity relation on streams *}

definition
  bisimilar :: "('a, 's) Stream \<Rightarrow> ('a, 't) Stream \<Rightarrow> bool" (infix "\<approx>" 50)
where
  "a \<approx> b \<longleftrightarrow> unstream\<cdot>a = unstream\<cdot>b \<and> a \<noteq> \<bottom> \<and> b \<noteq> \<bottom>"

lemma unstream_cong:
  "a \<approx> b \<Longrightarrow> unstream\<cdot>a = unstream\<cdot>b"
    unfolding bisimilar_def by simp

lemma stream_unstream_cong:
  "a \<approx> b \<Longrightarrow> stream\<cdot>(unstream\<cdot>a) \<approx> b"
    unfolding bisimilar_def by simp

end


theory cube imports newparaGste1
begin

abbreviation c::"varType" where
"c \<equiv>  (Ident ''c'')"

abbreviation n::"varType" where
"n \<equiv>  (Ident ''n'')"

abbreviation k::"varType" where
"k \<equiv>  (Ident ''k'')"

abbreviation m::"varType" where
"m \<equiv>  (Ident ''m'')"

definition leRule::"nat \<Rightarrow> rule" where [simp]:
"leRule N\<equiv>
let g = uip ''<'' [IVar n, Const (index N)]  in
let s = parallel [(c, uif ''+'' [IVar c,IVar k]),
                  (k, uif ''+'' [IVar k,IVar m]),
                  (m, uif ''+'' [IVar m,Const (index 6)]),
                  (n, uif ''+'' [IVar n,Const (index 1)])]  in
guard g s"

consts J::" interpretFunType"

axiomatization where axiomOnIAdd [simp,intro]:
"  J  ''+'' [index a,   index b] = index (a + b)"

axiomatization where axiomOnIMultiply [simp,intro]:
"  J  ''*'' [index a,   index b] = index (a * b)"

axiomatization where axiomOnLe [simp,intro]:
"  J   ''leq'' [index a, index b]  = boolV (a \<le> b)"

axiomatization where axiomOnLess [simp,intro]:
"  J   ''<'' [index a, index b]  = boolV (a < b)"

axiomatization where onVarn [simp,intro]:
"  \<exists> a. s n= (index a)"

axiomatization where onVarc [simp,intro]:
"  \<exists> a. s c= (index a)"

axiomatization where onVark [simp,intro]:
"  \<exists> a. s k= (index a)"

axiomatization where onVarm [simp,intro]:
"  \<exists> a. s m= (index a)"

subsection{*Definitions of initial states*}
definition initSpec0::" formula" where [simp]:
"initSpec0  \<equiv>
andForm (eqn (IVar m) (Const (index 6)))
(andForm (eqn (IVar k) (Const (index 1)))
(andForm (eqn (IVar c) (Const (index 0)))
(eqn (IVar n) (Const (index 0)))))"

definition inv1::"formula" where [simp]:
"inv1 \<equiv>eqn ( IVar c) (uif ''*'' [(uif ''*'' [IVar n, IVar n]), IVar n])"

definition inv2::"formula" where [simp]:
"inv2\<equiv> eqn ( IVar k)
      (uif ''+''
      [(uif ''+'' [(uif ''*'' [(uif ''*'' [IVar n, IVar n]), Const (index 3)]),
                   (uif ''*'' [IVar n,  Const (index 3)])]),
      Const (index 1)])"

definition inv3::"formula" where [simp]:
"inv3 \<equiv> eqn (IVar m) (uif ''+'' [(uif ''*'' [IVar n,Const (index 6)]),Const (index 6)])"

definition inv4::"nat \<Rightarrow> formula" where [simp]:
"inv4 N \<equiv> uip ''leq'' [IVar n, Const (index N)]"

definition invariants::"nat \<Rightarrow>formula set" where [simp]:
"invariants N \<equiv> {inv1, inv2, inv3,inv4 N}"

lemma lemmaOnInv4:

shows "invHoldForRule' J s (inv4 N) (leRule N) (invariants N)"  (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -

  have "\<exists> a. s n=(index a)"  by simp
    then obtain a where a1:"s n= index a" by blast
  from a1 have "?P1 s"
    by auto
  then show ?thesis by auto
qed

lemma lemmaOnInv3:

shows "invHoldForRule' J s (inv3 ) (leRule N) (invariants N)"   (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -

  have "\<exists> a. s n=(index a)"  by simp
  then obtain a where a1:"s n= index a" by blast

  have "\<exists> a. s m=(index a)"  by simp
  then obtain a' where a2:"s m= index a'" by blast

  from a1 a2 have "?P2 s"
    by auto

  then  show ?thesis  by auto

qed

lemma lemmaOnInv2:

shows "invHoldForRule' J s (inv2 ) (leRule N) (invariants N)"   (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -

  have "\<exists> a. s n=(index a)"  by simp
  then obtain a where a1:"s n= index a" by blast

  have "\<exists> a. s k=(index a)"  by simp
  then obtain a' where a2:"s k= index a'" by blast

  from a1 a2   have "?P3 s  "
  proof(unfold invHoldForRule4_def,rule_tac x="{inv2,inv3}" in exI,auto )qed

  then show ?thesis by blast

qed

lemma lemmaOnInv1:

shows "invHoldForRule' J s (inv1 ) (leRule N) (invariants N)"   (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -

  have "\<exists> a. s n=(index a)"  by simp
  then obtain a where a1:"s n= index a" by blast

  have "\<exists> a. s c=(index a)"  by simp
  then obtain a' where a2:"s c= index a'" by blast

  have "\<exists> a. s k=(index a)"  by simp
  then obtain a0 where a3:"s k= index a0" by blast

  have a4:"2 *(a*a) + a*a*a=(a+(a+a*a))*a"
    by (simp add: comm_semiring_class.distrib)

  from a1 a2 a3 a4  have "?P3 s"
  proof(unfold invHoldForRule4_def,rule_tac x="{inv1,inv2}" in exI,simp)qed

  then   show ?thesis  by blast
qed

lemma invs_on_rules:
  assumes a1: "f \<in> invariants N" and a2: "r \<in> {leRule N} "
  shows "invHoldForRule'  J s f r (invariants N)"
proof -

  have b1: "r=leRule N"
    apply (cut_tac a2, auto) done
  have "f=inv1 | f=inv2 |f=inv3 |f =inv4 N"
    using a1 by auto
    moreover {
      assume c1: "f=inv1"
      have "invHoldForRule'  J s f r (invariants N )"
        using b1 c1 lemmaOnInv1 by blast
    }

  moreover {
      assume c1: "f=inv2"
      have "invHoldForRule'  J s f r (invariants N)"
        using b1 c1 lemmaOnInv2 by blast
    }
  moreover {
      assume c1: "f=inv3"
      have "invHoldForRule'  J s f r (invariants N)"
        using b1 c1 lemmaOnInv3 by blast
    }

  moreover {
      assume c1: "f=inv4 N"
      have "invHoldForRule'  J s f r (invariants N)"
        using b1 c1 lemmaOnInv4 by blast
    }
    ultimately show ?thesis by blast
qed

lemma iniImply_inv:
assumes a1:"f \<in> invariants N" and a2: "formEval J (initSpec0) s"
shows "formEval J f s "
using a1 a2 by auto

lemma consistentCube:
  shows " consistent'  J (invariants N) {initSpec0} {leRule N}"
proof(unfold  consistent'_def,rule conjI)
  show "\<forall>inv ini s. inv \<in> invariants N \<longrightarrow> ini \<in> {initSpec0} \<longrightarrow> formEval J ini s \<longrightarrow> formEval J inv s"
    using iniImply_inv by blast
next
  show "\<forall>inv r s. inv \<in> invariants N \<longrightarrow> r \<in> {leRule N} \<longrightarrow> invHoldForRule' J s inv r (invariants N)"

  by (smt consistent'_def iniImply_inv invs_on_rules singletonD)
qed

lemma cubeInv:
  assumes  a2:"s \<in> reachableSet J {initSpec0}  {leRule N}"
  shows "\<forall> inv. inv \<in> invariants N\<longrightarrow>formEval J inv s"  (is "?P s")
  using assms consistentCube consistentLemma' by blast

end


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

datatype Nat = Z | S "Nat"

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

theorem property0 :
  "((add3acc x y z) = (add3acc z y x))"
  oops

end


(*
Title: Strong-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel, Jens Sauer
*)
theory Strong_Security
imports Types
begin

locale Strong_Security =
fixes SR :: "('exp, 'id, 'val, 'com) TSteps"
and DA :: "('id, 'd::order) DomainAssignment"

begin

\<comment> \<open>define when two states are indistinguishable for an observer on domain d\<close>
definition d_equal :: "'d::order \<Rightarrow> ('id, 'val) State
  \<Rightarrow> ('id, 'val) State \<Rightarrow> bool"
where
"d_equal d m m' \<equiv> \<forall>x. ((DA x) \<le> d \<longrightarrow> (m x) = (m' x))"

abbreviation d_equal' :: "('id, 'val) State
  \<Rightarrow> 'd::order \<Rightarrow> ('id, 'val) State \<Rightarrow> bool"
( "(_ =\<^bsub>_\<^esub> _)" )
where
"m =\<^bsub>d\<^esub> m' \<equiv> d_equal d m m'"

\<comment> \<open>transitivity of d-equality\<close>
lemma d_equal_trans:
"\<lbrakk> m =\<^bsub>d\<^esub> m'; m' =\<^bsub>d\<^esub> m'' \<rbrakk> \<Longrightarrow> m =\<^bsub>d\<^esub> m''"
by (simp add: d_equal_def)

abbreviation SRabbr :: "('exp, 'id, 'val, 'com) TSteps_curry"
("(1\<langle>_,/_\<rangle>) \<rightarrow>/ (1\<langle>_,/_\<rangle>)" [0,0,0,0] 81)
where
"\<langle>c,m\<rangle> \<rightarrow> \<langle>c',m'\<rangle> \<equiv> ((c,m),(c',m')) \<in> SR"

\<comment> \<open>predicate for strong d-bisimulation\<close>
definition Strong_d_Bisimulation :: "'d \<Rightarrow> 'com Bisimulation_type \<Rightarrow> bool"
where
"Strong_d_Bisimulation d R \<equiv>
  (sym R) \<and>
  (\<forall>(V,V') \<in> R. length V = length V') \<and>
  (\<forall>(V,V') \<in> R. \<forall>i < length V. \<forall>m1 m1' m2 W.
  \<langle>V!i,m1\<rangle> \<rightarrow> \<langle>W,m2\<rangle> \<and> m1 =\<^bsub>d\<^esub> m1'
  \<longrightarrow> (\<exists>W' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle> \<and> (W,W') \<in> R \<and> m2 =\<^bsub>d\<^esub> m2'))"

\<comment> \<open>union of all strong d-bisimulations\<close>
definition USdB :: "'d \<Rightarrow> 'com Bisimulation_type"
("\<approx>\<^bsub>_\<^esub>" 65)
where
"\<approx>\<^bsub>d\<^esub> \<equiv> \<Union>{r. (Strong_d_Bisimulation d r)}"

abbreviation relatedbyUSdB :: "'com list \<Rightarrow> 'd \<Rightarrow> 'com list \<Rightarrow> bool"
("(_ \<approx>\<^bsub>_\<^esub> _)" [66,66] 65)
where "V \<approx>\<^bsub>d\<^esub> V' \<equiv> (V,V') \<in> USdB d"

\<comment> \<open>predicate to define when a program is strongly secure\<close>
definition Strongly_Secure :: "'com list \<Rightarrow> bool"
where
"Strongly_Secure V \<equiv> (\<forall>d. V \<approx>\<^bsub>d\<^esub> V)"

\<comment> \<open>auxiliary lemma to obtain central strong d-Bisimulation property as Lemma
 in meta logic (allows instantiating all the variables manually if necessary)\<close>
lemma strongdB_aux: "\<And>V V' m1 m1' m2 W i. \<lbrakk> Strong_d_Bisimulation d R;
 i < length V ; (V,V') \<in> R; \<langle>V!i,m1\<rangle> \<rightarrow> \<langle>W,m2\<rangle>; m1 =\<^bsub>d\<^esub> m1' \<rbrakk>
 \<Longrightarrow> (\<exists>W' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle> \<and> (W,W') \<in> R \<and> m2 =\<^bsub>d\<^esub> m2')"
by (simp add: Strong_d_Bisimulation_def, fastforce)

lemma trivialpair_in_USdB:
"[] \<approx>\<^bsub>d\<^esub> []"
by (simp add: USdB_def Strong_d_Bisimulation_def,
  rule_tac x="{([],[])}" in exI, simp add: sym_def)

lemma USdBsym: "sym (\<approx>\<^bsub>d\<^esub>)"
by (simp add: USdB_def Strong_d_Bisimulation_def sym_def, auto)

lemma USdBeqlen:
  "V \<approx>\<^bsub>d\<^esub> V' \<Longrightarrow> length V = length V'"
by (simp add: USdB_def Strong_d_Bisimulation_def, auto)

lemma USdB_Strong_d_Bisimulation:
  "Strong_d_Bisimulation d (\<approx>\<^bsub>d\<^esub>)"
proof (simp add: Strong_d_Bisimulation_def, auto)
  show "sym (\<approx>\<^bsub>d\<^esub>)" by (rule USdBsym)
next
  fix V V'
  show "V \<approx>\<^bsub>d\<^esub> V' \<Longrightarrow> length V = length V'" by (rule USdBeqlen, auto)
next
  fix V V' m1 m1' m2 W i
  assume inUSdB: "V \<approx>\<^bsub>d\<^esub> V'"
  assume stepV: "\<langle>V!i,m1\<rangle> \<rightarrow> \<langle>W,m2\<rangle>"
  assume irange: "i < length V"
  assume dequal: "m1 =\<^bsub>d\<^esub> m1'"

  from inUSdB obtain R where someR:
    "Strong_d_Bisimulation d R \<and> (V,V') \<in> R"
    by (simp add: USdB_def, auto)

  with strongdB_aux stepV irange dequal show
    "\<exists>W' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle> \<and> W \<approx>\<^bsub>d\<^esub> W' \<and> m2 =\<^bsub>d\<^esub> m2'"
    by (simp add: USdB_def, fastforce)

qed

lemma USdBtrans: "trans (\<approx>\<^bsub>d\<^esub>)"
proof (simp add: trans_def, auto)
  fix V V' V''
  assume p1: "V \<approx>\<^bsub>d\<^esub> V'"
  assume p2: "V' \<approx>\<^bsub>d\<^esub> V''"

  let ?R = "{(V,V''). \<exists>V'. V \<approx>\<^bsub>d\<^esub> V' \<and> V' \<approx>\<^bsub>d\<^esub> V''}"

  from p1 p2 have inRest: "(V,V'') \<in> ?R" by auto

  have SdB_rest: "Strong_d_Bisimulation d ?R"
    proof (simp add: Strong_d_Bisimulation_def sym_def, auto)
        fix V V' V''
        assume p1: "V \<approx>\<^bsub>d\<^esub> V'"
        moreover
        assume p2: "V' \<approx>\<^bsub>d\<^esub> V''"
        moreover
        from p1 USdBsym have "V' \<approx>\<^bsub>d\<^esub> V"
          by (simp add: sym_def)
        moreover
        from p2 USdBsym have "V'' \<approx>\<^bsub>d\<^esub> V'"
          by (simp add: sym_def)
        ultimately show
        "\<exists>V'. V'' \<approx>\<^bsub>d\<^esub> V' \<and> V' \<approx>\<^bsub>d\<^esub> V"
          by (rule_tac x="V'" in exI, auto)
      next
        fix V V' V''
        assume p1: "V \<approx>\<^bsub>d\<^esub> V'"
        moreover
        assume p2: "V' \<approx>\<^bsub>d\<^esub> V''"
        moreover
        from p1 USdBeqlen[of "V" "V'"] have "length V = length V'"
          by auto
        moreover
        from p2 USdBeqlen[of "V'" "V''"] have "length V' = length V''"
          by auto
        ultimately show eqlen: "length V = length V''" by auto
      next
        fix V V' V'' i m1 m1' W m2
        assume step: "\<langle>V!i,m1\<rangle> \<rightarrow> \<langle>W,m2\<rangle>"
        assume dequal: "m1 =\<^bsub>d\<^esub> m1'"
        assume p1: "V \<approx>\<^bsub>d\<^esub> V'"
        assume p2: "V' \<approx>\<^bsub>d\<^esub> V''"
        assume irange: "i < length V"
        from p1 USdBeqlen[of "V" "V'"]
        have leq: "length V = length V'"
          by force

        have deq_same: "m1' =\<^bsub>d\<^esub> m1'" by (simp add: d_equal_def)

        from irange step dequal p1 USdB_Strong_d_Bisimulation
          strongdB_aux[of "d" "\<approx>\<^bsub>d\<^esub>" "i" "V" "V'" "m1" "W" "m2" "m1'"]
        obtain W' m2' where p1concl:
          "\<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle> \<and> W \<approx>\<^bsub>d\<^esub> W' \<and> m2 =\<^bsub>d\<^esub> m2'"
          by auto

        with deq_same leq USdB_Strong_d_Bisimulation
          strongdB_aux[of "d" "\<approx>\<^bsub>d\<^esub>" "i" "V'" "V''" "m1'" "W'" "m2'" "m1'"]
          irange p2 dequal obtain W'' m2'' where p2concl:
          "W' \<approx>\<^bsub>d\<^esub> W'' \<and> \<langle>V''!i,m1'\<rangle> \<rightarrow> \<langle>W'',m2''\<rangle> \<and> m2' =\<^bsub>d\<^esub> m2''"
          by auto

        from p1concl p2concl d_equal_trans have tt'': "m2 =\<^bsub>d\<^esub> m2''"
          by blast

        from p1concl p2concl have "(W,W'') \<in> ?R"
          by auto

        with p2concl tt'' show "\<exists>W'' m2''. \<langle>V''!i,m1'\<rangle> \<rightarrow> \<langle>W'',m2''\<rangle> \<and>
          (\<exists>V'. W \<approx>\<^bsub>d\<^esub> V' \<and> V' \<approx>\<^bsub>d\<^esub> W'') \<and> m2 =\<^bsub>d\<^esub> m2''"
          by auto
    qed

  hence liftup: "?R \<subseteq> (\<approx>\<^bsub>d\<^esub>)"
    by (simp add: USdB_def, auto)

  with inRest show "V \<approx>\<^bsub>d\<^esub> V''"
    by auto

qed

end

end


theory HomologySModule
  imports Main
          Gamma
          SimplicialSet
          "Category3.FunctorCategory"
          FinsetEquivalence
          SmashProduct
          GammaSetAsEndofunctor
          LoopSpace
begin

locale product_functor =
  F : "functor" A B F +
  G : "functor" C D G
  for A :: "'a comp"
  and B :: "'b comp"
  and F :: "'a \<Rightarrow> 'b"
  and C :: "'c comp"
  and D :: "'d comp"
  and G :: "'c \<Rightarrow> 'd"
begin

interpretation AxC : product_category A C
  unfolding product_category_def
  by (simp add: F.A.category_axioms G.A.category_axioms)

interpretation BxD : product_category B D
  unfolding product_category_def
  by (simp add: F.B.category_axioms G.B.category_axioms)

definition FxG where
  "FxG = MkFunctor AxC.comp BxD.comp (\<lambda>x. (F (fst x), G (snd x)))"

lemma is_functor : "functor AxC.comp BxD.comp FxG"
  unfolding functor_def
  apply (simp add: AxC.is_category BxD.is_category)
  unfolding functor_axioms_def
  apply auto
  unfolding FxG_def
        apply simp
       apply simp
      apply simp
     apply simp
    apply simp
   apply simp
  unfolding reverse_equality [OF FxG_def]
proof-
  fix f g h i
  assume seq1: "F.A.arr (fst (AxC.comp (f, g) (h, i)))"
  assume seq2: "G.A.arr (snd (AxC.comp (f, g) (h, i)))"
  then have arr_fghi : "F.A.arr f \<and> G.A.arr g \<and> F.A.arr h \<and> G.A.arr i"
    unfolding AxC.comp_def
    by (metis AxC.arr_char AxC.seq_char F.A.seqE G.A.seqE \<open>F.A.arr (fst (AxC.comp (f, g) (h, i)))\<close> \<open>G.A.arr (snd (AxC.comp (f, g) (h, i)))\<close> fst_conv snd_conv)

  from seq1 have eq: "F.A.cod h = F.A.dom f \<and> G.A.cod i = G.A.dom g"
    unfolding AxC.comp_def
    apply (simp add: arr_fghi)
    using fst_conv by fastforce

  show "FxG (AxC.comp (f, g) (h, i)) = BxD.comp (FxG (f, g)) (FxG (h, i))"
    unfolding FxG_def
    apply (simp add: arr_fghi seq1 seq2)
    unfolding AxC.comp_def BxD.comp_def
    by (simp add: arr_fghi eq)
qed

end

locale compose_with_functor =
  A_B : functor_category A B +
  F : "functor" B C F
  for A :: "'a comp"
  and B :: "'b comp"
  and C :: "'c comp"
  and F :: "'b \<Rightarrow> 'c"
begin

interpretation A_C : functor_category A C
  unfolding functor_category_def
  by (simp add: F.B.category_axioms A_B.A.category_axioms)

interpretation eval: evaluation_functor A B
  unfolding evaluation_functor_def
  unfolding functor_category_def product_category_def
  apply (simp add: A_B.A.category_axioms A_B.B.category_axioms)
  by (simp add: A_B.is_category)

interpretation F_compose: curried_functor A_B.comp A C "(F \<circ> eval.map)"
  unfolding curried_functor_def
  unfolding binary_functor_def
  unfolding currying_def product_category_def functor_category_def
  apply (simp add: A_B.A.category_axioms A_B.B.category_axioms
                   A_B.is_category F.B.category_axioms)
  apply (rule_tac functor_comp)
  using eval.is_functor apply simp
  using F.functor_axioms.

definition map where
  "map = F_compose.map"

lemma is_functor: "functor A_B.comp A_C.comp map"
  unfolding map_def
  using F_compose.is_functor.

end

(*
locale gamma_set =
  A: "functor" pointed_fin_set.comp pointed_set.pointed_set_comp A
  for A :: "(nat \<times> nat list) option \<Rightarrow> ('a pointed_set.LC pointed_set.parr) option" +
  assumes
  preserves_point : "category.terminal pointed_set.pointed_set_comp (A (Some (1, [0])))"
begin
end
*)

locale SphereCoeffHomology =
  Coeff: "functor" pointed_fin_set.comp pointed_set.pointed_set_comp Coeff +
  Y : pointed_simplicial_set Y
  for Coeff :: "(nat \<times> nat list) option \<Rightarrow> ('a pointed_set.LC pointed_set.parr) option"
  and Y :: "(nat \<times> nat list) option \<Rightarrow> ('a pointed_set.LC pointed_set.parr) option"
begin

interpretation Gamma : subcategory fin_set.comp pointed_fin_set.PointedArr'
  using Gamma.pointed_fin_set.is_subcategory.

interpretation Delta : simplex.

interpretation Set: category pointed_set.pointed_set_comp
  using pointed_set.is_category.

interpretation sSet : functor_category Delta.comp pointed_set.pointed_set_comp
  unfolding functor_category_def
  by (simp add: Delta.is_category pointed_set.is_category)

definition Inc where
  "Inc = FinsetEquivalence.inclusionFunctor"

definition IncxY where
  "IncxY = product_functor.FxG
       Gamma.comp pointed_set.pointed_set_comp Inc
       Delta.comp pointed_set.pointed_set_comp Y"

lemma IncxY_functor: "functor
       (product_category.comp Gamma.comp Delta.comp)
       (product_category.comp pointed_set.pointed_set_comp pointed_set.pointed_set_comp)
       IncxY"
  unfolding IncxY_def
  apply (rule_tac product_functor.is_functor)
  unfolding product_functor_def
  apply (simp add: Y.X.functor_axioms)
  using FinsetEquivalence.inclusion_functor
  unfolding pointed_fin_set.comp_def Inc_def.

lemma GDS_curry: "currying Gamma.comp Delta.comp pointed_set.pointed_set_comp"
  unfolding currying_def
  by (simp add: Gamma.category_axioms Delta.is_category Set.category_axioms)

interpretation smash_with_Y:
         curried_functor "Gamma.comp" "Delta.comp" "pointed_set.pointed_set_comp" "(smash_functor \<circ> IncxY)"
  unfolding curried_functor_def
  unfolding currying_def
  unfolding functor_category_def
  unfolding binary_functor_def
  unfolding product_category_def
  apply (simp add: Gamma.category_axioms Delta.is_category Set.category_axioms)
  apply (rule_tac functor_comp)
  using IncxY_functor apply simp
  using smash_functor.

definition smash_with_Y where
  "smash_with_Y = smash_with_Y.map"

lemma smash_with_Y: "functor Gamma.comp sSet.comp smash_with_Y"
  unfolding smash_with_Y_def
  using smash_with_Y.is_functor.

interpretation coeff_as_endofunctor: gammaset_as_endofunctor Coeff
  unfolding gammaset_as_endofunctor_def
  using Coeff.functor_axioms
  by simp

interpretation sSet_endofunctor: compose_with_functor
                   simplex.comp pointed_set.pointed_set_comp pointed_set.pointed_set_comp
                   coeff_as_endofunctor.map
  unfolding compose_with_functor_def
  unfolding functor_category_def
  apply (simp add: Delta.is_category pointed_set.is_category)
  using coeff_as_endofunctor.is_functor.

definition sSet_endofunctor where
  "sSet_endofunctor = sSet_endofunctor.map"

lemma sSet_endofunctor : "functor sSet.comp sSet.comp sSet_endofunctor"
  unfolding sSet_endofunctor_def
  using sSet_endofunctor.is_functor.

definition Homology where
  "Homology n = pi0 \<circ> (\<Omega>_tothe n) \<circ> sSet_endofunctor.map \<circ> smash_with_Y"

lemma Homology_functor: "functor Gamma.comp pointed_set.pointed_set_comp (Homology n)"
  unfolding Homology_def
  apply (rule_tac functor_comp)
  using smash_with_Y apply simp
  apply (rule_tac functor_comp)
  using sSet_endofunctor.is_functor apply simp
  apply (rule_tac functor_comp)
  using \<Omega>_tothe_functor apply blast
  using pi0_functor.

end

end


theory "RunList"

imports
   "InstructionAux" "ProgramList" "InstructionRelocate"
"InstructionPc"

begin

(* declare cut_memory.simps [simp del] *)

definition p_length :: "inst list \<Rightarrow> nat" where
"p_length lst = length (program_list_of_lst lst)"

definition program_at ::
 "program \<Rightarrow> inst list \<Rightarrow> int \<Rightarrow> bool" where
"program_at prog lst n = (\<forall>x.
   x \<ge> p_length lst \<or>
   program_map_of_lst 0 lst x = program_content prog (x+n))"

theorem program_list_content_eq2 :
  "program_map_of_lst t lst (n+t) = index (program_list_of_lst lst) n"
using program_list_map_eq by auto

theorem program_list_content_eq3 :
  "index (program_list_of_lst lst) n = program_map_of_lst 0 lst (n+0)"
  using program_list_map_eq by blast

theorem program_list_content_eq4 :
  "program_map_of_lst 0 lst n = index (program_list_of_lst lst) n"
  by (simp add: program_list_content_eq3)

definition program_int_map :: "inst list \<Rightarrow> int \<Rightarrow> inst option" where
"program_int_map lst x = program_map_of_lst 0 lst (nat x)"

theorem program_location :
 "program_at (program_of_lst (a@b) program_int_map) b (p_length a)"
apply(auto simp:program_at_def p_length_def
   program_list_content_eq4 program_list_append
   program_int_map_def)
  by (smt nat_diff_distrib' nat_int negative_zle)

(*
definition eval_expr_at :: "variable_env \<Rightarrow> address \<Rightarrow> nat \<Rightarrow> expr \<Rightarrow> 256 word option" where
"eval_expr_at v addr n expr =
  get_top v (program_iter \<lparr>
       cenv_program = \<lparr>
         program_content = program_content_of_lst n (compile_expr expr),
         program_length = 0,
         program_annotation = (\<lambda> x. [])
       \<rparr>,
       cenv_this = addr \<rparr>
     (Continue (v\<lparr>venv_pc := n \<rparr>) 100 100) (count_steps expr))"
*)

(* what is same as list of instructions *)

fun run_list :: "constant_ctx \<Rightarrow> variable_ctx \<Rightarrow>
   inst list \<Rightarrow> variable_ctx option" where
"run_list c v [] = Some v"
| "run_list c v (Cons a t) = (case instruction_sem v c a of
  InstructionContinue v \<Rightarrow> run_list c v t
 | _ \<Rightarrow> None)"

theorem program_content_first [simp] :
  "program_map_of_lst 0 (a # lst) 0 = Some a"
apply(cases a)
apply(auto)
apply(subst program_list_content_eq4)
apply(cases "get_stack a")
apply(auto)
done

(*
theorem simple_relocatable [simp] :
  "xa \<in> set (compile_simple x) \<Longrightarrow> relocatable xa"
apply(induction x arbitrary:xa)
apply(auto)
done

theorem expr_aux1 :
"(\<And>x. x \<in> set (compile_expr e1) \<Longrightarrow>
             relocatable x) \<Longrightarrow>
       (\<And>x. x \<in> set (compile_expr e2) \<Longrightarrow>
             relocatable x) \<Longrightarrow>
       x \<in> set (binop_inst x1a) \<Longrightarrow> relocatable x"
apply(cases x1a)
apply(auto simp:binop_inst.simps)
done

theorem expr_aux2 :
"(\<And>x. x \<in> set (compile_expr e) \<Longrightarrow>
             relocatable x) \<Longrightarrow>
       x \<in> set (unop_inst x1a) \<Longrightarrow> relocatable x"
apply(cases x1a)
apply(auto simp:unop_inst.simps)
done

theorem expr_relocatable :
  "x \<in> set (compile_expr e) \<Longrightarrow> relocatable x"
apply(induction e arbitrary:x)
apply(auto)
using expr_aux1 apply(blast)
using expr_aux2 apply(blast)
done
*)

theorem word_length [simp] :
 "length ((word_rsplit (w::256 word)) :: 8 word list) = 32"
apply(rule length_word_rsplit_even_size)
apply(auto simp:word_size)
done

(*
theorem simple_good :
  "xa \<in> set (compile_expr (Simple x)) \<Longrightarrow>
   0 < inst_size xa"
apply(induction x arbitrary:xa)
apply(auto)
done

theorem good_aux1 : "(\<And>x. x \<in> set (compile_expr e1) \<Longrightarrow>
             0 < inst_size x) \<Longrightarrow>
       (\<And>x. x \<in> set (compile_expr e2) \<Longrightarrow>
             0 < inst_size x) \<Longrightarrow>
       x \<in> set (compile_expr (Binary x1a e1 e2)) \<Longrightarrow>
       0 < inst_size x"
apply(cases x1a)
apply(auto simp:binop_inst.simps)
done

theorem good_aux2 :
"(\<And>x. x \<in> set (compile_expr e) \<Longrightarrow>
             0 < inst_size x) \<Longrightarrow>
       x \<in> set (compile_expr (Unary x1a e)) \<Longrightarrow>
       0 < inst_size x"
apply(cases x1a)
apply(auto simp:unop_inst.simps)
done

theorem expr_good :
  "x \<in> set (compile_expr e) \<Longrightarrow> inst_size x > 0"
apply(induction e arbitrary:x)
using simple_good apply(blast)
using good_aux1 apply(blast)
using good_aux2 apply(blast)
done
*)

(*
theorem program_next_aux :
" (p_length (a # lst) \<le> 0 \<or>
        program_content_of_lst 0 (a # lst) 0 =
        program_content (cenv_program c)
         (0 + venv_pc v)) \<Longrightarrow>
    inst_code a \<noteq> [] \<Longrightarrow>
    program_content (cenv_program c) (venv_pc v) =
    Some a"
apply(auto)
apply(auto simp:p_length_def)
apply(cases a)
apply(auto)
apply(cases "get_stack a")
apply(auto)
done
*)

fun good_inst :: "inst \<Rightarrow> bool" where
"good_inst (Stack (PUSH_N lst)) = (length lst > 0 \<and> length lst \<le> 32)"
| "good_inst _ = True"

lemma program_length_not_empty : "p_length (a # lst) = 0 \<Longrightarrow>
    False"
apply(auto simp:p_length_def)
apply(cases a)
apply(auto)
apply(cases "get_stack a")
apply(auto)
done

lemma program_next_some :
"(p_length (a # lst) \<le> 0 \<or>
           program_map_of_lst 0
            (a # lst) 0 =
           program_content
            (cctx_program c)
            (int 0 + vctx_pc v)) \<Longrightarrow>
       program_content (cctx_program c)
        (vctx_pc v) =
       Some a"
apply(auto)
using program_length_not_empty apply blast

done

lemma program_next_none :
 "   ( p_length (a # lst) \<le> 0 \<or>
     program_map_of_lst 0 (a # lst) 0 =
        program_content (cctx_program c)
         (int 0 + vctx_pc v) ) \<Longrightarrow>
    program_content (cctx_program c)
     (vctx_pc v) =
    None \<Longrightarrow>
    Misc STOP = a"
apply(auto)
using program_length_not_empty apply blast
done

theorem program_next :
  "program_at (cctx_program c) (a # lst) (vctx_pc v) \<Longrightarrow>
   vctx_next_instruction v c = Some a"
apply(auto simp:program_content_first
    program_at_def vctx_next_instruction_def split:option.split)
using program_next_none apply blast
using program_next_some apply fastforce
done

definition program_step  :: "constant_ctx \<Rightarrow> instruction_result \<Rightarrow> instruction_result "  where
"program_step c pr1 = (
  (case  pr1 of
    InstructionToEnvironment _ _ _ => pr1
  | InstructionAnnotationFailure => pr1
  | InstructionContinue v =>
     if \<not> (check_annotations v c) then InstructionAnnotationFailure else
     (case  vctx_next_instruction v c of
        None => InstructionToEnvironment (ContractFail [ShouldNotHappen]) v None
      | Some i =>
        if check_resources v c ((vctx_stack   v)) i then
          instruction_sem v c i
        else
          InstructionToEnvironment (ContractFail
              ((case  inst_stack_numbers i of
                 (consumed, produced) =>
                 (if (((int (List.length ((vctx_stack   v))) + produced) - consumed) \<le>( 1024 :: int)) then [] else [TooLongStack])
                  @ (if predict_gas i v c \<le>(vctx_gas   v) then [] else [OutOfGas])
               )
              ))
              v None
     )
  ))"

fun program_iter ::
   "nat \<Rightarrow> constant_ctx \<Rightarrow> instruction_result \<Rightarrow> instruction_result"  where
"program_iter 0 ctx x = x"
| "program_iter (Suc n) ctx x = program_iter n ctx (program_step ctx x)"

lemma program_step_is_next_state :
 "program_step c x = next_state stopper c x"
  by (simp add: program_step_def)

declare instruction_sem_def [simp del]
declare check_annotations_def [simp del]
declare vctx_next_instruction_def [simp del]

theorem simple_step :
  "program_step c (InstructionContinue v) = InstructionContinue v2 \<Longrightarrow>
   instruction_sem v c (get_some (vctx_next_instruction v c)) =
   InstructionContinue v2"
apply(auto simp:program_step_def)
apply(cases "\<not> check_annotations v c")
apply(auto)
apply(cases "vctx_next_instruction v c")
apply(auto)
apply(cases "check_resources v c (vctx_stack v) (get_some (vctx_next_instruction v c))")
apply(auto)
done

theorem program_step_continue :
 "InstructionContinue v2 = program_step c x \<Longrightarrow>
  \<exists>v. x = InstructionContinue v"
apply(cases x)
apply(auto simp:program_step_def)
done

theorem program_iter_continue :
 "InstructionContinue v2 = program_iter steps c x \<Longrightarrow>
  \<exists>v n k. x = InstructionContinue v"
apply(induction steps arbitrary:v2 n2 k2 c)
apply(auto simp:program_step_continue)
apply(cases x)
apply(auto simp:program_step_def)
done

theorem list_like_step :
  "relocatable inst \<Longrightarrow>
   vctx_next_instruction v c = Some inst \<Longrightarrow>
   program_step c (InstructionContinue v) = InstructionContinue v2 \<Longrightarrow>
   run_list c v [inst] = Some v3 \<Longrightarrow>
   v2 = v3"
apply(simp)
apply(cases "instruction_sem v c inst")
apply(auto)
using simple_step
apply(fastforce)
done

theorem asd :
  "run_list c v (a # lst) = Some v3 \<Longrightarrow>
   \<exists>v2. run_list c v [a] = Some v2"
apply(cases "instruction_sem v c a")
apply(auto)
done

declare run_list.simps [simp del]

fun get_push :: "inst \<Rightarrow> byte list" where
"get_push (Stack (PUSH_N lst)) = lst"

theorem inst_size_eq :
  "good_inst a \<Longrightarrow>
   inst_size a = p_length [a]"
apply(auto simp:p_length_def)
apply(cases a)
apply(auto)
apply(cases "get_stack a")
apply(auto)
done

theorem no_jump_inc_pc2 :
   "program_step c (InstructionContinue v) = InstructionContinue nv \<Longrightarrow>
   is_inc_pc (vctx_next_instruction v c) \<Longrightarrow>
   vctx_pc nv = vctx_pc v + 1"
apply(auto simp:program_step_def)
apply(cases "\<not> check_annotations v c")
apply(auto)
apply(cases "vctx_next_instruction v c")
apply(auto)
apply(cases "check_resources v c
            (vctx_stack v) (get_some (vctx_next_instruction v c))")
apply(auto simp:no_jump_inc_pc)
done

theorem push_inc_pc2 :
   "program_step c (InstructionContinue v) = InstructionContinue nv \<Longrightarrow>
   vctx_next_instruction v c = Some (Stack (PUSH_N lst)) \<Longrightarrow>
   good_inst (Stack (PUSH_N lst)) \<Longrightarrow>
   vctx_pc nv = vctx_pc v + length lst + 1"
apply(auto simp:program_step_def)
apply(cases "\<not> check_annotations v c")
apply(auto)
apply(cases "vctx_next_instruction v c")
apply(auto)
apply(cases "check_resources v c
            (vctx_stack v) (get_some (vctx_next_instruction v c))")
apply(auto simp:push_inc_pc)
using push_inc_pc
done

theorem unknown_fail :
  "vctx_next_instruction v c = Some (Unknown x1) \<Longrightarrow>
   program_step c (InstructionContinue v) =
          InstructionContinue v2 \<Longrightarrow>
   False"
apply(auto simp:program_step_def)
apply(cases "\<not> check_annotations v c")
apply(cases "vctx_next_instruction v c")
apply(auto)
apply(cases "check_resources v c
            (vctx_stack v) (get_some (vctx_next_instruction v c))")
apply(auto simp:instruction_sem_def)
done

theorem correct_pc_inc1 :
  "relocatable a \<Longrightarrow>
   good_inst a \<Longrightarrow>
   vctx_next_instruction v c = Some a \<Longrightarrow>
   program_step c (InstructionContinue v) = InstructionContinue v2 \<Longrightarrow>
   vctx_pc v2 = vctx_pc v + inst_size a"
apply(cases a)
apply(auto)
using unknown_fail
apply(blast)
apply(auto simp:is_inc_pc.simps no_jump_inc_pc2)
apply(cases "get_stack a")
apply(auto simp:is_inc_pc.simps no_jump_inc_pc2)
apply(cases "get_push a")
apply(auto simp:push_inc_pc2)
done

theorem app_cons : "a # lst = [a]@lst"
apply(auto)
done

theorem asdf :
  "program_list_of_lst (a#lst) =
   program_list_of_lst [a] @ program_list_of_lst lst"
using program_list_append
apply(subst app_cons)
apply(blast)
done

declare program_list_of_lst.simps [simp del]

theorem program_index :
"index (program_list_of_lst (a#lst)) (n+p_length[a]) =
 index (program_list_of_lst lst) n"
apply(auto simp:p_length_def)
apply(subst asdf)
apply(auto)
done

theorem test :
 "p_length (a # lst) \<le> (xa+p_length[a]) \<or>
               index (program_list_of_lst (a # lst))
                (xa+p_length[a]) =
               program_content prog (xa + p_length[a] + (x::int)) \<Longrightarrow>
          index (program_list_of_lst lst) xa \<noteq>
          program_content prog
           (int xa + (x + int (p_length [a]))) \<Longrightarrow>
          p_length lst \<le> xa"
apply(auto)
apply(simp add:p_length_def)
apply(subst (asm) (2) asdf)
apply(auto)
apply(auto simp:program_index)
by (simp add: add.left_commute semiring_normalization_rules(24))

theorem program_at_inst :
  "program_at prog (a # lst) (x::int) \<Longrightarrow>
   program_at prog lst (x + p_length [a])"
apply(auto simp:program_at_def inst_size_eq)
apply(auto simp:program_list_content_eq4)

apply(rule_tac xa=xa and a=a and prog=prog and x="x" in test)
apply fastforce
apply fastforce
done

theorem inst_size_eq2 :
  "good_inst a \<Longrightarrow>
   p_length [a] = inst_size a"
apply(subst inst_size_eq)
apply(auto)
done

declare inst_size_def [simp del]

theorem program_at_next_aux :
 "program_at (cctx_program c) (a # lst) (vctx_pc v) \<Longrightarrow>
  relocatable a \<Longrightarrow>
  good_inst a \<Longrightarrow>
  program_step c (InstructionContinue v) = InstructionContinue v2 \<Longrightarrow>
  vctx_pc v2 = vctx_pc v + p_length [a]"
apply(auto simp:inst_size_eq2)
using correct_pc_inc1 program_next
apply(blast)
done

theorem program_at_next :
 "program_at (cctx_program c) (a # lst) (vctx_pc v) \<Longrightarrow>
  relocatable a \<Longrightarrow>
  good_inst a \<Longrightarrow>
  program_step c (InstructionContinue v) = InstructionContinue v2 \<Longrightarrow>
  program_at (cctx_program c) lst (vctx_pc v2)"
apply(subst program_at_next_aux)
apply auto
apply(simp add:program_at_inst)
done

theorem run_list_step :
"run_list c v (a # lst) = Some v3 \<Longrightarrow>
 run_list c v [a] = Some v2 \<Longrightarrow>
 run_list c v2 lst = Some v3"
apply(auto simp:run_list.simps)
apply(cases "instruction_sem v c a")
apply(auto)
apply(auto simp:run_list.simps)
done

fun abc1 :: "constant_ctx \<Rightarrow> variable_ctx \<Rightarrow> variable_ctx" where
"abc1 c v = (case program_step c (InstructionContinue v) of
  InstructionContinue a \<Rightarrow> a)"

lemma program_step_failure :
 "program_step c InstructionAnnotationFailure =
    InstructionContinue v2 \<Longrightarrow> False"
apply (auto simp:program_step_def)
done

lemma program_step_failure_env :
 "program_step c InstructionAnnotationFailure =
    InstructionToEnvironment x31 x32
        x33 \<Longrightarrow> False"
apply (auto simp:program_step_def)
done

lemma program_step_env :
 "program_step c (InstructionToEnvironment x31 x32
        x33) =
    InstructionContinue v2 \<Longrightarrow> False"
apply (auto simp:program_step_def)
done

lemma program_step_env_failure :
 "program_step c (InstructionToEnvironment x31 x32
        x33) =
    InstructionAnnotationFailure \<Longrightarrow> False"
apply (auto simp:program_step_def)
done

lemma program_iter_failure :
 "program_iter n c InstructionAnnotationFailure =
    InstructionContinue v2 \<Longrightarrow> False"
apply (induction n arbitrary:v2)
apply (auto)
apply (cases "program_step c
          InstructionAnnotationFailure")
apply auto
using program_step_failure apply blast
using program_step_failure_env apply blast
done

lemma program_iter_env :
 "program_iter n c (InstructionToEnvironment e f g) =
    InstructionContinue v2 \<Longrightarrow> False"
apply (induction n arbitrary:v2 e f g)
apply (cases n)
apply (auto)
apply (cases "program_step c
          (InstructionToEnvironment e f g)")
using program_step_env apply blast
using program_step_env_failure apply blast
  using program_step_def by auto

theorem step_abc1 :
   "program_iter (length lst) c
        (program_step c (InstructionContinue v))
         = InstructionContinue v2
       \<Longrightarrow>
       program_step c (InstructionContinue v) =
       InstructionContinue (abc1 c v)"
apply(auto)
apply(cases "program_step c (InstructionContinue v)")
apply(auto)
using program_iter_failure apply blast
using program_iter_env apply blast
done

theorem list_aux2 :
"     program_step c (InstructionContinue v) =
      InstructionContinue vv \<Longrightarrow>
      run_list c v [a] = Some vv \<Longrightarrow>

       program_at (cctx_program c) (a # lst)
        (vctx_pc v) \<Longrightarrow>
       program_iter (length lst) c
        (program_step c (InstructionContinue v))  =
       InstructionContinue v2 \<Longrightarrow>
       run_list c v (a # lst) = Some v3 \<Longrightarrow>
       relocatable a \<Longrightarrow>
       good_inst a \<Longrightarrow>
       \<forall>x\<in>set lst. relocatable x \<and> good_inst x \<Longrightarrow>

      ( program_at (cctx_program c) lst
            (vctx_pc vv) \<and>
           program_iter (length lst) c (InstructionContinue vv) =
           InstructionContinue v2 \<and>
           run_list c vv lst = Some v3)"
apply(auto)
apply(simp add:program_at_next)
using run_list_step
apply(blast)
done

theorem list_aux3 :
"     vv = abc1 c v \<Longrightarrow>
      program_step c (InstructionContinue v) =
      InstructionContinue vv \<Longrightarrow>
      run_list c v [a] = Some vv \<Longrightarrow>

      ( program_at (cctx_program c) lst
            (vctx_pc vv) \<Longrightarrow>
        program_iter (length lst) c (InstructionContinue vv) =
           InstructionContinue v2 \<Longrightarrow>
        run_list c vv lst = Some v3 \<Longrightarrow> v2 = v3) \<Longrightarrow>

       program_at (cctx_program c) (a # lst)
        (vctx_pc v) \<Longrightarrow>
       program_iter (length lst) c
        (program_step c (InstructionContinue v)) =
       InstructionContinue v2 \<Longrightarrow>
       run_list c v (a # lst) = Some v3 \<Longrightarrow>
       relocatable a \<Longrightarrow>
       good_inst a \<Longrightarrow>
       \<forall>x\<in>set lst. relocatable x \<and> good_inst x \<Longrightarrow>
       v2 = v3"
using list_aux2
apply blast
done

(*
theorem list_aux2 :
"     program_step c (Continue v e1 e2) =
      Continue vv ee1 ee2 \<Longrightarrow>
      run_list c v [a] = Some vv \<Longrightarrow>

       program_at (cenv_program c) (a # lst)
        (venv_pc v) \<Longrightarrow>
       program_iter c
        (program_step c (Continue v e1 e2))
        (length lst) =
       Continue v2 f1 f2 \<Longrightarrow>
       run_list c v (a # lst) = Some v3 \<Longrightarrow>
       relocatable a \<Longrightarrow>
       0 < inst_size a \<Longrightarrow>
       \<forall>x\<in>set lst. relocatable x \<and> 0 < inst_size x \<Longrightarrow>

      ( program_at (cenv_program c) lst
            (venv_pc vv) \<and>
           program_iter c (Continue vv ee1 ee2)
            (length lst) =
           Continue v2 f1 f2 \<and>
           run_list c vv lst = Some v3)"
apply(auto)
apply(simp add:program_at_next)
using run_list_step
apply(blast)
done

theorem list_aux :
"     program_step c (Continue v e1 e2) =
      Continue vv ee1 ee2 \<Longrightarrow>
      run_list c v [a] = Some vv \<Longrightarrow>

      ( program_at (cenv_program c) lst
            (venv_pc vv) \<Longrightarrow>
           program_iter c (Continue vv ee1 ee2)
            (length lst) =
           Continue v2 f1 f2 \<Longrightarrow>
           run_list c vv lst = Some v3 \<Longrightarrow> v2 = v3) \<Longrightarrow>

       program_at (cenv_program c) (a # lst)
        (venv_pc v) \<Longrightarrow>
       program_iter c
        (program_step c (Continue v e1 e2))
        (length lst) =
       Continue v2 f1 f2 \<Longrightarrow>
       run_list c v (a # lst) = Some v3 \<Longrightarrow>
       relocatable a \<Longrightarrow>
       0 < inst_size a \<Longrightarrow>
       \<forall>x\<in>set lst. relocatable x \<and> 0 < inst_size x \<Longrightarrow>
       v2 = v3"
using list_aux2
apply blast
done

theorem why :
   "Continue v2 f1 f2 = program_iter c
        (program_step c (Continue v e1 e2))
        (length lst)
       \<Longrightarrow>
       \<exists>vv ee1 ee2. program_step c (Continue v e1 e2) =
       Continue vv ee1 ee2"
using program_iter_continue
apply(blast)
done

theorem why2 :
   "program_iter c
        (program_step c (Continue v e1 e2))
        (length lst) = Continue v2 f1 f2
       \<Longrightarrow>
       \<exists>vv ee1 ee2. program_step c (Continue v e1 e2) =
       Continue vv ee1 ee2"
using why
by metis

fun abc2 :: "constant_env \<Rightarrow> variable_env \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"abc2 c v e1 e2 = (case program_step c (Continue v e1 e2) of
  Continue _ a _ \<Rightarrow> a)"

fun abc3 :: "constant_env \<Rightarrow> variable_env \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"abc3 c v e1 e2 = (case program_step c (Continue v e1 e2) of
  Continue _ _ a \<Rightarrow> a)"

theorem list_aux3 :
"     vv = abc1 c v e1 e2 \<Longrightarrow>
      ee1 = abc2 c v e1 e2 \<Longrightarrow>
      ee2 = abc3 c v e1 e2 \<Longrightarrow>
      program_step c (Continue v e1 e2) =
      Continue vv ee1 ee2 \<Longrightarrow>
      run_list c v [a] = Some vv \<Longrightarrow>

      ( program_at (cenv_program c) lst
            (venv_pc vv) \<Longrightarrow>
           program_iter c (Continue vv ee1 ee2)
            (length lst) =
           Continue v2 f1 f2 \<Longrightarrow>
           run_list c vv lst = Some v3 \<Longrightarrow> v2 = v3) \<Longrightarrow>

       program_at (cenv_program c) (a # lst)
        (venv_pc v) \<Longrightarrow>
       program_iter c
        (program_step c (Continue v e1 e2))
        (length lst) =
       Continue v2 f1 f2 \<Longrightarrow>
       run_list c v (a # lst) = Some v3 \<Longrightarrow>
       relocatable a \<Longrightarrow>
       0 < inst_size a \<Longrightarrow>
       \<forall>x\<in>set lst. relocatable x \<and> 0 < inst_size x \<Longrightarrow>
       v2 = v3"
using list_aux2
apply blast
done

declare abc2.simps [simp del]
declare abc3.simps [simp del]
*)

declare abc1.simps [simp del]

theorem list_like_step2 :
  "relocatable inst \<Longrightarrow>
   good_inst inst \<Longrightarrow>
   vctx_next_instruction v c = Some inst \<Longrightarrow>
   program_step c (InstructionContinue v) = InstructionContinue v2 \<Longrightarrow>
   run_list c v (inst#lst) = Some v3 \<Longrightarrow>
   run_list c v [inst] = Some v2"
using list_like_step asd
apply(fastforce)
done

theorem list_like_step3 :
  "relocatable inst \<Longrightarrow>
   good_inst inst \<Longrightarrow>
   vctx_next_instruction v c = Some inst \<Longrightarrow>
   program_step c (InstructionContinue v) = InstructionContinue v2 \<Longrightarrow>
   run_list c v (inst#lst) = Some v3 \<Longrightarrow>
   run_list c v [inst] = Some (abc1 c v)"
apply(auto simp:abc1.simps)
using list_like_step asd
apply(fastforce)
done

theorem list_like_run :
  "(\<forall>x \<in> set lst. relocatable x \<and> good_inst x) \<Longrightarrow>
   program_at (cctx_program c) lst (vctx_pc v) \<Longrightarrow>
   program_iter (length lst) c (InstructionContinue v)
       = InstructionContinue v2 \<Longrightarrow>
   run_list c v lst = Some v3 \<Longrightarrow>
   v2 = v3"
apply(induction lst arbitrary:v v2 v3)
apply(simp add:run_list.simps)
apply(auto simp:simple_step)

(* apply(auto simp:program_iter.simps) *)
apply(rule list_aux3)

apply(auto)
using step_abc1
apply(blast)
apply(rule list_like_step3)
apply(auto)
apply(rule program_next)
apply(auto)
using step_abc1
apply(blast)
done

end


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

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => int => 'a" where
"x y z =
   (case z < 0 of
      False =>
        (case y of cons2 z2 x2 => (if (z = 0) then z2 else x x2 (z - 1))))"

fun elem :: "'a => 'a list => bool" where
"elem y (nil2) = False"
| "elem y (cons2 z2 xs) = ((z2 = y) | (elem y xs))"

theorem property0 :
  "((elem y xs) ==> (? (z :: int) . (y = (x xs z))))"
  oops

end


theory propositional_AndCommutative
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end