section \<open>\<open>One_Dimensional_Spaces\<close> -- One dimensional complex vector spaces\<close>

theory One_Dimensional_Spaces
  imports
    Complex_Inner_Product
    "Complex_Bounded_Operators.Extra_Operator_Norm"
begin

text \<open>The class \<open>one_dim\<close> applies to one-dimensional vector spaces.
     Those are additionally interpreted as \<^class>\<open>complex_algebra_1\<close>s
     via the canonical isomorphism between a one-dimensional vector space and
     \<^typ>\<open>complex\<close>.\<close>
class one_dim = onb_enum + one + times + inverse +
  assumes one_dim_canonical_basis[simp]: "canonical_basis = [1]"
  assumes one_dim_prod_scale1: "(a *\<^sub>C 1) * (b *\<^sub>C 1) = (a * b) *\<^sub>C 1"
  assumes divide_inverse: "x / y = x * inverse y"
  assumes one_dim_inverse: "inverse (a *\<^sub>C 1) = inverse a *\<^sub>C 1"

hide_fact (open) divide_inverse
  \<comment> \<open>@{thm [source] divide_inverse} from class \<^class>\<open>field\<close>, instantiated below, subsumes this fact.\<close>

instance complex :: one_dim
  apply intro_classes
  unfolding canonical_basis_complex_def is_ortho_set_def
  by (auto simp: divide_complex_def)

