theory Specialisation_Examples
imports Main "~~/src/HOL/Library/Predicate_Compile_Alternative_Defs"
begin

declare [[values_timeout = 960.0]]

section \<open>Specialisation Examples\<close>

primrec nth_el'
where
  "nth_el' [] i = None"
| "nth_el' (x # xs) i = (case i of 0 => Some x | Suc j => nth_el' xs j)"

definition
  "greater_than_index xs = (\<forall>i x. nth_el' xs i = Some x --> x > i)"

code_pred (expected_modes: i => bool) [inductify, skip_proof, specialise] greater_than_index .
ML_val \<open>Core_Data.intros_of @{context} @{const_name specialised_nth_el'P}\<close>

thm greater_than_index.equation

values [expected "{()}"] "{x. greater_than_index [1,2,4,6]}"
values [expected "{}"] "{x. greater_than_index [0,2,3,2]}"

subsection \<open>Common subterms\<close>

text \<open>If a predicate is called with common subterms as arguments,
  this predicate should be specialised.
\<close>

definition max_nat :: "nat => nat => nat"
  where "max_nat a b = (if a <= b then b else a)"

lemma [code_pred_inline]:
  "max = max_nat"
by (simp add: fun_eq_iff max_def max_nat_def)

definition
  "max_of_my_Suc x = max x (Suc x)"

text \<open>In this example, max is specialised, hence the mode o => i => bool is possible\<close>

code_pred (modes: o => i => bool) [inductify, specialise, skip_proof] max_of_my_Suc .

thm max_of_my_SucP.equation

ML_val \<open>Core_Data.intros_of @{context} @{const_name specialised_max_natP}\<close>

values "{x. max_of_my_SucP x 6}"

subsection \<open>Sorts\<close>

declare sorted.Nil [code_pred_intro]
  sorted_single [code_pred_intro]
  sorted_many [code_pred_intro]

code_pred sorted
proof -
  assume "sorted xa"
  assume 1: "xa = [] \<Longrightarrow> thesis"
  assume 2: "\<And>x. xa = [x] \<Longrightarrow> thesis"
  assume 3: "\<And>x y zs. xa = x # y # zs \<Longrightarrow> x \<le> y \<Longrightarrow> sorted (y # zs) \<Longrightarrow> thesis"
  show thesis proof (cases xa)
    case Nil with 1 show ?thesis .
  next
    case (Cons x xs) show ?thesis proof (cases xs)
      case Nil with Cons 2 show ?thesis by simp
    next
      case (Cons y zs)
      show ?thesis
      proof (rule 3)
        from Cons \<open>xa = x # xs\<close> show "xa = x # y # zs" by simp
        with \<open>sorted xa\<close> show "x \<le> y" and "sorted (y # zs)" by simp_all
      qed
    qed
  qed
qed
thm sorted.equation

section \<open>Specialisation in POPLmark theory\<close>

notation
  Some ("\<lfloor>_\<rfloor>")

notation
  None ("\<bottom>")

notation
  length ("\<parallel>_\<parallel>")

notation
  Cons ("_ \<Colon>/ _" [66, 65] 65)

primrec
  nth_el :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" ("_\<langle>_\<rangle>" [90, 0] 91)
where
  "[]\<langle>i\<rangle> = \<bottom>"
| "(x # xs)\<langle>i\<rangle> = (case i of 0 \<Rightarrow> \<lfloor>x\<rfloor> | Suc j \<Rightarrow> xs \<langle>j\<rangle>)"

primrec assoc :: "('a \<times> 'b) list \<Rightarrow> 'a \<Rightarrow> 'b option" ("_\<langle>_\<rangle>\<^sub>?" [90, 0] 91)
where
  "[]\<langle>a\<rangle>\<^sub>? = \<bottom>"
| "(x # xs)\<langle>a\<rangle>\<^sub>? = (if fst x = a then \<lfloor>snd x\<rfloor> else xs\<langle>a\<rangle>\<^sub>?)"

primrec unique :: "('a \<times> 'b) list \<Rightarrow> bool"
where
  "unique [] = True"
| "unique (x # xs) = (xs\<langle>fst x\<rangle>\<^sub>? = \<bottom> \<and> unique xs)"

datatype type =
    TVar nat
  | Top
  | Fun type type    (infixr "\<rightarrow>" 200)
  | TyAll type type  ("(3\<forall><:_./ _)" [0, 10] 10)

datatype binding = VarB type | TVarB type
type_synonym env = "binding list"

primrec is_TVarB :: "binding \<Rightarrow> bool"
where
  "is_TVarB (VarB T) = False"
| "is_TVarB (TVarB T) = True"

primrec type_ofB :: "binding \<Rightarrow> type"
where
  "type_ofB (VarB T) = T"
| "type_ofB (TVarB T) = T"

primrec mapB :: "(type \<Rightarrow> type) \<Rightarrow> binding \<Rightarrow> binding"
where
  "mapB f (VarB T) = VarB (f T)"
| "mapB f (TVarB T) = TVarB (f T)"

datatype trm =
    Var nat
  | Abs type trm   ("(3\<lambda>:_./ _)" [0, 10] 10)
  | TAbs type trm  ("(3\<lambda><:_./ _)" [0, 10] 10)
  | App trm trm    (infixl "\<bullet>" 200)
  | TApp trm type  (infixl "\<bullet>\<^sub>\<tau>" 200)

primrec liftT :: "nat \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> type" ("\<up>\<^sub>\<tau>")
where
  "\<up>\<^sub>\<tau> n k (TVar i) = (if i < k then TVar i else TVar (i + n))"
| "\<up>\<^sub>\<tau> n k Top = Top"
| "\<up>\<^sub>\<tau> n k (T \<rightarrow> U) = \<up>\<^sub>\<tau> n k T \<rightarrow> \<up>\<^sub>\<tau> n k U"
| "\<up>\<^sub>\<tau> n k (\<forall><:T. U) = (\<forall><:\<up>\<^sub>\<tau> n k T. \<up>\<^sub>\<tau> n (k + 1) U)"

primrec lift :: "nat \<Rightarrow> nat \<Rightarrow> trm \<Rightarrow> trm" ("\<up>")
where
  "\<up> n k (Var i) = (if i < k then Var i else Var (i + n))"
| "\<up> n k (\<lambda>:T. t) = (\<lambda>:\<up>\<^sub>\<tau> n k T. \<up> n (k + 1) t)"
| "\<up> n k (\<lambda><:T. t) = (\<lambda><:\<up>\<^sub>\<tau> n k T. \<up> n (k + 1) t)"
| "\<up> n k (s \<bullet> t) = \<up> n k s \<bullet> \<up> n k t"
| "\<up> n k (t \<bullet>\<^sub>\<tau> T) = \<up> n k t \<bullet>\<^sub>\<tau> \<up>\<^sub>\<tau> n k T"

primrec substTT :: "type \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> type"  ("_[_ \<mapsto>\<^sub>\<tau> _]\<^sub>\<tau>" [300, 0, 0] 300)
where
  "(TVar i)[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> =
     (if k < i then TVar (i - 1) else if i = k then \<up>\<^sub>\<tau> k 0 S else TVar i)"
| "Top[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> = Top"
| "(T \<rightarrow> U)[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> = T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> \<rightarrow> U[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>"
| "(\<forall><:T. U)[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau> = (\<forall><:T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>. U[k+1 \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>)"

primrec decT :: "nat \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> type"  ("\<down>\<^sub>\<tau>")
where
  "\<down>\<^sub>\<tau> 0 k T = T"
| "\<down>\<^sub>\<tau> (Suc n) k T = \<down>\<^sub>\<tau> n k (T[k \<mapsto>\<^sub>\<tau> Top]\<^sub>\<tau>)"

primrec subst :: "trm \<Rightarrow> nat \<Rightarrow> trm \<Rightarrow> trm"  ("_[_ \<mapsto> _]" [300, 0, 0] 300)
where
  "(Var i)[k \<mapsto> s] = (if k < i then Var (i - 1) else if i = k then \<up> k 0 s else Var i)"
| "(t \<bullet> u)[k \<mapsto> s] = t[k \<mapsto> s] \<bullet> u[k \<mapsto> s]"
| "(t \<bullet>\<^sub>\<tau> T)[k \<mapsto> s] = t[k \<mapsto> s] \<bullet>\<^sub>\<tau> \<down>\<^sub>\<tau> 1 k T"
| "(\<lambda>:T. t)[k \<mapsto> s] = (\<lambda>:\<down>\<^sub>\<tau> 1 k T. t[k+1 \<mapsto> s])"
| "(\<lambda><:T. t)[k \<mapsto> s] = (\<lambda><:\<down>\<^sub>\<tau> 1 k T. t[k+1 \<mapsto> s])"

primrec substT :: "trm \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> trm"    ("_[_ \<mapsto>\<^sub>\<tau> _]" [300, 0, 0] 300)
where
  "(Var i)[k \<mapsto>\<^sub>\<tau> S] = (if k < i then Var (i - 1) else Var i)"
| "(t \<bullet> u)[k \<mapsto>\<^sub>\<tau> S] = t[k \<mapsto>\<^sub>\<tau> S] \<bullet> u[k \<mapsto>\<^sub>\<tau> S]"
| "(t \<bullet>\<^sub>\<tau> T)[k \<mapsto>\<^sub>\<tau> S] = t[k \<mapsto>\<^sub>\<tau> S] \<bullet>\<^sub>\<tau> T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>"
| "(\<lambda>:T. t)[k \<mapsto>\<^sub>\<tau> S] = (\<lambda>:T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>. t[k+1 \<mapsto>\<^sub>\<tau> S])"
| "(\<lambda><:T. t)[k \<mapsto>\<^sub>\<tau> S] = (\<lambda><:T[k \<mapsto>\<^sub>\<tau> S]\<^sub>\<tau>. t[k+1 \<mapsto>\<^sub>\<tau> S])"

primrec liftE :: "nat \<Rightarrow> nat \<Rightarrow> env \<Rightarrow> env" ("\<up>\<^sub>e")
where
  "\<up>\<^sub>e n k [] = []"
| "\<up>\<^sub>e n k (B \<Colon> \<Gamma>) = mapB (\<up>\<^sub>\<tau> n (k + \<parallel>\<Gamma>\<parallel>)) B \<Colon> \<up>\<^sub>e n k \<Gamma>"

primrec substE :: "env \<Rightarrow> nat \<Rightarrow> type \<Rightarrow> env"  ("_[_ \<mapsto>\<^sub>\<tau> _]\<^sub>e" [300, 0, 0] 300)
where
  "[][k \<mapsto>\<^sub>\<tau> T]\<^sub>e = []"
| "(B \<Colon> \<Gamma>)[k \<mapsto>\<^sub>\<tau> T]\<^sub>e = mapB (\<lambda>U. U[k + \<parallel>\<Gamma>\<parallel> \<mapsto>\<^sub>\<tau> T]\<^sub>\<tau>) B \<Colon> \<Gamma>[k \<mapsto>\<^sub>\<tau> T]\<^sub>e"

primrec decE :: "nat \<Rightarrow> nat \<Rightarrow> env \<Rightarrow> env"  ("\<down>\<^sub>e")
where
  "\<down>\<^sub>e 0 k \<Gamma> = \<Gamma>"
| "\<down>\<^sub>e (Suc n) k \<Gamma> = \<down>\<^sub>e n k (\<Gamma>[k \<mapsto>\<^sub>\<tau> Top]\<^sub>e)"

inductive
  well_formed :: "env \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile>\<^sub>w\<^sub>f _" [50, 50] 50)
