theory Hood_Melville_Queue
imports
  "HOL-Data_Structures.Queue_Spec"
begin

(* All the possible states a queue can be in *)
datatype 'a status =
  (* front \<ge> rear the queue operates like a normal split queue *)
  Idle
  (* The queue is performing the first step to create the new front *)
  | Rev nat "'a list" "'a list" "'a list" "'a list"
  (* Finishing creating the new front  *)
  | App nat "'a list" "'a list"
  (* The new front is ready *)
  | Done "'a list"

(* A queue with constant time dequeue and enqueue *)
record 'a queue = lenf   :: nat            (* length of the front *)
                  front  :: "'a list"      (* front of the queue *)
                  status :: "'a status"    (* status representing intermediate operations *)
                  rear   :: "'a list"      (* rear of the queue *)
                  lenr   :: nat            (* length of the rear *)

(* exec performs a single step towards creating the new front
   by reversing the rear and appending the front
*)
fun exec :: "'a status \<Rightarrow> 'a status" where
  "exec (Rev ok (x#f) f' (y#r) r') = Rev (ok+1) f  (x#f') r (y#r')"
| "exec (Rev ok []    f' [y]   r') = App ok f' (y#r')"
| "exec (App 0  f'     r')         = Done r' "
| "exec (App ok (x#f') r')         = App (ok-1) f' (x#r')"
| "exec s                          = s"

(* When a deq is performed decreases the number keeping track of
   how many element of the original queue should be used
*)
fun invalidate where
  "invalidate (Rev ok f f' r r') = Rev (ok-1) f f' r r'"
| "invalidate (App 0 f' (x#r'))  = Done r'"
| "invalidate (App ok f' r')     = App (ok-1) f' r'"
| "invalidate s = s"

(* Performs 2 steps and deals with the result *)
fun exec2 :: "'a queue \<Rightarrow> 'a queue" where
"exec2 q =
   (case exec (exec (status q)) of
     Done newf \<Rightarrow> q\<lparr>status := Idle,front := newf\<rparr> |
     newstate  \<Rightarrow> q\<lparr>status := newstate\<rparr>)"

(* Checks if the rear has became greater than the front,
   in which case the rear is cleared and a process to generate
   a new front is started, otherwise the queue functions normally
*)
definition check :: "'a queue \<Rightarrow> 'a queue" where
"check q = (if lenr q \<le> lenf q
            then exec2 q
            else let newstate = Rev 0 (front q) [] (rear q) []
                 in  exec2 (q\<lparr>lenf := lenf q + lenr q, status := newstate, rear := [], lenr := 0\<rparr>))"

(* empty queue *)
definition empty :: "'a queue" where
  "empty = queue.make 0 [] Idle [] 0"

(* Enqueue operation *)
fun enq where
  "enq x q = check (q\<lparr>rear := x#(rear q), lenr := lenr q + 1\<rparr>)"

(* Dequeue opertion *)
fun deq where
  "deq q = check (q\<lparr> lenf  := lenf q - 1
                  , front  := tl (front q)
                  , status := invalidate (status q)\<rparr>)"