lemma one_cinner_one[simp]: \<open>(1::('a::one_dim)) \<bullet>\<^sub>C 1 = 1\<close>
proof-
  include notation_norm
  have \<open>(canonical_basis::'a list) = [1::('a::one_dim)]\<close>
    by simp
  hence \<open>\<parallel>1::'a::one_dim\<parallel> = 1\<close>
    by (metis is_normal list.set_intros(1))
  hence \<open>\<parallel>1::'a::one_dim\<parallel>^2 = 1\<close>
    by simp
  moreover have  \<open>\<parallel>(1::('a::one_dim))\<parallel>^2 = (1::('a::one_dim)) \<bullet>\<^sub>C 1\<close>
    by (metis cnorm_eq_square)
  ultimately show ?thesis by simp
qed

lemma one_cinner_a_scaleC_one[simp]: \<open>((1::'a::one_dim) \<bullet>\<^sub>C a) *\<^sub>C 1 = a\<close>
proof-
  have \<open>(canonical_basis::'a list) = [1]\<close>
    by simp
  hence r2: \<open>a \<in> complex_vector.span ({1::'a})\<close>
    using  iso_tuple_UNIV_I empty_set is_generator_set list.simps(15)
    by metis
  have "(1::'a) \<notin> {}"
    by (metis equals0D)
  hence r1: \<open>\<exists> s. a = s *\<^sub>C 1\<close>
    by (metis Diff_insert_absorb r2 complex_vector.span_breakdown
        complex_vector.span_empty eq_iff_diff_eq_0 singleton_iff)
  then obtain s where s_def: \<open>a = s *\<^sub>C 1\<close>
    by blast
  have  \<open>(1::'a) \<bullet>\<^sub>C a = (1::'a) \<bullet>\<^sub>C (s *\<^sub>C 1)\<close>
    using \<open>a = s *\<^sub>C 1\<close>
    by simp
  also have \<open>\<dots> = s * ((1::'a) \<bullet>\<^sub>C 1)\<close>
    by simp
  also have \<open>\<dots> = s\<close>
    using one_cinner_one by auto
  finally show ?thesis
    by (simp add: s_def)
qed

lemma one_dim_apply_is_times_def:
  "\<psi> * \<phi> = ((1 \<bullet>\<^sub>C \<psi>) * (1 \<bullet>\<^sub>C \<phi>)) *\<^sub>C 1" for \<psi> :: \<open>'a::one_dim\<close>
  by (metis one_cinner_a_scaleC_one one_dim_prod_scale1)

instance one_dim \<subseteq> complex_algebra_1
proof
  fix x y z :: \<open>'a::one_dim\<close> and c :: complex
  show "(x * y) * z = x * (y * z)"
    by (simp add: one_dim_apply_is_times_def[where ?'a='a])
  show "(x + y) * z = x * z + y * z"
    by (metis (no_types, lifting) cinner_simps(2) complex_vector.vector_space_assms(2) complex_vector.vector_space_assms(3) one_dim_apply_is_times_def)
  show "x * (y + z) = x * y + x * z"
    by (metis (mono_tags, lifting) cinner_simps(2) complex_vector.vector_space_assms(2) distrib_left one_dim_apply_is_times_def)
  show "(c *\<^sub>C x) * y = c *\<^sub>C (x * y)"
    by (simp add: one_dim_apply_is_times_def[where ?'a='a])
  show "x * (c *\<^sub>C y) = c *\<^sub>C (x * y)"
    by (simp add: one_dim_apply_is_times_def[where ?'a='a])
  show "1 * x = x"
    by (metis mult.left_neutral one_cinner_a_scaleC_one one_cinner_one one_dim_apply_is_times_def)
  show "x * 1 = x"
    by (simp add: one_dim_apply_is_times_def [where ?'a = 'a])
  show "(0::'a) \<noteq> 1"
    by (metis cinner_eq_zero_iff one_cinner_one zero_neq_one)
qed

instance one_dim \<subseteq> complex_normed_algebra
proof
  fix x y :: \<open>'a::one_dim\<close>
  show "norm (x * y) \<le> norm x * norm y"
  proof-
    have r1:  "cmod ((1::'a) \<bullet>\<^sub>C x) \<le> norm (1::'a) * norm x"
      by (simp add: complex_inner_class.Cauchy_Schwarz_ineq2)
    have r2: "cmod ((1::'a) \<bullet>\<^sub>C y) \<le> norm (1::'a) * norm y"
      by (simp add: complex_inner_class.Cauchy_Schwarz_ineq2)

    have q1: "(1::'a) \<bullet>\<^sub>C 1 = 1"
      by simp
    hence "(norm (1::'a))^2 = 1"
      by (simp add: cnorm_eq_1 power2_eq_1_iff)
    hence "norm (1::'a) = 1"
      by (smt abs_norm_cancel power2_eq_1_iff)
    hence "cmod (((1::'a) \<bullet>\<^sub>C x) * ((1::'a) \<bullet>\<^sub>C y)) * norm (1::'a) = cmod (((1::'a) \<bullet>\<^sub>C x) * ((1::'a) \<bullet>\<^sub>C y))"
      by simp
    also have "\<dots> = cmod (((1::'a) \<bullet>\<^sub>C x)) * cmod (((1::'a) \<bullet>\<^sub>C y))"
      by (simp add: norm_mult)
    also have "\<dots> \<le> norm (1::'a) * norm x * norm (1::'a) * norm y"
      by (smt \<open>norm 1 = 1\<close> mult.commute mult_cancel_right1 norm_scaleC one_cinner_a_scaleC_one)
    also have "\<dots> = norm x * norm y"
      by (simp add: \<open>norm 1 = 1\<close>)
    finally show ?thesis
      by (simp add: one_dim_apply_is_times_def[where ?'a='a])
  qed
qed

instance one_dim \<subseteq> complex_normed_algebra_1
proof intro_classes
  show "norm (1::'a) = 1"
    by (metis complex_inner_1_left norm_eq_sqrt_cinner norm_one one_cinner_one)
qed

text \<open>This is the canonical isomorphism between any two one dimensional spaces. Specifically,
  if 1 denotes the element of the canonical basis (which is specified by type class \<^class>\<open>basis_enum\<close>),
  then \<^term>\<open>one_dim_iso\<close> is the unique isomorphism that maps 1 to 1.\<close>
definition one_dim_iso :: "'a::one_dim \<Rightarrow> 'b::one_dim"
  where "one_dim_iso a = of_complex (1 \<bullet>\<^sub>C a)"

lemma one_dim_iso_idem[simp]: "one_dim_iso (one_dim_iso x) = one_dim_iso x"
  by (simp add: one_dim_iso_def)

lemma one_dim_iso_id[simp]: "one_dim_iso = id"
  unfolding one_dim_iso_def
  by (auto simp add: of_complex_def)

lemma one_dim_iso_adjoint[simp]: \<open>cadjoint one_dim_iso = one_dim_iso\<close>
  apply (rule cadjoint_eqI)
  by (simp add: one_dim_iso_def of_complex_def)

lemma one_dim_iso_is_of_complex[simp]: "one_dim_iso = of_complex"
  unfolding one_dim_iso_def by auto

lemma of_complex_one_dim_iso[simp]: "of_complex (one_dim_iso \<psi>) = one_dim_iso \<psi>"
  by (metis one_dim_iso_is_of_complex one_dim_iso_idem)

lemma one_dim_iso_of_complex[simp]: "one_dim_iso (of_complex c) = of_complex c"
  by (metis one_dim_iso_is_of_complex one_dim_iso_idem)

lemma one_dim_iso_add[simp]:
  \<open>one_dim_iso (a + b) = one_dim_iso a + one_dim_iso b\<close>
  by (simp add: cinner_simps(2) one_dim_iso_def)

lemma one_dim_iso_minus[simp]:
  \<open>one_dim_iso (a - b) = one_dim_iso a - one_dim_iso b\<close>
  by (simp add: cinner_simps(3) one_dim_iso_def)

lemma one_dim_iso_scaleC[simp]: "one_dim_iso (c *\<^sub>C \<psi>) = c *\<^sub>C one_dim_iso \<psi>"
  by (metis cinner_scaleC_right of_complex_mult one_dim_iso_def scaleC_conv_of_complex)

lemma clinear_one_dim_iso[simp]: "clinear one_dim_iso"
  by (rule clinearI, auto)

lemma bounded_clinear_one_dim_iso[simp]: "bounded_clinear one_dim_iso"
proof (rule bounded_clinear_intro [where K = 1] , auto)
  fix x :: \<open>'a::one_dim\<close>
  show "norm (one_dim_iso x) \<le> norm x"
    by (metis (full_types) norm_of_complex of_complex_def one_cinner_a_scaleC_one one_dim_iso_def
        order_refl)
qed

lemma one_dim_iso_of_one[simp]: "one_dim_iso 1 = 1"
  by (simp add: one_dim_iso_def)

lemma onorm_one_dim_iso[simp]: "onorm one_dim_iso = 1"
proof (rule onormI [where b = 1 and x = 1])
  fix x :: \<open>'a::one_dim\<close>
  have "norm (one_dim_iso x ::'b) \<le> norm x"
    by (metis eq_iff norm_of_complex of_complex_def one_cinner_a_scaleC_one one_dim_iso_def)
  thus "norm (one_dim_iso (x::'a)::'b) \<le> 1 * norm x"
    by auto
  show "(1::'a) \<noteq> 0"
    by simp
  show "norm (one_dim_iso (1::'a)::'b) = 1 * norm (1::'a)"
    by auto
qed

lemma one_dim_iso_times[simp]: "one_dim_iso (\<psi> * \<phi>) = one_dim_iso \<psi> * one_dim_iso \<phi>"
  by (metis mult.left_neutral mult_scaleC_left of_complex_def one_cinner_a_scaleC_one one_dim_iso_def one_dim_iso_scaleC)

lemma one_dim_iso_of_zero[simp]: "one_dim_iso 0 = 0"
  by (simp add: complex_vector.linear_0)

lemma one_dim_iso_of_zero': "one_dim_iso x = 0 \<Longrightarrow> x = 0"
  by (metis of_complex_def of_complex_eq_0_iff one_cinner_a_scaleC_one one_dim_iso_def)

lemma one_dim_scaleC_1[simp]: "one_dim_iso x *\<^sub>C 1 = x"
  by (simp add: one_dim_iso_def)

lemma one_dim_clinear_eqI:
  assumes "(x::'a::one_dim) \<noteq> 0" and "clinear f" and "clinear g" and "f x = g x"
  shows "f = g"
proof (rule ext)
  fix y :: 'a
  from \<open>f x = g x\<close>
  have \<open>one_dim_iso x *\<^sub>C f 1 = one_dim_iso x *\<^sub>C g 1\<close>
    by (metis assms(2) assms(3) complex_vector.linear_scale one_dim_scaleC_1)
  hence "f 1 = g 1"
    using assms(1) one_dim_iso_of_zero' by auto
  then show "f y = g y"
    by (metis assms(2) assms(3) complex_vector.linear_scale one_dim_scaleC_1)
qed

lemma one_dim_norm: "norm x = cmod (one_dim_iso x)"
proof (subst one_dim_scaleC_1 [symmetric])
  show "norm (one_dim_iso x *\<^sub>C (1::'a)) = cmod (one_dim_iso x)"
    by (metis norm_of_complex of_complex_def)
qed

lemma one_dim_onorm:
  fixes f :: "'a::one_dim \<Rightarrow> 'b::complex_normed_vector"
  assumes "clinear f"
  shows "onorm f = norm (f 1)"
proof (rule onormI[where x=1])
  fix x :: 'a
  have "norm x * norm (f 1) \<le> norm (f 1) * norm x"
    by simp
  hence "norm (f (one_dim_iso x *\<^sub>C 1)) \<le> norm (f 1) * norm x"
    by (metis (mono_tags, lifting) assms complex_vector.linear_scale norm_scaleC one_dim_norm)
  thus "norm (f x) \<le> norm (f 1) * norm x"
    by (subst one_dim_scaleC_1 [symmetric])
qed auto

lemma one_dim_onorm':
  fixes f :: "'a::one_dim \<Rightarrow> 'b::one_dim"
  assumes "clinear f"
  shows "onorm f = cmod (one_dim_iso (f 1))"
  using assms one_dim_norm one_dim_onorm by fastforce

instance one_dim \<subseteq> zero_neq_one ..

lemma one_dim_iso_inj: "one_dim_iso x = one_dim_iso y \<Longrightarrow> x = y"
  by (metis one_dim_iso_idem one_dim_scaleC_1)

instance one_dim \<subseteq> comm_ring
proof intro_classes
  fix x y z :: 'a
  show "x * y = y * x"
    by (metis one_dim_apply_is_times_def ordered_field_class.sign_simps(5))
  show "(x + y) * z = x * z + y * z"
    by (simp add: ring_class.ring_distribs(2))
qed

instance one_dim \<subseteq> field
proof intro_classes
  fix x y z :: \<open>'a::one_dim\<close>
  show "1 * x = x"
    by simp

  have "(inverse ((1::'a) \<bullet>\<^sub>C x) * ((1::'a) \<bullet>\<^sub>C x)) *\<^sub>C (1::'a) = 1" if "x \<noteq> 0"
    by (metis left_inverse of_complex_def one_cinner_a_scaleC_one one_dim_iso_of_zero
        one_dim_iso_is_of_complex one_dim_iso_of_one that)
  hence "inverse (((1::'a) \<bullet>\<^sub>C x) *\<^sub>C 1) * ((1::'a) \<bullet>\<^sub>C x) *\<^sub>C 1 = (1::'a)" if "x \<noteq> 0"
    by (metis one_dim_inverse one_dim_prod_scale1 that)
  hence "inverse (((1::'a) \<bullet>\<^sub>C x) *\<^sub>C 1) * x = 1" if "x \<noteq> 0"
    using one_cinner_a_scaleC_one[of x, symmetric] that by auto
  thus "inverse x * x = 1" if "x \<noteq> 0"
    by (simp add: that)
  show "x / y = x * inverse y"
    by (simp add: one_dim_class.divide_inverse)
  show "inverse (0::'a) = 0"
    by (subst complex_vector.scale_zero_left[symmetric], subst one_dim_inverse, simp)
qed

instance one_dim \<subseteq> complex_normed_field
proof intro_classes
  fix x y :: 'a
  show "norm (x * y) = norm x * norm y"
    by (metis norm_mult one_dim_iso_times one_dim_norm)
qed

instance one_dim \<subseteq> chilbert_space..

lemma ccspan_one_dim[simp]: \<open>ccspan {x} = top\<close> if \<open>x \<noteq> 0\<close> for x :: \<open>_ :: one_dim\<close>
proof -
  have \<open>y \<in> cspan {x}\<close> for y
    using that by (metis complex_vector.span_base complex_vector.span_zero cspan_singleton_scaleC insertI1 one_dim_scaleC_1 scaleC_zero_left)
  then show ?thesis
    by (auto intro!: order.antisym ccsubspace_leI
      simp: top_ccsubspace.rep_eq ccspan.rep_eq)
qed

lemma one_dim_ccsubspace_all_or_nothing: \<open>A = bot \<or> A = top\<close> for A :: \<open>_::one_dim ccsubspace\<close>
proof (rule Meson.disj_comm, rule disjCI)
  assume \<open>A \<noteq> bot\<close>
  then obtain \<psi> where \<open>\<psi> \<in> space_as_set A\<close> and \<open>\<psi> \<noteq> 0\<close>
    by (metis ccsubspace_eqI singleton_iff space_as_set_bot zero_space_as_set)
  then have \<open>A \<ge> ccspan {\<psi>}\<close> (is \<open>_ \<ge> \<dots>\<close>)
    by (metis bot.extremum ccspan_leqI insert_absorb insert_mono)
  also have \<open>\<dots> = ccspan {one_dim_iso \<psi> *\<^sub>C 1}\<close>
    by auto
  also have \<open>\<dots> = ccspan {1}\<close>
    apply (rule ccspan_singleton_scaleC)
    using \<open>\<psi> \<noteq> 0\<close> one_dim_iso_of_zero' by auto
  also have \<open>\<dots> = top\<close>
    by auto
  finally show \<open>A = top\<close>
    by (simp add: top.extremum_uniqueI)
qed

lemma scaleC_1_right[simp]: \<open>scaleC x (1::'a::one_dim) = of_complex x\<close>
  unfolding of_complex_def by simp

end


theory Short_Theory_11_1
  imports "HOL-IMP.BExp" "HOL-IMP.Star"
begin

datatype
  com = SKIP
  | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
  | Seq    com  com         ("_;;/ _"  [60, 61] 60)
  | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 60, 61] 61)
  | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)
  | Repeat com bexp         ("(REPEAT _/ UNTIL _)" [60, 0] 61)

inductive big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55) where
    Skip: "(SKIP,s) \<Rightarrow> s" |
    Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
    Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
    IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
    IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
    WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
    WhileTrue: "\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
      \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
    RepeatTrue: "\<lbrakk> bval b t; (c, s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (REPEAT c UNTIL b, s) \<Rightarrow> t" |
    RepeatFalse: "\<lbrakk> \<not>bval b s\<^sub>2; (c, s\<^sub>1) \<Rightarrow> s\<^sub>2; (REPEAT c UNTIL b, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
      \<Longrightarrow> (REPEAT c UNTIL b, s\<^sub>1) \<Rightarrow> s\<^sub>3"
lemmas big_step_induct = big_step.induct[split_format(complete)]
declare big_step.intros [intro]

lemma BS_SkipE[elim!]: "\<lbrakk>(SKIP, s) \<Rightarrow> t; t = s \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (cases rule: big_step.cases) auto
lemma BS_AssignE[elim!]: "\<lbrakk>(x ::= a, s) \<Rightarrow> t; t = s(x := aval a s) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (cases rule: big_step.cases) auto
lemma BS_SeqE[elim!]: "\<lbrakk>(c\<^sub>1;; c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3;
 \<And>s\<^sub>2. \<lbrakk>(c\<^sub>1, s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2, s\<^sub>2) \<Rightarrow> s\<^sub>3\<rbrakk> \<Longrightarrow> P\<rbrakk>
\<Longrightarrow> P"
  by (cases rule: big_step.cases) auto
lemma BS_IfE[elim!]: "\<lbrakk>
  (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t;
  \<lbrakk>bval b s; (c\<^sub>1, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P;
  \<lbrakk>\<not> bval b s; (c\<^sub>2, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
  by (cases rule: big_step.cases) auto
lemma BS_WhileE[elim]: "\<lbrakk>
  (WHILE b DO c, s) \<Rightarrow> t;
  \<lbrakk>\<not> bval b t; s = t\<rbrakk> \<Longrightarrow> P;
  \<And>s\<^sub>2. \<lbrakk>bval b s; (c, s) \<Rightarrow> s\<^sub>2; (WHILE b DO c, s\<^sub>2) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
  by (cases rule: big_step.cases) auto
lemma BS_RepeatE[elim]: "\<lbrakk>
  (REPEAT c UNTIL b, s) \<Rightarrow> t;
  \<lbrakk>bval b t; (c, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P;
  \<And>s\<^sub>2. \<lbrakk>\<not> bval b s\<^sub>2; (c, s) \<Rightarrow> s\<^sub>2; (REPEAT c UNTIL b, s\<^sub>2) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
  by (cases rule: big_step.cases) auto

abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"

theorem big_step_determ: "\<lbrakk> (c,s) \<Rightarrow> t; (c,s) \<Rightarrow> u \<rbrakk> \<Longrightarrow> u = t"
  by (induct arbitrary: u rule: big_step.induct) blast+

inductive small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
  where
    Assign: "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |
    Seq1: "(SKIP;; c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" |
    Seq2: "(c\<^sub>1, s) \<rightarrow> (c\<^sub>1', s') \<Longrightarrow> (c\<^sub>1;; c\<^sub>2, s) \<rightarrow> (c\<^sub>1';; c\<^sub>2, s')" |
    IfTrue: "bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>1, s)" |
    IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" |
    While: "(WHILE b DO c, s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP, s)" |
    Repeat: "(REPEAT c UNTIL b, s) \<rightarrow> (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b, s)"

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

lemmas small_step_induct = small_step.induct[split_format(complete)]
declare small_step.intros[simp,intro]

lemma SS_SkipE[elim!]: "(SKIP, s) \<rightarrow> ct \<Longrightarrow> P"
  by (cases rule: small_step.cases) auto
lemma SS_AssignE[elim!]: "\<lbrakk>(x ::= a, s) \<rightarrow> ct; ct = (SKIP, s(x := aval a s)) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (cases rule: small_step.cases) auto
lemma SS_SeqE[elim]: "\<lbrakk>
  (c1;; c2, s) \<rightarrow> ct;
  \<lbrakk>ct = (c2, s); c1 = SKIP\<rbrakk> \<Longrightarrow> P;
  \<And>c\<^sub>1' s'. \<lbrakk>ct = (c\<^sub>1';; c2, s'); (c1, s) \<rightarrow> (c\<^sub>1', s')\<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
  by (cases rule: small_step.cases) auto
lemma SS_IfE[elim!]: "\<lbrakk>
  (IF b THEN c1 ELSE c2, s) \<rightarrow> ct;
  \<lbrakk>ct = (c1, s); bval b s\<rbrakk> \<Longrightarrow> P;
  \<lbrakk>ct = (c2, s); \<not> bval b s\<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
  by (cases rule: small_step.cases) auto
lemma SS_WhileE[elim]: "\<lbrakk>
  (WHILE b DO c, s) \<rightarrow> ct;
  ct = (IF b THEN c;; WHILE b DO c ELSE SKIP, s) \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
  by (cases rule: small_step.cases) auto
lemma SS_RepeatE[elim]: "\<lbrakk>
  (REPEAT c UNTIL b, s) \<rightarrow> ct;
  ct = (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b, s) \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
  by (cases rule: small_step.cases) auto

lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
  by (induct rule: star_induct) (simp, blast intro: star.step)

lemma seq_comp: "\<lbrakk>(c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (SKIP,s3)\<rbrakk>
  \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (SKIP,s3)"
  by (blast intro: star.step star_seq2 star_trans)

lemma big_to_small: "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
  by (induction rule: big_step.induct) (blast intro: seq_comp star.step)+

lemma small1_big_continue: "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
  by (induct arbitrary: t rule: small_step.induct) auto

lemma small_to_big: "cs \<rightarrow>* (SKIP,t) \<Longrightarrow> cs \<Rightarrow> t"
  by (induct cs "(SKIP,t)" rule: star.induct) (auto intro: small1_big_continue)

theorem big_iff_small: "cs \<Rightarrow> t = cs \<rightarrow>* (SKIP,t)"
  by (blast intro: big_to_small small_to_big)

section \<open>Denotational\<close>

type_synonym com_den = "(state \<times> state) set"

definition W :: "(state \<Rightarrow> bool) \<Rightarrow> com_den \<Rightarrow> (com_den \<Rightarrow> com_den)" where
  "W db dc = (\<lambda>dw. {(s, t). if db s then (s,t) \<in> dc O dw else s=t})"

definition R :: "com_den \<Rightarrow> (state \<Rightarrow> bool) \<Rightarrow> (com_den \<Rightarrow> com_den)" where
  "R dc db = (\<lambda>dr. dc O {(s, t). if db s then s = t else (s, t) \<in> dr})"

fun D :: "com \<Rightarrow> com_den" where
  "D SKIP = Id" |
  "D (x ::= a) = {(s,t). t = s(x := aval a s)}" |
  "D (c1;; c2)  = D c1 O D c2" |
  "D (IF b THEN c1 ELSE c2)
    = {(s,t). if bval b s then (s, t) \<in> D c1 else (s, t) \<in> D c2}" |
  "D (WHILE b DO c) = lfp (W (bval b) (D c))" |
  "D (REPEAT c UNTIL b) = lfp (R (D c) (bval b))"

lemma W_mono: "mono (W b c)"
  by (unfold W_def mono_def) auto

lemma R_mono: "mono (R c b)"
  by (unfold R_def mono_def) auto

lemma D_While_If:
  "D (WHILE b DO c) = D (IF b THEN c;; WHILE b DO c ELSE SKIP)"
proof-
  let ?w = "WHILE b DO c" let ?f = "W (bval b) (D c)"
  have "D ?w = lfp ?f" by simp
  also have "\<dots> = ?f (lfp ?f)" by(rule lfp_unfold [OF W_mono])
  also have "\<dots> = D(IF b THEN c;;?w ELSE SKIP)" by (simp add: W_def)
  finally show ?thesis .
qed

lemma D_Repeat_If:
  "D (REPEAT c UNTIL b) = D (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b)"
proof-
  let ?r = "REPEAT c UNTIL b" let ?f = "R (D c) (bval b)"
  have "D ?r = lfp ?f" by simp
  also have "\<dots> = ?f (lfp ?f)" by(rule lfp_unfold [OF R_mono])
  also have "\<dots> = D (c;; IF b THEN SKIP ELSE ?r)" by (simp add: R_def)
  finally show ?thesis .
qed

text\<open>Equivalence of denotational and big-step semantics:\<close>

lemma D_if_big_step:  "(c,s) \<Rightarrow> t \<Longrightarrow> (s,t) \<in> D(c)"
proof (induction rule: big_step_induct)
  case (WhileFalse b s c)
  show ?case unfolding D_While_If using WhileFalse by auto
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  show ?case unfolding D_While_If using WhileTrue(1, 4, 5) by auto
next
  case (RepeatTrue b t c s)
  show ?case unfolding D_Repeat_If using RepeatTrue(1, 3) by auto
next
  case (RepeatFalse b s\<^sub>2 c s\<^sub>1 s\<^sub>3)
  show ?case unfolding D_Repeat_If using RepeatFalse(1, 4, 5) by auto
qed auto

abbreviation Big_step :: "com \<Rightarrow> com_den" where
"Big_step c \<equiv> {(s,t). (c,s) \<Rightarrow> t}"

lemma Big_step_if_D:  "(s,t) \<in> D(c) \<Longrightarrow> (s,t) \<in> Big_step c"
proof (induction c arbitrary: s t)
  case (Seq c1 c2) thus ?case by fastforce
next
  case (While b c)
  let ?B = "Big_step (WHILE b DO c)" let ?f = "W (bval b) (D c)"
  have "?f ?B \<subseteq> ?B" using While.IH by (auto simp: W_def)
  from lfp_lowerbound[where ?f = "?f", OF this] While.prems
  show ?case by auto
next
  case (Repeat c b)
  let ?B = "Big_step (REPEAT c UNTIL b)" let ?f = "R (D c) (bval b)"
  have "?f ?B \<subseteq> ?B" using Repeat.IH by (auto simp: R_def)
  from lfp_lowerbound[where ?f = "?f", OF this] Repeat.prems
  show ?case by auto
qed (auto split: if_splits)

theorem denotational_is_big_step:
  "(s,t) \<in> D(c)  =  ((c,s) \<Rightarrow> t)"
by (metis D_if_big_step Big_step_if_D[simplified])

corollary equiv_c_iff_equal_D: "(c1 \<sim> c2) \<longleftrightarrow> D c1 = D c2"
  by(simp add: denotational_is_big_step[symmetric] set_eq_iff)

subsection "Continuity"

definition chain :: "(nat \<Rightarrow> 'a set) \<Rightarrow> bool" where
"chain S = (\<forall>i. S i \<subseteq> S(Suc i))"

lemma chain_total: "chain S \<Longrightarrow> S i \<le> S j \<or> S j \<le> S i"
by (metis chain_def le_cases lift_Suc_mono_le)

definition cont :: "('a set \<Rightarrow> 'b set) \<Rightarrow> bool" where
"cont f = (\<forall>S. chain S \<longrightarrow> f(UN n. S n) = (UN n. f(S n)))"

lemma mono_if_cont: fixes f :: "'a set \<Rightarrow> 'b set"
  assumes "cont f" shows "mono f"
proof
  fix a b :: "'a set" assume "a \<subseteq> b"
  let ?S = "\<lambda>n::nat. if n=0 then a else b"
  have "chain ?S" using \<open>a \<subseteq> b\<close> by(auto simp: chain_def)
  hence "f(UN n. ?S n) = (UN n. f(?S n))"
    using assms by (simp add: cont_def del: if_image_distrib)
  moreover have "(UN n. ?S n) = b" using \<open>a \<subseteq> b\<close> by (auto split: if_splits)
  moreover have "(UN n. f(?S n)) = f a \<union> f b" by (auto split: if_splits)
  ultimately show "f a \<subseteq> f b" by (metis Un_upper1)
qed

lemma chain_iterates: fixes f :: "'a set \<Rightarrow> 'a set"
  assumes "mono f" shows "chain(\<lambda>n. (f^^n) {})"
proof-
  have "(f ^^ n) {} \<subseteq> (f ^^ Suc n) {}" for n
  proof (induction n)
    case 0 show ?case by simp
  next
    case (Suc n) thus ?case using assms by (auto simp: mono_def)
  qed
  thus ?thesis by(auto simp: chain_def assms)
qed

theorem lfp_if_cont:
  assumes "cont f" shows "lfp f = (UN n. (f^^n) {})" (is "_ = ?U")
proof
  from assms mono_if_cont
  have mono: "(f ^^ n) {} \<subseteq> (f ^^ Suc n) {}" for n
    using funpow_decreasing [of n "Suc n"] by auto
  show "lfp f \<subseteq> ?U"
  proof (rule lfp_lowerbound)
    have "f ?U = (UN n. (f^^Suc n){})"
      using chain_iterates[OF mono_if_cont[OF assms]] assms
      by(simp add: cont_def)
    also have "\<dots> = (f^^0){} \<union> \<dots>" by simp
    also have "\<dots> = ?U"
      using mono by auto (metis funpow_simps_right(2) funpow_swap1 o_apply)
    finally show "f ?U \<subseteq> ?U" by simp
  qed
next
  have "(f^^n){} \<subseteq> p" if "f p \<subseteq> p" for n p
  proof -
    show ?thesis
    proof(induction n)
      case 0 show ?case by simp
    next
      case Suc
      from monoD[OF mono_if_cont[OF assms] Suc] \<open>f p \<subseteq> p\<close>
      show ?case by simp
    qed
  qed
  thus "?U \<subseteq> lfp f" by(auto simp: lfp_def)
qed

lemma cont_W: "cont(W b r)"
by(auto simp: cont_def W_def)

lemma cont_R: "cont(R c b)"
  by(auto simp: cont_def R_def)

subsection\<open>The denotational semantics is deterministic\<close>

lemma single_valued_UN_chain:
  assumes "chain S" "(\<And>n. single_valued (S n))"
  shows "single_valued(UN n. S n)"
proof(auto simp: single_valued_def)
  fix m n x y z assume "(x, y) \<in> S m" "(x, z) \<in> S n"
  with chain_total[OF assms(1), of m n] assms(2)
  show "y = z" by (auto simp: single_valued_def)
qed

lemma single_valued_lfp: fixes f :: "com_den \<Rightarrow> com_den"
assumes "cont f" "\<And>r. single_valued r \<Longrightarrow> single_valued (f r)"
shows "single_valued(lfp f)"
unfolding lfp_if_cont[OF assms(1)]
proof(rule single_valued_UN_chain[OF chain_iterates[OF mono_if_cont[OF assms(1)]]])
  fix n show "single_valued ((f ^^ n) {})"
  by(induction n)(auto simp: assms(2))
qed

lemma single_valued_D: "single_valued (D c)"
proof(induction c)
  case Seq thus ?case by(simp add: single_valued_relcomp)
next
  case (While b c)
  let ?f = "W (bval b) (D c)"
  have "single_valued (lfp ?f)"
  proof(rule single_valued_lfp[OF cont_W])
    show "\<And>r. single_valued r \<Longrightarrow> single_valued (?f r)"
      using While.IH by(force simp: single_valued_def W_def)
  qed
  thus ?case by simp
next
  case (Repeat c b)
  let ?f = "R (D c) (bval b)"
  have "single_valued (lfp ?f)"
  proof(rule single_valued_lfp[OF cont_R])
    show "\<And>r. single_valued r \<Longrightarrow> single_valued (?f r)"
      using Repeat.IH by(force simp: single_valued_def R_def)
  qed
  thus ?case by simp
qed (auto simp add: single_valued_def)

end


theory Subst_Term
  imports Chain
begin

definition well_formed_subst :: "(('d::fs_name) list \<times> ('e::fs_name) list) list \<Rightarrow> bool" where "well_formed_subst \<sigma> = ((filter (\<lambda>(xvec, Tvec). \<not>(length xvec = length Tvec \<and> distinct xvec)) \<sigma>) = [])"

locale subst_type =
  fixes subst :: "'a::fs_name \<Rightarrow> name list \<Rightarrow> 'b::fs_name list \<Rightarrow> 'a" ("_[_::=_]" [80, 80 ,80] 130)

  assumes eq[eqvt]: "\<And>p::name prm. (p \<bullet> (M[xvec::=Tvec])) = ((p \<bullet> M)[(p \<bullet> xvec)::=(p \<bullet> Tvec)])"
  and renaming:     "\<And>xvec Tvec p T. \<lbrakk>length xvec = length Tvec; (set p) \<subseteq> set xvec \<times> set (p \<bullet> xvec);
                                      distinct_perm p; (p \<bullet> xvec) \<sharp>* T\<rbrakk> \<Longrightarrow>
                                      T[xvec::=Tvec] = (p \<bullet> T)[(p \<bullet> xvec)::=Tvec]"
begin

lemma supp_subst:
  fixes M    :: 'a
  and   xvec :: "name list"
  and   Tvec :: "'b list"

  shows "(supp(M[xvec::=Tvec])::name set) \<subseteq> ((supp M) \<union> (supp xvec) \<union> (supp Tvec))"
proof(auto simp add: eqvts supp_def)
  fix x::name
  let ?P = "\<lambda>y. ([(x, y)] \<bullet> M)[([(x, y)] \<bullet> xvec)::=([(x, y)] \<bullet> Tvec)] \<noteq> M[xvec::=Tvec]"
  let ?Q = "\<lambda>y M. ([(x, y)] \<bullet> M) \<noteq> (M::'a)"
  let ?R = "\<lambda>y xvec. ([(x, y)] \<bullet> xvec) \<noteq> (xvec::name list)"
  let ?S = "\<lambda>y Tvec. ([(x, y)] \<bullet> Tvec) \<noteq> (Tvec::'b list)"
  assume A: "finite {y. ?Q y M}" and B: "finite {y. ?R y xvec}" and C: "finite {y. ?S y Tvec}" and D: "infinite {y. ?P(y)}"
  hence "infinite({y. ?P(y)} - {y. ?Q y M}  - {y. ?R y xvec}  - {y. ?S y Tvec})"
    by(auto intro: Diff_infinite_finite)
  hence "infinite({y. ?P(y) \<and> \<not>(?Q y M) \<and> \<not> (?R y xvec) \<and> \<not> (?S y Tvec)})" by(simp add: set_diff_eq)
  moreover have "{y. ?P(y) \<and> \<not>(?Q y M) \<and> \<not> (?R y xvec) \<and> \<not> (?S y Tvec)} = {}" by auto
  ultimately have "infinite {}" by(drule_tac Infinite_cong) auto
  thus False by simp
qed

lemma subst2[intro]:
  fixes x    :: name
  and   M    :: 'a
  and   xvec :: "name list"
  and   Tvec :: "'b list"

  assumes "x \<sharp> M"
  and     "x \<sharp> xvec"
  and     "x \<sharp> Tvec"

  shows "x \<sharp> M[xvec::=Tvec]"
using assms supp_subst
by(auto simp add: fresh_def)

lemma subst2_chain[intro]:
  fixes yvec :: "name list"
  and   M    :: 'a
  and   xvec :: "name list"
  and   Tvec :: "'b list"

  assumes "yvec \<sharp>* M"
  and     "yvec \<sharp>* xvec"
  and     "yvec \<sharp>* Tvec"

  shows "yvec \<sharp>* M[xvec::=Tvec]"
using assms
by(induct yvec) auto

lemma fs[simp]: "finite ((supp subst)::name set)"
by(simp add: supp_def perm_fun_def eqvts)
(*
lemma subst1_chain:
  fixes xvec :: "name list"
  and   Tvec :: "'b list"
  and   Xs   :: "name set"
  and   T    :: 'a

  assumes "length xvec = length Tvec"
  and     "distinct xvec"
  and     "Xs \<sharp>* T[xvec::=Tvec]"
  and     "Xs \<sharp>* xvec"

  shows "Xs \<sharp>* T"
using assms
by(auto intro: subst1 simp add: fresh_star_def)
*)
lemma subst4_chain:
  fixes xvec :: "name list"
  and   Tvec :: "'b list"
  and   T    :: 'a

  assumes "length xvec = length Tvec"
  and     "distinct xvec"
  and     "xvec \<sharp>* Tvec"

  shows "xvec \<sharp>* T[xvec::=Tvec]"
proof -
  obtain p where "((p::name prm) \<bullet> (xvec::name list)) \<sharp>* T" and "(p \<bullet> xvec) \<sharp>* xvec"
             and S: "(set p) \<subseteq> set xvec \<times> set (p \<bullet> xvec)"
             and "distinct_perm p"
    by(rule_tac xvec=xvec and c="(T, xvec)" in name_list_avoiding) auto

  from `length xvec = length Tvec` have "length(p \<bullet> xvec) = length Tvec" by simp
  moreover from `(p \<bullet> xvec) \<sharp>* T` have "(p \<bullet> p \<bullet> xvec) \<sharp>* (p \<bullet> T)"
    by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
  with `distinct_perm p` have "xvec \<sharp>* (p \<bullet> T)" by simp
  ultimately have "(set xvec) \<sharp>* (p \<bullet> T)[(p \<bullet> xvec)::=Tvec]" using `xvec \<sharp>* Tvec` `(p \<bullet> xvec) \<sharp>* xvec`
    by auto

  thus ?thesis using `length xvec = length Tvec` `distinct xvec` S `(p \<bullet> xvec) \<sharp>* T` `distinct_perm p`
    by(simp add: renaming)
qed

definition seq_subst :: "'a \<Rightarrow> (name list \<times> 'b list) list \<Rightarrow> 'a" ("_[<_>]" [80, 80] 130)
  where "M[<\<sigma>>] \<equiv> foldl (\<lambda>N. \<lambda>(xvec, Tvec). N[xvec::=Tvec]) M \<sigma>"

lemma seq_subst_nil[simp]:
  "seq_subst M [] = M"
by(simp add: seq_subst_def)

lemma seq_subst_cons[simp]:
  shows "seq_subst M ((xvec, Tvec)#\<sigma>) = seq_subst(M[xvec::=Tvec]) \<sigma>"
  by(simp add: seq_subst_def)

lemma seq_subst_term_append[simp]:
  shows "seq_subst M (\<sigma>@\<sigma>') = seq_subst (seq_subst M \<sigma>) \<sigma>'"
by(induct \<sigma>) (auto simp add: seq_subst_def)

lemma well_formed_subst_eqvt[eqvt]:
  fixes \<sigma> :: "(('d::fs_name) list \<times> ('e::fs_name) list) list"
  and   p :: "name prm"

  shows "p \<bullet> (well_formed_subst \<sigma>) = well_formed_subst(p \<bullet> \<sigma>)"
by(induct \<sigma> arbitrary: p) (auto simp add: eqvts well_formed_subst_def)

lemma well_formed_simp[simp]:
  fixes \<sigma> :: "(('d::fs_name) list \<times> ('e::fs_name) list) list"
  and   p :: "name prm"

  shows "well_formed_subst(p \<bullet> \<sigma>) = well_formed_subst \<sigma>"
by(induct \<sigma>) (auto simp add: eqvts well_formed_subst_def)

lemma well_formed_nil[simp]:
  "well_formed_subst []"
by(simp add: well_formed_subst_def)

lemma well_formed_cons[simp]:
  shows "well_formed_subst((xvec, Tvec)#\<sigma>) = (length xvec = length Tvec \<and> distinct xvec \<and> well_formed_subst \<sigma>)"
by(simp add: well_formed_subst_def) auto

lemma well_formed_append[simp]:
  fixes \<sigma>  :: "(('d::fs_name) list \<times> ('e::fs_name) list) list"
  and   \<sigma>' :: "(('d::fs_name) list \<times> ('e::fs_name) list) list"

  shows "well_formed_subst(\<sigma>@\<sigma>') = (well_formed_subst \<sigma> \<and> well_formed_subst \<sigma>')"
by(simp add: well_formed_subst_def)

lemma seq_subst2[intro]:
  fixes \<sigma> :: "(name list \<times> 'b list) list"
  and   T :: 'a
  and   x :: name

  assumes "x \<sharp> \<sigma>"
  and     "x \<sharp> T"

  shows "x \<sharp> T[<\<sigma>>]"
using assms
by(induct \<sigma> arbitrary: T) (clarsimp |  blast)+

lemma seq_subst2_chain[intro]:
  fixes \<sigma>    :: "(name list \<times> 'b list) list"
  and   T    :: 'a
  and   xvec :: "name list"

  assumes "xvec \<sharp>* \<sigma>"
  and     "xvec \<sharp>* T"

  shows "xvec \<sharp>* T[<\<sigma>>]"
using assms
by(induct xvec) auto

end

locale strong_subst_type =
  fixes subst :: "'a::fs_name \<Rightarrow> name list \<Rightarrow> 'b::fs_name list \<Rightarrow> 'a" ("_[_::=_]" [80, 80 ,80] 130)

  assumes eq[eqvt]: "\<And>p::name prm. (p \<bullet> (M[xvec::=Tvec])) = ((p \<bullet> M)[(p \<bullet> xvec)::=(p \<bullet> Tvec)])"
  and subst3:       "\<And>xvec Tvec T x. \<lbrakk>length xvec = length Tvec; distinct xvec; set(xvec) \<subseteq> supp(T); (x::name) \<sharp> T[xvec::=Tvec]\<rbrakk> \<Longrightarrow> x \<sharp> Tvec"
  and renaming:     "\<And>xvec Tvec p T. \<lbrakk>length xvec = length Tvec; (set p) \<subseteq> set xvec \<times> set (p \<bullet> xvec);
                                      distinct_perm p; (p \<bullet> xvec) \<sharp>* T\<rbrakk> \<Longrightarrow>
                                      T[xvec::=Tvec] = (p \<bullet> T)[(p \<bullet> xvec)::=Tvec]"
begin

lemma supp_subst:
  fixes M    :: 'a
  and   xvec :: "name list"
  and   Tvec :: "'b list"

  shows "(supp(M[xvec::=Tvec])::name set) \<subseteq> ((supp M) \<union> (supp xvec) \<union> (supp Tvec))"
proof(auto simp add: eqvts supp_def)
  fix x::name
  let ?P = "\<lambda>y. ([(x, y)] \<bullet> M)[([(x, y)] \<bullet> xvec)::=([(x, y)] \<bullet> Tvec)] \<noteq> M[xvec::=Tvec]"
  let ?Q = "\<lambda>y M. ([(x, y)] \<bullet> M) \<noteq> (M::'a)"
  let ?R = "\<lambda>y xvec. ([(x, y)] \<bullet> xvec) \<noteq> (xvec::name list)"
  let ?S = "\<lambda>y Tvec. ([(x, y)] \<bullet> Tvec) \<noteq> (Tvec::'b list)"
  assume A: "finite {y. ?Q y M}" and B: "finite {y. ?R y xvec}" and C: "finite {y. ?S y Tvec}" and D: "infinite {y. ?P(y)}"
  hence "infinite({y. ?P(y)} - {y. ?Q y M}  - {y. ?R y xvec}  - {y. ?S y Tvec})"
    by(auto intro: Diff_infinite_finite)
  hence "infinite({y. ?P(y) \<and> \<not>(?Q y M) \<and> \<not> (?R y xvec) \<and> \<not> (?S y Tvec)})" by(simp add: set_diff_eq)
  moreover have "{y. ?P(y) \<and> \<not>(?Q y M) \<and> \<not> (?R y xvec) \<and> \<not> (?S y Tvec)} = {}" by auto
  ultimately have "infinite {}" by(drule_tac Infinite_cong) auto
  thus False by simp
qed

lemma subst2[intro]:
  fixes x    :: name
  and   M    :: 'a
  and   xvec :: "name list"
  and   Tvec :: "'b list"

  assumes "x \<sharp> M"
  and     "x \<sharp> xvec"
  and     "x \<sharp> Tvec"

  shows "x \<sharp> M[xvec::=Tvec]"
using assms supp_subst
by(auto simp add: fresh_def)

lemma subst2_chain[intro]:
  fixes yvec :: "name list"
  and   M    :: 'a
  and   xvec :: "name list"
  and   Tvec :: "'b list"

  assumes "yvec \<sharp>* M"
  and     "yvec \<sharp>* xvec"
  and     "yvec \<sharp>* Tvec"

  shows "yvec \<sharp>* M[xvec::=Tvec]"
using assms
by(induct yvec) auto

lemma fs[simp]: "finite ((supp subst)::name set)"
by(simp add: supp_def perm_fun_def eqvts)
(*
lemma subst1_chain:
  fixes xvec :: "name list"
  and   Tvec :: "'b list"
  and   Xs   :: "name set"
  and   T    :: 'a

  assumes "length xvec = length Tvec"
  and     "distinct xvec"
  and     "Xs \<sharp>* T[xvec::=Tvec]"
  and     "Xs \<sharp>* xvec"

  shows "Xs \<sharp>* T"
using assms
by(auto intro: subst1 simp add: fresh_star_def)
*)
lemma subst3_chain:
  fixes xvec :: "name list"
  and   Tvec :: "'b list"
  and   Xs   :: "name set"
  and   T    :: 'a

  assumes "length xvec = length Tvec"
  and     "distinct xvec"
  and     "set xvec \<subseteq> supp T"
  and     "Xs \<sharp>* T[xvec::=Tvec]"

  shows "Xs \<sharp>* Tvec"
using assms
by(auto intro: subst3 simp add: fresh_star_def)

lemma subst4_chain:
  fixes xvec :: "name list"
  and   Tvec :: "'b list"
  and   T    :: 'a

  assumes "length xvec = length Tvec"
  and     "distinct xvec"
  and     "xvec \<sharp>* Tvec"

  shows "xvec \<sharp>* T[xvec::=Tvec]"
proof -
  obtain p where "((p::name prm) \<bullet> (xvec::name list)) \<sharp>* T" and "(p \<bullet> xvec) \<sharp>* xvec"
             and S: "(set p) \<subseteq> set xvec \<times> set (p \<bullet> xvec)"
             and "distinct_perm p"
    by(rule_tac xvec=xvec and c="(T, xvec)" in name_list_avoiding) auto

  from `length xvec = length Tvec` have "length(p \<bullet> xvec) = length Tvec" by simp
  moreover from `(p \<bullet> xvec) \<sharp>* T` have "(p \<bullet> p \<bullet> xvec) \<sharp>* (p \<bullet> T)"
    by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
  with `distinct_perm p` have "xvec \<sharp>* (p \<bullet> T)" by simp
  ultimately have "(set xvec) \<sharp>* (p \<bullet> T)[(p \<bullet> xvec)::=Tvec]" using `xvec \<sharp>* Tvec` `(p \<bullet> xvec) \<sharp>* xvec`
    by auto

  thus ?thesis using `length xvec = length Tvec` `distinct xvec` S `(p \<bullet> xvec) \<sharp>* T` `distinct_perm p`
    by(simp add: renaming)
qed

definition seq_subst :: "'a \<Rightarrow> (name list \<times> 'b list) list \<Rightarrow> 'a" ("_[<_>]" [80, 80] 130)
  where "M[<\<sigma>>] \<equiv> foldl (\<lambda>N. \<lambda>(xvec, Tvec). N[xvec::=Tvec]) M \<sigma>"

lemma seq_subst_nil[simp]:
  "seq_subst M [] = M"
by(simp add: seq_subst_def)

lemma seq_subst_cons[simp]:
  shows "seq_subst M ((xvec, Tvec)#\<sigma>) = seq_subst(M[xvec::=Tvec]) \<sigma>"
  by(simp add: seq_subst_def)

lemma seq_subst_term_append[simp]:
  shows "seq_subst M (\<sigma>@\<sigma>') = seq_subst (seq_subst M \<sigma>) \<sigma>'"
by(induct \<sigma>) (auto simp add: seq_subst_def)

definition well_formed_subst :: "(('d::fs_name) list \<times> ('e::fs_name) list) list \<Rightarrow> bool" where "well_formed_subst \<sigma> = ((filter (\<lambda>(xvec, Tvec). \<not>(length xvec = length Tvec \<and> distinct xvec)) \<sigma>) = [])"

lemma well_formed_subst_eqvt[eqvt]:
  fixes \<sigma> :: "(('d::fs_name) list \<times> ('e::fs_name) list) list"
  and   p :: "name prm"

  shows "p \<bullet> (well_formed_subst \<sigma>) = well_formed_subst(p \<bullet> \<sigma>)"
by(induct \<sigma> arbitrary: p) (auto simp add: eqvts well_formed_subst_def)

lemma well_formed_simp[simp]:
  fixes \<sigma> :: "(('d::fs_name) list \<times> ('e::fs_name) list) list"
  and   p :: "name prm"

  shows "well_formed_subst(p \<bullet> \<sigma>) = well_formed_subst \<sigma>"
by(induct \<sigma>) (auto simp add: eqvts well_formed_subst_def)

lemma well_formed_nil[simp]:
  "well_formed_subst []"
by(simp add: well_formed_subst_def)

lemma well_formed_cons[simp]:
  shows "well_formed_subst((xvec, Tvec)#\<sigma>) = (length xvec = length Tvec \<and> distinct xvec \<and> well_formed_subst \<sigma>)"
by(simp add: well_formed_subst_def) auto

lemma well_formed_append[simp]:
  fixes \<sigma>  :: "(('d::fs_name) list \<times> ('e::fs_name) list) list"
  and   \<sigma>' :: "(('d::fs_name) list \<times> ('e::fs_name) list) list"

  shows "well_formed_subst(\<sigma>@\<sigma>') = (well_formed_subst \<sigma> \<and> well_formed_subst \<sigma>')"
by(simp add: well_formed_subst_def)

lemma seq_subst2[intro]:
  fixes \<sigma> :: "(name list \<times> 'b list) list"
  and   T :: 'a
  and   x :: name

  assumes "x \<sharp> \<sigma>"
  and     "x \<sharp> T"

  shows "x \<sharp> T[<\<sigma>>]"
using assms
by(induct \<sigma> arbitrary: T) (clarsimp |  blast)+

lemma seq_subst2_chain[intro]:
  fixes \<sigma>    :: "(name list \<times> 'b list) list"
  and   T    :: 'a
  and   xvec :: "name list"

  assumes "xvec \<sharp>* \<sigma>"
  and     "xvec \<sharp>* T"

  shows "xvec \<sharp>* T[<\<sigma>>]"
using assms
by(induct xvec) auto

end

end


theory nat_javabip
  imports Main "/Volumes/Setup/Isabelle/Isabelle-Code/2022/March/libs_nat_functions"
begin

value "Connector"
value "(
(\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. (P ((fst sync), (snd sync)) \<longrightarrow>
      ((\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm))
      \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q ((fst t_elm), h)) ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P ((fst s_elm_1), (snd s_elm_1))
      \<and> (\<forall>l \<in> set (lookup_3 (fst s_elm_1) test_synchron) - {snd s_elm_1}. \<not>P ((fst s_elm_1), l)))
    )
))\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P ((fst t), l) \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P ((fst t), l1))))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q ((fst k), h) \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q ((fst k), h1))))
)"

