(*  Title:      Construct_SSA.thy
    Author:     Sebastian Ullrich
*)

section {* SSA Construction *}
subsection {* CFG to SSA CFG *}

theory Construct_SSA imports SSA_CFG
  "~~/src/HOL/Library/While_Combinator"
  "~~/src/HOL/Library/Product_Lexorder"
begin

type_synonym ('node, 'var) ssaVal = "'var \<times> 'node"

locale CFG_Construct = CFG \<alpha>n predecessors Entry "defs" "uses"
for
  \<alpha>n :: "'node::linorder list" and
  predecessors :: "'node \<Rightarrow> 'node list" and
  Entry::"'node" and
  "defs" :: "'node \<Rightarrow> 'var::linorder set" and
  "uses" :: "'node \<Rightarrow> 'var set"
begin
  fun phiDefNodes_aux :: "'var \<Rightarrow> 'node list \<Rightarrow> 'node \<Rightarrow> 'node set" where
    "phiDefNodes_aux v unvisited n =(
        if n \<notin> set unvisited \<or> v \<in> defs n then {}
        else fold (op \<union>)
          [phiDefNodes_aux v (removeAll n unvisited) m . m \<leftarrow> predecessors n]
          (if length (predecessors n) \<noteq> 1 then {n} else {})
    )"

  definition phiDefNodes :: "'var \<Rightarrow> 'node set" where
    "phiDefNodes v \<equiv> fold (op \<union>)
      [phiDefNodes_aux v \<alpha>n n . n \<leftarrow> \<alpha>n, v \<in> uses n]
      {}"

  definition var :: " ('node, 'var) ssaVal \<Rightarrow> 'var" where "var \<equiv> fst"
  abbreviation defNode :: "('node, 'var) ssaVal \<Rightarrow> 'node" where "defNode \<equiv> snd"

  declare var_def[simp]

  function lookupDef :: "'node \<Rightarrow> 'var \<Rightarrow> ('node, 'var) ssaVal" where
    "lookupDef n v =(
        if n \<notin> set \<alpha>n then undefined
        else if v \<in> defs n then (v,n)
        else case predecessors n of
          [m] \<Rightarrow> lookupDef m v
          | _ \<Rightarrow> (v,n)
    )"
  by auto

  termination by (relation "measure (\<lambda>(n,_). shortestPath n)") (auto elim: shortestPath_single_predecessor)
  declare lookupDef.simps [code]

  definition defs' :: "'node \<Rightarrow> ('node, 'var) ssaVal set" where
    "defs' n \<equiv> (\<lambda>v. (v,n)) ` defs n"
  definition uses' :: "'node \<Rightarrow> ('node, 'var) ssaVal set" where
    "uses' n \<equiv> lookupDef n ` uses n"
  definition phis' :: " ('node, ('node, 'var) ssaVal) phis" where
    "phis' \<equiv> \<lambda>(n,(v,m)).
      if m = n \<and> n \<in> phiDefNodes v \<and> v \<in> vars then
        Some [lookupDef m v . m \<leftarrow> predecessors n]
      else None"
  declare uses'_def [code] defs'_def [code] phis'_def [code]

  abbreviation "lookupDefNode n v \<equiv> defNode (lookupDef n v)"
  declare lookupDef.simps [simp del]
  declare phiDefNodes_aux.simps [simp del]

  lemma phiDefNodes_aux_cases:
    obtains (nonrec) "phiDefNodes_aux v unvisited n = {}" "(n \<notin> set unvisited \<or> v \<in> defs n)"
    | (rec) "phiDefNodes_aux v unvisited n = fold union (map (phiDefNodes_aux v (removeAll n unvisited)) (predecessors n))
          (if length (predecessors n) = 1 then {} else {n})"
       "n \<in> set unvisited" "v \<notin> defs n"
  proof (cases "n \<in> set unvisited \<and> v \<notin> defs n")
    case True
    thus ?thesis using rec by (simp add:phiDefNodes_aux.simps)
  next
    case False
    thus ?thesis using nonrec by (simp add:phiDefNodes_aux.simps)
  qed

  lemma phiDefNode_aux_is_join_node:
    assumes "n \<in> phiDefNodes_aux v un m"
    shows "length (predecessors n) \<noteq> 1"
  using assms proof (induction un arbitrary: m rule:removeAll_induct)
    case (1 un m)
    thus ?case
    proof (cases un v m rule:phiDefNodes_aux_cases)
      case rec
      with 1 show ?thesis by (fastforce elim!:fold_union_elem split:split_if_asm)
    qed auto
  qed

  lemma phiDefNode_is_join_node:
    assumes "n \<in> phiDefNodes v"
    shows "length (predecessors n) \<noteq> 1"
  using assms unfolding phiDefNodes_def
  by (auto elim!:fold_union_elem dest!:phiDefNode_aux_is_join_node)

  abbreviation unvisitedPath :: "'node list \<Rightarrow> 'node list \<Rightarrow> bool" where
    "unvisitedPath un ns \<equiv> distinct ns \<and> set ns \<subseteq> set un"

  lemma unvisitedPath_removeLast:
    assumes "unvisitedPath un ns" "length ns \<ge> 2"
    shows "unvisitedPath (removeAll (last ns) un) (butlast ns)"
  proof-
    let ?n = "last ns"
    let ?ns' = "butlast ns"
    let ?un' = "removeAll ?n un"
    let ?n' = "last ?ns'"
    from assms(2) have [simp]: "?n = ns ! (length ns - 1)" by -(rule last_conv_nth, auto)
    from assms(1) have "distinct ?ns'" by -(rule distinct_butlast, simp)
    moreover
    have "set ?ns' \<subseteq> set ?un'"
    proof
      fix n
      assume assm: "n \<in> set ?ns'"
      then obtain i where "n = ?ns' ! i" "i < length ?ns'" by (auto simp add:in_set_conv_nth)
      hence i: "n = ns ! i" "i < length ns - 1" by (auto simp add:nth_butlast)
      with assms have 1: "n \<noteq> ?n" by (auto iff:nth_eq_iff_index_eq)
      from i assms(1) have "n \<in> set un" by auto
      with `n \<in> set ?ns'` assms(1) 1 show "n \<in> set ?un'" by auto
    qed
    ultimately show ?thesis by simp
  qed

  lemma phiDefNodes_auxI:
    assumes "n\<comment>ns\<rightarrow>m" "unvisitedPath un ns" "\<forall>n \<in> set ns. v \<notin> defs n" "length (predecessors n) \<noteq> 1"
    shows "n \<in> phiDefNodes_aux v un m"
  using assms(1,2,3) proof (induction un arbitrary: m ns rule:removeAll_induct)
    case (1 un)
    show ?case
    proof (cases un v m rule:phiDefNodes_aux_cases)
      case nonrec
      from "1.prems"(1) have "m \<in> set ns" unfolding path2_def by auto
      with nonrec show ?thesis using "1.prems"(2,3) by auto
    next
      case rec
      show ?thesis
      proof (cases "n = m")
        case True
        thus ?thesis using rec assms(4) by -(subst rec(1), rule fold_union_elemI[of _ "{m}"], auto)
      next
        case False
        let ?ns' = "butlast ns"
        let ?m' = "last ?ns'"
        from "1.prems"(1) have [simp]: "m = last ns" unfolding path2_def by simp
        with 1(2) False have ns': "n\<comment>?ns'\<rightarrow>?m'" "?m' \<in> set (predecessors m)" by (auto intro: path2_unsnoc)

        have "n \<in> phiDefNodes_aux v (removeAll m un) ?m'"
        using rec(2) ns'
        apply-
        proof (rule "1.IH")
          from "1.prems"(1) False have "length ns \<ge> 2" by (auto simp del:`m = last ns`)
          with "1.prems"(2) show "unvisitedPath (removeAll m un) ?ns'" by (subst `m = last ns`, rule unvisitedPath_removeLast)
          from "1.prems"(3) show "\<forall>n \<in> set ?ns'. v \<notin> defs n" by (auto intro:in_set_butlastD)
        qed
        with ns'(2) show ?thesis by -(subst rec, rule fold_union_elemI, auto)
      qed
    qed
  qed

  lemma phiDefNodes_auxE:
    assumes "n \<in> phiDefNodes_aux v un m" "m \<in> set \<alpha>n"
    obtains ns where "n\<comment>ns\<rightarrow>m" "\<forall>n \<in> set ns. v \<notin> defs n" "length (predecessors n) \<noteq> 1" "unvisitedPath un ns"
  using assms proof (atomize_elim, induction un arbitrary:m rule:removeAll_induct)
    case (1 un)
    show ?case
    proof (cases un v m rule:phiDefNodes_aux_cases)
      case nonrec
      thus ?thesis using "1.prems" by simp
    next
      case rec
      show ?thesis
      proof (cases "n \<in> (if length (predecessors m) = 1 then {} else {m})")
        case True
        hence "n = m" by (simp split:split_if_asm)
        thus ?thesis using "1.prems"(2) rec True by auto
      next
        case False
        with rec "1.prems"(1) obtain m' where m': "n \<in> phiDefNodes_aux v (removeAll m un) m'" "m' \<in> set (predecessors m)"
          by (auto elim!:fold_union_elem)
        with "1.prems"(2) have "m' \<in> set \<alpha>n" by auto
        with "1.IH"[of m m'] m' rec obtain ns where "n\<comment>ns\<rightarrow>m'" "\<forall>n \<in> set ns. v \<notin> defs n" "length (predecessors n) \<noteq> 1" "unvisitedPath (removeAll m un) ns" by auto
        thus ?thesis using m' rec by -(rule exI, auto)
      qed
    qed
  qed

  lemma phiDefNodesE:
    assumes "n \<in> phiDefNodes v"
    obtains ns m where "n\<comment>ns\<rightarrow>m" "v \<in> uses m" "\<forall>n \<in> set ns. v \<notin> defs n" "length (predecessors n) \<noteq> 1"
  using assms
  by (auto elim!:phiDefNodes_auxE elim!:fold_union_elem simp:phiDefNodes_def)

  lemma phiDefNodes_\<alpha>n[dest]: "n \<in> phiDefNodes v \<Longrightarrow> n \<in> set \<alpha>n"
  by (erule phiDefNodesE, auto)

  lemma phiDefNodesI:
    assumes "n\<comment>ns\<rightarrow>m" "v \<in> uses m" "\<forall>n \<in> set ns. v \<notin> defs n" "length (predecessors n) \<noteq> 1"
    shows "n \<in> phiDefNodes v"
  proof-
    from assms(1) have "m \<in> set \<alpha>n" by (rule path2_in_\<alpha>n, auto)
    from assms obtain ns' where "n\<comment>ns'\<rightarrow>m" "distinct ns'" "\<forall>n \<in> set ns'. v \<notin> defs n" by -(rule simple_path2, auto)
    with assms(4) have 1: "n \<in> phiDefNodes_aux v \<alpha>n m" by -(rule phiDefNodes_auxI, auto intro:path2_in_\<alpha>n)
    thus ?thesis using assms(2) `m \<in> set \<alpha>n`
    unfolding phiDefNodes_def
    by -(rule fold_union_elemI, auto)
  qed

 lemma phiDefNodes:
    "n \<in> phiDefNodes v \<longleftrightarrow> (\<exists>ns m. n\<comment>ns\<rightarrow>m \<and> v \<in> uses m \<and> (\<forall>n \<in> set ns. v \<notin> defs n) \<and> length (predecessors n) \<noteq> 1)"
  by (auto intro!: phiDefNodesI exI elim!: phiDefNodesE)

  lemma lookupDef_cases[consumes 1]:
    assumes "n \<in> set \<alpha>n"
    obtains (SimpleDef) "v \<in> defs n" "lookupDef n v = (v,n)"
          | (PhiDef)    "v \<notin> defs n" "length (predecessors n) \<noteq> 1" "lookupDef n v = (v,n)"
          | (rec) m where "v \<notin> defs n" "predecessors n = [m]" "m \<in> set \<alpha>n" "lookupDef n v = lookupDef m v"
  proof (cases "v \<in> defs n")
    case True
    thus thesis using assms SimpleDef by (simp add:lookupDef.simps)
  next
    case False
    thus thesis
    proof (cases "length (predecessors n) = 1")
      case True
      then obtain m where m: "predecessors n = [m]" by (cases "predecessors n", auto)
      hence "m \<in> set (predecessors n)" by simp
      thus thesis using False rec assms m by -(subst(asm) lookupDef.simps, drule predecessor_is_node, auto)
    next
      case False
      thus thesis using `v \<notin> defs n` assms by -(rule PhiDef, assumption, assumption, subst lookupDef.simps, auto split:list.split)
    qed
  qed

  lemma lookupDef_cases'[consumes 1]:
    assumes "n \<in> set \<alpha>n"
    obtains (SimpleDef) "v \<in> defs n" "defNode (lookupDef n v) = n"
          | (PhiDef)    "v \<notin> defs n" "length (predecessors n) \<noteq> 1" "lookupDefNode n v = n"
          | (rec) m where "v \<notin> defs n" "predecessors n = [m]" "m \<in> set \<alpha>n" "lookupDef n v = lookupDef m v"
  using assms
  by (rule lookupDef_cases[of n v]) simp_all

  lemma lookupDefE:
    assumes "lookupDef n v = v'" "n \<in> set \<alpha>n"
    obtains (SimpleDef) "v \<in> defs n" "v' = (v,n)"
          | (PhiDef)    "v \<notin> defs n" "length (predecessors n) \<noteq> 1" "v' = (v,n)"
          | (rec) m where "v \<notin> defs n" "predecessors n = [m]" "m \<in> set \<alpha>n" "v' = lookupDef m v"
  using assms by -(atomize_elim, cases rule:lookupDef_cases[of n v], auto)

  lemma lookupDef_induct[consumes 1, case_names SimpleDef PhiDef rec]:
    assumes "n \<in> set \<alpha>n"
            "\<And>n. \<lbrakk>n \<in> set \<alpha>n; v \<in> defs n; lookupDef n v = (v,n)\<rbrakk> \<Longrightarrow> P n"
            "\<And>n. \<lbrakk>n \<in> set \<alpha>n; v \<notin> defs n; length (predecessors n) \<noteq> 1; lookupDef n v = (v,n)\<rbrakk> \<Longrightarrow> P n"
            "\<And>n m. \<lbrakk>v \<notin> defs n; predecessors n = [m]; m \<in> set \<alpha>n; lookupDef n v = lookupDef m v; P m\<rbrakk> \<Longrightarrow> P n"
    shows "P n"
  apply (induct rule:lookupDef.induct[where P = "\<lambda>n v'. v'=v \<and> n \<in> set \<alpha>n \<longrightarrow> P n", of v n, simplified (no_asm), THEN mp])
   apply clarsimp
   apply (rule_tac v=v and n=n in lookupDef_cases; auto intro: assms lookupDef_cases)
  by (rule assms(1))

  lemma lookupDef_induct'[consumes 2, case_names SimpleDef PhiDef rec]:
    assumes "n \<in> set \<alpha>n" "lookupDef n v = (v,n')"
            "\<lbrakk>v \<in> defs n'\<rbrakk> \<Longrightarrow> P n'"
            "\<lbrakk>v \<notin> defs n'; length (predecessors n') \<noteq> 1\<rbrakk> \<Longrightarrow> P n'"
            "\<And>n m. \<lbrakk>v \<notin> defs n; predecessors n = [m]; m \<in> set \<alpha>n; lookupDef n v = lookupDef m v; P m\<rbrakk> \<Longrightarrow> P n"
    shows "P n"
    using assms(1,2)
    proof (induction rule:lookupDef_induct[where v=v])
      case (SimpleDef n)
      with assms(2) have "n = n'" by auto
      with SimpleDef assms(3) show ?case by simp
    next
      case (PhiDef n)
      with assms(2) have "n = n'" by auto
      with PhiDef assms(4) show ?case by simp
    qed (rule assms(5), simp_all)

  lemma lookupDef_looksup[dest?]:
    assumes "lookupDef n v = (v',n')" "n \<in> set \<alpha>n"
    shows "v' = v"
  using assms(1) assms(2) by (induction rule:lookupDef.induct) (auto elim:lookupDefE)

  lemma lookupDef_looksup':
    assumes "(v',n') = lookupDef n v" "n \<in> set \<alpha>n"
    shows "v' = v"
  using assms(1)[symmetric] assms(2) by (rule lookupDef_looksup)

  lemma lookupDef_fst[simp]: "n \<in> set \<alpha>n \<Longrightarrow> fst (lookupDef n v) = v"
  by (metis fst_conv lookupDef_looksup'')

  lemma lookupDef_to_\<alpha>n:
    assumes "lookupDef n v = (v',n')" "n \<in> set \<alpha>n"
    shows "n' \<in> set \<alpha>n"
  using assms(2,1)
  by (induction rule:lookupDef_induct[of n v]) simp_all

  lemma lookupDef_to_\<alpha>n':
    assumes "lookupDef n v = val" "n \<in> set \<alpha>n"
    shows "defNode val \<in> set \<alpha>n"
  using assms by (cases val) (auto simp:lookupDef_to_\<alpha>n)

  lemma lookupDef_induct''[consumes 2, case_names SimpleDef PhiDef rec]:
    assumes "lookupDef n v = val" "n \<in> set \<alpha>n"
            "\<lbrakk>v \<in> defs (defNode val)\<rbrakk> \<Longrightarrow> P (defNode val)"
            "\<lbrakk>v \<notin> defs (defNode val); length (predecessors (defNode val)) \<noteq> 1\<rbrakk> \<Longrightarrow> P (defNode val)"
            "\<And>n m. \<lbrakk>v \<notin> defs n; predecessors n = [m]; m \<in> set \<alpha>n; lookupDef n v = lookupDef m v; P m\<rbrakk> \<Longrightarrow> P n"
    shows "P n"
  using assms
  apply (cases val)
  apply (simp)
  apply (erule lookupDef_induct')
  using assms(2) by (auto dest: lookupDef_looksup)

  sublocale braun_ssa: CFG_SSA_base \<alpha>n predecessors Entry defs' uses' phis'
    by unfold_locales

  lemma defs'_finite: "finite (defs' n)"
  unfolding defs'_def using defs_finite
  by simp

  lemma uses'_finite: "finite (uses' n)"
  unfolding uses'_def using uses_finite
  by simp

  lemma defs'_uses'_disjoint: "n \<in> set \<alpha>n \<Longrightarrow> defs' n \<inter> uses' n = {}"
  unfolding defs'_def uses'_def using defs_uses_disjoint
  by (auto dest:lookupDef_looksup')

  lemma phiDefNodes_aux_finite: "finite (phiDefNodes_aux v un m)"
  proof (induction un arbitrary:m rule:removeAll_induct)
    case (1 un)
    thus ?case by (cases un v m rule:phiDefNodes_aux_cases) auto
  qed

  lemma phis'_finite: "finite (dom (phis'))"
  proof-
    let ?super = "set \<alpha>n \<times> vars \<times> set \<alpha>n"
    have "finite ?super" by auto
    thus ?thesis
    by - (rule finite_subset[of _ ?super], auto simp:phis'_def split:split_if_asm)
  qed

  lemma phis'_wf: "phis' (n, v) = Some args \<Longrightarrow> length (predecessors n) = length args"
  unfolding phis'_def by (auto split:prod.splits split_if_asm)

  lemma simpleDefs_phiDefs_disjoint: "n \<in> set \<alpha>n \<Longrightarrow> defs' n \<inter> braun_ssa.phiDefs n = {}"
  unfolding braun_ssa.phiDefs_def
  unfolding phis'_def defs'_def
  by (auto elim!: phiDefNodesE dest!: path2_hd_in_ns split: split_if_asm)

  lemma oldDefs_correct: "defs n = var ` defs' n"
  by (simp add:defs'_def image_image)

  lemma oldUses_correct: "n \<in> set \<alpha>n \<Longrightarrow> uses n = var ` uses' n"
  by (simp add:uses'_def image_image)

  sublocale braun_ssa: CFG_SSA \<alpha>n predecessors Entry defs' uses' phis'
  apply unfold_locales
          apply (rule defs'_uses'_disjoint, simp_all)
         apply (rule defs'_finite)
        apply (auto simp add: uses'_def uses_in_\<alpha>n)[1]
       apply (rule uses'_finite)
      apply (rule phis'_finite)
     apply (auto simp: phis'_def split: split_if_asm)[1]
    apply (erule phis'_wf)
   apply (erule simpleDefs_phiDefs_disjoint)
  by (erule allDefs'_disjoint)
end

context CFG_Construct
begin
  lemma no_disjoint_cycle[simp]:
    assumes "n\<comment>ns\<rightarrow>n" "distinct ns"
    shows "ns = [n]"
  using assms unfolding path2_def
  by (metis distinct.simps(2) hd_Cons_tl last_in_set last_tl path_not_Nil)

  lemma lookupDef_path:
    assumes "m \<in> set \<alpha>n"
    obtains ns where  "lookupDefNode m v\<comment>ns\<rightarrow>m" "(\<forall>x \<in> set (tl ns). v \<notin> defs x)"
  apply atomize_elim
  using assms proof (induction rule:lookupDef_induct[of m v])
    case (SimpleDef n)
    thus ?case by -(rule exI[of _ "[n]"], auto)
  next
    case (PhiDef n)
    thus ?case by -(rule exI[of _ "[n]"], auto)
  next
    case (rec m m')
    then obtain ns where "lookupDefNode m v\<comment>ns\<rightarrow>m'" "\<forall>x \<in> set (tl ns). v \<notin> defs x" by auto
    with rec.hyps(1,2) show ?case by - (rule exI[of _ "ns@[m]"], auto simp: path2_not_Nil)
  qed

  lemma lookupDef_path_conventional:
    assumes "n\<comment>ns\<rightarrow>m" "n = lookupDefNode m v" "n \<notin> set (tl ns)" "x \<in> set (tl ns)" "v' \<in> braun_ssa.allDefs x"
    shows "var v' \<noteq> v"
  using assms(1-4) proof (induction rule:path2_rev_induct)
    case empty
    from empty.prems(3) have False by simp
    thus ?case ..
  next
    case (snoc ns m m')
    note snoc.prems(1)[simp]
    from snoc.hyps have p: "n\<comment>ns@[m']\<rightarrow>m'" by auto
    hence "m' \<in> set \<alpha>n" by auto
    thus ?thesis
    proof (cases rule:lookupDef_cases'[of m' v])
      case SimpleDef
      with snoc.prems(2,3) have False by (simp add:tl_append split:list.split_asm)
      thus ?thesis ..
    next
      case PhiDef
      with snoc.prems(2,3) have False by (simp add:tl_append split:list.split_asm)
      thus ?thesis ..
    next
      case (rec m\<^sub>2)
      from this(2) snoc.hyps(2) have[simp]: "m\<^sub>2 = m" by simp
      show ?thesis
      proof (cases "x \<in> set (tl ns)")
        case True
        with rec(4) snoc.prems(2) show ?thesis by - (rule snoc.IH, simp_all add:tl_append split:list.split_asm)
      next
        case False
        with snoc.prems(3) have[simp]: "x = m'" by (simp add:tl_append split:list.split_asm)

        show ?thesis
        proof (cases "v' \<in> defs' x")
          case True
          with rec(1) show ?thesis by (auto simp add:defs'_def)
        next
          case False
          with assms(5) have "v' \<in> braun_ssa.phiDefs m'" by (simp add:braun_ssa.allDefs_def)
          hence "m' \<in> phiDefNodes (fst v')"
            unfolding braun_ssa.phiDefs_def by (auto simp add: phis'_def split:prod.split_asm split_if_asm)
          with rec(2) show ?thesis by (auto dest:phiDefNode_is_join_node)
        qed
      qed
    qed
  qed

  lemma allUse_lookupDef:
    assumes "v \<in> braun_ssa.allUses m" "m \<in> set \<alpha>n"
    shows "lookupDef m (var v) = v"
  proof (cases "v \<in> uses' m")
    case True
    then obtain v' where v': "v = lookupDef m v'" "v' \<in> uses m" by (auto simp add:uses'_def)
    with assms(2) have "var v = v'" unfolding var_def by (metis lookupDef_fst)
    with v' show ?thesis by simp
  next
    case False
    with assms(1) obtain  m' v' vs where "(m,v) \<in> set (zip (predecessors m') vs)" "phis' (m', v') = Some vs"
      by (auto simp add:braun_ssa.allUses_def elim:braun_ssa.phiUsesE)
    hence l: "v = lookupDef m (var v')" by (auto simp add:phis'_def split:prod.split_asm split_if_asm elim:in_set_zip_map)
    with assms(2) have "var v = var v'" unfolding var_def by (metis lookupDef_fst)
    with l show ?thesis by simp
  qed

  lemma phis'_fst:
    assumes "phis' (n,v) = Some vs" "v' \<in> set vs"
    shows "var v' = var v"
  using assms by (auto intro!:lookupDef_fst dest!:phiDefNodes_\<alpha>n simp add:phis'_def split:prod.split_asm split_if_asm)

  lemma allUse_simpleUse:
    assumes "v \<in> braun_ssa.allUses m" "m \<in> set \<alpha>n"
    obtains ms m' where "m\<comment>ms\<rightarrow>m'" "var v \<in> uses m'" "\<forall>x \<in> set (tl ms). var v \<notin> defs x"
  proof (cases "v \<in> uses' m")
    case True
    then obtain v' where v': "v = lookupDef m v'" "v' \<in> uses m" by (auto simp add:uses'_def)
    with assms(2) have "var v = v'" unfolding var_def by (metis lookupDef_fst)
    with v' assms(2) show ?thesis by - (rule that, auto)
  next
    case False
    with assms(1) obtain  m' v' vs where phi: "(m,v) \<in> set (zip (predecessors m') vs)" "phis' (m', v') = Some vs"
      by (auto simp add:braun_ssa.allUses_def elim:braun_ssa.phiUsesE)
    hence m': "m' \<in> phiDefNodes (var v')" by (auto simp add:phis'_def split:prod.split_asm split_if_asm)
    from phi have[simp]: "var v = var v'" by - (rule phis'_fst, auto)
    from m' obtain m'' ms where "m'\<comment>ms\<rightarrow>m''" "\<forall>x \<in> set ms. var v' \<notin> defs x" "var v' \<in> uses m''" by (rule phiDefNodesE)
    with phi(1) show ?thesis by - (rule that[of "m#ms" m''], auto simp del:var_def)
  qed

  lemma defs': "v \<in> defs' n \<longleftrightarrow> var v \<in> defs n \<and> defNode v = n"
  by (cases v, auto simp add:defs'_def)

  lemma use_implies_allDef:
    assumes "lookupDef m (var v) = v"  "m \<in> set \<alpha>n" "var v \<in> uses m'" "m\<comment>ms\<rightarrow>m'" "\<forall>x \<in> set (tl ms). var v \<notin> defs x"
    shows "v \<in> braun_ssa.allDefs (defNode v)"
  using assms proof (induction arbitrary:ms rule:lookupDef_induct'')
      case SimpleDef
      hence "v \<in> defs' (defNode v)" by (simp add:defs')
      thus ?case by (simp add:braun_ssa.allDefs_def)
    next
      case PhiDef
      from PhiDef.prems(1,2) have vars: "var v \<in> vars" by auto
      from PhiDef.hyps(1) PhiDef.prems(2,3) have "\<forall>n\<in>set ms. var v \<notin> defs n" by (metis hd_Cons_tl path2_def path2_not_Nil set_ConsD)
      with PhiDef have "defNode v \<in> phiDefNodes (var v)" by - (rule phiDefNodesI)
      with vars have "v \<in> braun_ssa.phiDefs (defNode v)" unfolding braun_ssa.phiDefs_def by (auto simp add: phis'_def split: prod.split)
      thus ?case by (simp add:braun_ssa.allDefs_def)
    next
      case (rec n m)
      from rec.hyps(1) rec.prems(2,3) have "\<forall>n\<in>set ms. var v \<notin> defs n" by (metis hd_Cons_tl path2_def path2_not_Nil set_ConsD)
      with rec show ?case by - (rule rec.IH[of "m#ms"], auto)
    qed

  lemma allUse_defNode_in_\<alpha>n:
    assumes "v \<in> braun_ssa.allUses m" "m \<in> set \<alpha>n"
    shows "defNode v \<in> set \<alpha>n"
  proof-
    let ?n = "defNode (lookupDef m (var v))"
    from assms(1,2) have l: "lookupDef m (var v) = v" by (rule allUse_lookupDef)
    from assms obtain ns where ns: "?n\<comment>ns\<rightarrow>m" by - (rule lookupDef_path, auto)
    with l show ?thesis by auto
  qed

  lemma allUse_implies_allDef:
    assumes "v \<in> braun_ssa.allUses m" "m \<in> set \<alpha>n"
    shows "v \<in> braun_ssa.allDefs (defNode v)"
  proof-
    let ?n = "defNode (lookupDef m (var v))"
    from assms(1,2) have l: "lookupDef m (var v) = v" by (rule allUse_lookupDef)
    from assms obtain ns where ns: "?n\<comment>ns\<rightarrow>m" "\<forall>x \<in> set (tl ns). var v \<notin> defs x" by - (rule lookupDef_path, auto)
    from assms obtain ms m' where "m\<comment>ms\<rightarrow>m'" "var v \<in> uses m'" "\<forall>x \<in> set (tl ms). var v \<notin> defs x" by - (rule allUse_simpleUse)
    hence "v \<in> braun_ssa.allDefs (defNode v)" using ns assms(2) l by - (rule use_implies_allDef, auto)
    with assms(2) l show ?thesis by simp
  qed

  lemma conventional:
    assumes "n\<comment>ns\<rightarrow>m" "n \<notin> set (tl ns)" "v \<in> braun_ssa.allDefs n" "v \<in> braun_ssa.allUses m"
      "x \<in> set (tl ns)" "v' \<in> braun_ssa.allDefs x"
    shows "var v' \<noteq> var v"
  proof-
    from assms(1) have[simp]: "m \<in> set \<alpha>n" by auto
    from assms(4) have[simp]: "lookupDef m (var v) = v" by - (rule allUse_lookupDef, auto)

    from assms(1,4) have "v \<in> braun_ssa.allDefs (defNode v)" by - (rule allUse_implies_allDef, auto)
    with assms(1,3,4) braun_ssa.allDefs_disjoint[of n "defNode v"] have[simp]: "defNode v = n" by - (rule braun_ssa.allDefs_disjoint', auto elim: allUse_defNode_in_\<alpha>n)

    from assms show ?thesis by - (rule lookupDef_path_conventional[where m=m], simp_all add:uses'_def del:var_def)
  qed

  lemma allDefs_var_disjoint_aux: "n \<in> set \<alpha>n \<Longrightarrow> v \<in> defs n \<Longrightarrow> n \<notin> phiDefNodes v"
    by (auto elim!:phiDefNodesE dest:path2_hd_in_ns)

  lemma allDefs_var_disjoint: "\<lbrakk>n \<in> set \<alpha>n; v \<in> braun_ssa.allDefs n; v' \<in> braun_ssa.allDefs n; v \<noteq> v'\<rbrakk> \<Longrightarrow> var v' \<noteq> var v"
    unfolding braun_ssa.allDefs_def braun_ssa.phiDefs_def
    by (auto simp: defs'_def phis'_def intro: allDefs_var_disjoint_aux split:prod.splits split_if_asm)

  lemma[simp]: "n \<in> set \<alpha>n \<Longrightarrow> length (predecessors n) \<noteq> 1 \<Longrightarrow> lookupDefNode n v = n"
  by (cases rule:lookupDef_cases[of n v]) simp_all

  lemma lookupDef_idem[simp]:
    assumes "n \<in> set \<alpha>n"
    shows "lookupDef (lookupDefNode n v) v = lookupDef n v"
  using assms by (induction rule:lookupDef_induct''[of n v, OF refl]) (simp_all add:assms)
end

locale CFG_Construct_wf = CFG_Construct \<alpha>n predecessors Entry "defs" "uses" + CFG_wf \<alpha>n predecessors Entry "defs" "uses"
for
  \<alpha>n :: "'node::linorder list" and
  predecessors :: "'node \<Rightarrow> 'node list" and
  Entry::"'node" and
  "defs" :: "'node \<Rightarrow> 'var::linorder set" and
  "uses" :: "'node \<Rightarrow> 'var set"
begin
  lemma def_ass_allUses_aux:
    assumes "Entry\<comment>ns\<rightarrow>n"
    shows "lookupDefNode n (var v) \<in> set ns"
  proof-
    from assms have[simp]: "n \<in> set \<alpha>n" by auto
    thus ?thesis using assms
    proof (induction arbitrary:ns rule:lookupDef_induct''[of n "var v", OF refl, consumes 1])
      case (3 m m' ns)
      show ?case
      proof (cases "length ns \<ge> 2")
        case False
        with "3.prems" have "m = Entry" by (metis path2_nontrivial)
        with "3.hyps"(2) have False by simp
        thus ?thesis ..
      next
        case True
        with "3.prems" have "Entry\<comment>butlast ns\<rightarrow>m'"
        by (rule path2_unsnoc) (simp add:"3.hyps"(2))
        with "3.hyps" "3.IH"[of "butlast ns"] show ?thesis by (simp add:in_set_butlastD)
      qed
    qed auto
  qed

  lemma def_ass_allUses:
    assumes "v \<in> braun_ssa.allUses n" "n \<in> set \<alpha>n"
    shows "braun_ssa.defAss n v"
  proof (rule braun_ssa.defAssI)
    fix ns
    assume asm: "Entry\<comment>ns\<rightarrow>n"
    let ?m = "lookupDefNode n (var v)"
    from asm have "?m \<in> set ns" by (rule def_ass_allUses_aux)
    moreover from assms allUse_lookupDef have "?m = defNode v" by simp
    moreover from assms allUse_implies_allDef have "v \<in> braun_ssa.allDefs (defNode v)" by simp
    ultimately show "\<exists>n\<in>set ns. v \<in> braun_ssa.allDefs n" by auto
  qed

  lemma Empty_no_phis:
    shows "phis' (Entry, v) = None"
  proof-
    have "\<And>v. Entry \<notin> phiDefNodes v"
    proof (rule, rule phiDefNodesE, assumption)
      fix v ns m
      assume asm: "Entry\<comment>ns\<rightarrow>m" "\<forall>n\<in>set ns. v \<notin> defs n" "v \<in> uses m"
      hence "m \<in> set \<alpha>n" by auto
      from def_ass_uses[of, THEN bspec[OF _ this], THEN bspec[OF _ asm(3)]] asm
      show False by (auto elim!:defAss'E)
    qed
    thus ?thesis by (auto simp:phis'_def split:prod.split)
  qed

  lemma braun_ssa_CFG_SSA_wf:
    "CFG_SSA_wf \<alpha>n predecessors Entry defs' uses' phis'"
  apply unfold_locales
   apply (erule def_ass_allUses, assumption)
  apply (rule Empty_no_phis)
  done

  sublocale braun_ssa: CFG_SSA_wf \<alpha>n predecessors Entry defs' uses' phis'
  by (rule braun_ssa_CFG_SSA_wf)

  lemma braun_ssa_CFG_SSA_Transformed:
    "CFG_SSA_Transformed \<alpha>n predecessors Entry defs uses defs' uses' phis' var"
  apply unfold_locales
      apply (rule oldDefs_correct)
     apply (erule oldUses_correct)
    apply (erule conventional, simp, simp, simp, simp, simp)
   apply (erule phis'_fst, simp)
  apply (erule allDefs_var_disjoint, simp, simp, simp)
  done

  sublocale braun_ssa: CFG_SSA_Transformed \<alpha>n predecessors Entry "defs" "uses" defs' uses' phis' var
  by (rule braun_ssa_CFG_SSA_Transformed)

  lemma PhiDef_defNode_eq:
    assumes "n \<in> set \<alpha>n" "n \<in> phiDefNodes v" "v \<in> vars"
    shows "braun_ssa.defNode (v,n) = n"
  using assms by - (rule braun_ssa.defNode_eq, rule assms(1), subst braun_ssa.allDefs_def, subst braun_ssa.phiDefs_def, auto simp: phis'_def)

  lemma phiDefNodes_aux_pruned_aux:
    assumes "n \<in> phiDefNodes_aux v \<alpha>n nUse" "v \<in> uses nUse" "n\<comment>ns\<rightarrow>m" "m\<comment>ms\<rightarrow>nUse" "braun_ssa.liveVal (lookupDef m v)" "\<forall>n \<in> set (ns@ms). v \<notin> defs n"
    shows "braun_ssa.liveVal (v,n)"
  using assms(3-) proof (induction n ns m arbitrary:ms rule:path2_rev_induct)
    case empty
    with assms(1) have "lookupDef n v = (v,n)"
      by -(drule phiDefNode_aux_is_join_node, cases rule:lookupDef_cases, auto)
    with empty.prems(2) show ?case by simp
  next
    case (snoc ns m m')
    from snoc.prems have "m' \<in> set \<alpha>n" by auto
    thus ?case
    proof (cases rule:lookupDef_cases[where v=v])
      case SimpleDef
      with snoc.prems(3) have False by simp
      thus ?thesis..
    next
      have step: "braun_ssa.liveVal (lookupDef m v) \<Longrightarrow> ?thesis"
      proof (rule snoc.IH)
        from snoc.prems(1) snoc.hyps(2) show "m\<comment>m#ms\<rightarrow>nUse" by auto
        from snoc.prems(3) snoc.hyps(1) show "\<forall>n\<in> set(ns @ m # ms). v \<notin> defs n" by auto
      qed
      {
        case rec
        from snoc.hyps(2) rec(2) have[simp]: "predecessors m' = [m]" by auto
        with rec snoc.prems(2) have "braun_ssa.liveVal (lookupDef m v)" by auto
        with step show ?thesis.
      next
        case PhiDef
        with snoc assms(2) have phiDefNode: "m' \<in> phiDefNodes v" by -(rule phiDefNodesI, auto)
        from assms(2,4) have vars: "v \<in> vars" by auto
        have "braun_ssa.liveVal (lookupDef m v)"
        proof (rule braun_ssa.livePhi)
          from PhiDef(3) snoc.prems(2) show "braun_ssa.liveVal (v,m')" by simp
          from phiDefNode snoc.hyps(2) vars show "braun_ssa.phiArg (v,m') (lookupDef m v)"
            by (subst braun_ssa.phiArg_def, subst braun_ssa.phi_def, subst PhiDef_defNode_eq, auto simp: phis'_def)
        qed
        thus ?thesis by (rule step)
      }
    qed
  qed

  lemma phiDefNodes_aux_pruned:
    assumes "m \<in> phiDefNodes_aux v \<alpha>n n" "n \<in> set \<alpha>n" "v \<in> uses n"
    shows "braun_ssa.liveVal (v, m)"
  proof-
    from assms(1,2) obtain ns where ns: "m\<comment>ns\<rightarrow>n" "\<forall>n \<in> set ns. v \<notin> defs n" by (rule phiDefNodes_auxE)
    hence "v \<notin> defs n" by (auto dest:path2_last simp: path2_not_Nil)
    with ns assms(1,3) show ?thesis
    apply-
    proof (rule phiDefNodes_aux_pruned_aux)
      from assms(2,3) show "braun_ssa.liveVal (lookupDef n v)" by -(rule braun_ssa.liveSimple, auto simp add:uses'_def)
    qed auto
  qed

  theorem phis'_pruned: "braun_ssa.pruned"
  unfolding braun_ssa.pruned_def braun_ssa.phiDefs_def
  apply (subst phis'_def)
  by (auto split:prod.splits split_if_asm simp add:phiDefNodes_def elim!:fold_union_elem phiDefNodes_aux_pruned)

  declare var_def[simp del]

  declare no_disjoint_cycle [simp del]

  declare lookupDef.simps [code]
  declare phiDefNodes_aux.simps [code]
  declare phiDefNodes_def [code]
  declare defs'_def [code]
  declare uses'_def [code]
  declare phis'_def [code]
end

end


(*<*)
theory Simulation imports HOTL
begin
(*>*)
subsection \<open>Simulation \label{subsec:Simulation}\<close>

text\<open>\noindent %
This section is made up of four parts.
In \ref{subsubsec:pre} basic notions are defined that will be
used throughout the remainder of the section.
Part \ref{subsubsec:t1} gives an axiomatization of what is valid at @{text "t\<^sub>1"} and some proofs on
the basis of those axioms.
The same holds for \ref{subsubsec:t2} and \ref{subsubsec:t3}, only they describe
the state at @{text "t\<^sub>2"} and @{text "t\<^sub>3"} respectively. \<close>

(* Preliminaries *)
subsubsection \<open> Preliminaries \label{subsubsec:pre}\<close>

text\<open>\noindent %
We begin with definitions for governmental institutions @{text "g"}. They express that @{text "g"} is a certain branch of government.

This is a very simplified version of the Constitution, stripped off anything not relevant to the argument.
For instance, rather than saying that some @{text "g"} has executive powers and is thus entitled to command the army,
grant and reprieve pardons\footnote{S. \usc{2}{2}{}}, we simply state that @{text "g"} \emph{is} the executive.\<close>
consts (*predicates for branches of government *)
       is_leg::"g\<Rightarrow>\<sigma>"     \<comment> \<open>g is the legislative\<close>
       is_exe::"g\<Rightarrow>\<sigma>"     \<comment> \<open>g is the executive\<close>
       is_jud::"g\<Rightarrow>\<sigma>"     \<comment> \<open>g is the judiciary\<close>

text\<open>\noindent %
We require the branches to be unique, i.e. each branch has to have a unique governmental institution associated with it.

One could imagine a distribution of one branch over several governmental institutions. In fact, governmental institution
@{text "Courts"} represents a collection of courts and thus several different governmental institutions. To Isabelle, however,
it is a single instance of type @{text "g"}. Only we know that @{text "Courts"} isn't just one institution.

We choose to demand uniqueness because it keeps the model simple without taking
away any concepts necessary to the argument. If we didn't demand uniqueness, we would have to explicitly state which
institutions represent which branches \emph{and} which they do not represent. Otherwise, the fact that for example @{text "Congress"}
is legislative would not imply that @{text "P"} isn't. So @{text "P"} could be both legislative and executive. To then prove
 non-dictatorship for @{text "t\<^sub>1"} and @{text "t\<^sub>2"} would be impossible since any institution could be all of the branches.

Given that we do not need to model an institution representing several branches we may as well simplify things and demand uniqueness.
\<close>

axiomatization where
       unique_is_leg: "\<lfloor>\<^bold>\<forall>\<^sub>gg1. \<^bold>\<forall>\<^sub>gg2. (((is_leg g1)\<^bold>\<and>(is_leg g2))\<^bold>\<longrightarrow>(g1 \<^bold>= g2))\<rfloor>" and
       unique_is_exe: "\<lfloor>\<^bold>\<forall>\<^sub>gg1. \<^bold>\<forall>\<^sub>gg2. (((is_exe g1)\<^bold>\<and>(is_exe g2))\<^bold>\<longrightarrow>(g1 \<^bold>= g2))\<rfloor>" and
       unique_is_jud: "\<lfloor>\<^bold>\<forall>\<^sub>gg1. \<^bold>\<forall>\<^sub>gg2. (((is_jud g1)\<^bold>\<and>(is_jud g2))\<^bold>\<longrightarrow>(g1 \<^bold>= g2))\<rfloor>"
(*<*)
named_theorems Unique declare unique_is_leg[Unique] unique_is_exe[Unique] unique_is_jud[Unique]
(*>*)

text\<open>\noindent %
 There is a dictatorship at @{text "t"} if at that instance of time a dictator @{text "d"} exists that represents
all branches of government.\<close>

definition Dictatorship::"\<sigma>"
  where "Dictatorship \<equiv> \<lambda>t. \<exists>d. \<lfloor>(is_leg d) \<^bold>\<and> (is_exe d) \<^bold>\<and> (is_jud d)\<rfloor>\<^sub>t"

text\<open>\noindent %
Below follow some predicates for formulas @{text "\<phi>::\<sigma>"}. Based on these we also define predicates that are only dependant on time, and thus
are either valid or not valid for a certain instance of time. These will serve as properties of the Constitution at different points in time.
\<close>

consts  (*predicates for branches of government *)
      is_amd::"\<sigma>\<Rightarrow>\<sigma>"       \<comment> \<open>@{text "\<phi>"} is an amendment\<close>
      is_prop::"\<sigma>\<Rightarrow>\<sigma>"       \<comment> \<open>@{text "\<phi>"} is proposed\<close>
      is_rat::"\<sigma>\<Rightarrow>\<sigma>"         \<comment> \<open>@{text "\<phi>"} is ratified\<close>
      sup_prop::"g\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" \<comment> \<open>@{text "\<phi>"} has support by @{text "g"} to be proposed\<close>
      sup_rat::"\<sigma>\<Rightarrow>\<sigma>"       \<comment> \<open>@{text "\<phi>"} has support to be ratified\<close>
      maint_suf::"\<sigma>\<Rightarrow>\<sigma>"   \<comment> \<open>@{text "\<phi>"} maintains suffrage in Senate for all states\<close>

text\<open>\noindent %
We shall now define the following concepts:
\begin{labeling}{@{text "omsp"}}
\item[@{text "oap"}] Only amendments may be proposed. \\This time dependant formula is used for technical reasons.
It helps to distinguish between generic formulas @{text "\<phi>"} of type @{text "\<sigma>"} and what we call amendment. For example
@{text "oap"} itself may not be proposed if it isn't also declared an amendment.
\item[@{text "osp"}] Only if an amendment has the support of the legislative, can it be proposed.
\\This is a simplified version of what Art. V says. Basically @{text "osp"} requires an amendment to have support by two thirds
of both houses of Congress. As mentioned above we omit the option of support by a specific convention, so we can concentrate solely on
horizontal division of power.\\
Another reason why this simplified version is preferable is because it is more generic and allows for a change of interpretation. That is,
 we can make a statement about the legislative supporting an amendment, no matter if the current constitution stipulates
Congress to be the legislative or not.
\item[@{text "omsp"}] Only amendments that maintain suffrage may be proposed.
\item[@{text "opr"}] Only proposed amendments may be ratified at the next time instance.
\item[@{text "osr"}] Only if an amendment has the support for ratification, can it be ratified in the future.
\item[@{text "psr"}] If an amendment is proposed and has the support for ratification, it will be ratified at the next
time instance.\\
This will be used to show that an amendment proposed at @{text "t\<^sub>i"} is ratified and thus valid at @{text "t\<^sub>i\<^sub>+\<^sub>1"}, given that
it also has support for ratification at @{text "t\<^sub>i"}.
\\Note that together with @{text "opr"} this makes proposition and ratification of an amendment a two-step process.
\item[@{text "rv"}] If an amendment is ratified, it is also valid.
\\Here the framework for reasoning about amendments is entwined with the the content of the amendments. In combination with @{text "psr"} this property is a
 precarious one to work with for, as soon as @{text "rv"} is declared to be valid for some @{text "t"},
it will be possible to prove anything as long as it has been proposed with support for ratification in the preceding instance of time.
\end{labeling}\<close>

abbreviation oap::"\<sigma>"
  where "oap \<equiv> \<^bold>\<forall>\<^sub>\<sigma>\<phi>. (\<^bold>\<not>(is_amd \<phi>))\<^bold>\<longrightarrow>(\<^bold>\<not>(is_prop \<phi>))"
(**)
abbreviation osp::"\<sigma>"
  where "osp \<equiv> \<^bold>\<forall>\<^sub>\<sigma>\<phi>. \<^bold>\<forall>\<^sub>gg.(is_leg g)\<^bold>\<longrightarrow>((\<^bold>\<not>(sup_prop g \<phi>))\<^bold>\<longrightarrow>(\<^bold>\<not>(is_prop \<phi>)))"
(**)
abbreviation omsp::"\<sigma>"
  where "omsp \<equiv> \<^bold>\<forall>\<^sub>\<sigma>\<phi>. (\<^bold>\<not>(maint_suf \<phi>))\<^bold>\<longrightarrow>(\<^bold>\<not>(is_prop \<phi>))"
(**)
abbreviation opr::"\<sigma>"
  where "opr \<equiv> \<^bold>\<forall>\<^sub>\<sigma>\<phi>. (\<^bold>\<not>(is_prop \<phi>))\<^bold>\<longrightarrow>(\<^bold>\<not>(\<^bold>X(is_rat \<phi>)))"
(**)
abbreviation osr::"\<sigma>"
  where "osr \<equiv> \<^bold>\<forall>\<^sub>\<sigma>\<phi>. \<^bold>\<forall>\<^sub>gg. (\<^bold>\<not>(sup_rat \<phi>))\<^bold>\<longrightarrow>(\<^bold>\<not>(\<^bold>X(is_rat \<phi>)))"
(**)
abbreviation psr::"\<sigma>"
  where "psr \<equiv> \<^bold>\<forall>\<^sub>\<sigma>\<phi>. (is_prop \<phi> \<^bold>\<and> (sup_rat \<phi>))\<^bold>\<longrightarrow> (\<^bold>X(is_rat \<phi>))"
(**)
abbreviation rv::"\<sigma>"
  where "rv \<equiv> \<^bold>\<forall>\<^sub>\<sigma>\<phi>. (is_rat \<phi>) \<^bold>\<longrightarrow> \<phi>"

(* Time instance t1*)
subsubsection \<open> Time instance @{term "t\<^sub>1"} \label{subsubsec:t1}\<close>
text\<open>\noindent %
 The following section starts with an axiomatic description of the Constitution's state at @{text "t\<^sub>1"}. This also includes
some preparation for @{text "t\<^sub>2"}, namely defining amendment @{text "amd1"} and giving axioms on what ought to be valid
at @{text "t\<^sub>2"}.

Before proceeding to @{text "t\<^sub>2"}, we will prove some properties valid at @{text "t\<^sub>1"}, in particular that there is no dictatorship
at @{text "t\<^sub>1"} with the given axioms.
\<close>
(* State of constitution at t1*)
text\<open>\noindent %
 At @{text "t\<^sub>1"} @{text "Congress"} is the legislative, the @{text "President"} is the executive and the @{text "Courts"} are the judiciary.
We write @{text "President"} for constant @{text "P"} in continuous text for better readability but use @{text "P"} in commands to keep names
short.
\<close>
axiomatization where
    Con_Leg_t1: "\<lfloor>is_leg Congress\<rfloor>\<^sub>t\<^sub>1" and
    P_Exe_t1: "\<lfloor>is_exe P\<rfloor>\<^sub>t\<^sub>1" and
    Cou_Jud_t1: "\<lfloor>is_jud Courts\<rfloor>\<^sub>t\<^sub>1"

text\<open>\noindent %
All of the above defined properties for an instance of time are valid at @{text "t\<^sub>1"}.\<close>
axiomatization where
    oap_t1: "\<lfloor>oap\<rfloor>\<^sub>t\<^sub>1" and
    osp_t1: "\<lfloor>osp\<rfloor>\<^sub>t\<^sub>1" and
    omsp_t1:"\<lfloor>omsp\<rfloor>\<^sub>t\<^sub>1" and
    opr_t1: "\<lfloor>opr\<rfloor>\<^sub>t\<^sub>1" and
    rv_t1:  "\<lfloor>rv\<rfloor>\<^sub>t\<^sub>1" and
    osr_t1: "\<lfloor>osr\<rfloor>\<^sub>t\<^sub>1" and
    psr_t1: "\<lfloor>psr\<rfloor>\<^sub>t\<^sub>1"

(*Preparation for t2 *)

text\<open>\noindent %
 Here are two suggestions of what @{text "amd1"} might look like.\<close>

definition amd1a::\<sigma>
  where "amd1a \<equiv> \<^bold>\<exists>\<^sub>\<sigma>\<phi>. (\<^bold>\<not>(maint_suf \<phi>))\<^bold>\<and>((is_prop \<phi>))"
definition amd1b::\<sigma>
  where "amd1b \<equiv> \<^bold>\<forall>\<^sub>\<sigma>\<phi>. (is_prop \<phi>)\<^bold>\<longrightarrow> ((maint_suf \<phi>) \<^bold>\<or> \<^bold>\<not>(maint_suf \<phi>))"

text\<open>\noindent %
 Neither are optimal solutions.
Indeed, there is no optimal solution for the presented framework.

This is because what we want @{text "amd1"} to say is that it is not necessary for all proposed amendments
to maintain all states' suffrage in Senate.
In other words we want condition
\[ \text{@{text "omsp \<equiv> \<^bold>\<forall>\<^sub>\<sigma>\<phi>. (\<^bold>\<not>(maint_suf \<phi>))\<^bold>\<longrightarrow>(\<^bold>\<not>(is_prop \<phi>))"}} \]
to be omitted at @{text "t\<^sub>2"}.
This, however is not the same as requiring the amendment to be the negation of @{text "osmp"} as @{text "amd1a"} does.
The negation would require at least one @{text "\<phi>::\<sigma>"} to expressly \emph{not} maintain suffrage rights for some state \emph{and}
be proposed. Yet, it were acceptable both if such a @{text "\<phi>"} existed and if it didn't. We do not want to demand
such a @{text "\<phi>"} into existence.

One could therefore choose to use @{text "amd1b"} that states a proposed @{text "\<phi>"} may either satisfy the @{text "maint_suf"}
condition or it may not. Unfortunately, this is a tautology since @{term "a \<longrightarrow> b"} is always true if @{text "b"} is always true.
The @{text "b"} in this case is tautology @{text "(maint_suf \<phi>) \<^bold>\<or> \<^bold>\<not>(maint_suf \<phi>)"} and thus always true.

Although the suggested amendments do not constitute ideal amendments for the desired outcome, we shall still use them.
They help to illustrate how one can reason about amendments within this framework.

Notice that one could introduce deontic logic%
\footnote{For an overview of deontic logic, see \cite{sep-logic-deontic}}
 to argue about the \emph{necessity} of @{text "omsp"}. We choose not to do this
in order to avoid inadvertent errors due to a mixture of deontic and temporal logic.
\<close>

text\<open>\noindent %
 Next there are a few axioms that pave the way for the state at @{text "t\<^sub>2"}.\<close>

text\<open>\noindent %
 Amendments @{text "amd1a"} and @{text "amd1b"} are both proposed and have support for ratification at @{text "t\<^sub>1"}, so
they may be ratified at the next instance.
\<close>
axiomatization where
  amd1a_prop_t1:    "\<lfloor>is_prop amd1a\<rfloor>\<^sub>t\<^sub>1" and
  amd1a_sup_rat_t1: "\<lfloor>sup_rat amd1a\<rfloor>\<^sub>t\<^sub>1" and
  amd1b_prop_t1:    "\<lfloor>is_prop amd1b\<rfloor>\<^sub>t\<^sub>1" and
  amd1b_sup_rat_t1: "\<lfloor>sup_rat amd1b\<rfloor>\<^sub>t\<^sub>1"

text\<open>\noindent %
 The distribution of powers stays the same at the next instance: @{text "Congress"} is the legislative,
the @{text "President"} the executive and @{text "Courts"} are the judiciary.\<close>
axiomatization where
  XCon_Leg_t1: "\<lfloor>\<^bold>X(is_leg Congress)\<rfloor>\<^sub>t\<^sub>1" and
  XP_Exe_t1:   "\<lfloor>\<^bold>X(is_exe P)\<rfloor>\<^sub>t\<^sub>1"         and
  XCou_Jud_t1: "\<lfloor>\<^bold>X(is_jud Courts)\<rfloor>\<^sub>t\<^sub>1"

text\<open>\noindent %
 All properties defined in \ref{subsubsec:pre} are valid next time, except for @{text "maint_suf"}. This is
to ensure that we can introduce an amendment at @{text "t\<^sub>2"} that does not satisfy @{text "maint_suf"}.

\noindent In a way the amendment to Art. V is implemented by simply not using @{text "\<lfloor>\<^bold>X omsp\<rfloor>\<^sub>t\<^sub>1"} as axiom,
rather than by working with one of the above suggested amendments @{text "amd1a"} and @{text "amd1b"}.

One could criticize two aspects of this approach. \textbf{Firstly}, the fact that not an actual amendment
is used to bring about the change but rather the lack of an axiom. As argued above this is not possible, however.
\textbf{Secondly}, it shouldn't be necessary for us to explicitly state which axioms to keep and which to give up when transitioning to
the next time point. It would be preferable if the logical system automatically kept all axioms that do not lead to contradictions
and discarded the problematic ones. We will see in \ref{subsubsec:HOQu} why this is not easily done and content ourselves with
the solution at hand.

Observe that our logic is suitable to express this problem in the sense that we would run into inconsistencies,
were we to keep condition @{text "omsp"} for @{text "t\<^sub>2"} and also introduce an amendment @{text "amd2"} with @{text "\<^bold>\<not>(maint_suf amd2)"}.

\<close>
axiomatization where
  Xoap_t1:"\<lfloor>\<^bold>X oap\<rfloor>\<^sub>t\<^sub>1" and
  Xosp_t1:"\<lfloor>\<^bold>X osp\<rfloor>\<^sub>t\<^sub>1" and
  Xopr_t1:"\<lfloor>\<^bold>X opr\<rfloor>\<^sub>t\<^sub>1" and
  Xrv_t1: "\<lfloor>\<^bold>X rv\<rfloor>\<^sub>t\<^sub>1"  and
  Xosr_t1:"\<lfloor>\<^bold>X osr\<rfloor>\<^sub>t\<^sub>1" and
  Xpsr_t1:"\<lfloor>\<^bold>X psr\<rfloor>\<^sub>t\<^sub>1"

(* No dictatorship at t1*)
text\<open>\noindent %
 Using the axioms provided above, we shall prove that there is no dictatorship at @{text "t\<^sub>1"}.
This requires the proof of facts @{text "only_g_power_t1"} meaning that @{text "g"}  is the only governmental
institution with @{text "power"}(legislative, executive, judicial) at @{text "t\<^sub>1"}. Since @{text "g"} is different for each @{text "power"}
 no dictatorship can be in place at @{text "t\<^sub>1"}.
\<close>

lemma only_Con_Leg_t1: "\<lfloor>\<^bold>\<forall>\<^sub>gg. (is_leg g)\<^bold>\<longrightarrow>(g \<^bold>= Congress)\<rfloor>\<^sub>t\<^sub>1"
  unfolding Defs using unique_is_leg Con_Leg_t1
  by (simp add: global_valid_def local_valid_def tallB_g_def tall_g_def tand_def teq_def timp_def)

lemma only_P_Exe_t1:"\<lfloor>\<^bold>\<forall>\<^sub>gg. (is_exe g)\<^bold>\<longrightarrow>(g \<^bold>= P)\<rfloor>\<^sub>t\<^sub>1"
  unfolding Defs using unique_is_exe P_Exe_t1
  by (simp add: global_valid_def local_valid_def tallB_g_def tall_g_def tand_def teq_def timp_def)

lemma only_Cou_Jud_t1:"\<lfloor>\<^bold>\<forall>\<^sub>gg. (is_jud g)\<^bold>\<longrightarrow>(g \<^bold>= Courts)\<rfloor>\<^sub>t\<^sub>1"
  unfolding Defs using unique_is_jud Cou_Jud_t1
  by (simp add: global_valid_def local_valid_def tallB_g_def tall_g_def tand_def teq_def timp_def)

text\<open>\noindent %
 With these we can prove theorem @{text "noDictatorship_t1"}.\<close>

theorem noDictatorship_t1: "\<lfloor>\<^bold>\<not> Dictatorship\<rfloor>\<^sub>t\<^sub>1"
  unfolding Defs using only_Con_Leg_t1 only_P_Exe_t1 only_Cou_Jud_t1
  by (metis (no_types, lifting) Dictatorship_def g.distinct(1) local_valid_def tallB_g_def tall_g_def tand_def teq_def timp_def)(*

 List of theorems at  t1*)
(*<*)
named_theorems t1_state and t1_prep_t2  declare
 (* t1_state -ax *) Con_Leg_t1[t1_state] P_Exe_t1[t1_state] Cou_Jud_t1[t1_state]
                oap_t1[t1_state] osp_t1[t1_state] omsp_t1[t1_state] opr_t1[t1_state] rv_t1[t1_state] osr_t1[t1_state] psr_t1[t1_state]
 (* t1_state -derived *) noDictatorship_t1[t1_state]
 (* t1_prep_t2 *) amd1b_prop_t1[t1_prep_t2] amd1b_sup_rat_t1[t1_prep_t2] Xoap_t1[t1_prep_t2] Xosp_t1[t1_prep_t2] Xopr_t1[t1_prep_t2] Xrv_t1[t1_prep_t2] Xosr_t1[t1_prep_t2] Xpsr_t1[t1_prep_t2]
(*>*)(*
*)(*<*)
 (*just some tests for t1*)
lemma T_is_prop_cond: "\<lfloor>\<^bold>\<forall>\<^sub>\<sigma>\<phi>. (\<^bold>\<not>((is_amd \<phi>) \<^bold>\<and> (maint_suf \<phi>) \<^bold>\<and> (sup_prop Congress \<phi>)))\<^bold>\<longrightarrow>(\<^bold>\<not>(is_prop \<phi>))\<rfloor>\<^sub>t\<^sub>1"
  using oap_t1 osp_t1 omsp_t1 unfolding Defs
  using Con_Leg_t1 local_valid_def by blast
  \<comment> \<open>can axioms for proposition-conditions be generalised to one?\<close>
lemma T_is_rat_cond: "\<lfloor>\<^bold>\<forall>\<^sub>\<sigma>\<phi>. (\<^bold>\<not>((is_prop \<phi>) \<^bold>\<and> (sup_rat \<phi>)))\<^bold>\<longrightarrow>(\<^bold>\<not>(\<^bold>X(is_rat \<phi>)))\<rfloor>\<^sub>t\<^sub>1"
  using oap_t1 opr_t1 osr_t1 unfolding Defs
  by blast
  \<comment> \<open>can axioms for ratification-conditions be generalised to one?\<close>
lemma T_is_rat_ind_cond: "\<lfloor>\<^bold>\<forall>\<^sub>\<sigma>\<phi>. (\<^bold>\<not>((is_amd \<phi>) \<^bold>\<and> (maint_suf \<phi>) \<^bold>\<and> (sup_prop Congress \<phi>)))\<^bold>\<longrightarrow>(\<^bold>\<not>(\<^bold>X(is_rat \<phi>)))\<rfloor>\<^sub>t\<^sub>1"
  using oap_t1 opr_t1 osp_t1 omsp_t1 unfolding Defs
  using Con_Leg_t1 local_valid_def by blast
  \<comment> \<open>are prop-conditions also X-rat-conditions? They should be since rat only possible if prop.\<close>
lemma T_amd1b_is_amd:"\<lfloor>is_amd amd1b\<rfloor>\<^sub>t\<^sub>1"
  unfolding Defs using oap_t1 amd1b_prop_t1
  using local_valid_def tallB_s_def tall_s_def timp_def tneg_def by auto
lemma T_amd1b_sup_prop:"\<lfloor>sup_prop Congress amd1b\<rfloor>\<^sub>t\<^sub>1"
  unfolding Defs using osp_t1 amd1b_prop_t1 Con_Leg_t1
  using local_valid_def tallB_s_def tall_s_def tallB_g_def tall_g_def tand_def timp_def tneg_def by auto
lemma T_amd1b_maint_suf:"\<lfloor>maint_suf amd1b\<rfloor>\<^sub>t\<^sub>1"
  unfolding Defs using omsp_t1 amd1b_prop_t1
  using local_valid_def tallB_s_def tall_s_def timp_def tneg_def by auto
(*>*)(*
*)
text\<open>\noindent %
 Finally we check whether the axioms so far are even satisfiable by asking Nitpick to find a satisfiable model for @{text "True"},
 which it does.\<close>
lemma T_basic_sat_t1: "True" nitpick[satisfy,user_axioms,show_all,card time = 4]oops

(* Time instance t2*)
subsubsection \<open>Time instance @{term "t\<^sub>2"} \label{subsubsec:t2}\<close>
text\<open>\noindent %
 As before there are three parts to @{text "t\<^sub>2"}. This time they differ a little in structure.

The description of the current state is not given by a set of axioms but rather conclusions drawn from the preparation
at @{text "t\<^sub>1"}. This also includes proofs for the validity of @{text "amd1a"} and @{text "amd1b"}.
The preparation for the next instance of time introduces the new amendment @{text "amd2"}.
The proof for the non-existence of dictatorship at @{text "t\<^sub>2"} is practically the same as in @{text "t\<^sub>1"}.
\<close>
(* State of constitution at t2*)
text\<open>\noindent %
 Based on axioms @{text " XCon_Leg_t1"}, @{text "XP_Exe_t1"} and @{text "XCou_Jud_t1"} we can now deduct that @{text "Congress"} is still the
legislative, the @{text "President"} the executive and @{text "Courts"} are the judiciary.\<close>
lemma Con_Leg_t2:"\<lfloor>is_leg Congress\<rfloor>\<^sub>t\<^sub>2"
  unfolding Defs
  using XCon_Leg_t1 local_valid_def tnext_def t1_s_t2 by auto

lemma P_Exe_t2:"\<lfloor>is_exe P\<rfloor>\<^sub>t\<^sub>2"
  unfolding Defs using tnext_def XP_Exe_t1
  using XP_Exe_t1 local_valid_def tnext_def t1_s_t2 by auto

lemma Cou_Jud_t2:"\<lfloor>is_jud Courts\<rfloor>\<^sub>t\<^sub>2"
  using XCou_Jud_t1 local_valid_def tnext_def t1_s_t2 by auto

text\<open>\noindent %
 Analogously, we can refer to axioms @{text "Xproperty_t1"} to conclude that @{text "property"} is valid at
@{text "t\<^sub>2"}. These are the same properties we had for @{text "t\<^sub>1"} with the exception of @{text "omsp"}.
\<close>
lemma oap_t2:"\<lfloor>oap\<rfloor>\<^sub>t\<^sub>2"
  using Xoap_t1 local_valid_def tnext_def t1_s_t2 by auto
lemma osp_t2:"\<lfloor>osp\<rfloor>\<^sub>t\<^sub>2"
  using Xosp_t1 local_valid_def tnext_def t1_s_t2 by auto
lemma opr_t2:"\<lfloor>opr\<rfloor>\<^sub>t\<^sub>2"
  using Xopr_t1 local_valid_def tnext_def t1_s_t2 by auto
lemma rv_t2:"\<lfloor>rv\<rfloor>\<^sub>t\<^sub>2"
  using Xrv_t1 local_valid_def tnext_def t1_s_t2 by auto
lemma osr_t2:"\<lfloor>osr\<rfloor>\<^sub>t\<^sub>2"
  using Xosr_t1 local_valid_def tnext_def t1_s_t2 by auto
lemma psr_t2:"\<lfloor>psr\<rfloor>\<^sub>t\<^sub>2"
  using Xpsr_t1 local_valid_def tnext_def t1_s_t2 by auto

(* amds now valid  t2*)
text\<open>\noindent %
Below are proofs for the amendments proposed previously.

As discussed above, the outline for a validity proof where an amendment @{text "amd"} is concerned is as follows:
\begin{center}
\begin{tabularx}{0.7\textwidth}{c  c}
$t_i$&  $t_{i+1}$ \\ \midrule
@{text "psr_t\<^sub>i"}& @{text "rv_t\<^sub>i\<^sub>+\<^sub>1"} \\ \hline
 @{text "is_prop amd"}& \rdelim\}{2}{1.8cm}[$\underset{\text{@{text "psr_t\<^sub>i"}}}{\Rightarrow}$ @{text "is_rat amd"} $~~~\underset{\text{@{text "rv_t\<^sub>i\<^sub>+\<^sub>1"}}}{\Rightarrow}$ @{text "amd"}]\\
@{text "sup_rat amd"} & \\
\end{tabularx}
\end{center}

\noindent This is exactly what we do with @{text "amd1a"}. Using @{text " amd1a_prop_t1"}, @{text " amd1a_sup_rat_t1"} and @{text "psr_t1"}
 we get that @{text "\<lfloor>\<^bold>X(is_rat amd1a)\<rfloor>\<^sub>t\<^sub>1"}. By definition of @{text "\<^bold>X"}
this means that @{text "\<lfloor>is_rat amd1a\<rfloor>\<^sub>t\<^sub>2"} is true and by @{text "rv_t2"} that @{text "\<lfloor>amd1a\<rfloor>\<^sub>t\<^sub>2"} is true.
\<close>

(*amd1a*)
lemma amd1a_val_t2:"\<lfloor>amd1a\<rfloor>\<^sub>t\<^sub>2"
proof -
  have "\<lfloor>\<^bold>X(is_rat amd1a)\<rfloor>\<^sub>t\<^sub>1"
    using amd1a_prop_t1 amd1a_sup_rat_t1 psr_t1 local_valid_def tallB_s_def tall_s_def tand_def timp_def tnext_def
    by auto
  thus "\<lfloor>amd1a\<rfloor>\<^sub>t\<^sub>2"
    using local_valid_def tallB_s_def tall_s_def timp_def tnext_def rv_t2 t1_s_t2
    by auto
qed

text\<open>\noindent %
See below that we can prove @{text "\<lfloor>amd1b\<rfloor>\<^sub>t\<^sub>2"} with or without these axioms.
 We do not need to use the deduction rules provided by our axioms because
 @{text "amd1b"} is a tautology. Indeed, we can also show @{text "amd1b"}'s validity for @{text "t\<^sub>1"} and its global validity.
This is not possible with @{text "amd1a"}.
 \<close>

(*amd1b*)
lemma amd1b_val_t2:"\<lfloor>amd1b\<rfloor>\<^sub>t\<^sub>2"
  unfolding Defs
  by (simp add: amd1b_def tallB_s_def tall_s_def timp_def tneg_def tor_def)

lemma amd1b_val_t2_2:"\<lfloor>amd1b\<rfloor>\<^sub>t\<^sub>2"
  unfolding Defs using amd1b_sup_rat_t1 amd1b_prop_t1 psr_t1 rv_t2
  by (simp add: amd1b_def tallB_s_def tall_s_def timp_def tneg_def tor_def)

lemma amd1b_val_t1:"\<lfloor>amd1b\<rfloor>\<^sub>t\<^sub>1"
  unfolding Defs
  by (simp add: amd1b_def tallB_s_def tall_s_def timp_def tneg_def tor_def)

lemma amd1b_val:"\<lfloor>amd1b\<rfloor>"
  unfolding Defs
  by (simp add: amd1b_def tallB_s_def tall_s_def timp_def tneg_def tor_def)

(*Preparation for t3 at t2*)

text\<open>\noindent %
 Now we introduce @{text "amd2"} which will transfer all governmental power to the @{text "President"}.
Technically @{text "amd2"} does not bereave any state of its votes in Senate and would thus satifsy @{text "maint_suf"}.
However, if Congress does not have any real power any more, then neither do its members, which would render any state's
votes inane. So, in effect, we have that @{text "\<not>(maint_suf amd2)"}.

Notice that we cannot declare @{text "\<not>(maint_suf amd2)"} to be globally valid since a state's votes in Senate depend on
what the Constitution currently looks like. Were we to consider predicate @{text "maint_suf"} for @{text "amd2"} at a time when
states have no suffrage in Senate  @{text "(maint_suf amd2)"} would be true.
\<close>

definition amd2::\<sigma> where " amd2 \<equiv> is_leg P \<^bold>\<and> is_exe P \<^bold>\<and> is_jud P"
axiomatization where
  amd2_prop_t2:"\<lfloor>is_prop amd2\<rfloor>\<^sub>t\<^sub>2" and
  amd2_sup_rat_t2:"\<lfloor>sup_rat amd2\<rfloor>\<^sub>t\<^sub>2" and
  amd2_not_maint_suf_t2:"\<lfloor>\<^bold>\<not>(maint_suf amd2)\<rfloor>\<^sub>t\<^sub>2"

text\<open>\noindent %
 As before we intend to keep all time dependant conditions except for @{text "omsp"} when transitioning to @{text "t\<^sub>3"}.
\<close>

axiomatization where
  Xoap_t2:"\<lfloor>\<^bold>X oap\<rfloor>\<^sub>t\<^sub>2" and
  Xosp_t2:"\<lfloor>\<^bold>X osp\<rfloor>\<^sub>t\<^sub>2" and
  Xopr_t2:"\<lfloor>\<^bold>X opr\<rfloor>\<^sub>t\<^sub>2" and
  Xrv_t2:"\<lfloor>\<^bold>X rv\<rfloor>\<^sub>t\<^sub>2" and
  Xosr_t2:"\<lfloor>\<^bold>X osr\<rfloor>\<^sub>t\<^sub>2" and
  Xpsr_t2:"\<lfloor>\<^bold>X psr\<rfloor>\<^sub>t\<^sub>2"

text\<open>\noindent %
In \ref{subsubsec:types} we mentioned that we needed @{text "t\<^sub>e"} for technical reasons.
This is because we want to use above given axiom @{term "\<lfloor>\<^bold>X opr\<rfloor>\<^sub>t\<^sub>2"} without creating inconsistencies due to a missing successor for @{term "t\<^sub>3"}.
\begin{align*}
\text{@{term "\<lfloor>\<^bold>X opr\<rfloor>\<^sub>t\<^sub>2"}} &\Rightarrow \text{@{term "\<lfloor>opr\<rfloor>\<^sub>t\<^sub>3"}} \\
&\Leftrightarrow \text{@{text "\<lfloor>\<^bold>\<forall>\<^sub>\<sigma>\<phi>. (\<^bold>\<not>(is_prop \<phi>))\<^bold>\<longrightarrow>(\<^bold>\<not>(\<^bold>X(is_rat \<phi>)))\<rfloor>\<^sub>t\<^sub>3"}}\\
&\Leftrightarrow \text{@{text "\<lfloor>\<^bold>\<forall>\<^sub>\<sigma>\<phi>. (\<^bold>X(is_rat \<phi>))\<^bold>\<longrightarrow>(is_prop \<phi>)\<rfloor>\<^sub>t\<^sub>3"}} \\
&\Leftrightarrow \text{@{text "\<forall>\<phi>. ((\<^bold>X(is_rat \<phi>))t\<^sub>3)\<longrightarrow>(is_prop \<phi>) t\<^sub>3"}} \\
&\Leftrightarrow \text{@{text "\<forall>\<phi>. \<forall>t'.((succ t\<^sub>3 t')\<longrightarrow>(is_rat \<phi>) t')\<longrightarrow>(is_prop \<phi>) t\<^sub>3"}} \\
\end{align*}
If @{text "t\<^sub>3"} does not have a successor @{text "(succ t\<^sub>3 t')"} will always be false, making @{text "(succ t\<^sub>3 t')\<longrightarrow>(is_rat \<phi>) t'"}
always true which it shouldn't be. As soon as term @{text "(is_prop \<phi>) t\<^sub>3"} is not true for some @{text "\<phi>"}, axiom @{term "\<lfloor>\<^bold>X opr\<rfloor>\<^sub>t\<^sub>2"}
will cause an inconsistency.

We therefore want @{text "t\<^sub>3"} to have a successor. In order to avoid circular succession we introduce dummy instance @{text "t\<^sub>e"}.
\<close>

(* No dictatorship at  t2*)
text\<open>\noindent %
 Analogously to the proof at \ref{subsubsec:t1}, we prove properties @{text "only_g_power_t2"} for @{text "g"}, governmental institution
and @{text "power \<in> {legilslative power, executive power, judicial power}"} to use them in the proof for @{text "noDictatorship_t2"}.\<close>
lemma only_Con_Leg_t2:"\<lfloor>\<^bold>\<forall>\<^sub>gg. (is_leg g)\<^bold>\<longrightarrow>(g \<^bold>= Congress)\<rfloor>\<^sub>t\<^sub>2"
  using unique_is_leg Con_Leg_t2 global_valid_def local_valid_def tallB_g_def tall_g_def tand_def teq_def timp_def
  by simp

lemma only_P_Exe_t2:"\<lfloor>\<^bold>\<forall>\<^sub>gg. (is_exe g)\<^bold>\<longrightarrow>(g \<^bold>= P)\<rfloor>\<^sub>t\<^sub>2"
  unfolding Defs using unique_is_exe P_Exe_t2
  by (simp add: global_valid_def local_valid_def tallB_g_def tall_g_def tand_def teq_def timp_def)

lemma only_Cou_Jud_t2:"\<lfloor>\<^bold>\<forall>\<^sub>gg. (is_jud g)\<^bold>\<longrightarrow>(g \<^bold>= Courts)\<rfloor>\<^sub>t\<^sub>2"
  unfolding Defs using unique_is_jud Cou_Jud_t2
  by (simp add: global_valid_def local_valid_def tallB_g_def tall_g_def tand_def teq_def timp_def)

theorem noDictatorship_t2: "\<lfloor>\<^bold>\<not> Dictatorship\<rfloor>\<^sub>t\<^sub>2"
  unfolding Defs using only_Con_Leg_t2 only_P_Exe_t2 only_Cou_Jud_t2 Dictatorship_def
  by (metis (mono_tags, lifting) g.distinct(3) local_valid_def tallB_g_def tall_g_def  tand_def teq_def timp_def)

(* List of theorems at  t2*)
(*<*)
named_theorems t2_state and t2_prep_t3  declare
 (* t2_state -derived *) Con_Leg_t2[t2_state] P_Exe_t2[t2_state] Cou_Jud_t2[t2_state]
                oap_t2[t2_state] osp_t2[t2_state] opr_t2[t2_state] rv_t2[t2_state] osr_t2[t2_state] psr_t2[t2_state]
                amd1b_val_t2[t2_state] amd1a_val_t2[t2_state]
                only_Con_Leg_t2[t2_state] only_P_Exe_t2[t2_state] only_Cou_Jud_t2[t2_state]
                noDictatorship_t2[t2_state]
 (* t2_prep_t3 *) amd2_prop_t2[t2_prep_t3] amd2_sup_rat_t2[t2_prep_t3]  amd2_not_maint_suf_t2[t2_prep_t3]
                Xoap_t2[t2_prep_t3]  Xopr_t2[t2_prep_t3] Xrv_t2[t2_prep_t3]  Xpsr_t2[t2_prep_t3]
(*>*)

text\<open>\noindent %
 Also, analogously we make sure that Nitpick can still find a satisfiable model for our axioms.\<close>
lemma T_basic_sat_t2: "True" nitpick[satisfy,user_axioms,show_all,card time = 4]oops

(* Time instance t3*)
subsubsection \<open>Time instance @{term "t\<^sub>3"} \label{subsubsec:t3}\<close>
(*State of constitution at t3*)

text\<open>\noindent %
 The remainder of this section is rather simple. We prove properties for new time instance @{text "t\<^sub>3"} using
previously provided axioms @{text "Xproperty_t2"}. We then proceed to show that @{text "amd2"} is valid with the
reasoning given above and use it to prove that there is now a dictatorship.
\<close>

lemma oap_t3:"\<lfloor>oap\<rfloor>\<^sub>t\<^sub>3"
  using Xoap_t2 local_valid_def tnext_def t2_s_t3 by auto
lemma osp_t3:"\<lfloor>osp\<rfloor>\<^sub>t\<^sub>3"
  using Xosp_t2 local_valid_def tnext_def t2_s_t3 by auto
lemma opr_t3:"\<lfloor>opr\<rfloor>\<^sub>t\<^sub>3"
  using Xopr_t2 local_valid_def tnext_def t2_s_t3 by auto
lemma rv_t3:"\<lfloor>rv\<rfloor>\<^sub>t\<^sub>3"
  using Xrv_t2 local_valid_def tnext_def t2_s_t3 by auto
lemma osr_t3:"\<lfloor>osr\<rfloor>\<^sub>t\<^sub>3"
  using Xosr_t2 local_valid_def tnext_def t2_s_t3 by auto
lemma psr_t3:"\<lfloor>psr\<rfloor>\<^sub>t\<^sub>3"
  using Xpsr_t2 local_valid_def tnext_def t2_s_t3 by auto

lemma amd2_val_t3:"\<lfloor>amd2\<rfloor>\<^sub>t\<^sub>3"
proof -
  have "\<lfloor>\<^bold>X(is_rat amd2)\<rfloor>\<^sub>t\<^sub>2"
    using amd2_prop_t2 amd2_sup_rat_t2 local_valid_def tallB_s_def tall_s_def tand_def timp_def tnext_def psr_t2
    by auto
  thus  "\<lfloor>amd2\<rfloor>\<^sub>t\<^sub>3"
    using local_valid_def tallB_s_def tall_s_def timp_def tnext_def rv_t3 t2_s_t3
    by auto
qed

(* Dictatorship at t3 *)

text\<open>\noindent %
Since @{text "amd2 \<equiv> is_leg P \<^bold>\<and> is_exe P \<^bold>\<and> is_jud P"} we can easily show that the condition for @{text "Dictatorship"}
is satisfied.
\<close>

theorem Dictatorship_t3:"\<lfloor>Dictatorship\<rfloor>\<^sub>t\<^sub>3"
proof -
  have "\<lfloor>is_leg P \<^bold>\<and> is_exe P \<^bold>\<and> is_jud P\<rfloor>\<^sub>t\<^sub>3"
    using amd2_val_t3 amd2_def
    by ( simp add: local_valid_def tand_def)
  thus "\<lfloor>Dictatorship\<rfloor>\<^sub>t\<^sub>3"
    by (meson Dictatorship_def local_valid_def)
qed

text\<open>\noindent %
To conclude we check for satisfiability again.
\<close>

lemma T_basic_sat_t3: "True" nitpick[satisfy,user_axioms,show_all,card time = 4]oops

(*<*)
end
(*>*)


theory HEAP0ProofsIJW
imports HEAP0
begin

theorem (in level0_new)
  locale0_new_FSB: "PO_new0_feasibility"
unfolding PO_new0_feasibility_def  new0_postcondition_def new0_post_def
proof -
 from l0_new0_precondition_def new0_pre_def obtain f0new r
   where f0wit: "f0new = f0 - locs_of r s0" and isb: "is_block r s0 f0"
   by auto
 moreover have "F0_inv f0new" using l0_invariant_def F0_inv_def f0wit by simp
 ultimately show "\<exists>f' r'. (is_block r' s0 f0 \<and> f' = f0 - locs_of r' s0) \<and> F0_inv f'" by blast
qed

theorem (in level0_dispose)
  locale0_dispose_FSB: "PO_dispose0_feasibility"
unfolding PO_dispose0_feasibility_def dispose0_postcondition_def dispose0_post_def
proof -
  from l0_dispose0_precondition_def dispose0_pre_def obtain f0new
    where f0wit: "f0new = (f0 \<union> locs_of d0 s0)" by auto
  moreover have "F0_inv f0new"
  proof -
  	have "finite (locs_of d0 s0)" using locs_of_def l0_input_notempty_def by auto
  	then have "F0_inv (f0 \<union> locs_of d0 s0)"
  	 using l0_invariant_def F0_inv_def by simp
  	thus "F0_inv f0new"
  		using f0wit dispose0_post_def by auto
  qed
  ultimately show "\<exists>f'. f' = f0 \<union> locs_of d0 s0 \<and> F0_inv f'" by blast
qed

(* The above proofs are straightforward, but there is a wee bit of clutter due to the depth of
   definitions that are being unfolded. Possibly this is overkill for Isar-style proofs where
   we can use forwards proof to control the zoom level? Of course, it is useful for the metis
   style of proof!
*)

end


(*  Title:      Uint_Userguide.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter {* User guide for native words *}

(*<*)
theory Uint_Userguide imports
  Uint32
  Uint16
  Code_Target_Bits_Int
begin
(*>*)

text {*
  This tutorial explains how to best use the types for native
  words like @{typ "uint32"} in your formalisation.
  You can base your formalisation
  \begin{enumerate}
  \item either directly on these types,
  \item or on the generic @{typ "'a word"} and only introduce native
    words a posteriori via code generator refinement.
  \end{enumerate}

  The first option causes the least overhead if you have to prove only
  little about the words you use and start a fresh formalisation.
  Just use the native type @{typ uint32} instead of @{typ "32 word"}
  and similarly for @{text uint64}, @{text uint16}, and @{text uint8}.
  As native word types are meant only for code generation, the lemmas
  about @{typ "'a word"}  have not been duplicated, but you can transfer
  theorems between native word types and @{typ "'a word"} using the
  transfer package.

  Note, however, that this option restricts your work a bit:
  your own functions cannot be ``polymorphic'' in the word length,
  but you have to define a separate function for every word length you need.

  The second option is recommended if you already have a formalisation
  based on @{typ "'a word"} or if your proofs involve words and their
  properties. It separates code generation from modelling and proving,
  i.e., you can work with words as usual. Consequently, you have to
  manually setup the code generator to use the native types wherever
  you want. The following describes how to achieve this with moderate
  effort.

  Note, however, that some target languages of the code generator
  (especially OCaml) do not support all the native word types provided.
  Therefore, you should only import those types that you need -- the
  theory file for each type mentions at the top the restrictions for
  code generation. For example, PolyML does not provide the Word16
  structure, and OCaml provides neither Word8 nor Word16.
  You can still use these theories provided that you also import
  the theory @{theory "Code_Target_Bits_Int"} (which implements
  @{typ int} by target-language integers), but these words will
  be implemented via Isabelle's @{text "HOL-Word"} library, i.e.,
  you do not gain anything in terms of efficiency.

  \textbf{There is a separate code target @{text "SML_word"} for SML.}
  If you use one of the native words that PolyML does not support
  (such as @{text "uint16"} and @{text uint64} in 32-bit mode), but would
  like to map its operations to the Standard Basis Library functions,
  make sure to use the target @{text "SML_word"} instead of @{text "SML"};
  if you only use native word sizes that PolyML supports, you can stick
  with @{text "SML"}.  This ensures that code generation within Isabelle
  as used by @{text Quickcheck}, @{text value} and @\{code\} in ML blocks
  continues to work.
*}

section {* Lifting functions from @{typ "'a word"} to native words *}

text {*
  This section shows how to convert functions from @{typ "'a word"} to native
  words. For example, the following function @{text sum_squares} computes
  the sum of the first @{term n} square numbers in 16 bit arithmetic using
  a tail-recursive function @{text gen_sum_squares} with accumulator;
  for convenience, @{text sum_squares_int} takes an integer instead of a word.
*}

function gen_sum_squares :: "16 word \<Rightarrow> 16 word \<Rightarrow> 16 word" where (*<*)[simp del]:(*>*)

  "gen_sum_squares accum n =
   (if n = 0 then accum else gen_sum_squares (accum + n * n) (n - 1))"
(*<*)by pat_completeness simp
termination by(relation "measure (nat \<circ> uint \<circ> snd)")
  (simp_all, metis (hide_lams, mono_tags) uint_1 uint_eq_0 uint_minus_simple_alt uint_sub_ge word_le_sub1 word_less_def word_neq_0_conv word_zero_le zle_diff1_eq)(*>*)

definition sum_squares :: "16 word \<Rightarrow> 16 word" where
   "sum_squares = gen_sum_squares 0"

definition sum_squares_int :: "int \<Rightarrow> 16 word" where
  "sum_squares_int n = sum_squares (word_of_int n)"

text {*
  The generated code for @{term sum_squares} and @{term sum_squares_int}
  emulates words with unbounded integers and explicit modulus as specified
  in the theory @{theory Word}. But for efficiency, we want that the
  generated code uses machine words and machine arithmetic. Unfortunately,
  as @{typ "'a word"} is polymorphic in the word length, the code generator
  can only do this if we use another type for machine words. The theory
  @{theory Uint16} defines the type @{typ uint16} for machine words of
  16~bits. We just have to follow two steps to use it:

  First, we lift all our functions from @{typ "16 word"} to @{typ uint16},
  i.e., @{term sum_squares}, @{term gen_sum_squares}, and
  @{term sum_squares_int} in our case. The theory @{theory Uint16} sets
  up the lifting package for this and has already taken care of the
  arithmetic and bit-wise operations.
*}
lift_definition gen_sum_squares_uint :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16"
  is gen_sum_squares .
lift_definition sum_squares_uint :: "uint16 \<Rightarrow> uint16" is sum_squares .
lift_definition sum_squares_int_uint :: "int \<Rightarrow> uint16" is sum_squares_int .

text {*
  Second, we also have to transfer the code equations for our functions.
  The attribute @{text Transfer.transferred} takes care of that, but it is
  better to check that the transfer succeeded: inspect the theorem to check
  that the new constants are used throughout.
*}

lemmas [Transfer.transferred, code] =
  gen_sum_squares.simps
  sum_squares_def
  sum_squares_int_def

text {*
  Finally, we export the code to standard ML.  We use the target
  @{text "SML_word"} instead of @{text "SML"} to have the operations
  on @{typ uint16} mapped to the Standard Basis Library. As PolyML
  does not provide a Word16 type, the mapping for @{typ uint16} is only
  active in the refined target @{text "SML_word"}.
*}
export_code sum_squares_int_uint in SML_word

text {*
  Nevertheless, we can still evaluate terms with @{term "uint16"} within
  Isabelle, i.e., PolyML, but this will be translated to @{typ "16 word"}
  and therefore less efficient.
*}

value "sum_squares_int_uint 40"

section {* Storing native words in datatypes *}

text {*
  The above lifting is necessary for all functions whose type mentions
  the word type. Fortunately, we do not have to duplicate functions that
  merely operate on datatypes that contain words. Nevertheless, we have
  to tell the code generator that these functions should call the new ones,
  which operate on machine words. This section shows how to achieve this
  with data refinement.
*}

subsection {* Example: expressions and two semantics *}

text {*
  As the running example, we consider a language of expressions (literal values, less-than comparisions and conditional) where values are either booleans or 32-bit words.
  The original specification uses the type @{typ "32 word"}.
*}

datatype val = Bool bool | Word "32 word"
datatype expr = Lit val | LT expr expr | IF expr expr expr

abbreviation (input) word :: "32 word \<Rightarrow> expr" where "word i \<equiv> Lit (Word i)"
abbreviation (input) bool :: "bool \<Rightarrow> expr" where "bool i \<equiv> Lit (Bool i)"

-- {* Denotational semantics of expressions, @{term None} denotes a type error *}
fun eval :: "expr \<Rightarrow> val option" where
  "eval (Lit v) = Some v"
| "eval (LT e\<^sub>1 e\<^sub>2) =
  (case (eval e\<^sub>1, eval e\<^sub>2)
   of (Some (Word i\<^sub>1), Some (Word i\<^sub>2)) \<Rightarrow> Some (Bool (i\<^sub>1 < i\<^sub>2))
   | _ \<Rightarrow> None)"
| "eval (IF e\<^sub>1 e\<^sub>2 e\<^sub>3) =
  (case eval e\<^sub>1 of Some (Bool b) \<Rightarrow> if b then eval e\<^sub>2 else eval e\<^sub>3
   | _ \<Rightarrow> None)"

-- {* Small-step semantics of expressions, it gets stuck upon type errors. *}
inductive step :: "expr \<Rightarrow> expr \<Rightarrow> bool" ("_ \<rightarrow> _" [50, 50] 60) where
  "e \<rightarrow> e' \<Longrightarrow> LT e e\<^sub>2 \<rightarrow> LT e' e\<^sub>2"
| "e \<rightarrow> e' \<Longrightarrow> LT (word i) e \<rightarrow> LT (word i) e'"
| "LT (word i\<^sub>1) (word i\<^sub>2) \<rightarrow> bool (i\<^sub>1 < i\<^sub>2)"
| "e \<rightarrow> e' \<Longrightarrow> IF e e\<^sub>1 e\<^sub>2 \<rightarrow> IF e' e\<^sub>1 e\<^sub>2"
| "IF (bool True) e\<^sub>1 e\<^sub>2 \<rightarrow> e\<^sub>1"
| "IF (bool False) e\<^sub>1 e\<^sub>2 \<rightarrow> e\<^sub>2"

-- {* Compile the inductive definition with the predicate compiler *}
code_pred (modes: i \<Rightarrow> o \<Rightarrow> bool as reduce, i \<Rightarrow> i \<Rightarrow> bool as step') step .

subsection {* Change the datatype to use machine words *}

text {*
  Now, we want to use @{typ uint32} instead of @{typ "32 word"}.
  The goal is to make the code generator use the new type without
  duplicating any of the types (@{typ val}, @{typ expr}) or the
  functions (@{term eval}, @{term reduce}) on such types.

  The constructor @{term Word} has @{typ "32 word"} in its type, so
  we have to lift it to @{text "Word'"}, and the same holds for the
  case combinator @{term case_val}, which @{term case_val'} replaces.%
  \footnote{%
    Note that we should not declare a case translation for the new
    case combinator because this will break parsing case expressions
    with old case combinator.
  }
  Next, we set up the code generator accordingly:
  @{term Bool} and @{term Word'} are the new constructors for @{typ val},
  and @{term case_val'} is the new case combinator with an appropriate
  case certificate.%
  \footnote{%
    Case certificates tell the code generator to replace the HOL
    case combinator for a datatype with the case combinator of the
    target language.  Without a case certificate, the code generator
    generates a function that re-implements the case combinator;
    in a strict languages like ML or Scala, this means that the code
    evaluates all possible cases before it decides which one is taken.

    Case certificates are described in Haftmann's PhD thesis
    \cite[Def.\ 27]{Haftmann2009PhD}. For a datatype @{text dt}
    with constructors @{text "C\<^sub>1"} to @{text "C\<^sub>n"}
    where each constructor @{text "C\<^sub>i"} takes @{text "k\<^sub>i"} parameters,
    the certificate for the case combinator @{text "case_dt"}
    looks as follows:

    {
      \isamarkuptrue\isacommand{lemma}\isamarkupfalse\isanewline%
      \ \ \isakeyword{assumes}\ {\isachardoublequoteopen}CASE\ {\isasymequiv}\ dt{\isacharunderscore}case\ c\isactrlsub {\isadigit{1}}\ c\isactrlsub {\isadigit{2}}\ \ldots\ c\isactrlsub{n}{\isachardoublequoteclose}\isanewline
      \ \ \isakeyword{shows}\ {\isachardoublequoteopen}{\isacharparenleft}CASE\ {\isacharparenleft}C\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{1}}\isactrlsub {k\ensuremath{{}_1}}{\isacharparenright}\ {\isasymequiv}\ c\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{1}}\isactrlsub {k\ensuremath{{}_1}}{\isacharparenright}\isanewline
      \ \ \ \ {\isacharampersand}{\isacharampersand}{\isacharampersand}\ {\isacharparenleft}CASE\ {\isacharparenleft}C\isactrlsub {\isadigit{2}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{2}}\isactrlsub {k\ensuremath{{}_2}}{\isacharparenright}\ {\isasymequiv}\ c\isactrlsub {\isadigit{2}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{2}}\isactrlsub {k\ensuremath{{}_2}}{\isacharparenright}\isanewline
      \ \ \ \ {\isacharampersand}{\isacharampersand}{\isacharampersand}\ \ldots\isanewline
      \ \ \ \ {\isacharampersand}{\isacharampersand}{\isacharampersand}\ {\isacharparenleft}CASE\ {\isacharparenleft}C\isactrlsub {n}\ a\isactrlsub {n}\isactrlsub {\isadigit{1}}\ a\isactrlsub {n}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {n}\isactrlsub {k\ensuremath{{}_n}}{\isacharparenright}\ {\isasymequiv}\ c\isactrlsub {n}\ a\isactrlsub {n}\isactrlsub {\isadigit{1}}\ a\isactrlsub {n}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {n}\isactrlsub {k\ensuremath{{}_n}}{\isacharparenright}{\isachardoublequoteclose}\isanewline
    }
  }
  We delete the code equations for the old constructor @{term Word}
  and case combinator @{term case_val} such that the code generator
  reports missing adaptations.
*}

lift_definition Word' :: "uint32 \<Rightarrow> val" is Word .

code_datatype Bool Word'

lift_definition case_val' :: "(bool \<Rightarrow> 'a) \<Rightarrow> (uint32 \<Rightarrow> 'a) \<Rightarrow> val \<Rightarrow> 'a" is case_val .

lemmas [code, simp] = val.case [Transfer.transferred]

lemma case_val'_cert:
  fixes bool word' b w
  assumes "CASE \<equiv> case_val' bool word'"
  shows "(CASE (Bool b) \<equiv> bool b) &&& (CASE (Word' w) \<equiv> word' w)"
  by (simp_all add: assms)

setup \<open>Code.declare_case_global @{thm case_val'_cert}\<close>

declare [[code drop: case_val Word]]

subsection {* Make functions use functions on machine words *}

text {*
  Finally, we merely have to change the code equations to use the
  new functions that operate on @{typ uint32}. As before, the
  attribute @{text Transfer.transferred} does the job. In our example,
  we adapt the equality test on @{typ val} (code equations
  @{thm [source] val.eq.simps}) and the denotational and small-step
  semantics (code equations @{thm [source] eval.simps} and
  @{thm [source] step.equation}, respectively).

  We check that the adaptation has suceeded by exporting the functions.
  As we only use native word sizes that PolyML supports, we can use
  the usual target @{text "SML"} instead of @{text "SML_word"}.
*}

lemmas [code] =
  val.eq.simps[THEN meta_eq_to_obj_eq, Transfer.transferred, THEN eq_reflection]
  eval.simps[Transfer.transferred]
  step.equation[Transfer.transferred]

export_code reduce step' eval in SML

section {* Troubleshooting *}

text {*
  This section explains some possible problems when using native words.
  If you experience other difficulties, please contact the author.
*}

subsection {* @{text export_code} raises an exception \label{section:export_code:exception} *}

text {*
  Probably, you have defined and are using a function on a native word type,
  but the code equation refers to emulated words. For example, the following
  defines a function @{text double} that doubles a word. When we try to export
  code for @{text double} without any further setup, @{text export_code} will
  raise an exception or generate code that does not compile.
*}

lift_definition double :: "uint32 \<Rightarrow> uint32" is "\<lambda>x. x + x" .

text {*
  We have to prove a code equation that only uses the existing operations on
  @{typ uint32}. Then, @{text export_code} works again.
*}

lemma double_code [code]: "double n = n + n"
by transfer simp

subsection {* The generated code does not compile *}

text {*
  Probably, you have been exporting to a target language for which there
  is no setup, or your compiler does not provide the required API. Every
  theory for native words mentions at the start the limitations on code
  generation. Check that your concrete application meets all the
  requirements.

  Alternatively, this might be an instance of the problem described
  in \S\ref{section:export_code:exception}.

  For Haskell, you have to enable the extension TypeSynonymInstances with \texttt{-XTypeSynonymInstances}
  if you are using polymorphic bit operations on the native word types.
*}

subsection {* The generated code is too slow *}

text {*
  The generated code will most likely not be as fast as a direct implementation in the target language with manual tuning.
  This is because we want the configuration of the code generation to be sound (as it can be used to prove theorems in Isabelle).
  Therefore, the bit operations sometimes perform range checks before they call the target language API.
  Here are some examples:
  \begin{itemize}
  \item Shift distances and bit indices in target languages are often expected to fit into a bounded integer or word.
    However, the size of these types varies across target languages and platforms.
    Hence, no Isabelle/HOL type can model uniformly all of them.
    Instead, the bit operations use arbitrary-precision integers for such quantities and check at run-time that the values fit into a bounded integer or word, respectively -- if not, they raise an exception.

  \item Division and modulo operations explicitly test whether the divisor is $0$ and return the HOL value of division by $0$ in that case.
    This is necessary because some languages leave the behaviour of division by 0 unspecified.
  \end{itemize}

  If you have better ideas how to eliminate such checks and speed up the generated code without sacrificing soundness, please contact the author!
*}

(*<*)end(*>*)


section \<open>Soundness Theorems\<close>

theory Wasm_Soundness imports Main Wasm_Properties begin

theorem preservation:
  assumes "\<turnstile>_i s;vs;es : ts"
          "\<lparr>s;vs;es\<rparr> \<leadsto>_i \<lparr>s';vs';es'\<rparr>"
  shows "\<turnstile>_i s';vs';es' : ts"
proof -
  obtain \<S> where "store_typing s \<S>" "\<S>\<bullet>None \<tturnstile>_i vs;es : ts"
    using assms(1) config_typing.simps
    by blast
  hence "store_typing s' \<S>" "\<S>\<bullet>None \<tturnstile>_i vs';es' : ts"
    using assms(2) store_preserved types_preserved_e
    by simp_all
  thus ?thesis
    using config_typing.intros
    by blast
qed

theorem progress:
  assumes "\<turnstile>_i s;vs;es : ts"
  shows "const_list es \<or> es = [Trap] \<or> (\<exists>a s' vs' es'. \<lparr>s;vs;es\<rparr> \<leadsto>_i \<lparr>s';vs';es'\<rparr>)"
proof -
  obtain \<S> where "store_typing s \<S>" "\<S>\<bullet>None \<tturnstile>_i vs;es : ts"
    using assms config_typing.simps
    by blast
  thus ?thesis
    using progress_e4
    by blast
qed

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Strong_Late_Bisim_Pres
  imports Strong_Late_Bisim Strong_Late_Sim_Pres
begin

lemma tauPres:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim> Q"

  shows "\<tau>.(P) \<sim> \<tau>.(Q)"
proof -
  let ?X = "{(\<tau>.(P), \<tau>.(Q)), (\<tau>.(Q), \<tau>.(P))}"
  have "(\<tau>.(P), \<tau>.(Q)) \<in> ?X" by auto
  thus ?thesis using `P \<sim> Q`
    by(coinduct rule: bisimCoinduct)
      (auto intro: Strong_Late_Sim_Pres.tauPres dest: symmetric)
qed

lemma inputPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   x :: name

  assumes PSimQ: "\<forall>y. P[x::=y] \<sim> Q[x::=y]"

  shows "a<x>.P \<sim> a<x>.Q"
proof -
  let ?X = "{(a<x>.P, a<x>.Q) | a x P Q. \<forall>y. P[x::=y] \<sim> Q[x::=y]}"
  {
    fix axP axQ p
    assume "(axP, axQ) \<in> ?X"
    then obtain a x P Q where A: "\<forall>y. P[x::=y] \<sim> Q[x::=y]" and B: "axP = a<x>.P" and C: "axQ = a<x>.Q"
      by auto
    have "\<And>y. ((p::name prm) \<bullet> P)[(p \<bullet> x)::=y] \<sim> (p \<bullet> Q)[(p \<bullet> x)::=y]"
    proof -
      fix y
      from A have "P[x::=(rev p \<bullet> y)] \<sim> Q[x::=(rev p \<bullet> y)]"
        by blast
      hence "(p \<bullet> (P[x::=(rev p \<bullet> y)])) \<sim> p \<bullet> (Q[x::=(rev p \<bullet> y)])"
        by(rule bisimClosed)
      thus "(p \<bullet> P)[(p \<bullet> x)::=y] \<sim> (p \<bullet> Q)[(p \<bullet> x)::=y]"
        by(simp add: eqvts pt_pi_rev[OF pt_name_inst, OF at_name_inst])
    qed
    hence "((p::name prm) \<bullet> axP, p \<bullet> axQ) \<in> ?X" using B C
      by auto
  }
  hence "eqvt ?X" by(simp add: eqvt_def)

  from PSimQ have "(a<x>.P, a<x>.Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: bisimCoinduct)
    case(cSim P Q)
    thus ?case using `eqvt ?X`
      by(force intro: inputPres)
  next
    case(cSym P Q)
    thus ?case
      by(blast dest: symmetric)
  qed
qed

lemma outputPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   b :: name

  assumes "P \<sim> Q"

  shows "a{b}.P \<sim> a{b}.Q"
proof -
  let ?X = "{(a{b}.P, a{b}.Q), (a{b}.Q, a{b}.P)}"
  have "(a{b}.P, a{b}.Q) \<in> ?X" by auto
  thus ?thesis using `P \<sim> Q`
    by(coinduct rule: bisimCoinduct)
      (auto intro: Strong_Late_Sim_Pres.outputPres dest: symmetric)
qed

  assumes "P \<sim> Q"

  shows "[a\<frown>b]P \<sim> [a\<frown>b]Q"
proof -
  let ?X = "{([a\<frown>b]P, [a\<frown>b]Q), ([a\<frown>b]Q, [a\<frown>b]P)}"
  have "([a\<frown>b]P, [a\<frown>b]Q) \<in> ?X" by auto
  thus ?thesis using `P \<sim> Q`
    by(coinduct rule: bisimCoinduct)
      (auto intro: Strong_Late_Sim_Pres.matchPres dest: symmetric bisimE)
qed

lemma mismatchPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   b :: name

  assumes "P \<sim> Q"

  shows "[a\<noteq>b]P \<sim> [a\<noteq>b]Q"
proof -
  let ?X = "{([a\<noteq>b]P, [a\<noteq>b]Q), ([a\<noteq>b]Q, [a\<noteq>b]P)}"
  have "([a\<noteq>b]P, [a\<noteq>b]Q) \<in> ?X" by auto
  thus ?thesis using `P \<sim> Q`
    by(coinduct rule: bisimCoinduct)
      (auto intro: Strong_Late_Sim_Pres.mismatchPres dest: symmetric bisimE)
qed

lemma sumPres:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  assumes "P \<sim> Q"

  shows "P \<oplus> R \<sim> Q \<oplus> R"
proof -
  let ?X = "{(P \<oplus> R, Q \<oplus> R), (Q \<oplus> R, P \<oplus> R)}"
  have "(P \<oplus> R, Q \<oplus> R) \<in> ?X" by auto
  thus ?thesis using `P \<sim> Q`
    by(coinduct rule: bisimCoinduct)
      (auto intro: Strong_Late_Sim_Pres.sumPres reflexive dest: symmetric bisimE)
qed

  shows "<\<nu>x>P \<sim> <\<nu>x>Q"
proof -
  let ?X = "{x. \<exists>P Q. P \<sim> Q \<and> (\<exists>a. x = (<\<nu>a>P, <\<nu>a>Q))}"
  from `P \<sim> Q` have "(<\<nu>x>P, <\<nu>x>Q) \<in> ?X" by blast
  thus ?thesis
  proof(coinduct rule: bisimCoinduct)
    case(cSim xP xQ)
    {
      fix P Q a
      assume PSimQ: "P \<leadsto>[bisim] Q"
      moreover have "\<And>P Q a. P \<sim> Q \<Longrightarrow> (<\<nu>a>P, <\<nu>a>Q) \<in> ?X \<union> bisim" by blast
      moreover have "bisim \<subseteq> ?X \<union> bisim" by blast
      moreover have "eqvt bisim" by simp
      moreover have "eqvt ?X"
        by(auto simp add: eqvt_def) (blast intro: bisimClosed)
      hence "eqvt (?X \<union> bisim)" by auto
      ultimately have "<\<nu>a>P \<leadsto>[(?X \<union> bisim)] <\<nu>a>Q"
        by(rule Strong_Late_Sim_Pres.resPres)
    }
    with `(xP, xQ) \<in> ?X` show ?case
      by(auto dest: bisimE)
  next
    case(cSym xP xQ)
    thus ?case by(auto dest: symmetric)
  qed
qed

lemma parPres:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  assumes "P \<sim> Q"

  shows "P \<parallel> R \<sim> Q \<parallel> R"
proof -
  let ?X = "{(resChain lst (P \<parallel> R), resChain lst (Q \<parallel> R)) | lst P R Q. P \<sim> Q}"
  have EmptyChain: "\<And>P Q. P \<parallel> Q = resChain [] (P \<parallel> Q)" by auto
  with `P \<sim> Q` have "(P \<parallel> R, Q \<parallel> R) \<in> ?X" by blast
  thus ?thesis
  proof(coinduct rule: bisimCoinduct)
    case(cSim PR QR)
    {
      fix P Q R lst

      assume "P \<sim> Q"

      hence "P \<leadsto>[bisim] Q" by(rule bisimE)
      moreover note `P \<sim> Q`
      moreover have "\<And>P Q R. P \<sim> Q \<Longrightarrow> (P \<parallel> R, Q \<parallel> R) \<in> ?X"
        by auto (blast intro: EmptyChain)
      moreover
      {
        fix xP xQ x
        assume "(xP, xQ) \<in> ?X"
        then obtain P Q R lst
          where "P \<sim> Q" and "xP = resChain lst (P \<parallel> R)" and xQeq: "xQ = resChain lst (Q \<parallel> R)"
          by auto
        moreover hence "(resChain (x#lst) (P \<parallel> R), resChain (x#lst) (Q \<parallel> R)) \<in> ?X"
          by blast
        ultimately have "(<\<nu>x>xP, <\<nu>x>xQ) \<in> ?X" by auto
      }
      note ResPres = this
      moreover have "eqvt bisim" by simp
      moreover have "eqvt ?X"
        by(auto simp add: eqvt_def) (blast intro: bisimClosed)
      ultimately have "P \<parallel> R \<leadsto>[(?X)] Q \<parallel> R" by(rule parPres)
      hence "resChain lst (P \<parallel> R) \<leadsto>[?X] (resChain lst (Q \<parallel> R))" using `eqvt ?X` ResPres
        by(rule resChainI)
      hence "resChain lst (P \<parallel> R) \<leadsto>[(?X \<union> bisim)] (resChain lst (Q \<parallel> R))"
        by(force intro: Strong_Late_Sim.monotonic)
    }
    with `(PR, QR) \<in> ?X` show ?case
      by auto
  next
    case(cSym PR QR)
    thus ?case by(blast dest: symmetric)
  qed
qed

  assumes PBiSimQ: "P \<sim> Q"

  shows "!P \<sim> !Q"
proof -
  let ?X = "bangRel bisim"
  from PBiSimQ have "(!P, !Q) \<in> ?X" by(rule Rel.BRBang)
  thus ?thesis
  proof(coinduct rule: bisimCoinduct)
    case(cSim bP bQ)
    {
      fix P Q
      assume "(P, Q) \<in> ?X"
      hence "P \<leadsto>[?X] Q"
      proof(induct)
        fix P Q
        assume "P \<sim> Q"
        thus "!P \<leadsto>[?X] !Q" using bisimE bisimEqvt
          by(rule Strong_Late_Sim_Pres.bangPres)
      next
        fix P Q R T
        assume RBiSimT: "R \<sim> T"
        assume PBangRelQ: "(P, Q) \<in> ?X"
        assume PSimQ: "P \<leadsto>[?X] Q"
        from RBiSimT  have "R \<leadsto>[bisim] T" by(blast dest: bisimE)
        thus "R \<parallel> P \<leadsto>[?X] T \<parallel> Q" using PSimQ RBiSimT PBangRelQ Rel.BRPar Rel.BRRes bisimEqvt eqvtBangRel
          by(blast intro: Strong_Late_Sim_Pres.parCompose)
      next
        fix P Q a
        assume "P \<leadsto>[?X] Q"
        moreover from eqvtBangRel bisimEqvt have "eqvt ?X" by blast
        ultimately show "<\<nu>a>P \<leadsto>[?X] <\<nu>a>Q" using Rel.BRRes by(blast intro: Strong_Late_Sim_Pres.resPres)
      qed
      hence "P \<leadsto>[((bangRel bisim) \<union> bisim)] Q" by(rule_tac Strong_Late_Sim.monotonic) auto
    }
    with `(bP, bQ) \<in> ?X` show ?case by auto
  next
    case(cSym bP bQ)
    thus ?case by(metis bangRelSymetric symmetric)
  qed
qed

end


(*  Title:      HOL/MicroJava/BV/BVSpec.thy

    Author:     Cornelia Pusch, Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen

*)

header {* \isaheader{The Bytecode Verifier}\label{sec:BVSpec} *}

theory BVSpec
imports Effect
begin

text {*
  This theory contains a specification of the BV. The specification
  describes correct typings of method bodies; it corresponds
  to type \emph{checking}.
*}

definition
  -- "The method type only contains declared classes:"
  check_types :: "'m prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err list \<Rightarrow> bool"
where
  "check_types P mxs mxl \<tau>s \<equiv> set \<tau>s \<subseteq> states P mxs mxl"

  -- "An instruction is welltyped if it is applicable and its effect"
  -- "is compatible with the type at all successor instructions:"
definition
  wt_instr :: "['m prog,ty,nat,pc,ex_table,instr,pc,ty\<^sub>m] \<Rightarrow> bool"
  ("_,_,_,_,_ \<turnstile> _,_ :: _" [60,0,0,0,0,0,0,61] 60)
where
  "P,T,mxs,mpc,xt \<turnstile> i,pc :: \<tau>s \<equiv>
  app i P mxs T pc mpc xt (\<tau>s!pc) \<and>
  (\<forall>(pc',\<tau>') \<in> set (eff i P pc xt (\<tau>s!pc)). P \<turnstile> \<tau>' \<le>' \<tau>s!pc')"

  -- {* The type at @{text "pc=0"} conforms to the method calling convention: *}
definition wt_start :: "['m prog,cname,ty list,nat,ty\<^sub>m] \<Rightarrow> bool"
where
  "wt_start P C Ts mxl\<^sub>0 \<tau>s \<equiv>
  P \<turnstile> Some ([],OK (Class C)#map OK Ts@replicate mxl\<^sub>0 Err) \<le>' \<tau>s!0"

  -- "A method is welltyped if the body is not empty,"
  -- "if the method type covers all instructions and mentions"
  -- "declared classes only, if the method calling convention is respected, and"
  -- "if all instructions are welltyped."
definition wt_method :: "['m prog,cname,ty list,ty,nat,nat,instr list,
                 ex_table,ty\<^sub>m] \<Rightarrow> bool"
where
  "wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s \<equiv>
  0 < size is \<and> size \<tau>s = size is \<and>
  check_types P mxs (1+size Ts+mxl\<^sub>0) (map OK \<tau>s) \<and>
  wt_start P C Ts mxl\<^sub>0 \<tau>s \<and>
  (\<forall>pc < size is. P,T\<^sub>r,mxs,size is,xt \<turnstile> is!pc,pc :: \<tau>s)"

  -- "A program is welltyped if it is wellformed and all methods are welltyped"
definition  wf_jvm_prog_phi :: "ty\<^sub>P \<Rightarrow> jvm_prog \<Rightarrow> bool" ("wf'_jvm'_prog\<^bsub>_\<^esub>")
where
  "wf_jvm_prog\<^bsub>\<Phi>\<^esub> \<equiv>
    wf_prog (\<lambda>P C (M,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,is,xt)).
      wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt (\<Phi> C M))"

definition wf_jvm_prog :: "jvm_prog \<Rightarrow> bool"
where
  "wf_jvm_prog P \<equiv> \<exists>\<Phi>. wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"

lemma wt_jvm_progD:
  "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P \<Longrightarrow> \<exists>wt. wf_prog wt P"
(*<*) by (unfold wf_jvm_prog_phi_def, blast) (*>*)

lemma wt_jvm_prog_impl_wt_instr:
  "\<lbrakk> wf_jvm_prog\<^bsub>\<Phi>\<^esub> P;
      P \<turnstile> C sees M:Ts \<rightarrow> T = (mxs,mxl\<^sub>0,ins,xt) in C; pc < size ins \<rbrakk>
  \<Longrightarrow> P,T,mxs,size ins,xt \<turnstile> ins!pc,pc :: \<Phi> C M"
(*<*)
  apply (unfold wf_jvm_prog_phi_def)
  apply (drule (1) sees_wf_mdecl)
  apply (simp add: wf_mdecl_def wt_method_def)
  done
(*>*)

lemma wt_jvm_prog_impl_wt_start:
  "\<lbrakk> wf_jvm_prog\<^bsub>\<Phi>\<^esub> P;
     P \<turnstile> C sees M:Ts \<rightarrow> T = (mxs,mxl\<^sub>0,ins,xt) in C \<rbrakk> \<Longrightarrow>
  0 < size ins \<and> wt_start P C Ts mxl\<^sub>0 (\<Phi> C M)"
(*<*)
  apply (unfold wf_jvm_prog_phi_def)
  apply (drule (1) sees_wf_mdecl)
  apply (simp add: wf_mdecl_def wt_method_def)
  done
(*>*)

end