(*  Title:       POSIX Lexing with Derivatives of Regular Expressions
    Authors:     Fahad Ausaf <fahad.ausaf at icloud.com>, 2016
                 Roy Dyckhoff <roy.dyckhoff at st-andrews.ac.uk>, 2016
                 Christian Urban <christian.urban at kcl.ac.uk>, 2016
    Maintainer:  Christian Urban <christian.urban at kcl.ac.uk>
*)

theory Lexer
  imports "Regular-Sets.Derivatives"
begin

section \<open>Values\<close>

datatype 'a val =
  Void
| Atm 'a
| Seq "'a val" "'a val"
| Right "'a val"
| Left "'a val"
| Stars "('a val) list"

section \<open>The string behind a value\<close>

fun
  flat :: "'a val \<Rightarrow> 'a list"
where
  "flat (Void) = []"
| "flat (Atm c) = [c]"
| "flat (Left v) = flat v"
| "flat (Right v) = flat v"
| "flat (Seq v1 v2) = (flat v1) @ (flat v2)"
| "flat (Stars []) = []"
| "flat (Stars (v#vs)) = (flat v) @ (flat (Stars vs))"

lemma flat_Stars [simp]:
 "flat (Stars vs) = concat (map flat vs)"
by (induct vs) (auto)

section \<open>Relation between values and regular expressions\<close>

inductive
  Prf :: "'a val \<Rightarrow> 'a rexp \<Rightarrow> bool" ("\<turnstile> _ : _" [100, 100] 100)
where
 "\<lbrakk>\<turnstile> v1 : r1; \<turnstile> v2 : r2\<rbrakk> \<Longrightarrow> \<turnstile> Seq v1 v2 : Times r1 r2"
| "\<turnstile> v1 : r1 \<Longrightarrow> \<turnstile> Left v1 : Plus r1 r2"
| "\<turnstile> v2 : r2 \<Longrightarrow> \<turnstile> Right v2 : Plus r1 r2"
| "\<turnstile> Void : One"
| "\<turnstile> Atm c : Atom c"
| "\<turnstile> Stars [] : Star r"
| "\<lbrakk>\<turnstile> v : r; \<turnstile> Stars vs : Star r\<rbrakk> \<Longrightarrow> \<turnstile> Stars (v # vs) : Star r"

inductive_cases Prf_elims:
  "\<turnstile> v : Zero"
  "\<turnstile> v : Times r1 r2"
  "\<turnstile> v : Plus r1 r2"
  "\<turnstile> v : One"
  "\<turnstile> v : Atom c"
(*  "\<turnstile> vs : Star r"*)

lemma Prf_flat_lang:
  assumes "\<turnstile> v : r" shows "flat v \<in> lang r"
using assms
by(induct v r rule: Prf.induct) (auto)

lemma Prf_Stars:
  assumes "\<forall>v \<in> set vs. \<turnstile> v : r"
  shows "\<turnstile> Stars vs : Star r"
using assms
by(induct vs) (auto intro: Prf.intros)

lemma Star_string:
  assumes "s \<in> star A"
  shows "\<exists>ss. concat ss = s \<and> (\<forall>s \<in> set ss. s \<in> A)"
using assms
by (metis in_star_iff_concat subsetD)

lemma Star_val:
  assumes "\<forall>s\<in>set ss. \<exists>v. s = flat v \<and> \<turnstile> v : r"
  shows "\<exists>vs. concat (map flat vs) = concat ss \<and> (\<forall>v\<in>set vs. \<turnstile> v : r)"
using assms
apply(induct ss)
apply(auto)
apply (metis empty_iff list.set(1))
by (metis concat.simps(2) list.simps(9) set_ConsD)

lemma L_flat_Prf1:
  assumes "\<turnstile> v : r" shows "flat v \<in> lang r"
using assms
by (induct)(auto)

lemma L_flat_Prf2:
  assumes "s \<in> lang r" shows "\<exists>v. \<turnstile> v : r \<and> flat v = s"
using assms
apply(induct r arbitrary: s)
apply(auto intro: Prf.intros)
using Prf.intros(2) flat.simps(3) apply blast
using Prf.intros(3) flat.simps(4) apply blast
apply (metis Prf.intros(1) concE flat.simps(5))
apply(subgoal_tac "\<exists>vs::('a val) list. concat (map flat vs) = s \<and> (\<forall>v \<in> set vs. \<turnstile> v : r)")
apply(auto)[1]
apply(rule_tac x="Stars vs" in exI)
apply(simp)
apply (simp add: Prf_Stars)
apply(drule Star_string)
apply(auto)
apply(rule Star_val)
apply(auto)
done

lemma L_flat_Prf:
  "lang r = {flat v | v. \<turnstile> v : r}"
using L_flat_Prf1 L_flat_Prf2 by blast

section \<open>Sulzmann and Lu functions\<close>

fun
  mkeps :: "'a rexp \<Rightarrow> 'a val"
where
  "mkeps(One) = Void"
| "mkeps(Times r1 r2) = Seq (mkeps r1) (mkeps r2)"
| "mkeps(Plus r1 r2) = (if nullable(r1) then Left (mkeps r1) else Right (mkeps r2))"
| "mkeps(Star r) = Stars []"

fun injval :: "'a rexp \<Rightarrow> 'a \<Rightarrow> 'a val \<Rightarrow> 'a val"
where
  "injval (Atom d) c Void = Atm d"
| "injval (Plus r1 r2) c (Left v1) = Left(injval r1 c v1)"
| "injval (Plus r1 r2) c (Right v2) = Right(injval r2 c v2)"
| "injval (Times r1 r2) c (Seq v1 v2) = Seq (injval r1 c v1) v2"
| "injval (Times r1 r2) c (Left (Seq v1 v2)) = Seq (injval r1 c v1) v2"
| "injval (Times r1 r2) c (Right v2) = Seq (mkeps r1) (injval r2 c v2)"
| "injval (Star r) c (Seq v (Stars vs)) = Stars ((injval r c v) # vs)"

section \<open>Mkeps, injval\<close>

lemma mkeps_nullable:
  assumes "nullable r"
  shows "\<turnstile> mkeps r : r"
using assms
by (induct r)
   (auto intro: Prf.intros)

lemma mkeps_flat:
  assumes "nullable r"
  shows "flat (mkeps r) = []"
using assms
by (induct r) (auto)

lemma Prf_injval:
  assumes "\<turnstile> v : deriv c r"
  shows "\<turnstile> (injval r c v) : r"
using assms
apply(induct r arbitrary: c v rule: rexp.induct)
apply(auto intro!: Prf.intros mkeps_nullable elim!: Prf_elims split: if_splits)
(* Star *)
apply(rotate_tac 2)
apply(erule Prf.cases)
apply(simp_all)[7]
apply(auto)
apply (metis Prf.intros(6) Prf.intros(7))
by (metis Prf.intros(7))

lemma Prf_injval_flat:
  assumes "\<turnstile> v : deriv c r"
  shows "flat (injval r c v) = c # (flat v)"
using assms
apply(induct r arbitrary: v c)
apply(auto elim!: Prf_elims split: if_splits)
apply(metis mkeps_flat)
apply(rotate_tac 2)
apply(erule Prf.cases)
apply(simp_all)[7]
done

(* HERE *)

section \<open>Our Alternative Posix definition\<close>

inductive
  Posix :: "'a list \<Rightarrow> 'a rexp \<Rightarrow> 'a val \<Rightarrow> bool" ("_ \<in> _ \<rightarrow> _" [100, 100, 100] 100)
where
  Posix_One: "[] \<in> One \<rightarrow> Void"
| Posix_Atom: "[c] \<in> (Atom c) \<rightarrow> (Atm c)"
| Posix_Plus1: "s \<in> r1 \<rightarrow> v \<Longrightarrow> s \<in> (Plus r1 r2) \<rightarrow> (Left v)"
| Posix_Plus2: "\<lbrakk>s \<in> r2 \<rightarrow> v; s \<notin> lang r1\<rbrakk> \<Longrightarrow> s \<in> (Plus r1 r2) \<rightarrow> (Right v)"
| Posix_Times: "\<lbrakk>s1 \<in> r1 \<rightarrow> v1; s2 \<in> r2 \<rightarrow> v2;
    \<not>(\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (s1 @ s\<^sub>3) \<in> lang r1 \<and> s\<^sub>4 \<in> lang r2)\<rbrakk> \<Longrightarrow>
    (s1 @ s2) \<in> (Times r1 r2) \<rightarrow> (Seq v1 v2)"