(*JvB*)
value "(
(\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. (P (fst sync) (snd sync) \<longrightarrow>
      ((\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q (fst t_elm) (snd t_elm)
      \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q (fst t_elm) h) ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P (fst s_elm_1) (snd s_elm_1)
      \<and> (\<forall>l \<in> set (lookup_3 (fst s_elm_1) test_synchron) - {snd s_elm_1}. \<not>P (fst s_elm_1) l))
    )
))\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P (fst t) l \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P (fst t) l1)))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q (fst k) h \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q (fst k) h1)))
)"

(*jvb rutgon*)
value "(
(\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. (P (fst sync) (snd sync) \<longrightarrow>
      ((\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q (fst t_elm) (snd t_elm)
      ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P (fst s_elm_1) (snd s_elm_1))
    )
))\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P (fst t) l \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P (fst t) l1)))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q (fst k) h \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q (fst k) h1)))
)"

lemma compare_rg: "(
(\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. (P (fst sync) (snd sync) \<longrightarrow>
      ((\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q (fst t_elm) (snd t_elm)
      \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q (fst t_elm) h) ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P (fst s_elm_1) (snd s_elm_1)
      \<and> (\<forall>l \<in> set (lookup_3 (fst s_elm_1) test_synchron) - {snd s_elm_1}. \<not>P (fst s_elm_1) l))
    )
))\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P (fst t) l \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P (fst t) l1)))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q (fst k) h \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q (fst k) h1)))
) \<longleftrightarrow>
\<not>(
(\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. (P (fst sync) (snd sync) \<longrightarrow>
      ((\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q (fst t_elm) (snd t_elm)
      ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P (fst s_elm_1) (snd s_elm_1))
    )
))\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P (fst t) l \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P (fst t) l1)))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q (fst k) h \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q (fst k) h1)))
)
"
  nitpick [timeout=120, card = 5]
