chapter \<open>IMP with Arrays\<close>
theory IMPArrayHoarePartial
imports
  Main
  "~~/src/HOL/Library/Monad_Syntax"
  "~~/src/HOL/Eisbach/Eisbach"
  "~~/src/HOL/Library/Rewrite"
begin

text \<open>
  Extension of IMP by generalized arrays and the common arithmetic and Boolean operations.

  In this language, each variable stores a map from integers to integers.

  Initially, all integers are mapped to zero.

  In an expression, and on the LHS of an assignment, only indexed variables are allowed.
  That is, all expressions compute with single integers.
  \<open> x[3] ::= y[0] + 5 \<close>

  The Clear operation resets the mapping of a variable to all zeroes.
  \<open>CLR x\<close>

  If the index is omitted, variables are indexed at zero.
  This allows to use the variables as if they held single values.
  \<open>x ::= y + 5\<close> is the same as \<open>x[0] ::= y[0] + 5\<close>

  Summarized:
    \<^item> Every variable is an array, but, by default, we only use index zero.
    \<^item> Arrays can be indexed by arbitrary integers (including negative ones),
      and dynamically grow as needed.
\<close>

section \<open>Miscellaneous\<close>
(* Required to "instantiate" existential without introducing new variable,
  which would not unify with already introduced schematic *)
lemma ex_eq_some: "(\<exists>x. P x) \<longleftrightarrow> P (SOME x. P x)"
  by (meson someI)

section \<open>Syntax\<close>

subsection \<open>Variables and Constants\<close>
type_synonym vname = string

type_synonym val = int

subsection \<open>Arithmetic Expressions\<close>
datatype aexp =
    N int            -- \<open>Constant\<close>
  | V vname aexp     -- \<open>Array at index \<open>x[i]\<close>\<close>
  | Binop "int \<Rightarrow> int \<Rightarrow> int" aexp aexp -- \<open>Binary operation\<close>

abbreviation "V0 x \<equiv> V (x) (N 0)" -- \<open>Abbreviation for \<open>x[0]\<close>\<close>

abbreviation "Plus \<equiv> Binop (op+)"
abbreviation "Minus \<equiv> Binop (op-)"
abbreviation "Times \<equiv> Binop (op*)"

text \<open>Warning, the following two also give defined results on division by zero!\<close>
value "a div (0::int)" value "a mod (0::int)"
abbreviation "Div \<equiv> Binop (op div)"
abbreviation "Mod \<equiv> Binop (op mod)"

subsection \<open>Boolean Expressions\<close>
datatype bexp =
    Bc bool    -- \<open>True or False\<close>
  | Not bexp   -- \<open>Negation\<close>
  | BBop "bool\<Rightarrow>bool\<Rightarrow>bool" bexp bexp   -- \<open>Binary boolean operation\<close>
  | Cmpop "int \<Rightarrow> int \<Rightarrow> bool" aexp aexp -- \<open>Comparison operation\<close>

abbreviation "And \<equiv> BBop op \<and>"
abbreviation "Or \<equiv> BBop op \<or>"
abbreviation "BNEq \<equiv> BBop op \<noteq>"
abbreviation "BEq \<equiv> BBop op \<longleftrightarrow>"

abbreviation "Less \<equiv> Cmpop op <"
abbreviation "Leq \<equiv> Cmpop op \<le>"
abbreviation "Greater \<equiv> Cmpop op >"
abbreviation "Geq \<equiv> Cmpop op \<ge>"
abbreviation "Equal \<equiv> Cmpop op ="
abbreviation "NEqual \<equiv> Cmpop op \<noteq>"

subsection \<open>Commands\<close>

datatype
  com = SKIP
      | Assign vname aexp aexp  -- \<open> Assignment to index of array. \<open>x[i] = a\<close>\<close>
      | Clear  vname            -- \<open> Set all indices of array to 0\<close>
      | Seq    com  com         -- \<open> Sequential composition \<open>c\<^sub>1; c\<^sub>2\<close>\<close>
      | If     bexp com com     -- \<open> Conditional. \<open>if (b) c\<^sub>1 else c\<^sub>2\<close>\<close>
      | While  bexp com         -- \<open> While loop. \<open>while (b) c\<close>\<close>

subsection \<open>Concrete Syntax\<close>

text \<open>Like the original IMP, we only expose a minimal syntax for commands by default\<close>

notation
  Assign  ("_[_] ::= _" [1000,900, 41] 41) and
  Clear   ("CLR _" [41] 41) and
  Seq     ("_;;/ _"  [40, 41] 40) and
  If      ("(IF _/ THEN _/ ELSE _)"  [0, 0, 41] 41) and
  While   ("(WHILE _/ DO _)"  [0, 41] 41)

text \<open>Shortcut notation for assigning to index 0. \<close>
abbreviation Assign0 ("_ ::= _" [1000, 41] 41)
  where "x ::= v \<equiv> (x[N 0] ::= v)"

abbreviation true where "true \<equiv> Bc True"
abbreviation false where "false \<equiv> Bc False"

text \<open>
  However, we provide a bundle with somewhat more fancy syntax.
\<close>

abbreviation (input) "IMP_Variable \<equiv> V0"
syntax "_IMPVariable" :: "idt \<Rightarrow> aexp"
translations "CONST IMP_Variable" \<rightharpoonup> "_IMPVariable"

abbreviation (input) "IMP_VariableI \<equiv> V"
syntax "_IMPVariableI" :: "idt \<Rightarrow> aexp \<Rightarrow> aexp"
translations "CONST IMP_VariableI" \<rightharpoonup> "_IMPVariableI"

abbreviation (input) "IMP_Assign x v \<equiv> Assign x (N 0) v"
syntax "_IMPAssign" :: "idt \<Rightarrow> aexp \<Rightarrow> com"
translations "CONST IMP_Assign" \<rightharpoonup> "_IMPAssign"

abbreviation (input) "IMP_AssignI x i v \<equiv> Assign x i v"
syntax "_IMPAssignI" :: "idt \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> com"
translations "CONST IMP_AssignI" \<rightharpoonup> "_IMPAssignI"

abbreviation (input) "IMP_Clear x \<equiv> Clear x"
syntax "_IMPClear" :: "idt \<Rightarrow> com"
translations "CONST IMP_Clear" \<rightharpoonup> "_IMPClear"