| Posix_Star1: "\<lbrakk>s1 \<in> r \<rightarrow> v; s2 \<in> Star r \<rightarrow> Stars vs; flat v \<noteq> [];
    \<not>(\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (s1 @ s\<^sub>3) \<in> lang r \<and> s\<^sub>4 \<in> lang (Star r))\<rbrakk>
    \<Longrightarrow> (s1 @ s2) \<in> Star r \<rightarrow> Stars (v # vs)"
| Posix_Star2: "[] \<in> Star r \<rightarrow> Stars []"

inductive_cases Posix_elims:
  "s \<in> Zero \<rightarrow> v"
  "s \<in> One \<rightarrow> v"
  "s \<in> Atom c \<rightarrow> v"
  "s \<in> Plus r1 r2 \<rightarrow> v"
  "s \<in> Times r1 r2 \<rightarrow> v"
  "s \<in> Star r \<rightarrow> v"

lemma Posix1:
  assumes "s \<in> r \<rightarrow> v"
  shows "s \<in> lang r" "flat v = s"
using assms
by (induct s r v rule: Posix.induct) (auto)

lemma Posix1a:
  assumes "s \<in> r \<rightarrow> v"
  shows "\<turnstile> v : r"
using assms
by (induct s r v rule: Posix.induct)(auto intro: Prf.intros)

lemma Posix_mkeps:
  assumes "nullable r"
  shows "[] \<in> r \<rightarrow> mkeps r"
using assms
apply(induct r)
apply(auto intro: Posix.intros simp add: nullable_iff)
apply(subst append.simps(1)[symmetric])
apply(rule Posix.intros)
apply(auto)
done

lemma Posix_determ:
  assumes "s \<in> r \<rightarrow> v1" "s \<in> r \<rightarrow> v2"
  shows "v1 = v2"
using assms
proof (induct s r v1 arbitrary: v2 rule: Posix.induct)
  case (Posix_One v2)
  have "[] \<in> One \<rightarrow> v2" by fact
  then show "Void = v2" by cases auto
next
  case (Posix_Atom c v2)
  have "[c] \<in> Atom c \<rightarrow> v2" by fact
  then show "Atm c = v2" by cases auto
next
  case (Posix_Plus1 s r1 v r2 v2)
  have "s \<in> Plus r1 r2 \<rightarrow> v2" by fact
  moreover
  have "s \<in> r1 \<rightarrow> v" by fact
  then have "s \<in> lang r1" by (simp add: Posix1)
  ultimately obtain v' where eq: "v2 = Left v'" "s \<in> r1 \<rightarrow> v'" by cases auto
  moreover
  have IH: "\<And>v2. s \<in> r1 \<rightarrow> v2 \<Longrightarrow> v = v2" by fact
  ultimately have "v = v'" by simp
  then show "Left v = v2" using eq by simp
next
  case (Posix_Plus2 s r2 v r1 v2)
  have "s \<in> Plus r1 r2 \<rightarrow> v2" by fact
  moreover
  have "s \<notin> lang r1" by fact
  ultimately obtain v' where eq: "v2 = Right v'" "s \<in> r2 \<rightarrow> v'"
    by cases (auto simp add: Posix1)
  moreover
  have IH: "\<And>v2. s \<in> r2 \<rightarrow> v2 \<Longrightarrow> v = v2" by fact
  ultimately have "v = v'" by simp
  then show "Right v = v2" using eq by simp
next
  case (Posix_Times s1 r1 v1 s2 r2 v2 v')
  have "(s1 @ s2) \<in> Times r1 r2 \<rightarrow> v'"
       "s1 \<in> r1 \<rightarrow> v1" "s2 \<in> r2 \<rightarrow> v2"
       "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang r1 \<and> s\<^sub>4 \<in> lang r2)" by fact+
  then obtain v1' v2' where "v' = Seq v1' v2'" "s1 \<in> r1 \<rightarrow> v1'" "s2 \<in> r2 \<rightarrow> v2'"
  apply(cases) apply (auto simp add: append_eq_append_conv2)
  using Posix1(1) by fastforce+
  moreover
  have IHs: "\<And>v1'. s1 \<in> r1 \<rightarrow> v1' \<Longrightarrow> v1 = v1'"
            "\<And>v2'. s2 \<in> r2 \<rightarrow> v2' \<Longrightarrow> v2 = v2'" by fact+
  ultimately show "Seq v1 v2 = v'" by simp
next
  case (Posix_Star1 s1 r v s2 vs v2)
  have "(s1 @ s2) \<in> Star r \<rightarrow> v2"
       "s1 \<in> r \<rightarrow> v" "s2 \<in> Star r \<rightarrow> Stars vs" "flat v \<noteq> []"
       "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang r \<and> s\<^sub>4 \<in> lang (Star r))" by fact+
  then obtain v' vs' where "v2 = Stars (v' # vs')" "s1 \<in> r \<rightarrow> v'" "s2 \<in> (Star r) \<rightarrow> (Stars vs')"
  apply(cases) apply (auto simp add: append_eq_append_conv2)
  using Posix1(1) apply fastforce
  apply (metis Posix1(1) Posix_Star1.hyps(6) append_Nil append_Nil2)
  using Posix1(2) by blast
  moreover
  have IHs: "\<And>v2. s1 \<in> r \<rightarrow> v2 \<Longrightarrow> v = v2"
            "\<And>v2. s2 \<in> Star r \<rightarrow> v2 \<Longrightarrow> Stars vs = v2" by fact+
  ultimately show "Stars (v # vs) = v2" by auto
next
  case (Posix_Star2 r v2)
  have "[] \<in> Star r \<rightarrow> v2" by fact
  then show "Stars [] = v2" by cases (auto simp add: Posix1)
qed

lemma Posix_injval:
  assumes "s \<in> (deriv c r) \<rightarrow> v"
  shows "(c # s) \<in> r \<rightarrow> (injval r c v)"
using assms
proof(induct r arbitrary: s v rule: rexp.induct)
  case Zero
  have "s \<in> deriv c Zero \<rightarrow> v" by fact
  then have "s \<in> Zero \<rightarrow> v" by simp
  then have "False" by cases
  then show "(c # s) \<in> Zero \<rightarrow> (injval Zero c v)" by simp
next
  case One
  have "s \<in> deriv c One \<rightarrow> v" by fact
  then have "s \<in> Zero \<rightarrow> v" by simp
  then have "False" by cases
  then show "(c # s) \<in> One \<rightarrow> (injval One c v)" by simp
next
  case (Atom d)
  consider (eq) "c = d" | (ineq) "c \<noteq> d" by blast
  then show "(c # s) \<in> (Atom d) \<rightarrow> (injval (Atom d) c v)"
  proof (cases)
    case eq
    have "s \<in> deriv c (Atom d) \<rightarrow> v" by fact
    then have "s \<in> One \<rightarrow> v" using eq by simp
    then have eqs: "s = [] \<and> v = Void" by cases simp
    show "(c # s) \<in> Atom d \<rightarrow> injval (Atom d) c v" using eq eqs
    by (auto intro: Posix.intros)
  next
    case ineq
    have "s \<in> deriv c (Atom d) \<rightarrow> v" by fact
    then have "s \<in> Zero \<rightarrow> v" using ineq by simp
    then have "False" by cases
    then show "(c # s) \<in> Atom d \<rightarrow> injval (Atom d) c v" by simp
  qed
next
  case (Plus r1 r2)
  have IH1: "\<And>s v. s \<in> deriv c r1 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r1 \<rightarrow> injval r1 c v" by fact
  have IH2: "\<And>s v. s \<in> deriv c r2 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r2 \<rightarrow> injval r2 c v" by fact
  have "s \<in> deriv c (Plus r1 r2) \<rightarrow> v" by fact
  then have "s \<in> Plus (deriv c r1) (deriv c r2) \<rightarrow> v" by simp
  then consider (left) v' where "v = Left v'" "s \<in> deriv c r1 \<rightarrow> v'"
              | (right) v' where "v = Right v'" "s \<notin> lang (deriv c r1)" "s \<in> deriv c r2 \<rightarrow> v'"
              by cases auto
  then show "(c # s) \<in> Plus r1 r2 \<rightarrow> injval (Plus r1 r2) c v"
  proof (cases)
    case left
    have "s \<in> deriv c r1 \<rightarrow> v'" by fact
    then have "(c # s) \<in> r1 \<rightarrow> injval r1 c v'" using IH1 by simp
    then have "(c # s) \<in> Plus r1 r2 \<rightarrow> injval (Plus r1 r2) c (Left v')" by (auto intro: Posix.intros)
    then show "(c # s) \<in> Plus r1 r2 \<rightarrow> injval (Plus r1 r2) c v" using left by simp
  next
    case right
    have "s \<notin> lang (deriv c r1)" by fact
    then have "c # s \<notin> lang r1" by (simp add: lang_deriv Deriv_def)
    moreover
    have "s \<in> deriv c r2 \<rightarrow> v'" by fact
    then have "(c # s) \<in> r2 \<rightarrow> injval r2 c v'" using IH2 by simp
    ultimately have "(c # s) \<in> Plus r1 r2 \<rightarrow> injval (Plus r1 r2) c (Right v')"
      by (auto intro: Posix.intros)
    then show "(c # s) \<in> Plus r1 r2 \<rightarrow> injval (Plus r1 r2) c v" using right by simp
  qed
next
  case (Times r1 r2)
  have IH1: "\<And>s v. s \<in> deriv c r1 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r1 \<rightarrow> injval r1 c v" by fact
  have IH2: "\<And>s v. s \<in> deriv c r2 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r2 \<rightarrow> injval r2 c v" by fact
  have "s \<in> deriv c (Times r1 r2) \<rightarrow> v" by fact
  then consider
        (left_nullable) v1 v2 s1 s2 where
        "v = Left (Seq v1 v2)"  "s = s1 @ s2"
        "s1 \<in> deriv c r1 \<rightarrow> v1" "s2 \<in> r2 \<rightarrow> v2" "nullable r1"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r1) \<and> s\<^sub>4 \<in> lang r2)"
      | (right_nullable) v1 s1 s2 where
        "v = Right v1" "s = s1 @ s2"
        "s \<in> deriv c r2 \<rightarrow> v1" "nullable r1" "s1 @ s2 \<notin> lang (Times (deriv c r1) r2)"
      | (not_nullable) v1 v2 s1 s2 where
        "v = Seq v1 v2" "s = s1 @ s2"
        "s1 \<in> deriv c r1 \<rightarrow> v1" "s2 \<in> r2 \<rightarrow> v2" "\<not>nullable r1"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r1) \<and> s\<^sub>4 \<in> lang r2)"
        by (force split: if_splits elim!: Posix_elims simp add: lang_deriv Deriv_def)
  then show "(c # s) \<in> Times r1 r2 \<rightarrow> injval (Times r1 r2) c v"
    proof (cases)
      case left_nullable
      have "s1 \<in> deriv c r1 \<rightarrow> v1" by fact
      then have "(c # s1) \<in> r1 \<rightarrow> injval r1 c v1" using IH1 by simp
      moreover
      have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r1) \<and> s\<^sub>4 \<in> lang r2)" by fact
      then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> lang r1 \<and> s\<^sub>4 \<in> lang r2)"
         by (simp add: lang_deriv Deriv_def)
      ultimately have "((c # s1) @ s2) \<in> Times r1 r2 \<rightarrow> Seq (injval r1 c v1) v2" using left_nullable by (rule_tac Posix.intros)
      then show "(c # s) \<in> Times r1 r2 \<rightarrow> injval (Times r1 r2) c v" using left_nullable by simp
    next
      case right_nullable
      have "nullable r1" by fact
      then have "[] \<in> r1 \<rightarrow> (mkeps r1)" by (rule Posix_mkeps)
      moreover
      have "s \<in> deriv c r2 \<rightarrow> v1" by fact
      then have "(c # s) \<in> r2 \<rightarrow> (injval r2 c v1)" using IH2 by simp
      moreover
      have "s1 @ s2 \<notin> lang (Times (deriv c r1) r2)" by fact
      then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = c # s \<and> [] @ s\<^sub>3 \<in> lang r1 \<and> s\<^sub>4 \<in> lang r2)"
        using right_nullable
        apply (auto simp add: lang_deriv Deriv_def append_eq_Cons_conv)
        by (metis concI mem_Collect_eq)
      ultimately have "([] @ (c # s)) \<in> Times r1 r2 \<rightarrow> Seq (mkeps r1) (injval r2 c v1)"
      by(rule Posix.intros)
      then show "(c # s) \<in> Times r1 r2 \<rightarrow> injval (Times r1 r2) c v" using right_nullable by simp
    next
      case not_nullable
      have "s1 \<in> deriv c r1 \<rightarrow> v1" by fact
      then have "(c # s1) \<in> r1 \<rightarrow> injval r1 c v1" using IH1 by simp
      moreover
      have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r1) \<and> s\<^sub>4 \<in> lang r2)" by fact
      then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> lang r1 \<and> s\<^sub>4 \<in> lang r2)" by (simp add: lang_deriv Deriv_def)
      ultimately have "((c # s1) @ s2) \<in> Times r1 r2 \<rightarrow> Seq (injval r1 c v1) v2" using not_nullable
        by (rule_tac Posix.intros) (simp_all)
      then show "(c # s) \<in> Times r1 r2 \<rightarrow> injval (Times r1 r2) c v" using not_nullable by simp
    qed
next
  case (Star r)
  have IH: "\<And>s v. s \<in> deriv c r \<rightarrow> v \<Longrightarrow> (c # s) \<in> r \<rightarrow> injval r c v" by fact
  have "s \<in> deriv c (Star r) \<rightarrow> v" by fact
  then consider
      (cons) v1 vs s1 s2 where
        "v = Seq v1 (Stars vs)" "s = s1 @ s2"
        "s1 \<in> deriv c r \<rightarrow> v1" "s2 \<in> (Star r) \<rightarrow> (Stars vs)"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r) \<and> s\<^sub>4 \<in> lang (Star r))"
        apply(auto elim!: Posix_elims(1-5) simp add: lang_deriv Deriv_def intro: Posix.intros)
        apply(rotate_tac 3)
        apply(erule_tac Posix_elims(6))
        apply (simp add: Posix.intros(6))
        using Posix.intros(7) by blast
    then show "(c # s) \<in> Star r \<rightarrow> injval (Star r) c v"
    proof (cases)
      case cons
          have "s1 \<in> deriv c r \<rightarrow> v1" by fact
          then have "(c # s1) \<in> r \<rightarrow> injval r c v1" using IH by simp
        moreover
          have "s2 \<in> Star r \<rightarrow> Stars vs" by fact
        moreover
          have "(c # s1) \<in> r \<rightarrow> injval r c v1" by fact
          then have "flat (injval r c v1) = (c # s1)" by (rule Posix1)
          then have "flat (injval r c v1) \<noteq> []" by simp
        moreover
          have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> lang (deriv c r) \<and> s\<^sub>4 \<in> lang (Star r))" by fact
          then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> lang r \<and> s\<^sub>4 \<in> lang (Star r))"
            by (simp add: lang_deriv Deriv_def)
        ultimately
        have "((c # s1) @ s2) \<in> Star r \<rightarrow> Stars (injval r c v1 # vs)" by (rule Posix.intros)
        then show "(c # s) \<in> Star r \<rightarrow> injval (Star r) c v" using cons by(simp)
    qed
qed

section \<open>The Lexer by Sulzmann and Lu\<close>

fun
  lexer :: "'a rexp \<Rightarrow> 'a list \<Rightarrow> ('a val) option"
where
  "lexer r [] = (if nullable r then Some(mkeps r) else None)"
| "lexer r (c#s) = (case (lexer (deriv c r) s) of
                    None \<Rightarrow> None
                  | Some(v) \<Rightarrow> Some(injval r c v))"

lemma lexer_correct_None:
  shows "s \<notin> lang r \<longleftrightarrow> lexer r s = None"
apply(induct s arbitrary: r)
apply(simp add: nullable_iff)
apply(drule_tac x="deriv a r" in meta_spec)
apply(auto simp add: lang_deriv Deriv_def)
done

lemma lexer_correct_Some:
  shows "s \<in> lang r \<longleftrightarrow> (\<exists>v. lexer r s = Some(v) \<and> s \<in> r \<rightarrow> v)"