(*
lemma compare_var: "((((P 51 1 \<longrightarrow>
    (((Q 11 1 \<and> \<not> Q 11 2) \<and> Q 12 1 \<or> Q 2 1 \<and> \<not> Q 2 2) \<or>
     ((Q 11 1 \<and> \<not> Q 11 2) \<and> Q 12 1 \<or> Q 2 2 \<and> \<not> Q 2 1) \<or>
     ((Q 11 2 \<and> \<not> Q 11 1) \<and> Q 12 1 \<or> Q 2 1 \<and> \<not> Q 2 2) \<or> (Q 11 2 \<and> \<not> Q 11 1) \<and> Q 12 1 \<or> Q 2 2 \<and> \<not> Q 2 1) \<and>
    (P 52 1 \<and> \<not> P 52 2 \<or> P 52 2 \<and> \<not> P 52 1)) \<and>
   (P 51 2 \<longrightarrow>
    (((Q 11 1 \<and> \<not> Q 11 2) \<and> Q 12 1 \<or> Q 2 1 \<and> \<not> Q 2 2) \<or>
     ((Q 11 1 \<and> \<not> Q 11 2) \<and> Q 12 1 \<or> Q 2 2 \<and> \<not> Q 2 1) \<or>
     ((Q 11 2 \<and> \<not> Q 11 1) \<and> Q 12 1 \<or> Q 2 1 \<and> \<not> Q 2 2) \<or> (Q 11 2 \<and> \<not> Q 11 1) \<and> Q 12 1 \<or> Q 2 2 \<and> \<not> Q 2 1) \<and>
    (P 52 1 \<and> \<not> P 52 2 \<or> P 52 2 \<and> \<not> P 52 1))) \<and>
  (P 52 1 \<longrightarrow>
   (((Q 11 1 \<and> \<not> Q 11 2) \<and> Q 12 1 \<or> Q 2 1 \<and> \<not> Q 2 2) \<or>
    ((Q 11 1 \<and> \<not> Q 11 2) \<and> Q 12 1 \<or> Q 2 2 \<and> \<not> Q 2 1) \<or>
    ((Q 11 2 \<and> \<not> Q 11 1) \<and> Q 12 1 \<or> Q 2 1 \<and> \<not> Q 2 2) \<or> (Q 11 2 \<and> \<not> Q 11 1) \<and> Q 12 1 \<or> Q 2 2 \<and> \<not> Q 2 1) \<and>
   (P 51 1 \<and> \<not> P 51 2 \<or> P 51 2 \<and> \<not> P 51 1)) \<and>
  (P 52 2 \<longrightarrow>
   (((Q 11 1 \<and> \<not> Q 11 2) \<and> Q 12 1 \<or> Q 2 1 \<and> \<not> Q 2 2) \<or>
    ((Q 11 1 \<and> \<not> Q 11 2) \<and> Q 12 1 \<or> Q 2 2 \<and> \<not> Q 2 1) \<or>
    ((Q 11 2 \<and> \<not> Q 11 1) \<and> Q 12 1 \<or> Q 2 1 \<and> \<not> Q 2 2) \<or> (Q 11 2 \<and> \<not> Q 11 1) \<and> Q 12 1 \<or> Q 2 2 \<and> \<not> Q 2 1) \<and>
   (P 51 1 \<and> \<not> P 51 2 \<or> P 51 2 \<and> \<not> P 51 1))) \<and>
 (((P 51 1 \<longrightarrow> \<not> P 51 2) \<and> (P 51 2 \<longrightarrow> \<not> P 51 1)) \<and> (P 52 1 \<longrightarrow> \<not> P 52 2) \<and> (P 52 2 \<longrightarrow> \<not> P 52 1)) \<and>
 ((Q 11 1 \<longrightarrow> \<not> Q 11 2) \<and> (Q 11 2 \<longrightarrow> \<not> Q 11 1)) \<and> (Q 2 1 \<longrightarrow> \<not> Q 2 2) \<and> (Q 2 2 \<longrightarrow> \<not> Q 2 1))
