(*  Title:      HOL/Metis_Examples/Sets.thy
    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    Author:     Jasmin Blanchette, TU Muenchen

Metis example featuring typed set theory.
*)

section \<open>Metis Example Featuring Typed Set Theory\<close>

theory Sets
imports Main
begin

declare [[metis_new_skolem]]

lemma "\<exists>x X. \<forall>y. \<exists>z Z. (~P(y,y) | P(x,x) | ~S(z,x)) &
               (S(x,y) | ~S(y,z) | Q(Z,Z))  &
               (Q(X,y) | ~Q(y,Z) | S(X,X))"
by metis

lemma "P(n::nat) ==> \<not>P(0) ==> n \<noteq> 0"
by metis

sledgehammer_params [isar_proofs, compress = 1]

(*multiple versions of this example*)
lemma (*equal_union: *)
   "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))"
proof -
  have F1: "\<forall>(x\<^sub>2::'b set) x\<^sub>1::'b set. x\<^sub>1 \<subseteq> x\<^sub>1 \<union> x\<^sub>2" by (metis Un_commute Un_upper2)
  have F2a: "\<forall>(x\<^sub>2::'b set) x\<^sub>1::'b set. x\<^sub>1 \<subseteq> x\<^sub>2 \<longrightarrow> x\<^sub>2 = x\<^sub>2 \<union> x\<^sub>1" by (metis Un_commute subset_Un_eq)
  have F2: "\<forall>(x\<^sub>2::'b set) x\<^sub>1::'b set. x\<^sub>1 \<subseteq> x\<^sub>2 \<and> x\<^sub>2 \<subseteq> x\<^sub>1 \<longrightarrow> x\<^sub>1 = x\<^sub>2" by (metis F2a subset_Un_eq)
  { assume "\<not> Z \<subseteq> X"
    hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
  moreover
  { assume AA1: "Y \<union> Z \<noteq> X"
    { assume "\<not> Y \<subseteq> X"
      hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis F1) }
    moreover
    { assume AAA1: "Y \<subseteq> X \<and> Y \<union> Z \<noteq> X"
      { assume "\<not> Z \<subseteq> X"
        hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
      moreover
      { assume "(Z \<subseteq> X \<and> Y \<subseteq> X) \<and> Y \<union> Z \<noteq> X"
        hence "Y \<union> Z \<subseteq> X \<and> X \<noteq> Y \<union> Z" by (metis Un_subset_iff)
        hence "Y \<union> Z \<noteq> X \<and> \<not> X \<subseteq> Y \<union> Z" by (metis F2)
        hence "\<exists>x\<^sub>1::'a set. Y \<subseteq> x\<^sub>1 \<union> Z \<and> Y \<union> Z \<noteq> X \<and> \<not> X \<subseteq> x\<^sub>1 \<union> Z" by (metis F1)
        hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
      ultimately have "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis AAA1) }
    ultimately have "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis AA1) }
  moreover
  { assume "\<exists>x\<^sub>1::'a set. (Z \<subseteq> x\<^sub>1 \<and> Y \<subseteq> x\<^sub>1) \<and> \<not> X \<subseteq> x\<^sub>1"
    { assume "\<not> Y \<subseteq> X"
      hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis F1) }
    moreover
    { assume AAA1: "Y \<subseteq> X \<and> Y \<union> Z \<noteq> X"
      { assume "\<not> Z \<subseteq> X"
        hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
      moreover
      { assume "(Z \<subseteq> X \<and> Y \<subseteq> X) \<and> Y \<union> Z \<noteq> X"
        hence "Y \<union> Z \<subseteq> X \<and> X \<noteq> Y \<union> Z" by (metis Un_subset_iff)
        hence "Y \<union> Z \<noteq> X \<and> \<not> X \<subseteq> Y \<union> Z" by (metis F2)
        hence "\<exists>x\<^sub>1::'a set. Y \<subseteq> x\<^sub>1 \<union> Z \<and> Y \<union> Z \<noteq> X \<and> \<not> X \<subseteq> x\<^sub>1 \<union> Z" by (metis F1)
        hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
      ultimately have "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis AAA1) }
    ultimately have "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by blast }
  moreover
  { assume "\<not> Y \<subseteq> X"
    hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis F1) }
  ultimately show "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by metis
qed

sledgehammer_params [isar_proofs, compress = 2]

lemma (*equal_union: *)
   "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))"
proof -
  have F1: "\<forall>(x\<^sub>2::'b set) x\<^sub>1::'b set. x\<^sub>1 \<subseteq> x\<^sub>2 \<and> x\<^sub>2 \<subseteq> x\<^sub>1 \<longrightarrow> x\<^sub>1 = x\<^sub>2" by (metis Un_commute subset_Un_eq)
  { assume AA1: "\<exists>x\<^sub>1::'a set. (Z \<subseteq> x\<^sub>1 \<and> Y \<subseteq> x\<^sub>1) \<and> \<not> X \<subseteq> x\<^sub>1"
    { assume AAA1: "Y \<subseteq> X \<and> Y \<union> Z \<noteq> X"
      { assume "\<not> Z \<subseteq> X"
        hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
      moreover
      { assume "Y \<union> Z \<subseteq> X \<and> X \<noteq> Y \<union> Z"
        hence "\<exists>x\<^sub>1::'a set. Y \<subseteq> x\<^sub>1 \<union> Z \<and> Y \<union> Z \<noteq> X \<and> \<not> X \<subseteq> x\<^sub>1 \<union> Z" by (metis F1 Un_commute Un_upper2)
        hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
      ultimately have "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis AAA1 Un_subset_iff) }
    moreover
    { assume "\<not> Y \<subseteq> X"
      hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_commute Un_upper2) }
    ultimately have "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis AA1 Un_subset_iff) }
  moreover
  { assume "\<not> Z \<subseteq> X"
    hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
  moreover
  { assume "\<not> Y \<subseteq> X"
    hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_commute Un_upper2) }
  moreover
  { assume AA1: "Y \<subseteq> X \<and> Y \<union> Z \<noteq> X"
    { assume "\<not> Z \<subseteq> X"
      hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
    moreover
    { assume "Y \<union> Z \<subseteq> X \<and> X \<noteq> Y \<union> Z"
      hence "\<exists>x\<^sub>1::'a set. Y \<subseteq> x\<^sub>1 \<union> Z \<and> Y \<union> Z \<noteq> X \<and> \<not> X \<subseteq> x\<^sub>1 \<union> Z" by (metis F1 Un_commute Un_upper2)
      hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
    ultimately have "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis AA1 Un_subset_iff) }
  ultimately show "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by metis
qed

sledgehammer_params [isar_proofs, compress = 3]

lemma (*equal_union: *)
   "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))"
proof -
  have F1a: "\<forall>(x\<^sub>2::'b set) x\<^sub>1::'b set. x\<^sub>1 \<subseteq> x\<^sub>2 \<longrightarrow> x\<^sub>2 = x\<^sub>2 \<union> x\<^sub>1" by (metis Un_commute subset_Un_eq)
  have F1: "\<forall>(x\<^sub>2::'b set) x\<^sub>1::'b set. x\<^sub>1 \<subseteq> x\<^sub>2 \<and> x\<^sub>2 \<subseteq> x\<^sub>1 \<longrightarrow> x\<^sub>1 = x\<^sub>2" by (metis F1a subset_Un_eq)
  { assume "(Z \<subseteq> X \<and> Y \<subseteq> X) \<and> Y \<union> Z \<noteq> X"
    hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis F1 Un_commute Un_subset_iff Un_upper2) }
  moreover
  { assume AA1: "\<exists>x\<^sub>1::'a set. (Z \<subseteq> x\<^sub>1 \<and> Y \<subseteq> x\<^sub>1) \<and> \<not> X \<subseteq> x\<^sub>1"
    { assume "(Z \<subseteq> X \<and> Y \<subseteq> X) \<and> Y \<union> Z \<noteq> X"
      hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis F1 Un_commute Un_subset_iff Un_upper2) }
    hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis AA1 Un_commute Un_subset_iff Un_upper2) }
  ultimately show "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_commute Un_upper2)
qed

sledgehammer_params [isar_proofs, compress = 4]

lemma (*equal_union: *)
   "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))"
proof -
  have F1: "\<forall>(x\<^sub>2::'b set) x\<^sub>1::'b set. x\<^sub>1 \<subseteq> x\<^sub>2 \<and> x\<^sub>2 \<subseteq> x\<^sub>1 \<longrightarrow> x\<^sub>1 = x\<^sub>2" by (metis Un_commute subset_Un_eq)
  { assume "\<not> Y \<subseteq> X"
    hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_commute Un_upper2) }
  moreover
  { assume AA1: "Y \<subseteq> X \<and> Y \<union> Z \<noteq> X"
    { assume "\<exists>x\<^sub>1::'a set. Y \<subseteq> x\<^sub>1 \<union> Z \<and> Y \<union> Z \<noteq> X \<and> \<not> X \<subseteq> x\<^sub>1 \<union> Z"
      hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_upper2) }
    hence "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis AA1 F1 Un_commute Un_subset_iff Un_upper2) }
  ultimately show "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V::'a set. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))" by (metis Un_subset_iff Un_upper2)
qed

sledgehammer_params [isar_proofs, compress = 1]

lemma (*equal_union: *)
   "(X = Y \<union> Z) = (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))"
by (metis Un_least Un_upper1 Un_upper2 set_eq_subset)

lemma "(X = Y \<inter> Z) = (X \<subseteq> Y \<and> X \<subseteq> Z \<and> (\<forall>V. V \<subseteq> Y \<and> V \<subseteq> Z \<longrightarrow> V \<subseteq> X))"
by (metis Int_greatest Int_lower1 Int_lower2 subset_antisym)

lemma fixedpoint: "\<exists>!x. f (g x) = x \<Longrightarrow> \<exists>!y. g (f y) = y"
by metis

lemma (* fixedpoint: *) "\<exists>!x. f (g x) = x \<Longrightarrow> \<exists>!y. g (f y) = y"
proof -
  assume "\<exists>!x::'a. f (g x) = x"
  thus "\<exists>!y::'b. g (f y) = y" by metis
qed

lemma (* singleton_example_2: *)
     "\<forall>x \<in> S. \<Union>S \<subseteq> x \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
by (metis Set.subsetI Union_upper insertCI set_eq_subset)

lemma (* singleton_example_2: *)
     "\<forall>x \<in> S. \<Union>S \<subseteq> x \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
by (metis Set.subsetI Union_upper insert_iff set_eq_subset)

lemma singleton_example_2:
     "\<forall>x \<in> S. \<Union>S \<subseteq> x \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
proof -
  assume "\<forall>x \<in> S. \<Union>S \<subseteq> x"
  hence "\<forall>x\<^sub>1. x\<^sub>1 \<subseteq> \<Union>S \<and> x\<^sub>1 \<in> S \<longrightarrow> x\<^sub>1 = \<Union>S" by (metis set_eq_subset)
  hence "\<forall>x\<^sub>1. x\<^sub>1 \<in> S \<longrightarrow> x\<^sub>1 = \<Union>S" by (metis Union_upper)
  hence "\<forall>x\<^sub>1::('a set) set. \<Union>S \<in> x\<^sub>1 \<longrightarrow> S \<subseteq> x\<^sub>1" by (metis subsetI)
  hence "\<forall>x\<^sub>1::('a set) set. S \<subseteq> insert (\<Union>S) x\<^sub>1" by (metis insert_iff)
  thus "\<exists>z. S \<subseteq> {z}" by metis
qed

text \<open>
  From W. W. Bledsoe and Guohui Feng, SET-VAR. JAR 11 (3), 1993, pages
  293-314.
\<close>

(* Notes: (1) The numbering doesn't completely agree with the paper.
   (2) We must rename set variables to avoid type clashes. *)
lemma "\<exists>B. (\<forall>x \<in> B. x \<le> (0::int))"
      "D \<in> F \<Longrightarrow> \<exists>G. \<forall>A \<in> G. \<exists>B \<in> F. A \<subseteq> B"
      "P a \<Longrightarrow> \<exists>A. (\<forall>x \<in> A. P x) \<and> (\<exists>y. y \<in> A)"
      "a < b \<and> b < (c::int) \<Longrightarrow> \<exists>B. a \<notin> B \<and> b \<in> B \<and> c \<notin> B"
      "P (f b) \<Longrightarrow> \<exists>s A. (\<forall>x \<in> A. P x) \<and> f s \<in> A"
      "P (f b) \<Longrightarrow> \<exists>s A. (\<forall>x \<in> A. P x) \<and> f s \<in> A"
      "\<exists>A. a \<notin> A"
      "(\<forall>C. (0, 0) \<in> C \<and> (\<forall>x y. (x, y) \<in> C \<longrightarrow> (Suc x, Suc y) \<in> C) \<longrightarrow> (n, m) \<in> C) \<and> Q n \<longrightarrow> Q m"
       apply (metis all_not_in_conv)
      apply (metis all_not_in_conv)
     apply (metis mem_Collect_eq)
    apply (metis less_le singleton_iff)
   apply (metis mem_Collect_eq)
  apply (metis mem_Collect_eq)
 apply (metis all_not_in_conv)
by (metis pair_in_Id_conv)

end


subsubsection \<open>State 0 equation\<close>

theory State_0_Equation imports "../Register_Machine/MultipleStepState"
                                    RM_Sums_Diophantine "../Diophantine/Binary_And"

begin

context rm_eq_fixes
begin

  text \<open>Equation 4.24\<close>
  definition state_0 :: "bool" where
    "state_0 \<equiv> s 0 = 1 + b*\<Sum>S+ p 0 s + b*\<Sum>S- p 0 (\<lambda>k. s k && z (modifies (p!k)))
                                             + b*\<Sum>S0 p 0 (\<lambda>k. s k && (e - z (modifies (p!k))))"

end

context register_machine
begin

no_notation ppolynomial.Sum (infixl "\<^bold>+" 65)
no_notation ppolynomial.NatDiff (infixl "\<^bold>-" 65)
no_notation ppolynomial.Prod (infixl "\<^bold>*" 70)

lemma state_0_dioph:
  fixes b e :: polynomial
  fixes z s :: "polynomial list"
  assumes "length z = n" "length s = Suc m"
  defines "DR \<equiv> LARY (\<lambda>ll. rm_eq_fixes.state_0 p (ll!0!0) (ll!0!1)
                            (nth (ll!1)) (nth (ll!2))) [[b, e], z, s]"
  shows "is_dioph_rel DR"
proof -
  let ?N = "2"
  define b' e' z' s' where pushed_def: "b' = push_param b ?N"
                                       "e' = push_param e ?N"
                                       "z' = map (\<lambda>x. push_param x ?N) z"
                                       "s' = map (\<lambda>x. push_param x ?N) s"

  define z0 z1 where z_def: "z0 \<equiv> map (\<lambda>i. z' ! modifies (p!i)) [0..<length p]"
                            "z1 \<equiv> map (\<lambda>i. e' [-] z' ! modifies (p!i)) [0..<length p]"

  define param_0_is_sum_sub_nzero_term where
    "param_0_is_sum_sub_nzero_term \<equiv> [Param 0 = \<Sum>S- 0 (s' && z0)]"

  define param_1_is_sum_sub_zero_term where
    "param_1_is_sum_sub_zero_term \<equiv> [Param 1 = \<Sum>S0 0 (s' && z1)]"

  define step_relation where
    "step_relation \<equiv> (s'!0 [=] \<^bold>1 [+] b' [*] ([\<Sum>S+] p 0 (nth s'))
                                  [+] b' [*] Param 0 [+] b' [*] Param 1)"

  define DS where "DS \<equiv> [\<exists>?N] step_relation
                          [\<and>] param_0_is_sum_sub_nzero_term
                          [\<and>] param_1_is_sum_sub_zero_term"

  have "p \<noteq> []" using p_nonempty by auto
  have ps_lengths: "length p = length s"
    using \<open>length s = Suc m\<close> m_def \<open>p \<noteq> []\<close> by auto
  have s_len: "length s > 0"
    using ps_lengths \<open>p \<noteq> []\<close> by auto
  have p_len: "length p > 0"
    using ps_lengths s_len by auto
  have p_len2: "length p = Suc m"
    using ps_lengths \<open>length s = Suc m\<close> by auto
  have len_s': "length s' = Suc m"
    unfolding pushed_def using \<open>length s = Suc m\<close> by auto
  have "length z0 = Suc m"
    unfolding z_def ps_lengths \<open>length s = Suc m\<close> by simp
  have "length z1 = Suc m"
    unfolding z_def ps_lengths \<open>length s = Suc m\<close> by simp

  have modifies_le_n: "k < length p \<Longrightarrow> modifies (p!k) < n" for k
    using  modifies_yields_valid_register \<open>length z = n\<close> by auto

  have "eval DS a = eval DR a" for a
  proof -

    have b'_unfold: "peval b' (push_list a ks) = peval b a" if "length ks = 2" for ks
      using push_push_simp unfolding pushed_def using that by metis

    have s'_0_unfold: "peval (s' ! 0) (push_list a ks) = peval (s ! 0) a" if "length ks = 2" for ks
      unfolding pushed_def using push_push_map_i[of ks 2 0 s a] that unfolding list_eval_def
      \<open>length s > 0\<close> using s_len by auto

    have sum_nzero_unfold:
      "eval [polynomial.Param 0 = \<Sum>S- 0 (s' && z0)] (push_list a ks)
      = (peval (polynomial.Param 0) (push_list a ks)
        = \<Sum>S- p 0 (\<lambda>k. peval (s' ! k) (push_list a ks) && peval (z0 ! k) (push_list a ks)))" for ks
      using sum_rsub_nzero_of_bit_and_eval[of s' z0 "Param 0" 0 "push_list a ks"]
            \<open>length p > 0\<close> \<open>length s' = Suc m\<close> \<open>length z0 = Suc m\<close> by auto

    have sum_zero_unfold:
      "eval [polynomial.Param 1 = \<Sum>S0 0 (s' && z1)] (push_list a ks)
      = (peval (polynomial.Param 1) (push_list a ks)
         = \<Sum>S0 p 0 (\<lambda>k. peval (s' ! k) (push_list a ks) && peval (z1 ! k) (push_list a ks)))" for ks
      using sum_rsub_zero_of_bit_and_eval[of s' z1 "Param 1" 0 "push_list a ks"]
            \<open>length p > 0\<close> \<open>length s' = Suc m\<close> \<open>length z1 = Suc m\<close> by auto

    have param_0_unfold: "peval (Param 0) (push_list a ks) = ks ! 0" if "length ks = 2" for ks
      unfolding push_list_def using that by auto

    have param_1_unfold: "peval (Param 1) (push_list a ks) = ks ! 1" if "length ks = 2" for ks
      unfolding push_list_def using that by auto

    have sum_sadd_unfold:
      "peval ([\<Sum>S+] p 0 ((!) s')) (push_list a ks) = \<Sum>S+ p 0 (\<lambda>x. peval (s ! x) a)"
      if "length ks = 2" for ks
      using sum_sadd_polynomial_eval \<open>length p > 0\<close> apply auto
      apply (rule sum_sadd_cong, auto)
      unfolding pushed_def using push_push_map_i[of ks 2 _ s a] that
      unfolding \<open>length p = length s\<close> list_eval_def
      by (smt One_nat_def assms le_imp_less_Suc m_def nth_map p_len2)

    have z0_unfold:
      "peval (s' ! k) (push_list a ks) && peval (z0 ! k) (push_list a ks)
      = peval (s ! k) a && peval (z ! modifies (p ! k)) a"
      if "length ks = 2" and "k < length p" for k ks
    proof -
      have map: "map (\<lambda>i. z' ! modifies (p ! i)) [0..<length p] ! k
            = z' ! modifies (p ! k)"
        unfolding z_def using nth_map[of k "[0..<length p]" "\<lambda>i. z' ! modifies (p ! i)"]
        using \<open>k < length p\<close> by auto

      have s: "peval (map (\<lambda>x. push_param x 2) s ! k) (push_list a ks) = peval (s ! k) a"
        using push_push_map_i[of ks 2 k s] that nth_map[of k s]
        unfolding \<open>length s = Suc m\<close> \<open>length p = Suc m\<close> list_eval_def by auto

      have z: "peval (map (\<lambda>x. push_param x 2) z ! modifies (p ! k)) (push_list a ks)
               = peval (z ! modifies (p ! k)) a"
        using push_push_map_i[of ks 2 "modifies (p!k)" z a] modifies_le_n[of k] that nth_map[of _ z]
        unfolding \<open>length z = n\<close> list_eval_def by auto

      show ?thesis
        unfolding z_def map unfolding pushed_def s z by auto
    qed

    have z1_unfold:
      "peval (s' ! k) (push_list a ks) && peval (z1 ! k) (push_list a ks)
      = peval (s ! k) a && (peval e a - peval (z ! modifies (p ! k)) a)"
      if "length ks = 2" and "k < length p" for k ks
    proof -
      have map:
        "map (\<lambda>i. e' [-] (z' ! (modifies (p ! i)))) [0..<length p] ! k
         = e' [-] (z' ! modifies (p ! k))"
        using nth_map[of k "[0..<length p]" "\<lambda>i. z' ! modifies (p ! i)"]
        using \<open>k < length p\<close> by auto

      have s: "peval (map (\<lambda>x. push_param x 2) s ! k) (push_list a ks) = peval (s ! k) a"
        using push_push_map_i[of ks 2 k s] that nth_map[of k s]
        unfolding \<open>length s = Suc m\<close> \<open>length p = Suc m\<close> list_eval_def by auto

      have z: "peval (push_param e 2) (push_list a ks)
             - peval (map (\<lambda>x. push_param x 2) z ! modifies (p ! k)) (push_list a ks)
             = peval e a - peval (z ! (modifies (p!k))) a"
        using push_push_simp[of e ks a] unfolding \<open>length ks = 2\<close> apply simp
        using push_push_map_i[of ks 2 "modifies (p!k)" z a] modifies_le_n[of k] that
              nth_map[of "modifies (p!k)" z "(\<lambda>x. peval x a)"]
        unfolding \<open>length z = n\<close> list_eval_def by auto

      show ?thesis
        unfolding z_def map unfolding pushed_def s using z by auto
    qed

    have z0sum_unfold:
      "(\<Sum>S- p 0 (\<lambda>k. peval (s' ! k) (push_list a ks) && peval (z0 ! k) (push_list a ks)))
      =(\<Sum>S- p 0 (\<lambda>k. peval (s ! k) a && peval (z ! modifies (p ! k)) a))"
      if "length ks = 2" for ks
      apply (rule sum_ssub_nzero_cong) using z0_unfold[of ks] that
      by (metis \<open>length s = Suc m\<close> le_imp_less_Suc m_def ps_lengths)

    have z1sum_unfold:
      "(\<Sum>S0 p 0 (\<lambda>k. peval (s' ! k) (push_list a ks) && peval (z1 ! k) (push_list a ks)))
      =(\<Sum>S0 p 0 (\<lambda>k. peval (s ! k) a && peval e a - peval (z ! modifies (p ! k)) a))"
      if "length ks = 2" for ks
      apply (rule sum_ssub_zero_cong) using z1_unfold[of ks] that
      by (metis \<open>length s = Suc m\<close> le_imp_less_Suc m_def ps_lengths)

    have sum_sadd_map: "\<Sum>S+ p 0 ((!) (map (\<lambda>P. peval P a) s)) = \<Sum>S+ p 0 (\<lambda>x. peval (s ! x) a)"
      apply (rule sum_sadd_cong, auto)
      using nth_map[of _ s "(\<lambda>P. peval P a)"] m_def \<open>length s = Suc m\<close> by auto

    have sum_ssub_nzero_map:
      "(\<Sum>S- p 0 (\<lambda>k. peval (s ! k) a && peval (z ! modifies (p ! k)) a))
     = (\<Sum>S- p 0 (\<lambda>k. map (\<lambda>P. peval P a) s ! k && map (\<lambda>P. peval P a) z ! modifies (p ! k)))"
    proof -
     have 1: "peval (s ! k) a && peval (z ! modifies (p ! k)) a =
           map (\<lambda>P. peval P a) s ! k && map (\<lambda>P. peval P a) z ! modifies (p ! k) "
           if "k < length p" for k
     proof -
       have "peval (s ! k) a = map (\<lambda>P. peval P a) s ! k"
       using nth_map that ps_lengths by auto
       moreover have "peval (z ! modifies (p ! k)) a
                      = map (\<lambda>P. peval P a) z ! modifies (p ! k) "
         using nth_map[of "modifies (p!k)" z "(\<lambda>P. peval P a)"] modifies_le_n[of k] that
         using \<open>length z = n\<close> by auto
       ultimately show ?thesis by auto
     qed
     show ?thesis apply (rule sum_ssub_nzero_cong, auto)
       using 1 by (metis Suc_le_mono Suc_pred less_eq_Suc_le p_len)
    qed

    have sum_ssub_zero_map:
      "(\<Sum>S0 p 0 (\<lambda>k. peval (s ! k) a && peval e a - peval (z ! modifies (p ! k)) a))
     = (\<Sum>S0 p 0 (\<lambda>k. map (\<lambda>P. peval P a) s ! k && peval e a
                                                      - map (\<lambda>P. peval P a) z ! modifies (p ! k)))"
    proof -
     have 1: "peval (s ! k) a && peval e a - peval (z ! modifies (p ! k)) a =
           map (\<lambda>P. peval P a) s ! k && peval e a - map (\<lambda>P. peval P a) z ! modifies (p ! k) "
           if "k < length p" for k
     proof -
       have "peval (s ! k) a = map (\<lambda>P. peval P a) s ! k"
       using nth_map that ps_lengths by auto
       moreover have "peval (z ! modifies (p ! k)) a
                      = map (\<lambda>P. peval P a) z ! modifies (p ! k) "
         using nth_map[of "modifies (p!k)" z "(\<lambda>P. peval P a)"] modifies_le_n[of k] that
         using \<open>length z = n\<close> by auto
       ultimately show ?thesis by auto
     qed
     show ?thesis apply (rule sum_ssub_zero_cong, auto)
       using 1 by (metis Suc_le_mono Suc_pred less_eq_Suc_le p_len)
    qed

    have "eval DS a =
              (\<exists>ks. length ks = 2 \<and>
                  eval (s' ! 0 [=] \<^bold>1 [+] b' [*] ([\<Sum>S+] p 0 (!) s') [+] b' [*] Param 0
                                     [+] b' [*] Param (Suc 0)) (push_list a ks)
                \<and> eval [polynomial.Param 0 = \<Sum>S- 0 (s' && z0)] (push_list a ks)
                \<and> eval [polynomial.Param 1 = \<Sum>S0 0 (s' && z1)] (push_list a ks))"
      unfolding DS_def step_relation_def param_0_is_sum_sub_nzero_term_def
        param_1_is_sum_sub_zero_term_def by (simp add: defs)

    also have "... = (\<exists>ks. length ks = 2 \<and>
         peval (s' ! 0) (push_list a ks) =
         Suc (peval b' (push_list a ks) * peval ([\<Sum>S+] p 0 ((!) s')) (push_list a ks) +
              peval b' (push_list a ks) * push_list a ks 0 +
              peval b' (push_list a ks) * push_list a ks (Suc 0))
          \<and> (peval (Param 0) (push_list a ks)
              = \<Sum>S- p 0 (\<lambda>k. peval (s' ! k) (push_list a ks) && peval (z0 ! k) (push_list a ks)))
          \<and> (peval (Param 1) (push_list a ks)
              = \<Sum>S0 p 0 (\<lambda>k. peval (s' ! k) (push_list a ks) && peval (z1 ! k) (push_list a ks))))"
      unfolding sum_nzero_unfold sum_zero_unfold by (simp add: defs )

    also have "... = (\<exists>ks. length ks = 2 \<and>
         peval (s ! 0) a =
         Suc (peval b a * peval ([\<Sum>S+] p 0 ((!) s')) (push_list a ks) +
              peval b a * push_list a ks 0 +
              peval b a * push_list a ks (Suc 0))
          \<and> (ks!0
              = \<Sum>S- p 0 (\<lambda>k. peval (s' ! k) (push_list a ks) && peval (z0 ! k) (push_list a ks)))
          \<and> (ks!1
              = \<Sum>S0 p 0 (\<lambda>k. peval (s' ! k) (push_list a ks) && peval (z1 ! k) (push_list a ks))))"
      using b'_unfold s'_0_unfold param_0_unfold param_1_unfold by auto

    also have "... = (\<exists>ks. length ks = 2 \<and>
     peval (s ! 0) a =
         Suc (peval b a * \<Sum>S+ p 0 (\<lambda>x. peval (s ! x) a) +
              peval b a * (ks!0) + peval b a * (ks!1))
      \<and> (ks!0 = \<Sum>S- p 0 (\<lambda>k. peval (s' ! k) (push_list a ks) && peval (z0 ! k) (push_list a ks)))
      \<and> (ks!1 = \<Sum>S0 p 0 (\<lambda>k. peval (s' ! k) (push_list a ks) && peval (z1 ! k) (push_list a ks))))"
      using push_list_def sum_sadd_unfold by auto

    also have "... = (\<exists>ks. length ks = 2 \<and>
     peval (s ! 0) a = Suc (peval b a * \<Sum>S+ p 0 (\<lambda>x. peval (s ! x) a)
                     + peval b a * (ks!0) + peval b a * (ks!1))
      \<and> (ks!0 = \<Sum>S- p 0 (\<lambda>k. peval (s ! k) a && peval (z ! modifies (p ! k)) a))
      \<and> (ks!1 = \<Sum>S0 p 0 (\<lambda>k. peval (s ! k) a && peval e a - peval (z ! modifies (p ! k)) a)))"
      using z0sum_unfold z1sum_unfold by auto

    also have "... = (\<exists>ks. length ks = 2 \<and>
      peval (s ! 0) a
      = Suc (peval b a * \<Sum>S+ p 0 (\<lambda>x. peval (s ! x) a)
      + peval b a * \<Sum>S- p 0 (\<lambda>k. peval (s ! k) a && peval (z ! modifies (p ! k)) a)
      + peval b a * \<Sum>S0 p 0 (\<lambda>k. peval (s ! k) a && peval e a - peval (z ! modifies (p ! k)) a))
      \<and> (ks!0 = \<Sum>S- p 0 (\<lambda>k. peval (s ! k) a && peval (z ! modifies (p ! k)) a))
      \<and> (ks!1 = \<Sum>S0 p 0 (\<lambda>k. peval (s ! k) a && peval e a - peval (z ! modifies (p ! k)) a)))"
      by auto

    also have "... = (peval (s ! 0) a
      = Suc (peval b a * \<Sum>S+ p 0 (\<lambda>x. peval (s ! x) a)
      + peval b a * \<Sum>S- p 0 (\<lambda>k. peval (s ! k) a && peval (z ! modifies (p ! k)) a)
      + peval b a * \<Sum>S0 p 0 (\<lambda>k. peval (s ! k) a && peval e a - peval (z ! modifies (p ! k)) a)))"
      apply auto
      apply (rule exI[of _ "[(\<Sum>S- p 0 (\<lambda>k. peval (s ! k) a && peval (z ! modifies (p ! k)) a)),
              \<Sum>S0 p 0 (\<lambda>k. peval (s ! k) a && peval e a - peval (z ! modifies (p ! k)) a) ]"])
      by auto

    also have "... = (map (\<lambda>P. peval P a) s ! 0 =
     Suc (peval b a * \<Sum>S+ p 0 ((!) (map (\<lambda>P. peval P a) s))  +
          peval b a * \<Sum>S- p 0 (\<lambda>k. map (\<lambda>P. peval P a) s ! k
                                && map (\<lambda>P. peval P a) z ! modifies (p ! k))  +
          peval b a *
          \<Sum>S0 p 0 (\<lambda>k. map (\<lambda>P. peval P a) s ! k && peval e a
                                                    - map (\<lambda>P. peval P a) z ! modifies (p ! k)) ))"
      using nth_map[of _ _ "(\<lambda>P. peval P a)"] \<open>length s > 0\<close>
      using sum_ssub_zero_map sum_sadd_map sum_ssub_nzero_map by auto

    finally show ?thesis unfolding DR_def using rm_eq_fixes_def local.register_machine_axioms
      rm_eq_fixes.state_0_def by (simp add: defs)
  qed

  moreover have "is_dioph_rel DS"
    unfolding DS_def param_1_is_sum_sub_zero_term_def param_0_is_sum_sub_nzero_term_def
    step_relation_def by (auto simp add: dioph)

  ultimately show ?thesis
    by (simp add: is_dioph_rel_def)
qed

end

end


(*
  Title:    HOL/Library/Complex_Order.thy
  Author:   Dominique Unruh, University of Tartu

  Instantiation of complex numbers as an ordered set.
*)

theory Complex_Order
  imports Complex_Main
begin

instantiation complex :: order begin

definition \<open>x < y \<longleftrightarrow> Re x < Re y \<and> Im x = Im y\<close>
definition \<open>x \<le> y \<longleftrightarrow> Re x \<le> Re y \<and> Im x = Im y\<close>

instance
  apply standard
  by (auto simp: less_complex_def less_eq_complex_def complex_eq_iff)
end

lemma nonnegative_complex_is_real: \<open>(x::complex) \<ge> 0 \<Longrightarrow> x \<in> \<real>\<close>
  by (simp add: complex_is_Real_iff less_eq_complex_def)

lemma complex_is_real_iff_compare0: \<open>(x::complex) \<in> \<real> \<longleftrightarrow> x \<le> 0 \<or> x \<ge> 0\<close>
  using complex_is_Real_iff less_eq_complex_def by auto

instance complex :: ordered_comm_ring
  apply standard
  by (auto simp: less_complex_def less_eq_complex_def complex_eq_iff mult_left_mono mult_right_mono)

instance complex :: ordered_real_vector
  apply standard
  by (auto simp: less_complex_def less_eq_complex_def mult_left_mono mult_right_mono)

instance complex :: ordered_cancel_comm_semiring
  by standard

end


section \<open>Lens Instances\<close>

theory Lens_Instances
  imports Lens_Order Lens_Symmetric Scene_Spaces "HOL-Eisbach.Eisbach" "HOL-Library.Stream"
  keywords "alphabet" "statespace" :: "thy_defn"
begin

text \<open>In this section we define a number of concrete instantiations of the lens locales, including
  functions lenses, list lenses, and record lenses.\<close>

subsection \<open>Function Lens\<close>

text \<open>A function lens views the valuation associated with a particular domain element @{typ "'a"}.
      We require that range type of a lens function has cardinality of at least 2; this ensures
      that properties of independence are provable.\<close>

definition fun_lens :: "'a \<Rightarrow> ('b::two \<Longrightarrow> ('a \<Rightarrow> 'b))" where
[lens_defs]: "fun_lens x = \<lparr> lens_get = (\<lambda> f. f x), lens_put = (\<lambda> f u. f(x := u)) \<rparr>"

lemma fun_vwb_lens: "vwb_lens (fun_lens x)"
  by (unfold_locales, simp_all add: fun_lens_def)

text \<open>Two function lenses are independent if and only if the domain elements are different.\<close>

lemma fun_lens_indep:
  "fun_lens x \<bowtie> fun_lens y \<longleftrightarrow> x \<noteq> y"
proof -
  obtain u v :: "'a::two" where "u \<noteq> v"
    using two_diff by auto
  thus ?thesis
    by (auto simp add: fun_lens_def lens_indep_def)
qed

subsection \<open>Function Range Lens\<close>

text \<open>The function range lens allows us to focus on a particular region of a function's range.\<close>

definition fun_ran_lens :: "('c \<Longrightarrow> 'b) \<Rightarrow> (('a \<Rightarrow> 'b) \<Longrightarrow> '\<alpha>) \<Rightarrow> (('a \<Rightarrow> 'c) \<Longrightarrow> '\<alpha>)" where
[lens_defs]: "fun_ran_lens X Y = \<lparr> lens_get = \<lambda> s. get\<^bsub>X\<^esub> \<circ> get\<^bsub>Y\<^esub> s
                                 , lens_put = \<lambda> s v. put\<^bsub>Y\<^esub> s (\<lambda> x::'a. put\<^bsub>X\<^esub> (get\<^bsub>Y\<^esub> s x) (v x)) \<rparr>"

lemma fun_ran_mwb_lens: "\<lbrakk> mwb_lens X; mwb_lens Y \<rbrakk> \<Longrightarrow> mwb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

lemma fun_ran_wb_lens: "\<lbrakk> wb_lens X; wb_lens Y \<rbrakk> \<Longrightarrow> wb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

lemma fun_ran_vwb_lens: "\<lbrakk> vwb_lens X; vwb_lens Y \<rbrakk> \<Longrightarrow> vwb_lens (fun_ran_lens X Y)"
  by (unfold_locales, auto simp add: fun_ran_lens_def)

subsection \<open>Map Lens\<close>

text \<open>The map lens allows us to focus on a particular region of a partial function's range. It
  is only a mainly well-behaved lens because it does not satisfy the PutGet law when the view
  is not in the domain.\<close>

definition map_lens :: "'a \<Rightarrow> ('b \<Longrightarrow> ('a \<rightharpoonup> 'b))" where
[lens_defs]: "map_lens x = \<lparr> lens_get = (\<lambda> f. the (f x)), lens_put = (\<lambda> f u. f(x \<mapsto> u)) \<rparr>"

lemma map_mwb_lens: "mwb_lens (map_lens x)"
  by (unfold_locales, simp_all add: map_lens_def)

lemma source_map_lens: "\<S>\<^bsub>map_lens x\<^esub> = {f. x \<in> dom(f)}"
  by (force simp add: map_lens_def lens_source_def)

lemma pget_map_lens: "pget\<^bsub>map_lens k\<^esub> f = f k"
  by (auto simp add: lens_partial_get_def source_map_lens)
     (auto simp add: map_lens_def, metis not_Some_eq)

subsection \<open>List Lens\<close>

text \<open>The list lens allows us to view a particular element of a list. In order to show it is mainly
  well-behaved we need to define to additional list functions. The following function adds
  a number undefined elements to the end of a list.\<close>

definition list_pad_out :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list" where
"list_pad_out xs k = xs @ replicate (k + 1 - length xs) undefined"

text \<open>The following function is like @{term "list_update"} but it adds additional elements to the
  list if the list isn't long enough first.\<close>

definition list_augment :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
"list_augment xs k v = (list_pad_out xs k)[k := v]"

text \<open>The following function is like @{term nth} but it expressly returns @{term undefined} when
  the list isn't long enough.\<close>

definition nth' :: "'a list \<Rightarrow> nat \<Rightarrow> 'a" where
"nth' xs i = (if (length xs > i) then xs ! i else undefined)"

text \<open>We can prove some additional laws about list update and append.\<close>

lemma list_update_append_lemma1: "i < length xs \<Longrightarrow> xs[i := v] @ ys = (xs @ ys)[i := v]"
  by (simp add: list_update_append)

lemma list_update_append_lemma2: "i < length ys \<Longrightarrow> xs @ ys[i := v] = (xs @ ys)[i + length xs := v]"
  by (simp add: list_update_append)

text \<open>We can also prove some laws about our new operators.\<close>

lemma nth'_0 [simp]: "nth' (x # xs) 0 = x"
  by (simp add: nth'_def)

lemma nth'_Suc [simp]: "nth' (x # xs) (Suc n) = nth' xs n"
  by (simp add: nth'_def)

lemma list_augment_0 [simp]:
  "list_augment (x # xs) 0 y = y # xs"
  by (simp add: list_augment_def list_pad_out_def)

lemma list_augment_Suc [simp]:
  "list_augment (x # xs) (Suc n) y = x # list_augment xs n y"
  by (simp add: list_augment_def list_pad_out_def)

lemma list_augment_twice:
  "list_augment (list_augment xs i u) j v = (list_pad_out xs (max i j))[i:=u, j:=v]"
  apply (auto simp add: list_augment_def list_pad_out_def list_update_append_lemma1 replicate_add[THEN sym] max_def)
  apply (metis Suc_le_mono add.commute diff_diff_add diff_le_mono le_add_diff_inverse2)
done

lemma list_augment_last [simp]:
  "list_augment (xs @ [y]) (length xs) z = xs @ [z]"
  by (induct xs, simp_all)

lemma list_augment_idem [simp]:
  "i < length xs \<Longrightarrow> list_augment xs i (xs ! i) = xs"
  by (simp add: list_augment_def list_pad_out_def)

text \<open>We can now prove that @{term list_augment} is commutative for different (arbitrary) indices.\<close>

lemma list_augment_commute:
  "i \<noteq> j \<Longrightarrow> list_augment (list_augment \<sigma> j v) i u = list_augment (list_augment \<sigma> i u) j v"
  by (simp add: list_augment_twice list_update_swap max.commute)

text \<open>We can also prove that we can always retrieve an element we have added to the list, since
  @{term list_augment} extends the list when necessary. This isn't true of @{term list_update}. \<close>

lemma nth_list_augment: "list_augment xs k v ! k = v"
  by (simp add: list_augment_def list_pad_out_def)

lemma nth'_list_augment: "nth' (list_augment xs k v) k = v"
  by (auto simp add: nth'_def nth_list_augment list_augment_def list_pad_out_def)

text \<open> The length is expanded if not already long enough, or otherwise left as it is. \<close>

lemma length_list_augment_1: "k \<ge> length xs \<Longrightarrow> length (list_augment xs k v) = Suc k"
  by (simp add: list_augment_def list_pad_out_def)

lemma length_list_augment_2: "k < length xs \<Longrightarrow> length (list_augment xs k v) = length xs"
  by (simp add: list_augment_def list_pad_out_def)

text \<open>We also have it that @{term list_augment} cancels itself.\<close>

lemma list_augment_same_twice: "list_augment (list_augment xs k u) k v = list_augment xs k v"
  by (simp add: list_augment_def list_pad_out_def)

lemma nth'_list_augment_diff: "i \<noteq> j \<Longrightarrow> nth' (list_augment \<sigma> i v) j = nth' \<sigma> j"
  by (auto simp add: list_augment_def list_pad_out_def nth_append nth'_def)

text \<open>The definition of @{const list_augment} is not good for code generation,
      since it produces undefined values even when padding out is not required.
      Here, we defined a code equation that avoids this.\<close>

lemma list_augment_code [code]:
  "list_augment xs k v = (if (k < length xs) then list_update xs k v else list_update (list_pad_out xs k) k v)"
  by (simp add:list_pad_out_def list_augment_def)

text \<open>Finally we can create the list lenses, of which there are three varieties. One that allows
  us to view an index, one that allows us to view the head, and one that allows us to view the tail.
  They are all mainly well-behaved lenses.\<close>

definition list_lens :: "nat \<Rightarrow> ('a::two \<Longrightarrow> 'a list)" where
[lens_defs]: "list_lens i = \<lparr> lens_get = (\<lambda> xs. nth' xs i)
                            , lens_put = (\<lambda> xs x. list_augment xs i x) \<rparr>"

abbreviation hd_lens ("hd\<^sub>L") where "hd_lens \<equiv> list_lens 0"

definition tl_lens :: "'a list \<Longrightarrow> 'a list" ("tl\<^sub>L") where
[lens_defs]: "tl_lens = \<lparr> lens_get = (\<lambda> xs. tl xs)
                        , lens_put = (\<lambda> xs xs'. hd xs # xs') \<rparr>"

lemma list_mwb_lens: "mwb_lens (list_lens x)"
  by (unfold_locales, simp_all add: list_lens_def nth'_list_augment list_augment_same_twice)

text \<open> The set of constructible sources is precisely those where the length is greater than the
  given index. \<close>

lemma source_list_lens: "\<S>\<^bsub>list_lens i\<^esub> = {xs. length xs > i}"
  apply (auto simp add: lens_source_def list_lens_def)
   apply (metis length_list_augment_1 length_list_augment_2 lessI not_less)
  apply (metis list_augment_idem)
  done

lemma tail_lens_mwb:
  "mwb_lens tl\<^sub>L"
  by (unfold_locales, simp_all add: tl_lens_def)

lemma source_tail_lens: "\<S>\<^bsub>tl\<^sub>L\<^esub> = {xs. xs \<noteq> []}"
  using list.exhaust_sel by (auto simp add: tl_lens_def lens_source_def)

text \<open>Independence of list lenses follows when the two indices are different.\<close>

lemma list_lens_indep:
  "i \<noteq> j \<Longrightarrow> list_lens i \<bowtie> list_lens j"
  by (simp add: list_lens_def lens_indep_def list_augment_commute nth'_list_augment_diff)

lemma hd_tl_lens_indep [simp]:
  "hd\<^sub>L \<bowtie> tl\<^sub>L"
  apply (rule lens_indepI)
    apply (simp_all add: list_lens_def tl_lens_def)
    apply (metis hd_conv_nth hd_def length_greater_0_conv list.case(1) nth'_def nth'_list_augment)
   apply (metis (full_types) hd_conv_nth hd_def length_greater_0_conv list.case(1) nth'_def)
  apply (metis One_nat_def diff_Suc_Suc diff_zero length_0_conv length_list_augment_1 length_tl linorder_not_less list.exhaust list.sel(2) list.sel(3) list_augment_0 not_less_zero)
done

lemma hd_tl_lens_pbij: "pbij_lens (hd\<^sub>L +\<^sub>L tl\<^sub>L)"
  by (unfold_locales, auto simp add: lens_defs)

subsection \<open>Stream Lenses\<close>

primrec stream_update :: "'a stream \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a stream" where
"stream_update xs 0 a = a##(stl xs)" |
"stream_update xs (Suc n) a = shd xs ## (stream_update (stl xs) n a)"

lemma stream_update_snth: "(stream_update xs n a) !! n = a"
proof (induction n arbitrary: xs a)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then show ?case by simp
qed

lemma stream_update_unchanged: "i \<noteq> j \<Longrightarrow> (stream_update xs i a) !! j = xs !! j"
  using gr0_conv_Suc by (induct i j arbitrary: xs rule: diff_induct; fastforce)

lemma stream_update_override: "stream_update (stream_update xs n a) n b = stream_update xs n b"
  by (induction n arbitrary: xs a; simp)

lemma stream_update_nth: "stream_update \<sigma> i (\<sigma> !! i) = \<sigma>"
  by (metis stream.map_cong stream_smap_nats stream_update_snth stream_update_unchanged)

definition stream_lens :: "nat \<Rightarrow> ('a::two \<Longrightarrow> 'a stream)" where
[lens_defs]: "stream_lens i = \<lparr> lens_get = (\<lambda> xs. snth xs i)
                            , lens_put = (\<lambda> xs x. stream_update xs i x)\<rparr>"

lemma stream_vwb_lens: "vwb_lens (stream_lens i)"
  apply (unfold_locales; simp add: stream_lens_def)
    apply (rule stream_update_snth)
    apply (rule stream_update_nth)
    apply (rule stream_update_override)
  done

subsection \<open>Record Field Lenses\<close>

text \<open>We also add support for record lenses. Every record created can yield a lens for each field.
  These cannot be created generically and thus must be defined case by case as new records are
  created. We thus create a new Isabelle outer syntax command \textbf{alphabet} which enables this.
  We first create syntax that allows us to obtain a lens from a given field using the internal
  record syntax translations.\<close>

abbreviation (input) "fld_put f \<equiv> (\<lambda> \<sigma> u. f (\<lambda>_. u) \<sigma>)"

syntax
  "_FLDLENS" :: "id \<Rightarrow> logic"  ("FLDLENS _")
translations
  "FLDLENS x" => "\<lparr> lens_get = x, lens_put = CONST fld_put (_update_name x) \<rparr>"

text \<open> We also allow the extraction of the "base lens", which characterises all the fields added
  by a record without the extension. \<close>

syntax
  "_BASELENS" :: "id \<Rightarrow> logic"  ("BASELENS _")

abbreviation (input) "base_lens t e m \<equiv> \<lparr> lens_get = t, lens_put = \<lambda> s v. e v (m s) \<rparr>"

ML \<open>
  fun baselens_tr [Free (name, _)] =
    let
      val extend = Free (name ^ ".extend", dummyT);
      val truncate = Free (name ^ ".truncate", dummyT);
      val more = Free (name ^ ".more", dummyT);
    in
      Const (@{const_syntax "base_lens"}, dummyT) $ truncate $ extend $ more
    end
  | baselens_tr _ = raise Match;
\<close>

parse_translation \<open>[(@{syntax_const "_BASELENS"}, K baselens_tr)]\<close>

text \<open>We also introduce the \textbf{alphabet} command that creates a record with lenses for each field.
  For each field a lens is created together with a proof that it is very well-behaved, and for each
  pair of lenses an independence theorem is generated. Alphabets can also be extended which yields
  sublens proofs between the extension field lens and record extension lenses. \<close>

named_theorems lens

ML_file \<open>Lens_Lib.ML\<close>
ML_file \<open>Lens_Record.ML\<close>

text \<open>The following theorem attribute stores splitting theorems for alphabet types which which is useful
  for proof automation.\<close>

named_theorems alpha_splits

text \<open> We supply a helpful tactic to remove the subscripted v characters from subgoals. These
  exist because the internal names of record fields have them. \<close>

method rename_alpha_vars = tactic \<open> Lens_Utils.rename_alpha_vars \<close>

subsection \<open>Locale State Spaces \<close>

text \<open> Alternative to the alphabet command, we also introduce the statespace command, which
  implements Schirmer and Wenzel's locale-based approach to state space modelling~\<^cite>\<open>"Schirmer2009"\<close>.

  It has the advantage of allowing multiple inheritance of state spaces, and also variable names are
  fully internalised with the locales. The approach is also far simpler than record-based state
  spaces.

  It has the disadvantage that variables may not be fully polymorphic, unlike for the
  alphabet command. This makes it in general unsuitable for UTP theory alphabets. \<close>

ML_file \<open>Lens_Statespace.ML\<close>

subsection \<open>Type Definition Lens\<close>

text \<open> Every type defined by a \<^bold>\<open>typedef\<close> command induces a partial bijective lens constructed
  using the abstraction and representation functions. \<close>

context type_definition
begin

definition typedef_lens :: "'b \<Longrightarrow> 'a" ("typedef\<^sub>L") where
[lens_defs]: "typedef\<^sub>L = \<lparr> lens_get = Abs, lens_put = (\<lambda> s. Rep) \<rparr>"

lemma pbij_typedef_lens [simp]: "pbij_lens typedef\<^sub>L"
  by (unfold_locales, simp_all add: lens_defs Rep_inverse)

lemma source_typedef_lens: "\<S>\<^bsub>typedef\<^sub>L\<^esub> = A"
  using Rep_cases by (auto simp add: lens_source_def lens_defs Rep)

lemma bij_typedef_lens_UNIV: "A = UNIV \<Longrightarrow> bij_lens typedef\<^sub>L"
  by (auto intro: pbij_vwb_is_bij_lens simp add: mwb_UNIV_src_is_vwb_lens source_typedef_lens)

end

subsection \<open>Mapper Lenses\<close>

definition lmap_lens ::
  "(('\<alpha> \<Rightarrow> '\<beta>) \<Rightarrow> ('\<gamma> \<Rightarrow> '\<delta>)) \<Rightarrow>
   (('\<beta> \<Rightarrow> '\<alpha>) \<Rightarrow> '\<delta> \<Rightarrow> '\<gamma>) \<Rightarrow>
   ('\<gamma> \<Rightarrow> '\<alpha>) \<Rightarrow>
   ('\<beta> \<Longrightarrow> '\<alpha>) \<Rightarrow>
   ('\<delta> \<Longrightarrow> '\<gamma>)" where
  [lens_defs]:
  "lmap_lens f g h l = \<lparr>
  lens_get = f (get\<^bsub>l\<^esub>),
  lens_put = g o (put\<^bsub>l\<^esub>) o h \<rparr>"

text \<open>
  The parse translation below yields a heterogeneous mapping lens for any
  record type. This achieved through the utility function above that
  constructs a functorial lens. This takes as input a heterogeneous mapping
  function that lifts a function on a record's extension type to an update
  on the entire record, and also the record's ``more'' function. The first input
  is given twice as it has different polymorphic types, being effectively
  a type functor construction which are not explicitly supported by HOL. We note
  that the \<open>more_update\<close> function does something similar to the extension lifting,
  but is not precisely suitable here since it only considers homogeneous functions,
  namely of type \<open>'a \<Rightarrow> 'a\<close> rather than \<open>'a \<Rightarrow> 'b\<close>.
\<close>

syntax
  "_lmap" :: "id \<Rightarrow> logic" ("lmap[_]")

ML \<open>
  fun lmap_tr [Free (name, _)] =
    let
      val extend = Free (name ^ ".extend", dummyT);
      val truncate = Free (name ^ ".truncate", dummyT);
      val more = Free (name ^ ".more", dummyT);
      val map_ext = Abs ("f", dummyT,
                    Abs ("r", dummyT,
                      extend $ (truncate $ Bound 0) $ (Bound 1 $ (more $ (Bound 0)))))

    in
      Const (@{const_syntax "lmap_lens"}, dummyT) $ map_ext $ map_ext $ more
    end
  | lmap_tr _ = raise Match;
\<close>

parse_translation \<open>[(@{syntax_const "_lmap"}, K lmap_tr)]\<close>

subsection \<open>Lens Interpretation\<close>

named_theorems lens_interp_laws

locale lens_interp = interp
begin
declare meta_interp_law [lens_interp_laws]
declare all_interp_law [lens_interp_laws]
declare exists_interp_law [lens_interp_laws]

end

subsection \<open> Tactic \<close>

text \<open> A simple tactic for simplifying lens expressions \<close>

declare split_paired_all [alpha_splits]

method lens_simp = (simp add: alpha_splits lens_defs prod.case_eq_if)

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_int_mul_ident_left
  imports "../../Test_Base"
begin

datatype Sign = Pos | Neg

datatype Nat = Z | S "Nat"

datatype Integer = P "Nat" | N "Nat"

fun toInteger :: "Sign => Nat => Integer" where
  "toInteger (Pos) y = P y"
| "toInteger (Neg) (Z) = P Z"
| "toInteger (Neg) (S z) = N z"

fun sign :: "Integer => Sign" where
  "sign (P y) = Pos"
| "sign (N z) = Neg"

fun pred :: "Nat => Nat" where
  "pred (S y) = y"

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

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

fun opposite :: "Sign => Sign" where
  "opposite (Pos) = Neg"
| "opposite (Neg) = Pos"

fun timesSign :: "Sign => Sign => Sign" where
  "timesSign (Pos) y = y"
| "timesSign (Neg) y = opposite y"

definition(*fun*) one :: "Integer" where
  "one = P (S Z)"

fun absVal :: "Integer => Nat" where
  "absVal (P n) = n"
| "absVal (N m) = plus (S Z) m"

fun times :: "Integer => Integer => Integer" where
  "times x y =
   toInteger
     (timesSign (sign x) (sign y)) (times2 (absVal x) (absVal y))"

theorem property0 :
  "(x = (times one x))"
  oops

end


(*<*)
theory Interval
  imports "HOL-Library.Extended_Nat" "HOL-Library.Product_Lexorder"
begin
(*>*)

section \<open>Intervals\<close>

typedef \<I> = "{(i :: nat, j :: enat). i \<le> j}"
  by (intro exI[of _ "(0, \<infinity>)"]) auto

setup_lifting type_definition_\<I>

instantiation \<I> :: equal begin
lift_definition equal_\<I> :: "\<I> \<Rightarrow> \<I> \<Rightarrow> bool" is "(=)" .
instance by standard (transfer, auto)
end

instantiation \<I> :: linorder begin
lift_definition less_eq_\<I> :: "\<I> \<Rightarrow> \<I> \<Rightarrow> bool" is "(\<le>)" .
lift_definition less_\<I> :: "\<I> \<Rightarrow> \<I> \<Rightarrow> bool" is "(<)" .
instance by standard (transfer, auto)+
end

lift_definition all :: \<I> is "(0, \<infinity>)" by simp
lift_definition left :: "\<I> \<Rightarrow> nat" is fst .
lift_definition right :: "\<I> \<Rightarrow> enat" is snd .
lift_definition point :: "nat \<Rightarrow> \<I>" is "\<lambda>n. (n, enat n)" by simp
lift_definition init :: "nat \<Rightarrow> \<I>" is "\<lambda>n. (0, enat n)" by auto
abbreviation mem where "mem n I \<equiv> (left I \<le> n \<and> n \<le> right I)"
lift_definition subtract :: "nat \<Rightarrow> \<I> \<Rightarrow> \<I>" is
  "\<lambda>n (i, j). (i - n, j - enat n)" by (auto simp: diff_enat_def split: enat.splits)
lift_definition add :: "nat \<Rightarrow> \<I> \<Rightarrow> \<I>" is
  "\<lambda>n (a, b). (a, b + enat n)" by (auto simp add: add_increasing2)

lemma left_right: "left I \<le> right I"
  by transfer auto

lemma point_simps[simp]:
  "left (point n) = n"
  "right (point n) = n"
  by (transfer; auto)+

lemma init_simps[simp]:
  "left (init n) = 0"
  "right (init n) = n"
  by (transfer; auto)+

lemma subtract_simps[simp]:
  "left (subtract n I) = left I - n"
  "right (subtract n I) = right I - n"
  "subtract 0 I = I"
  "subtract x (point y) = point (y - x)"
  by (transfer; auto)+

definition shifted :: "\<I> \<Rightarrow> \<I> set" where
  "shifted I = (\<lambda>n. subtract n I) ` {0 .. (case right I of \<infinity> \<Rightarrow> left I | enat n \<Rightarrow> n)}"

lemma subtract_shifted: "subtract n I \<in> shifted I"
  by (cases "n \<le> (case right I of \<infinity> \<Rightarrow> left I | enat n \<Rightarrow> n)")
    (auto simp: shifted_def subtract_too_much)

lemma finite_shifted: "finite (shifted I)"
  unfolding shifted_def by auto

definition interval :: "nat \<Rightarrow> enat \<Rightarrow> \<I>" where
  "interval l r = (if l \<le> r then Abs_\<I> (l, r) else undefined)"

lemma [code abstract]: "Rep_\<I> (interval l r) = (if l \<le> r then (l, r) else Rep_\<I> undefined)"
  unfolding interval_def using Abs_\<I>_inverse by simp

(*<*)
end
(*>*)