apply(induct s arbitrary: r)
apply(auto simp add: Posix_mkeps nullable_iff)[1]
apply(drule_tac x="deriv a r" in meta_spec)
apply(simp add: lang_deriv Deriv_def)
apply(rule iffI)
apply(auto intro: Posix_injval simp add: Posix1(1))
done

lemma lexer_correctness:
  shows "(lexer r s = Some v) \<longleftrightarrow> s \<in> r \<rightarrow> v"
  and   "(lexer r s = None) \<longleftrightarrow> \<not>(\<exists>v. s \<in> r \<rightarrow> v)"
apply(auto)
using lexer_correct_None lexer_correct_Some apply fastforce
using Posix1(1) Posix_determ lexer_correct_Some apply blast
using Posix1(1) lexer_correct_None apply blast
using lexer_correct_None lexer_correct_Some by blast

end


section \<open>Extrapolation of DBMs\<close>

theory DBM_Normalization
  imports DBM_Basics DBM_Misc "HOL-Eisbach.Eisbach"
begin

text \<open>NB: The journal paper on extrapolations based on lower and upper bounds
@{cite "BehrmannBLP06"} provides slightly incorrect definitions that would always set
(lower) bounds of the form \<open>M 0 i\<close> to \<open>\<infinity>\<close>.
To fix this, we use two invariants that can also be found in TChecker's DBM library, for instance:
  \<^enum> Lower bounds are always nonnegative, i.e.\ \<open>\<forall>i \<le> n. M 0 i \<le> 0\<close>
   (see \<open>extra_lup_lower_bounds\<close>).
  \<^enum> Entries to the diagonal is always normalized to \<open>Le 0\<close>, \<open>Lt 0\<close> or \<open>\<infinity>\<close>. This makes it again
    obvious that the set of normalized DBMs is finite.
\<close>

(* XXX move *)
lemmas dbm_less_simps[simp] = dbm_lt_code_simps[folded DBM.less]

lemma dbm_less_eq_simps[simp]:
  "Le a \<le> Le b \<longleftrightarrow> a \<le> b"
  "Le a \<le> Lt b \<longleftrightarrow> a < b"
  "Lt a \<le> Le b \<longleftrightarrow> a \<le> b"
  "Lt a \<le> Lt b \<longleftrightarrow> a \<le> b"
  unfolding less_eq dbm_le_def by auto

lemma Le_less_Lt[simp]: "Le x < Lt x \<longleftrightarrow> False"
  using leD by blast

subsection \<open>Classical extrapolation\<close>

text \<open>This is the implementation of the classical extrapolation operator (\<open>Extra\<^sub>M\<close>).\<close>

fun norm_upper :: "('t::linorder) DBMEntry \<Rightarrow> 't \<Rightarrow> 't DBMEntry"
where
  "norm_upper e t = (if Le t \<prec> e then \<infinity> else e)"

fun norm_lower :: "('t::linorder) DBMEntry \<Rightarrow> 't \<Rightarrow> 't DBMEntry"
where
  "norm_lower e t = (if e \<prec> Lt t then Lt t else e)"

definition
  "norm_diag e = (if e \<prec> Le 0 then Lt 0 else if e = Le 0 then e else \<infinity>)"

text \<open>
  Note that literature pretends that \<open>\<zero>\<close> would have a bound of negative infinity in \<open>k\<close>
  and thus defines normalization uniformly. The easiest way to get around this seems to explicate
  this in the definition as below.
\<close>
definition norm :: "('t :: linordered_ab_group_add) DBM \<Rightarrow> (nat \<Rightarrow> 't) \<Rightarrow> nat \<Rightarrow> 't DBM"
where
  "norm M k n \<equiv> \<lambda>i j.
    let ub = if i > 0 then k i   else 0 in
    let lb = if j > 0 then - k j else 0 in
    if i \<le> n \<and> j \<le> n then
      if i \<noteq> j then norm_lower (norm_upper (M i j) ub) lb else norm_diag (M i j)
    else M i j
  "

subsection \<open>Extrapolations based on lower and upper bounds\<close>

text \<open>This is the implementation of the LU-bounds based extrapolation operation (\<open>Extra_{LU}\<close>).\<close>
definition extra_lu ::
  "('t :: linordered_ab_group_add) DBM \<Rightarrow> (nat \<Rightarrow> 't) \<Rightarrow> (nat \<Rightarrow> 't) \<Rightarrow> nat \<Rightarrow> 't DBM"
where
  "extra_lu M l u n \<equiv> \<lambda>i j.
    let ub = if i > 0 then l i   else 0 in
    let lb = if j > 0 then - u j else 0 in
    if i \<le> n \<and> j \<le> n then
      if i \<noteq> j then norm_lower (norm_upper (M i j) ub) lb else norm_diag (M i j)
    else M i j
  "

lemma norm_is_extra:
  "norm M k n = extra_lu M k k n"
  unfolding norm_def extra_lu_def ..

text \<open>This is the implementation of the LU-bounds based extrapolation operation (\<open>Extra_{LU}^+\<close>).\<close>
definition extra_lup ::
  "('t :: linordered_ab_group_add) DBM \<Rightarrow> (nat \<Rightarrow> 't) \<Rightarrow> (nat \<Rightarrow> 't) \<Rightarrow> nat \<Rightarrow> 't DBM"
where
  "extra_lup M l u n \<equiv> \<lambda>i j.
    let ub = if i > 0 then Lt (l i) else Le 0;
        lb = if j > 0 then Lt (- u j) else Lt 0
    in
    if i \<le> n \<and> j \<le> n then
      if i \<noteq> j then
        if ub \<prec> M i j then \<infinity>
        else if i > 0 \<and> M 0 i \<prec> Lt (- l i) then \<infinity>
        else if i > 0 \<and> M 0 j \<prec> lb then \<infinity>
        else if i = 0 \<and> M 0 j \<prec> lb then Lt (- u j)
        else M i j
      else norm_diag (M i j)
    else M i j
  "

method csimp = (clarsimp simp: extra_lup_def Let_def DBM.less[symmetric] not_less any_le_inf neutral)

method solve = csimp?; safe?; (csimp | meson Lt_le_LeI le_less le_less_trans less_asym'); fail

\<^cancel>\<open>lemma extrapolations_diag_preservation:
  "extra_lu M L U n i i = M i i" "extra_lup M L U n i i = M i i" "norm M k n i i = M i i"
  unfolding extra_lu_def extra_lup_def norm_def Let_def by auto\<close>

lemma
  assumes "\<forall>i \<le> n. i > 0 \<longrightarrow> M 0 i \<le> 0" "\<forall>i \<le> n. U i \<ge> 0"
  shows
    extra_lu_lower_bounds:  "\<forall>i \<le> n. i > 0 \<longrightarrow> extra_lu M L U n 0 i \<le> 0" and
    norm_lower_bounds:      "\<forall>i \<le> n. i > 0 \<longrightarrow> norm M U n 0 i \<le> 0" and
    extra_lup_lower_bounds: "\<forall>i \<le> n. i > 0 \<longrightarrow> extra_lup M L U n 0 i \<le> 0"
  using assms unfolding extra_lu_def norm_def by - (csimp; force)+

lemma extra_lu_le_extra_lup:
  assumes canonical: "canonical M n"
      and canonical_lower_bounds: "\<forall>i \<le> n. i > 0 \<longrightarrow> M 0 i \<le> 0"
  shows "extra_lu M l u n i j \<le> extra_lup M l u n i j"
proof -
  have "M 0 j \<le> M i j" if "i \<le> n" "j \<le> n" "i > 0"
  proof -
    have "M 0 i \<le> 0"
      using canonical_lower_bounds \<open>i \<le> n\<close> \<open>i > 0\<close> by simp
    then have "M 0 i + M i j \<le> M i j"
      by (simp add: add_decreasing)
    also have "M 0 j \<le> M 0 i + M i j"
      using canonical that by auto
    finally (xtrans) show ?thesis .
  qed
  then show ?thesis
    by - (cases "i \<le> n"; cases "j \<le> n"; unfold extra_lu_def Let_def; clarsimp; safe?; solve)
qed

lemma extra_lu_subs_extra_lup:
  assumes canonical: "canonical M n" and canonical_lower_bounds: "\<forall>i \<le> n. i > 0 \<longrightarrow> M 0 i \<le> 0"
    shows "[extra_lu M L U n]\<^bsub>v,n\<^esub> \<subseteq> [extra_lup M L U n]\<^bsub>v,n\<^esub>"
  using assms
  by (auto intro: extra_lu_le_extra_lup simp: DBM.less_eq[symmetric] elim!: DBM_le_subset[rotated])

subsection \<open>Extrapolations are widening operators\<close>

lemma extra_lu_mono:
  assumes "\<forall>c. v c > 0" "u \<in> [M]\<^bsub>v,n\<^esub>"
  shows "u \<in> [extra_lu M L U n]\<^bsub>v,n\<^esub>" (is "u \<in> [?M2]\<^bsub>v,n\<^esub>")
proof -
  note A = assms
  note M1 = A(2)[unfolded DBM_zone_repr_def DBM_val_bounded_def]
  show ?thesis
  proof (unfold DBM_zone_repr_def DBM_val_bounded_def, auto)
    show "Le 0 \<preceq> ?M2 0 0"
      using A unfolding extra_lu_def DBM_zone_repr_def DBM_val_bounded_def dbm_le_def norm_diag_def
      by auto
  next
    fix c assume "v c \<le> n"
    with M1 have M1: "dbm_entry_val u None (Some c) (M 0 (v c))" by auto
    from \<open>v c \<le> n\<close> A have *:
      "?M2 0 (v c) = norm_lower (norm_upper (M 0 (v c)) 0) (- U (v c))"
    unfolding extra_lu_def by auto
    show "dbm_entry_val u None (Some c) (?M2 0 (v c))"
    proof (cases "M 0 (v c) \<prec> Lt (- U (v c))")
      case True
      show ?thesis
      proof (cases "Le 0 \<prec> M 0 (v c)")
        case True with * show ?thesis by auto
      next
        case False
        with * True have "?M2 0 (v c) = Lt (- U (v c))" by auto
        moreover from True dbm_entry_val_mono_2[OF M1] have
          "dbm_entry_val u None (Some c) (Lt (- U (v c)))"
        by auto
        ultimately show ?thesis by auto
      qed
    next
      case False
      show ?thesis
      proof (cases "Le 0 \<prec> M 0 (v c)")
        case True with * show ?thesis by auto
      next
        case F: False
        with M1 * False show ?thesis by auto
      qed
    qed
  next
    fix c assume "v c \<le> n"
    with M1 have M1: "dbm_entry_val u (Some c) None (M (v c) 0)" by auto
    from \<open>v c \<le> n\<close> A have *:
      "?M2 (v c) 0 = norm_lower (norm_upper (M (v c) 0) (L (v c))) 0"
    unfolding extra_lu_def by auto
    show "dbm_entry_val u (Some c) None (?M2 (v c) 0)"
    proof (cases "Le (L (v c)) \<prec> M (v c) 0")
      case True
      with A(1,2) \<open>v c \<le> n\<close> have "?M2 (v c) 0 = \<infinity>" unfolding extra_lu_def by auto
      then show ?thesis by auto
    next
      case False
      show ?thesis
      proof (cases "M (v c) 0 \<prec> Lt 0")
        case True with False * dbm_entry_val_mono_3[OF M1] show ?thesis by auto
      next
        case F: False
        with M1 * False show ?thesis by auto
      qed
    qed
  next
    fix c1 c2 assume "v c1 \<le> n" "v c2 \<le> n"
    with M1 have M1: "dbm_entry_val u (Some c1) (Some c2) (M (v c1) (v c2))" by auto
    show "dbm_entry_val u (Some c1) (Some c2) (?M2 (v c1) (v c2))"
    proof (cases "v c1 = v c2")
      case True
      with M1 show ?thesis
        by (auto simp: extra_lu_def norm_diag_def dbm_entry_val.simps dbm_lt.simps)
           (meson diff_less_0_iff_less le_less_trans less_le_trans)+
    next
      case False
      show ?thesis
      proof (cases "Le (L (v c1)) \<prec> M (v c1) (v c2)")
        case True
        with A(1,2) \<open>v c1 \<le> n\<close> \<open>v c2 \<le> n\<close> \<open>v c1 \<noteq> v c2\<close> have "?M2 (v c1) (v c2) = \<infinity>"
          unfolding extra_lu_def by auto
        then show ?thesis by auto
      next
        case False
        with A(1,2) \<open>v c1 \<le> n\<close> \<open>v c2 \<le> n\<close> \<open>v c1 \<noteq> v c2\<close> have *:
          "?M2 (v c1) (v c2) = norm_lower (M (v c1) (v c2)) (- U (v c2))"
          unfolding extra_lu_def by auto
        show ?thesis
        proof (cases "M (v c1) (v c2) \<prec> Lt (- U (v c2))")
          case True
          with dbm_entry_val_mono_1[OF M1] have
            "dbm_entry_val u (Some c1) (Some c2) (Lt (- U (v c2)))"
            by auto
          then have "u c1 - u c2 < - U (v c2)" by auto
          with * True show ?thesis by auto
        next
          case False with M1 * show ?thesis by auto
        qed
      qed
    qed
  qed
qed

lemma norm_mono:
  assumes "\<forall>c. v c > 0" "u \<in> [M]\<^bsub>v,n\<^esub>"
  shows "u \<in> [norm M k n]\<^bsub>v,n\<^esub>"
  using assms unfolding norm_is_extra by (rule extra_lu_mono)

subsection \<open>Finiteness of extrapolations\<close>

abbreviation "dbm_default M n \<equiv> (\<forall> i > n. \<forall> j. M i j = 0) \<and> (\<forall> j > n. \<forall> i. M i j = 0)"

lemma norm_default_preservation:
  "dbm_default M n \<Longrightarrow> dbm_default (norm M k n) n"
  by (simp add: norm_def norm_diag_def DBM.neutral dbm_lt.simps)

lemma extra_lu_default_preservation:
  "dbm_default M n \<Longrightarrow> dbm_default (extra_lu M L U n) n"
  by (simp add: extra_lu_def norm_diag_def DBM.neutral dbm_lt.simps)

instance int :: linordered_cancel_ab_monoid_add by (standard; simp)

(* XXX Move *)
lemmas finite_subset_rev[intro?] = finite_subset[rotated]
lemmas [intro?] = finite_subset

lemma extra_lu_finite:
  fixes L U :: "nat \<Rightarrow> nat"
  shows "finite {extra_lu M L U n | M. dbm_default M n}"
proof -
  let ?u = "Max {L i | i. i \<le> n}" let ?l = "- Max {U i | i. i \<le> n}"
  let ?S = "(Le ` {d :: int. ?l \<le> d \<and> d \<le> ?u}) \<union> (Lt ` {d :: int. ?l \<le> d \<and> d \<le> ?u}) \<union> {Le 0, Lt 0, \<infinity>}"
  from finite_set_of_finite_funs2[of "{0..n}" "{0..n}" ?S] have fin:
    "finite {f. \<forall>x y. (x \<in> {0..n} \<and> y \<in> {0..n} \<longrightarrow> f x y \<in> ?S)
                \<and> (x \<notin> {0..n} \<longrightarrow> f x y = 0) \<and> (y \<notin> {0..n} \<longrightarrow> f x y = 0)}" (is "finite ?R")
    by auto
  { fix M :: "int DBM" assume A: "dbm_default M n"
    let ?M = "extra_lu M L U n"
    from extra_lu_default_preservation[OF A] have A: "dbm_default ?M n" .
    { fix i j assume "i \<in> {0..n}" "j \<in> {0..n}"
      then have B: "i \<le> n" "j \<le> n"
        by auto
      have "?M i j \<in> ?S"
      proof (cases "?M i j \<in> {Le 0, Lt 0, \<infinity>}")
        case True then show ?thesis
          by auto
      next
        case F: False
        note not_inf = this
        have "?l \<le> get_const (?M i j) \<and> get_const (?M i j) \<le> ?u"
        proof (cases "i = 0")
          case True
          show ?thesis
          proof (cases "j = 0")
            case True
            with \<open>i = 0\<close> A F show ?thesis
              unfolding extra_lu_def by (auto simp: neutral norm_diag_def)
          next
            case False
            with \<open>i = 0\<close> B not_inf have "?M i j \<le> Le 0" "Lt (-int (U j)) \<le> ?M i j"
              unfolding extra_lu_def by (auto simp: Let_def less[symmetric] intro: any_le_inf)
            with not_inf have "get_const (?M i j) \<le> 0" "-U j \<le> get_const (?M i j)"
              by (cases "?M i j"; auto)+
            moreover from \<open>j \<le> n\<close> have "- U j \<ge> ?l"
              by (auto intro: Max_ge)
            ultimately show ?thesis
              by auto
          qed
        next
          case False
          then have "i > 0" by simp
          show ?thesis
          proof (cases "j = 0")
            case True
            with \<open>i > 0\<close> A(1) B not_inf have "Lt 0 \<le> ?M i j" "?M i j \<le> Le (int (L i))"
              unfolding extra_lu_def by (auto simp: Let_def less[symmetric] intro: any_le_inf)
            with not_inf have "0 \<le> get_const (?M i j)" "get_const (?M i j) \<le> L i"
              by (cases "?M i j"; auto)+
            moreover from \<open>i \<le> n\<close> have "L i \<le> ?u"
              by (auto intro: Max_ge)
            ultimately show ?thesis
              by auto
          next
            case False
            with \<open>i > 0\<close> A(1) B not_inf F have
              "Lt (-int (U j)) \<le> ?M i j" "?M i j \<le> Le (int (L i))"
              unfolding extra_lu_def
              by (auto simp: Let_def less[symmetric] neutral norm_diag_def
                    intro: any_le_inf split: if_split_asm)
            with not_inf have "- U j \<le> get_const (?M i j)" "get_const (?M i j) \<le> L i"
              by (cases "?M i j"; auto)+
            moreover from \<open>i \<le> n\<close> \<open>j \<le> n\<close> have "?l \<le> - U j" "L i \<le> ?u"
              by (auto intro: Max_ge)
            ultimately show ?thesis
              by auto
          qed
        qed
        then show ?thesis by (cases "?M i j"; auto elim: Ints_cases)
      qed
    } moreover
    { fix i j assume "i \<notin> {0..n}"
      with A have "?M i j = 0" by auto
    } moreover
    { fix i j assume "j \<notin> {0..n}"
      with A have "?M i j = 0" by auto
    } moreover note the = calculation
  } then have "{extra_lu M L U n | M. dbm_default M n} \<subseteq> ?R"
      by blast
  with fin show ?thesis ..