\<longleftrightarrow>
((((P 51 1 \<longrightarrow>
    ((Q 11 1 \<and> Q 12 1 \<or> Q 2 1) \<or> (Q 11 1 \<and> Q 12 1 \<or> Q 2 2) \<or> (Q 11 2 \<and> Q 12 1 \<or> Q 2 1) \<or> Q 11 2 \<and> Q 12 1 \<or> Q 2 2) \<and>
    (P 52 1 \<or> P 52 2)) \<and>
   (P 51 2 \<longrightarrow>
    ((Q 11 1 \<and> Q 12 1 \<or> Q 2 1) \<or> (Q 11 1 \<and> Q 12 1 \<or> Q 2 2) \<or> (Q 11 2 \<and> Q 12 1 \<or> Q 2 1) \<or> Q 11 2 \<and> Q 12 1 \<or> Q 2 2) \<and>
    (P 52 1 \<or> P 52 2))) \<and>
  (P 52 1 \<longrightarrow>
   ((Q 11 1 \<and> Q 12 1 \<or> Q 2 1) \<or> (Q 11 1 \<and> Q 12 1 \<or> Q 2 2) \<or> (Q 11 2 \<and> Q 12 1 \<or> Q 2 1) \<or> Q 11 2 \<and> Q 12 1 \<or> Q 2 2) \<and>
   (P 51 1 \<or> P 51 2)) \<and>
  (P 52 2 \<longrightarrow>
   ((Q 11 1 \<and> Q 12 1 \<or> Q 2 1) \<or> (Q 11 1 \<and> Q 12 1 \<or> Q 2 2) \<or> (Q 11 2 \<and> Q 12 1 \<or> Q 2 1) \<or> Q 11 2 \<and> Q 12 1 \<or> Q 2 2) \<and>
   (P 51 1 \<or> P 51 2))) \<and>
 (((P 51 1 \<longrightarrow> \<not> P 51 2) \<and> (P 51 2 \<longrightarrow> \<not> P 51 1)) \<and> (P 52 1 \<longrightarrow> \<not> P 52 2) \<and> (P 52 2 \<longrightarrow> \<not> P 52 1)) \<and>
 ((Q 11 1 \<longrightarrow> \<not> Q 11 2) \<and> (Q 11 2 \<longrightarrow> \<not> Q 11 1)) \<and> (Q 2 1 \<longrightarrow> \<not> Q 2 2) \<and> (Q 2 2 \<longrightarrow> \<not> Q 2 1))"
  by cannot *)