where
  wf_TVar: "\<Gamma>\<langle>i\<rangle> = \<lfloor>TVarB T\<rfloor> \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f TVar i"
| wf_Top: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f Top"
| wf_arrow: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f U \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<rightarrow> U"
| wf_all: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<Longrightarrow> TVarB T \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f U \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f (\<forall><:T. U)"

inductive
  well_formedE :: "env \<Rightarrow> bool"  ("_ \<turnstile>\<^sub>w\<^sub>f" [50] 50)
  and well_formedB :: "env \<Rightarrow> binding \<Rightarrow> bool"  ("_ \<turnstile>\<^sub>w\<^sub>f\<^sub>B _" [50, 50] 50)
where
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f\<^sub>B B \<equiv> \<Gamma> \<turnstile>\<^sub>w\<^sub>f type_ofB B"
| wf_Nil: "[] \<turnstile>\<^sub>w\<^sub>f"
| wf_Cons: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f\<^sub>B B \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> B \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f"

inductive_cases well_formed_cases:
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f TVar i"
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f Top"
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f T \<rightarrow> U"
  "\<Gamma> \<turnstile>\<^sub>w\<^sub>f (\<forall><:T. U)"

inductive_cases well_formedE_cases:
  "B \<Colon> \<Gamma> \<turnstile>\<^sub>w\<^sub>f"

inductive
  subtyping :: "env \<Rightarrow> type \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile> _ <: _" [50, 50, 50] 50)
where
  SA_Top: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f S \<Longrightarrow> \<Gamma> \<turnstile> S <: Top"
| SA_refl_TVar: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>w\<^sub>f TVar i \<Longrightarrow> \<Gamma> \<turnstile> TVar i <: TVar i"
| SA_trans_TVar: "\<Gamma>\<langle>i\<rangle> = \<lfloor>TVarB U\<rfloor> \<Longrightarrow>
    \<Gamma> \<turnstile> \<up>\<^sub>\<tau> (Suc i) 0 U <: T \<Longrightarrow> \<Gamma> \<turnstile> TVar i <: T"
| SA_arrow: "\<Gamma> \<turnstile> T\<^sub>1 <: S\<^sub>1 \<Longrightarrow> \<Gamma> \<turnstile> S\<^sub>2 <: T\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> S\<^sub>1 \<rightarrow> S\<^sub>2 <: T\<^sub>1 \<rightarrow> T\<^sub>2"
| SA_all: "\<Gamma> \<turnstile> T\<^sub>1 <: S\<^sub>1 \<Longrightarrow> TVarB T\<^sub>1 \<Colon> \<Gamma> \<turnstile> S\<^sub>2 <: T\<^sub>2 \<Longrightarrow>
    \<Gamma> \<turnstile> (\<forall><:S\<^sub>1. S\<^sub>2) <: (\<forall><:T\<^sub>1. T\<^sub>2)"

inductive
  typing :: "env \<Rightarrow> trm \<Rightarrow> type \<Rightarrow> bool"    ("_ \<turnstile> _ : _" [50, 50, 50] 50)
where
  T_Var: "\<Gamma> \<turnstile>\<^sub>w\<^sub>f \<Longrightarrow> \<Gamma>\<langle>i\<rangle> = \<lfloor>VarB U\<rfloor> \<Longrightarrow> T = \<up>\<^sub>\<tau> (Suc i) 0 U \<Longrightarrow> \<Gamma> \<turnstile> Var i : T"
| T_Abs: "VarB T\<^sub>1 \<Colon> \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda>:T\<^sub>1. t\<^sub>2) : T\<^sub>1 \<rightarrow> \<down>\<^sub>\<tau> 1 0 T\<^sub>2"
| T_App: "\<Gamma> \<turnstile> t\<^sub>1 : T\<^sub>11 \<rightarrow> T\<^sub>12 \<Longrightarrow> \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>11 \<Longrightarrow> \<Gamma> \<turnstile> t\<^sub>1 \<bullet> t\<^sub>2 : T\<^sub>12"
| T_TAbs: "TVarB T\<^sub>1 \<Colon> \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda><:T\<^sub>1. t\<^sub>2) : (\<forall><:T\<^sub>1. T\<^sub>2)"
| T_TApp: "\<Gamma> \<turnstile> t\<^sub>1 : (\<forall><:T\<^sub>11. T\<^sub>12) \<Longrightarrow> \<Gamma> \<turnstile> T\<^sub>2 <: T\<^sub>11 \<Longrightarrow>
    \<Gamma> \<turnstile> t\<^sub>1 \<bullet>\<^sub>\<tau> T\<^sub>2 : T\<^sub>12[0 \<mapsto>\<^sub>\<tau> T\<^sub>2]\<^sub>\<tau>"
| T_Sub: "\<Gamma> \<turnstile> t : S \<Longrightarrow> \<Gamma> \<turnstile> S <: T \<Longrightarrow> \<Gamma> \<turnstile> t : T"

code_pred [inductify, skip_proof, specialise] typing .

thm typing.equation

values 6 "{(E, t, T). typing E t T}"

subsection \<open>Higher-order predicate\<close>

code_pred [inductify] mapB .

subsection \<open>Multiple instances\<close>

inductive subtype_refl' where
  "\<Gamma> \<turnstile> t : T ==> \<not> (\<Gamma> \<turnstile> T <: T) ==> subtype_refl' t T"

code_pred (modes: i => i => bool, o => i => bool, i => o => bool, o => o => bool) [inductify] subtype_refl' .

thm subtype_refl'.equation

end


(*  Title:      HOL/Induct/Com.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1997  University of Cambridge

Example of Mutual Induction via Iteratived Inductive Definitions: Commands
*)

section{*Mutual Induction via Iteratived Inductive Definitions*}

theory Com imports Main begin

typedecl loc
type_synonym state = "loc => nat"

datatype
  exp = N nat
      | X loc
      | Op "nat => nat => nat" exp exp
      | valOf com exp          ("VALOF _ RESULTIS _"  60)
and
  com = SKIP
      | Assign loc exp         (infixl ":=" 60)
      | Semi com com           ("_;;_"  [60, 60] 60)
      | Cond exp com com       ("IF _ THEN _ ELSE _"  60)
      | While exp com          ("WHILE _ DO _"  60)

subsection {* Commands *}

text{* Execution of commands *}

abbreviation (input)
  generic_rel  ("_/ -|[_]-> _" [50,0,50] 50)  where
  "esig -|[eval]-> ns == (esig,ns) \<in> eval"

text{*Command execution.  Natural numbers represent Booleans: 0=True, 1=False*}

inductive_set
  exec :: "((exp*state) * (nat*state)) set => ((com*state)*state)set"
  and exec_rel :: "com * state => ((exp*state) * (nat*state)) set => state => bool"
    ("_/ -[_]-> _" [50,0,50] 50)
  for eval :: "((exp*state) * (nat*state)) set"
  where
    "csig -[eval]-> s == (csig,s) \<in> exec eval"

  | Skip:    "(SKIP,s) -[eval]-> s"

  | Assign:  "(e,s) -|[eval]-> (v,s') ==> (x := e, s) -[eval]-> s'(x:=v)"

  | Semi:    "[| (c0,s) -[eval]-> s2; (c1,s2) -[eval]-> s1 |]
             ==> (c0 ;; c1, s) -[eval]-> s1"

  | IfTrue: "[| (e,s) -|[eval]-> (0,s');  (c0,s') -[eval]-> s1 |]
             ==> (IF e THEN c0 ELSE c1, s) -[eval]-> s1"

  | IfFalse: "[| (e,s) -|[eval]->  (Suc 0, s');  (c1,s') -[eval]-> s1 |]
              ==> (IF e THEN c0 ELSE c1, s) -[eval]-> s1"

  | WhileFalse: "(e,s) -|[eval]-> (Suc 0, s1)
                 ==> (WHILE e DO c, s) -[eval]-> s1"

  | WhileTrue:  "[| (e,s) -|[eval]-> (0,s1);
                    (c,s1) -[eval]-> s2;  (WHILE e DO c, s2) -[eval]-> s3 |]
                 ==> (WHILE e DO c, s) -[eval]-> s3"