qed

lemma normalized_integral_dbms_finite:
  "finite {norm M (k :: nat \<Rightarrow> nat) n | M. dbm_default M n}"
  unfolding norm_is_extra by (rule extra_lu_finite)

end


theory Monad
  imports Main "HOL-Library.Monad_Syntax"
begin

datatype ('M, 'a) state = State (runState: "'M \<Rightarrow> 'a \<times> 'M")
term 0 (**)

definition return :: "'a \<Rightarrow> ('M, 'a) state" where
  "return a \<equiv> State (\<lambda>M. (a, M))"
term 0 (**)

definition bind :: "('M, 'a) state \<Rightarrow> ('a \<Rightarrow> ('M, 'b) state) \<Rightarrow> ('M, 'b) state" where
  "bind s k \<equiv> State (\<lambda>M. let (a, M') = runState s M in runState (k a) M')"
term 0 (**)

adhoc_overloading
  Monad_Syntax.bind bind

definition get :: "('M, 'M) state" where
  "get \<equiv> State (\<lambda>M. (M, M))"

definition put :: "'M \<Rightarrow> ('M, unit) state" where
  "put M \<equiv> State (\<lambda>_. ((), M))"
term 0 (**)

lemma bind_assoc:
  fixes s::"('M, 'a) state" and k0 k1
  shows "(s \<bind> k0) \<bind> k1 = s \<bind> (\<lambda>a. k0 a \<bind> k1)"
  unfolding bind_def by (auto split: prod.split)

lemma left_identity:
  "return v \<bind> k = k v"
  unfolding return_def bind_def by simp

lemma right_identity:
  "s \<bind> return = s"
  unfolding return_def bind_def by simp

lemma runState_return:
  "runState (return x) M = (x, M)"
  unfolding return_def by simp
end


theory Lzip_ltakeWhile_snd
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer

codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

primcorec ltakeWhile :: "('a \<Rightarrow> bool) \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist"
where
  "lnull xs \<or> \<not> P (lhd xs) \<Longrightarrow> lnull (ltakeWhile P xs)"
| "lhd (ltakeWhile P xs) = lhd xs"
| "ltl (ltakeWhile P xs) = ltakeWhile P (ltl xs)"
datatype ('a, 'b) Pair2 = Pair2 'a 'b

primcorec lzip :: "'a Llist \<Rightarrow> 'b Llist \<Rightarrow> (('a, 'b) Pair2) Llist"
where
  "lnull xs \<or> lnull ys \<Longrightarrow> lnull (lzip xs ys)"
| "lhd (lzip xs ys) = (Pair2 (lhd xs) (lhd ys))"
| "ltl (lzip xs ys) = lzip (ltl xs) (ltl ys)"

fun snd2 :: "('a,'b) Pair2 \<Rightarrow> 'b" where
"snd2 (Pair2 a b) = b"

theorem lzip_ltakeWhile_snd: "lzip xs (ltakeWhile P ys) = ltakeWhile (P \<circ> snd2) (lzip xs ys)"
by hipster_coinduct_sledgehammer
end


theory Seq_Obs
  imports
   Ordered_Semigroups
  "rg-algebra/General/Sequential"
begin

locale first = fixes first

locale last  = fixes last

locale seq =  fixes seq :: "'a  \<Rightarrow> 'a \<Rightarrow> 'a" (infixl ";" 90)

locale test_semigroup = ordered_semigroup +
  fixes unit_of :: "'a \<Rightarrow> 'a" ("(_\<^sub>1)" [1000] 999)
  fixes test :: "'b  \<Rightarrow> 'a"
  assumes unit_of_unit: "\<And>a t. b \<le> test t \<Longrightarrow> (unit_of a) \<le> b \<longleftrightarrow> a \<le> f a b"
  assumes down_unit:    "\<And> a b. f b (unit_of a) \<le> b"
  assumes unit_of_apply: "\<And>a. a \<le> f a (unit_of a)"
begin