(* Computes the "true" front of a queue *)
fun front_list :: "'a queue \<Rightarrow> 'a list" where
  "front_list q = (case status q of
                     Idle   \<Rightarrow> front q
                   | Done f \<Rightarrow> f
                   | Rev ok f f' r r' \<Rightarrow> rev (take ok f') @ f @ rev r @ r'
                   | App ok f' r'     \<Rightarrow> rev (take ok f') @ r')"

(* Rear of the queue in the proper order (oldest element in head) *)
definition rear_list :: "'a queue \<Rightarrow> 'a list" where
  "rear_list = rev o rear"

(* Queue to list projection *)
fun list :: "'a queue \<Rightarrow> 'a list" where
  "list q = front_list q @ rear_list q"

(* Query operation (irrelevant) *)
fun first :: "'a queue \<Rightarrow> 'a" where
 "first q = hd (front q)"

(* How many applications of exec are needed to reach Idle or Done status *)
fun rem_steps :: "'a status \<Rightarrow> nat" where
  "rem_steps (Rev ok f f' r r') = 2*length f + ok + 2"
| "rem_steps (App ok   f'   r') = ok + 1"
| "rem_steps _ = 0"

(* Status invariants *)
fun inv_st :: "'a status \<Rightarrow> bool" where
  "inv_st (Rev ok f f' r r') = (length f + 1 = length r \<and>
                                      length f' = length r'   \<and>
                                      ok \<le> length f')"
| "inv_st (App ok f' r') = (ok \<le> length f' \<and> length f' < length r')"
| "inv_st _ = True"

fun steps :: "nat \<Rightarrow> 'a status \<Rightarrow> 'a status" where
  "steps n st = (exec ^^ n) st"

(* unused *)
lemma rev_steps_app:
  assumes inv: "inv_st (Rev ok f f' r r')"
  shows "steps (length f + 1) (Rev ok f f' r r') = App (length f + ok) (rev f @ f') (rev r @ r')"
proof -
  show ?thesis using inv
  proof (induction f arbitrary: ok f' r r')
    case Nil
    then obtain x where "r = [x]"
      by (metis One_nat_def Suc_length_conv add.right_neutral add_Suc_right length_0_conv inv_st.simps(1))
    then show ?case using Nil by simp
  next
    case (Cons a f)
    then obtain x and xs where "r = x # xs"
      by (metis One_nat_def Suc_length_conv add_Suc_right inv_st.simps(1))
    hence r_x: "r = x # xs" by simp
    then show ?case using Cons Nat.funpow_add by (simp add: Nat.funpow_swap1)
  qed
qed

(* unused *)
lemma inv_st_steps:
  assumes inv      : "inv_st s"
  assumes not_idle : "s \<noteq> Idle"
  shows              "\<exists>x. steps (rem_steps s) s = Done x" (is "?reach_done s")
proof -
  let ?steps = "\<lambda>x. steps (rem_steps x)"
  have app_inv: "inv_st (App ok f r) \<Longrightarrow> ?reach_done (App ok f r)"
    for ok f r
  proof (induct f arbitrary: ok r)
    case (Cons a f') then show ?case
      by (induct ok; simp add: Nat.funpow_swap1)
  qed simp
  show ?thesis
  proof (cases s)
    case (App ok f' r')
    then show ?thesis using inv app_inv unfolding App by simp
  next
    case (Rev ok f f' r r')
    have rep_split: "rem_steps (Rev ok f f' r r') = (length f + ok + 1) + (length f + 1)" by simp
    then have split: "\<And>stp. ?steps (Rev ok f f' r r') stp = (steps (length f + ok + 1)) ((steps (length f + 1)) stp) "
      unfolding rep_split Nat.funpow_add steps.simps by simp
    also have f: "inv_st (App (length f + ok) (rev f @ f') (rev r @ r'))"
      using Rev inv by simp
    thus ?thesis using inv f[THEN app_inv]
      unfolding Rev split inv[simplified Rev,THEN rev_steps_app] by simp
  qed (auto simp add: not_idle)
qed

(* Preservation of the status invariants by exec2 *)
lemma inv_st_exec:
  assumes inv_st: "inv_st s"
  shows "inv_st (exec s)"
proof (cases s)
next
  case (Rev ok f f' r r')
  show ?thesis
  proof (cases f)
    case Nil
    then show ?thesis using inv_st unfolding Rev
      by (simp; cases r;cases ok; cases f'; simp)
  next
    case C_a: (Cons a as)
    then obtain x xs where "r = x # xs" using inv_st unfolding Rev Cons
      by (metis One_nat_def length_Suc_conv list.size(4) inv_st.simps(1))
    hence r_x: "r = x # xs" by simp
    then show ?thesis
    proof (cases as)
      case Nil then show ?thesis using inv_st unfolding Rev C_a Nil r_x by (simp; cases xs; simp)
    next
      case (Cons b bs)
      then show ?thesis using inv_st unfolding Rev C_a r_x by (simp; cases xs; simp)
    qed
  qed
next
  case (App ok f r)
  then show ?thesis
  proof (cases ok)
    case (Suc ok')
    then obtain x xs where "f = x # xs" using inv_st unfolding App Suc
      by (metis Suc_le_D Zero_not_Suc list.exhaust list.size(3) inv_st.simps(2))
    then show ?thesis using inv_st unfolding App Suc
      by (cases ok'; cases xs; simp)
  qed simp
qed simp+

(* Preservation of the status invariants by exec2 *)
lemma inv_st_exec2:
  assumes inv_st: "inv_st s"
  shows "inv_st (exec (exec s))"
proof -
  show ?thesis using inv_st inv_st_exec
  by auto
qed

lemma inv_st_invalidate:
  assumes inv_st: "inv_st s"
  shows "inv_st (invalidate s)"
proof (cases s)
next
  case (Rev ok f f' r r')
  show ?thesis using inv_st unfolding Rev by auto
next
  case (App ok f r)
  then show ?thesis
    using inv_st unfolding App
    by (cases ok; cases r; simp)
qed simp+

(* Queue invariants *)
definition invar where
  "invar q = (lenf q = length (front_list q) \<and>
              lenr q = length (rear_list q)  \<and>
              lenr q \<le> lenf q \<and>
              (case status q of
                 Rev ok f f' r r' \<Rightarrow> 2*lenr q  \<le> length f' \<and> ok \<noteq> 0 \<and> 2*length f + ok + 2 \<le> 2*length (front q)
               | App ok f r       \<Rightarrow> 2*lenr q  \<le> length r \<and> ok + 1  \<le> 2*length (front q)
               | _ \<Rightarrow> True) \<and>
              (\<exists>rest. front_list q = front q @ rest) \<and>
              (\<not>(\<exists>fr. status q = Done fr)) \<and>
              inv_st (status q))"

(* The empty list satisfies the invariant *)
lemma invar_empty: "invar empty"
  by(simp add: invar_def empty_def make_def rear_list_def)

(* List lemmas *)

lemma tl_rev_take: "\<lbrakk>0 < ok; ok \<le> length f\<rbrakk> \<Longrightarrow> rev (take ok (x # f)) = tl (rev (take ok f)) @ [x]"
by(simp add: rev_take Suc_diff_le drop_Suc tl_drop)

lemma tl_rev_take_Suc:
  "n + 1 \<le> length l \<Longrightarrow> rev (take n l) = tl (rev (take (Suc n) l))"
by(simp add: rev_take tl_drop Suc_diff_Suc flip: drop_Suc)

(* Dequeue operations preserve the invariants *)
lemma invar_deq:
  assumes inv: "invar q"
  shows "invar (deq q)"
proof (cases q)
  case (fields lenf front status rear lenr)
  have pre_inv: "\<exists>rest. front @ rest = front_list q" using inv unfolding fields
    by(simp add: invar_def check_def; cases status; auto simp add: invar_def Let_def rear_list_def)
  have tl_app: "status \<noteq> Idle \<Longrightarrow> \<forall>l. tl front @ l = tl (front @ l)" using inv unfolding fields
    by (simp add: invar_def check_def; cases status; cases front;auto simp add: invar_def Let_def rear_list_def)
  then show ?thesis
  proof (cases status rule: exec.cases)
    case st: (1 ok x f f' y r r')
    then show ?thesis
    proof (cases f)
      case Nil
      have pre: "\<exists>rest. front_list (deq q) = tl front @ rest" using inv pre_inv unfolding fields st Nil
        apply (simp add: invar_def check_def; cases r; simp add: invar_def Let_def rear_list_def)
        apply (erule exE)
        apply (rule_tac x=rest in exI)
        apply (simp add: tl_app st tl_rev_take)
        apply (cases f'; auto)
        done
     then show ?thesis using inv unfolding fields st Nil
       by (simp add: invar_def check_def rear_list_def; cases r; auto simp add: min_absorb2 invar_def rear_list_def Let_def)
    next
      case (Cons a list)
      then show ?thesis using pre_inv inv
        unfolding fields st Nil
        apply (simp add: invar_def check_def inv ; cases r; simp add: invar_def inv min_absorb2 rear_list_def)
        apply (erule exE)
        apply (rule conjI, force)
        apply (rule_tac x=rest in exI)
        apply (simp add: tl_app st tl_rev_take)
        apply (cases f'; auto)
        done
    qed
  next
    case st: (2 ok f y r)
    then show ?thesis
    proof(cases ok)
      case ok: 0
      then show ?thesis using inv unfolding fields st
        by (simp add: invar_def check_def rear_list_def)
    next
      case (Suc ok')
      obtain fx fs where "f = fx # fs"
        using inv lessI less_le_trans not_less_zero
        unfolding fields st Suc invar_def
        by (metis list.exhaust list.size(3) select_convs(3) inv_st.simps(1))
      hence f_x: "f = fx # fs" by simp
      obtain rx rs where "r = rx # rs"
        using inv lessI less_le_trans not_less_zero
        unfolding fields st Suc invar_def
        by (metis list.exhaust list.size(3) select_convs(3) inv_st.simps(1))
      hence r_x: "r = rx # rs" by simp
      then show ?thesis using pre_inv inv unfolding fields st Suc invar_def rear_list_def r_x f_x
        apply (simp add: check_def; cases ok'; simp add: check_def min_absorb2)
        apply (erule exE)
        apply (rule conjI, arith)
        apply (rule_tac x=rest in exI)
        apply (simp add: tl_app st tl_rev_take_Suc)
        by (metis Suc_le_length_iff length_take list.sel(3) min_absorb2 n_not_Suc_n rev_is_Nil_conv take_tl tl_Nil tl_append2)
    qed
  next
    case st: (3 f r)
    show ?thesis using inv unfolding fields st
      by(cases r; simp add: invar_def check_def rear_list_def)
  next
    case st: (4 ok x f r)
    then show ?thesis
    proof(cases ok)
      case 0
      then show ?thesis using inv unfolding fields st invar_def rear_list_def
        by (simp add: check_def)
    next
      case (Suc ok')
      then show ?thesis using pre_inv inv unfolding fields st invar_def rear_list_def Suc
        apply (cases f; cases ok'; simp add: invar_def rear_list_def check_def min_absorb2)
        apply (erule exE)
        apply (rule conjI, arith)
        apply (rule_tac x=rest in exI)
        apply (simp add: tl_app st tl_rev_take_Suc)
        by (metis length_take list.size(3) min.absorb2 nat.distinct(1) rev.simps(1) rev_rev_ident tl_append2)
    qed
  next
    case st: "5_1"
    then show ?thesis
    proof (cases "lenr \<le> lenf - 1")
      case True
      then show ?thesis using inv unfolding st fields
        by (simp add: check_def rear_list_def invar_def)
    next
      case overflows: False
      then have f_eq_r: "length front = length rear" using inv unfolding st fields
        by (simp add: le_antisym rear_list_def invar_def)
      then show ?thesis
      proof (cases front)
        case Nil
        show ?thesis using inv overflows unfolding st fields Nil
          by (cases rear; auto simp add: rear_list_def check_def Let_def invar_def)
      next
        case C_a : (Cons a as)
        then obtain x xs where "rear = x # xs"
          using inv overflows unfolding st fields Cons invar_def
          by (metis f_eq_r length_Suc_conv C_a)
        hence rear_x: "rear = x # xs" by simp
        then show ?thesis
        proof (cases as)
          case Nil
          then show ?thesis using inv overflows unfolding st fields Nil rear_x C_a
            by (cases xs; simp add: invar_def check_def Let_def rear_list_def)
        next
          case (Cons b bs)
          then show ?thesis using inv overflows unfolding st fields Cons rear_x C_a invar_def
            by (cases xs; cases bs; simp add: check_def Let_def rear_list_def)
        qed
      qed
    qed
  next
    case st: "5_2" then show ?thesis using inv unfolding fields st
      by (simp add: invar_def inv fields st)
  next
    case st: "5_3" then show ?thesis using inv unfolding fields st
      by (simp add: invar_def)
  next
    case st: "5_4" then show ?thesis using inv unfolding fields st
      by (simp add: invar_def)
  next
    case st: "5_5" then show ?thesis using inv unfolding fields st
      by (simp add: invar_def)
  next
    case st: ("5_6" v) then show ?thesis using inv unfolding fields st
      by (simp add: invar_def)
  qed
qed

(* Enqueue operation preserv the invariants *)
lemma invar_enq:
  assumes inv: "invar q"
  shows "invar (enq x q)"
proof (cases q)
  case (fields lenf front status rear lenr)
  then show ?thesis
  proof(cases status rule: exec.cases)
    case st: (1 ok x f f' y r r')
    then show ?thesis
    proof (cases f)
      case Nil
      then show ?thesis using inv unfolding fields st Nil
        by (simp add: invar_def check_def rear_list_def; cases r; auto simp add: min_absorb2 invar_def rear_list_def Let_def)
    next
      case (Cons a list)
      then show ?thesis using inv check_def rear_list_def
        unfolding fields st Nil invar_def check_def rear_list_def
        by (simp; cases r; auto simp add: min_absorb2 check_def)
    qed
  next
    case st: (2 ok f y r)
    then show ?thesis
    proof(cases ok)
      case ok: 0
      then show ?thesis using inv unfolding fields st
        by (simp add: invar_def check_def rear_list_def)
    next
      case (Suc ok')
      obtain fx fs where "f = fx # fs"
        using inv lessI less_le_trans not_less_zero
        unfolding fields st Suc invar_def
        by (metis list.exhaust list.size(3) select_convs(3) inv_st.simps(1))
      hence f_x: "f = fx # fs" by simp
      obtain rx rs where "r = rx # rs"
        using inv lessI less_le_trans not_less_zero
        unfolding fields st Suc invar_def
        by (metis list.exhaust list.size(3) select_convs(3) inv_st.simps(1))
      hence r_x: "r = rx # rs" by simp
      then show ?thesis using inv unfolding fields st Suc invar_def rear_list_def r_x f_x
        by (simp add: check_def; cases ok'; simp add: check_def min_absorb2)
    qed
  next
    case st: (3 f r)
    then show ?thesis
    proof(cases r)
      case Nil
      then show ?thesis using inv unfolding fields st
        by(simp add:  check_def rear_list_def Let_def invar_def)
    next
      case (Cons a list)
      then show ?thesis using inv unfolding fields st
        by (simp add:  check_def rear_list_def Let_def invar_def)
    qed
  next
    case st: (4 ok x f r)
    then show ?thesis
    proof(cases ok)
      case 0
      then show ?thesis using inv unfolding fields st invar_def rear_list_def
        by (simp add: check_def)
    next
      case (Suc ok')
      then show ?thesis using inv unfolding fields st invar_def rear_list_def Suc
        by (cases f; cases ok'; auto simp add: invar_def rear_list_def check_def min_absorb2)
    qed
  next
    case st: "5_1"
    then show ?thesis
    proof (cases "lenr + 1 \<le> lenf")
      case True
      then show ?thesis using inv unfolding st fields
        by (simp add: check_def rear_list_def invar_def)
    next
      case overflows: False
      then have f_eq_r: "length front = length rear" using inv unfolding st fields
        by (simp add: le_antisym rear_list_def invar_def)
      then show ?thesis
      proof (cases front)
        case Nil
        show ?thesis using inv overflows unfolding st fields Nil
          by (cases rear; auto simp add: rear_list_def check_def Let_def invar_def)
      next
        case C_a : (Cons a as)
        then obtain x xs where "rear = x # xs"
          using inv overflows unfolding st fields Cons invar_def
          by (metis f_eq_r length_Suc_conv C_a)
        hence rear_x: "rear = x # xs" by simp
        then show ?thesis
        proof (cases as)
          case Nil
          then show ?thesis using inv overflows unfolding st fields Nil rear_x C_a
            by (cases xs; simp add: invar_def check_def Let_def rear_list_def)
        next
          case (Cons b bs)
          then show ?thesis using inv overflows unfolding st fields Cons rear_x C_a invar_def
            by (cases xs; cases bs; simp add: check_def Let_def rear_list_def)
        qed
      qed
    qed
  next
    case st: "5_2" then show ?thesis using inv unfolding fields st
      by (simp add: invar_def)
  next
    case st: "5_3" then show ?thesis using inv unfolding fields st
      by (simp add: invar_def)
  next
    case st: "5_4" then show ?thesis using inv unfolding fields st
      by (simp add: invar_def)
  next
    case st: "5_5" then show ?thesis using inv unfolding fields st
      by (simp add: invar_def)
  next
    case st: "5_6" then show ?thesis using inv unfolding fields st
      by (simp add: invar_def)
  qed
qed

(* Correctness proof of the dequeue operation *)
lemma queue_correct_deq :
  assumes inv: "invar q"
  shows "list (deq q) = tl (list q)"
proof (cases q)
  case (fields lenf front status rear lenr)
  have inv_deq: "invar (deq q)" using inv invar_deq by simp
  then show ?thesis
  proof (cases status rule: exec.cases)
    case st: (1 ok x f f' y r r')
    then show ?thesis using inv inv_deq unfolding st fields
      apply (cases f; cases r; simp add: invar_def check_def rear_list_def min_absorb2 tl_rev_take)
      by (metis le_zero_eq length_take list.size(3) min.absorb2 not_le rev_is_Nil_conv tl_append2)+
  next
    case st: (2 ok f y r)
    then show ?thesis
      proof(cases ok)
      case ok: 0
      then show ?thesis using inv unfolding fields st
        by (simp add: invar_def check_def rear_list_def)
    next
      case (Suc ok')
      then show ?thesis using inv inv_deq unfolding fields st Suc invar_def
        apply (cases f; cases r; cases ok'; simp add: check_def min_absorb2 rear_list_def tl_rev_take_Suc)
        by (metis (no_types) length_greater_0_conv less_le_trans old.nat.distinct(2) rev_is_Nil_conv take_eq_Nil tl_append2 zero_less_Suc)
    qed
  next
    case st: (3 f r)
    then show ?thesis using inv inv_deq unfolding st fields
      by (cases f; cases r; simp add: invar_def check_def rear_list_def)
  next
    case st: (4 ok x f r)
    then show ?thesis
    proof(cases ok)
      case 0
      then show ?thesis using inv inv_deq unfolding fields st invar_def rear_list_def
        by (simp add: check_def rear_list_def)
    next
      case (Suc ok')
      then show ?thesis using inv inv_deq unfolding fields st invar_def rear_list_def Suc
        apply (cases f; cases ok'; auto simp add: rear_list_def check_def min_absorb2 tl_rev_take_Suc)
        by (metis Nitpick.size_list_simp(2) length_rev length_take min.absorb2 nat.simps(3) tl_append2)
    qed
  next
    case st: "5_1"
    then show ?thesis
    proof (cases "lenr \<le> lenf - 1")
      case True
      then show ?thesis
        using inv inv_deq Nil_is_rev_conv append_Nil diff_is_0_eq diff_zero length_0_conv
        unfolding st fields
        by (simp add: check_def rear_list_def invar_def; metis  list.sel(2) tl_append2)
    next
      case overflows: False
      then have f_eq_r: "length front = length rear" using inv unfolding st fields
        by (simp add: le_antisym rear_list_def invar_def)
      then show ?thesis
      proof (cases front)
        case Nil
        show ?thesis using inv overflows inv_deq unfolding st fields Nil
          by (cases rear; auto simp add: rear_list_def check_def Let_def invar_def)
      next
        case C_a : (Cons a as)
        then obtain x xs where "rear = x # xs"
          using inv overflows unfolding st fields Cons invar_def
          by (metis f_eq_r length_Suc_conv C_a)
        hence rear_x: "rear = x # xs" by simp
        then show ?thesis
        proof (cases as)
          case Nil
          then show ?thesis using inv overflows unfolding st fields Nil rear_x C_a
            by (cases xs; simp add: invar_def check_def Let_def rear_list_def)
        next
          case (Cons b bs)
          then show ?thesis using inv overflows unfolding st fields Cons rear_x C_a invar_def
            by (cases xs; cases bs; simp add: check_def Let_def rear_list_def)
        qed
      qed
    qed
  next
    case st: "5_2" then show ?thesis using inv inv_deq unfolding st fields
      by (simp add: invar_def check_def rear_list_def)
  next
    case st: "5_3" then show ?thesis using inv inv_deq unfolding st fields
      by (simp add: invar_def check_def rear_list_def)
  next
    case st: "5_4" then show ?thesis using inv inv_deq unfolding st fields
      by (simp add: invar_def check_def rear_list_def)
  next
    case st: "5_5" then show ?thesis using inv inv_deq unfolding st fields
      by (simp add: invar_def check_def rear_list_def)
  next
    case st: "5_6" then show ?thesis using inv inv_deq unfolding st fields
      by (simp add: invar_def check_def rear_list_def)
  qed
qed

(* Correctness proof of the enqueue operation *)
lemma queue_correct_enq :
  assumes inv: "invar q"
  shows "list (enq x q) = (list q) @ [x]"
proof (cases q)
  case (fields lenf front status rear lenr)
  have inv_deq: "invar (enq x q)" using inv invar_enq by simp
  then show ?thesis
  proof (cases status rule: exec.cases)
    case st: (1 ok x f f' y r r')
    then show ?thesis using inv inv_deq unfolding st fields
      by (cases f; cases r; simp add: invar_def check_def rear_list_def min_absorb2 tl_rev_take)
  next
    case st: (2 ok f y r)
    then show ?thesis
      proof(cases ok)
      case ok: 0
      then show ?thesis using inv unfolding fields st
        by (simp add: invar_def check_def rear_list_def)
    next
      case (Suc ok')
      then show ?thesis using inv inv_deq unfolding fields st Suc invar_def
        by (cases f; cases r; cases ok'; simp add: check_def min_absorb2 rear_list_def tl_rev_take_Suc)
    qed
  next
    case st: (3 f r)
    then show ?thesis using inv inv_deq unfolding st fields
      by (cases f; cases r; simp add: invar_def check_def rear_list_def)
  next
    case st: (4 ok x f r)
    then show ?thesis
    proof(cases ok)
      case 0
      then show ?thesis using inv inv_deq unfolding fields st invar_def rear_list_def
        by (simp add: check_def rear_list_def)
    next
      case (Suc ok')
      then show ?thesis using inv inv_deq unfolding fields st invar_def rear_list_def Suc
        by (cases f; cases ok'; auto simp add: rear_list_def check_def min_absorb2 tl_rev_take_Suc)
    qed
  next
    case st: "5_1"
    then show ?thesis
    proof (cases "lenr + 1 \<le> lenf")
      case True
      then show ?thesis
        using inv inv_deq Nil_is_rev_conv append_Nil diff_is_0_eq diff_zero length_0_conv
        unfolding st fields
        by (simp add: check_def rear_list_def invar_def; metis  list.sel(2) tl_append2)
    next
      case overflows: False
      then have f_eq_r: "length front = length rear" using inv unfolding st fields
        by (simp add: le_antisym rear_list_def invar_def)
      then show ?thesis
      proof (cases front)
        case Nil
        show ?thesis using inv overflows inv_deq unfolding st fields Nil
          by (cases rear; auto simp add: rear_list_def check_def Let_def invar_def)
      next
        case C_a : (Cons a as)
        then obtain x xs where "rear = x # xs"
          using inv overflows unfolding st fields Cons invar_def
          by (metis f_eq_r length_Suc_conv C_a)
        hence rear_x: "rear = x # xs" by simp
        then show ?thesis
        proof (cases as)
          case Nil
          then show ?thesis using inv overflows unfolding st fields Nil rear_x C_a
            by (cases xs; simp add: invar_def check_def Let_def rear_list_def)
        next
          case (Cons b bs)
          then show ?thesis using inv overflows unfolding st fields Cons rear_x C_a invar_def
            by (cases xs; cases bs; simp add: check_def Let_def rear_list_def)
        qed
      qed
    qed
  next
    case st: "5_2" then show ?thesis using inv inv_deq unfolding st fields
      by (simp add: invar_def check_def rear_list_def)
  next
    case st: "5_3" then show ?thesis using inv inv_deq unfolding st fields
      by (simp add: invar_def check_def rear_list_def)
  next
    case st: "5_4" then show ?thesis using inv inv_deq unfolding st fields
      by (simp add: invar_def check_def rear_list_def)
  next
    case st: "5_5" then show ?thesis using inv inv_deq unfolding st fields
      by (simp add: invar_def check_def rear_list_def)
  next
    case st: "5_6" then show ?thesis using inv inv_deq unfolding st fields
      by (simp add: invar_def check_def rear_list_def)
  qed
qed

(* Constructive approach *)
datatype 'a action = Deq | Enq 'a

type_synonym 'a actions = "'a action list"

(* Perform a given action on the queue *)
fun do_act :: "'a action \<Rightarrow> 'a queue \<Rightarrow> 'a queue" where
  "do_act Deq q     = deq q"
| "do_act (Enq x) q = enq x q"

(* Create a queue from a list of actions *)
definition qfa :: "'a actions \<Rightarrow> 'a queue" where
  "qfa = (\<lambda>acts. foldr do_act acts empty)"

(* Any queue created from list of actions satisfies the invariants *)
lemma invar_qfa : "invar (qfa l)"
proof(induction l)
  case Nil
  then show ?case by (simp add: qfa_def invar_empty)
next
  case (Cons x xs)
  have qfa_cons: "qfa (x#xs) = do_act x (qfa xs)" by (simp add: qfa_def)
  then show ?case
  proof(cases x)
    case Deq
    then show ?thesis using invar_deq[of "qfa xs"] unfolding qfa_cons
      by (simp add: Cons)
  next
    case (Enq a)
    then show ?thesis using invar_enq[of "qfa xs"] unfolding qfa_cons
      by (simp add: Cons)
  qed
qed

(* Correctness proof *)
lemma qfa_deq_correct: "list (deq (qfa l)) = tl (list (qfa l))"
  using invar_qfa queue_correct_deq by blast

lemma qfa_enq_correct: "list (enq x (qfa l)) = (list (qfa l)) @ [x]"
  by (meson invar_qfa queue_correct_enq)

lemma first_correct :
  assumes inv:      "invar q"
  assumes not_nil : "list q \<noteq> []"
  shows             "first q = hd (list q)"
proof (cases "front q")
  obtain rest where front_l: "front_list q = front q @ rest"
    using inv
    by (auto simp add: invar_def simp del: front_list.simps)
  case front_nil: Nil
  have rear_nil: "rear_list q = []" using inv unfolding invar_def rear_list_def front_nil
    by (simp; cases "status q"; simp add: front_nil)
  have front_nil: "front_list q = []" using inv unfolding invar_def rear_list_def front_nil
    by (simp; cases "status q"; simp add: front_nil)
  show ?thesis using not_nil unfolding  list.simps rear_nil front_nil
    by simp
next
  case front_cons: (Cons x xs)
  show ?thesis using inv unfolding list.simps first.simps front_cons front_list.simps
    apply (simp add: invar_def rear_list_def)
    by (metis append_Cons front_cons list.sel(1))
qed

fun is_empty :: "'a queue \<Rightarrow> bool" where
  "is_empty q = (list q = [])"

interpretation HMQ: Queue where
  empty    = empty    and
  enq      = enq      and
  first    = first    and
  deq      = deq      and
  is_empty = is_empty and
  list     = list  and
  invar    = invar
proof (standard, goal_cases)
  case 1 thus ?case
    by (simp add: empty_def make_def rear_list_def)
next
  case 2 thus ?case using queue_correct_enq by simp
next
  case 3 thus ?case using queue_correct_deq by simp
next
  case 4 thus ?case using first_correct by simp
next
  case 5 thus ?case by simp
next
  case 6 thus ?case
    by (simp add: empty_def invar_def make_def rear_list_def)
next
  case 7 thus ?case using invar_enq by simp
next
  case 8 thus ?case using invar_deq by simp
qed

end


theory AbstractClassType
  imports
    Main
    "Ecore-GROOVE-Mapping.Type_Model_Graph_Mapping"
    "Ecore-GROOVE-Mapping.Identifier_List"
begin

section "Definition of a type model which introduces an abstract class"

definition tmod_abstract_class :: "'t Id \<Rightarrow> 't type_model" where
  "tmod_abstract_class name = \<lparr>
    Class = {name},
    Enum = {},
    UserDataType = {},
    Field = {},
    FieldSig = (\<lambda>x. undefined),
    EnumValue = {},
    Inh = {},
    Prop = {abstract name},
    Constant = {},
    ConstType = (\<lambda>x. undefined)
  \<rparr>"

lemma tmod_abstract_class_correct: "type_model (tmod_abstract_class name)"
proof (intro type_model.intro)
  fix p
  assume "p \<in> Prop (tmod_abstract_class name)"
  then have p_def: "p = abstract name"
    unfolding tmod_abstract_class_def
    by simp
  have "abstract name \<in> Property (tmod_abstract_class name)"
  proof (intro Property.abstract_property)
    show "name \<in> Class (tmod_abstract_class name)"
      unfolding tmod_abstract_class_def
      by simp
  qed
  then show "p \<in> Property (tmod_abstract_class name)"
    by (simp add: p_def)
next
  have "asym {} \<and> irrefl {}"
    by (simp add: asym.intros irrefl_def)
  then show "asym (Inh (tmod_abstract_class name)) \<and> irrefl ((Inh (tmod_abstract_class name))\<^sup>+)"
    unfolding tmod_abstract_class_def
    by simp
qed (simp_all add: tmod_abstract_class_def)

lemma tmod_abstract_class_combine_correct:
  assumes "type_model Tmod"
  assumes new_class: "name \<notin> Class Tmod \<union> Enum Tmod \<union> UserDataType Tmod"
  assumes "\<And>x. x \<in> Class Tmod \<union> Enum Tmod \<union> UserDataType Tmod \<Longrightarrow> \<not>id_in_ns name (Identifier x) \<and> \<not>id_in_ns x (Identifier name)"
  shows "type_model (tmod_combine Tmod (tmod_abstract_class name))"
proof (intro tmod_combine_full_distinct_correct)
  show "type_model (tmod_abstract_class name)"
    by (fact tmod_abstract_class_correct)
next
  show "(Class Tmod \<union> Enum Tmod \<union> UserDataType Tmod) \<inter> (Class (tmod_abstract_class name) \<union> Enum (tmod_abstract_class name) \<union> UserDataType (tmod_abstract_class name)) = {}"
    unfolding tmod_abstract_class_def
    using new_class
    by simp
qed (simp_all add: assms tmod_abstract_class_def)

section "Encoding of a Class as Node Type in GROOVE"

definition tg_abstract_class_as_node_type :: "'t Id \<Rightarrow> ('t list) type_graph" where
  "tg_abstract_class_as_node_type name = \<lparr>
    NT = {type (id_to_list name)},
    ET = {},
    inh = {(type (id_to_list name), type (id_to_list name))},
    abs = {type (id_to_list name)},
    mult = (\<lambda>x. undefined),
    contains = {}
  \<rparr>"

lemma tg_abstract_class_as_node_type_correct: "type_graph (tg_abstract_class_as_node_type name)"
proof (intro type_graph.intro)
  fix n
  assume "n \<in> NT (tg_abstract_class_as_node_type name)"
  then have "n = type (id_to_list name)"
    unfolding tg_abstract_class_as_node_type_def
    by simp
  then have "n \<in> Lab\<^sub>t"
    by (simp add: Lab\<^sub>t.rule_type_labels)
  then show "n \<in> Lab\<^sub>t \<union> Lab\<^sub>p"
    by blast
next
  show "Partial_order (inh (tg_abstract_class_as_node_type name))"
    unfolding tg_abstract_class_as_node_type_def partial_order_on_def preorder_on_def
    by simp
qed (simp_all add: tg_abstract_class_as_node_type_def)

lemma tg_abstract_class_as_node_type_combine_correct:
  assumes "type_graph TG"
  assumes new_node_type: "type (id_to_list name) \<notin> NT TG"
  shows "type_graph (tg_combine TG (tg_abstract_class_as_node_type name))"
proof (intro tg_combine_distinct_correct)
  show "type_graph (tg_abstract_class_as_node_type name)"
    by (fact tg_abstract_class_as_node_type_correct)
qed (simp_all add: tg_abstract_class_as_node_type_def assms)

subsection "Transformation functions"

definition tmod_abstract_class_to_tg_abstract_class_as_node_type :: "'t type_model \<Rightarrow> ('t list) type_graph" where
  "tmod_abstract_class_to_tg_abstract_class_as_node_type Tmod = \<lparr>
    NT = type ` id_to_list ` Class Tmod,
    ET = {},
    inh = type ` id_to_list ` Class Tmod \<times> type ` id_to_list ` Class Tmod,
    abs = type ` id_to_list ` Class Tmod,
    mult = (\<lambda>x. undefined),
    contains = {}
  \<rparr>"

lemma tmod_abstract_class_to_tg_abstract_class_as_node_type_proj:
  shows "tmod_abstract_class_to_tg_abstract_class_as_node_type (tmod_abstract_class name) = tg_abstract_class_as_node_type name"
  unfolding tmod_abstract_class_to_tg_abstract_class_as_node_type_def tmod_abstract_class_def tg_abstract_class_as_node_type_def
  by simp

lemma tmod_abstract_class_to_tg_abstract_class_as_node_type_func:
  shows "tg_combine_mapping_function (tmod_abstract_class_to_tg_abstract_class_as_node_type) (tmod_abstract_class name) (tg_abstract_class_as_node_type name)"
  by (intro tg_combine_mapping_function.intro)
    (simp_all add: tmod_abstract_class_to_tg_abstract_class_as_node_type_def tmod_abstract_class_def tg_abstract_class_as_node_type_def tmod_combine_def)

definition tg_abstract_class_as_node_type_to_tmod_abstract_class :: "('t list) type_graph \<Rightarrow> 't type_model" where
  "tg_abstract_class_as_node_type_to_tmod_abstract_class TG = \<lparr>
    Class = list_to_id ` unlabel ` NT TG,
    Enum = {},
    UserDataType = {},
    Field = {},
    FieldSig = (\<lambda>x. undefined),
    EnumValue = {},
    Inh = {},
    Prop = abstract ` list_to_id ` unlabel ` NT TG,
    Constant = {},
    ConstType = (\<lambda>x. undefined)
  \<rparr>"

lemma tg_abstract_class_as_node_type_to_tmod_abstract_class_proj:
  shows "tg_abstract_class_as_node_type_to_tmod_abstract_class (tg_abstract_class_as_node_type name) = tmod_abstract_class name"
  unfolding tg_abstract_class_as_node_type_to_tmod_abstract_class_def tmod_abstract_class_def tg_abstract_class_as_node_type_def
  by (simp add: id_to_list_inverse)

lemma tg_abstract_class_as_node_type_to_tmod_abstract_class_func:
  shows "tmod_combine_mapping_function (tg_abstract_class_as_node_type_to_tmod_abstract_class) (tg_abstract_class_as_node_type name) (tmod_abstract_class name)"
  by (intro tmod_combine_mapping_function.intro)
    (simp_all add: tg_abstract_class_as_node_type_to_tmod_abstract_class_def tmod_abstract_class_def tg_abstract_class_as_node_type_def tg_combine_def id_to_list_inverse)

end


(*
 * Copyright (C) 2014 NICTA
 * All rights reserved.
 *)

(* Author: David Cock - David.Cock@nicta.com.au *)

header {* Miscellaneous Mathematics *}

theory Misc imports Real Multivariate_Analysis begin

text_raw {* \label{s:misc} *}

lemma setsum_UNIV:
  fixes S::"'a::finite set"
  assumes complete: "\<And>x. x\<notin>S \<Longrightarrow> f x = 0"
  shows "setsum f S = setsum f UNIV"
proof -
  from complete have "setsum f S = setsum f (UNIV - S) + setsum f S" by(simp)
  also have "... = setsum f UNIV"
    by(auto intro: setsum.subset_diff[symmetric])
  finally show ?thesis .
qed

lemma cInf_mono:
  fixes A::"'a::conditionally_complete_lattice set"
  assumes lower: "\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. a \<le> b"
      and bounded: "\<And>a. a \<in> A \<Longrightarrow> c \<le> a"
      and ne: "B \<noteq> {}"
  shows "Inf A \<le> Inf B"
proof(rule cInf_greatest[OF ne])
  fix b assume bin: "b \<in> B"
  with lower obtain a where ain: "a \<in> A" and le: "a \<le> b" by(auto)
  from ain bounded have "Inf A \<le> a" by(intro cInf_lower bdd_belowI, auto)
  also note le
  finally show "Inf A \<le> b" .
qed

lemma max_distrib:
  fixes c::real
  assumes nn: "0 \<le> c"
  shows "c * max a b = max (c * a) (c * b)"
proof(cases "a \<le> b")
  case True
  moreover with nn have "c * a \<le> c * b" by(auto intro:mult_left_mono)
  ultimately show ?thesis by(simp add:max.absorb2)
next
  case False then have "b \<le> a" by(auto)
  moreover with nn have "c * b \<le> c * a" by(auto intro:mult_left_mono)
  ultimately show ?thesis by(simp add:max.absorb1)
qed

lemma mult_div_mono_left:
  fixes c::real
  assumes nnc: "0 \<le> c" and nzc: "c \<noteq> 0"
      and inv: "a \<le> inverse c * b"
  shows "c * a \<le> b"
proof -
  from nnc inv have "c * a \<le> (c * inverse c) * b"
    by(auto simp:mult.assoc intro:mult_left_mono)
  also from nzc have "... = b" by(simp)
  finally show "c * a \<le> b" .
qed

lemma mult_div_mono_right:
  fixes c::real
  assumes nnc: "0 \<le> c" and nzc: "c \<noteq> 0"
      and inv: "inverse c * a \<le> b"
  shows "a \<le> c * b"
proof -
  from nzc have "a = (c * inverse c) * a " by(simp)
  also from nnc inv have "(c * inverse c) * a \<le> c * b"
    by(auto simp:mult.assoc intro:mult_left_mono)
  finally show "a \<le> c * b" .
qed

lemma min_distrib:
  fixes c::real
  assumes nnc: "0 \<le> c"
  shows "c * min a b = min (c * a) (c * b)"
proof(cases "a \<le> b")
  case True moreover with nnc have "c * a \<le> c * b"
    by(blast intro:mult_left_mono)
  ultimately show ?thesis by(auto)
next
  case False hence "b \<le> a" by(auto)
  moreover with nnc have "c * b \<le> c * a"
    by(blast intro:mult_left_mono)
  ultimately show ?thesis by(simp add:min.absorb2)
qed

lemma nonempty_witness:
  "S \<noteq> {} \<Longrightarrow> \<exists>x. x \<in> S"
  by(blast)

lemma finite_set_least:
  fixes S::"'a::linorder set"
  assumes finite: "finite S"
      and ne: "S \<noteq> {}"
  shows "\<exists>x\<in>S. \<forall>y\<in>S. x \<le> y"
proof -
  have "S = {} \<or> (\<exists>x\<in>S. \<forall>y\<in>S. x \<le> y)"
  proof(rule finite_induct, simp_all add:assms)
    fix x::'a and S::"'a set"
    assume IH: "S = {} \<or> (\<exists>x\<in>S. \<forall>y\<in>S. x \<le> y)"
    show "(\<forall>y\<in>S. x \<le> y) \<or> (\<exists>x'\<in>S. x' \<le> x \<and> (\<forall>y\<in>S. x' \<le> y))"
    proof(cases "S={}")
      case True then show ?thesis by(auto)
    next
      case False with IH have "\<exists>x\<in>S. \<forall>y\<in>S. x \<le> y" by(auto)
      then obtain z where zin: "z \<in> S" and zmin: "\<forall>y\<in>S. z \<le> y" by(auto)
      thus ?thesis by(cases "z \<le> x", auto)
    qed
  qed
  with ne show ?thesis by(auto)
qed

lemma cSup_add:
  fixes c::real
  assumes ne: "S \<noteq> {}"
      and bS: "\<And>x. x\<in>S \<Longrightarrow> x \<le> b"
  shows "Sup S + c = Sup {x + c |x. x \<in> S}"
proof(rule antisym)
  from ne bS show "Sup {x + c |x. x \<in> S} \<le> Sup S + c"
    by(auto intro!:cSup_least add_right_mono cSup_upper bdd_aboveI)

  have "Sup S \<le> Sup {x + c |x. x \<in> S} - c"
  proof(intro cSup_least ne)
    fix x assume xin: "x \<in> S"
    from bS have "\<And>x. x\<in>S \<Longrightarrow> x + c \<le> b + c" by(auto intro:add_right_mono)
    hence "bdd_above {x + c |x. x \<in> S}" by(intro bdd_aboveI, blast)
    with xin have "x + c \<le> Sup {x + c |x. x \<in> S}" by(auto intro:cSup_upper)
    thus "x \<le> Sup {x + c |x. x \<in> S} - c" by(auto)
  qed
  thus "Sup S + c \<le> Sup {x + c |x. x \<in> S}" by(auto)
qed

lemma cSup_mult:
  fixes c::real
  assumes ne: "S \<noteq> {}"
      and bS: "\<And>x. x\<in>S \<Longrightarrow> x \<le> b"
      and nnc: "0 \<le> c"
  shows "c * Sup S = Sup {c * x |x. x \<in> S}"
proof(cases)
  assume "c = 0"
  moreover from ne have "\<exists>x. x \<in> S" by(auto)
  ultimately show ?thesis by(simp)
next
  assume cnz: "c \<noteq> 0"
  show ?thesis
  proof(rule antisym)
    from bS have baS: "bdd_above S" by(intro bdd_aboveI, auto)
    with ne nnc show "Sup {c * x |x. x \<in> S} \<le> c * Sup S"
      by(blast intro!:cSup_least mult_left_mono[OF cSup_upper])
    have "Sup S \<le> inverse c * Sup {c * x |x. x \<in> S}"
    proof(intro cSup_least ne)
      fix x assume xin: "x\<in>S"
      moreover from bS nnc have "\<And>x. x\<in>S \<Longrightarrow> c * x \<le> c * b" by(auto intro:mult_left_mono)
      ultimately have "c * x \<le> Sup {c * x |x. x \<in> S}"
        by(auto intro!:cSup_upper bdd_aboveI)
      moreover from nnc have "0 \<le> inverse c" by(auto)
      ultimately have "inverse c * (c * x) \<le> inverse c * Sup {c * x |x. x \<in> S}"
        by(auto intro:mult_left_mono)
      with cnz show "x \<le> inverse c * Sup {c * x |x. x \<in> S}"
        by(simp add:mult.assoc[symmetric])
    qed
    with nnc have "c * Sup S \<le> c * (inverse c * Sup {c * x |x. x \<in> S})"
      by(auto intro:mult_left_mono)
    with cnz show "c * Sup S \<le> Sup {c * x |x. x \<in> S}"
      by(simp add:mult.assoc[symmetric])
  qed
qed

lemma closure_contains_Sup:
  fixes S :: "real set"
  assumes neS: "S \<noteq> {}" and bS: "\<forall>x\<in>S. x \<le> B"
  shows "Sup S \<in> closure S"
proof -
  let ?T = "uminus ` S"
  from neS have neT: "?T \<noteq> {}" by(auto)
  from bS have bT: "\<forall>x\<in>?T. -B \<le> x" by(auto)
  hence bbT: "bdd_below ?T" by(intro bdd_belowI, blast)

  have "Sup S = - Inf ?T"
  proof(rule antisym)
    from neT bbT
    have "\<And>x. x\<in>S \<Longrightarrow> Inf (uminus ` S) \<le> -x"
      by(blast intro:cInf_lower)
    hence "\<And>x. x\<in>S \<Longrightarrow> -1 * -x \<le> -1 * Inf (uminus ` S)"
      by(rule mult_left_mono_neg, auto)
    hence lenInf: "\<And>x. x\<in>S \<Longrightarrow> x \<le> - Inf (uminus ` S)"
      by(simp)
    with neS bS show "Sup S \<le> - Inf ?T"
      by(blast intro:cSup_least)

    have "- Sup S \<le> Inf ?T"
    proof(rule cInf_greatest[OF neT])
      fix x assume "x \<in> uminus ` S"
      then obtain y where yin: "y \<in> S" and rwx: "x = -y" by(auto)
      from yin bS have "y \<le> Sup S"
        by(intro cSup_upper bdd_belowI, auto)
      hence "-1 * Sup S \<le> -1 * y"
        by(simp add:mult_left_mono_neg)
      with rwx show "- Sup S \<le> x" by(simp)
    qed
    hence "-1 * Inf ?T \<le> -1 * (- Sup S)"
      by(simp add:mult_left_mono_neg)
    thus "- Inf ?T \<le> Sup S" by(simp)
  qed
  also {
    thm bT
    from neT bbT have "Inf ?T \<in> closure ?T" by(rule closure_contains_Inf)
    hence "- Inf ?T \<in> uminus ` closure ?T" by(auto)
  }
  also {
    have "linear uminus" by(auto intro:linearI)
    hence "uminus ` closure ?T \<subseteq> closure (uminus ` ?T)"
      by(rule closure_linear_image)
  }
  also {
    have "uminus ` ?T \<subseteq> S" by(auto)
    hence "closure (uminus ` ?T) \<subseteq> closure S" by(rule closure_mono)
  }
  finally show "Sup S \<in> closure S" .
qed

lemma tendsto_min:
  fixes x y::real
  assumes ta: "a ----> x"
      and tb: "b ----> y"
  shows "(\<lambda>i. min (a i) (b i)) ----> min x y"
proof(rule LIMSEQ_I, simp)
  fix e::real assume pe: "0 < e"

  from ta pe obtain noa where balla: "\<forall>n\<ge>noa. abs (a n - x) < e"
    by(auto dest:LIMSEQ_D)
  from tb pe obtain nob where ballb: "\<forall>n\<ge>nob. abs (b n - y) < e"
    by(auto dest:LIMSEQ_D)

  {
    fix n
    assume ge: "max noa nob \<le> n"
    hence gea: "noa \<le> n" and geb: "nob \<le> n" by(auto)
    have "abs (min (a n) (b n) - min x y) < e"
    proof cases
      assume le: "min (a n) (b n) \<le> min x y"
      show ?thesis
      proof cases
        assume "a n \<le> b n"
        hence rwmin: "min (a n) (b n) = a n" by(auto)
        with le have "a n \<le> min x y" by(simp)
        moreover from gea balla have "abs (a n - x) < e" by(simp)
        moreover have "min x y \<le> x" by(auto)
        ultimately have "abs (a n - min x y) < e" by(auto)
        with rwmin show "abs (min (a n) (b n) - min x y) < e" by(simp)
      next
        assume "\<not> a n \<le> b n"
        hence "b n \<le> a n" by(auto)
        hence rwmin: "min (a n) (b n) = b n" by(auto)
        with le have "b n \<le> min x y" by(simp)
        moreover from geb ballb have "abs (b n - y) < e" by(simp)
        moreover have "min x y \<le> y" by(auto)
        ultimately have "abs (b n - min x y) < e" by(auto)
        with rwmin show "abs (min (a n) (b n) - min x y) < e" by(simp)
      qed
    next
      assume "\<not> min (a n) (b n) \<le> min x y"
      hence le: "min x y \<le> min (a n) (b n)" by(auto)
      show ?thesis
      proof cases
        assume "x \<le> y"
        hence rwmin: "min x y = x" by(auto)
        with le have "x \<le> min (a n) (b n)" by(simp)
        moreover from gea balla have "abs (a n - x) < e" by(simp)
        moreover have "min (a n) (b n) \<le> a n" by(auto)
        ultimately have "abs (min (a n) (b n) - x) < e" by(auto)
        with rwmin show "abs (min (a n) (b n) - min x y) < e" by(simp)
      next
        assume "\<not> x \<le> y"
        hence "y \<le> x" by(auto)
        hence rwmin: "min x y = y" by(auto)
        with le have "y \<le> min (a n) (b n)" by(simp)
        moreover from geb ballb have "abs (b n - y) < e" by(simp)
        moreover have "min (a n) (b n) \<le> b n" by(auto)
        ultimately have "abs (min (a n) (b n) - y) < e" by(auto)
        with rwmin show "abs (min (a n) (b n) - min x y) < e" by(simp)
      qed
    qed
  }
  thus "\<exists>no. \<forall>n\<ge>no. \<bar>min (a n) (b n) - min x y\<bar> < e" by(blast)
qed

definition supp :: "('s \<Rightarrow> real) \<Rightarrow> 's set"
where "supp f = {x. f x \<noteq> 0}"

definition dist_remove :: "('s \<Rightarrow> real) \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow> real"
where "dist_remove p x = (\<lambda>y. if y=x then 0 else p y / (1 - p x))"

lemma supp_dist_remove:
  "p x \<noteq> 0 \<Longrightarrow> p x \<noteq> 1 \<Longrightarrow> supp (dist_remove p x) = supp p - {x}"
  by(auto simp:dist_remove_def supp_def)

lemma supp_empty:
  "supp f = {} \<Longrightarrow> f x = 0"
  by(simp add:supp_def)

lemma nsupp_zero:
  "x \<notin> supp f \<Longrightarrow> f x = 0"
  by(simp add:supp_def)

lemma setsum_supp:
  fixes f::"'a::finite \<Rightarrow> real"
  shows "setsum f (supp f) = setsum f UNIV"
proof -
  have "setsum f (UNIV - supp f) = 0"
    by(simp add:supp_def)
  hence "setsum f (supp f) = setsum f (UNIV - supp f) + setsum f (supp f)"
    by(simp)
  also have "... = setsum f UNIV"
    by(simp add:setsum.subset_diff[symmetric])
  finally show ?thesis .
qed

subsection {* Truncated Subtraction *}
text_raw {* \label{s:trunc_sub} *}

definition
  tminus :: "real \<Rightarrow> real \<Rightarrow> real" (infixl "\<ominus>" 60)
where
  "x \<ominus> y = max (x - y) 0"

lemma minus_le_tminus[intro!,simp]:
  "a - b \<le> a \<ominus> b"
  unfolding tminus_def by(auto)

lemma tminus_cancel_1:
  "0 \<le> a \<Longrightarrow> a + 1 \<ominus> 1 = a"
  unfolding tminus_def by(simp)

lemma tminus_zero_imp_le:
  "x \<ominus> y \<le> 0 \<Longrightarrow> x \<le> y"
  by(simp add:tminus_def)

lemma tminus_zero[simp]:
  "0 \<le> x \<Longrightarrow> x \<ominus> 0 = x"
  by(simp add:tminus_def)

lemma tminus_left_mono:
  "a \<le> b \<Longrightarrow> a \<ominus> c \<le> b \<ominus> c"
  unfolding tminus_def
  by(case_tac "a \<le> c", simp_all)

lemma tminus_less:
  "\<lbrakk> 0 \<le> a; 0 \<le> b \<rbrakk> \<Longrightarrow> a \<ominus> b \<le> a"
  unfolding tminus_def by(force)

lemma tminus_left_distrib:
  assumes nna: "0 \<le> a"
  shows "a * (b \<ominus> c) = a * b \<ominus> a * c"
proof(cases "b \<le> c")
  case True note le = this
  hence "a * max (b - c) 0 = 0" by(simp add:max.absorb2)
  also {
    from nna le have "a * b \<le> a * c" by(blast intro:mult_left_mono)
    hence "0 = max (a * b - a * c) 0" by(simp add:max.absorb1)
  }
  finally show ?thesis by(simp add:tminus_def)
next
  case False hence le: "c \<le> b" by(auto)
  hence "a * max (b - c) 0 = a * (b - c)" by(simp only:max.absorb1)
  also {
    from nna le have "a * c \<le> a * b" by(blast intro:mult_left_mono)
    hence "a * (b - c) = max (a * b - a * c) 0" by(simp add:max.absorb1 field_simps)
  }
  finally show ?thesis by(simp add:tminus_def)
qed

lemma tminus_le[simp]:
  "b \<le> a \<Longrightarrow> a \<ominus> b = a - b"
  unfolding tminus_def by(simp)

lemma tminus_le_alt[simp]:
  "a \<le> b \<Longrightarrow> a \<ominus> b = 0"
  by(simp add:tminus_def)

lemma tminus_add_mono:
  "(a+b) \<ominus> (c+d) \<le> (a\<ominus>c) + (b\<ominus>d)"
proof(cases "0 \<le> a - c")
  case True note pac = this
  show ?thesis
  proof(cases "0 \<le> b - d")
    case True note pbd = this
    from pac and pbd have "(c + d) \<le> (a + b)" by(simp)
    with pac and pbd show ?thesis by(simp)
  next
    case False with pac show ?thesis
      by(cases "c + d \<le> a + b", auto)
  qed
next
  case False note nac = this
  show ?thesis
  proof(cases "0 \<le> b - d")
    case True with nac show ?thesis
      by(cases "c + d \<le> a + b", auto)
  next
    case False note nbd = this
    with nac have "\<not>(c + d) \<le> (a + b)" by(simp)
    with nac and nbd show ?thesis by(simp)
  qed
qed

lemma tminus_setsum_mono:
  assumes fS: "finite S"
  shows "setsum f S \<ominus> setsum g S \<le> setsum (\<lambda>x. f x \<ominus> g x) S"
        (is "?X S")
proof(rule finite_induct)
  from fS show "finite S" .

  show "?X {}" by(simp)

  fix x and F
  assume fF: "finite F" and xniF: "x \<notin> F"
     and IH: "?X F"
  have "f x + setsum f F \<ominus> g x + setsum g F \<le>
        (f x \<ominus> g x) + (setsum f F \<ominus> setsum g F)"
    by(rule tminus_add_mono)
  also from IH have "... \<le> (f x \<ominus> g x) + (\<Sum>x\<in>F. f x \<ominus> g x)"
    by(rule add_left_mono)
  finally show "?X (insert x F)"
    by(simp add:setsum.insert[OF fF xniF])
qed

lemma tminus_nneg[simp,intro]:
  "0 \<le> a \<ominus> b"
  by(cases "b \<le> a", auto)

lemma tminus_right_antimono:
  assumes clb: "c \<le> b"
  shows "a \<ominus> b \<le> a \<ominus> c"
proof(cases "b \<le> a")
  case True
  moreover with clb have "c \<le> a" by(auto)
  moreover note clb
  ultimately show ?thesis by(simp)
next
  case False then show ?thesis by(simp)
qed

lemma min_tminus_distrib:
  "min a b \<ominus> c = min (a \<ominus> c) (b \<ominus> c)"
  unfolding tminus_def by(auto)

end


(*by Ammer*)
theory Simple_TBOUND_Cond
imports Time_Reasoning
begin

text \<open>This entry stops at showing the correctness and complexity of the operations,
  but does not provide a complete or universally usable methods to reason about
  programs using these operations.

  In this theory, we provide an ad-hoc method, which is showcased
  with a simple example later on.
\<close>

text \<open>definition of conditional TBOUND relation  and setup\<close>

definition cond_TBOUND::"assn \<Rightarrow> 'a Heap  \<Rightarrow> nat\<Rightarrow> bool"("\
 _ \
/ TBOUND/ _ _") where
  "cond_TBOUND P c t \<equiv> (\<forall>h as. (h,as) \<Turnstile> P \<longrightarrow> time c h \<le> t)"

named_theorems cond_TBOUND

lemma htt_elim:
  assumes "
 c <Q>T[b]"
  shows "\
P\
 TBOUND c b"
  using assms
  unfolding htt_def cond_TBOUND_def by simp

lemma htt_intro:
  assumes "
 c <Q>"
    and   "\
P\
 TBOUND c b"
  shows "
 c <Q> T[b]"
  using assms unfolding htt_def cond_TBOUND_def by simp

lemma cond_TBOUND_mono: "\
P\
 TBOUND c b \<Longrightarrow> b \<le> b' \<Longrightarrow> \
P\
 TBOUND c b'"
  unfolding cond_TBOUND_def by auto

lemma time_leq_bindy: "time c h \<le> t1 \<Longrightarrow> time (d (the_res c h)) (the_heap c h) \<le> t2 \<Longrightarrow>
              time (c \<bind> d) h \<le> t1+t2"
 by (simp add: time_bind)

lemma cond_TBOUND_bind[cond_TBOUND]:
  assumes "\
P\
 TBOUND c t1"
  and "
 c <Q>"
  and "(\<And> x h. x = the_res c h \<Longrightarrow> \
Q x\
 TBOUND (d x) t2)"
shows  "\
P\
 TBOUND (c \<bind> d) (t1+t2)"
  unfolding cond_TBOUND_def hoare_triple_def
  apply auto
  subgoal for h as
    apply(cases "fails (d (the_res c h)) (the_heap c h)")
   apply (simp add: time_bind)
    apply(rule time_leq_bindy)
    subgoal
    using assms  unfolding cond_TBOUND_def hoare_triple_def
    apply auto
    done
  using assms(3)[of "(the_res c h)" h]
  unfolding cond_TBOUND_def
  using assms(2)
  unfolding hoare_triple_def Let_def the_res_def the_heap_def
  apply(auto split: option.split)
   apply force+
  done
  done

lemma cond_TBOUND_return[cond_TBOUND]: "\
 P \
 TBOUND (return x) 1"
  by (simp add: cond_TBOUND_def time_return)

lemma cond_TBOUND_cons:
  assumes "P \<Longrightarrow>\<^sub>A Q"
      and "\
 Q \
 TBOUND c b"
    shows "\
 P \
 TBOUND c b"
  using assms
  unfolding cond_TBOUND_def
  apply sep_auto
  by (meson entailsD)

method cond_TBOUND= (rule cond_TBOUND_mono, rule cond_TBOUND)

end


theory UnifyExpr
  imports "../Utils" "../Variable"
begin

datatype uexpr =
  Var var
  | Ctor string "uexpr list"

fun vars :: "uexpr \<Rightarrow> var set"
and varss :: "uexpr list \<Rightarrow> var set" where
  "vars (Var x) = {x}"
| "vars (Ctor k es) = varss es"
| "varss [] = {}"
| "varss (e # es) = vars e \<union> varss es"

primrec ctor_count :: "uexpr \<Rightarrow> nat" where
  "ctor_count (Var x) = 0"
| "ctor_count (Ctor k es) = Suc (sum_list (map ctor_count es))"

fun list_vars :: "(uexpr \<times> uexpr) list \<Rightarrow> var set" where
  "list_vars [] = {}"
| "list_vars ((e\<^sub>1, e\<^sub>2) # ess) = vars e\<^sub>1 \<union> vars e\<^sub>2 \<union> list_vars ess"

fun list_ctor_count :: "(uexpr \<times> uexpr) list \<Rightarrow> nat" where
  "list_ctor_count [] = 0"
| "list_ctor_count ((e\<^sub>1, e\<^sub>2) # ess) = ctor_count e\<^sub>1 + list_ctor_count ess"

definition structural :: "(uexpr \<Rightarrow> bool) \<Rightarrow> bool" where
  "structural P = (\<exists>f. \<forall>k es. P (Ctor k es) = (list_all P es \<and> f k (length es)))"

lemma [simp]: "finite (list_vars ess)"
  by (induction ess rule: list_vars.induct) simp_all

lemma [simp]: "list_vars (ess\<^sub>1 @ ess\<^sub>2) = list_vars ess\<^sub>1 \<union> list_vars ess\<^sub>2"
  by (induction ess\<^sub>1 rule: list_ctor_count.induct) auto

lemma [simp]: "length es\<^sub>1 = length es\<^sub>2 \<Longrightarrow> list_vars (zip es\<^sub>1 es\<^sub>2) = varss es\<^sub>1 \<union> varss es\<^sub>2"
proof (induction es\<^sub>1 arbitrary: es\<^sub>2)
  case (Cons e\<^sub>1 es\<^sub>1)
  thus ?case by (induction es\<^sub>2) auto
qed simp_all

lemma [simp]: "list_ctor_count (ess\<^sub>1 @ ess\<^sub>2) = list_ctor_count ess\<^sub>1 + list_ctor_count ess\<^sub>2"
  by (induction ess\<^sub>1 rule: list_ctor_count.induct) simp_all

lemma [simp]: "length es\<^sub>1 = length es\<^sub>2 \<Longrightarrow>
  list_ctor_count (zip es\<^sub>1 es\<^sub>2) = sum_list (map ctor_count es\<^sub>1)"
proof (induction es\<^sub>1 arbitrary: es\<^sub>2)
  case (Cons e\<^sub>1 es\<^sub>1)
  thus ?case by (induction es\<^sub>2) simp_all
qed simp_all

end


(*
   Title: The Calculus of Communicating Systems
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weak_Bisim_Pres
  imports Weak_Bisim Weak_Sim_Pres Strong_Bisim_SC
begin

lemma actPres:
  fixes P :: ccs
  and   Q :: ccs
  and   \<alpha> :: act

  assumes "P \<approx> Q"

  shows "\<alpha>.(P) \<approx> \<alpha>.(Q)"
proof -
  let ?X = "{(\<alpha>.(P), \<alpha>.(Q)) | P Q. P \<approx> Q}"
  from assms have "(\<alpha>.(P), \<alpha>.(Q)) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: weakBisimulationCoinduct) (auto dest: weakBisimulationE intro: actPres)
qed

lemma parPres:
  fixes P :: ccs
  and   Q :: ccs
  and   R :: ccs

  assumes "P \<approx> Q"

  shows "P \<parallel> R \<approx> Q \<parallel> R"
proof -
  let ?X = "{(P \<parallel> R, Q \<parallel> R) | P Q R. P \<approx> Q}"
  from assms have "(P \<parallel> R, Q \<parallel> R) \<in> ?X" by blast
  thus ?thesis
    by(coinduct rule: weakBisimulationCoinduct, auto)
      (blast intro: parPres dest: weakBisimulationE)+
qed

  assumes "P \<approx> Q"

  shows "\<lparr>\<nu>x\<rparr>P \<approx> \<lparr>\<nu>x\<rparr>Q"
proof -
  let ?X = "{(\<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) | x P Q. P \<approx> Q}"
  from assms have "(\<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: weakBisimulationCoinduct) (auto intro: resPres dest: weakBisimulationE)
qed

  assumes "P \<approx> Q"

  shows "!P \<approx> !Q"
proof -
  let ?X = "bangRel weakBisimulation"
  let ?Y = "weakBisimulation O ?X O bisim"
  {
    fix R T P Q
    assume "R \<approx> T" and "(P, Q) \<in> ?Y"
    from \<open>(P, Q) \<in> ?Y\<close> obtain P' Q' where "P \<approx> P'" and "(P', Q') \<in> ?X" and "Q' \<sim> Q"
      by auto
    from \<open>P \<approx> P'\<close> have "R \<parallel> P \<approx> R \<parallel> P'"
      by(metis parPres bisimWeakBisimulation transitive parComm)
    moreover from \<open>R \<approx> T\<close> \<open>(P', Q') \<in> ?X\<close> have "(R \<parallel> P', T \<parallel> Q') \<in> ?X" by(auto dest: BRPar)
    moreover from \<open>Q' \<sim> Q\<close> have "T \<parallel> Q' \<sim> T \<parallel> Q" by(metis Strong_Bisim_Pres.parPres Strong_Bisim.transitive parComm)
    ultimately have "(R \<parallel> P, T \<parallel> Q) \<in> ?Y" by auto
  } note BRParAux = this

  from assms have "(!P, !Q) \<in> ?X" by(auto intro: BRBang)
  thus ?thesis
  proof(coinduct rule: weakBisimWeakUpto)
    case(cSim P Q)
    from \<open>(P, Q) \<in> bangRel weakBisimulation\<close> show ?case
    proof(induct)
      case(BRBang P Q)
      note \<open>P \<approx> Q\<close> weakBisimulationE(1) BRParAux
      moreover have "?X \<subseteq> ?Y" by(auto intro: Strong_Bisim.reflexive reflexive)
      moreover {
        fix P Q
        assume "(P \<parallel> !P, Q) \<in> ?Y"
        hence "(!P, Q) \<in> ?Y" using bangUnfold
          by(blast dest: Strong_Bisim.transitive transitive bisimWeakBisimulation)
      }
      ultimately show ?case by(rule bangPres)
    next
      case(BRPar R T P Q)
      from \<open>R \<approx> T\<close> have "R \<leadsto>\<^sup>^<weakBisimulation> T" by(rule weakBisimulationE)
      moreover note \<open>R \<approx> T\<close> \<open>P \<leadsto>\<^sup>^<?Y> Q\<close>
      moreover from \<open>(P, Q) \<in> ?X\<close> have "(P, Q) \<in> ?Y" by(blast intro: Strong_Bisim.reflexive reflexive)
      ultimately show ?case using BRParAux by(rule Weak_Sim_Pres.parPresAux)
    qed
  next
    case(cSym P Q)
    thus ?case
      by induct (auto dest: weakBisimulationE intro: BRPar BRBang)
  qed
qed

end


(*
    Title:      Bases_Of_Fundamental_Subspaces.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

header{*Bases of the four fundamental subspaces*}

theory Bases_Of_Fundamental_Subspaces
imports
  Gauss_Jordan_PA
begin

subsection{*Computation of the bases of the fundamental subspaces*}

definition "basis_null_space A = {row i (P_Gauss_Jordan (transpose A)) | i. to_nat i \<ge> rank A}"
definition "basis_row_space A = {row i (Gauss_Jordan A) |i. row i (Gauss_Jordan A) \<noteq> 0}"
definition "basis_col_space A = {row i (Gauss_Jordan (transpose A)) |i. row i (Gauss_Jordan (transpose A)) \<noteq> 0}"
definition "basis_left_null_space A = {row i (P_Gauss_Jordan A) | i. to_nat i \<ge> rank A}"

subsection{*Relatioships amongst the bases*}

lemma basis_null_space_eq_basis_left_null_space_transpose:
  "basis_null_space A = basis_left_null_space (transpose A)"
unfolding basis_null_space_def
unfolding basis_left_null_space_def
unfolding rank_transpose[of A, symmetric] ..

lemma basis_null_space_transpose_eq_basis_left_null_space:
shows "basis_null_space (transpose A) = basis_left_null_space A"
by (metis transpose_transpose basis_null_space_eq_basis_left_null_space_transpose)

lemma basis_col_space_eq_basis_row_space_transpose:
  "basis_col_space A = basis_row_space (transpose A)"
unfolding basis_col_space_def basis_row_space_def ..

subsection{*Code equations*}

text{*Code equations to make more efficient the computations.*}
lemma basis_null_space_code[code]: "basis_null_space A = (let GJ = Gauss_Jordan_PA (transpose A);
                                                               rank_A = (if A = 0 then 0 else to_nat (GREATEST' a. row a (snd GJ) \<noteq> 0) + 1)
                                                               in {row i (fst GJ) | i. to_nat i \<ge> rank_A})"
unfolding basis_null_space_def Let_def P_Gauss_Jordan_def
unfolding Gauss_Jordan_PA_eq
unfolding rank_transpose[symmetric, of A]
unfolding rank_Gauss_Jordan_code[of "transpose A"]
unfolding Let_def
unfolding transpose_zero ..

lemma basis_row_space_code[code]: "basis_row_space A = (let A' = Gauss_Jordan A in {row i A' |i. row i A' \<noteq> 0})"
unfolding basis_row_space_def Let_def ..

lemma basis_col_space_code[code]: "basis_col_space A = (let A' = Gauss_Jordan (transpose A) in {row i A' |i. row i A' \<noteq> 0})"
unfolding basis_col_space_def Let_def ..

lemma basis_left_null_space_code[code]: "basis_left_null_space A = (let GJ = Gauss_Jordan_PA A;
                                                               rank_A = (if A = 0 then 0 else to_nat (GREATEST' a. row a (snd GJ) \<noteq> 0) + 1)
                                                               in {row i (fst GJ) | i. to_nat i \<ge> rank_A})"
unfolding basis_left_null_space_def Let_def P_Gauss_Jordan_def
unfolding Gauss_Jordan_PA_eq
unfolding rank_Gauss_Jordan_code[of "A"]
unfolding Let_def
unfolding transpose_zero ..

subsection{*Demonstrations that they are bases*}

text{*We prove that we have obtained a basis for each subspace*}

lemma independent_basis_left_null_space:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "vec.independent (basis_left_null_space A)"
proof (unfold basis_left_null_space_def, rule vec.independent_mono)
show "vec.independent (rows (P_Gauss_Jordan A))"
  by (metis P_Gauss_Jordan_def det_dependent_rows invertible_det_nz invertible_fst_Gauss_Jordan_PA)
show "{row i (P_Gauss_Jordan A) |i. rank A \<le> to_nat i} \<subseteq> (rows (P_Gauss_Jordan A))" unfolding rows_def by fast
qed

lemma card_basis_left_null_space_eq_dim:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "card (basis_left_null_space A) = vec.dim (left_null_space A)"
proof -
let ?f="\<lambda>n. row (from_nat (n + (rank A))) (P_Gauss_Jordan A)"
have "card (basis_left_null_space A) = card {row i (P_Gauss_Jordan A) | i. to_nat i \<ge> rank A}" unfolding basis_left_null_space_def ..
also have "... = card {..<(vec.dimension TYPE('a) TYPE('rows)) - rank A}"
  proof (rule bij_betw_same_card[symmetric, of ?f], unfold bij_betw_def, rule conjI)
    show "inj_on ?f {..<(vec.dimension TYPE('a) TYPE('rows)) - rank A}" unfolding inj_on_def
      proof (auto, rule ccontr, unfold dimension_vector)
        fix x y
        assume x: "x <CARD('rows) - rank A"
          and y: "y < CARD('rows) - rank A"
          and eq: "row (from_nat (x + rank A)) (P_Gauss_Jordan A) = row (from_nat (y + rank A)) (P_Gauss_Jordan A)"
          and x_not_y: "x \<noteq> y"
          have "det (P_Gauss_Jordan A) = 0"
            proof (rule det_identical_rows[OF _ eq])
              have "(x + rank A) \<noteq> (y + rank A)" using x_not_y x y by simp
              thus "(from_nat (x + rank A)::'rows) \<noteq> from_nat (y + rank A)" by (metis (mono_tags) from_nat_eq_imp_eq less_diff_conv x y)
            qed
          moreover have "invertible (P_Gauss_Jordan A)" by (metis P_Gauss_Jordan_def invertible_fst_Gauss_Jordan_PA)
          ultimately show False  unfolding invertible_det_nz by contradiction
       qed
       show "?f  ` {..<(vec.dimension TYPE('a) TYPE('rows)) - rank A} = {row i (P_Gauss_Jordan A) |i. rank A \<le> to_nat i}"
       proof (unfold image_def dimension_vector, auto, metis le_add2 less_diff_conv to_nat_from_nat_id)
        fix i::'rows
        assume rank_le_i: "rank A \<le> to_nat i"
        show "\<exists>x\<in>{..<CARD('rows) - rank A}. row i (P_Gauss_Jordan A) = row (from_nat (x + rank A)) (P_Gauss_Jordan A)"
            proof (rule bexI[of _ "(to_nat i - rank A)"])
              have "i = (from_nat (to_nat i - rank A + rank A))" by (metis rank_le_i from_nat_to_nat_id le_add_diff_inverse2)
              thus "row i (P_Gauss_Jordan A) = row (from_nat (to_nat i - rank A + rank A)) (P_Gauss_Jordan A)" by presburger
              show "to_nat i - rank A \<in> {..<CARD('rows) - rank A}" using rank_le_i by (metis diff_less_mono lessThan_def mem_Collect_eq to_nat_less_card)
            qed
        qed
        qed
        also have "... = (vec.dimension TYPE('a) TYPE('rows)) - rank A" unfolding card_lessThan ..
        also have "... = vec.dim (null_space (transpose A))" unfolding dim_null_space rank_transpose ..
        also have "... = vec.dim (left_null_space A)" unfolding left_null_space_eq_null_space_transpose ..
        finally show ?thesis .
qed

lemma basis_left_null_space_in_left_null_space:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "basis_left_null_space A \<subseteq> left_null_space A"
  proof (unfold basis_left_null_space_def left_null_space_def, auto)
    fix i::'rows
    assume rank_le_i: " rank A \<le> to_nat i"
    have "row i (P_Gauss_Jordan A) v* A = ((P_Gauss_Jordan A) $ i) v* A" unfolding row_def vec_nth_inverse ..
    also have "... = ((P_Gauss_Jordan A) ** A) $ i" unfolding row_matrix_matrix_mult by simp
    also have "... = (Gauss_Jordan A) $ i" unfolding P_Gauss_Jordan_def Gauss_Jordan_PA_eq[symmetric] using fst_Gauss_Jordan_PA by metis
    also have "... = 0" by (rule rank_less_row_i_imp_i_is_zero[OF rank_le_i])
    finally show "row i (P_Gauss_Jordan A) v* A = 0" .
qed

lemma left_null_space_subset_span_basis:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows  "left_null_space A \<subseteq> vec.span (basis_left_null_space A)"
proof (rule vec.card_ge_dim_independent)
show "basis_left_null_space A \<subseteq> left_null_space A" by (rule basis_left_null_space_in_left_null_space)
show "vec.independent (basis_left_null_space A)" by (rule independent_basis_left_null_space)
show "vec.dim (left_null_space A) \<le> card (basis_left_null_space A)"
  proof -
    have "{x. x v* A = 0} = {x. (transpose A) *v x = 0}" by (metis transpose_vector)
    thus ?thesis using card_basis_left_null_space_eq_dim by (metis order_refl)
  qed
qed

corollary basis_left_null_space:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "vec.independent (basis_left_null_space A) \<and>
       left_null_space A = vec.span (basis_left_null_space A)"
by (metis basis_left_null_space_in_left_null_space independent_basis_left_null_space
  left_null_space_subset_span_basis vec.span_subspace subspace_left_null_space)

corollary basis_null_space:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "vec.independent (basis_null_space A) \<and>
       null_space A = vec.span (basis_null_space A)"
unfolding basis_null_space_eq_basis_left_null_space_transpose
unfolding null_space_eq_left_null_space_transpose
by (rule basis_left_null_space)

lemma basis_row_space_subset_row_space:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "basis_row_space A \<subseteq> row_space A"
  proof -
    have "basis_row_space A = {row i (Gauss_Jordan A) |i. row i (Gauss_Jordan A) \<noteq> 0}" unfolding basis_row_space_def ..
    also have "... \<subseteq> row_space (Gauss_Jordan A)"
      proof (unfold row_space_def, clarify)
        fix i assume "row i (Gauss_Jordan A) \<noteq> 0"
        show "row i (Gauss_Jordan A) \<in> vec.span (rows (Gauss_Jordan A))" by (rule vec.span_superset, auto simp add: rows_def)
      qed
      also have "... = row_space A" unfolding Gauss_Jordan_PA_eq[symmetric] unfolding fst_Gauss_Jordan_PA[symmetric]
      by (rule row_space_is_preserved[OF invertible_fst_Gauss_Jordan_PA])
      finally show ?thesis .
qed

lemma row_space_subset_span_basis_row_space:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "row_space A \<subseteq> vec.span (basis_row_space A)"
proof (rule vec.card_ge_dim_independent)
show "basis_row_space A \<subseteq> row_space A" by (rule basis_row_space_subset_row_space)
show "vec.independent (basis_row_space A)" unfolding basis_row_space_def by (rule independent_not_zero_rows_rref[OF rref_Gauss_Jordan])
show "vec.dim (row_space A) \<le> card (basis_row_space A)"
unfolding basis_row_space_def
using rref_rank[OF rref_Gauss_Jordan, of A] unfolding row_rank_def[symmetric] rank_def[symmetric] rank_Gauss_Jordan[symmetric] by fastforce
qed

lemma basis_row_space:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "vec.independent (basis_row_space A)
  \<and> vec.span (basis_row_space A) = row_space A"
proof (rule conjI)
  show "vec.independent (basis_row_space A)" unfolding basis_row_space_def using independent_not_zero_rows_rref[OF rref_Gauss_Jordan] .
  show "vec.span (basis_row_space A) = row_space A"
    proof (rule vec.span_subspace)
      show "basis_row_space A \<subseteq> row_space A" by (rule basis_row_space_subset_row_space)
      show "row_space A \<subseteq> vec.span (basis_row_space A)" by (rule row_space_subset_span_basis_row_space)
      show "vec.subspace (row_space A)" by (rule subspace_row_space)
    qed
qed

corollary basis_col_space:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "vec.independent (basis_col_space A)
  \<and> vec.span (basis_col_space A) = col_space A"
unfolding col_space_eq_row_space_transpose basis_col_space_eq_basis_row_space_transpose
by (rule basis_row_space)

end


(*  Title:      HOL/UNITY/Simple/Reach.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

Reachability in Directed Graphs.  From Chandy and Misra, section 6.4.
[this example took only four days!]
*)

theory Reach imports "../UNITY_Main" begin

typedecl vertex

type_synonym state = "vertex=>bool"

consts
  init ::  "vertex"

  edges :: "(vertex*vertex) set"

definition asgt :: "[vertex,vertex] => (state*state) set"
  where "asgt u v = {(s,s'). s' = s(v:= s u | s v)}"

definition Rprg :: "state program"
  where "Rprg = mk_total_program ({%v. v=init}, \<Union>(u,v)\<in>edges. {asgt u v}, UNIV)"

definition reach_invariant :: "state set"
  where "reach_invariant = {s. (\<forall>v. s v --> (init, v) \<in> edges^*) & s init}"

definition fixedpoint :: "state set"
  where "fixedpoint = {s. \<forall>(u,v)\<in>edges. s u --> s v}"

definition metric :: "state => nat"
  where "metric s = card {v. ~ s v}"

text{**We assume that the set of vertices is finite*}
axiomatization where
  finite_graph:  "finite (UNIV :: vertex set)"

(*TO SIMPDATA.ML??  FOR CLASET??  *)
lemma ifE [elim!]:
    "[| if P then Q else R;
        [| P;   Q |] ==> S;
        [| ~ P; R |] ==> S |] ==> S"
by (simp split: split_if_asm)

declare Rprg_def [THEN def_prg_Init, simp]

declare asgt_def [THEN def_act_simp,simp]

text{*All vertex sets are finite*}
declare finite_subset [OF subset_UNIV finite_graph, iff]

declare reach_invariant_def [THEN def_set_simp, simp]

lemma reach_invariant: "Rprg \<in> Always reach_invariant"
apply (rule AlwaysI, force)
apply (unfold Rprg_def, safety)
apply (blast intro: rtrancl_trans)
done

(*** Fixedpoint ***)

(*If it reaches a fixedpoint, it has found a solution*)
lemma fixedpoint_invariant_correct:
     "fixedpoint \<inter> reach_invariant = { %v. (init, v) \<in> edges^* }"
apply (unfold fixedpoint_def)
apply (rule equalityI)
apply (auto intro!: ext)
apply (erule rtrancl_induct, auto)
done

lemma lemma1:
     "FP Rprg \<subseteq> fixedpoint"
apply (simp add: FP_def fixedpoint_def Rprg_def mk_total_program_def)
apply (auto simp add: stable_def constrains_def)
apply (drule bspec, assumption)
apply (simp add: Image_singleton image_iff)
apply (drule fun_cong, auto)
done

lemma lemma2:
     "fixedpoint \<subseteq> FP Rprg"
apply (simp add: FP_def fixedpoint_def Rprg_def mk_total_program_def)
apply (auto intro!: ext simp add: stable_def constrains_def)
done

lemma FP_fixedpoint: "FP Rprg = fixedpoint"
by (rule equalityI [OF lemma1 lemma2])

(*If we haven't reached a fixedpoint then there is some edge for which u but
  not v holds.  Progress will be proved via an ENSURES assertion that the
  metric will decrease for each suitable edge.  A union over all edges proves
  a LEADSTO assertion that the metric decreases if we are not at a fixedpoint.
  *)

lemma Compl_fixedpoint: "- fixedpoint = (\<Union>(u,v)\<in>edges. {s. s u & ~ s v})"
apply (simp add: FP_fixedpoint [symmetric] Rprg_def mk_total_program_def)
apply (rule subset_antisym)
apply (auto simp add: Compl_FP UN_UN_flatten)
 apply (rule fun_upd_idem, force)
apply (force intro!: rev_bexI simp add: fun_upd_idem_iff)
done

lemma Diff_fixedpoint:
     "A - fixedpoint = (\<Union>(u,v)\<in>edges. A \<inter> {s. s u & ~ s v})"
by (simp add: Diff_eq Compl_fixedpoint, blast)

(*** Progress ***)

lemma Suc_metric: "~ s x ==> Suc (metric (s(x:=True))) = metric s"
apply (unfold metric_def)
apply (subgoal_tac "{v. ~ (s (x:=True)) v} = {v. ~ s v} - {x}")
 prefer 2 apply force
apply (simp add: card_Suc_Diff1 del:card_Diff_insert)
done

lemma metric_less [intro!]: "~ s x ==> metric (s(x:=True)) < metric s"
by (erule Suc_metric [THEN subst], blast)

lemma metric_le: "metric (s(y:=s x | s y)) \<le> metric s"
  by (cases "s x --> s y") (auto intro: less_imp_le simp add: fun_upd_idem)

lemma LeadsTo_Diff_fixedpoint:
     "Rprg \<in> ((metric-`{m}) - fixedpoint) LeadsTo (metric-`(lessThan m))"
apply (simp (no_asm) add: Diff_fixedpoint Rprg_def)
apply (rule LeadsTo_UN, auto)
apply (ensures_tac "asgt a b")
 prefer 2 apply blast
apply (simp (no_asm_use) add: linorder_not_less)
apply (drule metric_le [THEN order_antisym])
apply (auto elim: less_not_refl3 [THEN [2] rev_notE])
done

lemma LeadsTo_Un_fixedpoint:
     "Rprg \<in> (metric-`{m}) LeadsTo (metric-`(lessThan m) \<union> fixedpoint)"
apply (rule LeadsTo_Diff [OF LeadsTo_Diff_fixedpoint [THEN LeadsTo_weaken_R]
                             subset_imp_LeadsTo], auto)
done

(*Execution in any state leads to a fixedpoint (i.e. can terminate)*)
lemma LeadsTo_fixedpoint: "Rprg \<in> UNIV LeadsTo fixedpoint"
apply (rule LessThan_induct, auto)
apply (rule LeadsTo_Un_fixedpoint)
done

lemma LeadsTo_correct: "Rprg \<in> UNIV LeadsTo { %v. (init, v) \<in> edges^* }"
apply (subst fixedpoint_invariant_correct [symmetric])
apply (rule Always_LeadsTo_weaken [OF reach_invariant LeadsTo_fixedpoint], auto)
done

end


theory Lexer
  imports Spec
begin

section {* The Lexer Functions by Sulzmann and Lu  *}

fun
  mkeps :: "rexp \<Rightarrow> val"
where
  "mkeps(ONE) = Void"
| "mkeps(SEQ r1 r2) = Seq (mkeps r1) (mkeps r2)"
| "mkeps(ALT r1 r2) = (if nullable(r1) then Left (mkeps r1) else Right (mkeps r2))"
| "mkeps(STAR r) = Stars []"

fun injval :: "rexp \<Rightarrow> char \<Rightarrow> val \<Rightarrow> val"
where
  "injval (CHAR d) c Void = Char d"
| "injval (ALT r1 r2) c (Left v1) = Left(injval r1 c v1)"
| "injval (ALT r1 r2) c (Right v2) = Right(injval r2 c v2)"
| "injval (SEQ r1 r2) c (Seq v1 v2) = Seq (injval r1 c v1) v2"
| "injval (SEQ r1 r2) c (Left (Seq v1 v2)) = Seq (injval r1 c v1) v2"
| "injval (SEQ r1 r2) c (Right v2) = Seq (mkeps r1) (injval r2 c v2)"
| "injval (STAR r) c (Seq v (Stars vs)) = Stars ((injval r c v) # vs)"

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

section {* Mkeps, Injval Properties *}

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

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

lemma Prf_injval_flat:
  assumes "\<Turnstile> v : der c r"
  shows "flat (injval r c v) = c # (flat v)"
using assms
apply(induct c r arbitrary: v rule: der.induct)
apply(auto elim!: Prf_elims intro: mkeps_flat split: if_splits)
done

lemma Prf_injval:
  assumes "\<Turnstile> v : der c r"
  shows "\<Turnstile> (injval r c v) : r"
using assms
apply(induct r arbitrary: c v rule: rexp.induct)
apply(auto intro!: Prf.intros mkeps_nullable elim!: Prf_elims split: if_splits)
apply(simp add: Prf_injval_flat)
done

text {*
  Mkeps and injval produce, or preserve, Posix values.
*}

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

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

section {* Lexer Correctness *}

lemma lexer_correct_None:
  shows "s \<notin> L r \<longleftrightarrow> lexer r s = None"
  apply(induct s arbitrary: r)
  apply(simp)
  apply(simp add: nullable_correctness)
  apply(simp)
  apply(drule_tac x="der a r" in meta_spec)
  apply(auto)
  apply(auto simp add: der_correctness Der_def)
done

lemma lexer_correct_Some:
  shows "s \<in> L r \<longleftrightarrow> (\<exists>v. lexer r s = Some(v) \<and> s \<in> r \<rightarrow> v)"
  apply(induct s arbitrary : r)
  apply(simp only: lexer.simps)
  apply(simp)
  apply(simp add: nullable_correctness Posix_mkeps)
  apply(drule_tac x="der a r" in meta_spec)
  apply(simp (no_asm_use) add: der_correctness Der_def del: lexer.simps)
  apply(simp del: lexer.simps)
  apply(simp only: lexer.simps)
  apply(case_tac "lexer (der a r) s = None")
   apply(auto)[1]
  apply(simp)
  apply(erule exE)
  apply(simp)
  apply(rule iffI)
  apply(simp add: Posix_injval)
  apply(simp add: Posix1(1))
done

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

fun flex :: "rexp \<Rightarrow> (val \<Rightarrow> val) => string \<Rightarrow> (val \<Rightarrow> val)"
  where
  "flex r f [] = f"
| "flex r f (c#s) = flex (der c r) (\<lambda>v. f (injval r c v)) s"

lemma flex_fun_apply:
  shows "g (flex r f s v) = flex r (g o f) s v"
  apply(induct s arbitrary: g f r v)
  apply(simp_all add: comp_def)
  by meson

lemma flex_append:
  shows "flex r f (s1 @ s2) = flex (ders s1 r) (flex r f s1) s2"
  apply(induct s1 arbitrary: s2 r f)
  apply(simp_all)
  done

lemma lexer_flex:
  shows "lexer r s = (if nullable (ders s r)
                      then Some(flex r id s (mkeps (ders s r))) else None)"
  apply(induct s arbitrary: r)
  apply(simp_all add: flex_fun_apply)
  done

unused_thms

end


(*
 * Copyright Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* Author: Jeremy Dawson, NICTA *)

section \<open>Operation variant for the least significant bit\<close>

theory Least_significant_bit
  imports
    "HOL-Library.Word"
    More_Word
begin

class lsb = semiring_bits +
  fixes lsb :: \<open>'a \<Rightarrow> bool\<close>
  assumes lsb_odd: \<open>lsb = odd\<close>

instantiation int :: lsb
begin

definition lsb_int :: \<open>int \<Rightarrow> bool\<close>
  where \<open>lsb i = bit i 0\<close> for i :: int

instance
  by standard (simp add: fun_eq_iff lsb_int_def bit_0)

end

lemma bin_last_conv_lsb: "odd = (lsb :: int \<Rightarrow> bool)"
  by (simp add: lsb_odd)

lemma int_lsb_numeral [simp]:
  "lsb (0 :: int) = False"
  "lsb (1 :: int) = True"
  "lsb (Numeral1 :: int) = True"
  "lsb (- 1 :: int) = True"
  "lsb (- Numeral1 :: int) = True"
  "lsb (numeral (num.Bit0 w) :: int) = False"
  "lsb (numeral (num.Bit1 w) :: int) = True"
  "lsb (- numeral (num.Bit0 w) :: int) = False"
  "lsb (- numeral (num.Bit1 w) :: int) = True"
  by (simp_all add: lsb_int_def bit_0)

instantiation word :: (len) lsb
begin

definition lsb_word :: \<open>'a word \<Rightarrow> bool\<close>
  where word_lsb_def: \<open>lsb a \<longleftrightarrow> odd (uint a)\<close> for a :: \<open>'a word\<close>

instance
  apply standard
  apply (simp add: fun_eq_iff word_lsb_def)
  apply transfer apply simp
  done

end

lemma lsb_word_eq:
  \<open>lsb = (odd :: 'a word \<Rightarrow> bool)\<close> for w :: \<open>'a::len word\<close>
  by (fact lsb_odd)

lemma word_lsb_alt: "lsb w = bit w 0"
  for w :: "'a::len word"
  by (simp add: lsb_word_eq bit_0)

lemma word_lsb_1_0 [simp]: "lsb (1::'a::len word) \<and> \<not> lsb (0::'b::len word)"
  unfolding word_lsb_def by simp

lemma word_lsb_int: "lsb w \<longleftrightarrow> uint w mod 2 = 1"
  apply (simp add: lsb_odd flip: odd_iff_mod_2_eq_one)
  apply transfer
  apply simp
  done

lemmas word_ops_lsb = lsb0 [unfolded word_lsb_alt]

lemma word_lsb_numeral [simp]:
  "lsb (numeral bin :: 'a::len word) \<longleftrightarrow> odd (numeral bin :: int)"
  by (simp only: lsb_odd, transfer) rule

lemma word_lsb_neg_numeral [simp]:
  "lsb (- numeral bin :: 'a::len word) \<longleftrightarrow> odd (- numeral bin :: int)"
  by (simp only: lsb_odd, transfer) rule

lemma word_lsb_nat:"lsb w = (unat w mod 2 = 1)"
  apply (simp add: word_lsb_def Groebner_Basis.algebra(31))
  apply transfer
  apply (simp add: even_nat_iff)
  done

instantiation integer :: lsb
begin

context
  includes integer.lifting
begin

lift_definition lsb_integer :: \<open>integer \<Rightarrow> bool\<close> is lsb .

instance
  by (standard; transfer) (fact lsb_odd)

end

end

end