lemma compare_var_1: "(((P 41 1 \<longrightarrow> (Q 11 1 \<and> \<not> Q 11 2) \<and> Q 12 1 \<and> Q 13 1 \<or> (Q 11 2 \<and> \<not> Q 11 1) \<and> Q 12 1 \<and> Q 13 1) \<and>
  (P 51 1 \<longrightarrow> (Q 11 1 \<and> \<not> Q 11 2) \<and> Q 12 1 \<and> Q 13 1 \<or> (Q 11 2 \<and> \<not> Q 11 1) \<and> Q 12 1 \<and> Q 13 1)) \<and>
 (Q 11 1 \<longrightarrow> \<not> Q 11 2) \<and> (Q 11 2 \<longrightarrow> \<not> Q 11 1))
\<longleftrightarrow>
(((P 41 1 \<longrightarrow> Q 11 1 \<and> Q 12 1 \<and> Q 13 1 \<or> Q 11 2 \<and> Q 12 1 \<and> Q 13 1) \<and>
  (P 51 1 \<longrightarrow> Q 11 1 \<and> Q 12 1 \<and> Q 13 1 \<or> Q 11 2 \<and> Q 12 1 \<and> Q 13 1)) \<and>
 (Q 11 1 \<longrightarrow> \<not> Q 11 2) \<and> (Q 11 2 \<longrightarrow> \<not> Q 11 1))"
  by blast

