theory turing_to_while
  imports Main "Turing" "../IMP-/Com" "../IMP-/Big_StepT" "../IMP-/Small_StepT" "../IMP-/Big_Step_Small_Step_Equivalence"  "../IMP-/Max_Constant" "../fresh_names/Fresh_Class" "tape_nat_conversion"

begin
subsection "Encoding of Tape Instructions As arithmetic Operations"
text "The encoding of the tape into a natural number as well as the encoding of the operations as functions on natural numbers is taken from https://www21.in.tum.de/teaching/theo/SS19/folien-handout.pdf ."
abbreviation LeftShift:: "atomExp \<Rightarrow> aexp" ("_\<lless>") where
"LeftShift a \<equiv> Plus a a"

fun encode_tape_instr :: "action  \<Rightarrow> com" where
"encode_tape_instr a = (case a of Nop \<Rightarrow> SKIP |
                                  W0 \<Rightarrow> ''y''::= (V ''y''\<then>);;''y''::= (V ''y''\<lless>) |
                                  W1 \<Rightarrow> ''y''::= (V ''y''\<then>);;''y''::=(V ''y''\<lless>);;''y''::= ((V ''y'') \<oplus> (N 1)) |
                                  L \<Rightarrow> ''y''::= (V ''y''\<lless>);;''t''::=(V ''x''\<doteq>1);;''y''::= ((V ''y'') \<oplus> (V ''t''));; ''x''::= (V ''x''\<then>) |
                                  R \<Rightarrow> ''x''::= (V ''x''\<lless>);;''t''::=(V ''y''\<doteq>1);;''x''::= ((V ''x'') \<oplus> (V ''t''));;''y''::= (V ''y''\<then>))"
lemma encode_tape_instr_cost:
  assumes encode_instr: "((encode_tape_instr i),s0) \<Rightarrow>\<^bsup> k \<^esup> s"
  shows " 1 \<le> k \<and> k \<le> 8"
 using assms proof (cases i)
  case W0
  then show ?thesis using encode_instr by fastforce
next
  case W1
  then show ?thesis using encode_instr by fastforce
next
  case L
  then show ?thesis using encode_instr by fastforce
next
  case R
  then show ?thesis using encode_instr by fastforce
next
  case Nop
  then show ?thesis using encode_instr by fastforce
qed

lemma rightShift_state:
  assumes rightShift_com: "(v::= (V v\<then>), s) \<Rightarrow>\<^bsup> k \<^esup> s'"
  shows " (s v) div 2 = s' v"
  using assms proof -
   show ?thesis using rightShift_com by auto
 qed

lemma encode_w0_x:
  assumes encode_w0: "(c;;(encode_tape_instr W0),s0) \<Rightarrow>\<^bsup> k \<^esup> s"
    and encode_instr: "(c,s0) \<Rightarrow>\<^bsup> k' \<^esup> s'"