declare exec.intros [intro]

inductive_cases
        [elim!]: "(SKIP,s) -[eval]-> t"
    and [elim!]: "(x:=a,s) -[eval]-> t"
    and [elim!]: "(c1;;c2, s) -[eval]-> t"
    and [elim!]: "(IF e THEN c1 ELSE c2, s) -[eval]-> t"
    and exec_WHILE_case: "(WHILE b DO c,s) -[eval]-> t"

text{*Justifies using "exec" in the inductive definition of "eval"*}
lemma exec_mono: "A<=B ==> exec(A) <= exec(B)"
apply (rule subsetI)
apply (simp add: split_paired_all)
apply (erule exec.induct)
apply blast+
done

lemma [pred_set_conv]:
  "((\<lambda>x x' y y'. ((x, x'), (y, y')) \<in> R) <= (\<lambda>x x' y y'. ((x, x'), (y, y')) \<in> S)) = (R <= S)"
  unfolding subset_eq
  by (auto simp add: le_fun_def)

lemma [pred_set_conv]:
  "((\<lambda>x x' y. ((x, x'), y) \<in> R) <= (\<lambda>x x' y. ((x, x'), y) \<in> S)) = (R <= S)"
  unfolding subset_eq
  by (auto simp add: le_fun_def)

text{*Command execution is functional (deterministic) provided evaluation is*}
theorem single_valued_exec: "single_valued ev ==> single_valued(exec ev)"
apply (simp add: single_valued_def)
apply (intro allI)
apply (rule impI)
apply (erule exec.induct)
apply (blast elim: exec_WHILE_case)+
done

subsection {* Expressions *}

text{* Evaluation of arithmetic expressions *}

inductive_set
  eval    :: "((exp*state) * (nat*state)) set"
  and eval_rel :: "[exp*state,nat*state] => bool"  (infixl "-|->" 50)
  where
    "esig -|-> ns == (esig, ns) \<in> eval"

  | N [intro!]: "(N(n),s) -|-> (n,s)"

  | X [intro!]: "(X(x),s) -|-> (s(x),s)"

  | Op [intro]: "[| (e0,s) -|-> (n0,s0);  (e1,s0)  -|-> (n1,s1) |]
                 ==> (Op f e0 e1, s) -|-> (f n0 n1, s1)"

  | valOf [intro]: "[| (c,s) -[eval]-> s0;  (e,s0)  -|-> (n,s1) |]
                    ==> (VALOF c RESULTIS e, s) -|-> (n, s1)"

  monos exec_mono

inductive_cases
        [elim!]: "(N(n),sigma) -|-> (n',s')"
    and [elim!]: "(X(x),sigma) -|-> (n,s')"
    and [elim!]: "(Op f a1 a2,sigma)  -|-> (n,s')"
    and [elim!]: "(VALOF c RESULTIS e, s) -|-> (n, s1)"

lemma var_assign_eval [intro!]: "(X x, s(x:=n)) -|-> (n, s(x:=n))"
  by (rule fun_upd_same [THEN subst]) fast

text{* Make the induction rule look nicer -- though @{text eta_contract} makes the new
    version look worse than it is...*}

lemma split_lemma: "{((e,s),(n,s')). P e s n s'} = Collect (split (%v. split (split P v)))"
  by auto