lemma compare_var_2: "(((P411 \<longrightarrow> (Q111 \<and> \<not> Q112) \<and> Q121 \<and> Q131 \<or> (Q112 \<and> \<not> Q111) \<and> Q121 \<and> Q131) \<and>
  (P511 \<longrightarrow> (Q111 \<and> \<not> Q112) \<and> Q121 \<and> Q131 \<or> (Q112 \<and> \<not> Q111) \<and> Q121 \<and> Q131)) \<and>
 (Q111 \<longrightarrow> \<not> Q112) \<and> (Q112 \<longrightarrow> \<not> Q111))
\<longleftrightarrow>
(((P411 \<longrightarrow> Q111 \<and> Q121 \<and> Q131 \<or> Q112 \<and> Q121 \<and> Q131) \<and>
  (P511 \<longrightarrow> Q111 \<and> Q121 \<and> Q131 \<or> Q112 \<and> Q121 \<and> Q131)) \<and>
 (Q111 \<longrightarrow> \<not> Q112) \<and> (Q112 \<longrightarrow> \<not> Q111))"
  by blast

end


theory examples
imports Main  "basic" "quantum_hoare_logic" "lt"
begin

lemma grover:  "valid I
               ((((Init q0 0);Init q1 1;Init q 2;Init r 3;
               Utrans Delta 2;Utrans H 0;Utrans H 1;Utrans H 2);
              While M0 M1 C Q);
           Cond [(N0,SKIP,p0),(N1,SKIP,p1),(N2,SKIP,p2),(N3,SKIP,p3)] )
               P"