ML \<open>
  structure IMP_Translation = struct

    val cfg_var_syntax = Attrib.setup_config_bool @{binding IMP_var_syntax} (K false)

    fun
      var_tr ctxt [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u] =
        c $ var_tr ctxt [t] $ u
    | var_tr _ [Free (str,_)] = Syntax.const (@{const_syntax V0}) $ HOLogic.mk_string str
    | var_tr _ ts = raise (TERM ("IMP_Variable",ts))

    fun
      vari_tr ctxt [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u, it] =
        c $ vari_tr ctxt [t,it] $ u
    | vari_tr _ [Free (str,_),it] = Syntax.const (@{const_syntax V}) $ HOLogic.mk_string str $ it
    | vari_tr _ ts = raise (TERM ("IMP_VariableI",ts))

    fun
      ass_tr ctxt [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u, rhst] =
        c $ ass_tr ctxt [t,rhst] $ u
    | ass_tr _ [Free (str,_),rhst] = Syntax.const (@{const_syntax Assign0}) $ HOLogic.mk_string str $ rhst
    | ass_tr _ ts = raise (TERM ("IMP_AssignI",ts))

    fun
      assi_tr ctxt [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u, it, rhst] =
        c $ assi_tr ctxt [t,it,rhst] $ u
    | assi_tr _ [Free (str,_),it,rhst] = Syntax.const (@{const_syntax Assign}) $ HOLogic.mk_string str $ it $ rhst
    | assi_tr _ ts = raise (TERM ("IMP_Assign",ts))

    fun
      clr_tr ctxt [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u] =
        c $ clr_tr ctxt [t] $ u
    | clr_tr _ [Free (str,_)] = Syntax.const (@{const_syntax Clear}) $ HOLogic.mk_string str
    | clr_tr _ ts = raise (TERM ("IMP_Clear",ts))

    fun
      dest_list_syntax (Const (@{const_syntax List.Cons},_)$x$xs)
        = x::dest_list_syntax xs
    | dest_list_syntax (Const (@{const_syntax List.Nil},_)) = []
    | dest_list_syntax _ = raise Match

    fun
      dest_char_syntax (Const (@{const_syntax String.Char}, _) $ c) =
        let
          val n = Numeral.dest_num_syntax c
          val s = chr n
        in
          s
        end
    | dest_char_syntax _ = raise Match

    fun dest_var_syntax t = let
      val s =
          dest_list_syntax t
        |> map dest_char_syntax
        |> implode
      val _ = Symbol.is_ascii_identifier s orelse raise Match
    in
      s
    end

    fun
      var_tr' _ [t:term] =
        Syntax.const @{const_syntax "IMP_Variable"} $ Syntax.const (dest_var_syntax t)
    | var_tr' _ [t:term,it] =
        Syntax.const @{const_syntax "IMP_VariableI"} $ Syntax.const (dest_var_syntax t) $ it
    | var_tr' _ _ = raise Match

    fun
      ass_tr' _ [t:term,vt] =
        Syntax.const @{const_syntax "IMP_Assign"} $ Syntax.const (dest_var_syntax t) $ vt
    | ass_tr' _ [t:term,it,vt] =
        Syntax.const @{const_syntax "IMP_AssignI"} $ Syntax.const (dest_var_syntax t) $ it $ vt
    | ass_tr' _ _ = raise Match

    fun
      clr_tr' _ [t:term] =
        Syntax.const @{const_syntax "IMP_Clear"} $ Syntax.const (dest_var_syntax t)
    | clr_tr' _ _ = raise Match

    fun if_var_syntax f ctxt =
      if Config.get ctxt cfg_var_syntax then
        f ctxt
      else
        raise Match

    val _ = Theory.setup (
      Sign.print_translation [
        (@{const_syntax "V0"}, if_var_syntax var_tr'),
        (@{const_syntax "V"}, if_var_syntax var_tr'),
        (@{const_syntax "Assign0"}, if_var_syntax ass_tr'),
        (@{const_syntax "Assign"}, if_var_syntax ass_tr'),
        (@{const_syntax "Clear"}, if_var_syntax clr_tr')
      ]
    )
    val _ = Theory.setup (
      Sign.parse_translation [
        (@{syntax_const "_IMPVariable"}, if_var_syntax var_tr),
        (@{syntax_const "_IMPVariableI"}, if_var_syntax vari_tr),
        (@{syntax_const "_IMPAssign"}, if_var_syntax ass_tr),
        (@{syntax_const "_IMPAssignI"}, if_var_syntax assi_tr),
        (@{syntax_const "_IMPClear"}, if_var_syntax clr_tr)
      ]
    )

  end
\<close>

consts
  eplus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  eminus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  etimes :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  edivide :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  emodulo :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  eequal :: "'a \<Rightarrow> 'a \<Rightarrow> 'b"
  neequal :: "'a \<Rightarrow> 'a \<Rightarrow> 'b"
  eless :: "'a \<Rightarrow> 'a \<Rightarrow> 'b"
  egreater :: "'a \<Rightarrow> 'a \<Rightarrow> 'b"

bundle IMP_Syntax begin

notation IMP_Variable ("$_" [100] 100)
notation IMP_VariableI ("_\<^bold>[_\<^bold>]" [100,100] 100)

no_notation
  Assign0 ("_ ::= _" [1000, 41] 41) and
  Assign  ("_[_] ::= _" [1000,900, 41] 41) and
  Clear   ("CLR _" [41] 41)

notation
  IMP_Assign ("_ ::= _" [1000, 41] 41) and
  IMP_AssignI  ("_\<^bold>[_\<^bold>] ::= _" [1000,0, 41] 41) and
  IMP_Clear   ("CLR _" [41] 41)

declare [[IMP_var_syntax]]

no_notation
  plus  (infixl "+" 65) and
  minus (infixl "-" 65) and
  times (infixl "*" 70) and
  divide (infixl "div" 70) and
  modulo (infixl "mod" 70)

notation
  eplus   (infixl "+" 65)   and
  eminus  (infixl "-" 65)   and
  etimes  (infixl "*" 70)   and
  edivide (infixl "div" 70) and
  emodulo (infixl "mod" 70)

adhoc_overloading eplus plus Plus
adhoc_overloading eminus minus Minus
adhoc_overloading etimes times Times
adhoc_overloading edivide divide Div
adhoc_overloading emodulo modulo Mod

notation Or (infixr "||" 30)
notation And (infixr "&&" 35)
notation Not ("!_" [90] 90)

no_notation "Pure.eq" (infix "==" 2)

notation
  eequal  (infix "==" 50) and
  neequal (infix "!=" 50)

adhoc_overloading eequal BEq Equal
adhoc_overloading neequal BNEq NEqual

no_notation
  less ("(_/ < _)"  [51, 51] 50) and
  greater  (infix ">" 50) and
  less_eq  ("(_/ <= _)" [51, 51] 50) and
  greater_eq  (infix ">=" 50)

notation
  eless ("(_/ < _)"  [51, 51] 50) and
  egreater (infix ">" 50)

adhoc_overloading eless less Less
adhoc_overloading egreater greater Greater

notation
  Leq  ("(_/ <= _)" [51, 51] 50) and
  Geq  (infix ">=" 50)

end

subsection \<open>Syntax Overview\<close>

text \<open>Activate the Syntax locally in a context\<close>
context
  includes IMP_Syntax
begin

  subsubsection \<open>Arithmetic expressions\<close>

  text \<open>Idiosyncrasies:
    \<^item> For array indexing, we use bold brackets \<open>\<^bold>[ \<^bold>]\<close>. Type \<open>\ bold [\<close> and \<open>\ bold ]\<close>
    \<^item> Prefixing a variable with \<open>$\<close> refers to index 0 of this variable.
      This way, variables, which hold maps, can conveniently be used as single values.
  \<close>

  term "$foo"       term "V0 ''foo''"
  term "bar\<^bold>[N 3\<^bold>]"   term "V ''bar'' (N 3)" -- \<open>Type "\ bold [" and "\ bold ]" \<close>
  term "$a + $b"        term "Plus (V0 ''a'') (V0 ''b'')"
  term "$a + $b * $c"   term "Plus (V0 ''a'') (Times (V0 ''b'') (V0 ''c''))"
  term "($a + $b) * $c" term "Times (Plus (V0 ''a'') (V0 ''b'')) (V0 ''c'')"

  term "a\<^bold>[$i\<^bold>] + $b - $c*$d div $e mod $f"

  text \<open>Boolean Expressions\<close>
  text \<open>Idiosyncrasies:
    \<^item> Not \<open>!\<close> binds with high priority, higher than any other operator
  \<close>

  term "$a < $b"
  term "$a > $b"
  term "$a <= $b"
  term "$a >= $b"
  term "$x == $y"
  term "$x != $y"

  term "true && false"
  term "true || false"
  term "true != false"
  term "true == true"

  term "(!true == false)  = ( (!true) == false )"
  term "!(true == false)"

  text \<open>Commands\<close>
  text \<open>Idiosyncrasies:
    \<^item> Using \<open>::=\<close> for assignment, and, again, bold brackets for array indexing
  \<close>

  term "CLR x"                term "Clear ''x''"
  term "x ::= $a + N 1"       term "Assign0 ''x'' (Plus (V0 ''a'') (N 1))"
  term "x\<^bold>[$i\<^bold>] ::= $a + N 1"   term "Assign ''x'' (V0 ''i'') (Plus (V0 ''a'') (N 1))"

  term "x ::= $a;; y ::= $b"
  term "IF $x<N 5 THEN SKIP ELSE x::=$x - N 1"
  term "WHILE $x<N 5 DO x::=$x + N 1"

end

subsection \<open>Example Program\<close>
locale Imp_Array_Examples begin
unbundle IMP_Syntax
abbreviation "array_sum \<equiv>
  CLR r;;             (* It's good practice to clear auxiliary variables before use *)
  r ::= N 0;;         (* Not strictly necessary, but documents that r is used as plain variable  *)
  WHILE $l < $h DO (
    r ::= $r + a\<^bold>[$l\<^bold>];;
    l ::= $l + (N 1)
  )"

term array_sum

end

section \<open>Semantics\<close>

subsection \<open>States and Configuration\<close>
text \<open>
  Each variable holds an unlimited amount of values, indexed by integers
\<close>
type_synonym state = "vname \<Rightarrow> (int \<Rightarrow> val)"
type_synonym config = "com \<times> state"

text {* A little syntax magic to write larger states compactly: *}

(* All variables hold zeroes initially.
*)
definition null_state ("<>") where
  "null_state \<equiv> \<lambda>_ _. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

lemma null_state_app[simp]: "<> x = (\<lambda>_. 0)" by (auto simp: null_state_def)

text \<open>Constructing a generalized array from a list\<close>
definition list :: "int list \<Rightarrow> int \<Rightarrow> int" where
  "list l i \<equiv> if 0\<le>i \<and> nat i<length l then l!nat i else 0"

text \<open>Plain variable: Value at index 0 only\<close>
abbreviation "var x \<equiv> list [x]"

lemma "var x i = (if i=0 then x else 0)" by (simp add: list_def)

lemma list_nth[simp]: "\<lbrakk>0\<le>i; nat i<length l\<rbrakk> \<Longrightarrow> list l i = l!nat i"
  by (auto simp: list_def)

lemma list_subst[simp]: "\<lbrakk> 0\<le>i; nat i<length l \<rbrakk> \<Longrightarrow> (list l)(i:=x) = list (l[nat i:=x])"
  by (auto simp: list_def intro!: ext)

lemma list_fold[simp]: "(\<lambda>_. 0)(0:=x) = var x"
  by (auto simp: list_def intro!: ext)

lemma list_inj[simp]: "length l = length l' \<Longrightarrow> list l = list l' \<longleftrightarrow> l=l'"
  apply (auto simp: list_def[abs_def] split: if_splits)
  by (metis (mono_tags, hide_lams) nat_int nth_equalityI of_nat_0_le_iff)

subsection \<open>Arithmetic Expressions\<close>

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x i) s = (s x) (aval i s)" |
"aval (Binop f a1 a2) s = f (aval a1 s) (aval a2 s)"

subsection \<open>Boolean Expressions\<close>

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s \<longleftrightarrow> v" |
"bval (Not b) s \<longleftrightarrow> \<not>(bval b s)" |
"bval (BBop f b1 b2) s \<longleftrightarrow> f (bval b1 s) (bval b2 s)" |
"bval (Cmpop f a1 a2) s \<longleftrightarrow> f (aval a1 s) (aval a2 s)"

subsection \<open>Big-Step\<close>

inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x[i] ::= a,s) \<Rightarrow> s(x := ((s x)(aval i s := aval a s)))" |
Clear: "(CLR x, s) \<Rightarrow> s(x:=(\<lambda>_. 0))" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s; (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"

subsubsection \<open>Automatic Derivation\<close>
text \<open>The following is a method to execute a configuration by deriving it's big-step semantics\<close>
method Bs_simp = simp add: list_def
method If = (rule IfTrue, (Bs_simp;fail)) | (rule IfFalse, (Bs_simp;fail))
method While = (rule WhileTrue, (Bs_simp;fail)) | (rule WhileFalse, (Bs_simp;fail))
method BigStep = simp?; ((rule Skip Assign Seq Clear) | If | While)
method BigSteps = BigStep+

context Imp_Array_Examples begin
  schematic_goal "(array_sum,<''l'':=list [1], ''h'':=list [5], ''a'':=list [100,1,2,3,4,200,300]>) \<Rightarrow> ?s"
    by BigSteps

end

subsubsection \<open>Proof Automation Setup\<close>
declare big_step.intros [intro]

lemmas big_step_induct = big_step.induct[split_format(complete)]

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"

inductive_cases AssignE[elim!]: "(x[i] ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases ClearE[elim!]: "(CLR x,s) \<Rightarrow> t"
thm ClearE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE
inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE

subsubsection \<open>Properties\<close>

text \<open>Sequential composition is associative\<close>
lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> s1" and
    c2: "(c2, s1) \<Rightarrow> s2" and
    c3: "(c3, s2) \<Rightarrow> s'" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> s'" by (rule Seq)
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> s'" by (rule Seq)
next
  -- "The other direction is analogous"
  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"
  thus "(c1;; c2;; c3, s) \<Rightarrow> s'" by auto
qed

text \<open>The big-step semantics is deterministic\<close>
theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
proof (induction arbitrary: u rule: big_step.induct)
  case (Skip s)
  then show ?case by auto
next
  case (Assign x i a s u)
  then show ?case by auto
next
  case (Clear x s)
  then show ?case by auto
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  then show ?case by blast
next
  case (IfTrue b s c\<^sub>1 t c\<^sub>2)
  from IfTrue.prems IfTrue.hyps(1) IfTrue.IH
  show ?case by auto
next
  case (IfFalse b s c\<^sub>2 t c\<^sub>1)
  from IfFalse.prems IfFalse.hyps(1) IfFalse.IH
  show ?case by auto
next
  case (WhileFalse b s c)
  then show ?case by auto
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3) then show ?case by blast
qed

subsection \<open>Small-Step\<close>

fun small_step :: "com * state \<Rightarrow> com * state" where
  "small_step (SKIP;;c\<^sub>2,s) = (c\<^sub>2,s)"
| "small_step (x[i] ::= a, s) = (SKIP, s(x := ((s x)(aval i s := aval a s))))"
| "small_step (CLR x, s) = (SKIP, s(x:=(\<lambda>_. 0)))"
| "small_step (c\<^sub>1;;c\<^sub>2,s) = (let (c\<^sub>1',s) = small_step (c\<^sub>1,s) in (c\<^sub>1';;c\<^sub>2,s))"
| "small_step (IF b THEN c1 ELSE c2, s) = (if bval b s then (c1, s) else (c2, s))"
| "small_step (WHILE b DO c,s) = (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"
| "small_step (SKIP,s) = undefined"

abbreviation is_small_step (infix "\<rightarrow>" 55)
  where "is_small_step cs cs' \<equiv> fst cs \<noteq> SKIP \<and> small_step cs = cs'"

abbreviation
  small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
  where "x \<rightarrow>* y == (op \<rightarrow>)\<^sup>*\<^sup>* x y"

subsubsection{* Proof infrastructure *}

text{* The default induction rule @{thm[source] small_step.induct} only works
for lemmas of the form @{text"a \<rightarrow> b \<Longrightarrow> \<dots>"} where @{text a} and @{text b} are
not already pairs @{text"(DUMMY,DUMMY)"}. We can generate a suitable variant
of @{thm[source] small_step.induct} for pairs by ``splitting'' the arguments
@{text"\<rightarrow>"} into pairs: *}
lemmas small_step_induct = small_step.induct[split_format(complete)]

subsubsection "Equivalence with big-step semantics"

lemma ss_seq2: "(c,s) \<rightarrow> (c',s') \<Longrightarrow> (c;;cx,s) \<rightarrow> (c';;cx,s')"
  by (induction c s arbitrary: c' s' rule: small_step_induct) auto

lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
  apply (induction rule: converse_rtranclp_induct2)
  apply (auto simp: ss_seq2 converse_rtranclp_into_rtranclp)
  done

lemma seq_comp:
  "\<lbrakk> (c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (SKIP,s3) \<rbrakk>
   \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (SKIP,s3)"
proof -
  assume a1: "(c2, s2) \<rightarrow>* (SKIP, s3)"
  assume a2: "(c1, s1) \<rightarrow>* (SKIP, s2)"
  have "(SKIP;; c2, s2) \<rightarrow>* (SKIP, s3)"
    using a1 by (simp add: converse_rtranclp_into_rtranclp)
  then have "\<And>p. p \<rightarrow>* (SKIP, s3) \<or> \<not> p \<rightarrow>* (SKIP;; c2, s2)"
    by (metis (lifting) rtranclp.rtrancl_into_rtrancl rtranclp_idemp)
  then show ?thesis
    using a2 star_seq2 by blast
qed

lemma big_to_small:
  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof (induction rule: big_step.induct)
  case Skip show ?case by blast
next
  case Assign then show ?case
    by (auto intro!: r_into_rtranclp ext)
next
  case Clear then show ?case
    by (auto intro!: r_into_rtranclp ext)
next
  case Seq thus ?case by (blast intro: seq_comp)
next
  case IfTrue thus ?case
    by (auto intro: converse_rtranclp_into_rtranclp)
next
  case IfFalse thus ?case
    by (auto intro: converse_rtranclp_into_rtranclp)
next
  case WhileFalse thus ?case
    by (fastforce intro: converse_rtranclp_into_rtranclp)

next
  case WhileTrue
  thus ?case
    apply (rule_tac converse_rtranclp_into_rtranclp)
    apply simp
    apply (rule_tac converse_rtranclp_into_rtranclp)
    apply simp
    by (simp add: seq_comp)

qed

lemma small1_big_continue:
  "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
apply (induction arbitrary: cs' t rule: small_step.induct)
apply (auto split: prod.splits if_splits)
done

lemma small_to_big:
  "cs \<rightarrow>* (SKIP,t) \<Longrightarrow> cs \<Rightarrow> t"
apply (induction rule: converse_rtranclp_induct)
apply (auto intro: small1_big_continue)
done

text {*
  Finally, the equivalence theorem:
*}
theorem big_iff_small:
  "cs \<Rightarrow> t \<longleftrightarrow> cs \<rightarrow>* (SKIP,t)"
  using small_to_big big_to_small by blast

subsection \<open>Termination\<close>
definition "final cs \<equiv> \<nexists>cs'. cs\<rightarrow>cs'"

lemma SKIP_final[simp]: "final (c,s) \<longleftrightarrow> c=SKIP"
  by (auto simp: final_def)

section \<open>Hoare-Logic for Partial Correctness\<close>

type_synonym assn = "state \<Rightarrow> bool"

definition
hoare_valid :: "assn \<Rightarrow> com \<Rightarrow> (assn) \<Rightarrow> bool" ("\<Turnstile> {(1_)}/ (_)/ {(1_)}" 50) where
"\<Turnstile> {P}c{Q} = (\<forall>s t. P s \<and> (c,s) \<Rightarrow> t \<longrightarrow> Q t)"

context
  notes [simp] = hoare_valid_def
begin
  lemma hoare_validI:
    assumes "\<And>s t. \<lbrakk> P s; (c,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> Q t"
    shows "\<Turnstile> {P}c{Q}"
    using assms by auto

  lemma conseq_rule:
    assumes "\<And>s. P s \<Longrightarrow> P' s"
    assumes "\<Turnstile> {P'} c {Q'}"
    assumes "\<And>s. Q' s \<Longrightarrow> Q s"
    shows "\<Turnstile> {P} c {Q}"
    using assms by auto

  (* One-sided versions of the consequence rule *)
  lemma conseq_pre_rule:
    assumes "\<Turnstile> {P'} c {Q}"
    assumes "\<And>s. P s \<Longrightarrow> P' s"
    shows "\<Turnstile> {P} c {Q}"
    using assms using conseq_rule by blast

  lemma conseq_post_rule:
    assumes "\<And>s. Q s \<Longrightarrow> Q' s"
    assumes "\<Turnstile> {P} c {Q}"
    shows "\<Turnstile> {P} c {Q'}"
    using assms using conseq_rule by blast

  lemma skip_rule: "\<Turnstile> {P} SKIP {P}"
    by (auto simp: hoare_valid_def)

  lemma assign_rule: "\<Turnstile> {\<lambda>s. P (s( x := (s x)(aval i s := aval a s) )) } x[i]::=a {P}"
    by (auto)

  lemma clear_rule: "\<Turnstile> {\<lambda>s. P (s( x := (\<lambda>_. 0) )) } CLR x {P}"
    by (auto)

  lemma basic_seq_rule:
    assumes "\<Turnstile> {P} c\<^sub>1 {Q}" "\<Turnstile> {Q} c\<^sub>2 {R}"
    shows "\<Turnstile> {P} c\<^sub>1;;c\<^sub>2 {R}"
    using assms by auto

  lemma if_rule:
    assumes "\<Turnstile> {P1} c\<^sub>1 {Q}" "\<Turnstile> {P2} c\<^sub>2 {Q}"
    shows "\<Turnstile> {\<lambda>s. if bval b s then P1 s else P2 s} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}"
    using assms by auto

  lemma basic_while_rule:
    assumes "\<Turnstile> {\<lambda>s. P s \<and> bval b s} c {P}"
    shows "\<Turnstile> {P} WHILE b DO c {\<lambda>s. P s \<and> \<not> bval b s}"
  proof (rule hoare_validI)
    fix s t
    assume "(WHILE b DO c, s) \<Rightarrow> t" "P s"
    then show "P t \<and> \<not> bval b t"
    proof (induction "WHILE b DO c" s t rule: big_step_induct)
      case (WhileFalse s)
      then show ?case by simp
    next
      case (WhileTrue s\<^sub>1 s\<^sub>2 s\<^sub>3)
      note IH = \<open>P s\<^sub>2 \<Longrightarrow> P s\<^sub>3 \<and> \<not> bval b s\<^sub>3\<close>

      from \<open>P s\<^sub>1\<close> \<open>bval b s\<^sub>1\<close> \<open>(c, s\<^sub>1) \<Rightarrow> s\<^sub>2\<close> \<open>\<Turnstile> {\<lambda>s. P s \<and> bval b s} c {P}\<close> have "P s\<^sub>2"
        unfolding hoare_valid_def by auto
      with IH show "P s\<^sub>3 \<and> \<not> bval b s\<^sub>3" .
    qed
  qed

  text \<open>We swap the premises of the sequence rule, as our
    verification condition generator will work on sequences
    from right to left.\<close>
  lemma seq_rule:
    assumes "\<Turnstile> {Q} c\<^sub>2 {R}" "\<Turnstile> {P} c\<^sub>1 {Q}"
    shows "\<Turnstile> {P} c\<^sub>1;;c\<^sub>2 {R}"
    using basic_seq_rule assms by blast

  text \<open>We combine the while-rule with a consequence rule, to
    make it more usable in verification condition generation\<close>

  (* Explicit backwards derivation *)
  lemma while_rule:
    assumes "\<Turnstile> {R} c {P}"
    assumes "\<And>s. \<lbrakk>P s; bval b s\<rbrakk> \<Longrightarrow> R s"
    assumes "\<And>s. \<lbrakk>P s; \<not>bval b s\<rbrakk> \<Longrightarrow> Q s"
    shows "\<Turnstile> {P} WHILE b DO c {Q}"
    apply (rule conseq_post_rule[where Q="\<lambda>s. P s \<and> \<not>bval b s"])
    apply (rule assms(3); simp)
    apply (rule basic_while_rule)
    apply (rule conseq_pre_rule)
    apply (rule assms(1))
    apply (rule assms(2); auto)
    done

end

section \<open>Verification Condition Generator\<close>

definition AWHILE :: "assn \<Rightarrow> bexp \<Rightarrow> com \<Rightarrow> com" ("(INVAR _ WHILE _/ DO _)"  [0, 0, 61] 61)
  where "INVAR I WHILE b DO c \<equiv> WHILE b DO c"

lemma annot_invar: "(WHILE b DO c) = (INVAR I WHILE b DO c)" by (simp add: AWHILE_def)

lemma awhile_rule:
  assumes "\<Turnstile> {R} c {P}"
  assumes "\<And>s. \<lbrakk>P s; bval b s\<rbrakk> \<Longrightarrow> R s"
  assumes "\<And>s. \<lbrakk>P s; \<not>bval b s\<rbrakk> \<Longrightarrow> Q s"
  shows "\<Turnstile> {P} INVAR P WHILE b DO c {Q}"
  unfolding AWHILE_def by (rule while_rule[OF assms])

lemmas vcg_rules = skip_rule assign_rule clear_rule seq_rule if_rule awhile_rule

method vcg_step = clarsimp?;rule vcg_rules | (safe;clarsimp)
method vcg_present_nice_goal = clarsimp?, ((thin_tac "_=list _")+)?
method vcg_ctd = vcg_step+, vcg_present_nice_goal?
method vcg = rule conseq_pre_rule, vcg_ctd

end


theory DSG
  imports Main History
begin

section \<open>Transaction Dependencies\<close>

text \<open>We begin by formalizing three types of dependencies between transactions: wr-depends,
ww-depends, and rw-depends. The wr-depends relation captures the idea of a transaction t2 reading
another transaction T1's write.\<close>

definition wr_depends :: "history \<Rightarrow> atxn \<Rightarrow> atxn \<Rightarrow> bool" where
"wr_depends h t1 t2 \<equiv> \<exists>w1 r2. (a_is_committed t1) \<and>
                              (a_is_committed t2) \<and>
                              (w1 \<in> ext_awrites t1) \<and>
                              (r2 \<in> ext_areads t2) \<and>
                              ((key w1) = (key r2)) \<and>
                              ((post_version w1) = (pre_version r2))"

text \<open>We say t1 ww-depends t2 if t2 overwrote t1--that is, if t1 installed
some version v1 of k, and t2 wrote v2, such that v1 came immediately before v2 in the version order
of k.\<close>

definition ww_depends :: "history \<Rightarrow> atxn \<Rightarrow> atxn \<Rightarrow> bool" where
"ww_depends h t1 t2 \<equiv> \<exists>w1 w2.
  (a_is_committed t1) \<and>
  (a_is_committed t2) \<and>
  (w1 \<in> ext_awrites t1) \<and>
  (w2 \<in> ext_awrites t2) \<and>
  ((key w1) = (key w2)) \<and>
  (is_next_in_history h (key w1) (apost_version w1) (apost_version w2))"

lemma ww_depends_example: "ww_depends
  (History objs
           {(ATxn [(AWrite x v0 a1 v1 [])] True),
            (ATxn [(AWrite x v1 a2 v2 [])] True)}
           {(KeyVersionOrder x [v0, v1, v2])})
  (ATxn [(AWrite x v0 a1 v1 [])] True)
  (ATxn [(AWrite x v1 a2 v2 [])] True)
= True"
  apply (simp add:ww_depends_def)
  done

text \<open>An rw-dependency is just like a ww-dependency, only transaction t1 *read* state just prior to
t2's write.\<close>

definition rw_depends :: "history \<Rightarrow> atxn \<Rightarrow> atxn \<Rightarrow> bool" where
"rw_depends h t1 t2 \<equiv> \<exists>r1 w2.
  (a_is_committed t1) \<and>
  (a_is_committed t2) \<and>
  (r1 \<in> ext_areads t1) \<and>
  (w2 \<in> ext_awrites t2) \<and>
  ((key r1) = (key w2)) \<and>
  (is_next_in_history h (key r1) (apost_version r1) (apost_version w2))"

section \<open>Direct Serialization Graphs\<close>

text \<open>Now, we define a Direct Serialization Graph of a history as a graph where nodes are
transactions in that history, and arcs are dependencies between them. We codify these three types of
dependency with a type, and create a dependency type to wrap them. We call these aDeps for abstract
dependencies; later, we'll define analogous observed dependencies.\<close>

datatype depType = WR | WW | RW

datatype adep = ADep atxn depType atxn

primrec adep_head :: "adep \<Rightarrow> atxn" where
"adep_head (ADep t _ _) = t"

primrec adep_tail :: "adep \<Rightarrow> atxn" where
"adep_tail (ADep _ _ t) = t"

class dep_typed =
  fixes dep_type :: "'a \<Rightarrow> depType"

instantiation adep :: "dep_typed"
begin
primrec dep_type_adep :: "adep \<Rightarrow> depType" where
"dep_type_adep (ADep _ t _) = t"
instance ..
end

type_synonym dsg = "(atxn, adep) pre_digraph"

text \<open>The DSG of a history is defined by mapping each dependency to an edge in the graph.\<close>

definition dsg :: "history \<Rightarrow> dsg" where
"dsg h \<equiv> \<lparr>verts = all_atxns h,
          arcs  = ({(ADep t1 WR t2) | t1 t2. wr_depends h t1 t2} \<union>
                   {(ADep t1 WW t2) | t1 t2. ww_depends h t1 t2} \<union>
                   {(ADep t1 RW t2) | t1 t2. rw_depends h t1 t2}),
          tail = adep_tail,
          head = adep_head\<rparr>"

text \<open>Now, we need to characterize a cycle in a DSG. TODO: I don't know how to use the definitions
in the locales in Arc_Walk.thy, but I assume we should take advantage of them. Copy-pasting with
slight mods for now.\<close>

type_synonym 'a path = "'a list"

text \<open>The list of vertices of a walk. The additional vertex argument is there to deal with the case
of empty walks.\<close>

primrec path_verts :: "('a,'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> 'b path \<Rightarrow> 'a list" where
    "path_verts G u [] = [u]"
  | "path_verts G u (e # es) = tail G e # path_verts G (head G e) es"

text \<open>
  Tests whether a list of arcs is a consistent arc sequence,
  i.e. a list of arcs, where the head G node of each arc is
  the tail G node of the following arc.
\<close>
fun cas :: "('a, 'b) pre_digraph => 'a \<Rightarrow> 'b path \<Rightarrow> 'a \<Rightarrow> bool" where
  "cas G u [] v = (u = v)" |
  "cas G u (e # es) v = (tail G e = u \<and> cas G (head G e) es v)"

definition path :: "('a,'b) pre_digraph \<Rightarrow> 'a \<Rightarrow> 'b path \<Rightarrow> 'a \<Rightarrow> bool" where
  "path G u p v \<equiv> u \<in> verts G \<and> set p \<subseteq> arcs G \<and> cas G u p v"

text \<open>Is the given path a cycle in the given graph?\<close>

definition cycle :: "('a,'b) pre_digraph \<Rightarrow> 'b path \<Rightarrow> bool" where
  "cycle G p \<equiv> \<exists>u. path G u p u \<and> distinct (tl (path_verts G u p)) \<and> p \<noteq> []"

text \<open>We would like a cycle whose edges are all of the given set of dependency types.\<close>

primrec path_dep_types :: "('a::dep_typed) path \<Rightarrow> depType set" where
"path_dep_types []        = {}" |
"path_dep_types (x # xs)  = (Set.insert (dep_type x) (path_dep_types xs))"

end


theory Prover
imports Main
begin

declare ex_image_cong_iff [simp del]

subsection "Formulas"

type_synonym pred = nat

type_synonym var = nat

datatype form =
  PAtom pred "var list"
  | NAtom pred "var list"
  | FConj form form
  | FDisj form form
  | FAll form
  | FEx form

primrec preSuc :: "nat list => nat list"
where
  "preSuc [] = []"
| "preSuc (a#list) = (case a of 0 => preSuc list | Suc n => n#(preSuc list))"

primrec fv :: "form => var list" \<comment> \<open>shouldn't need to be more constructive than this\<close>
where
  "fv (PAtom p vs) = vs"
| "fv (NAtom p vs) = vs"
| "fv (FConj f g) = (fv f) @ (fv g)"
| "fv (FDisj f g) = (fv f) @ (fv g)"
| "fv (FAll f) = preSuc (fv f)"
| "fv (FEx f) = preSuc (fv f)"

definition
  bump :: "(var => var) => (var => var)" \<comment> \<open>substitute a different var for 0\<close> where
  "bump phi y = (case y of 0 => 0 | Suc n => Suc (phi n))"

primrec subst :: "(nat => nat) => form => form"
where
  "subst r (PAtom p vs) = (PAtom p (map r vs))"
| "subst r (NAtom p vs) = (NAtom p (map r vs))"
| "subst r (FConj f g) = FConj (subst r f) (subst r g)"
| "subst r (FDisj f g) = FDisj (subst r f) (subst r g)"
| "subst r (FAll f) = FAll (subst (bump r) f)"
| "subst r (FEx f) = FEx (subst (bump r) f)"

lemma size_subst[simp]: "\<forall>m. size (subst m f) = size f"
  by (induct f) (force+)

definition
  finst :: "form => var => form" where
  "finst body w = (subst (% v. case v of 0 => w | Suc n => n) body)"

lemma size_finst[simp]: "size (finst f m) = size f"
  by (simp add: finst_def)

type_synonym seq = "form list"

type_synonym nform = "nat * form"

type_synonym nseq = "nform list"

definition
  s_of_ns :: "nseq => seq" where
  "s_of_ns ns = map snd ns"

definition
  ns_of_s :: "seq => nseq" where
  "ns_of_s s = map (% x. (0,x)) s"

primrec flatten :: "'a list list => 'a list"
where
  "flatten [] = []"
| "flatten (a#list) = (a@(flatten list))"

definition
  sfv :: "seq => var list" where
  "sfv s = flatten (map fv s)"

lemma sfv_nil: "sfv [] = []" by(force simp: sfv_def)
lemma sfv_cons: "sfv (a#list) = (fv a) @ (sfv list) " by(force simp: sfv_def)

primrec maxvar :: "var list => var"
where
  "maxvar [] = 0"
| "maxvar (a#list) = max a (maxvar list)"

lemma maxvar: "\<forall>v \<in> set vs. v \<le> maxvar vs"
  by (induct vs) (auto simp: max_def)

definition
  newvar :: "var list => var" where
  "newvar vs = (if vs = [] then 0 else Suc (maxvar vs))"
  \<comment> \<open>note that for newvar to be constructive, need an operation to get a different var from a given set\<close>

lemma newvar: "newvar vs \<notin> (set vs)"
  using length_pos_if_in_set maxvar newvar_def by force

(*lemmas newvar_sfv = newvar[of "sfv s"]*)

primrec subs :: "nseq => nseq list"
where
  "subs [] = [[]]"
| "subs (x#xs) =
  (let (m,f) = x in
                case f of
                        PAtom p vs => if NAtom p vs : set (map snd xs) then [] else [xs@[(0,PAtom p vs)]]
                        | NAtom p vs => if PAtom p vs : set (map snd xs) then [] else [xs@[(0,NAtom p vs)]]
                        | FConj f g => [xs@[(0,f)],xs@[(0,g)]]
                        | FDisj f g => [xs@[(0,f),(0,g)]]
                        | FAll f => [xs@[(0,finst f (newvar (sfv (s_of_ns (x#xs)))))]]
                        | FEx f => [xs@[(0,finst f m),(Suc m,FEx f)]]
                )"

subsection "Derivations"

primrec is_axiom :: "seq => bool"
where
  "is_axiom [] = False"
| "is_axiom (a#list) = ((? p vs. a = PAtom p vs & NAtom p vs : set list) | (? p vs. a = NAtom p vs & PAtom p vs : set list))"

inductive_set
  deriv :: "nseq => (nat * nseq) set"
  for s :: nseq
where
  init: "(0,s) \<in> deriv s"
| step: "(n,x) \<in> deriv s ==> y : set (subs x) ==> (Suc n,y) \<in> deriv s"
  \<comment> \<open>the closure of the branch at isaxiom\<close>

(*lemma step': "(n,x) \<in> deriv s ==> y : set (subs x) ==> ~ is_axiom (s_of_ns x) ==> (Suc n,y) \<in> deriv s"*)

lemma patom:  "(n,(m,PAtom p vs)#xs) \<in> deriv(nfs) ==> ~is_axiom (s_of_ns ((m,PAtom p vs)#xs)) ==> (Suc n,xs@[(0,PAtom p vs)]) \<in> deriv(nfs)"
  and natom:  "(n,(m,NAtom p vs)#xs) \<in> deriv(nfs) ==> ~is_axiom (s_of_ns ((m,NAtom p vs)#xs)) ==> (Suc n,xs@[(0,NAtom p vs)]) \<in> deriv(nfs)"
  and fconj1: "(n,(m,FConj f g)#xs) \<in> deriv(nfs) ==> ~is_axiom (s_of_ns ((m,FConj f g)#xs)) ==> (Suc n,xs@[(0,f)]) \<in> deriv(nfs)"
  and fconj2: "(n,(m,FConj f g)#xs) \<in> deriv(nfs) ==> ~is_axiom (s_of_ns ((m,FConj f g)#xs)) ==> (Suc n,xs@[(0,g)]) \<in> deriv(nfs)"
  and fdisj:  "(n,(m,FDisj f g)#xs) \<in> deriv(nfs) ==> ~is_axiom (s_of_ns ((m,FDisj f g)#xs)) ==> (Suc n,xs@[(0,f),(0,g)]) \<in> deriv(nfs)"
  and fall:   "(n,(m,FAll f)#xs) \<in> deriv(nfs) ==> ~is_axiom (s_of_ns ((m,FAll f)#xs)) ==> (Suc n,xs@[(0,finst f (newvar (sfv (s_of_ns ((m,FAll f)#xs)))))]) \<in> deriv(nfs)"
  and fex:    "(n,(m,FEx f)#xs) \<in> deriv(nfs) ==> ~is_axiom (s_of_ns ((m,FEx f)#xs)) ==> (Suc n,xs@[(0,finst f m),(Suc m,FEx f)]) \<in> deriv(nfs)"
  apply(auto intro: step simp add: Let_def s_of_ns_def)
  done

lemmas not_is_axiom_subs = patom natom fconj1 fconj2 fdisj fall fex

lemmas[simp] = init
lemmas [intro] = init step

lemma deriv0[simp]: "(0,x) \<in> deriv y = (x = y)"
  apply(rule)
  apply(erule deriv.cases) apply(simp) apply(simp)
  apply(simp)
  done

(*
lemma deriv_exists: "(n,x) \<in> deriv s ==> x \<noteq> [] ==> ~ is_axiom (s_of_ns x) ==> (\<exists>y. (Suc n, y) \<in> deriv s & y : set (subs x))"
  apply(case_tac x) apply(simp)
  apply(case_tac a) apply(case_tac b)
       apply(auto simp add: Let_def s_of_ns_def intro: step)
  apply(rule_tac x= "list @ [(0, form1)]" in exI)
  apply(simp)
  apply(rule step) apply(assumption) apply(simp add: Let_def)
  done
*)

lemma deriv_upwards: "(n,list) \<in> deriv s ==> ~ is_axiom (s_of_ns (list)) ==> (\<exists>zs. (Suc n, zs) \<in> deriv s & zs : set (subs list))"
  apply(case_tac list) apply force
  apply(case_tac a) apply(case_tac b)
       apply(simp add: Let_def) apply(rule) apply(simp add: s_of_ns_def) apply(force dest: not_is_axiom_subs)
      apply(simp add: Let_def) apply(rule) apply(simp add: s_of_ns_def) apply(force dest: not_is_axiom_subs)
     apply(simp add: Let_def) apply(force dest: not_is_axiom_subs)
    apply(simp add: Let_def) apply(force dest: not_is_axiom_subs)
   apply(simp add: Let_def) apply(force dest: not_is_axiom_subs)
  apply(simp add: Let_def) apply(force dest: not_is_axiom_subs)
  done

lemma deriv_downwards (*derivSucE*): "(Suc n, x) \<in> deriv s ==> \<exists>y. (n,y) \<in> deriv s & x : set (subs y) & ~ is_axiom (s_of_ns y)"
  apply(erule deriv.cases)
  apply(simp)
  apply(simp add: s_of_ns_def Let_def)
  apply(rule_tac x=xa in exI) apply(simp)
  apply(case_tac xa) apply(simp)
  apply(case_tac a) apply(case_tac b)
       apply(auto simp add: Let_def)
   apply (rename_tac[!] nat lista a)
   apply(subgoal_tac "NAtom nat lista \<in> snd ` set list") apply(simp) apply(force)
  apply(subgoal_tac "PAtom nat lista \<in> snd ` set list") apply(simp) apply(force)
  done

lemma deriv_deriv_child(*derivSuc*)[rule_format]: "\<forall>x y. (Suc n,x) \<in> deriv y = (\<exists>z. z : set (subs y) & ~ is_axiom (s_of_ns y) & (n,x) \<in> deriv z)"
  apply(induct n)
   apply(rule, rule) apply(rule) apply(frule_tac deriv_downwards) apply(simp)
   apply(simp) apply(rule step) apply(simp) apply(simp)
  apply(blast dest!: deriv_downwards elim: deriv.cases) \<comment> \<open>blast needs some help with the reasoning, hence derivSucE\<close>
  done

(*
lemma deriv_not_nil: "s \<noteq> [] ==> \<forall>t. (n,t) \<in> deriv s --> t \<noteq> []"
  apply(induct_tac n)
  apply(force)
  apply (blast dest: derivSucE deriv_exists);
  done
*)

lemma deriv_progress: "(n,a#list) \<in> deriv s ==> ~ is_axiom (s_of_ns (a#list)) ==> (\<exists>zs. (Suc n, list@zs) \<in> deriv s)"
  apply(subgoal_tac "a#list \<noteq> []") prefer 2 apply(simp)
  apply(case_tac a) apply(case_tac b)
       apply(force dest: not_is_axiom_subs)+
  done

definition
  inc :: "nat * nseq => nat * nseq" where
  "inc = (%(n,fs). (Suc n, fs))"

lemma inj_inc[simp]: "inj inc"
  apply(simp add: inc_def) apply(simp add: inj_on_def) done

lemma deriv: "deriv y = insert (0,y) (inc ` (Union (deriv ` {w. ~is_axiom (s_of_ns y) & w : set (subs y)})))"
  apply(rule set_eqI)
  apply(simp add: split_paired_all)
  apply(case_tac a)
   apply(force simp: inc_def)
  apply(force simp: deriv_deriv_child inc_def)
  done

lemma deriv_is_axiom: "is_axiom (s_of_ns s) ==> deriv s = {(0,s)}"
  apply(rule)
   apply(rule)
   apply(case_tac x) apply(simp)
   apply(erule_tac deriv.induct) apply(force) apply(simp add: s_of_ns_def) apply(case_tac s) apply(simp) apply(case_tac aa) apply(case_tac ba)
         apply(simp_all add: Let_def)
  done

lemma is_axiom_finite_deriv: "is_axiom (s_of_ns s) ==> finite (deriv s)"
  apply(simp add: deriv_is_axiom) done

subsection "Failing path"

primrec failing_path :: "(nat * nseq) set => nat => (nat * nseq)"
where
  "failing_path ns 0 = (SOME x. x \<in> ns & fst x = 0 & infinite (deriv (snd x)) & ~ is_axiom (s_of_ns (snd x)))"
| "failing_path ns (Suc n) = (let fn = failing_path ns n in
  (SOME fsucn. fsucn \<in> ns & fst fsucn = Suc n & (snd fsucn) : set (subs (snd fn)) & infinite (deriv (snd fsucn)) & ~ is_axiom (s_of_ns (snd fsucn))))"

locale loc1 =
  fixes s and f
  assumes f: "f = failing_path (deriv s)"

lemma (in loc1) f0: "infinite (deriv s) ==> f 0 \<in> (deriv s) & fst (f 0) = 0 & infinite (deriv (snd (f 0))) & ~ is_axiom (s_of_ns (snd (f 0)))"
  apply(simp add: f) apply(rule someI_ex) apply(rule_tac x="(0,s)" in exI) apply(force simp add: deriv_is_axiom) done

lemma infinite_union: "finite Y ==> infinite (Union (f ` Y)) ==> \<exists>y. y \<in> Y & infinite (f y)"
  apply(rule ccontr) apply(simp) done

lemma infinite_inj_infinite_image: "inj_on f Z ==> infinite (f ` Z) = infinite Z"
  apply(rule ccontr)
  apply(simp)
  apply(force dest: finite_imageD)
  done

lemma inj_inj_on: "inj f ==> inj_on f A"
by(blast intro: subset_inj_on)

lemma collect_disj: "{x. P x | Q x} = {x. P x} Un {x. Q x}" by(force)

lemma t: "finite {w. P w} ==> finite {w. Q w & P w}"
  by (rule finite_subset, auto)

lemma finite_subs: "finite {w. ~is_axiom (s_of_ns y) & w : set (subs y)}"
  apply(case_tac y) apply(simp add: s_of_ns_def)
  apply(case_tac a) apply(case_tac b)
  apply(simp_all only: subs.simps)
  apply(auto intro: t simp add: collect_disj)
  done

lemma (in loc1) fSuc:
  shows "[|
  f n \<in> deriv s & fst (f n) = n & infinite (deriv (snd (f n))) & ~is_axiom (s_of_ns (snd (f n)))
  |] ==> f (Suc n) \<in> deriv s & fst (f (Suc n)) = Suc n & (snd (f (Suc n))) : set (subs (snd (f n))) & infinite (deriv (snd (f (Suc n)))) & ~is_axiom (s_of_ns (snd (f (Suc n))))"
  apply(simp add: Let_def f)
  apply(rule_tac someI_ex)
  apply(simp only: f[symmetric])
  apply(drule_tac subst[OF deriv[of "snd (f n)"] ])
  apply(simp only: finite_insert) apply(subgoal_tac "infinite (\<Union>(deriv ` {w. ~is_axiom (s_of_ns (snd (f n))) & w : set (subs (snd (f n)))}))")
   apply(drule_tac infinite_union[OF finite_subs]) apply(erule exE) apply(rule_tac x="(Suc n, y)" in exI)
   apply(clarify) apply(simp) apply(case_tac "f n") apply(simp add: step) apply(force simp add: is_axiom_finite_deriv)
  apply(force simp add: infinite_inj_infinite_image inj_inj_on)
  done

lemma (in loc1) is_path_f_0: "infinite (deriv s) ==> f 0 = (0,s)"
  apply(subgoal_tac "f 0 \<in> deriv s & fst (f 0) = 0")
   prefer 2 apply(frule_tac f0) apply(simp)
  apply(case_tac "f 0") apply(elim conjE, simp)
  done

lemma (in loc1) is_path_f': "infinite (deriv s) ==> \<forall>n. f n \<in> deriv s & fst (f n) = n & infinite (deriv (snd (f n))) & ~ is_axiom (s_of_ns (snd (f n)))"
  apply(rule)
  apply(induct_tac n)
  apply(simp add: f0)
  apply(simp add: fSuc)
  done

lemma (in loc1) is_path_f: "infinite (deriv s) ==> \<forall>n. f n \<in> deriv s & fst (f n) = n & (snd (f (Suc n))) : set (subs (snd (f n))) & infinite (deriv (snd (f n)))"
  apply(rule)
  apply(frule_tac is_path_f') apply(simp) apply(simp add: fSuc)
  done

subsection "Models"

typedecl U

type_synonym model = "U set * (pred => U list => bool)"

type_synonym env = "var => U"

primrec FEval :: "model => env => form => bool"
where
  "FEval MI e (PAtom P vs) = (let IP = (snd MI) P in IP (map e vs))"
| "FEval MI e (NAtom P vs) = (let IP = (snd MI) P in ~ (IP (map e vs)))"
| "FEval MI e (FConj f g) = ((FEval MI e f) & (FEval MI e g))"
| "FEval MI e (FDisj f g) = ((FEval MI e f) | (FEval MI e g))"
| "FEval MI e (FAll f) = (\<forall>m \<in> (fst MI). FEval MI (% y. case y of 0 => m | Suc n => e n) f)"
| "FEval MI e (FEx f) = (\<exists>m \<in> (fst MI). FEval MI (% y. case y of 0 => m | Suc n => e n) f)"

lemma and_lem: "(a=c) ==> (b=d) ==> (a & b) = (c & d)" by simp

lemma or_lem: "(a=c) ==> (b=d) ==> (a | b) = (c | d)" by simp

(*lemma all_eq_all: "\<forall>x. P x = Q x ==> (\<forall>x. P x) = (\<forall>x. Q x)" by blast*)

lemma ball_eq_ball: "\<forall>x \<in> m. P x = Q x ==> (\<forall>x \<in> m. P x) = (\<forall>x \<in> m. Q x)" by blast

lemma bex_eq_bex: "\<forall>x \<in> m. P x = Q x ==> (\<exists>x \<in> m. P x) = (\<exists>x \<in> m. Q x)" by blast

lemma preSuc[simp]:"\<forall>n. Suc n \<in> set A = (n \<in> set (preSuc A))"
   apply(induct_tac A) apply(simp) apply(case_tac a, force, force) done

lemma FEval_cong: "\<forall>e1 e2. (\<forall>x. x \<in> set (fv A) --> e1 x = e2 x) --> FEval MI e1 A = FEval MI e2 A"
proof (induction A)
  case (PAtom x1 x2)
  then show ?case
    by (metis FEval.simps(1) fv.simps(1) map_cong)
next
  case (NAtom x1 x2)
  then show ?case
    by simp (metis list.map_cong0)
next
  case (FConj A1 A2)
  then show ?case
    by simp blast
next
  case (FDisj A1 A2)
  then show ?case
    by simp blast
next
  case (FAll A)
  then show ?case
    by (metis (no_types, lifting) FEval.simps(5) Nitpick.case_nat_unfold One_nat_def Suc_pred fv.simps(5) gr0I preSuc)
next
  case (FEx A)
  then show ?case
    by (metis (no_types, lifting) FEval.simps(6) Nitpick.case_nat_unfold One_nat_def Suc_pred fv.simps(6) gr0I preSuc)
qed

primrec SEval :: "model => env => form list => bool"
where
  "SEval m e [] = False"
| "SEval m e (x#xs) = (FEval m e x | SEval m e xs)"

lemma SEval_def2: "SEval m e s = (\<exists>f. f \<in> set s & FEval m e f)"
  by (induct s) auto

lemma SEval_append: "SEval m e (xs@ys) = ( (SEval m e xs) | (SEval m e ys))"
  by (induct xs) auto

lemma all_eq_all: "\<forall>x. P x = Q x ==> (\<forall>x. P x) = (\<forall>x. Q x)" by blast

lemma all_conj: "(\<forall>x. A x & B x) = ((\<forall>x. A x) & (\<forall>x. B x))" by blast

lemma SEval_cong: "(\<forall>x. x \<in> set (sfv s) --> e1 x = e2 x) --> SEval m e1 s = SEval m e2 s"
  apply(induct s) apply(simp)
  apply(simp) apply(intro allI impI)
  apply(rule or_lem) apply(simp add: sfv_cons) apply(simp add: FEval_cong)
  apply(simp add: sfv_cons)
  done

definition
  is_env :: "model => env => bool" where
  "is_env MI e = (\<forall>x. e x \<in> (fst MI))"

definition
  Svalid :: "form list => bool" where
  "Svalid s = (\<forall>MI e. is_env MI e --> SEval MI e s)"

subsection "Soundness"

lemma fold_compose1: "(% x. f (g x)) = (f o g)"
  apply(rule ext) apply(force) done

lemma FEval_subst: "\<forall>e f. (FEval MI e (subst f A)) = (FEval MI (e o f) A)"
  apply(induct A)
       apply(simp add: Let_def) apply(simp only: fold_compose1 map_map) apply(blast)
      apply(simp add: Let_def) apply(simp only: fold_compose1 map_map) apply(blast)
     apply(simp)
    apply(simp)
   apply(simp (no_asm_use)) apply(simp) apply(rule,rule) apply(rule ball_eq_ball) apply(rule) apply(simp add: bump_def)
   apply(subgoal_tac "(%u. case_nat m e (case u of 0 => 0 | Suc n => Suc (f n))) = (case_nat m (%n. e (f n)))") apply(simp)
   apply(rule ext) apply(case_tac u)
    apply(simp) apply(simp)
  apply(simp (no_asm_use)) apply(simp) apply(rule,rule) apply(rule bex_eq_bex) apply(rule) apply(simp add: bump_def)
  apply(subgoal_tac "(%u. case_nat m e (case u of 0 => 0 | Suc n => Suc (f n))) = (case_nat m (%n. e (f n)))") apply(simp)
  apply(rule ext) apply(case_tac u)
   apply(simp) apply(simp)
  done

(*
lemma bump_f_x_0[simp]: "bump f x 0 = x" apply(simp add: bump_def) done

lemma bump_id_suc[simp]: "bump id x (Suc n) = Suc n" apply(simp add: bump_def) done

lemma bump_id_0[simp]: "bump id 0 = id" apply(rule ext) apply(simp add: bump_def) apply(case_tac x) apply(auto) done
*)

lemma FEval_finst: "FEval mo e (finst A u) = FEval mo (case_nat (e u) e) A"
  apply(simp add: finst_def)
  apply(simp add: FEval_subst)
  apply(subgoal_tac "(e o case_nat u (%n. n)) = (case_nat (e u) e)") apply(simp)
  apply(rule ext)
  apply(case_tac x,auto)
  done

lemma ball_maxscope: "(\<forall>x \<in> m. P x | Q) ==> (\<forall>x \<in> m. P x) | Q " by blast

lemma sound_FAll: "u \<notin> set (sfv (FAll f#s)) ==> Svalid (s@[finst f u]) ==> Svalid (FAll f#s)"
  apply(simp add: Svalid_def del: SEval.simps)
  apply(rule allI)
  apply(rule allI)
  apply(rename_tac M I)
  apply(rule allI) apply(rule)
  apply(simp)
  apply(simp add: SEval_append)
  apply(rule ball_maxscope)
  apply(rule)
  apply(simp add: FEval_finst)

  apply(drule_tac x=M in spec, drule_tac x=I in spec) \<comment> \<open>this is the goal\<close>

  apply(drule_tac x="e(u:=m)" in spec) apply(erule impE) apply(simp add: is_env_def) apply(erule disjE)
   apply(rule disjI2)
   apply(subgoal_tac "SEval (M,I) (e(u :=m)) s = SEval (M,I) e s")
    apply(simp)
   apply(rule SEval_cong[rule_format]) apply(simp add: sfv_cons) apply(force)

  apply(rule disjI1)
  apply(simp)
  apply(subgoal_tac "FEval (M,I) (case_nat m (e(u :=m))) f = FEval (M,I) (case_nat m e) f")
   apply(simp)
  apply(rule FEval_cong[rule_format])

  apply(case_tac x, simp)
  apply(simp)
  apply(simp only: preSuc[rule_format, symmetric])
  apply(subgoal_tac "nat \<in> set (fv (FAll f))") prefer 2 apply(simp)

  apply(force simp: sfv_cons)
  done
    \<comment> \<open>phew, that really was a bit more difficult than expected\<close>
    \<comment> \<open>note that we can avoid maxscoping at the cost of instantiating the hyp twice- an additional time for M\<close>

    \<comment> \<open>different proof, instantiating quantifier twice, avoiding maxscoping\<close>
lemma sound_FAll': "u \<notin> set (sfv (FAll f#s)) ==> Svalid (s@[finst f u]) ==> Svalid (FAll f#s)"
  apply(simp add: Svalid_def del: SEval.simps)
  apply(rule allI)
  apply(rule allI)
  apply(rename_tac M I)
  apply(rule allI) apply(rule)
  apply(simp)
  apply(simp add: SEval_append)
  apply(drule_tac x=M in spec, drule_tac x=I in spec)
  apply(frule_tac x="e" in spec) apply(erule impE) apply(simp add: is_env_def)
  apply(case_tac "SEval (M, I) e s") apply(simp)
  apply(simp)
    \<comment> \<open>second instantiation\<close>
  apply(simp add: FEval_finst)
  apply(rule)
  apply(drule_tac x="e(u:=m)" in spec) apply(erule impE) apply(simp add: is_env_def)
  apply(erule disjE)
   apply(subgoal_tac "SEval (M,I) (e(u :=m)) s = SEval (M,I) e s")
    apply(simp)
   apply(rule SEval_cong[rule_format]) apply(simp add: sfv_cons) apply(force)
  apply(simp)
  apply(subgoal_tac "FEval (M,I) (case_nat m (e(u :=m))) f = FEval (M,I) (case_nat m e) f")
   apply(simp)
  apply(rule FEval_cong[rule_format])
  apply(case_tac x, simp)
  apply(simp)
  apply(simp only: preSuc[rule_format, symmetric])
  apply(subgoal_tac "nat \<in> set (fv (FAll f))") prefer 2 apply(simp)
  apply(force simp: sfv_cons)
  done
    \<comment> \<open>not much better, probably slightly worse\<close>

(*
lemma sound_FAll: "u \<notin> sfv ((0,FAll f)#s) ==> SEval m e (map snd (s@[(0,finst u f)])) ==> SEval m e (map snd ((0,FAll f)#s))"
  apply(simp)
  apply(rule all_maxscope)
  apply(rule)
  apply(simp add: SEval_append)
  apply(erule disjE)
  apply(simp)
  apply(rule disjI1)
  apply(simp add: FEval_finst)
  apply(subgoal_tac "FEval m (case_nat (e u) e) f = FEval m (case_nat x e) f") apply(simp)
  apply(rule FEval_cong[rule_format])
  apply(case_tac xa)
  apply(simp)
  oops -- "and this isn't provable- the heart of the rules-preserve-validity debate"
*)

lemma sound_FEx: "Svalid (s@[finst f u,FEx f]) ==> Svalid (FEx f#s)"
  apply(simp add: Svalid_def del: SEval.simps)
  apply(rule allI)
  apply(rule allI)
  apply(rename_tac ms m)
  apply(rule) apply(rule)
  apply(simp)
  apply(simp add: SEval_append)
  apply(simp add: FEval_finst)

  apply(drule_tac x=ms in spec, drule_tac x=m in spec)
  apply(drule_tac x=e in spec) apply(erule impE) apply(assumption)
  apply(erule disjE)
  apply(simp)
  apply(erule disjE)
   apply(rule disjI1)
   apply(rule_tac x="e u" in bexI) apply(simp) apply(simp add: is_env_def)
  apply(force)
  done

lemma max_exists: "finite (X::nat set) ==> X \<noteq> {} --> (\<exists>x. x \<in> X & (\<forall>y. y \<in> X --> y \<le> x))"
  apply(erule_tac finite_induct)
  apply(force)
  apply(rule)
  apply(case_tac "F = {}")
  apply(force)
  apply(erule impE) apply(force)
  apply(elim exE conjE)
  apply(rule_tac x="max x xa" in exI)
  apply(rule) apply(simp add: max_def)
  apply(simp add: max_def) apply(force)
  done
  \<comment> \<open>poor max lemmas in lib\<close>

lemma inj_finite_image_eq_finite: "inj_on f Z ==> finite (f ` Z) = finite Z"
  by (blast intro: finite_imageD)

lemma finite_inc: "finite (inc ` X) = finite X"
  apply(rule inj_finite_image_eq_finite)
  apply(rule_tac B=UNIV in subset_inj_on)
  apply(auto)
  done

lemma finite_deriv_deriv: "finite (deriv s) ==> finite  (deriv ` {w. ~is_axiom (s_of_ns s) & w : set (subs s)})"
  by (simp only: deriv) simp

definition
  init :: "nseq => bool" where
  "init s = (\<forall>x \<in> (set s). fst x = 0)"

definition
  is_FEx :: "form => bool" where
  "is_FEx f = (case f of
      PAtom p vs => False
    | NAtom p vs => False
    | FConj f g => False
    | FDisj f g => False
    | FAll f => False
    | FEx f => True)"

lemma is_FEx[simp]: "~ is_FEx (PAtom p vs)
  & ~ is_FEx (NAtom p vs)
  & ~ is_FEx (FConj f g)
  & ~ is_FEx (FDisj f g)
  & ~ is_FEx (FAll f)"
  by(force simp: is_FEx_def)

lemma index0: "init s ==> \<forall>u m A. (n, u) \<in> deriv s --> (m,A) \<in> (set u) --> (~ is_FEx A) --> m = 0"
  apply(induct_tac n)
  apply(rule,rule,rule,rule,rule,rule) apply(simp) apply(force simp add: init_def)
  apply(rule,rule,rule,rule,rule,rule)
  \<comment> \<open>inversion on @{term "(Suc n, u) \<in> deriv s"}\<close>
  apply(drule_tac deriv_downwards) apply(elim exE conjE)
  apply(case_tac y) apply(simp)
  apply(case_tac a) apply(case_tac b)
       apply(force simp add: Let_def s_of_ns_def)
      apply(force simp add: Let_def s_of_ns_def)
     apply(force simp add: Let_def s_of_ns_def)
    apply(force simp add: Let_def s_of_ns_def)
   apply(force simp add: Let_def s_of_ns_def)
  apply(force simp add: is_FEx_def Let_def s_of_ns_def)
  done

lemma soundness': "init s ==> finite (deriv s) ==> m \<in> (fst ` (deriv s)) ==> \<forall>y u. (y,u) \<in> (deriv s) --> y \<le> m ==> \<forall>n t. h = m - n & (n,t) \<in> deriv s --> Svalid (s_of_ns t)"
  apply(induct_tac h)
    \<comment> \<open>base case\<close>
   apply(simp) apply(rule,rule,rule) apply(elim conjE)
   apply(subgoal_tac "n=m") prefer 2 apply(force)
   apply(simp)
   apply(simp add: Svalid_def) apply(rule,rule) apply(rename_tac gs g) apply(rule) apply(rule) apply(simp add: SEval_def2)
   apply(case_tac "is_axiom (s_of_ns t)")
     \<comment> \<open>base case, is axiom\<close>
    apply(simp add: s_of_ns_def) apply(case_tac t) apply(simp) apply(simp)
    apply(erule disjE)
      \<comment> \<open>base case, is axiom, starts with PAtom\<close>
     apply(elim conjE exE)
     apply(subgoal_tac "FEval (gs,g) e (PAtom p vs) | FEval (gs,g) e (NAtom p vs)")
      apply(erule disjE) apply(force) apply(rule_tac x="NAtom p vs" in exI) apply(force)
     apply(simp add: Let_def)
      \<comment> \<open>base case, is axiom, starts with NAtom\<close>
    apply(elim conjE exE)
    apply(subgoal_tac "FEval (gs,g) e (PAtom p vs) | FEval (gs,g) e (NAtom p vs)")
      apply(erule disjE) apply(rule_tac x="PAtom p vs" in exI) apply(force) apply(force)
    apply(simp add: Let_def)

    \<comment> \<open>base case, not is axiom: if not a satax, then subs holds... but this can't be\<close>
   apply(drule_tac deriv_upwards) apply(assumption) apply(elim conjE exE) apply(force)

     \<comment> \<open>step case, by case analysis\<close>

  apply(intro allI impI) apply(elim exE conjE)

  apply(case_tac "is_axiom (s_of_ns t)")
    \<comment> \<open>step case, is axiom\<close>
  apply(simp add: Svalid_def) apply(rule,rule) apply(rename_tac gs g) apply(rule) apply(rule) apply(simp add: SEval_def2)
    apply(simp add: s_of_ns_def) apply(case_tac t) apply(simp) apply(simp)
    apply(erule disjE)
     apply(elim conjE exE)
     apply(subgoal_tac "FEval (gs,g) e (PAtom p vs) | FEval (gs,g) e (NAtom p vs)")
      apply(erule disjE) apply(force) apply(rule_tac x="NAtom p vs" in exI) apply(blast)
     apply(simp add: Let_def)
    apply(elim conjE exE)
    apply(subgoal_tac "FEval (gs,g) e (PAtom p vs) | FEval (gs,g) e (NAtom p vs)")
      apply(erule disjE) apply(rule_tac x="PAtom p vs" in exI) apply(blast) apply(simp) apply(force)
    apply(simp add: Let_def)

     \<comment> \<open>we hit FAll/ FEx cases first\<close>

  apply(case_tac "\<exists>(a::nat) f list. t = (a,FAll f)#list")
   apply(elim exE) apply(simp)
   apply(subgoal_tac "a = 0")
    prefer 2
    apply(rule_tac n=na and u=t and A="FAll f" in index0[rule_format])
    apply(assumption) apply(simp) apply(simp) apply(simp)
   apply(frule_tac deriv.step) apply(simp add: Let_def)  \<comment> \<open>nice use of simp to instantiate\<close>
   apply(drule_tac x="Suc na" in spec, drule_tac x="list @ [(0, finst f (newvar (sfv (s_of_ns t))))]" in spec) apply(erule impE, simp)
   apply(subgoal_tac "newvar (sfv (s_of_ns t)) \<notin> set (sfv (s_of_ns t))")
    prefer 2 apply(rule newvar)
   apply(simp)
   apply(simp add: s_of_ns_def)
   apply(frule_tac sound_FAll) apply(simp) apply(simp)

  apply(case_tac "\<exists>a f list. t = (a,FEx f)#list")
   apply(elim exE)
   apply(frule_tac deriv.step) apply(simp add: Let_def) \<comment> \<open>nice use of simp to instantiate\<close>
   apply(drule_tac x="Suc na" in spec, drule_tac x="list @ [(0, finst f a), (Suc a, FEx f)]" in spec) apply(erule impE, assumption)
   apply(drule_tac x="Suc na" in spec, drule_tac x="list @ [(0, finst f a), (Suc a, FEx f)]" in spec) apply(erule impE) apply(rule) apply(arith) apply(assumption)
   apply(subgoal_tac "Svalid (s_of_ns (list@[(0,finst f a), (Suc a, FEx f)]))")
    apply(simp add: s_of_ns_def)
    apply(frule_tac sound_FEx) apply(simp) apply(simp)

  \<comment> \<open>now for other cases\<close>
      \<comment> \<open>case empty list\<close>
  apply(case_tac t) apply(simp)
   apply(frule_tac step) apply(simp) apply(simp) apply(drule_tac x="Suc na" in spec) back apply(drule_tac x="[]" in spec) apply(erule impE) apply(rule) apply(arith) apply(assumption) apply(assumption)

  apply(simp add: Svalid_def) apply(rule,rule) apply(rename_tac gs g) apply(rule) apply(rule) apply(simp add: SEval_def2)
  \<comment> \<open>na t in deriv, so too is subs\<close>
   \<comment> \<open>if not a satax, then subs holds...\<close>
  apply(case_tac a)
  apply(case_tac b)
       apply(simp del: FEval.simps) apply(frule_tac patom) apply(assumption)
       apply(rename_tac nat lista)
       apply(frule_tac x="Suc na" in spec, drule_tac x="list @ [(0, PAtom nat lista)]" in spec)
       apply(erule impE) apply(arith)
       apply(drule_tac x=gs in spec, drule_tac x=g in spec, drule_tac x=e in spec) apply(erule impE) apply(simp add: is_env_def)
       apply(elim exE conjE) apply(rule_tac x=f in exI) apply(simp add: s_of_ns_def) \<comment> \<open>weirdly, simp succeeds, force and blast fail\<close>
      apply(simp del: FEval.simps) apply(frule_tac natom) apply(assumption)
      apply(rename_tac nat lista)
      apply(frule_tac x="Suc na" in spec, drule_tac x="list @ [(0, NAtom nat lista)]" in spec)
      apply(erule impE) apply(arith)
      apply(drule_tac x=gs in spec, drule_tac x=g in spec, drule_tac x=e in spec) apply(erule impE, simp)
      apply(elim exE conjE) apply(rule_tac x=f in exI) apply(simp add: s_of_ns_def)
     apply(simp del: FEval.simps) apply(frule_tac fconj1) apply(assumption) apply(frule_tac fconj2) apply(assumption)
     apply(rename_tac form1 form2)
     apply(frule_tac x="Suc na" in spec, drule_tac x="list @ [(0, form1)]" in spec)
     apply(erule impE) apply(arith)
     apply(drule_tac x=gs in spec, drule_tac x=g in spec, drule_tac x=e in spec) apply(erule impE, simp) apply(elim exE conjE)
     apply(drule_tac x="Suc na" in spec, drule_tac x="list @ [(0, form2)]" in spec)
     apply(erule impE) apply(arith)
     apply(drule_tac x=gs in spec, drule_tac x=g in spec, drule_tac x=e in spec) apply(erule impE, simp) apply(elim exE conjE)
     apply(simp only: s_of_ns_def)
     apply(simp)
     apply(elim disjE)
        apply(simp) apply(rule_tac x="FConj form1 form2" in exI) apply(simp)
       apply(simp) apply(rule_tac x="fa" in exI) apply(simp)
      apply(simp) apply(rule_tac x="f" in exI) apply(simp)
     apply(rule_tac x="f" in exI, simp)
    apply(simp del: FEval.simps) apply(frule_tac fdisj) apply(assumption)
    apply(rename_tac form1 form2)
    apply(frule_tac x="Suc na" in spec, drule_tac x="list @ [(0, form1),(0,form2)]" in spec)
    apply(erule impE) apply(arith)
    apply(drule_tac x=gs in spec, drule_tac x=g in spec, drule_tac x=e in spec) apply(erule impE, simp) apply(elim exE conjE)
    apply(simp add: s_of_ns_def)
    apply(elim disjE)
      apply(simp) apply(rule_tac x="FDisj form1 form2" in exI) apply(simp)
     apply(simp) apply(rule_tac x="FDisj form1 form2" in exI) apply(simp)
    apply(rule_tac x="f" in exI) apply(simp)
      \<comment> \<open>all case\<close>
   apply(force)
  apply(force)
  done

subsection "Contains, Considers"

definition
  "contains" :: "(nat => (nat*nseq)) => nat => nform => bool" where
  "contains f n nf = (nf \<in> set (snd (f n)))"

definition
  considers :: "(nat => (nat*nseq)) => nat => nform => bool" where
  "considers f n nf = (case snd (f n) of [] => False | (x#xs) => x = nf)"

lemma (in loc1) progress: "infinite (deriv s) ==> snd (f n) = a#list --> (\<exists>zs'. snd (f (Suc n)) = list@zs')"
  apply(subgoal_tac "(snd (f (Suc n))) : set (subs (snd (f n)))") defer apply(frule_tac is_path_f) apply(blast)
  apply(case_tac a)
  apply(case_tac b)
  apply(safe)
  apply(simp_all add: Let_def split: if_splits)
  apply(erule disjE)
  apply(simp_all)
  done

lemma (in loc1) contains_considers': "infinite (deriv s) ==> \<forall>n y ys. snd (f n) = xs@y#ys --> (\<exists>m zs'. snd (f (n+m)) = y#zs')"
  apply(induct_tac xs)
  apply(rule,rule,rule,rule) apply(rule_tac x=0 in exI) apply(rule_tac x=ys in exI) apply(force)

  apply(rule,rule,rule,rule) apply(simp) apply(frule_tac progress) apply(erule impE) apply(assumption)
  apply(erule exE) apply(simp)

  apply(drule_tac x="Suc n" in spec)
  apply(case_tac y) apply(rename_tac u v)
  apply(drule_tac x="u" in spec)
  apply(drule_tac x="v" in spec)
  apply(erule impE) apply(force)

  apply(elim exE)
  apply(rule_tac x="Suc m" in exI)
  apply(force)
  done

lemma list_decomp[rule_format]: "v \<in> set p --> (\<exists> xs ys. p = xs@(v#ys) \<and> v \<notin> set xs)"
  apply(induct p)
  apply(force)
  apply(case_tac "v=a")
   apply(force)
  apply(auto)
  apply(rule_tac x="a#xs" in exI)
  apply(auto)
  done

lemma (in loc1) contains_considers: "infinite (deriv s) ==> contains f n y ==> (\<exists>m. considers f (n+m) y)"
  apply(simp add: contains_def considers_def)
  apply(frule_tac list_decomp) apply(elim exE conjE)
  apply(frule_tac contains_considers'[rule_format]) apply(assumption) apply(elim exE)
  apply(rule_tac x=m in exI)
  apply(force)
  done

lemma (in loc1) contains_propagates_patoms[rule_format]: "infinite (deriv s) ==> contains f n (0, PAtom p vs) --> contains f (n+q) (0, PAtom p vs)"
  apply(induct_tac q) apply(simp)
  apply(rule)
  apply(erule impE) apply(assumption)
  apply(subgoal_tac "~is_axiom (s_of_ns (snd (f (n+na))))") defer
   apply(subgoal_tac "infinite (deriv (snd (f (n+na))))") defer
    apply(force dest: is_path_f)
   defer
   apply(rule) apply(simp add: deriv_is_axiom)
  apply(simp add: contains_def)
  apply(drule_tac p="snd (f (n + na))" in list_decomp)
  apply(elim exE conjE)
  apply(case_tac xs)
   apply(simp)
   apply(subgoal_tac "(snd (f (Suc (n + na)))) : set (subs (snd (f (n + na))))")
    apply(simp add: Let_def split: if_splits)
   apply(frule_tac is_path_f) apply(drule_tac x="n+na" in spec) apply(force)
  apply(drule_tac progress)
  apply(erule impE) apply(force)
  apply(force)
  done

lemma (in loc1) contains_propagates_natoms[rule_format]: "infinite (deriv s) ==> contains f n (0, NAtom p vs) --> contains f (n+q) (0, NAtom p vs)"
  apply(induct_tac q) apply(simp)
  apply(rule)
  apply(erule impE) apply(assumption)
  apply(subgoal_tac "~is_axiom (s_of_ns (snd (f (n+na))))") defer
   apply(subgoal_tac "infinite (deriv (snd (f (n+na))))") defer
    apply(force dest: is_path_f)
   defer
   apply(rule) apply(simp add: deriv_is_axiom)
  apply(simp add: contains_def)
  apply(drule_tac p = "snd (f (n + na))" in list_decomp)
  apply(elim exE conjE)
  apply(case_tac xs)
   apply(simp)
   apply(subgoal_tac "(snd (f (Suc (n + na)))) : set (subs (snd (f (n + na))))")
    apply(simp add: Let_def split: if_splits)
   apply(frule_tac is_path_f) apply(drule_tac x="n+na" in spec) apply(force)
  apply(drule_tac progress)
  apply(erule impE) apply(force)
  apply(force)
  done

lemma (in loc1) contains_propagates_fconj: "infinite (deriv s) ==> contains f n (0, FConj g h) ==> (\<exists>y. contains f (n+y) (0,g) | contains f (n+y) (0,h))"
  apply(subgoal_tac "(\<exists>l. considers f (n+l) (0,FConj g h))") defer apply(rule contains_considers) apply(assumption) apply(assumption)
  apply(erule exE)
  apply(rule_tac x="Suc l" in exI)
  apply(simp add: considers_def) apply(case_tac "snd (f (n + l))", simp)
  apply(simp)
  apply(subgoal_tac "(snd (f (Suc (n + l)))) : set (subs (snd (f (n + l))))")
   apply(simp add: contains_def Let_def) apply(force)
  apply(frule_tac is_path_f) apply(drule_tac x="n+l" in spec) apply(force)
  done

lemma (in loc1) contains_propagates_fdisj: "infinite (deriv s) ==> contains f n (0, FDisj g h) ==> (\<exists>y. contains f (n+y) (0,g) & contains f (n+y) (0,h))"
  apply(subgoal_tac "(\<exists>l. considers f (n+l) (0,FDisj g h))") defer apply(rule contains_considers) apply(assumption) apply(assumption)
  apply(erule exE)
  apply(rule_tac x="Suc l" in exI)
  apply(simp add: considers_def) apply(case_tac "snd (f (n + l))", simp)
  apply(simp)
  apply(subgoal_tac " (snd (f (Suc (n + l)))) : set (subs (snd (f (n + l))))")
   apply(simp add: contains_def Let_def)
  apply(frule_tac is_path_f) apply(drule_tac x="n+l" in spec) apply(force)
  done

lemma (in loc1) contains_propagates_fall: "infinite (deriv s) ==> contains f n (0, FAll g)
  ==> (\<exists>y. contains f (Suc(n+y)) (0,finst g (newvar (sfv (s_of_ns (snd (f (n+y))))))))" \<comment> \<open>may need constraint on fv\<close>
  apply(subgoal_tac "(\<exists>l. considers f (n+l) (0,FAll g))") defer apply(rule contains_considers) apply(assumption) apply(assumption)
  apply(erule exE)
  apply(rule_tac x="l" in exI)
  apply(simp add: considers_def) apply(case_tac "snd (f (n + l))", simp)
  apply(simp)
  apply(subgoal_tac "(snd (f (Suc (n + l)))) : set (subs (snd (f (n + l))))")
   apply(simp add: contains_def Let_def)
  apply(frule_tac is_path_f) apply(drule_tac x="n+l" in spec) apply(force)
  done

lemma (in loc1) contains_propagates_fex: "infinite (deriv s) ==> contains f n (m, FEx g)
  ==> (\<exists>y.
  (contains f (n+y) (0,finst g m))
  & (contains f (n+y) (Suc m,FEx g)))"
  apply(subgoal_tac "(\<exists>l. considers f (n+l) (m,FEx g))") defer apply(rule contains_considers) apply(assumption) apply(assumption)
  apply(erule exE)
  apply(rule_tac x="Suc l" in exI)
  apply(simp add: considers_def) apply(case_tac "snd (f (n + l))", simp)
  apply(simp)
  apply(subgoal_tac " (snd (f (Suc (n + l)))) : set (subs (snd (f (n + l))))")
   apply(simp add: contains_def Let_def)
  apply(frule_tac is_path_f) apply(drule_tac x="n+l" in spec) apply(force)
  done

  \<comment> \<open>also need that if contains one, then contained an original at beginning\<close>
  \<comment> \<open>existentials: show that for exists formulae, if Suc m is marker, then there must have been m\<close>
  \<comment> \<open>show this by showing that nodes are upwardly closed, i.e. if never contains (m,x), then never contains (Suc m, x), by induction on n\<close>

lemma (in loc1) FEx_downward: "infinite (deriv s) ==> init s ==> \<forall>m. (Suc m,FEx g) \<in> set (snd (f n)) --> (\<exists>n'. (m, FEx g) \<in> set (snd (f n')))"
  apply(frule_tac is_path_f)
  apply(induct_tac n)
   apply(drule_tac x="0" in spec) apply(case_tac "f 0") apply(force simp: init_def)
  apply(intro allI impI)
  apply(frule_tac x="Suc n" in spec, elim conjE) apply(drule_tac x="n" in spec, elim conjE)
  apply(thin_tac "(snd (f (Suc (Suc n)))) : set (subs (snd (f (Suc n))))")
  apply(case_tac "f n") apply(simp)
  apply(case_tac b) apply(simp)
  apply(case_tac aa) apply(case_tac ba)
       apply(simp add: Let_def split: if_splits)
      apply(simp add: Let_def split: if_splits)
     apply(force simp add: Let_def)
    apply(force simp add: Let_def)
   apply(force simp add: Let_def)
  apply(rename_tac form)
  apply(case_tac "(ab, FEx form) = (m, FEx g)")
   apply(rule_tac x=n in exI) apply(force)
  apply(force simp add: Let_def)
  done

lemma (in loc1) FEx0: "infinite (deriv s) ==> init s ==> \<forall>n. contains f n (m,FEx g) --> (\<exists>n'. contains f n' (0, FEx g))"
  apply(simp add: contains_def)
  apply(induct_tac m)
   apply(force)
  apply(intro allI impI) apply(erule exE)
  apply(drule_tac FEx_downward[rule_format]) apply(assumption) apply(force)
  apply(elim exE conjE)
  apply(force)
  done

lemma (in loc1) FEx_upward': "infinite (deriv s) ==> init s ==> \<forall>n. contains f n (0, FEx g) --> (\<exists>n'. contains f n' (m, FEx g))"
  apply(intro allI impI)
  apply(induct_tac m) apply(force)
  apply(erule exE)
  apply(frule_tac n=n' in contains_considers) apply(assumption)
  apply(erule exE)
  apply(rule_tac x="Suc(n'+m)" in exI)
  apply(frule_tac is_path_f)
  apply(simp add: considers_def) apply(case_tac "snd (f (n'+m))") apply(force)
  apply(simp)
  apply(drule_tac x="n'+m" in spec)
  apply(force simp add: contains_def considers_def Let_def)
  done
  \<comment> \<open>FIXME contains and considers aren't buying us much\<close>

lemma (in loc1) FEx_upward: "infinite (deriv s) ==> init s ==> contains f n (m, FEx g) ==> (\<forall>m'. \<exists>n'. contains f n' (0, finst g m'))"
  apply(intro allI impI)
  apply(subgoal_tac "\<exists>n'. contains f n' (m', FEx g)") defer
  apply(frule_tac m = m and g = g in FEx0) apply(assumption)
  apply(drule_tac x=n in spec)
  apply(simp)
  apply(elim exE)
  apply(frule_tac g=g and m=m' in FEx_upward') apply(assumption)
  apply (blast dest: contains_propagates_fex intro: elim:)+
  done

subsection "Models 2"

axiomatization ntou :: "nat => U"
where ntou: "inj ntou"  \<comment> \<open>assume universe set is infinite\<close>

definition uton :: "U => nat" where "uton = inv ntou"

lemma uton_ntou: "uton (ntou x) = x"
  apply(simp add: uton_def) apply(simp add: ntou inv_f_f) done

lemma map_uton_ntou[simp]: "map uton (map ntou xs) = xs"
  apply(induct xs, auto simp: uton_ntou) done

lemma ntou_uton: "x \<in> range ntou ==> ntou (uton x) = x"
  apply(simp add: uton_def)
  apply(simp add: f_inv_into_f) done

subsection "Falsifying Model From Failing Path"

definition model :: "nseq => model" where
  "model s = (range ntou, % p ms. (let f = failing_path (deriv s) in
    (\<forall>n m. ~ contains f n (m,PAtom p (map uton ms)))))"

locale loc2 = loc1 +
  fixes mo
  assumes mo: "mo = model s"

lemma is_env_model_ntou: "is_env (model s) ntou"
  apply(simp add: is_env_def) apply(simp add: model_def) done

lemma (in loc1) [simp]: "infinite (deriv s) ==> init s ==> (contains f n (m,A)) ==> ~ is_FEx A ==> m = 0"
  apply(frule_tac n=n in index0)
  apply(frule_tac is_path_f) apply(drule_tac x=n in spec) apply(case_tac "f n")
  apply(simp)
  apply(simp add: contains_def)
  apply(force)
  done

lemma (in loc2) model':
  notes [simp] = FEval_subst
  notes [simp del] = is_axiom.simps
  shows "infinite (deriv s) ==> init s ==> \<forall>A. size A = h --> (\<forall>m n. contains f n (m,A) --> ~ (FEval mo ntou A))"

  apply(rule_tac nat_less_induct) apply(rule, rule) apply(case_tac A)
       apply(rule,rule,rule) apply(simp add: mo Let_def) apply(simp add: model_def Let_def del: map_map) apply(simp only: f[symmetric]) apply(force)

      apply(rule,rule,rule) apply(simp add: mo Let_def) apply(simp add: model_def Let_def del: map_map) apply(simp only: f[symmetric]) apply(rule ccontr) apply(simp del: map_map) apply(elim exE)
      apply(subgoal_tac "m = 0 & ma = 0") prefer 2 apply(simp del: map_map)
      apply(simp del: map_map)
      apply(rename_tac nat list m na nb ma)
      apply(subgoal_tac "? y. considers f (nb+na+y) (0, PAtom nat list)") prefer 2 apply(rule contains_considers) apply(assumption)
       apply(rule contains_propagates_patoms) apply(assumption) apply(assumption)
      apply(erule exE)
      apply(subgoal_tac "contains f (na+nb+y) (0, NAtom nat list)")
       apply(subgoal_tac "nb+na=na+nb")
        apply(simp) apply(subgoal_tac "is_axiom (s_of_ns (snd (f (na+nb+y))))")
         apply(drule_tac is_axiom_finite_deriv) apply(force dest: is_path_f)
        apply(simp add: contains_def considers_def) apply(case_tac "snd (f (na + nb + y))") apply(simp) apply(simp add: s_of_ns_def is_axiom.simps) apply(force)
       apply(force)
      apply(force intro: contains_propagates_natoms contains_propagates_patoms)

     apply(intro impI allI)
     apply(subgoal_tac "m=0") prefer 2 apply(simp) apply(simp del: FEval.simps)
     apply(frule_tac contains_propagates_fconj) apply(assumption)
     apply(rename_tac form1 form2 m na)
     apply(frule_tac x="size form1" in spec) apply(erule impE) apply(force) apply(drule_tac x="form1" in spec) apply(drule_tac x="size form2" in spec) apply(erule impE) apply(force) apply(simp)
     apply(force)

    apply(intro impI allI)
    apply(subgoal_tac "m=0") prefer 2 apply(simp) apply(simp del: FEval.simps)
    apply(frule_tac contains_propagates_fdisj) apply(assumption)
    apply(rename_tac form1 form2 m na)
    apply(frule_tac x="size form1" in spec) apply(erule impE) apply(force) apply(drule_tac x="form1" in spec) apply(drule_tac x="size form2" in spec) apply(erule impE) apply(force) apply(simp)
    apply(force)

   apply(intro impI allI)
   apply(subgoal_tac "m=0") prefer 2 apply(simp) apply(simp del: FEval.simps)
   apply(frule_tac contains_propagates_fall) apply(assumption)
   apply(erule exE) \<comment> \<open>all case\<close>
   apply(rename_tac form m na y)
   apply(drule_tac x="size form" in spec) apply(erule impE, force) apply(drule_tac x="finst form (newvar (sfv (s_of_ns (snd (f (na + y))))))" in spec) apply(erule impE, force)
   apply(erule impE, force) apply(simp add: FEval_finst) apply(rule_tac x="ntou (newvar (sfv (s_of_ns (snd (f (na + y))))))" in bexI) apply(assumption)
   using is_env_model_ntou[of s] apply(simp add: is_env_def mo)

  apply(intro impI allI) apply(simp del: FEval.simps)
  apply(frule_tac FEx_upward) apply(assumption) apply(assumption)
  apply(simp)
  apply(rule)
  apply(rename_tac form m na ma)
  apply(subgoal_tac "\<forall>m'. ~ FEval mo ntou (finst form m')")
   prefer 2 apply(rule)
   apply(drule_tac x="size form" in spec) apply(erule impE, force)
   apply(drule_tac x="finst form m'" in spec) apply(erule impE, force) apply(erule impE) apply(force) apply(simp add: id_def)
  apply(simp add: FEval_finst id_def)
  apply(drule_tac x="uton ma" and P="%m'. ~ (P m')" for P in spec)
  apply(subgoal_tac "ma \<in> range ntou") apply(frule_tac ntou_uton) apply(simp)
   apply(simp add: mo model_def)
  done

lemma (in loc2) model: "infinite (deriv s) ==> init s ==> (\<forall>A m n. contains f n (m,A) --> ~ (FEval mo ntou A))"
  apply(rule)
  apply(frule_tac model') apply(auto) done

subsection "Completeness"

lemma (in loc2) completeness': "infinite (deriv s) ==> init s ==> \<forall>mA \<in> set s. ~ FEval mo ntou (snd mA)" \<comment> \<open>FIXME tidy deriv s so that s consists of formulae only?\<close>
  apply(frule_tac model) apply(assumption)
  apply(rule)
  apply(case_tac mA)
  apply(drule_tac x="b" in spec) apply(drule_tac x="0" in spec) apply(drule_tac x=0 in spec) apply(erule impE)
   apply(simp add: contains_def) apply(frule_tac is_path_f_0) apply(simp)
   apply(subgoal_tac "a=0")
    prefer 2 apply(simp only: init_def, force)
  apply auto
  done \<comment> \<open>FIXME very ugly\<close>

thm loc2.completeness'[simplified loc2_def loc2_axioms_def loc1_def]

lemma completeness': "infinite (deriv s) ==> init s ==> \<forall>mA \<in> set s. ~ FEval (model s) ntou (snd mA)"
  apply(rule loc2.completeness'[simplified loc2_def loc2_axioms_def loc1_def])
  apply(auto) done

lemma completeness'': "infinite (deriv (ns_of_s s)) ==> init (ns_of_s s) ==> \<forall>A. A \<in> set s --> ~ FEval (model (ns_of_s s)) ntou A"
  apply(frule_tac completeness') apply(assumption)
  apply(simp add: ns_of_s_def)
  done

lemma completeness: "infinite (deriv (ns_of_s s)) ==> ~ Svalid s"
  apply(subgoal_tac "init (ns_of_s s)")
   prefer 2 apply(simp add: init_def ns_of_s_def)
  apply(frule_tac completeness'') apply(assumption)
  apply(simp add: Svalid_def)
  apply(simp add: SEval_def2)
  apply(rule_tac x="fst (model (ns_of_s s))" in exI)
  apply(rule_tac x="snd (model (ns_of_s s))" in exI)
  apply(rule_tac x="ntou" in exI)
  apply(simp add: model_def)
  apply(simp add: is_env_def)
  done
\<comment> \<open>FIXME silly splitting of quantified pairs\<close>

subsection "Sound and Complete"

lemma "Svalid s = finite (deriv (ns_of_s s))"
  using soundness completeness by blast

subsection "Algorithm"

primrec iter :: "('a => 'a) => 'a => nat => 'a" \<comment> \<open>fold for nats\<close>
where
  "iter g a 0 = a"
| "iter g a (Suc n) = g (iter g a n)"

lemma iter: "\<forall>a. (iter g (g a) n) = (g (iter g a n))"
  apply(induct n)
  apply(simp)
  apply(simp)
  done

lemma ex_iter': "(\<exists>n. R (iter g a n)) = (R a | (\<exists>n. R (iter g (g a) n)))"
  apply(rule)
   apply(erule exE)
   apply(case_tac n)
    apply(simp)
   apply(rule disjI2)
   apply(rule_tac x=nat in exI)
   apply(simp add: iter)
  apply(erule disjE)
   apply(rule_tac x=0 in exI, simp)
  apply(erule exE) apply(rule_tac x="Suc n" in exI)
  apply(simp add: iter)
  done

    \<comment> \<open>version suitable for computation\<close>
lemma ex_iter: "(\<exists>n. R (iter g a n)) = (if R a then True else (\<exists>n. R (iter g (g a) n)))"
  apply (rule trans)
  apply (rule ex_iter')
  apply (force )
  done

definition
  f :: "nseq list => nat => nseq list" where
  "f s n = iter (% x. flatten (map subs x)) s n"

lemma f_upwards: "f s n = [] ==> f s (n+m) = []"
  apply(induct_tac m) apply(simp)
  apply(simp add: f_def)
  done

lemma flatten_append: "flatten (xs@ys) = ((flatten xs) @ (flatten ys))"
  apply(induct xs) by auto

lemma set_flatten: "set (flatten xs) = Union (set ` set xs)"
  apply(induct xs) apply(simp)
  apply(simp)
  done

lemma f: "\<forall>x. ((n,x) \<in> deriv s) = (x \<in> set (f [s] n))"
  apply(induct n)
  apply(simp) apply(simp add: f_def)
  apply(rule)
  apply(rule)
   apply(drule_tac deriv_downwards)
   apply(elim exE conjE)
   apply(drule_tac x=y in spec)
   apply(simp)
   apply(drule_tac list_decomp) apply(elim exE conjE)
   apply(simp add: flatten_append f_def Let_def)
  apply(simp add: f_def)
  apply(simp add: set_flatten)
  apply(erule bexE)
  apply(drule_tac x=xa in spec)
  apply(rule step) apply(auto)
  done

lemma deriv_f: "deriv s = (\<Union>x. set (map (Pair x) (f [s] x)))"
  using f by (auto simp add: set_eq_iff)

lemma finite_f: "finite (set (f s x))"
  by (fact finite_set)

lemma finite_deriv: "finite (deriv s) = (\<exists>m. f [s] m = [])"
  apply(rule)
   apply(subgoal_tac "finite (fst ` (deriv s))") prefer 2 apply(simp)
   apply(frule_tac max_exists) apply(erule impE) apply(simp) apply(subgoal_tac "(0,s) \<in> deriv s") apply(force) apply(simp)
   apply(elim exE conjE)
   apply(rule_tac x="Suc x" in exI)
   apply(simp)
   apply(rule ccontr) apply(case_tac "f [s] (Suc x)") apply(simp)
   apply(subgoal_tac "(Suc x, a) \<in> deriv s") apply(force)
   apply(simp add: f)
  apply(erule exE)
  apply(subgoal_tac "\<forall>y. f [s] (m+y) = []")
   prefer 2 apply(rule) apply(rule f_upwards) apply(assumption)
  apply(simp add: deriv_f)
  apply(subgoal_tac "(UNIV::nat set) = {y. y < m} Un {y. m \<le> y}")
   prefer 2 apply force
  apply(erule_tac t="UNIV::nat set" in ssubst)
  apply(simp)
  apply(subgoal_tac "(UN x:Collect ((\<le>) m). Pair x ` set (f [s] x)) =  (UN x:Collect ((\<le>) m). {})") apply(simp only:) apply(force)
  apply(rule SUP_cong) apply(force) apply(drule_tac x="x-m" in spec) apply(force)
  done

lemma ex_iter_fSucn: "(\<exists>m. iter (% x. flat (map subs x)) l m = []) = (if l = [] then True else (\<exists>n. (iter (% x. flat (map subs x)) ((% x. flat (map subs x)) l) n) = []))"
  using ex_iter[of "% x. x = []", of "(% x. flat (map subs x))" l ] apply(force) done

definition prove' :: "nseq list => bool" where
  "prove' s = (\<exists>m. iter (% x. flatten (map subs x)) s m = [])"

lemma prove': "prove' l = (if l = [] then True else prove' ((% x. flatten (map subs x)) l))"
  apply(simp only: prove'_def)
  apply(rule ex_iter_fSucn)
  done
    \<comment> \<open>this is the main claim for efficiency- we have a tail recursive implementation via this lemma\<close>

definition prove :: "nseq => bool" where "prove s = prove' ([s])"

lemma finite_deriv_prove: "finite (deriv s) = prove s"
  by (simp add: finite_deriv prove_def prove'_def f_def)

subsection "Computation"

  \<comment> \<open>a sample formula to prove\<close>
lemma "(\<exists>x. A x | B x) --> ( (\<exists>x. B x) | (\<exists>x. A x))" by blast

  \<comment> \<open>convert to our form\<close>
lemma "((\<exists>x. A x | B x) --> ( (\<exists>x. B x) | (\<exists>x. A x)))
  = ( (\<forall>x. ~ A x & ~ B x) | ( (\<exists>x. B x) | (\<exists>x. A x)))" by blast

definition my_f :: "form" where
  "my_f = FDisj
  (FAll (FConj (NAtom 0 [0]) (NAtom 1 [0])))
  (FDisj (FEx (PAtom 1 [0])) (FEx (PAtom 0 [0])))"

  \<comment> \<open>we compute by rewriting\<close>

lemma membership_simps:
  "x \<in> set [] \<longleftrightarrow> False"
  "x \<in> set (y # ys) \<longleftrightarrow> x = y \<or> x \<in> set ys"
  by simp_all

lemmas ss = list.inject if_True if_False flatten.simps list.map
  bump_def sfv_def filter.simps is_axiom.simps fst_conv snd_conv
  form.simps collect_disj inc_def finst_def ns_of_s_def s_of_ns_def
  Let_def newvar_def subs.simps split_beta append_Nil append_Cons
  subst.simps nat.simps fv.simps maxvar.simps preSuc.simps simp_thms
  membership_simps

lemmas prove'_Nil = prove' [of "[]", simplified]
lemmas prove'_Cons = prove' [of "x#l", simplified] for x l

lemma search: "finite (deriv [(0,my_f)])"
  apply(simp add: my_f_def finite_deriv_prove prove_def)
  apply(simp only: prove'_Nil prove'_Cons ss)
  done

abbreviation Sprove :: "form list \<Rightarrow> bool" where "Sprove \<equiv> prove o ns_of_s"

abbreviation check :: "form \<Rightarrow> bool" where "check formula \<equiv> Sprove [formula]"

abbreviation valid :: "form \<Rightarrow> bool" where "valid formula \<equiv> Svalid [formula]"

theorem "check = valid" using soundness completeness finite_deriv_prove by auto

ML \<open>

fun max x y = if x > y then x else y;

fun flatten [] = []
  | flatten (a::list) = a @ (flatten list);

type pred = int;

type var = int;

datatype form =
    PAtom of pred * (var list)
  | NAtom of pred * (var list)
  | FConj of form * form
  | FDisj of form * form
  | FAll  of form
  | FEx   of form;

fun preSuc [] = []
  | preSuc (a::list) = if a = 0 then preSuc list else (a-1)::(preSuc list);

fun fv (PAtom (_,vs)) = vs
  | fv (NAtom (_,vs)) = vs
  | fv (FConj (f,g)) = (fv f) @ (fv g)
  | fv (FDisj (f,g)) = (fv f) @ (fv g)
  | fv (FAll f) = preSuc (fv f)
  | fv (FEx f)  = preSuc (fv f);

fun subst r (PAtom (p,vs)) = PAtom (p,map r vs)
  | subst r (NAtom (p,vs)) = NAtom (p,map r vs)
  | subst r (FConj (f,g)) = FConj (subst r f,subst r g)
  | subst r (FDisj (f,g)) = FDisj (subst r f,subst r g)
  | subst r (FAll f) = FAll (subst (fn 0 => 0 | v => (r (v-1))+1) f)
  | subst r (FEx f)  = FEx  (subst (fn 0 => 0 | v => (r (v-1))+1) f);

fun finst body w = subst (fn 0 => w | v => v-1) body;

fun s_of_ns ns = map (fn (_,y) => y) ns;

fun ns_of_s s = map (fn y => (0,y)) s;

fun sfv s = flatten (map fv s);

fun maxvar [] = 0
  | maxvar (a::list) = max a (maxvar list);

fun newvar vs = if vs = [] then 0 else (maxvar vs)+1;

fun test [] _ = false
  | test ((_,y)::list) z = if y = z then true else test list z;

fun subs [] = [[]]
  | subs (x::xs) = let val (n,f') = x in case f' of
      PAtom (p,vs) => if test xs (NAtom (p,vs)) then [] else [xs @ [(0,PAtom (p,vs))]]
    | NAtom (p,vs) => if test xs (PAtom (p,vs)) then [] else [xs @ [(0,NAtom (p,vs))]]
    | FConj (f,g) => [xs @ [(0,f)],xs @ [(0,g)]]
    | FDisj (f,g) => [xs @ [(0,f),(0,g)]]
    | FAll f => [xs @ [(0,finst f (newvar (sfv (s_of_ns (x::xs)))))]]
    | FEx f  => [xs @ [(0,finst f n),(n+1,f')]]
  end;

fun step s = flatten (map subs s);

fun prove' s = if s = [] then true else prove' (step s);

fun prove s = prove' [s];

fun check f = (prove o ns_of_s) [f];

val my_f = FDisj (
  (FAll (FConj ((NAtom (0,[0])), (NAtom (1,[0])))),
  (FDisj ((FEx ((PAtom (1,[0])))), (FEx (PAtom (0,[0])))))));

check my_f;

\<close>

end