text{*New induction rule.  Note the form of the VALOF induction hypothesis*}
lemma eval_induct
  [case_names N X Op valOf, consumes 1, induct set: eval]:
  "[| (e,s) -|-> (n,s');
      !!n s. P (N n) s n s;
      !!s x. P (X x) s (s x) s;
      !!e0 e1 f n0 n1 s s0 s1.
         [| (e0,s) -|-> (n0,s0); P e0 s n0 s0;
            (e1,s0) -|-> (n1,s1); P e1 s0 n1 s1
         |] ==> P (Op f e0 e1) s (f n0 n1) s1;
      !!c e n s s0 s1.
         [| (c,s) -[eval Int {((e,s),(n,s')). P e s n s'}]-> s0;
            (c,s) -[eval]-> s0;
            (e,s0) -|-> (n,s1); P e s0 n s1 |]
         ==> P (VALOF c RESULTIS e) s n s1
   |] ==> P e s n s'"
apply (induct set: eval)
apply blast
apply blast
apply blast
apply (frule Int_lower1 [THEN exec_mono, THEN subsetD])
apply (auto simp add: split_lemma)
done

text{*Lemma for @{text Function_eval}.  The major premise is that @{text "(c,s)"} executes to @{text "s1"}
  using eval restricted to its functional part.  Note that the execution
  @{text "(c,s) -[eval]-> s2"} can use unrestricted @{text eval}!  The reason is that
  the execution @{text "(c,s) -[eval Int {...}]-> s1"} assures us that execution is
  functional on the argument @{text "(c,s)"}.
*}
lemma com_Unique:
 "(c,s) -[eval Int {((e,s),(n,t)). \<forall>nt'. (e,s) -|-> nt' --> (n,t)=nt'}]-> s1
  ==> \<forall>s2. (c,s) -[eval]-> s2 --> s2=s1"
apply (induct set: exec)
      apply simp_all
      apply blast
     apply force
    apply blast
   apply blast
  apply blast
 apply (blast elim: exec_WHILE_case)
apply (erule_tac V = "(?c,s2) -[?ev]-> s3" in thin_rl)
apply clarify
apply (erule exec_WHILE_case, blast+)
done

text{*Expression evaluation is functional, or deterministic*}
theorem single_valued_eval: "single_valued eval"
apply (unfold single_valued_def)
apply (intro allI, rule impI)
apply (simp (no_asm_simp) only: split_tupled_all)
apply (erule eval_induct)
apply (drule_tac [4] com_Unique)
apply (simp_all (no_asm_use))
apply blast+
done

lemma eval_N_E [dest!]: "(N n, s) -|-> (v, s') ==> (v = n & s' = s)"
  by (induct e == "N n" s v s' set: eval) simp_all

text{*This theorem says that "WHILE TRUE DO c" cannot terminate*}
lemma while_true_E:
    "(c', s) -[eval]-> t ==> c' = WHILE (N 0) DO c ==> False"
  by (induct set: exec) auto

subsection{* Equivalence of IF e THEN c;;(WHILE e DO c) ELSE SKIP  and
       WHILE e DO c *}

lemma while_if1:
     "(c',s) -[eval]-> t
      ==> c' = WHILE e DO c ==>
          (IF e THEN c;;c' ELSE SKIP, s) -[eval]-> t"
  by (induct set: exec) auto

lemma while_if2:
     "(c',s) -[eval]-> t
      ==> c' = IF e THEN c;;(WHILE e DO c) ELSE SKIP ==>
          (WHILE e DO c, s) -[eval]-> t"
  by (induct set: exec) auto

theorem while_if:
     "((IF e THEN c;;(WHILE e DO c) ELSE SKIP, s) -[eval]-> t)  =
      ((WHILE e DO c, s) -[eval]-> t)"
by (blast intro: while_if1 while_if2)

subsection{* Equivalence of  (IF e THEN c1 ELSE c2);;c
                         and  IF e THEN (c1;;c) ELSE (c2;;c)   *}

lemma if_semi1:
     "(c',s) -[eval]-> t
      ==> c' = (IF e THEN c1 ELSE c2);;c ==>
          (IF e THEN (c1;;c) ELSE (c2;;c), s) -[eval]-> t"
  by (induct set: exec) auto

lemma if_semi2:
     "(c',s) -[eval]-> t
      ==> c' = IF e THEN (c1;;c) ELSE (c2;;c) ==>
          ((IF e THEN c1 ELSE c2);;c, s) -[eval]-> t"
  by (induct set: exec) auto

theorem if_semi: "(((IF e THEN c1 ELSE c2);;c, s) -[eval]-> t)  =
                  ((IF e THEN (c1;;c) ELSE (c2;;c), s) -[eval]-> t)"
  by (blast intro: if_semi1 if_semi2)

subsection{* Equivalence of  VALOF c1 RESULTIS (VALOF c2 RESULTIS e)
                  and  VALOF c1;;c2 RESULTIS e
 *}

lemma valof_valof1:
     "(e',s) -|-> (v,s')
      ==> e' = VALOF c1 RESULTIS (VALOF c2 RESULTIS e) ==>
          (VALOF c1;;c2 RESULTIS e, s) -|-> (v,s')"
  by (induct set: eval) auto

lemma valof_valof2:
     "(e',s) -|-> (v,s')
      ==> e' = VALOF c1;;c2 RESULTIS e ==>
          (VALOF c1 RESULTIS (VALOF c2 RESULTIS e), s) -|-> (v,s')"
  by (induct set: eval) auto

theorem valof_valof:
     "((VALOF c1 RESULTIS (VALOF c2 RESULTIS e), s) -|-> (v,s'))  =
      ((VALOF c1;;c2 RESULTIS e, s) -|-> (v,s'))"
  by (blast intro: valof_valof1 valof_valof2)

subsection{* Equivalence of  VALOF SKIP RESULTIS e  and  e *}

lemma valof_skip1:
     "(e',s) -|-> (v,s')
      ==> e' = VALOF SKIP RESULTIS e ==>
          (e, s) -|-> (v,s')"
  by (induct set: eval) auto

lemma valof_skip2:
    "(e,s) -|-> (v,s') ==> (VALOF SKIP RESULTIS e, s) -|-> (v,s')"
  by blast

theorem valof_skip:
    "((VALOF SKIP RESULTIS e, s) -|-> (v,s'))  =  ((e, s) -|-> (v,s'))"
  by (blast intro: valof_skip1 valof_skip2)

subsection{* Equivalence of  VALOF x:=e RESULTIS x  and  e *}

lemma valof_assign1:
     "(e',s) -|-> (v,s'')
      ==> e' = VALOF x:=e RESULTIS X x ==>
          (\<exists>s'. (e, s) -|-> (v,s') & (s'' = s'(x:=v)))"
  by (induct set: eval) (simp_all del: fun_upd_apply, clarify, auto)

lemma valof_assign2:
    "(e,s) -|-> (v,s') ==> (VALOF x:=e RESULTIS X x, s) -|-> (v,s'(x:=v))"
  by blast

end


(*  Title:      HOL/Library/Quotient_Option.thy
    Author:     Cezary Kaliszyk and Christian Urban
*)

section \<open>Quotient infrastructure for the option type\<close>

theory Quotient_Option
imports Quotient_Syntax
begin

subsection \<open>Rules for the Quotient package\<close>

lemma rel_option_map1:
  "rel_option R (map_option f x) y \<longleftrightarrow> rel_option (\<lambda>x. R (f x)) x y"
  by (simp add: rel_option_iff split: option.split)

lemma rel_option_map2:
  "rel_option R x (map_option f y) \<longleftrightarrow> rel_option (\<lambda>x y. R x (f y)) x y"
  by (simp add: rel_option_iff split: option.split)

declare
  map_option.id [id_simps]
  option.rel_eq [id_simps]

lemma reflp_rel_option:
  "reflp R \<Longrightarrow> reflp (rel_option R)"
  unfolding reflp_def split_option_all by simp

lemma option_symp:
  "symp R \<Longrightarrow> symp (rel_option R)"
  unfolding symp_def split_option_all
  by (simp only: option.rel_inject option.rel_distinct) fast

lemma option_transp:
  "transp R \<Longrightarrow> transp (rel_option R)"
  unfolding transp_def split_option_all
  by (simp only: option.rel_inject option.rel_distinct) fast

lemma option_equivp [quot_equiv]:
  "equivp R \<Longrightarrow> equivp (rel_option R)"
  by (blast intro: equivpI reflp_rel_option option_symp option_transp elim: equivpE)

lemma option_quotient [quot_thm]:
  assumes "Quotient3 R Abs Rep"
  shows "Quotient3 (rel_option R) (map_option Abs) (map_option Rep)"
  apply (rule Quotient3I)
  apply (simp_all add: option.map_comp comp_def option.map_id[unfolded id_def] option.rel_eq rel_option_map1 rel_option_map2 Quotient3_abs_rep [OF assms] Quotient3_rel_rep [OF assms])
  using Quotient3_rel [OF assms]
  apply (simp add: rel_option_iff split: option.split)
  done

declare [[mapQ3 option = (rel_option, option_quotient)]]

lemma option_None_rsp [quot_respect]:
  assumes q: "Quotient3 R Abs Rep"
  shows "rel_option R None None"
  by (rule option.ctr_transfer(1))

lemma option_Some_rsp [quot_respect]:
  assumes q: "Quotient3 R Abs Rep"
  shows "(R ===> rel_option R) Some Some"
  by (rule option.ctr_transfer(2))

lemma option_None_prs [quot_preserve]:
  assumes q: "Quotient3 R Abs Rep"
  shows "map_option Abs None = None"
  by (rule Option.option.map(1))

lemma option_Some_prs [quot_preserve]:
  assumes q: "Quotient3 R Abs Rep"
  shows "(Rep ---> map_option Abs) Some = Some"
  apply(simp add: fun_eq_iff)
  apply(simp add: Quotient3_abs_rep[OF q])
  done

end


section \<open> Overloaded Expression Constructs \<close>

theory utp_expr_ovld
  imports utp
begin

subsection \<open> Overloadable Constants \<close>

text \<open> For convenience, we often want to utilise the same expression syntax for multiple constructs.
  This can be achieved using ad-hoc overloading. We create a number of polymorphic constants and then
  overload their definitions using appropriate implementations. In order for this to work,
  each collection must have its own unique type. Thus we do not use the HOL map type directly,
  but rather our own partial function type, for example. \<close>

consts
  \<comment> \<open> Empty elements, for example empty set, nil list, 0... \<close>
  uempty     :: "'f"
  \<comment> \<open> Function application, map application, list application... \<close>
  uapply     :: "'f \<Rightarrow> 'k \<Rightarrow> 'v"
  \<comment> \<open> Function update, map update, list update... \<close>
  uupd       :: "'f \<Rightarrow> 'k \<Rightarrow> 'v \<Rightarrow> 'f"
  \<comment> \<open> Domain of maps, lists... \<close>
  udom       :: "'f \<Rightarrow> 'a set"
  \<comment> \<open> Range of maps, lists... \<close>
  uran       :: "'f \<Rightarrow> 'b set"
  \<comment> \<open> Domain restriction \<close>
  udomres    :: "'a set \<Rightarrow> 'f \<Rightarrow> 'f"
  \<comment> \<open> Range restriction \<close>
  uranres    :: "'f \<Rightarrow> 'b set \<Rightarrow> 'f"
  \<comment> \<open> Collection cardinality \<close>
  ucard      :: "'f \<Rightarrow> nat"
  \<comment> \<open> Collection summation \<close>
  usums      :: "'f \<Rightarrow> 'a"
  \<comment> \<open> Construct a collection from a list of entries \<close>
  uentries   :: "'k set \<Rightarrow> ('k \<Rightarrow> 'v) \<Rightarrow> 'f"

text \<open> We need a function corresponding to function application in order to overload. \<close>

definition fun_apply :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)"
where "fun_apply f x = f x"

declare fun_apply_def [simp]

definition ffun_entries :: "'k set \<Rightarrow> ('k \<Rightarrow> 'v) \<Rightarrow> ('k, 'v) ffun" where
"ffun_entries d f = graph_ffun {(k, f k) | k. k \<in> d}"

text \<open> We then set up the overloading for a number of useful constructs for various collections. \<close>

adhoc_overloading
  uempty 0 and
  uapply fun_apply and uapply nth and uapply pfun_app and
  uapply ffun_app and
  uupd pfun_upd and uupd ffun_upd and uupd list_augment and
  udom Domain and udom pdom and udom fdom and udom seq_dom and
  udom Range and uran pran and uran fran and uran set and
  udomres pdom_res and udomres fdom_res and
  uranres pran_res and udomres fran_res and
  ucard card and ucard pcard and ucard length and
  usums list_sum and usums Sum and usums pfun_sum and
  uentries pfun_entries and uentries ffun_entries

subsection \<open> Syntax Translations \<close>

syntax
  "_uundef"     :: "logic" ("\<bottom>\<^sub>u")
  "_umap_empty" :: "logic" ("[]\<^sub>u")
  "_uapply"     :: "('a \<Rightarrow> 'b, '\<alpha>) uexpr \<Rightarrow> utuple_args \<Rightarrow> ('b, '\<alpha>) uexpr" ("_'(_')\<^sub>a" [999,0] 999)
  "_umaplet"    :: "[logic, logic] => umaplet" ("_ /\<mapsto>/ _")
  ""            :: "umaplet => umaplets"             ("_")
  "_UMaplets"   :: "[umaplet, umaplets] => umaplets" ("_,/ _")
  "_UMapUpd"    :: "[logic, umaplets] => logic" ("_/'(_')\<^sub>u" [900,0] 900)
  "_UMap"       :: "umaplets => logic" ("(1[_]\<^sub>u)")
  "_ucard"      :: "logic \<Rightarrow> logic" ("#\<^sub>u'(_')")
  "_udom"       :: "logic \<Rightarrow> logic" ("dom\<^sub>u'(_')")
  "_uran"       :: "logic \<Rightarrow> logic" ("ran\<^sub>u'(_')")
  "_usum"       :: "logic \<Rightarrow> logic" ("sum\<^sub>u'(_')")
  "_udom_res"   :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixl "\<lhd>\<^sub>u" 85)
  "_uran_res"   :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixl "\<rhd>\<^sub>u" 85)
  "_uentries"   :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("entr\<^sub>u'(_,_')")

translations
  \<comment> \<open> Pretty printing for adhoc-overloaded constructs \<close>
  "f(x)\<^sub>a"    <= "CONST uapply f x"
  "dom\<^sub>u(f)" <= "CONST udom f"
  "ran\<^sub>u(f)" <= "CONST uran f"
  "A \<lhd>\<^sub>u f" <= "CONST udomres A f"
  "f \<rhd>\<^sub>u A" <= "CONST uranres f A"
  "#\<^sub>u(f)" <= "CONST ucard f"
  "f(k \<mapsto> v)\<^sub>u" <= "CONST uupd f k v"
  "0" <= "CONST uempty" \<comment> \<open> We have to do this so we don't see uempty. Is there a better way of printing? \<close>

  \<comment> \<open> Overloaded construct translations \<close>
  "f(x,y,z,u)\<^sub>a" == "CONST bop CONST uapply f (x,y,z,u)\<^sub>u"
  "f(x,y,z)\<^sub>a" == "CONST bop CONST uapply f (x,y,z)\<^sub>u"
  "f(x,y)\<^sub>a"  == "CONST bop CONST uapply f (x,y)\<^sub>u"
  "f(x)\<^sub>a"    == "CONST bop CONST uapply f x"
  "#\<^sub>u(xs)"  == "CONST uop CONST ucard xs"
  "sum\<^sub>u(A)" == "CONST uop CONST usums A"
  "dom\<^sub>u(f)" == "CONST uop CONST udom f"
  "ran\<^sub>u(f)" == "CONST uop CONST uran f"
  "[]\<^sub>u"     => "\<guillemotleft>CONST uempty\<guillemotright>"
  "\<bottom>\<^sub>u"     == "\<guillemotleft>CONST undefined\<guillemotright>"
  "A \<lhd>\<^sub>u f" == "CONST bop (CONST udomres) A f"
  "f \<rhd>\<^sub>u A" == "CONST bop (CONST uranres) f A"
  "entr\<^sub>u(d,f)" == "CONST bop CONST uentries d \<guillemotleft>f\<guillemotright>"
  "_UMapUpd m (_UMaplets xy ms)" == "_UMapUpd (_UMapUpd m xy) ms"
  "_UMapUpd m (_umaplet  x y)"   == "CONST trop CONST uupd m x y"
  "_UMap ms"                      == "_UMapUpd []\<^sub>u ms"
  "_UMap (_UMaplets ms1 ms2)"     <= "_UMapUpd (_UMap ms1) ms2"
  "_UMaplets ms1 (_UMaplets ms2 ms3)" <= "_UMaplets (_UMaplets ms1 ms2) ms3"

subsection \<open> Simplifications \<close>

lemma ufun_apply_lit [simp]:
  "\<guillemotleft>f\<guillemotright>(\<guillemotleft>x\<guillemotright>)\<^sub>a = \<guillemotleft>f(x)\<guillemotright>"
  by (transfer, simp)

lemma lit_plus_appl [lit_norm]: "\<guillemotleft>(+)\<guillemotright>(x)\<^sub>a(y)\<^sub>a = x + y" by (simp add: uexpr_defs, transfer, simp)
lemma lit_minus_appl [lit_norm]: "\<guillemotleft>(-)\<guillemotright>(x)\<^sub>a(y)\<^sub>a = x - y" by (simp add: uexpr_defs, transfer, simp)
lemma lit_mult_appl [lit_norm]: "\<guillemotleft>times\<guillemotright>(x)\<^sub>a(y)\<^sub>a = x * y" by (simp add: uexpr_defs, transfer, simp)
lemma lit_divide_apply [lit_norm]: "\<guillemotleft>(/)\<guillemotright>(x)\<^sub>a(y)\<^sub>a = x / y" by (simp add: uexpr_defs, transfer, simp)

lemma pfun_entries_apply [simp]:
  "(entr\<^sub>u(d,f) :: (('k, 'v) pfun, '\<alpha>) uexpr)(i)\<^sub>a = ((\<guillemotleft>f\<guillemotright>(i)\<^sub>a) \<triangleleft> i \<in>\<^sub>u d \<triangleright> \<bottom>\<^sub>u)"
  by (pred_auto)

lemma udom_uupdate_pfun [simp]:
  fixes m :: "(('k, 'v) pfun, '\<alpha>) uexpr"
  shows "dom\<^sub>u(m(k \<mapsto> v)\<^sub>u) = {k}\<^sub>u \<union>\<^sub>u dom\<^sub>u(m)"
  by (rel_auto)

lemma uapply_uupdate_pfun [simp]:
  fixes m :: "(('k, 'v) pfun, '\<alpha>) uexpr"
  shows "(m(k \<mapsto> v)\<^sub>u)(i)\<^sub>a = v \<triangleleft> i =\<^sub>u k \<triangleright> m(i)\<^sub>a"
  by (rel_auto)

subsection \<open> Indexed Assignment \<close>

syntax
  \<comment> \<open> Indexed assignment \<close>
  "_assignment_upd" :: "svid \<Rightarrow> uexp \<Rightarrow> uexp \<Rightarrow> logic" ("(_[_] :=/ _)" [63, 0, 0] 62)

translations
  \<comment> \<open> Indexed assignment uses the overloaded collection update function \emph{uupd}. \<close>
  "_assignment_upd x k v" => "x := &x(k \<mapsto> v)\<^sub>u"

end


theory Snoc
  imports "$HIPSTER_HOME/IsaHipster"

begin

fun snoc :: "'a list => 'a => 'a list"
where
  "snoc [] a = [a]"
| "snoc (x#xs) a = x # snoc xs a"

hipster snoc rev List.append
lemma lemma_a [thy_expl]: "rev (snoc z y) = y # rev z"
  apply (induct z)
  apply simp
  apply auto
  done

end

  (* Funny "feature" in QuickSpec: Seems it prunes the nessecary lemma_a if given all three functions at once!
   Probably because it decides to explore snoc and rev before snoc and append. Is the pruner too good? *)


theory EvenAutomat

imports automaton.dAutomaton_causal evenAutomat_inc

begin
(*Even automaton*)
fun dAeven_transition::"S_even \<Rightarrow> (nat) \<Rightarrow> (S_even \<times> bool)"where
"dAeven_transition (S True) (n) = (S (n mod 2 = 0),n mod 2 = 0)" |
"dAeven_transition (S False)(n) = (S (n mod 2 = 1),n mod 2 = 1)"

interpretation even_sscanl:sscanlGen "dAeven_transition" "S True" "buildEveninSBE" "buildEvenoutSBE"
  by(unfold_locales)

abbreviation evenStep::"(S_even \<Rightarrow> (inEven\<^sup>\<Omega> \<rightarrow> outEven\<^sup>\<Omega>))"where
"evenStep \<equiv> dawStateSem even_sscanl.da"

definition evenSpf::"(inEven\<^sup>\<Omega> \<rightarrow> outEven\<^sup>\<Omega>)"where
"evenSpf = dawSem even_sscanl.da"

lemma eveningetset_eq:"evenInSBE.getterSB\<cdot>(evenInSBE.setterSB\<cdot>s) = s"
  by(simp)

lemma evenoutgetset_eq:"evenOutSBE.getterSB\<cdot> (evenOutSBE.setterSB\<cdot>s) = s"
  by(simp)

lemma evenstep2sscanl:"evenOutSBE.getterSB\<cdot>(evenStep state\<cdot>(evenInSBE.setterSB\<cdot>input)) = sscanlAsnd dAeven_transition state\<cdot>input"
  by (simp add: even_sscanl.daut2sscanl)

lemma even_step_t1:"sscanlAsnd dAeven_transition (S True)\<cdot>(\<up>(n) \<bullet> s) = \<up>(n mod 2 = 0) \<bullet> sscanlAsnd dAeven_transition (S (n mod 2 = 0))\<cdot>(s)"
  by simp

lemma even_step_t2:"sscanlAsnd dAeven_transition (S False)\<cdot>(\<up>(n) \<bullet> s) = \<up>(n mod 2 = 1) \<bullet> sscanlAsnd dAeven_transition (S (n mod 2 = 1))\<cdot>(s)"
  by simp

lemma tinf_helper:assumes "Fin n < # input" and "\<forall>e\<in>(sValues\<cdot>input). e mod 2 = 0"
      shows"snth n (sscanlAsnd dAeven_transition (S True)\<cdot>input)"
using assms
proof(induction n arbitrary: input)
  case 0
  then show ?case
    apply(subst scases[of input])
    by simp_all
next
  case (Suc n)
  then show ?case
    apply(subst scases[of input])
    by simp_all
qed

lemma assumes "\<forall>e\<in>(sValues\<cdot>input). e mod 2 = 0"
      and "#input = \<infinity>"
      shows"evenOutSBE.getterSB\<cdot>(evenStep (S True)\<cdot>(evenInSBE.setterSB\<cdot>input)) = ((\<up>True)\<^sup>\<infinity>)"
  apply(simp add: evenstep2sscanl)
  apply(rule snths_eq,auto simp add: assms)
  by(rule tinf_helper,simp_all add: assms)

lemma ftinf_step:assumes "Fin (Suc n) < # input" and "\<forall>e\<in>(sValues\<cdot>input). e mod 2 = 1"
      shows"snth (Suc n) (sscanlAsnd dAeven_transition state\<cdot>input) = snth n (sscanlAsnd dAeven_transition state\<cdot>input)"
using assms
proof(induction n arbitrary: input state)
  case 0
  then show ?case
    sorry
next
  case (Suc n)
  then show ?case
    sorry
qed

lemma ftinf_helper:assumes "Fin n < # input" and "\<forall>e\<in>(sValues\<cdot>input). e mod 2 = 1"
      shows"snth n (sscanlAsnd dAeven_transition (S True)\<cdot>input) = snth n \<up>False \<bullet> \<up>True\<^sup>\<infinity>"
using assms
proof(induction n arbitrary: input)
  case 0
  then show ?case
    sorry
next
  case (Suc n)
  then show ?case
    sorry
qed

lemma assumes "\<forall>e\<in>(sValues\<cdot>input). e mod 2 = 1"
      and "#input = \<infinity>"
      shows"evenOutSBE.getterSB\<cdot>(evenStep (S True)\<cdot>(evenInSBE.setterSB\<cdot>input)) = ((\<up>False \<bullet> \<up>True)\<^sup>\<infinity>)"
  apply(simp add: evenstep2sscanl)
  apply(rule snths_eq,simp add:assms slen_sinftimes)
  by(subst ftinf_helper,simp_all add: assms)

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_32
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

theorem property0 :
  "((min a b) = (min b a))"
  oops

end


theory E imports Main       (* Aqvist's System E: C. Benzmüller & X. Parent, 2019 *)
begin
typedecl i (*Possible worlds.*) type_synonym \<sigma> = "(i\<Rightarrow>bool)"
consts aw::i (*Actual world.*)
abbreviation(input) etrue  :: "\<sigma>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
abbreviation(input) efalse :: "\<sigma>" ("\<^bold>\<bottom>")  where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
abbreviation(input) enot :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>_"[52]53)  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
abbreviation(input) eand :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<and>\<psi>(w)"
abbreviation(input) eor  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<or>\<psi>(w)"
abbreviation(input) eimp :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(w)"
abbreviation(input) eequ :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longleftrightarrow>\<psi>(w)"

(*Possibilist--constant domain--quantification.*)
abbreviation(input) eforall ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x. (\<Phi> x w)"
abbreviation(input) eforallB (binder"\<^bold>\<forall>"[8]9) where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation(input) eexists ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x. (\<Phi> x w)"
abbreviation(input) eexistsB (binder"\<^bold>\<exists>"[8]9) where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"

abbreviation(input) ebox :: "\<sigma>\<Rightarrow>\<sigma>" ("\<box>") where "\<box> \<equiv> \<lambda>\<phi> w.  \<forall>v. \<phi>(v)"
consts R :: "i\<Rightarrow>\<sigma>" (infixr "R" 70) (*Betterness relation, cf. def. of \<circle><_|_>.*)
abbreviation(input) eopt  :: "\<sigma>\<Rightarrow>\<sigma>" ("opt<_>")
  where "opt<\<phi>> \<equiv> (\<lambda>v. ( (\<phi>)(v) \<and> (\<forall>x. ((\<phi>)(x)  \<longrightarrow>  v R x) )) )"
abbreviation(input) esubset :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" (infix "\<^bold>\<subseteq>" 53)
  where "\<phi> \<^bold>\<subseteq> \<psi> \<equiv> \<forall>x. \<phi> x \<longrightarrow> \<psi> x"
abbreviation(input) econd  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<circle><_|_>")
  where "\<circle><\<psi>|\<phi>> \<equiv>  \<lambda>w. opt<\<phi>> \<^bold>\<subseteq> \<psi>"
abbreviation(input) euncobl :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<circle><_>")
  where "\<^bold>\<circle><\<phi>> \<equiv> \<circle><\<phi>|\<^bold>\<top>>"

abbreviation(input) evalid :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>"[8]109)  (*Global validity.*)
  where "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p w"
abbreviation ecjactual :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sub>l"[7]105) (*Local validity — in world aw.*)
  where "\<lfloor>p\<rfloor>\<^sub>l \<equiv> p(aw)"

lemma True nitpick [satisfy,user_axioms,expect=genuine] oops (*Consistency conf.*)

(*Correspondence theory.*)
lemma assumes "\<forall>x y z. x R y \<and> y R z \<longrightarrow> x R z"
      shows "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> \<^bold>\<not>(\<circle><\<^bold>\<not>\<xi>|\<phi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>"
  using assms by blast

lemma assumes "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> \<^bold>\<not>(\<circle><\<^bold>\<not>\<xi>|\<phi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>"
      shows "\<forall>x y z. x R y \<and> y R z \<longrightarrow> x R z"
  nitpick [show_all,format=2] oops (*Countermodel presented by Nitpick.*)
end


section\<open>Fully relational versions of higher order constructs\<close>
theory Higher_Order_Constructs
  imports
    Recursion_Thms
    Least
begin

syntax
  "_sats"  :: "[i, i, i] \<Rightarrow> o"  ("(_, _ \<Turnstile> _)" [36,36,36] 25)
translations
  "(M,env \<Turnstile> \<phi>)" \<rightleftharpoons> "CONST sats(M,\<phi>,env)"

definition
  is_If :: "[i\<Rightarrow>o,o,i,i,i] \<Rightarrow> o" where
  "is_If(M,b,t,f,r) \<equiv> (b \<longrightarrow> r=t) \<and> (\<not>b \<longrightarrow> r=f)"

lemma (in M_trans) If_abs:
  "is_If(M,b,t,f,r) \<longleftrightarrow> r = If(b,t,f)"
  by (simp add: is_If_def)

definition
  is_If_fm :: "[i,i,i,i] \<Rightarrow> i" where
  "is_If_fm(\<phi>,t,f,r) \<equiv> Or(And(\<phi>,Equal(t,r)),And(Neg(\<phi>),Equal(f,r)))"

lemma is_If_fm_type [TC]: "\<phi> \<in> formula \<Longrightarrow> t \<in> nat \<Longrightarrow> f \<in> nat \<Longrightarrow> r \<in> nat \<Longrightarrow>
  is_If_fm(\<phi>,t,f,r) \<in> formula"
  unfolding is_If_fm_def by auto

lemma sats_is_If_fm:
  assumes Qsats: "Q \<longleftrightarrow> A, env \<Turnstile> \<phi>" "env \<in> list(A)"
  shows "is_If(##A, Q, nth(t, env), nth(f, env), nth(r, env)) \<longleftrightarrow> A, env \<Turnstile> is_If_fm(\<phi>,t,f,r)"
  using assms unfolding is_If_def is_If_fm_def by auto

lemma is_If_fm_iff_sats [iff_sats]:
  assumes Qsats: "Q \<longleftrightarrow> A, env \<Turnstile> \<phi>" and
    "nth(t, env) = ta" "nth(f, env) = fa" "nth(r, env) = ra"
    "t \<in> nat" "f \<in> nat" "r \<in> nat" "env \<in> list(A)"
  shows "is_If(##A,Q,ta,fa,ra) \<longleftrightarrow> A, env \<Turnstile> is_If_fm(\<phi>,t,f,r)"
  using assms sats_is_If_fm[of Q A \<phi> env t f r] by simp

lemma arity_is_If_fm [arity]:
  "\<phi> \<in> formula \<Longrightarrow> t \<in> nat \<Longrightarrow> f \<in> nat \<Longrightarrow> r \<in> nat \<Longrightarrow>
    arity(is_If_fm(\<phi>, t, f, r)) = arity(\<phi>) \<union> succ(t) \<union> succ(r) \<union> succ(f)"
  unfolding is_If_fm_def
  by auto

definition
  is_The :: "[i\<Rightarrow>o,i\<Rightarrow>o,i] \<Rightarrow> o" where
  "is_The(M,Q,i) \<equiv> (Q(i) \<and> (\<exists>x[M]. Q(x) \<and> (\<forall>y[M]. Q(y) \<longrightarrow> y = x))) \<or>
                   (\<not>(\<exists>x[M]. Q(x) \<and> (\<forall>y[M]. Q(y) \<longrightarrow> y = x))) \<and> empty(M,i) "

(*
definition
  is_The_fm :: "[i,i] \<Rightarrow> i" where
  "is_The_fm(q,i) \<equiv> Or(And(Exists(And(Equal(succ(i),0),q)),
                  Exists(And(q,Forall(Implies(q,Equal(1,0)))))),
                          And(Neg(Exists(And(q,Forall(Implies(q,Equal(1,0)))))),empty_fm(i)))"

(* this doesn't work yet *)
lemma sats_The_fm :
  assumes p_iff_sats:
    "\<And>a. a \<in> A \<Longrightarrow> P(a) \<longleftrightarrow> sats(A, p, Cons(a, env))"
  shows
    "\<lbrakk>y \<in> nat; env \<in> list(A) ; 0\<in>A\<rbrakk>
    \<Longrightarrow> sats(A, is_The_fm(p,y), env) \<longleftrightarrow>
        is_The(##A, P, nth(y,env))"
  using nth_closed p_iff_sats
  unfolding is_The_def is_The_fm_def
  oops

lemma The_iff_sats [iff_sats]:
  assumes is_Q_iff_sats:
      "\<And>a. a \<in> A \<Longrightarrow> is_Q(a) \<longleftrightarrow> sats(A, q, Cons(a,env))"
  shows
  "\<lbrakk>nth(j,env) = y; j \<in> nat; env \<in> list(A); 0\<in>A\<rbrakk>
   \<Longrightarrow> is_The(##A, is_Q, y) \<longleftrightarrow> sats(A, is_The_fm(q,j), env)"
  using sats_The_fm [OF is_Q_iff_sats, of j , symmetric]
  by simp
*)

lemma (in M_trans) The_abs:
  assumes "\<And>x. Q(x) \<Longrightarrow> M(x)" "M(a)"
  shows "is_The(M,Q,a) \<longleftrightarrow> a = (THE x. Q(x))"
proof (cases "\<exists>x[M]. Q(x) \<and> (\<forall>y[M]. Q(y) \<longrightarrow> y = x)")
  case True
  with assms
  show ?thesis
    unfolding is_The_def
    by (intro iffI the_equality[symmetric])
      (auto, blast intro:theI)
next
  case False
  with \<open>\<And>x. Q(x) \<Longrightarrow> M(x)\<close>
  have " \<not> (\<exists>x. Q(x) \<and> (\<forall>y. Q(y) \<longrightarrow> y = x))"
    by auto
  then
  have "The(Q) = 0"
    by (intro the_0) auto
  with assms and False
  show ?thesis
    unfolding is_The_def
    by auto
qed

(*
definition
  recursor  :: "[i, [i,i]=>i, i]=>i"  where
    "recursor(a,b,k) \<equiv>  transrec(k, \<lambda>n f. nat_case(a, \<lambda>m. b(m, f`m), n))"
*)

definition
  is_recursor :: "[i\<Rightarrow>o,i,[i,i,i]\<Rightarrow>o,i,i] \<Rightarrow>o" where
  "is_recursor(M,a,is_b,k,r) \<equiv> is_transrec(M, \<lambda>n f ntc. is_nat_case(M,a,
      \<lambda>m bmfm.
      \<exists>fm[M]. fun_apply(M,f,m,fm) \<and> is_b(m,fm,bmfm),n,ntc),k,r)"

lemma (in M_eclose) recursor_abs:
  assumes "Ord(k)" and
    types: "M(a)" "M(k)" "M(r)" and
    b_iff: "\<And>m f bmf. M(m) \<Longrightarrow> M(f) \<Longrightarrow> M(bmf) \<Longrightarrow> is_b(m,f,bmf)  \<longleftrightarrow> bmf = b(m,f)" and
    b_closed: "\<And>m f bmf. M(m) \<Longrightarrow> M(f) \<Longrightarrow> M(b(m,f))" and
    repl: "transrec_replacement(M, \<lambda>n f ntc. is_nat_case(M, a,
        \<lambda>m bmfm. \<exists>fm[M]. fun_apply(M, f, m, fm) \<and> is_b( m, fm, bmfm), n, ntc), k)"
  shows
    "is_recursor(M,a,is_b,k,r) \<longleftrightarrow> r = recursor(a,b,k)"
  unfolding is_recursor_def recursor_def
  using assms
  apply (rule_tac transrec_abs)
       apply (auto simp:relation2_def)
   apply (rule nat_case_abs[THEN iffD1, where is_b1="\<lambda>m bmfm.
      \<exists>fm[M]. fun_apply(M,_,m,fm) \<and> is_b(m,fm,bmfm)"])
      apply (auto simp:relation1_def)
  apply (rule nat_case_abs[THEN iffD2, where is_b1="\<lambda>m bmfm.
      \<exists>fm[M]. fun_apply(M,_,m,fm) \<and> is_b(m,fm,bmfm)"])
     apply (auto simp:relation1_def)
  done

definition
  is_wfrec_on :: "[i=>o,[i,i,i]=>o,i,i,i, i] => o" where
  "is_wfrec_on(M,MH,A,r,a,z) == is_wfrec(M,MH,r,a,z)"

lemma (in M_trancl) trans_wfrec_on_abs:
  "[|wf(r);  trans(r);  relation(r);  M(r);  M(a);  M(z);
     wfrec_replacement(M,MH,r);  relation2(M,MH,H);
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g));
     r-``{a}\<subseteq>A; a \<in> A|]
   ==> is_wfrec_on(M,MH,A,r,a,z) \<longleftrightarrow> z=wfrec[A](r,a,H)"
  using trans_wfrec_abs wfrec_trans_restr
  unfolding is_wfrec_on_def by simp

end


subsection\<open>Converting between Resolution and SC proofs\<close>
theory LSC_Resolution
imports LSC Resolution
begin

lemma literal_subset_sandwich:
  assumes "is_lit_plus F" "cnf F = {C}" "R \<subseteq> C"
  shows "R = \<box> \<or> R = C"
using assms by(cases F rule: is_lit_plus.cases; simp) blast+ (* proof somewhat strange internally\<dots> *)

text\<open>Proof following Gallier~\cite{gallier2015logic}.\<close>
theorem CSC_Resolution_pre: "\<Gamma> \<Rightarrow>\<^sub>n \<Longrightarrow> \<forall>\<gamma> \<in> set_mset \<Gamma>. is_cnf \<gamma> \<Longrightarrow> (\<Union>(cnf ` set_mset \<Gamma>)) \<turnstile> \<box>"
proof(induction rule: LSC.induct)
  case (Ax k \<Gamma>)
  let ?s = "\<Union>(cnf ` set_mset (\<^bold>\<not> (Atom k), Atom k, \<Gamma>))"
  have "?s \<turnstile> {k\<^sup>+}" "?s \<turnstile> {k\<inverse>}" using Resolution.Ass[where 'a='a] by simp_all
  from Resolution.R[OF this, of k]
  have "?s \<turnstile> \<box>" by simp
  thus ?case by simp
next
  case (BotL \<Gamma>) thus ?case by(simp add: Ass)
next
  case (AndL F G \<Gamma>)
  hence "\<Union>(cnf ` set_mset (F, G, \<Gamma>)) \<turnstile> \<box>" by simp
  thus ?case by(simp add: Un_left_commute sup.assoc)
next
  (* The idea for the whole trickery with F being a literal (is_disj has to only allows right deep formulas)
    and the sandwiching is from Gallier, but mentioned there only in one little sentence. *)
  case (OrL F \<Gamma> G)
  hence "is_cnf (F \<^bold>\<or> G)" by simp
  hence d: "is_disj (F \<^bold>\<or> G)" by simp
  hence db: "is_disj F" "is_lit_plus F" "is_disj G" by (-, cases F) simp_all
  hence "is_cnf F \<and> is_cnf G" by(cases F; cases G; simp)
  with OrL have IH: "(\<Union>(cnf ` set_mset (F, \<Gamma>))) \<turnstile> \<box>" "(\<Union>(cnf ` set_mset (G, \<Gamma>))) \<turnstile> \<box>" by simp_all
  let ?\<Gamma> = "(\<Union>(cnf ` set_mset \<Gamma>))"
  from IH have IH_readable: "cnf F \<union> ?\<Gamma> \<turnstile> \<box>" "cnf G \<union> ?\<Gamma> \<turnstile> \<box>" by auto
  show ?case proof(cases "cnf F = {} \<or> cnf G = {}")
    case True
    hence "cnf (F \<^bold>\<or> G) = {}" by auto
    thus ?thesis using True IH by auto
  next
    case False
    then obtain S T where ST: "cnf F = {S}" "cnf G = {T}"
      using cnf_disj_ex db(1,3) (* try applying meson here. It's weird. and sledgehammer even suggests it. *) by metis
    (* hint: card S \<le> 1 *)
    hence R: "cnf (F \<^bold>\<or> G) = { S \<union> T }" by simp
    have "\<lbrakk>S\<triangleright>?\<Gamma> \<turnstile> \<box>; T\<triangleright>?\<Gamma> \<turnstile> \<box>\<rbrakk> \<Longrightarrow> S \<union> T\<triangleright> ?\<Gamma> \<turnstile> \<box>" proof -
      assume s: "S\<triangleright>?\<Gamma> \<turnstile> \<box>" and t: "T\<triangleright>?\<Gamma> \<turnstile> \<box>"
      hence s_w: "S \<triangleright> S \<union> T \<triangleright> ?\<Gamma> \<turnstile> \<box>" using Resolution_weaken by (metis insert_commute insert_is_Un)
      note Resolution_taint_assumptions[of "{T}" ?\<Gamma> "\<box>" S] t
      then obtain R where R: "S \<union> T \<triangleright> \<Union>(cnf ` set_mset \<Gamma>) \<turnstile> R" "R\<subseteq>S" by (auto simp: Un_commute)
      show ?thesis using literal_subset_sandwich[OF db(2) ST(1) R(2)] proof
        assume "R = \<box>" thus ?thesis using R(1) by blast
      next
        from Resolution_unnecessary[where T="{_}", simplified] R(1)
        have "(R \<triangleright> S \<union> T \<triangleright> ?\<Gamma> \<turnstile> \<box>) = (S \<union> T \<triangleright> ?\<Gamma> \<turnstile> \<box>)"  .
        moreover assume "R = S"
        ultimately show ?thesis using s_w by simp
      qed
    qed
    thus ?thesis using IH ST R by simp
  qed
  hence case_readable: "cnf (F \<^bold>\<or> G) \<union> ?\<Gamma> \<turnstile> \<box>" by auto
qed auto

corollary LSC_Resolution:
  assumes "\<Gamma> \<Rightarrow>\<^sub>n"
  shows "(\<Union>(cnf ` nnf ` set_mset \<Gamma>)) \<turnstile> \<box>"
proof -
  from assms
  have "image_mset nnf \<Gamma> \<Rightarrow>\<^sub>n" by (simp add: LSC_NNF)
  from LSC_cnf[OF this]
  have "image_mset (cnf_form_of \<circ> nnf) \<Gamma> \<Rightarrow>\<^sub>n" by(simp add: image_mset.compositionality is_nnf_nnf)
  moreover have "\<forall>\<gamma> \<in> set_mset (image_mset (cnf_form_of \<circ> nnf) \<Gamma>). is_cnf \<gamma>"
    using cnf_form_of_is[where 'a='a, OF is_nnf_nnf] by simp
  moreover note CSC_Resolution_pre
  ultimately have "\<Union>(cnf ` set_mset (image_mset (cnf_form_of \<circ> nnf) \<Gamma>)) \<turnstile> \<box>"  by blast
  hence "\<Union>((\<lambda>F. cnf (cnf_form_of (nnf F))) ` set_mset \<Gamma>) \<turnstile> \<box>" by simp
  thus ?thesis unfolding cnf_cnf[OF is_nnf_nnf] by simp
qed

corollary SC_Resolution:
  assumes "\<Gamma> \<Rightarrow> {#}"
  shows "(\<Union>(cnf ` nnf ` set_mset \<Gamma>)) \<turnstile> \<box>"
proof -
  from assms have "image_mset nnf \<Gamma> \<Rightarrow>\<^sub>n" by (simp add: LSC_NNF SC_LSC)
  hence "\<Union>(cnf` nnf ` set_mset (image_mset nnf \<Gamma>)) \<turnstile> \<box>" using LSC_Resolution by blast
  thus ?thesis using is_nnf_nnf_id[where 'a='a] is_nnf_nnf[where 'a='a] by auto
qed

(* Gallier just goes "Any resolution refutation can be transformed to a derivation in SCNF'"
   But we don't know what a resolution refutation is, inductively speaking. *)
(* would have been a bit nicer with orderings on formula to convert mset \<rightarrow> list *)
lemma Resolution_LSC_pre:
  assumes "S \<turnstile> R"
  assumes "finite R"
  assumes "finite S" "Ball S finite"
  shows "\<exists>S' R'. \<forall>\<Gamma>. set R' = R \<and> set (map set S') = S \<and>
    (disj_of_clause R', {#disj_of_clause c. c \<in># mset S'#} + \<Gamma> \<Rightarrow>\<^sub>n \<longrightarrow> {#disj_of_clause c. c \<in># mset S'#} + \<Gamma> \<Rightarrow>\<^sub>n)"
(* order of quantifiers is important here\<dots> *)
using assms proof(induction S R rule: Resolution.induct)
  case (Ass F S)
  (* Idea: we don't just obtain an S', we obtain an S' that contains R (and not just some reordering of it) *)
  define Sm where "Sm = S - {F}"
  hence Sm: "S = F\<triangleright>Sm" "F \<notin> Sm" using Ass by fast+ (* try doing this with obtain\<dots> *)
  with Ass have fsm: "finite Sm" "Ball Sm finite" by auto
  then obtain Sm' where "Sm = set (map set Sm')" by (metis (full_types) ex_map_conv finite_list)
  moreover obtain R' where [simp]: "F = set R'" using Ass finite_list by blast
  ultimately have S: "S = set (map set (R'#Sm'))" unfolding Sm by simp
  show ?case
    using LSC_Contract[where 'a='a]
    by(intro exI[where x="R'#Sm'"] exI[where x=R']) (simp add: S add_ac)
  (* this was the base case. ugh. *)
next
  case (R S F G k)
  from R.prems have fin: "finite F" "finite G" by simp_all
  from R.IH(1)[OF fin(1) R.prems(2,3)] obtain FR FS where IHF:
    "set FR = F" "set (map set FS) = S"
    "\<And>\<Gamma> GS. (disj_of_clause FR, image_mset disj_of_clause (mset (FS@GS)) + \<Gamma> \<Rightarrow>\<^sub>n
      \<Longrightarrow> image_mset disj_of_clause (mset (FS@GS)) + \<Gamma> \<Rightarrow>\<^sub>n)"
      by simp (metis add.assoc)
  from R.IH(2)[OF fin(2) R.prems(2,3)] obtain GR GS where IHG:
    "set GR = G" "set (map set GS) = S"
    "\<And>\<Gamma> HS. (disj_of_clause GR, image_mset disj_of_clause (mset (GS@HS)) + \<Gamma> \<Rightarrow>\<^sub>n
      \<Longrightarrow> image_mset disj_of_clause (mset (GS@HS)) + \<Gamma> \<Rightarrow>\<^sub>n)"
    by simp (metis add.assoc)
  have IH: "image_mset disj_of_clause (mset (FS @ GS)) + \<Gamma> \<Rightarrow>\<^sub>n"
    if "disj_of_clause FR, disj_of_clause GR, image_mset disj_of_clause (mset (FS @ GS)) + \<Gamma> \<Rightarrow>\<^sub>n"
    for \<Gamma> using IHF(3)[of GS \<Gamma>] IHG(3)[of FS "disj_of_clause FR, \<Gamma>"] that
    by(simp add: add_mset_commute add_ac)
  show ?case
    apply(intro exI[where x="FS @ GS"] exI[where x="removeAll (k\<^sup>+) FR @ removeAll (k\<inverse>) GR"] allI impI conjI)
      apply(simp add: IHF IHG;fail)
     apply(insert IHF IHG; simp;fail)
    apply(intro IH)
    apply(auto dest!: LSC_Sim_resolution_la simp add: IHF IHG R.hyps)
  done
qed

lemma Resolution_LSC_pre_nodisj: (* I've tried showing this directly instead of Resolution_LSC_pre, but that is surprisingly painful. *)
  assumes "S \<turnstile> R"
  assumes "finite R"
  assumes "finite S" "Ball S finite"
  shows "\<exists>S' R'. \<forall>\<Gamma>. is_nnf_mset \<Gamma> \<longrightarrow> is_disj R' \<and> is_nnf S' \<and> cnf R' = {R} \<and> cnf S' \<subseteq> S \<and>
    (R', S', \<Gamma> \<Rightarrow>\<^sub>n \<longrightarrow> S', \<Gamma> \<Rightarrow>\<^sub>n)"
proof -
  have mehorder: "F, \<^bold>\<And>G, \<Gamma> = \<^bold>\<And>G, F, \<Gamma>" for F G \<Gamma> by(simp add: add_ac)
  from Resolution_LSC_pre[where 'a='a,OF assms]
  obtain S' R' where o: "\<And>\<Gamma>. is_nnf_mset \<Gamma> \<Longrightarrow> set R' = R \<and> set (map set S') = S \<and>
  (disj_of_clause R', image_mset disj_of_clause (mset S') + \<Gamma> \<Rightarrow>\<^sub>n \<longrightarrow> image_mset disj_of_clause (mset S') + \<Gamma> \<Rightarrow>\<^sub>n)"
    by blast
  hence p: "is_nnf_mset \<Gamma> \<Longrightarrow> (disj_of_clause R', image_mset disj_of_clause (mset S') + \<Gamma> \<Rightarrow>\<^sub>n \<Longrightarrow> image_mset disj_of_clause (mset S') + \<Gamma> \<Rightarrow>\<^sub>n)"
    for \<Gamma> by blast
  show ?thesis
    apply(rule exI[where x="\<^bold>\<And>map disj_of_clause S'"])
    apply(rule exI[where x="disj_of_clause R'"])
    apply safe
         apply(intro disj_of_clause_is;fail)
        apply(simp add: cnf_disj o; fail)+
     subgoal using o by(fastforce simp add: cnf_BigAnd cnf_disj)
    subgoal for \<Gamma>
      apply(frule p)
       apply(unfold mehorder)
       apply(drule LSC_BigAndL_inv)
         apply(simp;fail)+
      by (simp add: LSC_BigAndL)
    done
qed

corollary Resolution_LSC1:
  assumes "S \<turnstile> \<box>"
  shows "\<exists>F. is_nnf F \<and> cnf F \<subseteq> S \<and> {#F#} \<Rightarrow>\<^sub>n"
proof -
  have *: "{f \<union> g |f g. f \<in> F \<and> g \<in> G} = {\<box>} \<Longrightarrow> F = {\<box>}" for F G
  proof (rule ccontr)
    assume m: "{f \<union> g |f g. f \<in> F \<and> g \<in> G} = {\<box>}"
    assume "F \<noteq> {\<box>}"
    hence "F = {} \<or> (\<exists>E. E \<in> F \<and> E \<noteq> \<box>)" by blast
    thus False proof
      assume "F = {}"
      with m show False by simp
    next
      assume "\<exists>E. E \<in> F \<and> E \<noteq> \<box>" then guess E .. note E = this
      show False proof cases
        assume "G = {}" with m show False by simp
      next
        assume "G \<noteq> {}"
        then obtain D where "D \<in> G" by blast
        with E have "E \<union> D \<in> {f \<union> g |f g. f \<in> F \<and> g \<in> G}" by blast
        with m E show False by simp
      qed
    qed
  qed
  have *: "F = {\<box>} \<and> G = {\<box>}" if "{f \<union> g |f g. f \<in> F \<and> g \<in> G} = {\<box>}" for F G
  proof (intro conjI)
    show "G = {\<box>}"
      apply(rule *[of G F])
      apply(subst that[symmetric])
    by blast
  qed (rule *[OF that])
  have *: "is_nnf F \<Longrightarrow> is_nnf_mset \<Gamma> \<Longrightarrow> cnf F = {\<box>} \<Longrightarrow> F,\<Gamma> \<Rightarrow>\<^sub>n" for F \<Gamma>
    apply(induction F rule: cnf.induct; simp)
      apply blast
     apply (metis LSC.LSC.AndL LSC_weaken add_mset_commute singleton_Un_iff)
    apply(drule *; simp add: LSC.LSC.OrL)
  done
  from Resolution_useless_infinite[OF assms]
  obtain S' where su: "S'\<subseteq>S" and fin: "finite S'" "Ball S' finite" and pr: "(S' \<turnstile> \<box>)" by blast
  from Resolution_LSC_pre_nodisj[OF pr finite.emptyI fin]
  obtain S'' where "is_nnf S''" "cnf S'' \<subseteq> S'" "{# S'' #} \<Rightarrow>\<^sub>n"
    using *[OF disj_is_nnf, of _ Mempty]
    by (metis LSC_weaken add_mset_commute empty_iff set_mset_empty)
  with su show ?thesis by blast
qed

corollary Resolution_SC1:
  assumes "S \<turnstile> \<box>"
  shows "\<exists>F. cnf (nnf F) \<subseteq> S \<and> {#F#} \<Rightarrow> {#}"
  apply(insert Resolution_LSC1[OF assms])
  apply(elim ex_forward)
  apply(elim conjE; intro conjI)
   subgoal by(subst is_nnf_nnf_id; assumption)
  apply(unfold SC_LSC)
  subgoal by (simp;fail)
done

(* really, these proofs have to do with sets, multisets and lists.
If I'd introduce finite sets somehow, the chaos would be perfect.
I want out.
*)

end