lift_definition dunit :: "'a downset" is "\<Down>(range unit_of) "
  apply (clarsimp)
  apply (clarsimp simp: downset_set_def')
  done

sublocale conv_right: right_monoid convolute dunit
  apply (standard)
  apply (transfer)
   apply (clarsimp simp:  down_sup_distrib )
  apply (safe; clarsimp simp: in_down_iff down_image_iff )
   defer
  apply (meson UNIV_I down_image_iff order_refl unit_of_apply)
  by (meson down_unit in_downsetI mono_f preorder_class.dual_order.refl)
end

locale seq_elem = seq + unital_semigroup seq last + last +
  flip: test_semigroup "\<lambda>x y. seq y x" first + first + bot_strict seq +
  constrains first :: "'a \<Rightarrow> 'a"
  assumes first_last: "range first = range last"
begin

definition "dnil = dunit \<squnion> flip.dunit"

lemma dunit_flip: "dunit = flip.dunit"
  by (transfer, clarsimp simp: first_last)

sublocale monoid convolute dnil
  apply (standard)
   apply (clarsimp simp: dnil_def sup_downset_def dunit_flip)
   apply (transfer)
  apply (intro set_eqI)
   apply (clarsimp simp: down_sup_distrib down_union_distrib down_image_iff)
   apply (safe; clarsimp simp: down_image_iff in_down_iff)
    apply (meson flip.down_unit in_downsetI mono_f order_refl)
   apply (clarsimp simp: down_image_iff in_down_iff Bex_def)
  using flip.unit_of_apply apply blast
apply (clarsimp simp: dnil_def sup_downset_def dunit_flip[symmetric])
   apply (transfer)
  apply (intro set_eqI)
   apply (clarsimp simp: down_sup_distrib down_union_distrib down_image_iff)
   apply (safe; clarsimp simp: down_image_iff in_down_iff)
    apply (meson down_unit in_downsetI mono_f order_refl)
   apply (clarsimp simp: down_image_iff in_down_iff Bex_def)
  using unit_of_apply apply blast
  done

sublocale downset_seq_distrib_left: seq_distrib_left convolute dnil
  apply (standard; clarsimp?)
   apply (simp add: conv_top_strict.top_strict_axioms top_strict.top_strict)
  apply (intro conjI)
  apply (clarsimp simp: less_eq_downset_def sup_downset_def, transfer, clarsimp)
  apply (metis)
  apply (clarsimp simp: less_eq_downset_def sup_downset_def, transfer, clarsimp)
  apply (blast)
  done

sublocale down_seq_distrib_right: seq_distrib convolute dnil
  apply (standard; transfer; clarsimp)
  apply (safe; clarsimp simp: in_down_iff)
   apply (meson bot_annihilate_seq dual_order.trans flip.mono_f order_refl)
  by blast

sublocale conv_seq_distrib: seq_nondet_distrib convolute dnil
  apply standard
  apply (clarsimp simp: sup_downset_def)
  apply (transfer, clarsimp simp: down_sup_distrib down_union_distrib)
  apply (safe; clarsimp simp: in_down_iff)
  by blast+

sublocale conv_seq_Distrib: seq_Nondet_distrib convolute dnil
  apply standard
  apply (transfer, clarsimp simp: down_sup_distrib down_union_distrib)
  apply (safe; clarsimp simp: in_down_iff)
     apply blast
    apply (meson in_downsetI)
   apply (blast)
  by (meson dual_order.trans preorder_bot_class.bot_least)

end

locale test_seq = seq_elem +
  assumes test_nil:   "range test = (range first - \<down>\<bottom>)" and
          test_atom:  "\<And>x t. x \<le> test t \<Longrightarrow> x \<le> \<bottom> \<or> x \<ge> test t" and
          test_le:    "\<And>x y. test x \<le> test y \<Longrightarrow> x = y" and
          first_le: "x \<le> y \<Longrightarrow> first x \<le> first y" and
          last_first_seq: "last x \<ge> first y \<Longrightarrow> last y \<le> last (x ; y)  "

begin

lemma test_is_first: "\<exists>c. first c = test t"
  by (metis DiffD1 image_iff rangeI test_nil)

lemma test_is_last: "\<exists>c. last c = test t"
  by (metis first_last image_iff rangeI test_is_first)

lemma first_le_test_iff: "(first a) \<le> test t \<longleftrightarrow> a \<le> (test t) ; a "
  by (rule flip.unit_of_unit, rule order_refl)

lemma first_test_last_test_iff: "first (test t) \<le> test t \<longleftrightarrow> last (test t) \<le> test t"
  apply (safe)
   apply (clarsimp simp: unit_of_unit flip.unit_of_unit first_le_test_iff)
  by (clarsimp simp: unit_of_unit flip.unit_of_unit first_le_test_iff)

lemma testE: "(\<And>c. first c = test t \<Longrightarrow> P (first c)) \<Longrightarrow> P (test t)"
  by (insert test_is_first[where t=t], clarsimp)

lemma testE': "(\<And>c. last c = test t \<Longrightarrow> P (last c)) \<Longrightarrow> P (test t)"
  by (insert test_is_last[where t=t], clarsimp)

lemma test_seq_test: "test t \<le> test t ; test t"
  apply (rule testE)
  apply (subst flip.unit_of_unit[where t=t])
   apply (metis flip.down_unit)
  apply (subst assoc)
  apply (rule order_trans[rotated])
   apply (rule mono_f, rule order_refl)
   apply (rule flip.unit_of_apply)
  apply (rule flip.unit_of_apply)
  done

lemma first_test: "x \<le> test t; y \<Longrightarrow> first x \<le> test t"
  apply (frule first_le)
  apply (rule order_trans, assumption)
  apply (subst  first_le_test_iff)
  apply (subst assoc[symmetric])
  apply (rule mono_f)
  apply (rule test_seq_test)
  by (rule order_refl)

lemma insert_bot_nonempty: "S \<noteq> {} \<Longrightarrow> insert \<bottom> (\<Down> S) = \<Down> (S :: 'a :: preorder_bot set)"
  apply (intro set_eqI iffI; clarsimp simp: downset_set_def')
  apply (subgoal_tac "\<exists>x. x \<in> S", clarsimp)
  by blast

lemma first_test_seq: "first (test t; y) \<le> test t"
  using first_test by blast

lift_definition dtest :: "'b set \<Rightarrow> 'a downset"  is "\<lambda>S. \<Down>(test ` S) \<union> \<Down>{\<bottom>}"
  apply (clarsimp)
  by (clarsimp simp: down_sup_distrib down_union_distrib)

lemma set_eqD1: "x \<in> S \<Longrightarrow> S = S' \<Longrightarrow> x \<in> S'"
  by (blast)

lemma no_bot_test: "\<bottom> \<notin> range test "
  by (subst test_nil, clarsimp)

sublocale conv_test_pre: test_sequential_pre convolute dtest
  apply (standard)
  apply (transfer)
       apply (clarsimp simp: Sup_downset_def down_sup_distrib)
  apply (simp add: image_Union)
       apply (intro set_eqI iffI; clarsimp?)
        apply (clarsimp simp: down_image_iff down_sup_distrib)
  apply (clarsimp simp: down_image_iff down_sup_distrib)
       apply (blast)
      apply (rule injI)
      apply (transfer)
      apply (intro set_eqI; clarsimp)
  apply (rule iffI)
      apply (drule_tac x="test xa" in set_eqD1[rotated])
        apply (meson UnCI down_image_iff dual_order.refl)
  apply (clarsimp)
       apply (elim disjE; clarsimp?)
  apply (clarsimp simp: down_image_iff)
  using test_le apply blast
  using test_nil apply auto[1]
  apply (drule sym)
  apply (drule_tac x="test xa" in set_eqD1[rotated])
        apply (meson UnCI down_image_iff dual_order.refl)
  apply (clarsimp)
       apply (elim disjE; clarsimp?)
  apply (clarsimp simp: down_image_iff)
  using test_le apply blast
  using test_nil apply auto[1]
           apply (clarsimp simp: sup_downset_def, transfer)
     apply (simp add: down_union_distrib image_Un)
     apply (clarsimp simp: inf_downset_def, transfer, clarsimp)

     apply (safe; clarsimp?)
          apply (clarsimp simp: inf_downset_def, transfer, clarsimp)
     apply (safe; clarsimp?)
      apply (clarsimp simp: down_image_iff in_down_iff)
      apply (metis)
      apply (clarsimp simp: down_image_iff in_down_iff)
     apply (metis)
      apply (clarsimp simp: down_image_iff in_down_iff)
  apply (metis IntI dual_order.trans test_atom test_le)
         apply (transfer, clarsimp)
        apply (clarsimp simp: less_eq_downset_def, transfer, intro iffI; clarsimp simp: down_image_iff)
   apply blast
  apply (clarsimp simp: subset_iff down_image_iff)
  apply (erule_tac x="test x" in allE)
  by (smt (verit) Diff_iff Un_iff down_image_iff dual_order.refl rangeI subset_eq test_le test_nil test_seq.test_le test_seq_axioms)

lemma nil_dnil: "conv_test_pre.nil= dnil"
  apply (clarsimp simp: conv_test_pre.nil_def, rule antisym; clarsimp simp: less_eq_downset_def dnil_def sup_downset_def)
   apply (transfer)
   apply (subst test_nil)
   apply (clarsimp)
   apply (intro conjI; clarsimp?)
    apply (metis Diff_subset down_image_iff iso_tuple_UNIV_I subset_image_iff)
  apply (meson UNIV_I down_image_iff not_in_down_iff order_trans preorder_bot_class.bot_least)
  apply (transfer; clarsimp)
  apply (safe)
   apply (clarsimp simp: downset_set_def')
   apply (metis Diff_iff bex_imageD dual_order.trans first_last in_down_iff
                range_subsetD subset_image_iff test_nil top.extremum_unique)
  apply (clarsimp simp: down_image_iff)
  by (metis Diff_iff bex_imageD dual_order.trans in_down_iff
                range_subsetD subset_image_iff test_nil top.extremum_unique)

lemma test_inf: "test ` p \<inter> test ` q = test ` (p \<inter> q)"
  apply (safe; clarsimp)
  apply (clarsimp simp: image_iff)
  by (metis Int_iff dual_order.refl test_le)

lemma test_le': "test x ; y \<le> y"
  by (metis flip.down_unit test_is_first)

lemma le_test: "y ; test x \<le> y"
  by (meson down_unit dual_order.trans flip.mono_f test_le' unit_of_apply)

lemma first_test_test: "first (test t) \<le> test t"
  using first_test unit_of_apply by blast

lemma first_test_test': "first (test t) \<ge> test t"
  using flip.unit_of_apply le_test order_trans by blast

lemma last_unit: "x ; last x \<ge> x"
  using unit_of_apply by blast

lemma rewrite_sup_helper: "mono_on UNIV f \<Longrightarrow> (\<Union>a\<in>\<Down>S. \<Union>b\<in>S'. \<down> (f a b)) = (\<Union>a\<in>S. \<Union>b\<in>S'. \<down> (f a b)) "
  apply (safe; clarsimp simp: in_down_iff)
   apply (smt (verit) downset_set_def dual_order.trans le_fun_def mem_Collect_eq monotoneD)
  apply (rule_tac x=a in bexI)
   apply (smt (verit) downset_set_def dual_order.trans le_fun_def mem_Collect_eq monotoneD)
  apply (clarsimp simp: downset_set_def)
  by (fastforce )

lemma nonempty_bot_union: "S \<noteq> {} \<Longrightarrow> \<Down> (S) \<union> \<Down> {\<bottom>} = \<Down>(S :: 'a :: preorder_bot set)"
  by (metis Un_empty_right Un_insert_right down_down
            down_union_distrib test_seq.insert_bot_nonempty
            test_seq_axioms)

lemma nonempty_bot_union': "S \<noteq> {} \<Longrightarrow> \<Down> (S) \<union> \<down>\<bottom> = \<Down>(S :: 'a :: preorder_bot set)"
  apply (safe; clarsimp simp: in_down_iff)
  apply (rule in_downsetI, clarsimp)
  apply (rule_tac x=x in bexI)
  using order_trans preorder_bot_class.bot_least apply blast
  using downset_set_def by blast

sublocale conv_test: test_sequential convolute dtest
  apply (standard)
  using left_neutral nil_dnil  apply presburger
  using right_neutral nil_dnil apply presburger
  using down_seq_distrib_right.Nondet_seq_distrib apply presburger
  using downset_seq_distrib_left.seq_nondet_distrib_weak apply presburger
   apply (simp add: conv_seq_distrib.seq_nondet_distrib)
  apply (rule antisym)
   defer
   apply (simp add: down_seq_distrib_right.seq_mono)
  apply (clarsimp simp: inf_downset_def less_eq_downset_def, transfer)
  apply (case_tac "p = {}", clarsimp)
   apply (clarsimp simp: down_sup_distrib down_union_distrib in_down_iff test_inf Bex_def down_image_iff)
   apply (meson aborting bot_annihilate_seq dual_order.trans flip.mono_f preorder_bot_class.bot_least)
  apply (subst nonempty_bot_union, clarsimp)
  apply (case_tac "q = {}", clarsimp)

   apply (clarsimp simp: down_sup_distrib down_union_distrib in_down_iff test_inf Bex_def down_image_iff)
   apply (meson aborting bot_annihilate_seq dual_order.trans flip.mono_f preorder_bot_class.bot_least)
  apply (subst nonempty_bot_union, clarsimp)
  apply (simp add: rewrite_sup_helper flip.mono_f le_fun_def monotone_onI)
  apply (subst nonempty_bot_union', clarsimp)
  apply (subst nonempty_bot_union', clarsimp)
  apply (clarsimp simp: down_sup_distrib down_union_distrib in_down_iff test_inf Bex_def down_image_iff)
  by (meson first_test flip.unit_of_apply in_downsetI test_le')

sublocale conv_assert: assertions convolute dtest ..

lemma down_bot_seq_bot[simp]: " (\<down> (\<bottom> ; x)) = (\<down> \<bottom>)"
  apply (safe; clarsimp simp: in_down_iff)
  using bot_annihilate_seq dual_order.trans by blast

lemma mono_seq_down:"(\<Union>x\<in>\<down> (a). (\<Union>x\<in>\<down> ((seq :: 'a \<Rightarrow> 'a \<Rightarrow> 'a) b x). f a b x)) = (\<Union>x\<in>\<down> (seq b a). f a b x)"
  apply (safe; clarsimp)
  apply (meson dual_order.trans order_refl in_down_iff mono_f)
  by (meson order_refl in_down_iff)

lemma mono_seq_down':"(\<Union>x\<in>\<down> (a). (\<Union>x\<in>\<down> ((seq :: 'a \<Rightarrow> 'a \<Rightarrow> 'a) x b). f a b x)) = (\<Union>x\<in>\<down> (seq a b). f a b x)"
  apply (safe; clarsimp)
   apply (meson dual_order.trans order_refl in_down_iff mono_f)
  using in_down_iff by blast

lemma sup_down_sup:"(\<Union>x\<in>\<down> (c). \<Union>y\<in>x'. \<down> (x ; y)) = (\<Union>y\<in>x'. \<down>(c ; y))"
  apply (safe; clarsimp simp: in_down_iff Bex_def)
   apply (meson dual_order.trans order_refl mono_f)
  by blast

end

end


theory prop_21
imports Main
        "../../TestTheories/Listi"
        "../../TestTheories/Naturals"
        "$HIPSTER_HOME/IsaHipster"

begin

hipster take leq len
lemma lemma_a [thy_expl]: "leq x2 x2 = True"
by (hipster_induct_schemes take.simps Naturals.leq.simps len.simps)

lemma lemma_aa [thy_expl]: "take x1 NL.Nil = NL.Nil"
by (hipster_induct_schemes take.simps Naturals.leq.simps len.simps)

lemma lemma_ab [thy_expl]: "take x2 (take x2 y2) = take x2 y2"
by (hipster_induct_schemes take.simps Naturals.leq.simps len.simps)

lemma lemma_ac [thy_expl]: "leq x2 (S x2) = True"
by (hipster_induct_schemes take.simps Naturals.leq.simps len.simps)

lemma lemma_ad [thy_expl]: "take (len x2) x2 = x2"
by (hipster_induct_schemes take.simps Naturals.leq.simps len.simps)

lemma lemma_ae [thy_expl]: "leq (S x2) x2 = False"
by (hipster_induct_schemes take.simps Naturals.leq.simps len.simps)

lemma lemma_af [thy_expl]: "take (len x16) (take y16 x16) = take y16 x16"
by (hipster_induct_schemes take.simps Naturals.leq.simps len.simps)

lemma lemma_ag [thy_expl]: "take (S x2) (take x2 y2) = take x2 y2"
by (hipster_induct_schemes take.simps Naturals.leq.simps len.simps)

lemma unknown [thy_expl]: "take x (take y z) = take y (take x z)"
oops

hipster_cond leq len take

theorem takeMore: "leq (len ts) n \<Longrightarrow> take n ts = ts"
by (hipster_induct_schemes leq.simps len.simps Nat.exhaust list.exhaust drop.simps)

end


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

datatype Nat = Z | S "Nat"

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

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

theorem property0 :
  "((add3 (add3 x1 x2 x3) x4 x5) = (add3 x1 (add3 x2 x3 x4) x5))"
  oops

end


section\<open>Renaming of variables in internalized formulas\<close>

theory Renaming
  imports
    "ZF-Constructible.Formula"
    ZF_Miscellanea
begin

subsection\<open>Renaming of free variables\<close>

definition
  union_fun :: "[i,i,i,i] \<Rightarrow> i" where
  "union_fun(f,g,m,p) \<equiv> \<lambda>j \<in> m \<union> p  . if j\<in>m then f`j else g`j"

lemma union_fun_type:
  assumes "f \<in> m \<rightarrow> n"
    "g \<in> p \<rightarrow> q"
  shows "union_fun(f,g,m,p) \<in> m \<union> p \<rightarrow> n \<union> q"
proof -
  let ?h="union_fun(f,g,m,p)"
  have
    D: "?h`x \<in> n \<union> q" if "x \<in> m \<union> p" for x
  proof (cases "x \<in> m")
    case True
    then have
      "x \<in> m \<union> p" by simp
    with \<open>x\<in>m\<close>
    have "?h`x = f`x"
      unfolding union_fun_def  beta by simp
    with \<open>f \<in> m \<rightarrow> n\<close> \<open>x\<in>m\<close>
    have "?h`x \<in> n" by simp
    then show ?thesis ..
  next
    case False
    with \<open>x \<in> m \<union> p\<close>
    have "x \<in> p"
      by auto
    with \<open>x\<notin>m\<close>
    have "?h`x = g`x"
      unfolding union_fun_def using beta by simp
    with \<open>g \<in> p \<rightarrow> q\<close> \<open>x\<in>p\<close>
    have "?h`x \<in> q" by simp
    then show ?thesis ..
  qed
  have A:"function(?h)" unfolding union_fun_def using function_lam by simp
  have " x\<in> (m \<union> p) \<times> (n \<union> q)" if "x\<in> ?h" for x
    using that lamE[of x "m \<union> p" _ "x \<in> (m \<union> p) \<times> (n \<union> q)"] D unfolding union_fun_def
    by auto
  then have B:"?h \<subseteq> (m \<union> p) \<times> (n \<union> q)" ..
  have "m \<union> p \<subseteq> domain(?h)"
    unfolding union_fun_def using domain_lam by simp
  with A B
  show ?thesis using  Pi_iff [THEN iffD2] by simp
qed

lemma union_fun_action :
  assumes
    "env \<in> list(M)"
    "env' \<in> list(M)"
    "length(env) = m \<union> p"
    "\<forall> i . i \<in> m \<longrightarrow>  nth(f`i,env') = nth(i,env)"
    "\<forall> j . j \<in> p \<longrightarrow> nth(g`j,env') = nth(j,env)"
  shows "\<forall> i . i \<in> m \<union> p \<longrightarrow>
          nth(i,env) = nth(union_fun(f,g,m,p)`i,env')"
proof -
  let ?h = "union_fun(f,g,m,p)"
  have "nth(x, env) = nth(?h`x,env')" if "x \<in> m \<union> p" for x
    using that
  proof (cases "x\<in>m")
    case True
    with \<open>x\<in>m\<close>
    have "?h`x = f`x"
      unfolding union_fun_def  beta by simp
    with assms \<open>x\<in>m\<close>
    have "nth(x,env) = nth(?h`x,env')" by simp
    then show ?thesis .
  next
    case False
    with \<open>x \<in> m \<union> p\<close>
    have
      "x \<in> p" "x\<notin>m"  by auto
    then
    have "?h`x = g`x"
      unfolding union_fun_def beta by simp
    with assms \<open>x\<in>p\<close>
    have "nth(x,env) = nth(?h`x,env')" by simp
    then show ?thesis .
  qed
  then show ?thesis by simp
qed

lemma id_fn_type :
  assumes "n \<in> nat"
  shows "id(n) \<in> n \<rightarrow> n"
  unfolding id_def using \<open>n\<in>nat\<close> by simp

lemma id_fn_action:
  assumes "n \<in> nat" "env\<in>list(M)"
  shows "\<And> j . j < n \<Longrightarrow> nth(j,env) = nth(id(n)`j,env)"
proof -
  show "nth(j,env) = nth(id(n)`j,env)" if "j < n" for j using that \<open>n\<in>nat\<close> ltD by simp
qed

definition
  rsum :: "[i,i,i,i,i] \<Rightarrow> i" where
  "rsum(f,g,m,n,p) \<equiv> \<lambda>j \<in> m+\<^sub>\<omega>p  . if j<m then f`j else (g`(j#-m))+\<^sub>\<omega>n"

lemma sum_inl:
  assumes "m \<in> nat" "n\<in>nat"
    "f \<in> m\<rightarrow>n" "x \<in> m"
  shows "rsum(f,g,m,n,p)`x = f`x"
proof -
  from \<open>m\<in>nat\<close>
  have "m\<le>m+\<^sub>\<omega>p"
    using add_le_self[of m] by simp
  with assms
  have "x\<in>m+\<^sub>\<omega>p"
    using ltI[of x m] lt_trans2[of x m "m+\<^sub>\<omega>p"] ltD by simp
  from assms
  have "x<m"
    using ltI by simp
  with \<open>x\<in>m+\<^sub>\<omega>p\<close>
  show ?thesis unfolding rsum_def by simp
qed

lemma sum_inr:
  assumes "m \<in> nat" "n\<in>nat" "p\<in>nat"
    "g\<in>p\<rightarrow>q" "m \<le> x" "x < m+\<^sub>\<omega>p"
  shows "rsum(f,g,m,n,p)`x = g`(x#-m)+\<^sub>\<omega>n"
proof -
  from assms
  have "x\<in>nat"
    using in_n_in_nat[of "m+\<^sub>\<omega>p"] ltD
    by simp
  with assms
  have "\<not> x<m"
    using not_lt_iff_le[THEN iffD2] by simp
  from assms
  have "x\<in>m+\<^sub>\<omega>p"
    using ltD by simp
  with \<open>\<not> x<m\<close>
  show ?thesis unfolding rsum_def by simp
qed

lemma sum_action :
  assumes "m \<in> nat" "n\<in>nat" "p\<in>nat" "q\<in>nat"
    "f \<in> m\<rightarrow>n" "g\<in>p\<rightarrow>q"
    "env \<in> list(M)"
    "env' \<in> list(M)"
    "env1 \<in> list(M)"
    "env2 \<in> list(M)"
    "length(env) = m"
    "length(env1) = p"
    "length(env') = n"
    "\<And> i . i < m \<Longrightarrow> nth(i,env) = nth(f`i,env')"
    "\<And> j. j < p \<Longrightarrow> nth(j,env1) = nth(g`j,env2)"
  shows "\<forall> i . i < m+\<^sub>\<omega>p \<longrightarrow>
          nth(i,env@env1) = nth(rsum(f,g,m,n,p)`i,env'@env2)"
proof -
  let ?h = "rsum(f,g,m,n,p)"
  from \<open>m\<in>nat\<close> \<open>n\<in>nat\<close> \<open>q\<in>nat\<close>
  have "m\<le>m+\<^sub>\<omega>p" "n\<le>n+\<^sub>\<omega>q" "q\<le>n+\<^sub>\<omega>q"
    using add_le_self[of m]  add_le_self2[of n q] by simp_all
  from \<open>p\<in>nat\<close>
  have "p = (m+\<^sub>\<omega>p)#-m" using diff_add_inverse2 by simp
  have "nth(x, env @ env1) = nth(?h`x,env'@env2)" if "x<m+\<^sub>\<omega>p" for x
  proof (cases "x<m")
    case True
    then
    have 2: "?h`x= f`x" "x\<in>m" "f`x \<in> n" "x\<in>nat"
      using assms sum_inl ltD apply_type[of f m _ x] in_n_in_nat by simp_all
    with \<open>x<m\<close> assms
    have "f`x < n" "f`x<length(env')"  "f`x\<in>nat"
      using ltI in_n_in_nat by simp_all
    with 2 \<open>x<m\<close> assms
    have "nth(x,env@env1) = nth(x,env)"
      using nth_append[OF \<open>env\<in>list(M)\<close>] \<open>x\<in>nat\<close> by simp
    also
    have
      "... = nth(f`x,env')"
      using 2 \<open>x<m\<close> assms by simp
    also
    have "... = nth(f`x,env'@env2)"
      using nth_append[OF \<open>env'\<in>list(M)\<close>] \<open>f`x<length(env')\<close> \<open>f`x \<in>nat\<close> by simp
    also
    have "... = nth(?h`x,env'@env2)"
      using 2 by simp
    finally
    have "nth(x, env @ env1) = nth(?h`x,env'@env2)" .
    then show ?thesis .
  next
    case False
    have "x\<in>nat"
      using that in_n_in_nat[of "m+\<^sub>\<omega>p" x] ltD \<open>p\<in>nat\<close> \<open>m\<in>nat\<close> by simp
    with \<open>length(env) = m\<close>
    have "m\<le>x" "length(env) \<le> x"
      using not_lt_iff_le \<open>m\<in>nat\<close> \<open>\<not>x<m\<close> by simp_all
    with \<open>\<not>x<m\<close> \<open>length(env) = m\<close>
    have 2 : "?h`x= g`(x#-m)+\<^sub>\<omega>n"  "\<not> x <length(env)"
      unfolding rsum_def
      using  sum_inr that beta ltD by simp_all
    from assms \<open>x\<in>nat\<close> \<open>p=m+\<^sub>\<omega>p#-m\<close>
    have "x#-m < p"
      using diff_mono[OF _ _ _ \<open>x<m+\<^sub>\<omega>p\<close> \<open>m\<le>x\<close>] by simp
    then have "x#-m\<in>p" using ltD by simp
    with \<open>g\<in>p\<rightarrow>q\<close>
    have "g`(x#-m) \<in> q"  by simp
    with \<open>q\<in>nat\<close> \<open>length(env') = n\<close>
    have "g`(x#-m) < q" "g`(x#-m)\<in>nat" using ltI in_n_in_nat by simp_all
    with \<open>q\<in>nat\<close> \<open>n\<in>nat\<close>
    have "(g`(x#-m))+\<^sub>\<omega>n <n+\<^sub>\<omega>q" "n \<le> g`(x#-m)+\<^sub>\<omega>n" "\<not> g`(x#-m)+\<^sub>\<omega>n < length(env')"
      using add_lt_mono1[of "g`(x#-m)" _ n,OF _ \<open>q\<in>nat\<close>]
        add_le_self2[of n] \<open>length(env') = n\<close>
      by simp_all
    from assms \<open>\<not> x < length(env)\<close> \<open>length(env) = m\<close>
    have "nth(x,env @ env1) = nth(x#-m,env1)"
      using nth_append[OF \<open>env\<in>list(M)\<close> \<open>x\<in>nat\<close>] by simp
    also
    have "... = nth(g`(x#-m),env2)"
      using assms \<open>x#-m < p\<close> by simp
    also
    have "... = nth((g`(x#-m)+\<^sub>\<omega>n)#-length(env'),env2)"
      using  \<open>length(env') = n\<close>
        diff_add_inverse2 \<open>g`(x#-m)\<in>nat\<close>
      by simp
    also
    have "... = nth((g`(x#-m)+\<^sub>\<omega>n),env'@env2)"
      using  nth_append[OF \<open>env'\<in>list(M)\<close>] \<open>n\<in>nat\<close> \<open>\<not> g`(x#-m)+\<^sub>\<omega>n < length(env')\<close>
      by simp
    also
    have "... = nth(?h`x,env'@env2)"
      using 2 by simp
    finally
    have "nth(x, env @ env1) = nth(?h`x,env'@env2)" .
    then show ?thesis .
  qed
  then show ?thesis by simp
qed

lemma sum_type  :
  assumes "m \<in> nat" "n\<in>nat" "p\<in>nat" "q\<in>nat"
    "f \<in> m\<rightarrow>n" "g\<in>p\<rightarrow>q"
  shows "rsum(f,g,m,n,p) \<in> (m+\<^sub>\<omega>p) \<rightarrow> (n+\<^sub>\<omega>q)"
proof -
  let ?h = "rsum(f,g,m,n,p)"
  from \<open>m\<in>nat\<close> \<open>n\<in>nat\<close> \<open>q\<in>nat\<close>
  have "m\<le>m+\<^sub>\<omega>p" "n\<le>n+\<^sub>\<omega>q" "q\<le>n+\<^sub>\<omega>q"
    using add_le_self[of m]  add_le_self2[of n q] by simp_all
  from \<open>p\<in>nat\<close>
  have "p = (m+\<^sub>\<omega>p)#-m" using diff_add_inverse2 by simp
  {fix x
    assume 1: "x\<in>m+\<^sub>\<omega>p" "x<m"
    with 1 have "?h`x= f`x" "x\<in>m"
      using assms sum_inl ltD by simp_all
    with \<open>f\<in>m\<rightarrow>n\<close>
    have "?h`x \<in> n" by simp
    with \<open>n\<in>nat\<close> have "?h`x < n" using ltI by simp
    with \<open>n\<le>n+\<^sub>\<omega>q\<close>
    have "?h`x < n+\<^sub>\<omega>q" using lt_trans2 by simp
    then
    have "?h`x \<in> n+\<^sub>\<omega>q"  using ltD by simp
  }
  then have 1:"?h`x \<in> n+\<^sub>\<omega>q" if "x\<in>m+\<^sub>\<omega>p" "x<m" for x using that .
  {fix x
    assume 1: "x\<in>m+\<^sub>\<omega>p" "m\<le>x"
    then have "x<m+\<^sub>\<omega>p" "x\<in>nat" using ltI in_n_in_nat[of "m+\<^sub>\<omega>p"] ltD by simp_all
    with 1
    have 2 : "?h`x= g`(x#-m)+\<^sub>\<omega>n"
      using assms sum_inr ltD by simp_all
    from assms \<open>x\<in>nat\<close> \<open>p=m+\<^sub>\<omega>p#-m\<close>
    have "x#-m < p" using diff_mono[OF _ _ _ \<open>x<m+\<^sub>\<omega>p\<close> \<open>m\<le>x\<close>] by simp
    then have "x#-m\<in>p" using ltD by simp
    with \<open>g\<in>p\<rightarrow>q\<close>
    have "g`(x#-m) \<in> q"  by simp
    with \<open>q\<in>nat\<close> have "g`(x#-m) < q" using ltI by simp
    with \<open>q\<in>nat\<close>
    have "(g`(x#-m))+\<^sub>\<omega>n <n+\<^sub>\<omega>q" using add_lt_mono1[of "g`(x#-m)" _ n,OF _ \<open>q\<in>nat\<close>] by simp
    with 2
    have "?h`x \<in> n+\<^sub>\<omega>q"  using ltD by simp
  }
  then have 2:"?h`x \<in> n+\<^sub>\<omega>q" if "x\<in>m+\<^sub>\<omega>p" "m\<le>x" for x using that .
  have
    D: "?h`x \<in> n+\<^sub>\<omega>q" if "x\<in>m+\<^sub>\<omega>p" for x
    using that
  proof (cases "x<m")
    case True
    then show ?thesis using 1 that by simp
  next
    case False
    with \<open>m\<in>nat\<close> have "m\<le>x" using not_lt_iff_le that in_n_in_nat[of "m+\<^sub>\<omega>p"] by simp
    then show ?thesis using 2 that by simp
  qed
  have A:"function(?h)" unfolding rsum_def using function_lam by simp
  have " x\<in> (m +\<^sub>\<omega> p) \<times> (n +\<^sub>\<omega> q)" if "x\<in> ?h" for x
    using that lamE[of x "m+\<^sub>\<omega>p" _ "x \<in> (m +\<^sub>\<omega> p) \<times> (n +\<^sub>\<omega> q)"] D unfolding rsum_def
    by auto
  then have B:"?h \<subseteq> (m +\<^sub>\<omega> p) \<times> (n +\<^sub>\<omega> q)" ..
  have "m +\<^sub>\<omega> p \<subseteq> domain(?h)"
    unfolding rsum_def using domain_lam by simp
  with A B
  show ?thesis using  Pi_iff [THEN iffD2] by simp
qed

lemma sum_type_id :
  assumes
    "f \<in> length(env)\<rightarrow>length(env')"
    "env \<in> list(M)"
    "env' \<in> list(M)"
    "env1 \<in> list(M)"
  shows
    "rsum(f,id(length(env1)),length(env),length(env'),length(env1)) \<in>
        (length(env)+\<^sub>\<omega>length(env1)) \<rightarrow> (length(env')+\<^sub>\<omega>length(env1))"
  using assms length_type id_fn_type sum_type
  by simp

lemma sum_type_id_aux2 :
  assumes
    "f \<in> m\<rightarrow>n"
    "m \<in> nat" "n \<in> nat"
    "env1 \<in> list(M)"
  shows
    "rsum(f,id(length(env1)),m,n,length(env1)) \<in>
        (m+\<^sub>\<omega>length(env1)) \<rightarrow> (n+\<^sub>\<omega>length(env1))"
  using assms id_fn_type sum_type
  by auto

lemma sum_action_id :
  assumes
    "env \<in> list(M)"
    "env' \<in> list(M)"
    "f \<in> length(env)\<rightarrow>length(env')"
    "env1 \<in> list(M)"
    "\<And> i . i < length(env) \<Longrightarrow> nth(i,env) = nth(f`i,env')"
  shows "\<And> i . i < length(env)+\<^sub>\<omega>length(env1) \<Longrightarrow>
          nth(i,env@env1) = nth(rsum(f,id(length(env1)),length(env),length(env'),length(env1))`i,env'@env1)"
proof -
  from assms
  have "length(env)\<in>nat" (is "?m \<in> _") by simp
  from assms have "length(env')\<in>nat" (is "?n \<in> _") by simp
  from assms have "length(env1)\<in>nat" (is "?p \<in> _") by simp
  note lenv = id_fn_action[OF \<open>?p\<in>nat\<close> \<open>env1\<in>list(M)\<close>]
  note lenv_ty = id_fn_type[OF \<open>?p\<in>nat\<close>]
  {
    fix i
    assume "i < length(env)+\<^sub>\<omega>length(env1)"
    have "nth(i,env@env1) = nth(rsum(f,id(length(env1)),?m,?n,?p)`i,env'@env1)"
      using sum_action[OF \<open>?m\<in>nat\<close> \<open>?n\<in>nat\<close> \<open>?p\<in>nat\<close> \<open>?p\<in>nat\<close> \<open>f\<in>?m\<rightarrow>?n\<close>
          lenv_ty \<open>env\<in>list(M)\<close> \<open>env'\<in>list(M)\<close>
          \<open>env1\<in>list(M)\<close> \<open>env1\<in>list(M)\<close> _
          _ _  assms(5) lenv
          ] \<open>i<?m+\<^sub>\<omega>length(env1)\<close> by simp
  }
  then show "\<And> i . i < ?m+\<^sub>\<omega>length(env1) \<Longrightarrow>
          nth(i,env@env1) = nth(rsum(f,id(?p),?m,?n,?p)`i,env'@env1)" by simp
qed

lemma sum_action_id_aux :
  assumes
    "f \<in> m\<rightarrow>n"
    "env \<in> list(M)"
    "env' \<in> list(M)"
    "env1 \<in> list(M)"
    "length(env) = m"
    "length(env') = n"
    "length(env1) = p"
    "\<And> i . i < m \<Longrightarrow> nth(i,env) = nth(f`i,env')"
  shows "\<And> i . i < m+\<^sub>\<omega>length(env1) \<Longrightarrow>
          nth(i,env@env1) = nth(rsum(f,id(length(env1)),m,n,length(env1))`i,env'@env1)"
  using assms length_type id_fn_type sum_action_id
  by auto

definition
  sum_id :: "[i,i] \<Rightarrow> i" where
  "sum_id(m,f) \<equiv> rsum(\<lambda>x\<in>1.x,f,1,1,m)"

lemma sum_id0 : "m\<in>nat\<Longrightarrow>sum_id(m,f)`0 = 0"
  by(unfold sum_id_def,subst sum_inl,auto)

lemma sum_idS : "p\<in>nat \<Longrightarrow> q\<in>nat \<Longrightarrow> f\<in>p\<rightarrow>q \<Longrightarrow> x \<in> p \<Longrightarrow> sum_id(p,f)`(succ(x)) = succ(f`x)"
  by(subgoal_tac "x\<in>nat",unfold sum_id_def,subst sum_inr,
      simp_all add:ltI,simp_all add: app_nm in_n_in_nat)

lemma sum_id_tc_aux :
  "p \<in> nat \<Longrightarrow>  q \<in> nat \<Longrightarrow> f \<in> p \<rightarrow> q \<Longrightarrow> sum_id(p,f) \<in> 1+\<^sub>\<omega>p \<rightarrow> 1+\<^sub>\<omega>q"
  by (unfold sum_id_def,rule sum_type,simp_all)

lemma sum_id_tc :
  "n \<in> nat \<Longrightarrow> m \<in> nat \<Longrightarrow> f \<in> n \<rightarrow> m \<Longrightarrow> sum_id(n,f) \<in> succ(n) \<rightarrow> succ(m)"
  by(rule ssubst[of  "succ(n) \<rightarrow> succ(m)" "1+\<^sub>\<omega>n \<rightarrow> 1+\<^sub>\<omega>m"],
      simp,rule sum_id_tc_aux,simp_all)

subsection\<open>Renaming of formulas\<close>

consts   ren :: "i\<Rightarrow>i"
primrec
  "ren(Member(x,y)) =
      (\<lambda> n \<in> nat . \<lambda> m \<in> nat. \<lambda>f \<in> n \<rightarrow> m. Member (f`x, f`y))"

"ren(Equal(x,y)) =
      (\<lambda> n \<in> nat . \<lambda> m \<in> nat. \<lambda>f \<in> n \<rightarrow> m. Equal (f`x, f`y))"

"ren(Nand(p,q)) =
      (\<lambda> n \<in> nat . \<lambda> m \<in> nat. \<lambda>f \<in> n \<rightarrow> m. Nand (ren(p)`n`m`f, ren(q)`n`m`f))"

"ren(Forall(p)) =
      (\<lambda> n \<in> nat . \<lambda> m \<in> nat. \<lambda>f \<in> n \<rightarrow> m. Forall (ren(p)`succ(n)`succ(m)`sum_id(n,f)))"

lemma arity_meml : "l \<in> nat \<Longrightarrow> Member(x,y) \<in> formula \<Longrightarrow> arity(Member(x,y)) \<le> l \<Longrightarrow> x \<in> l"
  by(simp,rule subsetD,rule le_imp_subset,assumption,simp)
lemma arity_memr : "l \<in> nat \<Longrightarrow> Member(x,y) \<in> formula \<Longrightarrow> arity(Member(x,y)) \<le> l \<Longrightarrow> y \<in> l"
  by(simp,rule subsetD,rule le_imp_subset,assumption,simp)
lemma arity_eql : "l \<in> nat \<Longrightarrow> Equal(x,y) \<in> formula \<Longrightarrow> arity(Equal(x,y)) \<le> l \<Longrightarrow> x \<in> l"
  by(simp,rule subsetD,rule le_imp_subset,assumption,simp)
lemma arity_eqr : "l \<in> nat \<Longrightarrow> Equal(x,y) \<in> formula \<Longrightarrow> arity(Equal(x,y)) \<le> l \<Longrightarrow> y \<in> l"
  by(simp,rule subsetD,rule le_imp_subset,assumption,simp)
lemma  nand_ar1 : "p \<in> formula \<Longrightarrow> q\<in>formula \<Longrightarrow>arity(p) \<le> arity(Nand(p,q))"
  by (simp,rule Un_upper1_le,simp+)
lemma nand_ar2 : "p \<in> formula \<Longrightarrow> q\<in>formula \<Longrightarrow>arity(q) \<le> arity(Nand(p,q))"
  by (simp,rule Un_upper2_le,simp+)

lemma nand_ar1D : "p \<in> formula \<Longrightarrow> q\<in>formula \<Longrightarrow> arity(Nand(p,q)) \<le> n \<Longrightarrow> arity(p) \<le> n"
  by(auto simp add:  le_trans[OF Un_upper1_le[of "arity(p)" "arity(q)"]])
lemma nand_ar2D : "p \<in> formula \<Longrightarrow> q\<in>formula \<Longrightarrow> arity(Nand(p,q)) \<le> n \<Longrightarrow> arity(q) \<le> n"
  by(auto simp add:  le_trans[OF Un_upper2_le[of "arity(p)" "arity(q)"]])

lemma ren_tc : "p \<in> formula \<Longrightarrow>
  (\<And> n m f . n \<in> nat \<Longrightarrow> m \<in> nat \<Longrightarrow> f \<in> n\<rightarrow>m \<Longrightarrow>  ren(p)`n`m`f \<in> formula)"
  by (induct set:formula,auto simp add: app_nm sum_id_tc)

lemma arity_ren :
  fixes "p"
  assumes "p \<in> formula"
  shows "\<And> n m f . n \<in> nat \<Longrightarrow> m \<in> nat \<Longrightarrow> f \<in> n\<rightarrow>m \<Longrightarrow> arity(p) \<le> n \<Longrightarrow> arity(ren(p)`n`m`f)\<le>m"
  using assms
proof (induct set:formula)
  case (Member x y)
  then have "f`x \<in> m" "f`y \<in> m"
    using Member assms by (simp add: arity_meml apply_funtype,simp add:arity_memr apply_funtype)
  then show ?case using Member by (simp add: Un_least_lt ltI)
next
  case (Equal x y)
  then have "f`x \<in> m" "f`y \<in> m"
    using Equal assms by (simp add: arity_eql apply_funtype,simp add:arity_eqr apply_funtype)
  then show ?case using Equal by (simp add: Un_least_lt ltI)
next
  case (Nand p q)
  then have "arity(p)\<le>arity(Nand(p,q))"
    "arity(q)\<le>arity(Nand(p,q))"
    by (subst  nand_ar1,simp,simp,simp,subst nand_ar2,simp+)
  then have "arity(p)\<le>n"
    and "arity(q)\<le>n" using Nand
    by (rule_tac j="arity(Nand(p,q))" in le_trans,simp,simp)+
  then have "arity(ren(p)`n`m`f) \<le> m" and  "arity(ren(q)`n`m`f) \<le> m"
    using Nand by auto
  then show ?case using Nand by (simp add:Un_least_lt)
next
  case (Forall p)
  from Forall have "succ(n)\<in>nat"  "succ(m)\<in>nat" by auto
  from Forall have 2: "sum_id(n,f) \<in> succ(n)\<rightarrow>succ(m)" by (simp add:sum_id_tc)
  from Forall have 3:"arity(p) \<le> succ(n)" by (rule_tac n="arity(p)" in natE,simp+)
  then have "arity(ren(p)`succ(n)`succ(m)`sum_id(n,f))\<le>succ(m)" using
      Forall \<open>succ(n)\<in>nat\<close> \<open>succ(m)\<in>nat\<close> 2 by force
  then show ?case using Forall 2 3 ren_tc arity_type pred_le by auto
qed

lemma arity_forallE : "p \<in> formula \<Longrightarrow> m \<in> nat \<Longrightarrow> arity(Forall(p)) \<le> m \<Longrightarrow> arity(p) \<le> succ(m)"
  by(rule_tac n="arity(p)" in natE,erule arity_type,simp+)

lemma env_coincidence_sum_id :
  assumes "m \<in> nat" "n \<in> nat"
    "\<rho> \<in> list(A)" "\<rho>' \<in> list(A)"
    "f \<in> n \<rightarrow> m"
    "\<And> i . i < n \<Longrightarrow> nth(i,\<rho>) = nth(f`i,\<rho>')"
    "a \<in> A" "j \<in> succ(n)"
  shows "nth(j,Cons(a,\<rho>)) = nth(sum_id(n,f)`j,Cons(a,\<rho>'))"
proof -
  let ?g="sum_id(n,f)"
  have "succ(n) \<in> nat" using \<open>n\<in>nat\<close> by simp
  then have "j \<in> nat" using \<open>j\<in>succ(n)\<close> in_n_in_nat by blast
  then have "nth(j,Cons(a,\<rho>)) = nth(?g`j,Cons(a,\<rho>'))"
  proof (cases rule:natE[OF \<open>j\<in>nat\<close>])
    case 1
    then show ?thesis using assms sum_id0 by simp
  next
    case (2 i)
    with \<open>j\<in>succ(n)\<close> have "succ(i)\<in>succ(n)" by simp
    with \<open>n\<in>nat\<close> have "i \<in> n" using nat_succD assms by simp
    have "f`i\<in>m" using \<open>f\<in>n\<rightarrow>m\<close> apply_type \<open>i\<in>n\<close> by simp
    then have "f`i \<in> nat" using in_n_in_nat \<open>m\<in>nat\<close> by simp
    have "nth(succ(i),Cons(a,\<rho>)) = nth(i,\<rho>)" using \<open>i\<in>nat\<close> by simp
    also have "... = nth(f`i,\<rho>')" using assms \<open>i\<in>n\<close> ltI by simp
    also have "... = nth(succ(f`i),Cons(a,\<rho>'))" using \<open>f`i\<in>nat\<close> by simp
    also have "... = nth(?g`succ(i),Cons(a,\<rho>'))"
      using assms sum_idS[OF \<open>n\<in>nat\<close> \<open>m\<in>nat\<close>  \<open>f\<in>n\<rightarrow>m\<close> \<open>i \<in> n\<close>] cases by simp
    finally have "nth(succ(i),Cons(a,\<rho>)) = nth(?g`succ(i),Cons(a,\<rho>'))" .
    then show ?thesis using \<open>j=succ(i)\<close> by simp
  qed
  then show ?thesis .
qed

lemma sats_iff_sats_ren :
  assumes "\<phi> \<in> formula"
  shows  "\<lbrakk>  n \<in> nat ; m \<in> nat ; \<rho> \<in> list(M) ; \<rho>' \<in> list(M) ; f \<in> n \<rightarrow> m ;
            arity(\<phi>) \<le> n ;
            \<And> i . i < n \<Longrightarrow> nth(i,\<rho>) = nth(f`i,\<rho>') \<rbrakk> \<Longrightarrow>
         sats(M,\<phi>,\<rho>) \<longleftrightarrow> sats(M,ren(\<phi>)`n`m`f,\<rho>')"
  using \<open>\<phi> \<in> formula\<close>
proof(induct \<phi> arbitrary:n m \<rho> \<rho>' f)
  case (Member x y)
  have "ren(Member(x,y))`n`m`f = Member(f`x,f`y)" using Member assms arity_type by force
  moreover
  have "x \<in> n" using Member arity_meml by simp
  moreover
  have "y \<in> n" using Member arity_memr by simp
  ultimately
  show ?case using Member ltI by simp
next
  case (Equal x y)
  have "ren(Equal(x,y))`n`m`f = Equal(f`x,f`y)" using Equal assms arity_type by force
  moreover
  have "x \<in> n" using Equal arity_eql by simp
  moreover
  have "y \<in> n" using Equal arity_eqr by simp
  ultimately show ?case using Equal ltI by simp
next
  case (Nand p q)
  have "ren(Nand(p,q))`n`m`f = Nand(ren(p)`n`m`f,ren(q)`n`m`f)" using Nand by simp
  moreover
  have "arity(p) \<le> n" using Nand nand_ar1D by simp
  moreover from this
  have "i \<in> arity(p) \<Longrightarrow> i \<in> n" for i using subsetD[OF le_imp_subset[OF \<open>arity(p) \<le> n\<close>]] by simp
  moreover from this
  have "i \<in> arity(p) \<Longrightarrow> nth(i,\<rho>) = nth(f`i,\<rho>')" for i using Nand ltI by simp
  moreover from this
  have "sats(M,p,\<rho>) \<longleftrightarrow> sats(M,ren(p)`n`m`f,\<rho>')" using \<open>arity(p)\<le>n\<close> Nand by simp
  have "arity(q) \<le> n" using Nand nand_ar2D by simp
  moreover from this
  have "i \<in> arity(q) \<Longrightarrow> i \<in> n" for i using subsetD[OF le_imp_subset[OF \<open>arity(q) \<le> n\<close>]] by simp
  moreover from this
  have "i \<in> arity(q) \<Longrightarrow> nth(i,\<rho>) = nth(f`i,\<rho>')" for i using Nand ltI by simp
  moreover from this
  have "sats(M,q,\<rho>) \<longleftrightarrow> sats(M,ren(q)`n`m`f,\<rho>')" using assms \<open>arity(q)\<le>n\<close> Nand by simp
  ultimately
  show ?case using Nand by simp
next
  case (Forall p)
  have 0:"ren(Forall(p))`n`m`f = Forall(ren(p)`succ(n)`succ(m)`sum_id(n,f))"
    using Forall by simp
  have 1:"sum_id(n,f) \<in> succ(n) \<rightarrow> succ(m)" (is "?g \<in> _") using sum_id_tc Forall by simp
  then have 2: "arity(p) \<le> succ(n)"
    using Forall le_trans[of _ "succ(pred(arity(p)))"] succpred_leI by simp
  have "succ(n)\<in>nat" "succ(m)\<in>nat" using Forall by auto
  then have A:"\<And> j .j < succ(n) \<Longrightarrow> nth(j, Cons(a, \<rho>)) = nth(?g`j, Cons(a, \<rho>'))" if "a\<in>M" for a
    using that env_coincidence_sum_id Forall ltD by force
  have
    "sats(M,p,Cons(a,\<rho>)) \<longleftrightarrow> sats(M,ren(p)`succ(n)`succ(m)`?g,Cons(a,\<rho>'))" if "a\<in>M" for a
  proof -
    have C:"Cons(a,\<rho>) \<in> list(M)" "Cons(a,\<rho>')\<in>list(M)" using Forall that by auto
    have "sats(M,p,Cons(a,\<rho>)) \<longleftrightarrow> sats(M,ren(p)`succ(n)`succ(m)`?g,Cons(a,\<rho>'))"
      using Forall(2)[OF \<open>succ(n)\<in>nat\<close> \<open>succ(m)\<in>nat\<close> C(1) C(2) 1 2 A[OF \<open>a\<in>M\<close>]] by simp
    then show ?thesis .
  qed
  then show ?case using Forall 0 1 2 by simp
qed

end