apply (vcg,auto)
apply quantum_oracle+
done
lemma loop:"valid Q (Utrans Or (10);Utrans H 0;Utrans H 1;Utrans Ph 10;
         Utrans H 0; Utrans H 1) G"
apply(vcg,auto)
apply quantum_oracle+
done
(*
lemma shor:"valid P  (Init q0 0;Utrans H 0;Utrans U 1;Utrans (dag U) 1;Utrans (dag H) 0;
                    Cond [(M0,SKIP,p0),(M1,SKIP,p1)])   Q"
apply(rule ord_wlp,auto)
apply quantum_oracle
done*)
end


theory Lappend_lnil2
  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 lappend :: "'a Llist \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist" where
"lnull xs \<Longrightarrow> lnull ys \<Longrightarrow> lnull (lappend xs ys)"
| "lhd (lappend xs ys) = lhd (if lnull xs then ys else xs)"
| "ltl (lappend xs ys) = (if lnull xs then ltl ys else lappend (ltl xs) ys)"

(*hipster lappend*)
lemma lemma_a [thy_expl]: "lappend y LNil = y"
  apply (coinduction  arbitrary: y rule: Lappend_lnil2.Llist.coinduct_strong)
by simp

lemma lemma_aa [thy_expl]: "lappend LNil y = y"
apply (coinduction  arbitrary: y rule: Lappend_lnil2.Llist.coinduct_strong)
by simp

lemma lemma_ab [thy_expl]: "ltl (lappend y y) = lappend (ltl y) y"
apply (coinduction  arbitrary: y rule: Lappend_lnil2.Llist.coinduct_strong)
apply simp
by (smt Llist.collapse(1) Llist.sel(2) lappend.disc_iff(2) lappend.simps(3) lappend.simps(4))

lemma lemma_ac [thy_expl]: "lappend (LCons y z) x2 = LCons y (lappend z x2)"
apply (coinduction  arbitrary: x2 y z rule: Lappend_lnil2.Llist.coinduct_strong)
by simp

lemma lemma_ad [thy_expl]: "lappend (lappend y z) x2 = lappend y (lappend z x2)"
apply (coinduction  arbitrary: x2 y z rule: Lappend_lnil2.Llist.coinduct_strong)
apply simp
by auto

lemma lemma_ae [thy_expl]: "ltl (lappend y (ltl y)) = lappend (ltl y) (ltl y)"
apply (coinduction  arbitrary: y rule: Lappend_lnil2.Llist.coinduct_strong)
apply simp
  by (fastforce Llist.collapse(1) Llist.sel(2) lemma_a)
(* Bad arguments for method "fastforce"\<here>:
  Llist.collapse ( 1 ) Llist.sel ( 2 ) lemma_a
but works if we change fastforce to metis?
*)

theorem  lappend_LNil2: "lappend xs LNil = xs"
  by (simp add: lemma_a)
(*by hipster_coinduct_sledgehammer works also*)
end


subsection\<open>An alternate proof of ND completeness\<close>
theory ND_Compl_SC
imports SC_Sema ND_Sound SCND Compactness
begin

lemma ND_sound_complete_countable:
  fixes \<Gamma> :: "'a :: countable formula set"
  shows "\<Gamma> \<turnstile> F \<longleftrightarrow> \<Gamma> \<TTurnstile> F" (is "?n \<longleftrightarrow> ?s")
proof
  assume ?n thus ?s by (fact ND_sound)
next
  assume s: ?s
  with compact_entailment obtain \<Gamma>' where 0: "finite \<Gamma>'" "\<Gamma>' \<TTurnstile> F" "\<Gamma>' \<subseteq> \<Gamma>"
    unfolding entailment_def by metis
  then obtain \<Gamma>'' where \<Gamma>'': "\<Gamma>' = set_mset \<Gamma>''" using finite_set_mset_mset_set by blast
  have su: "set_mset \<Gamma>'' \<subseteq> \<Gamma>" using 0  \<Gamma>'' by fast
  from 0 have "\<Turnstile> \<Gamma>'' \<Rightarrow> {#F#}" unfolding sequent_semantics_def entailment_def \<Gamma>'' by simp
  with SC_sound_complete have "\<Gamma>'' \<Rightarrow> {#F#}" by blast
  with SCND have "set_mset \<Gamma>'' \<union> \<^bold>\<not> ` set_mset {#F#} \<turnstile> \<bottom>" .
  thus ?n using ND.CC Weaken[OF _ su[THEN insert_mono]] by force
qed

text\<open>If you do not like the requirement that our atoms are countable,
you can also restrict yourself to a finite set of assumptions.\<close>

lemma ND_sound_complete_finite:
  assumes "finite \<Gamma>"
  shows "\<Gamma> \<turnstile> F \<longleftrightarrow> \<Gamma> \<TTurnstile> F" (is "?n \<longleftrightarrow> ?s")
proof
  assume ?n thus ?s by (fact ND_sound)
next
  assume s: ?s
  then obtain \<Gamma>'' where \<Gamma>'': "\<Gamma> = set_mset \<Gamma>''" using finite_set_mset_mset_set assms by blast
  have su: "set_mset \<Gamma>'' \<subseteq> \<Gamma>" using \<Gamma>'' by fast
  have "\<Turnstile> \<Gamma>'' \<Rightarrow> {#F#}" using s unfolding sequent_semantics_def entailment_def \<Gamma>'' by auto
  with SC_sound_complete have "\<Gamma>'' \<Rightarrow> {#F#}" by blast
  with SCND have "set_mset \<Gamma>'' \<union> \<^bold>\<not> ` set_mset {#F#} \<turnstile> \<bottom>" .
  thus ?n using ND.CC Weaken[OF _ su[THEN insert_mono]] by force
qed

end