shows "s ''x'' = s' ''x''"
  using assms proof -
  obtain k' s1 k'' where "(c,s0) \<Rightarrow>\<^bsup> k' \<^esup> s1" and
         "(encode_tape_instr W0,s1) \<Rightarrow>\<^bsup> k'' \<^esup> s" using encode_w0 by blast
  then have "s1 = s'" using big_step_t_determ2 encode_instr by blast
  have "''x'' \<notin> set (Max_Constant.all_variables (encode_tape_instr W0))" by simp
  then show ?thesis
    by (metis \<open>(encode_tape_instr W0, s1) \<Rightarrow>\<^bsup> k'' \<^esup> s\<close> \<open>s1 = s'\<close> com_only_vars)
qed

lemma encode_w0_y:
  assumes encode_w0: "(c;;(encode_tape_instr W0),s0) \<Rightarrow>\<^bsup> k \<^esup> s"
    and encode_instr: "(c,s0) \<Rightarrow>\<^bsup> k' \<^esup> s'"
shows "s ''y'' = (if even (s' ''y'') then s' ''y'' else s' ''y'' - 1)"
  using assms proof -
  obtain k' s1 k'' where "(c,s0) \<Rightarrow>\<^bsup> k' \<^esup> s1" and
         "(encode_tape_instr W0,s1) \<Rightarrow>\<^bsup> k'' \<^esup> s" and
         "k'' = 4" using encode_w0 by fastforce
  then have "s1 = s'" using big_step_t_determ2 encode_instr by blast
  have "k' + k'' = k"
    by (meson Seq \<open>(c, s0) \<Rightarrow>\<^bsup> k' \<^esup> s1\<close> \<open>(encode_tape_instr W0, s1) \<Rightarrow>\<^bsup> k'' \<^esup> s\<close> big_step_t_determ2 encode_w0)
  from encode_w0 have "(c;;''y''::= (V ''y''\<then>);;''y''::= (V ''y''\<lless>),s0) \<Rightarrow>\<^bsup> k \<^esup> s" by fastforce
  have "(c;;''y''::= (V ''y''\<then>);;''y''::= Plus (V ''y'') (V ''y''),s0) \<Rightarrow>\<^bsup> k \<^esup> s1(''y'' := LeftShift_nat (s1 ''y'' div 2))"
    apply(rule Seq) apply(rule Seq) apply(auto) apply(fact) apply(rule AssignI) using \<open>k' + k'' = k\<close> \<open>k'' = 4\<close> by auto
  then show ?thesis by (metis \<open>(c;; ''y'' ::= (V ''y''\<then>);; ''y'' ::= V ''y''\<lless>, s0) \<Rightarrow>\<^bsup> k \<^esup> s\<close> \<open>s1 = s'\<close> big_step_t_determ2 dvd_mult_div_cancel fun_upd_same mult_2 odd_two_times_div_two_nat)
qed

lemma update_encode_w0:
  assumes encode_w0: "((encode_tape_instr W0),s0) \<Rightarrow>\<^bsup> k \<^esup> s"
  assumes update_w0: "(l,r) = update W0 (l0,r0)"
  and tape_state_eq: "s0 ''x'' = tape_to_nat l0 \<and> s0 ''y'' = tape_to_nat r0"
shows "s ''x'' = tape_to_nat l" "s ''y'' = tape_to_nat r"
proof -
    from encode_w0 encode_w0_x tape_state_eq update_w0 show "s ''x'' = tape_to_nat l" by auto
  next
    from encode_w0 encode_w0_y have "s ''y'' = (if even (s0 ''y'') then s0 ''y'' else s0 ''y'' - 1)" by blast
    then have "s ''y'' = (if even (tape_to_nat r0) then tape_to_nat r0 else tape_to_nat r0 - 1)" using tape_state_eq by simp
    also have "(if even (tape_to_nat r0) then tape_to_nat r0 else tape_to_nat r0 - 1) = tape_to_nat r" proof (cases "even (tape_to_nat r0)")
      case True
      then have "Bk#tl r0 = r0 \<or> r0 = []" using tape_to_nat_even list.collapse by force
      moreover have "r0 = [] \<Longrightarrow> tape_to_nat r0 = tape_to_nat r" using update_w0 by auto
      moreover have "r0 = Bk#tl r0 \<Longrightarrow> tape_to_nat r0 = tape_to_nat r" using update_w0 by auto
      ultimately have "tape_to_nat r0 = tape_to_nat r" by auto
      then show ?thesis using True by auto
    next
      case False
      then have "Oc#tl r0 = r0" using list.collapse tape_to_nat_even tape_to_nat_odd by fastforce
      also have "Bk#tl r0 = r" using update_w0 by auto
      ultimately have "tape_to_nat r0 - 1 = tape_to_nat r"
        by (metis add_implies_diff cell.distinct(1) tape_to_nat.simps(2))
      then show ?thesis using False by auto
    qed
    finally show "s ''y'' = tape_to_nat r" by auto
  qed

lemma encode_w1_x:
  assumes encode_w1: "(c;;(encode_tape_instr W1),s0) \<Rightarrow>\<^bsup> k \<^esup> s"
    and encode_instr: "(c,s0) \<Rightarrow>\<^bsup> k' \<^esup> s'"
shows "s ''x'' = s' ''x''"
  using assms proof -
  obtain k' s1 k'' where "(c,s0) \<Rightarrow>\<^bsup> k' \<^esup> s1" and
         "(encode_tape_instr W1,s1) \<Rightarrow>\<^bsup> k'' \<^esup> s" using encode_w1 by blast
  then have "s1 = s'" using big_step_t_determ2 encode_instr by blast
  have "''x'' \<notin> set (Max_Constant.all_variables (encode_tape_instr W1))" by simp
  then show ?thesis
    by (metis \<open>(encode_tape_instr W1, s1) \<Rightarrow>\<^bsup> k'' \<^esup> s\<close> \<open>s1 = s'\<close> com_only_vars)
qed

lemma encode_w1_y: (* also provable by showing it is simply Suc W0 *)
  assumes encode_w1: "(c;;(encode_tape_instr W1),s0) \<Rightarrow>\<^bsup> k \<^esup> s"
    and encode_instr: "(c,s0) \<Rightarrow>\<^bsup> k' \<^esup> s'"
shows "s ''y'' = (if even (s' ''y'') then s' ''y'' + 1 else s' ''y'')"
  using assms proof -
  obtain k' s1 k'' where "(c,s0) \<Rightarrow>\<^bsup> k' \<^esup> s1" and
         "(encode_tape_instr W1,s1) \<Rightarrow>\<^bsup> k'' \<^esup> s" and
         "k'' = 6" using encode_w1 by fastforce
  then have "s1 = s'" using big_step_t_determ2 encode_instr by blast
  have "k' + k'' = k"
    by (meson Seq \<open>(c, s0) \<Rightarrow>\<^bsup> k' \<^esup> s1\<close> \<open>(encode_tape_instr W1, s1) \<Rightarrow>\<^bsup> k'' \<^esup> s\<close> big_step_t_determ2 encode_w1)
  from encode_w1 have "(c;;''y''::= (V ''y''\<then>);;''y''::= (V ''y''\<lless>);;''y''::= ((V ''y'') \<oplus> (N 1)),s0) \<Rightarrow>\<^bsup> k \<^esup> s" by fastforce
  have "(c;;''y''::= (V ''y''\<then>);;''y''::= Plus (V ''y'') (V ''y'');;''y''::= ((V ''y'') \<oplus> (N 1)),s0) \<Rightarrow>\<^bsup> k \<^esup>s1(''y'' := Suc (LeftShift_nat (s1 ''y'' div 2)))"
    apply(rule Seq) apply(rule Seq) apply(rule Seq) apply(auto) apply(fact) apply(rule AssignI) using \<open>k' + k'' = k\<close> \<open>k'' = 6\<close> by auto
  then show ?thesis
    by (smt (verit, del_insts) Suc_eq_plus1 \<open>(c;; ''y'' ::= (V ''y''\<then>);; ''y'' ::= V ''y''\<lless>;; ''y'' ::= (V ''y'' \<oplus> N 1), s0) \<Rightarrow>\<^bsup> k \<^esup> s\<close> \<open>s1 = s'\<close> add_self_div_2 bigstep_det bit_eq_rec even_add even_succ_div_2 fun_upd_same odd_one plus_1_eq_Suc)
  qed

lemma update_encode_w1:
  assumes encode_w1: "((encode_tape_instr W1),s0) \<Rightarrow>\<^bsup> k \<^esup> s"
  assumes update_w1: "(l,r) = update W1 (l0,r0)"
  and tape_state_eq: "s0 ''x'' = tape_to_nat l0 \<and> s0 ''y'' = tape_to_nat r0"
shows "s ''x'' = tape_to_nat l" "s ''y'' = tape_to_nat r"
proof -
    from encode_w1 encode_w0_x tape_state_eq update_w1 show "s ''x'' = tape_to_nat l" by auto
  next
    from encode_w1 encode_w1_y have "s ''y'' = (if even (s0 ''y'') then s0 ''y'' + 1 else s0 ''y'')" by blast
    then have "s ''y'' = (if even (tape_to_nat r0) then tape_to_nat r0 + 1 else tape_to_nat r0)" using tape_state_eq by simp
    also have "(if even (tape_to_nat r0) then tape_to_nat r0 + 1 else tape_to_nat r0) = tape_to_nat r" proof (cases "even (tape_to_nat r0)")
      case True
      then have "Bk#tl r0 = r0 \<or> r0 = []" using tape_to_nat_even list.collapse by force
      moreover have "r0 = [] \<Longrightarrow> tape_to_nat r0 + 1 = tape_to_nat r" using update_w1 by auto
      moreover have "r0 = Bk#tl r0 \<Longrightarrow> tape_to_nat r0 + 1 = tape_to_nat r" using update_w1
        by (metis Turing.update.simps(2) cell.distinct(1) prod.inject tape_to_nat.simps(2))
      ultimately have "tape_to_nat r0 + 1 = tape_to_nat r" by auto
      then show ?thesis using True by auto
    next
      case False
      then have "Oc#tl r0 = r0" using list.collapse tape_to_nat_even tape_to_nat_odd by fastforce
      then have "r0 = r" using update_w1 by simp
      then show ?thesis using False by auto
    qed
    finally show "s ''y'' = tape_to_nat r" by auto
  qed

lemma encode_L_x:
  assumes encode_L: "(c;;(encode_tape_instr L),s0) \<Rightarrow>\<^bsup> k \<^esup> s"
    and encode_instr: "(c,s0) \<Rightarrow>\<^bsup> k' \<^esup> s'"
shows "s ''x'' = s' ''x'' div 2"
  using assms proof -
  obtain k' s1 k'' where "(c,s0) \<Rightarrow>\<^bsup> k' \<^esup> s1" and
         "(encode_tape_instr L,s1) \<Rightarrow>\<^bsup> k'' \<^esup> s" and
         "k'' = 8" using encode_L by fastforce
  then have "s1 = s'" using big_step_t_determ2 encode_instr by blast
  also have "k' + k'' = k"
    by (meson Seq \<open>(c, s0) \<Rightarrow>\<^bsup> k' \<^esup> s1\<close> \<open>(encode_tape_instr L, s1) \<Rightarrow>\<^bsup> k'' \<^esup> s\<close> big_step_t_determ2 encode_L)
  from encode_L have "(c;;''y''::= (V ''y''\<lless>);;''t''::=(V ''x''\<doteq>1);;''y''::= ((V ''y'') \<oplus> (V ''t''));; ''x''::= (V ''x''\<then>),s0) \<Rightarrow>\<^bsup> k \<^esup> s" by fastforce
  have "(c;;''y''::= (V ''y''\<lless>);;''t''::=(V ''x''\<doteq>1);;''y''::= ((V ''y'') \<oplus> (V ''t''));; ''x''::= (V ''x''\<then>),s0) \<Rightarrow>\<^bsup> k \<^esup>  s1
    (''t'' := s1 ''x'' mod 2, ''y'' := LeftShift_nat (s1 ''y'') + s1 ''x'' mod 2,
     ''x'' := aval (V ''x''\<then>) (s1(''t'' := s1 ''x'' mod 2, ''y'' := LeftShift_nat (s1 ''y'') + s1 ''x'' mod 2)))"
    apply(rule Seq) apply(rule Seq) apply(rule Seq) apply(rule Seq) apply(auto) apply(fact) apply(rule AssignI) using \<open>k' + k'' = k\<close> \<open>k'' = 8\<close> by auto
  then show ?thesis
    by (smt (z3) \<open>(c;; ''y'' ::= V ''y''\<lless>;; ''t'' ::= (V ''x'' \<doteq>1);; ''y'' ::= (V ''y'' \<oplus> V ''t'');; ''x'' ::= (V ''x''\<then>), s0) \<Rightarrow>\<^bsup> k \<^esup> s\<close> \<open>s1 = s'\<close> atomVal.simps(1) aval.simps(5) big_step_t_determ2 char.inject fun_upd_other fun_upd_same list.inject)
qed

lemma encode_L_y:
  assumes encode_L: "(c;;(encode_tape_instr L),s0) \<Rightarrow>\<^bsup> k \<^esup> s"
    and encode_instr: "(c,s0) \<Rightarrow>\<^bsup> k' \<^esup> s'"
  shows "s ''y'' = s' ''y'' * 2 + s' ''x'' mod 2"
  using assms proof -
  obtain k' s1 k'' where "(c,s0) \<Rightarrow>\<^bsup> k' \<^esup> s1" and
         "(encode_tape_instr L,s1) \<Rightarrow>\<^bsup> k'' \<^esup> s" and
         "k'' = 8" using encode_L by fastforce
  then have "s1 = s'" using big_step_t_determ2 encode_instr by blast
  have "k' + k'' = k"
    by (meson Seq \<open>(c, s0) \<Rightarrow>\<^bsup> k' \<^esup> s1\<close> \<open>(encode_tape_instr L, s1) \<Rightarrow>\<^bsup> k'' \<^esup> s\<close> big_step_t_determ2 encode_L)
  from encode_L have "(c;;''y''::= (V ''y''\<lless>);;''t''::=(V ''x''\<doteq>1);;''y''::= ((V ''y'') \<oplus> (V ''t''));; ''x''::= (V ''x''\<then>),s0) \<Rightarrow>\<^bsup> k \<^esup> s" by fastforce
  have "(c;;''y''::= (V ''y''\<lless>);;''t''::=(V ''x''\<doteq>1);;''y''::= ((V ''y'') \<oplus> (V ''t''));; ''x''::= (V ''x''\<then>),s0) \<Rightarrow>\<^bsup> k \<^esup>  s1
    (''t'' := s1 ''x'' mod 2, ''y'' := LeftShift_nat (s1 ''y'') + s1 ''x'' mod 2,
     ''x'' := aval (V ''x''\<then>) (s1(''t'' := s1 ''x'' mod 2, ''y'' := LeftShift_nat (s1 ''y'') + s1 ''x'' mod 2)))"
    apply(rule Seq) apply(rule Seq) apply(rule Seq) apply(rule Seq) apply(auto) apply(fact) apply(rule AssignI) using \<open>k' + k'' = k\<close> \<open>k'' = 8\<close> by auto
  then show ?thesis
    by (smt (z3) \<open>(c;; ''y'' ::= V ''y''\<lless>;; ''t'' ::= (V ''x'' \<doteq>1);; ''y'' ::= (V ''y'' \<oplus> V ''t'');; ''x'' ::= (V ''x''\<then>), s0) \<Rightarrow>\<^bsup> k \<^esup> s\<close> \<open>s1 = s'\<close> big_step_t_determ2 char.inject fun_upd_apply le_add1 list.inject mult_2_right)
qed

lemma update_encode_L:
  assumes encode_L: "((encode_tape_instr L),s0) \<Rightarrow>\<^bsup> k \<^esup> s"
  assumes update_L: "(l,r) = update L (l0,r0)"
  and tape_state_eq: "s0 ''x'' = tape_to_nat l0 \<and> s0 ''y'' = tape_to_nat r0"
shows "s ''x'' = tape_to_nat l" "s ''y'' = tape_to_nat r"
proof -
  from encode_L encode_L_x have "s ''x'' = s0 ''x'' div 2" by auto
  then have "s ''x'' = tape_to_nat l0 div 2" using tape_state_eq by simp
  moreover have "l = tl l0" using update_L
    by (metis Nil_tl Turing.update.simps(3) prod.inject)
  moreover have "tape_to_nat (tl l0) = tape_to_nat l0 div 2" by (induct l0) auto
  ultimately show "s ''x'' = tape_to_nat l" by simp
  next
    from encode_L encode_L_y have "s ''y'' = s0 ''y'' * 2 + s0 ''x'' mod 2" by blast
    then have "s ''y'' = tape_to_nat r0 * 2 + tape_to_nat l0 mod 2" using tape_state_eq by simp
    have "r = (if l0 = [] then (Bk#r0) else (hd l0 # r0))" using update_L by auto
    then have "tape_to_nat r =  tape_to_nat r0 * 2 + tape_to_nat l0 mod 2" proof (cases l0)
      case Nil
      then have "r = (Bk#r0)"
        by (simp add: \<open>r = (if l0 = [] then Bk # r0 else hd l0 # r0)\<close>)
      then show ?thesis using local.Nil by auto
    next
      case (Cons a list)
      then show ?thesis proof (cases a)
        case Bk
      then have "r = (Bk#r0)" by (simp add: \<open>r = (if l0 = [] then Bk # r0 else hd l0 # r0)\<close> local.Cons)
        then show ?thesis by (simp add: Bk local.Cons)
      next
        case Oc
        then have "r = (Oc#r0)" by (simp add: \<open>r = (if l0 = [] then Bk # r0 else hd l0 # r0)\<close> local.Cons)
        then have "tape_to_nat r =  tape_to_nat r0 * 2 + 1" by simp
        have "odd(tape_to_nat (Oc#list))" by simp
        then have "tape_to_nat (Oc#list) mod 2 = 1" by presburger
        show ?thesis
          using Oc \<open>tape_to_nat (Oc # list) mod 2 = 1\<close> \<open>tape_to_nat r = tape_to_nat r0 * 2 + 1\<close> local.Cons by auto
      qed
    qed
    then show "s ''y'' = tape_to_nat r" by (simp add: \<open>s ''y'' = tape_to_nat r0 * 2 + tape_to_nat l0 mod 2\<close>)
  qed

lemma encode_R_y:
  assumes encode_R: "(c;;(encode_tape_instr R),s0) \<Rightarrow>\<^bsup> k \<^esup> s"
    and encode_instr: "(c,s0) \<Rightarrow>\<^bsup> k' \<^esup> s'"
shows "s ''y'' = s' ''y'' div 2"
  using assms proof -
  obtain k' s1 k'' where "(c,s0) \<Rightarrow>\<^bsup> k' \<^esup> s1" and
         "(encode_tape_instr R,s1) \<Rightarrow>\<^bsup> k'' \<^esup> s" and
         "k'' = 8" using encode_R by fastforce
  then have "s1 = s'" using big_step_t_determ2 encode_instr by blast
  have "k' + k'' = k"
    by (meson Seq \<open>(c, s0) \<Rightarrow>\<^bsup> k' \<^esup> s1\<close> \<open>(encode_tape_instr R, s1) \<Rightarrow>\<^bsup> k'' \<^esup> s\<close> big_step_t_determ2 encode_R)
  from encode_R have "(c;;''x''::= (V ''x''\<lless>);;''t''::=(V ''y''\<doteq>1);;''x''::= ((V ''x'') \<oplus> (V ''t''));;''y''::= (V ''y''\<then>),s0) \<Rightarrow>\<^bsup> k \<^esup> s" by fastforce
  have "(c;;''x''::= (V ''x''\<lless>);;''t''::=(V ''y''\<doteq>1);;''x''::= ((V ''x'') \<oplus> (V ''t''));;''y''::= (V ''y''\<then>),s0) \<Rightarrow>\<^bsup> k \<^esup> s1
    (''t'' := s1 ''y'' mod 2, ''x'' := LeftShift_nat (s1 ''x'') + s1 ''y'' mod 2,
     ''y'' := aval (V ''y''\<then>) (s1(''t'' := s1 ''y'' mod 2, ''x'' := LeftShift_nat (s1 ''x'') + s1 ''y'' mod 2)))"
    apply(rule Seq) apply(rule Seq) apply(rule Seq) apply(rule Seq) apply(auto) apply(fact) apply(rule AssignI) using \<open>k' + k'' = k\<close> \<open>k'' = 8\<close> by auto
  then show ?thesis
    by (smt (z3) \<open>(c;; ''x'' ::= V ''x''\<lless>;; ''t'' ::= (V ''y'' \<doteq>1);; ''x'' ::= (V ''x'' \<oplus> V ''t'');; ''y'' ::= (V ''y''\<then>), s0) \<Rightarrow>\<^bsup> k \<^esup> s\<close> \<open>s1 = s'\<close> atomVal.simps(1) aval.simps(5) big_step_t_determ2 char.inject fun_upd_other fun_upd_same list.inject)
qed

lemma encode_R_x:
  assumes encode_R: "(c;;(encode_tape_instr R),s0) \<Rightarrow>\<^bsup> k \<^esup> s"
    and encode_instr: "(c,s0) \<Rightarrow>\<^bsup> k' \<^esup> s'"
shows "s ''x'' = s' ''x'' * 2 + s' ''y'' mod 2"
  using assms proof -
  obtain k' s1 k'' where "(c,s0) \<Rightarrow>\<^bsup> k' \<^esup> s1" and
         "(encode_tape_instr R,s1) \<Rightarrow>\<^bsup> k'' \<^esup> s" and
         "k'' = 8" using encode_R by fastforce
  then have "s1 = s'" using big_step_t_determ2 encode_instr by blast
  have "k' + k'' = k"
    by (meson Seq \<open>(c, s0) \<Rightarrow>\<^bsup> k' \<^esup> s1\<close> \<open>(encode_tape_instr R, s1) \<Rightarrow>\<^bsup> k'' \<^esup> s\<close> big_step_t_determ2 encode_R)
  from encode_R have "(c;;''x''::= (V ''x''\<lless>);;''t''::=(V ''y''\<doteq>1);;''x''::= ((V ''x'') \<oplus> (V ''t''));;''y''::= (V ''y''\<then>),s0) \<Rightarrow>\<^bsup> k \<^esup> s" by fastforce
  have "(c;;''x''::= (V ''x''\<lless>);;''t''::=(V ''y''\<doteq>1);;''x''::= ((V ''x'') \<oplus> (V ''t''));;''y''::= (V ''y''\<then>),s0) \<Rightarrow>\<^bsup> k \<^esup> s1
    (''t'' := s1 ''y'' mod 2, ''x'' := LeftShift_nat (s1 ''x'') + s1 ''y'' mod 2,
     ''y'' := aval (V ''y''\<then>) (s1(''t'' := s1 ''y'' mod 2, ''x'' := LeftShift_nat (s1 ''x'') + s1 ''y'' mod 2)))"
    apply(rule Seq) apply(rule Seq) apply(rule Seq) apply(rule Seq) apply(auto) apply(fact) apply(rule AssignI) using \<open>k' + k'' = k\<close> \<open>k'' = 8\<close> by auto
  then show ?thesis
      by (smt (z3) \<open>(c;;''x''::= (V ''x''\<lless>);;''t''::=(V ''y''\<doteq>1);;''x''::= ((V ''x'') \<oplus> (V ''t''));;''y''::= (V ''y''\<then>),s0) \<Rightarrow>\<^bsup> k \<^esup> s\<close> \<open>s1 = s'\<close> big_step_t_determ2 char.inject fun_upd_apply le_add1 list.inject mult_2_right)
qed

lemma update_encode_R:
  assumes encode_R: "((encode_tape_instr R),s0) \<Rightarrow>\<^bsup> k \<^esup> s"
  assumes update_R: "(l,r) = update R (l0,r0)"
  and tape_state_eq: "s0 ''x'' = tape_to_nat l0 \<and> s0 ''y'' = tape_to_nat r0"
shows "s ''x'' = tape_to_nat l " "s ''y'' = tape_to_nat r"
proof -
  from encode_R encode_R_y have "s ''y'' = s0 ''y'' div 2" by auto
  then have "s ''y'' = tape_to_nat r0 div 2" using tape_state_eq by simp
  moreover have "r = tl r0" using update_R
    by (metis Nil_tl Turing.update.simps(4) prod.inject)
  moreover have "tape_to_nat (tl r0) = tape_to_nat r0 div 2" by (induct r0) auto
  ultimately show "s ''y'' = tape_to_nat r" by simp
  next
    from encode_R encode_R_x have "s ''x'' = s0 ''x'' * 2 + s0 ''y'' mod 2" by blast
    then have "s ''x'' = tape_to_nat l0 * 2 + tape_to_nat r0 mod 2" using tape_state_eq by simp
    have "l = (if r0 = [] then (Bk#l0) else (hd r0 # l0))" using update_R by auto
    then have "tape_to_nat l =  tape_to_nat l0 * 2 + tape_to_nat r0 mod 2" proof (cases r0)
      case Nil
      then have "l = (Bk#l0)"
        by (simp add: \<open>l = (if r0 = [] then (Bk#l0) else (hd r0 # l0))\<close>)
      then show ?thesis using local.Nil by auto
    next
      case (Cons a list)
      then show ?thesis proof (cases a)
        case Bk
      then have "l = (Bk#l0)" by (simp add: \<open>l = (if r0 = [] then (Bk#l0) else (hd r0 # l0))\<close> local.Cons)
        then show ?thesis by (simp add: Bk local.Cons)
      next
        case Oc
        then have "l = (Oc#l0)" by (simp add: \<open>l = (if r0 = [] then (Bk#l0) else (hd r0 # l0))\<close> local.Cons)
        then have "tape_to_nat l =  tape_to_nat l0 * 2 + 1" by simp
        have "odd(tape_to_nat (Oc#list))" by simp
        then have "tape_to_nat (Oc#list) mod 2 = 1" by presburger
        show ?thesis
          using Oc \<open>tape_to_nat (Oc # list) mod 2 = 1\<close> \<open>tape_to_nat l =  tape_to_nat l0 * 2 + 1\<close> local.Cons by auto
      qed
    qed
    then show "s ''x'' = tape_to_nat l" by (simp add: \<open>s ''x'' = tape_to_nat l0 * 2 + tape_to_nat r0 mod 2\<close>)
  qed

subsection "Transforming Turing Machine to IMP-"

abbreviation nth_name:: "nat \<Rightarrow> string" where
"nth_name n \<equiv> (as_string ((next^^n) (default::name)))"

text "After each iteration exactly one variable of the set corresponding to the states of the turing machine is 0.
We step into that statement and read the current head and store it in t and then step into the corresponding statement and
encode the turing machine operation as an arithmetic one."
fun turing_to_while_acc :: "tprog0 \<Rightarrow> name \<Rightarrow> com" where (* state has to evaluate all variables to 1 except (next (default::name)) which has to be 0 at the beginning *)
"turing_to_while_acc [] _ = SKIP" |
"turing_to_while_acc ((a0,s0)#(a1,s1)#is) n = turing_to_while_acc is (next n);;
  IF (as_string n)\<noteq>0 THEN SKIP
                     ELSE (''t''::=(V ''x''\<doteq>1);;IF ''t''\<noteq>0 THEN
                            encode_tape_instr a1;;(nth_name s1)::=A (N 0);;(as_string n)::=A (N 1);;''z''::=(A(N s1))
                          ELSE encode_tape_instr a0;;(nth_name s0)::=A (N 0);;(as_string n)::=A (N 1));;''z''::=(A(N s0))"
text "We iterate through the while loop until we enter the halting state/accepting state which corresponds to default:name (_)."
fun turing_to_while :: "config \<Rightarrow> tprog0 \<Rightarrow> com" where
"turing_to_while c p = (let (z,x,y) = encode_tape c in (''z''::=A (N z);;''x''::=A (N x);;''y''::=A (N y)));;
                                          WHILE (as_string (default::name))\<noteq>0 DO turing_to_while_acc p (next default)"

lemma conversion_correct_current_state:
  assumes "(turing_to_while_acc p n, \<lambda>s. if s=''x'' then tape_to_nat l else if s=''y'' then tape_to_nat r else if s = nth_name state then 0 else 1) \<Rightarrow>\<^bsup> k \<^esup> s"
  and "encode_tape (step0 (state,l,r) p) = (s1,l1,r1)"
  and is_in_program: "nth_name state \<in> set (Max_Constant.all_variables (turing_to_while_acc p n))"
  and tm_wf: "tm_wf0 p"
shows "(s1,l1,r1) = (s ''z'', s ''x'', s ''y'')"
  using assms proof(induction p n rule: turing_to_while_acc.induct)
    case (1 uu)
    then show ?case by simp
  next
    case (2 a0 s0 a1 s1 "is" n)
    from is_in_program have "nth_name state \<in> set (all_variables (turing_to_while_acc ((a0, s0) # (a1, s1) # is) n))"
      using "2.prems"(3) by blast
    then consider "nth_name state \<in> set (all_variables (turing_to_while_acc is (next n)))" |
    "nth_name state \<in> set (all_variables (turing_to_while_acc ((a0, s0) # [(a1, s1)]) n))" by auto
      then show ?case sorry
  next
    case (3 v b)
    then show ?case by simp
  qed

lemma state_contained:
  assumes tm_wf: "tm_wf0 p"
  and "nth_name e = as_string n" "e > 1"
  and is_valid_state: "2 * s \<le> length p" "s > 0"(* s > 0 cause 0 is special halting case, treated in the while loop and 2 * s \<le> length p cause there are at most p div 2 states *)
shows "nth_name s \<in> set (Max_Constant.all_variables (turing_to_while_acc p n))"
  using assms proof(induction p n rule: turing_to_while_acc.induct)
  case (1 uu)
  then show ?case by simp
next
  case (2 a0 s0 a1 s1 "is" n)
  then show ?case sorry
next
  case (3 v b)
  then show ?case by simp
qed

lemma conversion_step_correct:
  assumes tm_wf: "tm_wf0 p"
  and "(turing_to_while_acc p n, \<lambda>s. if s=''x'' then tape_to_nat l else if s=''y'' then tape_to_nat r else if s = nth_name state then 0 else 1) \<Rightarrow>\<^bsup> k \<^esup> s"
  and "encode_tape (step0 (state,l,r) p) = (s1,l1,r1)"
  shows "(s1,l1,r1) = (s ''z'', s ''x'', s ''y'')"
  using assms proof(induction p n rule: turing_to_while_acc.induct)
    case (1 uu)
    then show ?case by simp
  next
    case (2 a0 s0 a1 s1 "is" n)
    then show ?case sorry
  next
    case (3 v b)
    then show ?case by simp
  qed

lemma conversion_correct:
  assumes tm_wf: "tm_wf (p,0)"
  and tm_accepts: "is_final(steps0 c p n)"
  and "(turing_to_while c p, \<lambda>s. if s = ''__'' then 0 else 1) \<Rightarrow>\<^bsup> k \<^esup> s "
  shows "encode_tape (steps0 c p n) = (s ''_'',s ''x'', s ''y'')"
  using assms proof (induct p)
      case Nil
      then show ?case using tm_wf by force
    next
      case (Cons a p)
      then show ?case sorry
    qed


theory Memtype imports Main
begin

(** This file defines the interface for the memory model that
  is used in the dynamic semantics of all the languages used in the compiler.
  It defines a type [mem] of memory states, the following 4 basic
  operations over memory states, and their properties:
- [load]: read a memory chunk at a given address;
- [store]: store a memory chunk at a given address;
- [alloc]: allocate a fresh memory block;
- [free]: invalidate a memory block.
*)

(** Memory states are accessed by addresses [b, ofs]: pairs of a block
  identifier [b] and a byte offset [ofs] within that block.
  Each address is associated to permissions, also known as access rights.
  The following permissions are expressible:
- Freeable (exclusive access): all operations permitted
- Writable: load, store and pointer comparison operations are permitted,
  but freeing is not.
- Readable: only load and pointer comparison operations are permitted.
- Nonempty: valid, but only pointer comparisons are permitted.
- Empty: not yet allocated or previously freed; no operation permitted.

The first four cases are represented by the following type of permissions.
Being empty is represented by the absence of any permission.
*)

datatype permission =
    Freeable
  | Writable
  | Readable
  | Nonempty

(** In the list, each permission implies the other permissions further down the
    list.  We reflect this fact by the following order over permissions. *)

inductive perm_order :: "permission \<Rightarrow> permission \<Rightarrow> bool" where
    perm_refl: "perm_order p p"
  | perm_F_any: "perm_order Freeable p"
  | perm_W_R: "perm_order Writable Readable"
  | perm_any_N: "perm_order p Nonempty"

declare perm_order.intros[intro!]

lemma perm_order_code[code]: "perm_order p1 p2 =
  (if p1 = p2 then True else
  case (p1, p2) of
    (Freeable, _) \<Rightarrow> True
  | (Writable, Readable) \<Rightarrow> True
  | (_, Nonempty) \<Rightarrow> True
  | _ \<Rightarrow> False)"
  apply (simp add: perm_order.simps)
  by (metis permission.exhaust permission.simps(13) permission.simps(14) permission.simps(15) permission.simps(16))

lemma perm_order_trans:
  "perm_order p1 p2 \<Longrightarrow> perm_order p2 p3 \<Longrightarrow> perm_order p1 p3"
  using perm_order.simps by auto

(** Each address has not one, but two permissions associated
  with it.  The first is the current permission.  It governs whether
  operations (load, store, free, etc) over this address succeed or
  not.  The other is the maximal permission.  It is always at least as
  strong as the current permission.  Once a block is allocated, the
  maximal permission of an address within this block can only
  decrease, as a result of [free] or [drop_perm] operations, or of
  external calls.  In contrast, the current permission of an address
  can be temporarily lowered by an external call, then raised again by
  another external call. *)

datatype perm_kind = Max | Cur

end


section \<open>One-slot consistency\<close>

text \<open>The replicated state machine determines the values that are committed in each of a sequence
of \textit{slots}. Each slot runs a logically-separate consensus algorithm which is shown to be
consistent here. Further below, the protocol is shown to refine this slot-by-slot model correctly.\<close>

text \<open>Consistency is shown to follow from the invariants listed below. Further below, the protocol
is shown to preserve these invariants in each step, which means it is not enormously important
to understand these in detail.\<close>

theory OneSlot
  imports Preliminaries
begin

locale oneSlot =
  (* basic functions *)
  fixes Q :: "Node set set"
  fixes v :: "Term \<Rightarrow> Value"
    (* message-sent predicates *)
  fixes promised\<^sub>f :: "Node \<Rightarrow> Term \<Rightarrow> bool"
  fixes promised\<^sub>b :: "Node \<Rightarrow> Term \<Rightarrow> Term \<Rightarrow> bool"
  fixes proposed :: "Term \<Rightarrow> bool"
  fixes accepted :: "Node \<Rightarrow> Term \<Rightarrow> bool"
  fixes committed :: "Term \<Rightarrow> bool"
    (* other definitions *)
  fixes promised :: "Node \<Rightarrow> Term \<Rightarrow> bool"
  defines "promised n t \<equiv> promised\<^sub>f n t \<or> (\<exists> t'. promised\<^sub>b n t t')"
  fixes prevAccepted :: "Term \<Rightarrow> Node set \<Rightarrow> Term set"
  defines "prevAccepted t ns \<equiv> {t'. \<exists> n \<in> ns. promised\<^sub>b n t t'}"
    (* invariants *)
  assumes Q_intersects: "Q \<frown> Q"
  assumes promised\<^sub>f: "\<lbrakk> promised\<^sub>f n t; t' < t \<rbrakk> \<Longrightarrow> \<not> accepted n t'"
  assumes promised\<^sub>b_lt: "promised\<^sub>b n t t' \<Longrightarrow> t' < t"
  assumes promised\<^sub>b_accepted: "promised\<^sub>b n t t' \<Longrightarrow> accepted n t'"
  assumes promised\<^sub>b_max: "\<lbrakk> promised\<^sub>b n t t'; t' < t''; t'' < t \<rbrakk>
   \<Longrightarrow> \<not> accepted n t''"
  assumes proposed: "proposed t
     \<Longrightarrow> \<exists> q \<in> Q. (\<forall> n \<in> q. promised n t)
                     \<and> (prevAccepted t q = {}
                          \<or> (\<exists> t'. v t = v t' \<and> maxTerm (prevAccepted t q) \<le> t' \<and> proposed t' \<and> t' < t))"
  assumes proposed_finite: "finite {t. proposed t}"
  assumes accepted: "accepted n t \<Longrightarrow> proposed t"
  assumes committed: "committed t \<Longrightarrow> \<exists> q \<in> Q. \<forall> n \<in> q. accepted n t"

lemma (in oneSlot) prevAccepted_proposed: "prevAccepted t ns \<subseteq> {t. proposed t}"
  using accepted prevAccepted_def promised\<^sub>b_accepted by fastforce

lemma (in oneSlot) prevAccepted_finite: "finite (prevAccepted p ns)"
  using prevAccepted_proposed proposed_finite by (meson rev_finite_subset)

lemma (in oneSlot) Q_nonempty: "\<And>q. q \<in> Q \<Longrightarrow> q \<noteq> {}"
  using Q_intersects by (auto simp add: intersects_def)

text \<open>The heart of the consistency proof is property P2b from \textit{Paxos made simple} by Lamport:\<close>

lemma (in oneSlot) p2b:
  assumes "proposed t\<^sub>1" and "committed t\<^sub>2" and "t\<^sub>2 < t\<^sub>1"
  shows "v t\<^sub>1 = v t\<^sub>2"
  using assms
proof (induct t\<^sub>1 rule: less_induct)
  case (less t\<^sub>1)

  hence hyp: "\<And> t\<^sub>1'. \<lbrakk> t\<^sub>1' < t\<^sub>1; proposed t\<^sub>1'; t\<^sub>2 \<le> t\<^sub>1' \<rbrakk> \<Longrightarrow> v t\<^sub>1' = v t\<^sub>2"
    using le_imp_less_or_eq by blast

  from `proposed t\<^sub>1` obtain q\<^sub>1 t\<^sub>1' where
    q\<^sub>1_quorum:   "q\<^sub>1 \<in> Q" and
    q\<^sub>1_promised: "\<And>n. n \<in> q\<^sub>1 \<Longrightarrow> promised n t\<^sub>1" and
    q\<^sub>1_value:    "prevAccepted t\<^sub>1 q\<^sub>1 = {} \<or> (v t\<^sub>1 = v t\<^sub>1' \<and> maxTerm (prevAccepted t\<^sub>1 q\<^sub>1) \<le> t\<^sub>1' \<and> proposed t\<^sub>1' \<and> t\<^sub>1' < t\<^sub>1)"
    by (meson proposed)

  from `committed t\<^sub>2` obtain q\<^sub>2 where
    q\<^sub>2_quorum:   "q\<^sub>2 \<in> Q" and
    q\<^sub>2_accepted: "\<And>n. n \<in> q\<^sub>2 \<Longrightarrow> accepted n t\<^sub>2"
    using committed by force

  have "q\<^sub>1 \<inter> q\<^sub>2 \<noteq> {}"
    using Q_intersects intersects_def less.prems q\<^sub>1_quorum q\<^sub>2_quorum by auto

  then obtain n where n\<^sub>1: "n \<in> q\<^sub>1" and n\<^sub>2: "n \<in> q\<^sub>2" by auto

  from n\<^sub>1 q\<^sub>1_promised have "promised n t\<^sub>1" by simp
  moreover from n\<^sub>2 q\<^sub>2_accepted have "accepted n t\<^sub>2" by simp
  ultimately obtain t\<^sub>2' where t\<^sub>2': "promised\<^sub>b n t\<^sub>1 t\<^sub>2'"
    using less.prems(3) promised\<^sub>f promised_def by blast

  have q\<^sub>1_value: "v t\<^sub>1 = v t\<^sub>1'" "maxTerm (prevAccepted t\<^sub>1 q\<^sub>1) \<le> t\<^sub>1'" "proposed t\<^sub>1'" "t\<^sub>1' < t\<^sub>1"
    using n\<^sub>1 prevAccepted_def q\<^sub>1_value t\<^sub>2' by auto

  note `v t\<^sub>1 = v t\<^sub>1'`
  also have "v t\<^sub>1' = v t\<^sub>2"
  proof (intro hyp)
    have p: "maxTerm (prevAccepted t\<^sub>1 q\<^sub>1) \<in> prevAccepted t\<^sub>1 q\<^sub>1"
      apply (intro maxTerm_mem prevAccepted_finite)
      using n\<^sub>1 prevAccepted_def t\<^sub>2' by auto

    show "t\<^sub>1' < t\<^sub>1" "proposed t\<^sub>1'" using q\<^sub>1_value by simp_all

    have "t\<^sub>2 \<le> t\<^sub>2'"
      by (meson \<open>accepted n t\<^sub>2\<close> less.prems(3) not_le promised\<^sub>b_max t\<^sub>2')
    also have "t\<^sub>2' \<le> maxTerm (prevAccepted t\<^sub>1 q\<^sub>1)"
      using n\<^sub>1 prevAccepted_def t\<^sub>2' prevAccepted_finite by (intro maxTerm_max, auto)
    also have "... \<le> t\<^sub>1'" using q\<^sub>1_value by simp
    finally show "t\<^sub>2 \<le> t\<^sub>1'" .
  qed

  finally show ?case .
qed

text \<open>From this, it follows that any two committed values are equal as desired.\<close>

lemma (in oneSlot) consistent:
  assumes "committed t\<^sub>1" and "committed t\<^sub>2"
  shows "v t\<^sub>1 = v t\<^sub>2"
  using assms by (metis Q_nonempty accepted all_not_in_conv committed not_less_iff_gr_or_eq p2b)

text \<open>It will be useful later to know the conditions under which a value in a term can be committed,
which is spelled out here:\<close>

lemma (in oneSlot) commit:
  assumes q_quorum: "q \<in> Q"
  assumes q_accepted: "\<And>n. n \<in> q \<Longrightarrow> accepted n t\<^sub>0"
  defines "committed' t \<equiv> committed t \<or> t = t\<^sub>0"
  shows "oneSlot Q v promised\<^sub>f promised\<^sub>b proposed accepted committed'"
  by (smt committed'_def Q_intersects oneSlot_axioms oneSlot_def q_accepted q_quorum)

end


theory sort_SSortPermutes
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun ssortminimum :: "int => int list => int" where
"ssortminimum x (Nil2) = x"
| "ssortminimum x (Cons2 z ys) =
     (if z <= x then ssortminimum z ys else ssortminimum x ys)"

fun delete :: "int => int list => int list" where
"delete x (Nil2) = Nil2"
| "delete x (Cons2 z ys) =
     (if x = z then ys else Cons2 z (delete x ys))"

fun ssort :: "int list => int list" where
"ssort (Nil2) = Nil2"
| "ssort (Cons2 y ys) =
     Cons2
       (ssortminimum y ys)
       (ssort (delete (ssortminimum y ys) (Cons2 y ys)))"

fun count :: "int => int list => Nat" where
"count x (Nil2) = Z"
| "count x (Cons2 z xs) =
     (if x = z then S (count x xs) else count x xs)"

(*hipster ssortminimum delete ssort count *)

theorem x0 :
  "!! (x :: int) (y :: int list) . (count x (ssort y)) = (count x y)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


header {* Type Application *}

theory TypeApp
imports HOLCF
begin

subsection {* Class of type constructors *}

text {* In HOLCF, the type @{typ "udom defl"} consists of deflations
over the universal domain---each value of type @{typ "udom defl"}
represents a bifinite domain. In turn, values of the continuous
function type @{typ "udom defl \<rightarrow> udom defl"} represent functions from
domains to domains, i.e.~type constructors. *}

text {* Class @{text tycon}, defined below, will be populated with
dummy types: For example, if the type @{text foo} is an instance of
class @{text tycon}, then users will never deal with any values @{text
"x::foo"} in practice. Such types are only used with the overloaded
constant @{text tc}, which associates each type @{text "'a::tycon"}
with a value of type @{typ "udom defl \<rightarrow> udom defl"}. \medskip *}

class tycon =
  fixes tc :: "('a::type) itself \<Rightarrow> udom defl \<rightarrow> udom defl"

text {* Type @{typ "'a itself"} is defined in Isabelle's meta-logic;
it is inhabited by a single value, written @{term "TYPE('a)"}. We
define the syntax @{text "TC('a)"} to abbreviate @{text "tc
TYPE('a)"}. \medskip *}

syntax  "_TC" :: "type \<Rightarrow> logic"  ("(1TC/(1'(_')))")

translations "TC('a)" \<rightleftharpoons> "CONST tc TYPE('a)"

subsection {* Type constructor for type application *}

text {* We now define a binary type constructor that models type
application: Type @{text "('a, 't) app"} is the result of applying the
type constructor @{text 't} (from class @{text tycon}) to the type
argument @{text 'a} (from class @{text domain}). *}

text {* We define type @{text "('a, 't) app"} using @{text domaindef},
a low-level type-definition command provided by HOLCF (similar to
@{text typedef} in Isabelle/HOL) that defines a new domain type
represented by the given deflation. Note that in HOLCF, @{text
"DEFL('a)"} is an abbreviation for @{text "defl TYPE('a)"}, where
@{text "defl :: ('a::domain) itself \<Rightarrow> udom defl"} is an overloaded
function from the @{text domain} type class that yields the deflation
representing the given type. \medskip *}

domaindef ('a,'t) app = "TC('t::tycon)\<cdot>DEFL('a::domain)"

text {* We define the infix syntax @{text "'a\<cdot>'t"} for the type @{text
"('a,'t) app"}. Note that for consistency with Isabelle's existing
type syntax, we have used postfix order for type application: type
argument on the left, type constructor on the right. \medskip *}

type_notation app ("(_\<cdot>_)" [999,1000] 999)

text {* The @{text domaindef} command generates the theorem @{text
DEFL_app}: @{thm DEFL_app [where 'a="'a::domain" and 't="'t::tycon"]},
which we can use to derive other useful lemmas. \medskip *}

lemma TC_DEFL: "TC('t::tycon)\<cdot>DEFL('a) = DEFL('a\<cdot>'t)"
by (rule DEFL_app [symmetric])

lemma DEFL_app_mono [simp, intro]:
  "DEFL('a) \<sqsubseteq> DEFL('b) \<Longrightarrow> DEFL('a\<cdot>'t::tycon) \<sqsubseteq> DEFL('b\<cdot>'t)"
 apply (simp add: DEFL_app)
 apply (erule monofun_cfun_arg)
done

end


(*  Title:      HOL/Hoare/Separation.thy
    Author:     Tobias Nipkow
    Copyright   2003 TUM

A first attempt at a nice syntactic embedding of separation logic.
Already builds on the theory for list abstractions.

If we suppress the H parameter for "List", we have to hardwired this
into parser and pretty printer, which is not very modular.
Alternative: some syntax like <P> which stands for P H. No more
compact, but avoids the funny H.

*)

theory Separation imports Hoare_Logic_Abort SepLogHeap begin

text\<open>The semantic definition of a few connectives:\<close>

definition ortho :: "heap \<Rightarrow> heap \<Rightarrow> bool" (infix "\<bottom>" 55)
  where "h1 \<bottom> h2 \<longleftrightarrow> dom h1 \<inter> dom h2 = {}"

definition is_empty :: "heap \<Rightarrow> bool"
  where "is_empty h \<longleftrightarrow> h = Map.empty"

definition singl:: "heap \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
  where "singl h x y \<longleftrightarrow> dom h = {x} & h x = Some y"

definition star:: "(heap \<Rightarrow> bool) \<Rightarrow> (heap \<Rightarrow> bool) \<Rightarrow> (heap \<Rightarrow> bool)"
  where "star P Q = (\<lambda>h. \<exists>h1 h2. h = h1++h2 \<and> h1 \<bottom> h2 \<and> P h1 \<and> Q h2)"

definition wand:: "(heap \<Rightarrow> bool) \<Rightarrow> (heap \<Rightarrow> bool) \<Rightarrow> (heap \<Rightarrow> bool)"
  where "wand P Q = (\<lambda>h. \<forall>h'. h' \<bottom> h \<and> P h' \<longrightarrow> Q(h++h'))"

text\<open>This is what assertions look like without any syntactic sugar:\<close>

lemma "VARS x y z w h
 {star (%h. singl h x y) (%h. singl h z w) h}
 SKIP
 {x \<noteq> z}"
apply vcg
apply(auto simp:star_def ortho_def singl_def)
done

text\<open>Now we add nice input syntax.  To suppress the heap parameter
of the connectives, we assume it is always called H and add/remove it
upon parsing/printing. Thus every pointer program needs to have a
program variable H, and assertions should not contain any locally
bound Hs - otherwise they may bind the implicit H.\<close>

syntax
 "_emp" :: "bool" ("emp")
 "_singl" :: "nat \<Rightarrow> nat \<Rightarrow> bool" ("[_ \<mapsto> _]")
 "_star" :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "**" 60)
 "_wand" :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "-*" 60)

(* FIXME does not handle "_idtdummy" *)
ML \<open>
\<comment> \<open>\<open>free_tr\<close> takes care of free vars in the scope of separation logic connectives:
    they are implicitly applied to the heap\<close>
fun free_tr(t as Free _) = t $ Syntax.free "H"
\<^cancel>\<open>| free_tr((list as Free("List",_))$ p $ ps) = list $ Syntax.free "H" $ p $ ps\<close>
  | free_tr t = t

fun emp_tr [] = Syntax.const \<^const_syntax>\<open>is_empty\<close> $ Syntax.free "H"
  | emp_tr ts = raise TERM ("emp_tr", ts);
fun singl_tr [p, q] = Syntax.const \<^const_syntax>\<open>singl\<close> $ Syntax.free "H" $ p $ q
  | singl_tr ts = raise TERM ("singl_tr", ts);
fun star_tr [P,Q] = Syntax.const \<^const_syntax>\<open>star\<close> $
      absfree ("H", dummyT) (free_tr P) $ absfree ("H", dummyT) (free_tr Q) $
      Syntax.free "H"
  | star_tr ts = raise TERM ("star_tr", ts);
fun wand_tr [P, Q] = Syntax.const \<^const_syntax>\<open>wand\<close> $
      absfree ("H", dummyT) P $ absfree ("H", dummyT) Q $ Syntax.free "H"
  | wand_tr ts = raise TERM ("wand_tr", ts);
\<close>

parse_translation \<open>
 [(\<^syntax_const>\<open>_emp\<close>, K emp_tr),
  (\<^syntax_const>\<open>_singl\<close>, K singl_tr),
  (\<^syntax_const>\<open>_star\<close>, K star_tr),
  (\<^syntax_const>\<open>_wand\<close>, K wand_tr)]
\<close>

text\<open>Now it looks much better:\<close>

lemma "VARS H x y z w
 {[x\<mapsto>y] ** [z\<mapsto>w]}
 SKIP
 {x \<noteq> z}"
apply vcg
apply(auto simp:star_def ortho_def singl_def)
done

lemma "VARS H x y z w
 {emp ** emp}
 SKIP
 {emp}"
apply vcg
apply(auto simp:star_def ortho_def is_empty_def)
done

text\<open>But the output is still unreadable. Thus we also strip the heap
parameters upon output:\<close>

ML \<open>
local

fun strip (Abs(_,_,(t as Const("_free",_) $ Free _) $ Bound 0)) = t
  | strip (Abs(_,_,(t as Free _) $ Bound 0)) = t
\<^cancel>\<open>| strip (Abs(_,_,((list as Const("List",_))$ Bound 0 $ p $ ps))) = list$p$ps\<close>
  | strip (Abs(_,_,(t as Const("_var",_) $ Var _) $ Bound 0)) = t
  | strip (Abs(_,_,P)) = P
  | strip (Const(\<^const_syntax>\<open>is_empty\<close>,_)) = Syntax.const \<^syntax_const>\<open>_emp\<close>
  | strip t = t;

in

fun is_empty_tr' [_] = Syntax.const \<^syntax_const>\<open>_emp\<close>
fun singl_tr' [_,p,q] = Syntax.const \<^syntax_const>\<open>_singl\<close> $ p $ q
fun star_tr' [P,Q,_] = Syntax.const \<^syntax_const>\<open>_star\<close> $ strip P $ strip Q
fun wand_tr' [P,Q,_] = Syntax.const \<^syntax_const>\<open>_wand\<close> $ strip P $ strip Q

end
\<close>

print_translation \<open>
 [(\<^const_syntax>\<open>is_empty\<close>, K is_empty_tr'),
  (\<^const_syntax>\<open>singl\<close>, K singl_tr'),
  (\<^const_syntax>\<open>star\<close>, K star_tr'),
  (\<^const_syntax>\<open>wand\<close>, K wand_tr')]
\<close>

text\<open>Now the intermediate proof states are also readable:\<close>

lemma "VARS H x y z w
 {[x\<mapsto>y] ** [z\<mapsto>w]}
 y := w
 {x \<noteq> z}"
apply vcg
apply(auto simp:star_def ortho_def singl_def)
done

lemma "VARS H x y z w
 {emp ** emp}
 SKIP
 {emp}"
apply vcg
apply(auto simp:star_def ortho_def is_empty_def)
done

text\<open>So far we have unfolded the separation logic connectives in
proofs. Here comes a simple example of a program proof that uses a law
of separation logic instead.\<close>

\<comment> \<open>a law of separation logic\<close>
lemma star_comm: "P ** Q = Q ** P"
  by(auto simp add:star_def ortho_def dest: map_add_comm)

lemma "VARS H x y z w
 {P ** Q}
 SKIP
 {Q ** P}"
apply vcg
apply(simp add: star_comm)
done

lemma "VARS H
 {p\<noteq>0 \<and> [p \<mapsto> x] ** List H q qs}
 H := H(p \<mapsto> q)
 {List H p (p#qs)}"
apply vcg
apply(simp add: star_def ortho_def singl_def)
apply clarify
apply(subgoal_tac "p \<notin> set qs")
 prefer 2
 apply(blast dest:list_in_heap)
apply simp
done

lemma "VARS H p q r
  {List H p Ps ** List H q Qs}
  WHILE p \<noteq> 0
  INV {\<exists>ps qs. (List H p ps ** List H q qs) \<and> rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := the(H p); H := H(r \<mapsto> q); q := r OD
  {List H q (rev Ps @ Qs)}"
apply vcg
apply(simp_all add: star_def ortho_def singl_def)

apply fastforce

apply (clarsimp simp add:List_non_null)
apply(rename_tac ps')
apply(rule_tac x = ps' in exI)
apply(rule_tac x = "p#qs" in exI)
apply simp
apply(rule_tac x = "h1(p:=None)" in exI)
apply(rule_tac x = "h2(p\<mapsto>q)" in exI)
apply simp
apply(rule conjI)
 apply(rule ext)
 apply(simp add:map_add_def split:option.split)
apply(rule conjI)
 apply blast
apply(simp add:map_add_def split:option.split)
apply(rule conjI)
apply(subgoal_tac "p \<notin> set qs")
 prefer 2
 apply(blast dest:list_in_heap)
apply(simp)
apply fast

apply(fastforce)
done

end


(*  Title:      Containers/DList_Set.thy
    Author:     Andreas Lochbihler, KIT *)

theory DList_Set imports
  "Collection_Eq"
  "Equal"
begin

section {* Sets implemented by distinct lists *}

subsection {* Operations on the raw type with parametrised equality *}

context equal_base begin

primrec list_member :: "'a list \<Rightarrow> 'a \<Rightarrow> bool"
where
  "list_member []       y \<longleftrightarrow> False"
| "list_member (x # xs) y \<longleftrightarrow> equal x y \<or> list_member xs y"

primrec list_distinct :: "'a list \<Rightarrow> bool"
where
  "list_distinct []       \<longleftrightarrow> True"
| "list_distinct (x # xs) \<longleftrightarrow> \<not> list_member xs x \<and> list_distinct xs"

definition list_insert :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "list_insert x xs = (if list_member xs x then xs else x # xs)"

primrec list_remove1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "list_remove1 x [] = []"
| "list_remove1 x (y # xs) = (if equal x y then xs else y # list_remove1 x xs)"

primrec list_remdups :: "'a list \<Rightarrow> 'a list" where
  "list_remdups [] = []"
| "list_remdups (x # xs) = (if list_member xs x then list_remdups xs else x # list_remdups xs)"

lemma list_member_filterD: "list_member (filter P xs) x \<Longrightarrow> list_member xs x"
by(induct xs)(auto split: split_if_asm)

lemma list_distinct_filter [simp]: "list_distinct xs \<Longrightarrow> list_distinct (filter P xs)"
by(induct xs)(auto dest: list_member_filterD)

lemma list_distinct_tl [simp]: "list_distinct xs \<Longrightarrow> list_distinct (tl xs)"
by(cases xs) simp_all

end

lemmas [code] =
  equal_base.list_member.simps
  equal_base.list_distinct.simps
  equal_base.list_insert_def
  equal_base.list_remove1.simps
  equal_base.list_remdups.simps

lemmas [simp] =
  equal_base.list_member.simps
  equal_base.list_distinct.simps
  equal_base.list_remove1.simps
  equal_base.list_remdups.simps

lemma list_member_conv_member [simp]:
  "equal_base.list_member op = = List.member"
proof(intro ext)
  fix xs and x :: 'a
  show "equal_base.list_member op = xs x = List.member xs x"
    by(induct xs)(auto simp add: List.member_def)
qed

lemma list_distinct_conv_distinct [simp]:
  "equal_base.list_distinct op = = List.distinct"
proof
  fix xs :: "'a list"
  show "equal_base.list_distinct op = xs = distinct xs"
    by(induct xs)(auto simp add: List.member_def)
qed

lemma list_insert_conv_insert [simp]:
  "equal_base.list_insert op = = List.insert"
unfolding equal_base.list_insert_def[abs_def] List.insert_def[abs_def]
by(simp add: List.member_def)

lemma list_remove1_conv_remove1 [simp]:
  "equal_base.list_remove1 op = = List.remove1"
unfolding equal_base.list_remove1_def List.remove1_def ..

lemma list_remdups_conv_remdups [simp]:
  "equal_base.list_remdups op = = List.remdups"
unfolding equal_base.list_remdups_def List.remdups_def list_member_conv_member List.member_def ..

context equal begin

lemma member_insert [simp]: "list_member (list_insert x xs) y \<longleftrightarrow> equal x y \<or> list_member xs y"
by(auto simp add: equal_eq List.member_def)

lemma member_remove1 [simp]:
  "\<not> equal x y \<Longrightarrow> list_member (list_remove1 x xs) y = list_member xs y"
by(simp add: equal_eq List.member_def)

lemma distinct_remove1:
  "list_distinct xs \<Longrightarrow> list_distinct (list_remove1 x xs)"
by(simp add: equal_eq)

lemma distinct_member_remove1 [simp]:
  "list_distinct xs \<Longrightarrow> list_member (list_remove1 x xs) = (list_member xs)(x := False)"
by(auto simp add: equal_eq List.member_def[abs_def] fun_eq_iff)

end

lemma ID_ceq: (* FIXME: Adapt Set_Impl to directly use above equal class! *)
  "ID CEQ('a :: ceq) = Some eq \<Longrightarrow> equal eq"
by(unfold_locales)(clarsimp simp add: ID_ceq)

subsection {* The type of distinct lists *}

typedef 'a :: ceq set_dlist =
  "{xs::'a list. equal_base.list_distinct ceq' xs \<or> ID CEQ('a) = None}"
  morphisms list_of_dlist Abs_dlist'
proof
  show "[] \<in> ?set_dlist" by(simp)
qed

definition Abs_dlist :: "'a :: ceq list \<Rightarrow> 'a set_dlist"
where
  "Abs_dlist xs = Abs_dlist'
  (if equal_base.list_distinct ceq' xs \<or> ID CEQ('a) = None then xs
   else equal_base.list_remdups ceq' xs)"

lemma Abs_dlist_inverse:
  fixes y :: "'a :: ceq list"
  assumes "y \<in> {xs. equal_base.list_distinct ceq' xs \<or> ID CEQ('a) = None}"
  shows "list_of_dlist (Abs_dlist y) = y"
using assms by(auto simp add: Abs_dlist_def Abs_dlist'_inverse)

lemma list_of_dlist_inverse: "Abs_dlist (list_of_dlist dxs) = dxs"
by(cases dxs)(simp add: Abs_dlist'_inverse Abs_dlist_def)

lemma type_definition_set_dlist':
  "type_definition list_of_dlist Abs_dlist
  {xs :: 'a :: ceq list. equal_base.list_distinct ceq' xs \<or> ID CEQ('a) = None}"
by(unfold_locales)(rule set_dlist.list_of_dlist Abs_dlist_inverse list_of_dlist_inverse)+

lemmas Abs_dlist_cases[cases type: set_dlist] =
  type_definition.Abs_cases[OF type_definition_set_dlist']
  and Abs_dlist_induct[induct type: set_dlist] =
  type_definition.Abs_induct[OF type_definition_set_dlist'] and
  Abs_dlist_inject = type_definition.Abs_inject[OF type_definition_set_dlist']

setup_lifting type_definition_set_dlist'

subsection {* Operations *}

lift_definition empty :: "'a :: ceq set_dlist" is "[]"
by simp

lift_definition insert :: "'a :: ceq \<Rightarrow> 'a set_dlist \<Rightarrow> 'a set_dlist" is
  "equal_base.list_insert ceq'"
by(simp add: equal_base.list_insert_def)

lift_definition remove :: "'a :: ceq \<Rightarrow> 'a set_dlist \<Rightarrow> 'a set_dlist" is
  "equal_base.list_remove1 ceq'"
by(auto simp: equal.distinct_remove1 ID_ceq)

lift_definition filter :: "('a :: ceq \<Rightarrow> bool) \<Rightarrow> 'a set_dlist \<Rightarrow> 'a set_dlist" is List.filter
by(auto simp add: equal_base.list_distinct_filter)

text {* Derived operations: *}

lift_definition null :: "'a :: ceq set_dlist \<Rightarrow> bool" is List.null .

lift_definition member :: "'a :: ceq set_dlist \<Rightarrow> 'a \<Rightarrow> bool" is "equal_base.list_member ceq'" .

lift_definition length :: "'a :: ceq set_dlist \<Rightarrow> nat" is List.length .

lift_definition fold :: "('a :: ceq \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a set_dlist \<Rightarrow> 'b \<Rightarrow> 'b" is List.fold .

lift_definition foldr :: "('a :: ceq \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a set_dlist \<Rightarrow> 'b \<Rightarrow> 'b" is List.foldr .

lift_definition hd :: "'a :: ceq set_dlist \<Rightarrow> 'a" is "List.hd" .

lift_definition tl :: "'a :: ceq set_dlist \<Rightarrow> 'a set_dlist" is "List.tl"
by(auto simp add: equal_base.list_distinct_tl)

lift_definition dlist_all :: "('a \<Rightarrow> bool) \<Rightarrow> 'a :: ceq set_dlist \<Rightarrow> bool" is "list_all" .

lift_definition dlist_ex :: "('a \<Rightarrow> bool) \<Rightarrow> 'a :: ceq set_dlist \<Rightarrow> bool" is "list_ex" .

definition union :: "'a :: ceq set_dlist \<Rightarrow> 'a set_dlist \<Rightarrow> 'a set_dlist" where
  "union = fold insert"

lift_definition product :: "'a :: ceq set_dlist \<Rightarrow> 'b :: ceq set_dlist \<Rightarrow> ('a \<times> 'b) set_dlist"
  is "\<lambda>xs ys. rev (concat (map (\<lambda>x. map (Pair x) ys) xs))"
proof -
  fix xs :: "'a list" and ys :: "'b list"
  assume *: "equal_base.list_distinct ceq' xs \<or> ID CEQ('a) = None"
    "equal_base.list_distinct ceq' ys \<or> ID CEQ('b) = None"
  let ?product = "concat (map (\<lambda>x. map (Pair x) ys) xs)"
  { assume neq: "ID CEQ('a) \<noteq> None" "ID CEQ('b) \<noteq> None"
    hence ceq': "ceq' = (op = :: 'a \<Rightarrow> 'a \<Rightarrow> bool)" "ceq' = (op = :: 'b \<Rightarrow> 'b \<Rightarrow> bool)"
      by(auto intro: equal.equal_eq[OF ID_ceq])
    with * neq have dist: "distinct xs" "distinct ys" by simp_all
    hence "distinct ?product"
      by(cases "ys = []")(auto simp add: distinct_map map_replicate_const intro!: inj_onI distinct_concat)
    hence "distinct (rev ?product)" by simp
    moreover have "ceq' = (op = :: ('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool)"
      using neq ceq' by(auto simp add: ceq_prod_def ID_Some fun_eq_iff)
    ultimately have "equal_base.list_distinct ceq' (rev ?product)" by simp }
  with *
  show "equal_base.list_distinct ceq' (rev ?product) \<or> ID CEQ('a \<times> 'b) = None"
    by(fastforce simp add: ceq_prod_def ID_def split: option.split_asm)
qed

lift_definition Id_on :: "'a :: ceq set_dlist \<Rightarrow> ('a \<times> 'a) set_dlist"
 is "map (\<lambda>x. (x, x))"
proof -
  fix xs :: "'a list"
  assume ceq: "equal_base.list_distinct ceq' xs \<or> ID CEQ('a) = None"
  {
    assume ceq: "ID CEQ('a \<times> 'a) \<noteq> None"
      and xs: "equal_base.list_distinct ceq' xs"
    from ceq have "ID CEQ('a) \<noteq> None"
      and "ceq' = (op = :: 'a \<Rightarrow> 'a \<Rightarrow> bool)"
      and "ceq' = (op = :: ('a \<times> 'a) \<Rightarrow> ('a \<times> 'a) \<Rightarrow> bool)"
      by(auto simp add: equal.equal_eq[OF ID_ceq] ceq_prod_def ID_None ID_Some split: option.split_asm)
    hence "?thesis xs" using xs by(auto simp add: distinct_map intro: inj_onI) }
  thus "?thesis xs" using ceq by(auto dest: equal.equal_eq[OF ID_ceq] simp add: ceq_prod_def ID_None)
qed

subsection {* Properties *}

lemma member_empty [simp]: "member empty = (\<lambda>_. False)"
by transfer (simp add: fun_eq_iff)

lemma null_iff [simp]: "null xs \<longleftrightarrow> xs = empty"
by transfer(simp add: List.null_def)

lemma list_of_dlist_empty [simp]: "list_of_dlist DList_Set.empty = []"
by(rule empty.rep_eq)

lemma list_of_dlist_insert [simp]: "\<not> member dxs x \<Longrightarrow> list_of_dlist (insert x dxs) = x # list_of_dlist dxs"
by(cases dxs)(auto simp add: DList_Set.insert_def DList_Set.member_def Abs_dlist_inverse Abs_dlist_inject equal_base.list_insert_def List.member_def intro: Abs_dlist_inverse)

lemma list_of_dlist_eq_Nil_iff [simp]: "list_of_dlist dxs = [] \<longleftrightarrow> dxs = empty"
by(cases dxs)(auto simp add: Abs_dlist_inverse Abs_dlist_inject DList_Set.empty_def)

lemma fold_empty [simp]: "DList_Set.fold f empty b = b"
by(transfer) simp

lemma fold_insert [simp]: "\<not> member dxs x \<Longrightarrow> DList_Set.fold f (insert x dxs) b = DList_Set.fold f dxs (f x b)"
by(transfer)(simp add: equal_base.list_insert_def)

lemma no_memb_fold_insert:
  "\<not> member dxs x \<Longrightarrow> fold f (insert x dxs) b = fold f dxs (f x b)"
by(transfer)(simp add: equal_base.list_insert_def)

lemma set_fold_insert: "set (List.fold List.insert xs1 xs2) = set xs1 \<union> set xs2"
by(induct xs1 arbitrary: xs2) simp_all

lemma list_of_dlist_eq_singleton_conv:
  "list_of_dlist dxs = [x] \<longleftrightarrow> dxs = DList_Set.insert x DList_Set.empty"
by transfer(case_tac dxs, auto simp add: equal_base.list_insert_def)

lemma product_code [code abstract]:
  "list_of_dlist (product dxs1 dxs2) = fold (\<lambda>a. fold (\<lambda>c rest. (a, c) # rest) dxs2) dxs1 []"
proof -
  { fix xs ys and zs :: "('a \<times> 'b) list"
    have "rev (concat (map (\<lambda>x. map (Pair x) ys) xs)) @ zs =
          List.fold (\<lambda>a. List.fold (\<lambda>c rest. (a, c) # rest) ys) xs zs"
    proof(induction xs arbitrary: zs)
      case Nil thus ?case by simp
    next
      case (Cons x xs)
      have "List.fold (\<lambda>c rest. (x, c) # rest) ys zs = rev (map (Pair x) ys) @ zs"
        by(induct ys arbitrary: zs) simp_all
      with Cons.IH[of "rev (map (Pair x) ys) @ zs"]
      show ?case by simp
    qed }
  from this[of "list_of_dlist dxs2" "list_of_dlist dxs1" "[]"]
  show ?thesis by(simp add: product.rep_eq fold.rep_eq)
qed

lemma set_list_of_dlist_Abs_dlist:
  "set (list_of_dlist (Abs_dlist xs)) = set xs"
by(clarsimp simp add: Abs_dlist_def Abs_dlist'_inverse)(subst Abs_dlist'_inverse, auto dest: equal.equal_eq[OF ID_ceq])

context assumes ID_ceq_neq_None: "ID CEQ('a :: ceq) \<noteq> None"
begin

lemma equal_ceq: "equal (ceq' :: 'a \<Rightarrow> 'a \<Rightarrow> bool)"
using ID_ceq_neq_None by(clarsimp)(rule ID_ceq)

(* workaround for the next theorem *)
declare Domainp_forall_transfer[where A = "pcr_set_dlist op=", simplified set_dlist.domain_eq, transfer_rule]

lemma set_dlist_induct [case_names Nil insert, induct type: set_dlist]:
  fixes dxs :: "'a :: ceq set_dlist"
  assumes Nil: "P empty" and Cons: "\<And>a dxs. \<lbrakk> \<not> member dxs a; P dxs \<rbrakk> \<Longrightarrow> P (insert a dxs)"
  shows "P dxs"
using assms
proof transfer
  fix P :: "'a list \<Rightarrow> bool" and xs :: "'a list"
  assume NIL: "P []"
    and Insert: "\<And>xs. equal_base.list_distinct ceq' xs \<or> ID CEQ('a) = None
                 \<Longrightarrow> (\<And>x. \<lbrakk> \<not> equal_base.list_member ceq' xs x; P xs \<rbrakk> \<Longrightarrow> P (equal_base.list_insert ceq' x xs))"
    and Eq: "equal_base.list_distinct ceq' xs \<or> ID CEQ('a) = None"
  from Eq show "P xs"
  proof(induction xs)
    case Nil show ?case by(rule NIL)
  next
    case (Cons x xs) thus ?case using Insert[of xs x] equal.equal_eq[OF equal_ceq] ID_ceq_neq_None
      by(auto simp add: List.member_def simp del: not_None_eq)
  qed
qed

context
begin
interpretation lifting_syntax .

lemma fold_transfer2 [transfer_rule]:
  assumes "is_equality A"
  shows "((A ===> pcr_set_dlist op = ===> pcr_set_dlist op =) ===>
    (pcr_set_dlist op = :: 'a list \<Rightarrow> 'a set_dlist \<Rightarrow> bool) ===> pcr_set_dlist op = ===> pcr_set_dlist op =)
     List.fold DList_Set.fold"
unfolding Transfer.Rel_def set_dlist.pcr_cr_eq
proof(rule rel_funI)+
  fix f :: "'a \<Rightarrow> 'b list \<Rightarrow> 'b list" and g and xs :: "'a list" and ys and b :: "'b list" and c
  assume fg: "(A ===> cr_set_dlist ===> cr_set_dlist) f g"
  assume "cr_set_dlist xs ys" "cr_set_dlist b c"
  thus "cr_set_dlist (List.fold f xs b) (DList_Set.fold g ys c)"
  proof(induct ys arbitrary: xs b c rule: set_dlist_induct)
    case Nil thus ?case by(simp add: cr_set_dlist_def)
  next
    case (insert y dxs)
    have "A y y" and "cr_set_dlist (list_of_dlist c) c"
      using assms by(simp_all add: cr_set_dlist_def is_equality_def)
    with fg have "cr_set_dlist (f y (list_of_dlist c)) (g y c)"
      by -(drule (1) rel_funD)+
    thus ?case using insert by(simp add: cr_set_dlist_def)
  qed
qed

end

lemma distinct_list_of_dlist:
  "distinct (list_of_dlist (dxs :: 'a set_dlist))"
using list_of_dlist[of dxs] equal.equal_eq[OF equal_ceq]
by(simp add: ID_ceq_neq_None)

lemma member_empty_empty: "(\<forall>x :: 'a. \<not> member dxs x) \<longleftrightarrow> dxs = empty"
by(transfer)(simp add: equal.equal_eq[OF equal_ceq] List.member_def)

lemma Collect_member: "Collect (member (dxs :: 'a set_dlist)) = set (list_of_dlist dxs)"
by(simp add: member_def equal.equal_eq[OF equal_ceq] List.member_def[abs_def])

lemma member_insert: "member (insert (x :: 'a) xs) = (member xs)(x := True)"
by(transfer)(simp add: fun_eq_iff List.member_def ID_ceq_neq_None equal.equal_eq[OF equal_ceq])

lemma member_remove:
  "member (remove (x :: 'a) xs) = (member xs)(x := False)"
by transfer (auto simp add: fun_eq_iff ID_ceq_neq_None equal.equal_eq[OF equal_ceq] List.member_def)

lemma member_union: "member (union (xs1 :: 'a set_dlist) xs2) x \<longleftrightarrow> member xs1 x \<or> member xs2 x"
unfolding union_def
by(transfer)(simp add: equal.equal_eq[OF equal_ceq] List.member_def set_fold_insert)

lemma member_fold_insert: "member (List.fold insert xs dxs) (x :: 'a) \<longleftrightarrow> member dxs x \<or> x \<in> set xs"
by transfer(auto simp add: ID_ceq_neq_None equal.equal_eq[OF equal_ceq] List.member_def set_fold_insert)

lemma card_eq_length [simp]:
  "card (Collect (member (dxs :: 'a set_dlist))) = length dxs"
by transfer(simp add: ID_ceq_neq_None equal.equal_eq[OF equal_ceq] List.member_def[abs_def] distinct_card)

lemma finite_member [simp]:
  "finite (Collect (member (dxs :: 'a set_dlist)))"
by transfer(simp add: ID_ceq_neq_None equal.equal_eq[OF equal_ceq] List.member_def[abs_def])

lemma member_filter [simp]: "member (filter P xs) = (\<lambda>x :: 'a. member xs x \<and> P x)"
by transfer(simp add: ID_ceq_neq_None equal.equal_eq[OF equal_ceq] List.member_def[abs_def])

lemma dlist_all_conv_member: "dlist_all P dxs \<longleftrightarrow> (\<forall>x :: 'a. member dxs x \<longrightarrow> P x)"
by transfer(auto simp add: ID_ceq_neq_None equal.equal_eq[OF equal_ceq] list_all_iff List.member_def)

lemma member_Id_on: "member (Id_on dxs) = (\<lambda>(x :: 'a, y). x = y \<and> member dxs x)"
proof -
  have "ID CEQ('a \<times> 'a) = Some op ="
    using equal.equal_eq[where ?'a='a, OF equal_ceq]
    by(auto simp add: ceq_prod_def ID_ceq_neq_None ID_Some fun_eq_iff split: option.split)
  thus ?thesis
    using equal.equal_eq[where ?'a='a, OF equal_ceq]
    by transfer(auto simp add: ID_ceq_neq_None List.member_def[abs_def] ID_Some intro!: ext split: option.split_asm)
qed

end

lemma product_member:
  assumes "ID CEQ('a :: ceq) \<noteq> None" "ID CEQ('b :: ceq) \<noteq> None"
  shows "member (product dxs1 dxs2) = (\<lambda>(a :: 'a, b :: 'b). member dxs1 a \<and> member dxs2 b)"
proof -
  from assms have "ceq' = (op = :: 'a \<Rightarrow> 'a \<Rightarrow> bool)" "ceq' = (op = :: 'b \<Rightarrow> 'b \<Rightarrow> bool)"
    by(auto intro: equal.equal_eq[OF ID_ceq])
  moreover with assms have "ceq' = (op = :: ('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool)"
    by(auto simp add: ceq_prod_def ID_Some fun_eq_iff)
  ultimately show ?thesis by(transfer)(auto simp add: List.member_def[abs_def])
qed

hide_const (open) empty insert remove null member length fold foldr union filter hd tl dlist_all product Id_on

end


section \<open> Relational Calculus Laws \<close>

theory utp_rel_laws
  imports
    utp_rel
    utp_recursion
    utp_healthy
begin

section \<open> Conditional Laws \<close>

lemma rcond_idem [simp]: "P \<lhd> b \<rhd> P = P"
  by pred_auto

lemma rcond_sym: "P \<lhd> b \<rhd> Q = Q \<lhd> \<not>b \<rhd> P"
  by pred_auto

lemma rcond_assoc: "(P \<lhd> b \<rhd> Q) \<lhd> c \<rhd> R = P \<lhd> b \<and> c \<rhd> (Q \<lhd> c \<rhd> R)"
  by pred_auto

lemma rcond_distr: "P \<lhd> b \<rhd> (Q \<lhd> c \<rhd> R) = (P \<lhd> b \<rhd> Q) \<lhd> c \<rhd> (P \<lhd> b \<rhd> R)"
  by pred_auto

lemma rcond_true [simp]: "P \<lhd> True \<rhd> Q = P"
  by pred_auto

lemma rcond_false [simp]: "P \<lhd> False \<rhd> Q = Q"
  by pred_auto

lemma rcond_reach [simp]: "P \<lhd> b \<rhd> (Q \<lhd> b \<rhd> R) = P \<lhd> b \<rhd> R"
  by pred_auto

lemma rcond_disj [simp]: "P \<lhd> b \<rhd> (P \<lhd> c \<rhd> Q) = P \<lhd> b \<or> c \<rhd> Q"
  by pred_auto

lemma rcomp_rcond_left_distr:
  "(P \<lhd> b \<rhd> Q) ;; R = (P ;; R) \<lhd> b \<rhd> (Q ;; R) "
  by (pred_auto)

lemma rcond_seq_left_distr:
  "out\<alpha> \<sharp> b \<Longrightarrow> ((P \<triangleleft> b \<triangleright> Q) ;; R) = ((P ;; R) \<triangleleft> b \<triangleright> (Q ;; R))"
  by (pred_auto, blast)

lemma rcond_seq_right_distr:
  "in\<alpha> \<sharp> b \<Longrightarrow> (P ;; (Q \<triangleleft> b \<triangleright> R)) = ((P ;; Q) \<triangleleft> b \<triangleright> (P ;; R))"
  by (pred_auto, blast)

text \<open> Alternative expression of conditional using assumptions and choice \<close>

lemma rcond_rassume_expand: "P \<lhd> b \<rhd> Q = (\<questiondown>b? ;; P) \<sqinter> (\<questiondown>(\<not> b)? ;; Q)"
  by pred_auto

lemma rcond_mono [mono]: "\<lbrakk> (P\<^sub>1 :: 's pred) \<sqsubseteq> P\<^sub>2; Q\<^sub>1 \<sqsubseteq> Q\<^sub>2 \<rbrakk> \<Longrightarrow> (P\<^sub>1 \<triangleleft> b \<triangleright> Q\<^sub>1) \<sqsubseteq> (P\<^sub>2 \<triangleleft> b \<triangleright> Q\<^sub>2)"
  by pred_auto

lemma rcond_refine: "(P \<sqsubseteq> (Q \<triangleleft> b \<triangleright> R)) = (P \<sqsubseteq> (b \<and> Q)\<^sub>e \<and> (P \<sqsubseteq> ((\<not>b \<and> R)\<^sub>e)))"
  by pred_auto

section \<open> Precondition and Postcondition Laws \<close>

theorem precond_equiv:
  "P = (P ;; true) \<longleftrightarrow> (out\<alpha> \<sharp> P)"
  by (pred_auto)

theorem postcond_equiv:
  "P = (true ;; P) \<longleftrightarrow> (in\<alpha> \<sharp> P)"
  by (pred_auto)

theorem precond_left_zero:
  assumes "out\<alpha> \<sharp> p" "p \<noteq> false"
  shows "(true ;; p) = true"
  by (pred_auto assms: assms)

(*theorem feasibile_iff_true_right_zero:
  "P ;; true = true \<longleftrightarrow> (\<exists> out\<alpha> \<bullet> P)\<^sub>e"
  oops*)

subsection \<open> Sequential Composition Laws \<close>

lemma seqr_assoc: "(P ;; Q) ;; R = P ;; (Q ;; R)"
  by (pred_auto)

lemma seqr_left_unit [simp]:
  "II ;; P = P"
  by (pred_auto)

lemma seqr_right_unit [simp]:
  "P ;; II = P"
  by (pred_auto)

lemma seqr_left_zero [simp]:
  "false ;; P = false"
  by pred_auto

lemma seqr_right_zero [simp]:
  "P ;; false = false"
  by pred_auto

lemma seqr_mono:
  "\<lbrakk> P\<^sub>1 \<sqsubseteq> P\<^sub>2; Q\<^sub>1 \<sqsubseteq> Q\<^sub>2 \<rbrakk> \<Longrightarrow> (P\<^sub>1 ;; Q\<^sub>1) \<sqsubseteq> (P\<^sub>2 ;; Q\<^sub>2)"
  by (pred_auto, blast)

lemma mono_seqr [mono]:
  "\<lbrakk> mono P; mono Q \<rbrakk> \<Longrightarrow> mono (\<lambda> X. P X ;; Q X)"
  by (pred_auto add: mono_def, blast)

lemma cond_seqr_mono [mono]: "mono (\<lambda>X. (P ;; X) \<lhd> b \<rhd> II)"
  by (pred_auto add: mono_def)

lemma mono_seqr_tail:
  assumes "mono F"
  shows "mono (\<lambda> X. P ;; F(X))"
  by (pred_auto assms: assms add: mono_def)

lemma seqr_liberate_left: "vwb_lens x \<Longrightarrow> ((P  \\ $x\<^sup><) ;; Q) = ((P ;; Q) \\ $x\<^sup><)"
  by (pred_auto)

lemma seqr_liberate_right: "vwb_lens x \<Longrightarrow> P ;; Q \\ $x\<^sup>> = (P ;; Q) \\ $x\<^sup>>"
  by pred_auto

lemma seqr_or_distl:
  "((P \<or> Q) ;; R) = ((P ;; R) \<or> (Q ;; R))"
  by (pred_auto)

lemma seqr_or_distr:
  "(P ;; (Q \<or> R)) = ((P ;; Q) \<or> (P ;; R))"
  by (pred_auto)

lemma seqr_and_distr_ufunc:
  "Functional P \<Longrightarrow> (P ;; (Q \<and> R)) = ((P ;; Q) \<and> (P ;; R))"
  by (rel_auto, metis single_valuedD)

lemma seqr_and_distl_uinj:
  "Injective R \<Longrightarrow> ((P \<and> Q) ;; R) = ((P ;; R) \<and> (Q ;; R))"
  by (rel_auto, auto simp add: injective_def)

lemma seqr_unfold:
  "(P ;;\<^sub>h Q) = (\<exists> v. P\<lbrakk>\<guillemotleft>v\<guillemotright>/\<^bold>v\<^sup>>\<rbrakk> \<and> Q\<lbrakk>\<guillemotleft>v\<guillemotright>/\<^bold>v\<^sup><\<rbrakk>)\<^sub>e"
  by pred_auto

lemma seqr_unfold_heterogeneous:
  "(P ;; Q) = (\<exists> v. (pre(P\<lbrakk>\<guillemotleft>v\<guillemotright>/\<^bold>v\<^sup>>\<rbrakk>))\<^sup>< \<and> (post(Q\<lbrakk>\<guillemotleft>v\<guillemotright>/\<^bold>v\<^sup><\<rbrakk>))\<^sup>>)\<^sub>e"
  by pred_auto

lemma seqr_middle: "vwb_lens x \<Longrightarrow> P ;; Q = (\<Sqinter> v. P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<^sup>>\<rbrakk> ;; Q\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<^sup><\<rbrakk>)"
  by (pred_auto, metis vwb_lens.put_eq)

lemma seqr_left_one_point:
  assumes "vwb_lens x"
  shows "(P \<and> ($x\<^sup>> = \<guillemotleft>v\<guillemotright>)\<^sub>e) ;; Q = P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<^sup>>\<rbrakk> ;; Q\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<^sup><\<rbrakk>"
  by (pred_auto assms: assms, metis vwb_lens_wb wb_lens.get_put)

lemma seqr_right_one_point:
  assumes "vwb_lens x"
  shows "P ;; (($x\<^sup>< = \<guillemotleft>v\<guillemotright>)\<^sub>e \<and> Q) = P\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<^sup>>\<rbrakk> ;; Q\<lbrakk>\<guillemotleft>v\<guillemotright>/x\<^sup><\<rbrakk>"
  using assms
  by (pred_auto, metis vwb_lens_wb wb_lens.get_put)

lemma seqr_left_one_point_true:
  assumes "vwb_lens x"
  shows "(P \<and> ($x\<^sup>>)\<^sub>e) ;; Q = P\<lbrakk>True/x\<^sup>>\<rbrakk> ;; Q\<lbrakk>True/x\<^sup><\<rbrakk>"
  using assms
  by (pred_auto, metis (full_types) vwb_lens_wb wb_lens.get_put)

lemma seqr_left_one_point_false:
  assumes "vwb_lens x"
  shows "((P \<and> \<not>($x\<^sup>>)\<^sub>e) ;; Q) = (P\<lbrakk>False/x\<^sup>>\<rbrakk> ;; Q\<lbrakk>False/x\<^sup><\<rbrakk>)"
  using assms by (pred_auto, metis (full_types) vwb_lens_wb wb_lens.get_put)

lemma seqr_right_one_point_true:
  assumes "vwb_lens x"
  shows "(P ;; (($x\<^sup><)\<^sub>e \<and> Q)) = (P\<lbrakk>True/x\<^sup>>\<rbrakk> ;; Q\<lbrakk>True/x\<^sup><\<rbrakk>)"
  using assms by (pred_auto, metis (full_types) vwb_lens_wb wb_lens.get_put)

lemma seqr_right_one_point_false:
  assumes "vwb_lens x"
  shows "(P ;; (\<not>($x\<^sup><)\<^sub>e \<and> Q)) = (P\<lbrakk>False/x\<^sup>>\<rbrakk> ;; Q\<lbrakk>False/x\<^sup><\<rbrakk>)"
  using assms by (pred_auto, metis (full_types) vwb_lens_wb wb_lens.get_put)

lemma seqr_insert_ident_left:
  assumes "vwb_lens x" "$x\<^sup>> \<sharp> P" "$x\<^sup>< \<sharp> Q"
  shows "((($x\<^sup>> = $x\<^sup><)\<^sub>e \<and> P) ;; Q) = (P ;; Q)"
  by (pred_auto assms: assms, meson vwb_lens_def wb_lens_weak weak_lens.put_get)

lemma seqr_insert_ident_right:
  assumes "vwb_lens x" "$x\<^sup>> \<sharp> P" "$x\<^sup>< \<sharp> Q"
  shows "(P ;; (($x\<^sup>> = $x\<^sup><)\<^sub>e \<and> Q)) = (P ;; Q)"
  by (pred_auto assms: assms, metis (no_types, opaque_lifting) vwb_lens_def wb_lens_def weak_lens.put_get)

lemma seq_var_ident_lift:
  assumes "vwb_lens x" "$x\<^sup>> \<sharp> P" "$x\<^sup>< \<sharp> Q"
  shows "((($x\<^sup>> = $x\<^sup><)\<^sub>e \<and> P) ;; (($x\<^sup>> = $x\<^sup><)\<^sub>e \<and> Q)) = (($x\<^sup>> = $x\<^sup><)\<^sub>e \<and> (P ;; Q))"
  by (pred_auto assms: assms, metis (no_types, lifting) vwb_lens_wb wb_lens_weak weak_lens.put_get)

lemma seqr_bool_split:
  assumes "vwb_lens x"
  shows "P ;; Q = (P\<lbrakk>True/x\<^sup>>\<rbrakk> ;; Q\<lbrakk>True/x\<^sup><\<rbrakk> \<or> P\<lbrakk>False/x\<^sup>>\<rbrakk> ;; Q\<lbrakk>False/x\<^sup><\<rbrakk>)"
  using assms apply (subst seqr_middle[of x], simp_all)
  apply pred_auto
  apply (metis (full_types))
  done

lemma cond_inter_var_split:
  assumes "vwb_lens x"
  shows "(P \<triangleleft> $x\<^sup>> \<triangleright> Q) ;; R = (P\<lbrakk>True/x\<^sup>>\<rbrakk> ;; R\<lbrakk>True/x\<^sup><\<rbrakk> \<or> Q\<lbrakk>False/x\<^sup>>\<rbrakk> ;; R\<lbrakk>False/x\<^sup><\<rbrakk>)"
proof -
  have "(P \<triangleleft> $x\<^sup>> \<triangleright> Q) ;; R = (((x\<^sup>>)\<^sub>e \<and> P) ;; R \<or> (\<not> (x\<^sup>>)\<^sub>e \<and> Q) ;; R)"
    by pred_auto
  also have "... = ((P \<and> (x\<^sup>>)\<^sub>e) ;; R \<or> (Q \<and> \<not>(x\<^sup>>)\<^sub>e) ;; R)"
    by (pred_auto)
  also have "... = (P\<lbrakk>True/x\<^sup>>\<rbrakk> ;; R\<lbrakk>True/x\<^sup><\<rbrakk> \<or> Q\<lbrakk>False/x\<^sup>>\<rbrakk> ;; R\<lbrakk>False/x\<^sup><\<rbrakk>)"
    apply (pred_auto add: seqr_left_one_point_true seqr_left_one_point_false assms)
    by (metis (full_types) assms vwb_lens_wb wb_lens.get_put)+
  finally show ?thesis .
qed

theorem seqr_pre_transfer: "in\<alpha> \<sharp> q \<Longrightarrow> ((P \<and> q) ;; R) = (P ;; (q\<^sup>- \<and> R))"
  by pred_auto

theorem seqr_pre_transfer':
  "((P \<and> (q\<^sup>>)\<^sub>e) ;; R) = (P ;; ((q\<^sup><)\<^sub>e \<and> R))"
  by (pred_auto)

theorem seqr_post_out: "in\<alpha> \<sharp> r \<Longrightarrow> (P ;; (Q \<and> r)) = ((P ;; Q) \<and> r)"
  by (pred_auto)

lemma seqr_post_var_out:
  shows "(P ;; (Q \<and> (x\<^sup>>)\<^sub>e)) = ((P ;; Q) \<and> (x\<^sup>>)\<^sub>e)"
  by (pred_auto)

theorem seqr_post_transfer: "out\<alpha> \<sharp> q \<Longrightarrow> (P ;; (q \<and> R)) = ((P \<and> q\<^sup>-) ;; R)"
  by (pred_auto)

lemma seqr_pre_out: "out\<alpha> \<sharp> p \<Longrightarrow> ((p \<and> Q) ;; R) = (p \<and> (Q ;; R))"
  by (pred_auto)

lemma seqr_pre_var_out:
  shows "(((x\<^sup><)\<^sub>e \<and> P) ;; Q) = ((x\<^sup><)\<^sub>e \<and> (P ;; Q))"
  by (pred_auto)

lemma seqr_true_lemma:
  "(P = (\<not> ((\<not> P) ;; true))) = (P = (P ;; true))"
  by (pred_auto)

lemma seqr_to_conj: "\<lbrakk> out\<alpha> \<sharp> P; in\<alpha> \<sharp> Q \<rbrakk> \<Longrightarrow> (P ;; Q) = (P \<and> Q)"
  by (pred_auto; blast)

lemma liberate_seq_unfold:
  "vwb_lens x \<Longrightarrow> $x \<sharp> Q \<Longrightarrow> (P \\ $x) ;; Q = (P ;; Q) \\ $x"
  apply (pred_auto)
  oops

(* the following laws are like HOL.ex_simps but for lenses *)

named_theorems "pred_ex_simps"

lemma ex_lens_split_conj_unrest [pred_ex_simps]:
  assumes "$x \<sharp> Q" "mwb_lens x"
  shows "(\<exists> x \<Zspot> P \<and> Q) = ((\<exists> x \<Zspot> P) \<and> Q)"
  using assms by pred_auto

lemma ex_lens_split_conj_unrest2 [pred_ex_simps]:
  assumes "$x \<sharp> P" "mwb_lens x"
  shows "(\<exists> x \<Zspot> P \<and> Q) = (P \<and> (\<exists> x \<Zspot> Q))"
  using assms by pred_auto

lemma ex_lens_split_disj_unrest  [pred_ex_simps]:
  assumes "$x \<sharp> Q" "mwb_lens x"
  shows "(\<exists> x \<Zspot> P \<or> Q) = ((\<exists> x \<Zspot> P) \<or> Q)"
  using assms by pred_auto

lemma ex_lens_split_disj_unrest2  [pred_ex_simps]:
  assumes "$x \<sharp> P" "mwb_lens x"
  shows "(\<exists> x \<Zspot> P \<or> Q) = (P \<or> (\<exists> x \<Zspot> Q))"
  using assms by pred_auto

lemma ex_lens_split_impl_unrest  [pred_ex_simps]:
  assumes "$x \<sharp> Q" "mwb_lens x"
  shows "(\<exists> x \<Zspot> P \<longrightarrow> Q) = ((\<forall> x \<Zspot> P) \<longrightarrow> Q)"
  using assms by pred_auto

lemma ex_lens_split_impl_unrest2  [pred_ex_simps]:
  assumes "$x \<sharp> P" "mwb_lens x"
  shows "(\<exists> x \<Zspot> P \<longrightarrow> Q) = (P \<longrightarrow> (\<exists> x \<Zspot> Q))"
  using assms by pred_auto

(*
lemma shEx_mem_lift_seq_1 [uquant_lift]:
  assumes "out\<alpha> \<sharp> A"
  shows "((\<^bold>\<exists> x \<in> A \<bullet> P x) ;; Q) = (\<^bold>\<exists> x \<in> A \<bullet> (P x ;; Q))"
  using assms by rel_blast

lemma shEx_lift_seq_2 [uquant_lift]:
  "(P ;; (\<^bold>\<exists> x \<bullet> Q x)) = (\<^bold>\<exists> x \<bullet> (P ;; Q x))"
  by pred_auto

lemma shEx_mem_lift_seq_2 [uquant_lift]:
  assumes "in\<alpha> \<sharp> A"
  shows "(P ;; (\<^bold>\<exists> x \<in> A \<bullet> Q x)) = (\<^bold>\<exists> x \<in> A \<bullet> (P ;; Q x))"
  using assms by rel_blast*)

subsection \<open> Iterated Sequential Composition Laws \<close>

lemma iter_seqr_nil [simp]: "(;; i : [] \<bullet> P(i)) = II"
  by (simp add: seqr_iter_def)

lemma iter_seqr_cons [simp]: "(;; i : (x # xs) \<bullet> P(i)) = P(x) ;; (;; i : xs \<bullet> P(i))"
  by (simp add: seqr_iter_def)

subsection \<open> Quantale Laws \<close>

lemma seq_Sup_distl: "P ;; (\<Sqinter> A) = (\<Sqinter> Q\<in>A. P ;; Q)"
  by pred_auto

lemma seq_Sup_distr: "(\<Sqinter> A) ;; Q = (\<Sqinter> P\<in>A. P ;; Q)"
  by pred_auto

lemma seq_SUP_distl: "P ;; (\<Sqinter> Q\<in>A. F(Q)) = (\<Sqinter> Q\<in>A. P ;; F(Q))"
  by pred_auto

lemma seq_SUP_distr: "(\<Sqinter> P\<in>A. F(P)) ;; Q = (\<Sqinter> P\<in>A. F(P) ;; Q)"
  by pred_auto

subsection \<open> Skip Laws \<close>

lemma cond_skip: "out\<alpha> \<sharp> b \<Longrightarrow> (b \<and> II) = (II \<and> b\<^sup>-)"
  by (pred_auto)

lemma pre_skip_post: "((b\<^sup><)\<^sub>e \<and> II) = (II \<and> (b\<^sup>>)\<^sub>e)"
  by (pred_auto)

lemma skip_var:
  fixes x :: "(bool \<Longrightarrow> '\<alpha>)"
  shows "(($x\<^sup><)\<^sub>e \<and> II) = (II \<and> ($x\<^sup>>)\<^sub>e)"
  by (pred_auto)

(*
text \<open>Liberate currently doesn't work on relations - it expects a lens of type 'a instead of 'a \<times> 'a\<close>
lemma skip_r_unfold:
  "vwb_lens x \<Longrightarrow> II = (($x\<^sup>> = $x\<^sup><)\<^sub>e \<and> II \\ $x)"
  by (rel_simp, metis mwb_lens.put_put vwb_lens_mwb vwb_lens_wb wb_lens.get_put)
*)

lemma skip_r_alpha_eq:
  "II = (\<^bold>v\<^sup>< = \<^bold>v\<^sup>>)\<^sub>e"
  by (pred_auto)

(*
lemma skip_ra_unfold:
  "II\<^bsub>x;y\<^esub> = ($x\<acute> =\<^sub>u $x \<and> II\<^bsub>y\<^esub>)"
  by (pred_auto)

lemma skip_res_as_ra:
  "\<lbrakk> vwb_lens y; x +\<^sub>L y \<approx>\<^sub>L 1\<^sub>L; x \<bowtie> y \<rbrakk> \<Longrightarrow> II\<restriction>\<^sub>\<alpha>x = II\<^bsub>y\<^esub>"
  apply (pred_auto)
   apply (metis (no_types, lifting) lens_indep_def)
  apply (metis vwb_lens.put_eq)
  done
*)

subsection \<open> Assignment Laws \<close>

lemma assigns_skip: "\<langle>id\<rangle>\<^sub>a = II"
  by pred_auto

lemma assigns_comp: "\<langle>\<sigma>\<rangle>\<^sub>a ;; \<langle>\<rho>\<rangle>\<^sub>a = \<langle>\<rho> \<circ>\<^sub>s \<sigma>\<rangle>\<^sub>a"
  by pred_auto

lemma assigns_cond: "\<langle>\<sigma>\<rangle>\<^sub>a \<lhd> b \<rhd> \<langle>\<rho>\<rangle>\<^sub>a = \<langle>\<sigma> \<triangleleft> b \<triangleright> \<rho>\<rangle>\<^sub>a"
  by pred_auto

text \<open>Extend the alphabet of a substitution\<close>

lemma assigns_subst: "(subst_aext \<sigma> fst\<^sub>L) \<dagger> \<langle>\<rho>\<rangle>\<^sub>a = \<langle>\<rho> \<circ>\<^sub>s \<sigma>\<rangle>\<^sub>a"
  by pred_auto

lemma assigns_r_comp: "(\<langle>\<sigma>\<rangle>\<^sub>a ;; P) = ((\<lambda> s. put\<^bsub>fst\<^sub>L\<^esub> s (\<sigma> (get\<^bsub>fst\<^sub>L\<^esub> s))) \<dagger> P)"
  by (pred_auto)

lemma assigns_r_feasible:
  "(\<langle>\<sigma>\<rangle>\<^sub>a ;; true) = true"
  by (pred_auto)

lemma assign_subst [usubst]:
  "\<lbrakk> vwb_lens x; vwb_lens y \<rbrakk> \<Longrightarrow>  [x\<^sup>> \<leadsto> u\<^sup><] \<dagger> (y := v) = (y, x) := ([x \<leadsto> u] \<dagger> v, u)"
  apply pred_auto
  oops

lemma assign_vacuous_skip:
  assumes "vwb_lens x"
  shows "(x := $x) = II"
  using assms by pred_auto

text \<open> The following law shows the case for the above law when $x$ is only mainly-well behaved. We
  require that the state is one of those in which $x$ is well defined using and assumption. \<close>

(*
lemma assign_vacuous_assume:
  assumes "mwb_lens x"
  shows "[&\<^bold>v \<in> \<guillemotleft>\<S>\<^bsub>x\<^esub>\<guillemotright>]\<^sup>\<top> ;; (x := &x) = [&\<^bold>v \<in> \<guillemotleft>\<S>\<^bsub>x\<^esub>\<guillemotright>]\<^sup>\<top>"
  using assms by pred_auto *)

lemma assign_simultaneous:
  assumes "vwb_lens y" "x \<bowtie> y"
  shows "(x,y) := (e, $y) = (x := e)"
  using assms by pred_auto

lemma assigns_idem: "mwb_lens x \<Longrightarrow> (x,x) := (v,u) = (x := v)"
  by pred_auto

lemma assigns_r_conv:
  "bij f \<Longrightarrow> \<langle>f\<rangle>\<^sub>a\<^sup>- = \<langle>inv f\<rangle>\<^sub>a"
  by (pred_auto, simp_all add: bij_is_inj bij_is_surj surj_f_inv_f)

lemma assign_pred_transfer:
  assumes "$x\<^sup>< \<sharp> b" "out\<alpha> \<sharp> b"
  shows "(b \<and> x := v) = (x := v \<and> b\<^sup>-)"
  using assms apply pred_auto oops

lemma assign_r_comp: "x := u ;; P = P\<lbrakk>u\<^sup></x\<^sup><\<rbrakk>"
  by pred_auto

lemma assign_test: "mwb_lens x \<Longrightarrow> (x := \<guillemotleft>u\<guillemotright> ;; x := \<guillemotleft>v\<guillemotright>) = (x := \<guillemotleft>v\<guillemotright>)"
  by pred_auto

lemma assign_twice: "\<lbrakk> mwb_lens x; $x \<sharp> f \<rbrakk> \<Longrightarrow> (x := e ;; x := f) = (x := f)"
  by pred_auto

lemma assign_commute:
  assumes "x \<bowtie> y" "$x \<sharp> f" "$y \<sharp> e" "vwb_lens x" "vwb_lens y"
  shows "(x := e ;; y := f) = (y := f ;; x := e)"
  using assms by (pred_auto add: lens_indep_comm)

lemma assign_cond:
  "(x := e ;; (P \<lhd> b \<rhd> Q)) = ((x := e ;; P) \<lhd> b\<lbrakk>e/x\<rbrakk> \<rhd> (x := e ;; Q))"
  by pred_auto

lemma assign_rcond:
  "(x := e ;; (P \<lhd> b \<rhd> Q)) = ((x := e ;; P) \<lhd> (b\<lbrakk>e/x\<rbrakk>) \<rhd> (x := e ;; Q))"
  by (pred_auto)

lemma assign_r_alt_def:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "x := v = II\<lbrakk>v\<^sup></x\<^sup><\<rbrakk>"
  by (pred_auto)

lemma assigns_r_func: "Functional \<langle>f\<rangle>\<^sub>a"
  unfolding Functional_def assigns_r_def single_valued_def pred_rel_def
  by simp

lemma assigns_r_injective: "inj f \<Longrightarrow> Injective \<langle>f\<rangle>\<^sub>a"
  unfolding Injective_def pred_rel_def injective_def
  apply auto
    apply (metis Functional_def assigns_r_func pred_rel_def)
    apply (simp add: assigns_r_def injD)
  done
(*
lemma assigns_r_swap_uinj:
  "\<lbrakk> vwb_lens x; vwb_lens y; x \<bowtie> y \<rbrakk> \<Longrightarrow> (x,y) := (y,x)"
  by (metis assigns_r_uinj pr_var_def swap_usubst_inj)

lemma assign_unfold:
  "vwb_lens x \<Longrightarrow> (x := v) = (x\<^sup>> = v\<^sup><)"
  apply (pred_auto, auto simp add: comp_def)
  using vwb_lens.put_eq by fastforce*)

subsection \<open> Non-deterministic Assignment Laws \<close>

(*
lemma ndet_assign_comp:
  "x \<bowtie> y \<Longrightarrow> x := * ;; y := * = (x,y) := *"
  by (pred_auto add: lens_indep.lens_put_comm)

lemma ndet_assign_assign:
  "\<lbrakk> vwb_lens x; $x \<sharp> e \<rbrakk> \<Longrightarrow> x := * ;; x := e = x := e"
  by pred_auto

lemma ndet_assign_refine:
  "x := * \<sqsubseteq> x := e"
  by pred_auto
*)

subsection \<open> Converse Laws \<close>

lemma convr_invol [simp]: "p\<^sup>-\<^sup>- = p"
  by pred_auto
(*
lemma lit_convr [simp]: "(\<guillemotleft>v\<guillemotright>)\<^sup>- = \<guillemotleft>v\<guillemotright>"
  by pred_auto

lemma uivar_convr [simp]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "($x\<^sup><)\<^sup>- = $x\<^sup>>"
  by pred_auto

lemma uovar_convr [simp]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "($x\<acute>)\<^sup>- = $x"
  by pred_auto

lemma uop_convr [simp]: "(uop f u)\<^sup>- = uop f (u\<^sup>-)"
  by (pred_auto)

lemma bop_convr [simp]: "(bop f u v)\<^sup>- = bop f (u\<^sup>-) (v\<^sup>-)"
  by (pred_auto)

lemma eq_convr [simp]: "(p = q)\<^sup>- = (p\<^sup>- = q\<^sup>-)"
  by (pred_auto)
*)

lemma not_convr [simp]: "(\<not> p)\<^sup>- = (\<not> p\<^sup>-)"
  by (pred_auto)

lemma disj_convr [simp]: "(p \<or> q)\<^sup>- = (q\<^sup>- \<or> p\<^sup>-)"
  by (pred_auto)

lemma conj_convr [simp]: "(p \<and> q)\<^sup>- = (q\<^sup>- \<and> p\<^sup>-)"
  by (pred_auto)

lemma seqr_convr [simp]: "(p ;; q)\<^sup>- = (q\<^sup>- ;; p\<^sup>-)"
  by (pred_auto)

(*
lemma pre_convr [simp]: "\<lceil>p\<rceil>\<^sub><\<^sup>- = \<lceil>p\<rceil>\<^sub>>"
  by (pred_auto)

lemma post_convr [simp]: "\<lceil>p\<rceil>\<^sub>>\<^sup>- = \<lceil>p\<rceil>\<^sub><"
  by (pred_auto)*)

subsection \<open> Assertion and Assumption Laws \<close>

(*
declare sublens_def [lens_defs del]

lemma assume_false: "\<questiondown>false? = false"
  by (pred_auto)

lemma assume_true: "\<questiondown>true? = II"
  by (pred_auto)

lemma assume_seq: "\<questiondown>b? ;; \<questiondown>c? = \<questiondown>b \<and> c?"
  by (pred_auto)

(*
lemma assert_false: "{false}\<^sub>\<bottom> = true"
  by (pred_auto)

lemma assert_true: "{true}\<^sub>\<bottom> = II"
  by (pred_auto)

lemma assert_seq: "{b}\<^sub>\<bottom> ;; {c}\<^sub>\<bottom> = {(b \<and> c)}\<^sub>\<bottom>"
  by (pred_auto)*)

subsection \<open> While Loop Laws \<close>

theorem while_unfold:
  "while b do P od = ((P ;; while b do P od) \<lhd> b \<rhd> II)"
proof -
  have m:"mono (\<lambda>X. (P ;; X) \<lhd> b \<rhd> II)"
    unfolding mono_def by (meson equalityE rcond_mono ref_by_def relcomp_mono)
  have "(while b do P od) = (\<nu> X \<bullet> (P ;; X) \<lhd> b \<rhd> II)"
    by (simp add: while_top_def)
  also have "... = ((P ;; (\<nu> X \<bullet> (P ;; X) \<lhd> b \<rhd> II)) \<lhd> b \<rhd> II)"
    by (subst lfp_unfold, simp_all add: m)
  also have "... = ((P ;; while b do P od) \<lhd> b \<rhd> II)"
    by (simp add: while_top_def)
  finally show ?thesis .
qed

theorem while_false: "while (false)\<^sub>e do P od = II"
  by (subst while_unfold, pred_auto)

theorem while_true: "while (true)\<^sub>e do P od = false"
  apply (simp add: while_top_def alpha)
  apply (rule antisym)
  apply (rule lfp_lowerbound)
  apply (pred_auto)+
  done

theorem while_bot_unfold:
  "while\<^sub>\<bottom> b do P od = ((P ;; while\<^sub>\<bottom> b do P od) \<lhd> b \<rhd> II)"
proof -
  have m:"mono (\<lambda>X. (P ;; X) \<lhd> b \<rhd> II)"
    unfolding mono_def by (meson equalityE rcond_mono ref_by_def relcomp_mono)
  have "(while\<^sub>\<bottom> b do P od) = (\<mu> X \<bullet> (P ;; X) \<lhd> b \<rhd> II)"
    by (simp add: while_bot_def)
  also have "... = ((P ;; (\<mu> X \<bullet> (P ;; X) \<lhd> b \<rhd> II)) \<lhd> b \<rhd> II)"
    by (subst gfp_unfold, simp_all add: m)
  also have "... = ((P ;; while\<^sub>\<bottom> b do P od) \<lhd> b \<rhd> II)"
    by (simp add: while_bot_def)
  finally show ?thesis .
qed

theorem while_bot_false: "while\<^sub>\<bottom> (false)\<^sub>e do P od = II"
  by (pred_auto add: while_bot_def gfp_const)

theorem while_bot_true: "while\<^sub>\<bottom> (true)\<^sub>e do P od = (\<mu> X \<bullet> P ;; X)"
  by (pred_auto add: while_bot_def)

text \<open> An infinite loop with a feasible body corresponds to a program error (non-termination). \<close>

theorem while_infinite: "P ;; true = true \<Longrightarrow> while\<^sub>\<bottom> (true)\<^sub>e do P od = true"
  apply (rule antisym)
   apply (simp add: true_pred_def)
    apply (pred_auto add: gfp_upperbound while_bot_true)
  done

subsection \<open> Algebraic Properties \<close>

interpretation upred_semiring: semiring_1
  where times = "(;;)" and one = Id and zero = false_pred and plus = "Lattices.sup"
  by (unfold_locales; pred_auto+)

declare upred_semiring.power_Suc [simp del]

text \<open> We introduce the power syntax derived from semirings \<close>

text \<open> Set up transfer tactic for powers \<close>
unbundle utp_lattice_syntax

lemma Sup_power_expand:
  fixes P :: "nat \<Rightarrow> 'a::complete_lattice"
  shows "P(0) \<sqinter> (\<Sqinter>i. P(i+1)) = (\<Sqinter>i. P(i))"
proof -
  have "UNIV = insert (0::nat) {1..}"
    by auto
  moreover have "(\<Sqinter>i. P(i)) = \<Sqinter> (P ` UNIV)"
    by (blast)
  moreover have "\<Sqinter> (P ` insert 0 {1..}) = P(0) \<sqinter> \<Sqinter> (P ` {1..})"
    by (simp)
  moreover have "\<Sqinter> (P ` {1..}) = (\<Sqinter>i. P(i+1))"
    sorry
  ultimately show ?thesis
    by simp
qed
*)
(*
lemma Sup_upto_Suc: "(\<Sqinter>i\<in>{0..Suc n}. P \<^bold>^ i) = (\<Sqinter>i\<in>{0..n}. P \<^bold>^ i) \<sqinter> P \<^bold>^ Suc n"
proof -
  have "(\<Sqinter>i\<in>{0..Suc n}. P \<^bold>^ i) = (\<Sqinter>i\<in>insert (Suc n) {0..n}. P \<^bold>^ i)"
    by (simp add: atLeast0_atMost_Suc)
  also have "... = P \<^bold>^ Suc n \<sqinter> (\<Sqinter>i\<in>{0..n}. P \<^bold>^ i)"
    by (simp)
  finally show ?thesis
    by (simp add: Lattices.sup_commute)
qed
*)

subsection \<open> Relational Power \<close>

lemma upower_interp [rel]: "\<lbrakk>P \<^bold>^ i\<rbrakk>\<^sub>U = \<lbrakk>P\<rbrakk>\<^sub>U ^^ i"
  by (induct i arbitrary: P)
     ((auto; pred_auto add: pred_rel_def), simp add: rel_interp(1) upred_semiring.power_Suc2)

lemma Sup_power_expand:
  fixes P :: "nat \<Rightarrow> 'a::complete_lattice"
  shows "P(0) \<sqinter> (\<Sqinter>i. P(i+1)) = (\<Sqinter>i. P(i))"
proof -
  have "UNIV = insert (0::nat) {1..}"
    by auto
  moreover have "(\<Sqinter>i. P(i)) = \<Sqinter> (P ` UNIV)"
    by (blast)
  moreover have "\<Sqinter> (P ` insert 0 {1..}) = P(0) \<sqinter> \<Sqinter> (P ` {1..})"
    by (simp)
  moreover have "\<Sqinter> (P ` {1..}) = (\<Sqinter>i. P(i+1))"
    by (simp add: atLeast_Suc_greaterThan greaterThan_0 image_image)
  ultimately show ?thesis
    by (simp only:)
qed

lemma Sup_upto_Suc: "(\<Sqinter>i\<in>{0..Suc n}. P \<^bold>^ i) = (\<Sqinter>i\<in>{0..n}. P \<^bold>^ i) \<sqinter> P \<^bold>^ Suc n"
proof -
  have "(\<Sqinter>i\<in>{0..Suc n}. P \<^bold>^ i) = (\<Sqinter>i\<in>insert (Suc n) {0..n}. P \<^bold>^ i)"
    by (simp add: atLeast0_atMost_Suc)
  also have "... = P \<^bold>^ Suc n \<sqinter> (\<Sqinter>i\<in>{0..n}. P \<^bold>^ i)"
    by (simp)
  finally show ?thesis
    by (simp add: Lattices.sup_commute)
qed

text \<open> The following two proofs are adapted from the AFP entry
  \href{https://www.isa-afp.org/entries/Kleene_Algebra.shtml}{Kleene Algebra}.
  See also~\cite{Armstrong2012,Armstrong2015}. \<close>

thm rel_transfer

thm inf_fun_def

lemma upower_inductl:
  assumes "Q \<sqsubseteq> ((P ;; Q) \<sqinter> R)"
  shows "Q \<sqsubseteq> P \<^bold>^ n ;; R"
proof (induct n)
  case 0
  with assms show ?case by rel_simp
next
  case (Suc n)
  with assms show ?case
    by (rel_transfer)
       (metis (no_types, lifting) O_assoc le_iff_sup relcomp_distrib relpow.simps(2) relpow_commute sup.coboundedI1)
qed

lemma upower_inductr:
  assumes "Q \<sqsubseteq> R \<sqinter> (Q ;; P)"
  shows "Q \<sqsubseteq> R ;; (P \<^bold>^ n)"
proof (induct n)
  case 0
  with assms show ?case by auto
next
  case (Suc n)
  with assms show ?case
    by (rel_transfer)
       (metis (no_types, lifting) O_assoc le_supE relcomp_distrib2 relpow.simps(2) sup.order_iff)
qed

lemma SUP_atLeastAtMost_first:
  fixes P :: "nat \<Rightarrow> 'a::complete_lattice"
  assumes "m \<le> n"
  shows "(\<Sqinter>i\<in>{m..n}. P(i)) = P(m) \<sqinter> (\<Sqinter>i\<in>{Suc m..n}. P(i))"
  by (metis SUP_insert assms atLeastAtMost_insertL)

lemma upower_seqr_iter: "P \<^bold>^ n = (;; Q : replicate n P \<bullet> Q)"
  by (induct n, simp_all add: power.power.power_Suc)

subsection \<open> Omega \<close>

(*
definition uomega :: "'\<alpha> rel \<Rightarrow> '\<alpha> rel" ("_\<^sup>\<omega>" [999] 999) where
"P\<^sup>\<omega> = (\<mu> X \<bullet> P ;; X)"

subsection \<open> Relation Algebra Laws \<close>

theorem seqr_disj_cancel: "((P\<^sup>- ;; (\<not>(P ;; Q))) \<or> (\<not>Q)) = (\<not>Q)"
  by (pred_auto)
*)

subsection \<open> Kleene Algebra Laws \<close>

lemma ustar_rep_eq [rel]: "\<lbrakk>P\<^sup>\<star>\<rbrakk>\<^sub>U = \<lbrakk>P\<rbrakk>\<^sub>U\<^sup>*"
proof
  have "((a, b) \<in> \<lbrakk>P\<rbrakk>\<^sub>U\<^sup>*) \<Longrightarrow> (a,b) \<in> \<lbrakk>P\<^sup>\<star>\<rbrakk>\<^sub>U" for a b
    apply (induct rule: rtrancl.induct)
     apply (simp_all add: pred_rel_def ustar_def)
     apply (metis (full_types) power.power.power_0 prod.simps(2) skip_def)
    by (metis (mono_tags, lifting) case_prodI upred_semiring.power_Suc2 utp_rel.seq_def)
  then show "\<lbrakk>P\<rbrakk>\<^sub>U\<^sup>* \<subseteq> \<lbrakk>P\<^sup>\<star>\<rbrakk>\<^sub>U"
    by auto
next
  have "((a, b) \<in> \<lbrakk>P\<^sup>\<star>\<rbrakk>\<^sub>U) \<Longrightarrow> (a,b) \<in> \<lbrakk>P\<rbrakk>\<^sub>U\<^sup>*" for a b
    apply (simp add: ustar_def pred_rel_def)
    by (metis mem_Collect_eq pred_rel_def rtrancl_power upower_interp)
  then show "\<lbrakk>P\<^sup>\<star>\<rbrakk>\<^sub>U \<subseteq> \<lbrakk>P\<rbrakk>\<^sub>U\<^sup>*"
    by force
qed

theorem ustar_sub_unfoldl: "P\<^sup>\<star> \<sqsubseteq> II \<sqinter> (P;;P\<^sup>\<star>)"
  by rel_auto

theorem ustar_inductl:
  assumes "Q \<sqsubseteq> R" "Q \<sqsubseteq> P ;; Q"
  shows "Q \<sqsubseteq> P\<^sup>\<star> ;; R"
proof -
  have "P\<^sup>\<star> ;; R = (\<Sqinter> i. P \<^bold>^ i ;; R)"
    by (simp add: seq_SUP_distr ustar_def)
  also have "Q \<sqsubseteq> ..."
    by (simp add: assms ref_lattice.INF_greatest upower_inductl)
  finally show ?thesis .
qed

theorem ustar_inductr:
  assumes "Q \<sqsubseteq> R" "Q \<sqsubseteq> Q ;; P"
  shows "Q \<sqsubseteq> R ;; P\<^sup>\<star>"
proof -
  have "R ;; P\<^sup>\<star> = (\<Sqinter> i. R ;; P \<^bold>^ i)"
    by (simp add: seq_SUP_distl ustar_def)
  also have "Q \<sqsubseteq> ..."
    by (simp add: assms ref_lattice.INF_greatest upower_inductr)
  finally show ?thesis .
qed

lemma ustar_refines_nu: "(\<nu> X \<bullet> (P ;; X) \<sqinter> II) \<sqsubseteq> P\<^sup>\<star>"
proof (rule ustar_inductl[where R="II", simplified])
  show "(\<nu> X \<bullet> (P ;; X) \<sqinter> II) \<sqsubseteq> II"
    by (simp add: ref_by_pred_is_leq, metis le_supE lfp_greatest)
  show "(\<nu> X \<bullet> (P ;; X) \<sqinter> II) \<sqsubseteq> P ;; (\<nu> X \<bullet> (P ;; X) \<sqinter> II)" (is "?lhs \<sqsubseteq> ?rhs")
  proof -
    have "?lhs = (P ;; (\<nu> X \<bullet> (P ;; X) \<sqinter> II)) \<sqinter> II"
      by (rule lfp_unfold, simp add: mono)
    also have "... \<sqsubseteq> ?rhs" by simp
    finally show ?thesis .
  qed
qed

lemma ustar_as_nu: "P\<^sup>\<star> = (\<nu> X \<bullet> (P ;; X) \<sqinter> II)"
proof (rule ref_antisym)
  show "(\<nu> X \<bullet> (P ;; X) \<sqinter> II) \<sqsubseteq> P\<^sup>\<star>"
    by (simp add: ustar_refines_nu)
  show "P\<^sup>\<star> \<sqsubseteq> (\<nu> X \<bullet> (P ;; X) \<sqinter> II)"
    by (metis lfp_lowerbound pred_ref_iff_le sup_commute ustar_sub_unfoldl)
qed

lemma ustar_unfoldl: "P\<^sup>\<star> = II \<sqinter> (P ;; P\<^sup>\<star>)"
  by (rel_auto, meson converse_rtranclE)

text \<open> While loop can be expressed using Kleene star \<close>

(*
lemma while_star_form:
  "while b do P od = (P \<lhd> b \<rhd> II)\<^sup>\<star> ;; \<questiondown>(\<not>b)?"
proof -
  have 1: "Continuous (\<lambda>X. P ;; X \<lhd> b \<rhd> II)"
    by (pred_auto)
  have "while b do P od = (\<Sqinter>i. ((\<lambda>X. P ;; X \<lhd> b \<rhd> II) ^^ i) false)"
    by (simp add: "1" sup_continuous_Continuous sup_continuous_lfp while_top_def top_false)
  also have "... = ((\<lambda>X. P ;; X \<lhd> b \<rhd> II) ^^ 0) false \<sqinter> (\<Sqinter>i. ((\<lambda>X. P ;; X \<lhd> b \<rhd> II) ^^ (i+1)) false)"
    by (subst Sup_power_expand, simp)
  also have "... = (\<Sqinter>i. ((\<lambda>X. P ;; X \<lhd> b \<rhd> II) ^^ (i+1)) false)"
    by (simp)
  also have "... = (\<Sqinter>i. (P \<lhd> b \<rhd> II)\<^bold>^i ;; (false \<lhd> b \<rhd> II))"
  proof (rule SUP_cong, simp_all)
    fix i
    show "P ;; ((\<lambda>X. P ;; X \<lhd> b \<rhd> II) ^^ i) false \<lhd> b \<rhd> II = (P \<lhd> b \<rhd> II) \<^bold>^ i ;; (false \<lhd> b \<rhd> II)"
    proof (induct i)
      case 0
      then show ?case by simp
    next
      case (Suc i)
      then show ?case
        apply (simp only: upred_semiring.power_Suc)
    qed
  qed
  also have "... = (\<Sqinter>i\<in>{0..} \<bullet> (P \<lhd> b \<rhd> II)\<^bold>^i ;; [(\<not>b)]\<^sup>\<top>)"
    by (pred_auto)
  also have "... = (P \<lhd> b \<rhd> II)\<^sup>\<star> ;; [(\<not>b)]\<^sup>\<top>"
    by (metis seq_UINF_distr ustar_def)
  finally show ?thesis .
qed
*)

subsection \<open> Omega Algebra Laws \<close>

(*
lemma uomega_induct: "P ;; P\<^sup>\<omega> \<sqsubseteq> P\<^sup>\<omega>"
  by (metis gfp_unfold monoI ref_by_set_def relcomp_mono subset_refl uomega_def)

subsection \<open> Refinement Laws \<close>

lemma skip_r_refine: "(p \<Rightarrow> p) \<sqsubseteq> II"
  by pred_auto

lemma conj_refine_left: "(Q \<Rightarrow> P) \<sqsubseteq> R \<Longrightarrow> P \<sqsubseteq> (Q \<and> R)"
  by (pred_auto)

lemma pre_weak_rel:
  assumes "`p \<longrightarrow> I`"
  and     "(I \<longrightarrow> q)\<^sub>e \<sqsubseteq> P"
  shows "(p \<longrightarrow> q)\<^sub>e \<sqsubseteq> P"
  using assms by(pred_auto)
*)

(*
lemma cond_refine_rel:
  assumes "S \<sqsubseteq> (\<lceil>b\<rceil>\<^sub>< \<and> P)" "S \<sqsubseteq> (\<lceil>\<not>b\<rceil>\<^sub>< \<and> Q)"
  shows "S \<sqsubseteq> P \<lhd> b \<rhd> Q"
  by (metis aext_not assms(1) assms(2) cond_def lift_rcond_def utp_pred_laws.le_sup_iff)

lemma seq_refine_pred:
  assumes "(\<lceil>b\<rceil>\<^sub>< \<Rightarrow> \<lceil>s\<rceil>\<^sub>>) \<sqsubseteq> P" and "(\<lceil>s\<rceil>\<^sub>< \<Rightarrow> \<lceil>c\<rceil>\<^sub>>) \<sqsubseteq> Q"
  shows "(\<lceil>b\<rceil>\<^sub>< \<Rightarrow> \<lceil>c\<rceil>\<^sub>>) \<sqsubseteq> (P ;; Q)"
  using assms by pred_auto

lemma seq_refine_unrest:
  assumes "out\<alpha> \<sharp> b" "in\<alpha> \<sharp> c"
  assumes "(b \<Rightarrow> \<lceil>s\<rceil>\<^sub>>) \<sqsubseteq> P" and "(\<lceil>s\<rceil>\<^sub>< \<Rightarrow> c) \<sqsubseteq> Q"
  shows "(b \<Rightarrow> c) \<sqsubseteq> (P ;; Q)"
  using assms by rel_blast

subsection \<open> Preain and Postge Laws \<close>

named_theorems prepost

lemma Pre_conv_Post [prepost]:
  "Pre(P\<^sup>-) = Post(P)"
  by (pred_auto)

lemma Post_conv_Pre [prepost]:
  "Post(P\<^sup>-) = Pre(P)"
  by (pred_auto)

lemma Pre_skip [prepost]:
  "Pre(II) = true"
  by (pred_auto)

lemma Pre_assigns [prepost]:
  "Pre(\<langle>\<sigma>\<rangle>\<^sub>a) = true"
  by (pred_auto)

lemma Pre_miracle [prepost]:
  "Pre(false) = false"
  by (pred_auto)

lemma Pre_assume [prepost]:
  "Pre([b]\<^sup>\<top>) = b"
  by (pred_auto)

lemma Pre_)seq:
  "Pre(P ;; Q) = Pre(P ;; [Pre(Q)]\<^sup>\<top>)"
  by (pred_auto)

lemma Pre_disj [prepost]:
  "Pre(P \<or> Q) = (Pre(P) \<or> Pre(Q))"
  by (pred_auto)

lemma Pre_inf [prepost]:
  "Pre(P \<sqinter> Q) = (Pre(P) \<or> Pre(Q))"
  by (pred_auto)

text \<open> If P uses on the variables in @{term a} and @{term Q} does not refer to the variables of
  @{term "$a\<acute>"} then we can distribute. \<close>

lemma Pre_conj_indep [prepost]: "\<lbrakk> {$a,$a\<acute>} \<natural> P; $a\<acute> \<sharp> Q; vwb_lens a \<rbrakk> \<Longrightarrow> Pre(P \<and> Q) = (Pre(P) \<and> Pre(Q))"
  by (pred_auto, metis lens_override_def lens_override_idem)

lemma assume_Pre [prepost]:
  "[Pre(P)]\<^sup>\<top> ;; P = P"
  by (pred_auto)
*)

end