(*  Title:       A Definitional Encoding of TLA in Isabelle/HOL
    Authors:     Gudmund Grov <ggrov at inf.ed.ac.uk>
                 Stephan Merz <Stephan.Merz at loria.fr>
    Year:        2011
    Maintainer:  Gudmund Grov <ggrov at inf.ed.ac.uk>
*)

header {* Refining a Buffer Specification *}

theory Buffer
imports State
begin

text {*
  We specify a simple FIFO buffer and prove that two FIFO buffers
  in a row implement a FIFO buffer.
*}

subsection "Buffer specification"

text {*
  The following definitions all take three parameters: a state function
  representing the input channel of the FIFO buffer, another representing
  the internal queue, and a third one representing the output channel.
  These parameters will be instantiated later in the definition of the
  double FIFO.
*}

definition BInit :: "'a statefun \<Rightarrow> 'a list statefun \<Rightarrow> 'a statefun \<Rightarrow> temporal"
where "BInit ic q oc \<equiv> TEMP $q = #[]
                          \<and> $ic = $oc"   -- {* initial condition of buffer *}

definition Enq :: "'a statefun \<Rightarrow> 'a list statefun \<Rightarrow> 'a statefun \<Rightarrow> temporal"
where "Enq ic q oc \<equiv> TEMP ic$ \<noteq> $ic
                        \<and> q$ = $q @ [ ic$ ]
                        \<and> oc$ = $oc"     -- {* enqueue a new value *}

definition Deq :: "'a statefun \<Rightarrow> 'a list statefun \<Rightarrow> 'a statefun \<Rightarrow> temporal"
where "Deq ic q oc \<equiv> TEMP # 0 < length<$q>
                        \<and> oc$ = hd<$q>
                        \<and> q$ = tl<$q>
                        \<and> ic$ = $ic"     -- {* dequeue value at front *}

definition Nxt :: "'a statefun \<Rightarrow> 'a list statefun \<Rightarrow> 'a statefun \<Rightarrow> temporal"
where "Nxt ic q oc \<equiv> TEMP (Enq ic q oc \<or> Deq ic q oc)"

-- {* internal specification with buffer visible *}
definition ISpec :: "'a statefun \<Rightarrow> 'a list statefun \<Rightarrow> 'a statefun \<Rightarrow> temporal"
where "ISpec ic q oc \<equiv> TEMP BInit ic q oc
                          \<and> \<box>[Nxt ic q oc]_(ic,q,oc)
                          \<and> WF(Deq ic q oc)_(ic,q,oc)"

-- {* external specification: buffer hidden *}
definition Spec :: "'a statefun \<Rightarrow> 'a statefun \<Rightarrow> temporal"
where "Spec ic oc == TEMP (EEX q. ISpec ic q oc)"

subsection "Properties of the buffer"

text {*
  The buffer never enqueues the same element twice. We therefore
  have the following invariant:
  \begin{itemize}
  \item any two subsequent elements in the queue are different, and
    the last element in the queue is different from the value of the
    output channel,
  \item if the queue is non-empty then the last element in the queue
    is the value that appears on the input channel,
  \item if the queue is empty then the values on the output and input
    channels are equal.
  \end{itemize}

  The following auxiliary predicate @{text noreps} is true if no
  two subsequent elements in a list are identical.
*}

definition noreps :: "'a list \<Rightarrow> bool"
where "noreps xs \<equiv> \<forall>i < length xs - 1. xs!i \<noteq> xs!(Suc i)"

definition BInv :: "'a statefun \<Rightarrow> 'a list statefun \<Rightarrow> 'a statefun \<Rightarrow> temporal"
where "BInv ic q oc \<equiv> TEMP List.last<$oc # $q> = $ic \<and> noreps<$oc # $q>"

lemmas buffer_defs = BInit_def Enq_def Deq_def Nxt_def
                     ISpec_def Spec_def BInv_def

lemma ISpec_stutinv: "STUTINV (ISpec ic q oc)"
  unfolding buffer_defs by (simp add: bothstutinvs livestutinv)

lemma Spec_stutinv: "STUTINV Spec ic oc"
  unfolding buffer_defs by (simp add: bothstutinvs livestutinv eexSTUT)

text {* A lemma about lists that is useful in the following *}
lemma tl_self_iff_empty[simp]: "(tl xs = xs) = (xs = [])"
proof
  assume 1: "tl xs = xs"
  show "xs = []"
  proof (rule ccontr)
    assume "xs \<noteq> []" with 1 show "False"
      by (auto simp: neq_Nil_conv)
  qed
qed (auto)

lemma tl_self_iff_empty'[simp]: "(xs = tl xs) = (xs = [])"
proof
  assume 1: "xs = tl xs"
  show "xs = []"
  proof (rule ccontr)
    assume "xs \<noteq> []" with 1 show "False"
      by (auto simp: neq_Nil_conv)
  qed
qed (auto)

lemma Deq_visible:
  assumes v: "\<turnstile> Unchanged v \<longrightarrow> Unchanged q"
  shows "|~ <Deq ic q oc>_v = Deq ic q oc"
proof (auto simp: tla_defs)
  fix w
  assume deq: "w \<Turnstile> Deq ic q oc" and unch: "v (w (Suc 0)) = v (w 0)"
  from unch v[unlifted] have "q (w (Suc 0)) = q (w 0)"
    by (auto simp: tla_defs)
  with deq show "False" by (auto simp: Deq_def tla_defs)
qed

lemma Deq_enabledE: "\<turnstile> Enabled <Deq ic q oc>_(ic,q,oc) \<longrightarrow> $q ~= #[]"
  by (auto elim!: enabledE simp: Deq_def tla_defs)

text {*
  We now prove that @{text BInv} is an invariant of the Buffer
  specification.

  We need several lemmas about @{text noreps} that are used in the
  invariant proof.
*}

lemma noreps_empty [simp]: "noreps []"
  by (auto simp: noreps_def)

lemma noreps_singleton: "noreps [x]"  -- {* special case of following lemma *}
  by (auto simp: noreps_def)

lemma noreps_cons [simp]:
  "noreps (x # xs) = (noreps xs \<and> (xs = [] \<or> x \<noteq> hd xs))"
proof (auto simp: noreps_singleton)
  assume cons: "noreps (x # xs)"
  show "noreps xs"
  proof (auto simp: noreps_def)
    fix i
    assume i: "i < length xs - Suc 0" and eq: "xs!i = xs!(Suc i)"
    from i have "Suc i < length (x#xs) - 1" by auto
    moreover
    from eq have "(x#xs)!(Suc i) = (x#xs)!(Suc (Suc i))" by auto
    moreover
    note cons
    ultimately show False by (auto simp: noreps_def)
  qed
next
  assume 1: "noreps (hd xs # xs)" and 2: "xs \<noteq> []"
  from 2 obtain x xxs where "xs = x # xxs" by (cases xs, auto)
  with 1 show False by (auto simp: noreps_def)
next
  assume 1: "noreps xs" and 2: "x \<noteq> hd xs"
  show "noreps (x # xs)"
  proof (auto simp: noreps_def)
    fix i
    assume i: "i < length xs" and eq: "(x # xs)!i = xs!i"
    from i obtain y ys where xs: "xs = y # ys" by (cases xs, auto)
    show False
    proof (cases i)
      assume "i = 0"
      with eq 2 xs show False by auto
    next
      fix k
      assume k: "i = Suc k"
      with i eq xs 1 show False by (auto simp: noreps_def)
    qed
  qed
qed

lemma noreps_append [simp]:
  "noreps (xs @ ys) =
   (noreps xs \<and> noreps ys \<and> (xs = [] \<or> ys = [] \<or> List.last xs \<noteq> hd ys))"
proof auto
  assume 1: "noreps (xs @ ys)"
  show "noreps xs"
  proof (auto simp: noreps_def)
    fix i
    assume i: "i < length xs - Suc 0" and eq: "xs!i = xs!(Suc i)"
    from i have "i < length (xs @ ys) - Suc 0" by auto
    moreover
    from i eq have "(xs @ ys)!i = (xs@ys)!(Suc i)" by (auto simp: nth_append)
    moreover note 1
    ultimately show "False" by (auto simp: noreps_def)
  qed
next
  assume 1: "noreps (xs @ ys)"
  show "noreps ys"
  proof (auto simp: noreps_def)
    fix i
    assume i: "i < length ys - Suc 0" and eq: "ys!i = ys!(Suc i)"
    from i have "i + length xs < length (xs @ ys) - Suc 0" by auto
    moreover
    from i eq have "(xs @ ys)!(i+length xs) = (xs@ys)!(Suc (i + length xs))"
      by (auto simp: nth_append)
    moreover note 1
    ultimately show "False" by (auto simp: noreps_def)
  qed
next
  assume 1: "noreps (xs @ ys)" and 2: "xs \<noteq> []" and 3: "ys \<noteq> []"
     and 4: "List.last xs = hd ys"
  from 2 obtain x xxs where xs: "xs = x # xxs" by (cases xs, auto)
  from 3 obtain y yys where ys: "ys = y # yys" by (cases ys, auto)
  from xs ys have 5: "length xxs < length (xs @ ys) - 1" by auto
  from 4 xs ys have "(xs @ ys) ! (length xxs) = (xs @ ys) ! (Suc (length xxs))"
    by (auto simp: nth_append last_conv_nth)
  with 5 1 show "False" by (auto simp: noreps_def)
next
  assume 1: "noreps xs" and 2: "noreps ys" and 3: "List.last xs \<noteq> hd ys"
  show "noreps (xs @ ys)"
  proof (cases "xs = [] \<or> ys = []")
    case True
    with 1 2 show ?thesis by auto
  next
    case False
    then obtain x xxs where xs: "xs = x # xxs" by (cases xs, auto)
    from False obtain y yys where ys: "ys = y # yys" by (cases ys, auto)
    show ?thesis
    proof (auto simp: noreps_def)
      fix i
      assume i: "i < length xs + length ys - Suc 0"
         and eq: "(xs @ ys)!i = (xs @ ys)!(Suc i)"
      show "False"
      proof (cases "i < length xxs")
        case True
        hence "i < length (x # xxs)" by simp
        hence xsi: "((x # xxs) @ ys)!i = (x # xxs)!i"
          unfolding nth_append by simp
        from True have "(xxs @ ys)!i = xxs!i" by (auto simp: nth_append)
        with True xsi eq 1 xs show "False" by (auto simp: noreps_def)
      next
        assume i2: "\<not>(i < length xxs)"
        show False
        proof (cases "i = length xxs")
          case True
          with xs have xsi: "(xs @ ys)!i = List.last xs"
            by (auto simp: nth_append last_conv_nth)
          from True xs ys have "(xs @ ys)!(Suc i) = y"
            by (auto simp: nth_append)
          with 3 ys eq xsi show False by simp
        next
          case False
          with i2 xs have xsi: "\<not>(i < length xs)" by auto
          hence "(xs @ ys)!i = ys!(i - length xs)"
            by (simp add: nth_append)
          moreover
          from xsi have "Suc i - length xs = Suc (i - length xs)" by auto
          with xsi have "(xs @ ys)!(Suc i) = ys!(Suc (i - length xs))"
            by (simp add: nth_append)
          moreover
          from i xsi have "i - length xs < length ys - 1" by auto
          with 2 have "ys!(i - length xs) \<noteq> ys!(Suc (i - length xs))"
            by (auto simp: noreps_def)
          moreover
          note eq
          ultimately show False by simp
        qed
      qed
    qed
  qed
qed

lemma ISpec_BInv_lemma:
  "\<turnstile> BInit ic q oc \<and> \<box>[Nxt ic q oc]_(ic,q,oc) \<longrightarrow> \<box>(BInv ic q oc)"
proof (rule invmono)
  show "\<turnstile> BInit ic q oc \<longrightarrow> BInv ic q oc"
    by (auto simp: BInit_def BInv_def)
next
  have enq: "|~ Enq ic q oc \<longrightarrow> BInv ic q oc \<longrightarrow> \<circ>(BInv ic q oc)"
    by (auto simp: Enq_def BInv_def tla_defs)
  have deq: "|~ Deq ic q oc \<longrightarrow> BInv ic q oc \<longrightarrow> \<circ>(BInv ic q oc)"
    by (auto simp: Deq_def BInv_def tla_defs neq_Nil_conv)
  have unch: "|~ Unchanged (ic,q,oc) \<longrightarrow> BInv ic q oc \<longrightarrow> \<circ>(BInv ic q oc)"
    by (auto simp: BInv_def tla_defs)
  show "|~ BInv ic q oc \<and> [Nxt ic q oc]_(ic, q, oc) \<longrightarrow> \<circ>(BInv ic q oc)"
    by (auto simp: Nxt_def actrans_def
             elim: enq[unlift_rule] deq[unlift_rule] unch[unlift_rule])
qed

theorem ISpec_BInv: "\<turnstile> ISpec ic q oc \<longrightarrow> \<box>(BInv ic q oc)"
  by (auto simp: ISpec_def intro: ISpec_BInv_lemma[unlift_rule])

subsection "Two FIFO buffers in a row implement a buffer"

locale DBuffer =
  fixes inp :: "'a statefun"       -- {* input channel for double FIFO *}
    and mid :: "'a statefun"       -- {* channel linking the two buffers *}
    and out :: "'a statefun"       -- {* output channel for double FIFO *}
    and q1  :: "'a list statefun"  -- {* inner queue of first FIFO *}
    and q2  :: "'a list statefun"  -- {* inner queue of second FIFO *}
    and vars
  defines "vars \<equiv> LIFT (inp,mid,out,q1,q2)"
  assumes DB_base: "basevars vars"
begin

  text {*
    We need to specify the behavior of two FIFO buffers in a row.
    Intuitively, that specification is just the conjunction of
    two buffer specifications, where the first buffer has input
    channel @{text inp} and output channel @{text mid} whereas
    the second one receives from @{text mid} and outputs on @{text out}.
    However, this conjunction allows a simultaneous enqueue action
    of the first buffer and dequeue of the second one. It would not
    implement the previous buffer specification, which excludes such
    simultaneous enqueueing and dequeueing (it is written in
    ``interleaving style''). We could relax the specification of
    the FIFO buffer above, which is esthetically pleasant, but
    non-interleaving specifications are usually hard to get right
    and to understand. We therefore impose an interleaving constraint
    on the specification of the double buffer, which requires that
    enqueueing and dequeueing do not happen simultaneously.
  *}

  definition DBSpec
  where "DBSpec \<equiv> TEMP ISpec inp q1 mid
                     \<and> ISpec mid q2 out
                     \<and> \<box>[\<not>(Enq inp q1 mid \<and> Deq mid q2 out)]_vars"

  text {*
    The proof rules of TLA are geared towards specifications of the
    form @{text "Init \<and> \<box>[Next]_vars \<and> L"}, and we prove that
    @{text DBSpec} corresponds to a specification in this form,
    which we now define.
  *}

  definition FullInit
  where "FullInit \<equiv> TEMP (BInit inp q1 mid \<and> BInit mid q2 out)"

  definition FullNxt
  where "FullNxt \<equiv> TEMP (Enq inp q1 mid \<and> Unchanged (q2,out)
                       \<or> Deq inp q1 mid \<and> Enq mid q2 out
                       \<or> Deq mid q2 out \<and> Unchanged (inp,q1))"

  definition FullSpec
  where "FullSpec \<equiv> TEMP FullInit
                       \<and> \<box>[FullNxt]_vars
                       \<and> WF(Deq inp q1 mid)_vars
                       \<and> WF(Deq mid q2 out)_vars"

  text {*
    The concatenation of the two queues will serve as the refinement mapping.
  *}
  definition qc :: "'a list statefun"
  where "qc \<equiv> LIFT (q2 @ q1)"

  lemmas db_defs = buffer_defs DBSpec_def FullInit_def FullNxt_def FullSpec_def
                   qc_def vars_def

  lemma DBSpec_stutinv: "STUTINV DBSpec"
    unfolding db_defs by (simp add: bothstutinvs livestutinv)

  lemma FullSpec_stutinv: "STUTINV FullSpec"
    unfolding db_defs by (simp add: bothstutinvs livestutinv)

  text {*
    We prove that @{text DBSpec} implies @{text FullSpec}. (The converse
    implication also holds but is not needed for our implementation proof.)
  *}

  text {*
    The following lemma is somewhat more bureaucratic than we'd like
    it to be. It shows that the conjunction of the next-state relations,
    together with the invariant for the first queue, implies the full
    next-state relation of the combined queues.
  *}
  lemma DBNxt_then_FullNxt:
    "\<turnstile> \<box>BInv inp q1 mid
        \<and> \<box>[Nxt inp q1 mid]_(inp,q1,mid)
        \<and> \<box>[Nxt mid q2 out]_(mid,q2,out)
        \<and> \<box>[\<not>(Enq inp q1 mid \<and> Deq mid q2 out)]_vars
        \<longrightarrow> \<box>[FullNxt]_vars"
    (is "\<turnstile> \<box>?inv \<and> ?nxts \<longrightarrow> \<box>[FullNxt]_vars")
  proof -
    have "\<turnstile> \<box>[Nxt inp q1 mid]_(inp,q1,mid)
          \<and> \<box>[Nxt mid q2 out]_(mid,q2,out)
          \<longrightarrow> \<box>[  [Nxt inp q1 mid]_(inp,q1,mid)
               \<and> [Nxt mid q2 out]_(mid,q2,out)]_((inp,q1,mid),(mid,q2,out))"
      (is "\<turnstile> ?tmp \<longrightarrow> \<box>[?b1b2]_?vs")
      by (auto simp: M12[int_rewrite])
    moreover
    have "\<turnstile> \<box>[?b1b2]_?vs \<longrightarrow> \<box>[?b1b2]_vars"
      by (rule R1, auto simp: vars_def tla_defs)
    ultimately
    have 1: "\<turnstile> \<box>[Nxt inp q1 mid]_(inp,q1,mid)
             \<and> \<box>[Nxt mid q2 out]_(mid,q2,out)
             \<longrightarrow> \<box>[  [Nxt inp q1 mid]_(inp,q1,mid)
                   \<and> [Nxt mid q2 out]_(mid,q2,out) ]_vars"
      by force
    have 2: "\<turnstile> \<box>[?b1b2]_vars \<and> \<box>[\<not>(Enq inp q1 mid \<and> Deq mid q2 out)]_vars
               \<longrightarrow> \<box>[?b1b2 \<and> \<not>(Enq inp q1 mid \<and> Deq mid q2 out)]_vars"
      (is "\<turnstile> ?tmp2 \<longrightarrow> \<box>[?mid]_vars")
      by (simp add: M8[int_rewrite])
    have "\<turnstile> ?inv \<longrightarrow> #True" by auto
    moreover
    have "|~ ?inv \<and> \<circ>?inv \<and> [?mid]_vars \<longrightarrow> [FullNxt]_vars"
    proof -
      have "|~ ?inv \<and> ?mid \<longrightarrow> [FullNxt]_vars"
      proof -
        have A: "|~ Nxt inp q1 mid
                    \<longrightarrow> [Nxt mid q2 out]_(mid,q2,out)
                    \<longrightarrow> \<not>(Enq inp q1 mid \<and> Deq mid q2 out)
                    \<longrightarrow> ?inv
                    \<longrightarrow> FullNxt"
        proof -
          have enq: "|~ Enq inp q1 mid
                        \<and> [Nxt mid q2 out]_(mid,q2,out)
                        \<and> \<not>(Deq mid q2 out)
                        \<longrightarrow> Unchanged (q2,out)"
            by (auto simp: db_defs tla_defs)
          have deq1: "|~ Deq inp q1 mid \<longrightarrow> ?inv \<longrightarrow> mid$ \<noteq> $mid"
            by (auto simp: Deq_def BInv_def)
          have deq2: "|~ Deq mid q2 out \<longrightarrow> mid$ = $mid"
            by (auto simp: Deq_def)
          have deq: "|~ Deq inp q1 mid
                        \<and> [Nxt mid q2 out]_(mid,q2,out)
                        \<and> ?inv
                        \<longrightarrow> Enq mid q2 out"
            by (force simp: Nxt_def tla_defs
                      dest: deq1[unlift_rule] deq2[unlift_rule])
          with enq show ?thesis by (force simp: Nxt_def FullNxt_def)
        qed
        have B: "|~ Nxt mid q2 out
                    \<longrightarrow> Unchanged (inp,q1,mid)
                    \<longrightarrow> FullNxt"
          by (auto simp: db_defs tla_defs)
        have C: "\<turnstile> Unchanged (inp,q1,mid)
                \<longrightarrow> Unchanged (mid,q2,out)
                \<longrightarrow> Unchanged vars"
          by (auto simp: vars_def tla_defs)
        show ?thesis
          by (force simp: actrans_def
                    dest: A[unlift_rule] B[unlift_rule] C[unlift_rule])
      qed
      thus ?thesis by (auto simp: tla_defs)
    qed
    ultimately
    have "\<turnstile> \<box>?inv \<and> \<box>[?mid]_vars \<longrightarrow> \<box>#True \<and> \<box>[FullNxt]_vars"
      by (rule TLA2)
    with 1 2 show ?thesis by force
  qed

  text {*
    It is now easy to show that @{text DBSpec} refines @{text FullSpec}.
  *}
  theorem DBSpec_impl_FullSpec: "\<turnstile> DBSpec \<longrightarrow> FullSpec"
  proof -
    have 1: "\<turnstile> DBSpec \<longrightarrow> FullInit"
      by (auto simp: DBSpec_def FullInit_def ISpec_def)
    have 2: "\<turnstile> DBSpec \<longrightarrow> \<box>[FullNxt]_vars"
    proof -
      have "\<turnstile> DBSpec \<longrightarrow> \<box>(BInv inp q1 mid)"
        by (auto simp: DBSpec_def intro: ISpec_BInv[unlift_rule])
      moreover have "\<turnstile> DBSpec \<and> \<box>(BInv inp q1 mid) \<longrightarrow> \<box>[FullNxt]_vars"
        by (auto simp: DBSpec_def ISpec_def
                 intro: DBNxt_then_FullNxt[unlift_rule])
      ultimately show ?thesis by force
    qed
    have 3: "\<turnstile> DBSpec \<longrightarrow> WF(Deq inp q1 mid)_vars"
    proof -
      have 31: "\<turnstile> Unchanged vars \<longrightarrow> Unchanged q1"
        by (auto simp: vars_def tla_defs)
      have 32: "\<turnstile> Unchanged (inp,q1,mid) \<longrightarrow> Unchanged q1"
        by (auto simp: tla_defs)
      have deq: "|~ \<langle>Deq inp q1 mid\<rangle>_vars = \<langle>Deq inp q1 mid\<rangle>_(inp,q1,mid)"
        by (simp add: Deq_visible[OF 31, int_rewrite]
                      Deq_visible[OF 32, int_rewrite])
      show ?thesis
        by (auto simp: DBSpec_def ISpec_def WeakF_def
                       deq[int_rewrite] deq[THEN AA26,int_rewrite])
    qed
    have 4: "\<turnstile> DBSpec \<longrightarrow> WF(Deq mid q2 out)_vars"
    proof -
      have 41: "\<turnstile> Unchanged vars \<longrightarrow> Unchanged q2"
        by (auto simp: vars_def tla_defs)
      have 42: "\<turnstile> Unchanged (mid,q2,out) \<longrightarrow> Unchanged q2"
        by (auto simp: tla_defs)
      have deq: "|~ \<langle>Deq mid q2 out\<rangle>_vars = \<langle>Deq mid q2 out\<rangle>_(mid,q2,out)"
        by (simp add: Deq_visible[OF 41, int_rewrite]
                      Deq_visible[OF 42, int_rewrite])
      show ?thesis
        by (auto simp: DBSpec_def ISpec_def WeakF_def
                       deq[int_rewrite] deq[THEN AA26,int_rewrite])
    qed
    show ?thesis
      by (auto simp: FullSpec_def
               elim: 1[unlift_rule] 2[unlift_rule] 3[unlift_rule]
                     4[unlift_rule])
  qed

  text {*
    We now prove that two FIFO buffers in a row (as specified by formula
    @{text FullSpec}) implement a FIFO buffer whose internal queue is the
    concatenation of the two buffers. We start by proving step simulation.
  *}

  lemma FullInit: "\<turnstile> FullInit \<longrightarrow> BInit inp qc out"
    by (auto simp: db_defs tla_defs)

  lemma Full_step_simulation:
    "|~ [FullNxt]_vars \<longrightarrow> [Nxt inp qc out]_(inp,qc,out)"
    by (auto simp: db_defs tla_defs)

  text {*
    The liveness condition requires that the combined buffer
    eventually performs a @{text Deq} action on the output channel
    if it contains some element. The idea is to use the
    fairness hypothesis for the first buffer to prove that in that
    case, eventually the queue of the second buffer will be
    non-empty, and that it must therefore eventually dequeue
    some element.

    The first step is to establish the enabledness conditions
    for the two @{text Deq} actions of the implementation.
  *}

  lemma Deq1_enabled: "\<turnstile> Enabled \<langle>Deq inp q1 mid\<rangle>_vars = ($q1 \<noteq> #[])"
  proof -
    have 1: "|~ \<langle>Deq inp q1 mid\<rangle>_vars = Deq inp q1 mid"
      by (rule Deq_visible, auto simp: vars_def tla_defs)
    have "\<turnstile> Enabled (Deq inp q1 mid) = ($q1 \<noteq> #[])"
      by (force simp: Deq_def tla_defs vars_def
                intro: base_enabled[OF DB_base] elim!: enabledE)
    thus ?thesis by (simp add: 1[int_rewrite])
  qed

  lemma Deq2_enabled: "\<turnstile> Enabled \<langle>Deq mid q2 out\<rangle>_vars = ($q2 \<noteq> #[])"
  proof -
    have 1: "|~ \<langle>Deq mid q2 out\<rangle>_vars = Deq mid q2 out"
      by (rule Deq_visible, auto simp: vars_def tla_defs)
    have "\<turnstile> Enabled (Deq mid q2 out) = ($q2 \<noteq> #[])"
      by (force simp: Deq_def tla_defs vars_def
                intro: base_enabled[OF DB_base] elim!: enabledE)
    thus ?thesis by (simp add: 1[int_rewrite])
  qed

  text {*
    We now use rule @{text WF2} to prove that the combined buffer
    (behaving according to specification @{text FullSpec})
    implements the fairness condition of the single buffer under
    the refinement mapping.
  *}
  lemma Full_fairness:
    "\<turnstile> \<box>[FullNxt]_vars \<and> WF(Deq mid q2 out)_vars \<and> \<box>WF(Deq inp q1 mid)_vars
       \<longrightarrow> WF(Deq inp qc out)_(inp,qc,out)"
  proof (rule WF2)
    -- {* the helpful action is the @{text Deq} action of the second queue *}
    show "|~ \<langle>FullNxt \<and> Deq mid q2 out\<rangle>_vars \<longrightarrow> \<langle>Deq inp qc out\<rangle>_(inp,qc,out)"
      by (auto simp: db_defs tla_defs)
  next
    -- {* the helpful condition is the second queue being non-empty *}
    show "|~ ($q2 \<noteq> #[]) \<and> \<circ>($q2 \<noteq> #[]) \<and> \<langle>FullNxt \<and> Deq mid q2 out\<rangle>_vars
             \<longrightarrow> Deq mid q2 out"
      by (auto simp: tla_defs)
  next
    show "\<turnstile> $q2 \<noteq> #[] \<and> Enabled \<langle>Deq inp qc out\<rangle>_(inp, qc, out)
             \<longrightarrow> Enabled \<langle>Deq mid q2 out\<rangle>_vars"
      unfolding Deq2_enabled[int_rewrite] by auto
  next
    txt {*
      The difficult part of the proof is to show that the helpful
      condition will eventually always be true provided that the
      combined dequeue action is eventually always enabled and that
      the helpful action is never executed. We prove that (1) the
      helpful condition persists and (2) that it must eventually
      become true.
    *}
    have "\<turnstile> \<box>\<box>[FullNxt \<and> \<not>(Deq mid q2 out)]_vars
            \<longrightarrow> \<box>($q2 \<noteq> #[] \<longrightarrow> \<box>($q2 \<noteq> #[]))"
    proof (rule STL4)
      have "|~ $q2 \<noteq> #[] \<and> [FullNxt \<and> \<not>(Deq mid q2 out)]_vars
               \<longrightarrow> \<circ>($q2 \<noteq> #[])"
        by (auto simp: db_defs tla_defs)
      from this[THEN INV1]
      show "\<turnstile> \<box>[FullNxt \<and> \<not> Deq mid q2 out]_vars
              \<longrightarrow> ($q2 \<noteq> #[] \<longrightarrow> \<box>($q2 \<noteq> #[]))"
        by auto
    qed
    hence 1: "\<turnstile> \<box>[FullNxt \<and> \<not>(Deq mid q2 out)]_vars
                \<longrightarrow> \<diamond>($q2 \<noteq> #[]) \<longrightarrow> \<diamond>\<box>($q2 \<noteq> #[])"
      by (force intro: E31[unlift_rule])
    have 2: "\<turnstile> \<box>[FullNxt \<and> \<not>(Deq mid q2 out)]_vars
               \<and> WF(Deq inp q1 mid)_vars
               \<longrightarrow> (Enabled \<langle>Deq inp qc out\<rangle>_(inp, qc, out) \<leadsto> $q2 \<noteq> #[])"
    proof -
      have qc: "\<turnstile> ($qc \<noteq> #[]) = ($q1 \<noteq> #[] \<or> $q2 \<noteq> #[])"
        by (auto simp: qc_def tla_defs)
      have "\<turnstile> \<box>[FullNxt \<and> \<not>(Deq mid q2 out)]_vars \<and> WF(Deq inp q1 mid)_vars
              \<longrightarrow> ($q1 \<noteq> #[] \<leadsto> $q2 \<noteq> #[])"
      proof (rule WF1)
        show "|~ $q1 \<noteq> #[] \<and> [FullNxt \<and> \<not> Deq mid q2 out]_vars
                 \<longrightarrow> \<circ>($q1 \<noteq> #[]) \<or> \<circ>($q2 \<noteq> #[])"
          by (auto simp: db_defs tla_defs)
      next
        show "|~ $q1 \<noteq> #[]
                 \<and> \<langle>(FullNxt \<and> \<not> Deq mid q2 out) \<and> Deq inp q1 mid\<rangle>_vars \<longrightarrow>
                 \<circ>($q2 \<noteq> #[])"
          by (auto simp: db_defs tla_defs)
      next
        show "\<turnstile> $q1 \<noteq> #[] \<longrightarrow> Enabled \<langle>Deq inp q1 mid\<rangle>_vars"
          by (simp add: Deq1_enabled[int_rewrite])
      next
        show "|~ $q1 \<noteq> #[] \<and> Unchanged vars \<longrightarrow> \<circ>($q1 \<noteq> #[])"
          by (auto simp: vars_def tla_defs)
      qed
      hence "\<turnstile> \<box>[FullNxt \<and> \<not>(Deq mid q2 out)]_vars
                  \<and> WF(Deq inp q1 mid)_vars
                  \<longrightarrow> ($qc \<noteq> #[] \<leadsto> $q2 \<noteq> #[])"
        by (auto simp: qc[int_rewrite] LT17[int_rewrite] LT1[int_rewrite])
      moreover
      have "\<turnstile> Enabled \<langle>Deq inp qc out\<rangle>_(inp, qc, out) \<leadsto> $qc \<noteq> #[]"
        by (rule Deq_enabledE[THEN LT3])
      ultimately show ?thesis by (force elim: LT13[unlift_rule])
    qed
    with LT6
    have "\<turnstile> \<box>[FullNxt \<and> \<not>(Deq mid q2 out)]_vars
             \<and> WF(Deq inp q1 mid)_vars
             \<and> \<diamond>Enabled \<langle>Deq inp qc out\<rangle>_(inp, qc, out)
             \<longrightarrow> \<diamond>($q2 \<noteq> #[])"
      by force
    with 1 E16
    show "\<turnstile> \<box>[FullNxt \<and> \<not>(Deq mid q2 out)]_vars
            \<and> WF(Deq mid q2 out)_vars
            \<and> \<box>WF(Deq inp q1 mid)_vars
            \<and> \<diamond>\<box> Enabled \<langle>Deq inp qc out\<rangle>_(inp, qc, out)
            \<longrightarrow> \<diamond>\<box>($q2 \<noteq> #[])"
      by force
  qed

  text {*
    Putting everything together, we obtain that @{text FullSpec} refines
    the Buffer specification under the refinement mapping.
  *}
  theorem FullSpec_impl_ISpec: "\<turnstile> FullSpec \<longrightarrow> ISpec inp qc out"
    unfolding FullSpec_def ISpec_def
    using FullInit Full_step_simulation[THEN M11] Full_fairness
    by force

  theorem FullSpec_impl_Spec: "\<turnstile> FullSpec \<longrightarrow> Spec inp out"
    unfolding Spec_def using FullSpec_impl_ISpec
    by (force intro: eexI[unlift_rule])

  text {*
    By transitivity, two buffers in a row also implement a single buffer.
  *}
  theorem DBSpec_impl_Spec: "\<turnstile> DBSpec \<longrightarrow> Spec inp out"
    by (rule lift_imp_trans[OF DBSpec_impl_FullSpec FullSpec_impl_Spec])

end -- {* locale DBuffer *}

end


(* Author: Dmitriy Traytel *)

header "Some Useful Regular Operators"

(*<*)
theory Pi_Regular_Operators
imports Pi_Derivatives "~~/src/HOL/Library/While_Combinator"
begin
(*>*)

primrec REV :: "'a rexp \<Rightarrow> 'a rexp" where
  "REV Zero = Zero"
| "REV Full = Full"
| "REV One = One"
| "REV (Atom a) = Atom a"
| "REV (Plus r s) = Plus (REV r) (REV s)"
| "REV (Times r s) = Times (REV s) (REV r)"
| "REV (Star r) = Star (REV r)"
| "REV (Not r) = Not (REV r)"
| "REV (Inter r s) = Inter (REV r) (REV s)"
| "REV (Pr r) = Pr (REV r)"

lemma REV_REV[simp]: "REV (REV r) = r"
  by (induct r) auto

lemma final_REV[simp]: "final (REV r) = final r"
  by (induct r) auto

lemma REV_PLUS: "REV (PLUS xs) = PLUS (map REV xs)"
  by (induct xs rule: list_singleton_induct) auto

lemma (in alphabet) wf_REV[simp]: "wf n r \<Longrightarrow> wf n (REV r)"
  by (induct r arbitrary: n) auto

lemma (in project) lang_REV[simp]: "lang n (REV r) = rev ` lang n r"
  by (induct r arbitrary: n) (auto simp: image_image rev_map image_set_diff)

context embed
begin

primrec rderiv :: "'a \<Rightarrow> 'b rexp \<Rightarrow> 'b rexp" where
  "rderiv _ Zero = Zero"
| "rderiv _ Full = Full"
| "rderiv _ One = Zero"
| "rderiv a (Atom b) = (if lookup b a then One else Zero)"
| "rderiv a (Plus r s) = Plus (rderiv a r) (rderiv a s)"
| "rderiv a (Times r s) =
    (let rs' = Times r (rderiv a s)
     in if final s then Plus rs' (rderiv a r) else rs')"
| "rderiv a (Star r) = Times (Star r) (rderiv a r)"
| "rderiv a (Not r) = Not (rderiv a r)"
| "rderiv a (Inter r s) = Inter (rderiv a r) (rderiv a s)"
| "rderiv a (Pr r) = Pr (PLUS (map (\<lambda>a'. rderiv a' r) (embed a)))"

primrec rderivs where
  "rderivs [] r = r"
| "rderivs (w#ws) r = rderivs ws (rderiv w r)"

lemma rderivs_snoc: "rderivs (ws @ [w]) r = rderiv w (rderivs ws r)"
  by (induct ws arbitrary: r) auto

lemma rderivs_append: "rderivs (ws @ ws') r = rderivs ws' (rderivs ws r)"
  by (induct ws arbitrary: r) auto

lemma rderiv_lderiv: "rderiv as r = REV (lderiv as (REV r))"
  by (induct r arbitrary: as) (auto simp: Let_def o_def REV_PLUS)

lemma wf_rderiv[simp]: "wf n r \<Longrightarrow> wf n (rderiv w r)"
  unfolding rderiv_lderiv by (rule wf_REV[OF wf_lderiv[OF wf_REV]])

lemma wf_rderivs[simp]: "wf n r \<Longrightarrow> wf n (rderivs ws r)"
  unfolding rderivs_lderivs by (rule wf_REV[OF wf_lderivs[OF wf_REV]])

lemma lang_rderivs: "\<lbrakk>wf n r; wf_word n w\<rbrakk> \<Longrightarrow> lang n (rderivs w r) = rQuots w (lang n r)"
  unfolding rderivs_lderivs rQuots_rev_lQuots by (simp add: lang_lderivs)

corollary rderivs_final:
assumes "wf n r" "wf_word n w"
shows "final (rderivs w r) \<longleftrightarrow> rev w \<in> lang n r"
  using lang_rderivs[OF assms] lang_final[of "rderivs w r" n] by auto

lemma toplevel_summands_REV[simp]: "toplevel_summands (REV r) = REV ` toplevel_summands r"
  by (induct r) auto

lemma ACI_norm_REV: "\<guillemotleft>REV \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>REV r\<guillemotright>"
proof (induct r)
  case (Plus r s)
  show ?case
    unfolding REV.simps ACI_norm.simps Plus[symmetric] image_Un[symmetric]
      toplevel_summands.simps(1) toplevel_summands_ACI_norm toplevel_summands_REV
    unfolding toplevel_summands.simps(1)[symmetric] ACI_norm_flatten toplevel_summands_REV
    unfolding ACI_norm_flatten[symmetric] toplevel_summands_ACI_norm
    ..
qed auto

lemma ACI_norm_rderiv: "\<guillemotleft>rderiv as \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>rderiv as r\<guillemotright>"
  unfolding rderiv_lderiv by (metis ACI_norm_REV ACI_norm_lderiv)

lemma ACI_norm_rderivs: "\<guillemotleft>rderivs w \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>rderivs w r\<guillemotright>"
  unfolding rderivs_lderivs by (metis ACI_norm_REV ACI_norm_lderivs)

theorem finite_rderivs: "finite {\<guillemotleft>rderivs xs r\<guillemotright> | xs . True}"
  unfolding rderivs_lderivs
  by (subst ACI_norm_REV[symmetric]) (auto intro: finite_surj[OF finite_lderivs, of _ "\<lambda>r. \<guillemotleft>REV r\<guillemotright>"])

lemma lderiv_PLUS[simp]: "lderiv a (PLUS xs) = PLUS (map (lderiv a) xs)"
  by (induct xs rule: list_singleton_induct) auto

lemma rderiv_PLUS[simp]: "rderiv a (PLUS xs) = PLUS (map (rderiv a) xs)"
  by (induct xs rule: list_singleton_induct) auto

lemma lang_rderiv_lderiv: "lang n (rderiv a (lderiv b r)) = lang n (lderiv b (rderiv a r))"
  by (induct r arbitrary: n a b) (auto simp: Let_def conc_assoc)

lemma lang_lderiv_rderiv: "lang n (lderiv a (rderiv b r)) = lang n (rderiv b (lderiv a r))"
  by (induct r arbitrary: n a b) (auto simp: Let_def conc_assoc)

lemma lang_rderiv_lderivs[simp]: "\<lbrakk>wf n r; wf_word n w; a \<in> \<Sigma> n\<rbrakk> \<Longrightarrow>
  lang n (rderiv a (lderivs w r)) = lang n (lderivs w (rderiv a r))"
  by (induct w arbitrary: n r)
    (auto, auto simp: lang_lderivs lang_lderiv lang_rderiv lQuot_rQuot)

lemma lang_lderiv_rderivs[simp]: "\<lbrakk>wf n r; wf_word n w; a \<in> \<Sigma> n\<rbrakk> \<Longrightarrow>
  lang n (lderiv a (rderivs w r)) = lang n (rderivs w (lderiv a r))"
  by (induct w arbitrary: n r)
    (auto, auto simp: lang_rderivs lang_lderiv lang_rderiv lQuot_rQuot)
(*
primrec bideriv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp" where
  "bideriv _ _ Zero = Zero"
| "bideriv _ _ One = Zero"
| "bideriv a b (Atom c) = Zero"
| "bideriv a b (Plus r s) = Plus (bideriv a b r) (bideriv a b s)"
| "bideriv a b (Times r s) =
    (let rs' = Times (lderiv a r) (rderiv b s)
     in if final r \<and> final s then Plus (Plus rs' (bideriv a b r)) (bideriv a b s)
        else if final r then Plus rs' (bideriv a b s)
        else if final s then Plus rs' (bideriv a b r)
        else rs')"
| "bideriv a b (Star r) = Plus (bideriv a b r) (TIMES [lderiv a r, Star r, rderiv b r])"
| "bideriv a b (Not r) = Not (bideriv a b r)"
| "bideriv a b (Inter r s) = Inter (bideriv a b r) (bideriv a b s)"
| "bideriv a b (Pr r) = Pr (PLUS (map (\<lambda>b. PLUS (map (\<lambda>a. bideriv a b r) (embed a))) (embed b)))"

lemma wf_bideriv[simp]: "wf n r \<Longrightarrow> wf n (bideriv a b r)"
  by (induct r arbitrary: n a b) (auto simp: maps_def Let_def)

lemma ACI_norm_bideriv_rderiv_lderiv: "\<guillemotleft>bideriv a b r\<guillemotright> = \<guillemotleft>rderiv b (lderiv a r)\<guillemotright>"
  by (induct r arbitrary: a b)
    (auto simp: Let_def maps_def o_def list_all2_map1 list_all2_map2 intro!: ACI_PLUS list_all2_refl)

lemma bideriv_rderiv_lderiv:
  "lang n (bideriv a b r) = lang n (rderiv b (lderiv a r))"
  by (induct r arbitrary: n a b) (auto simp: Let_def)

lemma lang_bideriv:
  "\<lbrakk>wf n r; a \<in> \<Sigma> n; b \<in> \<Sigma> n\<rbrakk> \<Longrightarrow> lang n (bideriv a b r) = biQuot a b (lang n r)"
  by (auto simp: bideriv_rderiv_lderiv lang_lderiv lang_rderiv biQuot_rQuot_lQuot)

lemma ACI_norm_bideriv: "\<guillemotleft>bideriv a b \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>bideriv a b r\<guillemotright>"
  unfolding ACI_norm_bideriv_rderiv_lderiv by (metis ACI_norm_lderiv ACI_norm_rderiv)

fun biderivs where
  "biderivs [] [] r = r"
| "biderivs as [] r = lderivs as r"
| "biderivs [] bs r = rderivs bs r"
| "biderivs (a#as) (b#bs) r = biderivs as bs (bideriv a b r)"

lemma biderivs_rderivs_lderivs: "\<lbrakk>wf n r; wf_word n w1; wf_word n w2\<rbrakk> \<Longrightarrow>
  lang n (biderivs w1 w2 r) = lang n (rderivs w2 (lderivs w1 r))"
  by (induct arbitrary: r rule: biderivs.induct)
    (auto simp: lang_rderivs lang_lderivs bideriv_rderiv_lderiv)

lemma lang_biderivs:
  "\<lbrakk>wf n r; wf_word n w1; wf_word n w2\<rbrakk> \<Longrightarrow> lang n (biderivs w1 w2 r) = biQuots w1 w2 (lang n r)"
  by (auto simp: biderivs_rderivs_lderivs lang_lderivs lang_rderivs biQuots_rQuots_lQuots)

lemma wf_biderivs[simp]: "wf n r \<Longrightarrow> wf n (biderivs w1 w2 r)"
  by (induct arbitrary: r rule: biderivs.induct) auto
*)
definition "biderivs w1 w2 = rderivs w2 o lderivs w1"

lemma lang_biderivs: "\<lbrakk>wf n r; wf_word n w1; wf_word n w2\<rbrakk> \<Longrightarrow>
  lang n (biderivs w1 w2 r) = biQuots w1 w2 (lang n r)"
   unfolding biderivs_def by (auto simp: lang_rderivs lang_lderivs in_lists_conv_set)

lemma wf_biderivs[simp]: "wf n r \<Longrightarrow> wf n (biderivs w1 w2 r)"
  unfolding biderivs_def by simp

corollary biderivs_final:
assumes "wf n r" "wf_word n w1" "wf_word n w2"
shows "final (biderivs w1 w2 r) \<longleftrightarrow> w1 @ rev w2 \<in> lang n r"
  using lang_biderivs[OF assms] lang_final[of "biderivs w1 w2 r" n] by auto

lemma ACI_norm_biderivs: "\<guillemotleft>biderivs w1 w2 \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>biderivs w1 w2 r\<guillemotright>"
  unfolding biderivs_def by (metis ACI_norm_lderivs ACI_norm_rderivs o_apply)

lemma "finite {\<guillemotleft>biderivs w1 w2 r\<guillemotright> | w1 w2 . True}"
proof -
  have "{\<guillemotleft>biderivs w1 w2 r\<guillemotright> | w1 w2 . True} =
    (\<Union>s \<in> {\<guillemotleft>lderivs as r\<guillemotright> | as . True}. {\<guillemotleft>rderivs bs s\<guillemotright> | bs . True})"
    unfolding biderivs_def by (fastforce simp: ACI_norm_rderivs)
  also have "finite \<dots>" by (rule iffD2[OF finite_UN[OF finite_lderivs] ballI[OF finite_rderivs]])
  finally show ?thesis .
qed

end

subsection {* Quotioning by the same letter *}

definition "fin_cut_same x xs = take (LEAST n. drop n xs = replicate (length xs - n) x) xs"

lemma fin_cut_same_Nil[simp]: "fin_cut_same x [] = []"
  unfolding fin_cut_same_def by simp

lemma Least_fin_cut_same: "(LEAST n. drop n xs = replicate (length xs - n) y) =
  length xs - length (takeWhile (\<lambda>x. x = y) (rev xs))"
  (is "Least ?P = ?min")
proof (rule Least_equality)
  show "?P ?min" by (induct xs rule: rev_induct) (auto simp:  Suc_diff_le replicate_append_same)
next
  fix m assume "?P m"
  have "length xs - m \<le> length (takeWhile (\<lambda>x. x = y) (rev xs))"
  proof (intro length_takeWhile_less_P_nth)
    fix i assume "i < length xs - m"
    hence "rev xs ! i \<in> set (drop m xs)"
      by (induct xs arbitrary: i rule: rev_induct) (auto simp: nth_Cons')
    with `?P m` show "rev xs ! i = y" by simp
  qed simp
  thus "?min \<le> m" by linarith
qed

lemma takeWhile_takes_all: "length xs = m \<Longrightarrow> m \<le> length (takeWhile P xs) \<longleftrightarrow> Ball (set xs) P"
  by hypsubst_thin (induct xs, auto)

lemma fin_cut_same_Cons[simp]: "fin_cut_same x (y # xs) =
  (if fin_cut_same x xs = [] then if x = y then [] else [y] else y # fin_cut_same x xs)"
  unfolding fin_cut_same_def Least_fin_cut_same
  apply auto
  apply (simp add: takeWhile_takes_all)
  apply (simp add: takeWhile_takes_all)
  apply auto
  apply (metis (full_types) Suc_diff_le length_rev length_takeWhile_le take_Suc_Cons)
  apply (simp add: takeWhile_takes_all)
  apply (subst takeWhile_append2)
  apply auto
  apply (simp add: takeWhile_takes_all)
  apply auto
  apply (metis (full_types) Suc_diff_le length_rev length_takeWhile_le take_Suc_Cons)
  done

lemma fin_cut_same_singleton[simp]: "fin_cut_same x (xs @ [x]) = fin_cut_same x xs"
  by (induct xs) auto

lemma fin_cut_same_replicate[simp]: "fin_cut_same x (xs @ replicate n x) = fin_cut_same x xs"
  by (induct n arbitrary: xs)
    (auto simp: replicate_append_same[symmetric] append_assoc[symmetric] simp del: append_assoc)

lemma fin_cut_sameE: "fin_cut_same x xs = ys \<Longrightarrow> \<exists>m. xs = ys @ replicate m x"
  by (induct xs arbitrary: ys) (auto, metis replicate_Suc)

definition "SAMEQUOT a A = {fin_cut_same a x @ replicate m a| x m. x \<in> A}"

lemma SAMEQUOT_mono: "A \<subseteq> B \<Longrightarrow> SAMEQUOT a A \<subseteq> SAMEQUOT a B"
  unfolding SAMEQUOT_def by auto

locale embed2 = embed \<Sigma> wf_atom project lookup embed
  for \<Sigma> :: "nat \<Rightarrow> 'a set"
  and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool"
  and project :: "'a \<Rightarrow> 'a"
  and lookup :: "'b \<Rightarrow> 'a \<Rightarrow> bool"
  and embed :: "'a \<Rightarrow> 'a list" +
  fixes singleton :: "'a \<Rightarrow> 'b"
  assumes wf_singleton[simp]: "a \<in> \<Sigma> n \<Longrightarrow> wf_atom n (singleton a)"
  assumes lookup_singleton[simp]: "lookup (singleton a) a' = (a = a')"
begin

lemma finite_rderivs_same: "finite {\<guillemotleft>rderivs (replicate m a) r\<guillemotright> | m . True}"
  by (auto intro: finite_subset[OF _ finite_rderivs])

lemma wf_word_replicate[simp]: "a \<in> \<Sigma> n \<Longrightarrow> wf_word n (replicate m a)"
  by (induct m) auto

lemma star_singleton[simp]: "star {[x]} = {replicate m x | m . True}"
proof (intro equalityI subsetI)
  fix xs assume "xs \<in> star {[x]}"
  thus "xs \<in> {replicate m x | m . True}" by (induct xs) (auto, metis replicate_Suc)
qed (auto intro: Ball_starI)

definition "samequot a r = Times (flatten PLUS {\<guillemotleft>rderivs (replicate m a) r\<guillemotright> | m . True}) (Star (Atom (singleton a)))"

lemma wf_samequot: "\<lbrakk>wf n r; a \<in> \<Sigma> n\<rbrakk> \<Longrightarrow> wf n (samequot a r)"
  unfolding samequot_def wf.simps wf_flatten_PLUS[OF finite_rderivs_same] by auto

lemma lang_samequot: "\<lbrakk>wf n r; a \<in> \<Sigma> n\<rbrakk> \<Longrightarrow>
   lang n (samequot a r) = SAMEQUOT a (lang n r)"
   unfolding SAMEQUOT_def samequot_def lang.simps lang_flatten_PLUS[OF finite_rderivs_same]
   apply (rule sym)
   apply (auto simp: lang_rderivs)
   apply (intro concI)
   apply auto
   apply (insert fin_cut_sameE[OF refl, of _ a])
   apply (drule meta_spec)
   apply (erule exE)
   apply (intro exI conjI)
   apply (rule refl)
   apply (auto simp: lang_rderivs)
   apply (erule subst)
   apply assumption
   apply (erule concE)
   apply (auto simp: lang_rderivs)
   apply (drule meta_spec)
   apply (erule exE)
   apply (intro exI conjI)
   defer
   apply assumption
   unfolding fin_cut_same_replicate
   apply (erule trans)
   unfolding fin_cut_same_replicate
   apply (rule refl)
   done

fun rderiv_and_add where
  "rderiv_and_add as (_ :: bool, rs) =
    (let
      r = \<guillemotleft>rderiv as (hd rs)\<guillemotright>
    in if r \<in> set rs then (False, rs) else (True, r # rs))"

definition "invar_rderiv_and_add as r brs \<equiv>
  (if fst brs then True else \<guillemotleft>rderiv as (hd (snd brs))\<guillemotright> \<in> set (snd brs)) \<and>
  snd brs \<noteq> [] \<and> distinct (snd brs) \<and>
  (\<forall>i < length (snd brs). snd brs ! i = \<guillemotleft>rderivs (replicate (length (snd brs) - 1 - i) as) r\<guillemotright>)"

lemma invar_rderiv_and_add_init: "invar_rderiv_and_add as r (True, [\<guillemotleft>r\<guillemotright>])"
  unfolding invar_rderiv_and_add_def by auto

lemma invar_rderiv_and_add_step: "invar_rderiv_and_add as r brs \<Longrightarrow> fst brs \<Longrightarrow>
  invar_rderiv_and_add as r (rderiv_and_add as brs)"
  unfolding invar_rderiv_and_add_def by (cases brs) (auto simp:
    Let_def nth_Cons' ACI_norm_rderiv rderivs_snoc[symmetric] neq_Nil_conv replicate_append_same)

lemma rderivs_replicate_mult: "\<lbrakk>\<guillemotleft>rderivs (replicate i as) r\<guillemotright> = \<guillemotleft>r\<guillemotright>; i > 0\<rbrakk> \<Longrightarrow>
  \<guillemotleft>rderivs (replicate (m * i) as) r\<guillemotright> = \<guillemotleft>r\<guillemotright>"
proof (induct m arbitrary: r)
  case (Suc m)
  hence "\<guillemotleft>rderivs (replicate (m * i) as) \<guillemotleft>rderivs (replicate i as) r\<guillemotright>\<guillemotright> = \<guillemotleft>r\<guillemotright>"
    by (auto simp: ACI_norm_rderivs)
  thus ?case by (auto simp: ACI_norm_rderivs replicate_add rderivs_append)
qed simp

lemma rderivs_replicate_mult_rest:
  assumes "\<guillemotleft>rderivs (replicate i as) r\<guillemotright> = \<guillemotleft>r\<guillemotright>" "k < i"
  shows "\<guillemotleft>rderivs (replicate (m * i + k) as) r\<guillemotright> = \<guillemotleft>rderivs (replicate k as) r\<guillemotright>" (is "?L = ?R")
proof -
  have "?L = \<guillemotleft>rderivs (replicate k as) \<guillemotleft>rderivs (replicate (m * i) as) r\<guillemotright>\<guillemotright>"
    by (simp add: ACI_norm_rderivs replicate_add rderivs_append)
  also have "\<guillemotleft>rderivs (replicate (m * i) as) r\<guillemotright> = \<guillemotleft>r\<guillemotright>" using assms
    by (simp add: rderivs_replicate_mult)
  finally show ?thesis by (simp add: ACI_norm_rderivs)
qed

lemma rderivs_replicate_mod:
  assumes "\<guillemotleft>rderivs (replicate i as) r\<guillemotright> = \<guillemotleft>r\<guillemotright>" "i > 0"
  shows "\<guillemotleft>rderivs (replicate m as) r\<guillemotright> = \<guillemotleft>rderivs (replicate (m mod i) as) r\<guillemotright>" (is "?L = ?R")
  by (subst mod_div_equality[symmetric, of m i])
    (intro rderivs_replicate_mult_rest[OF assms(1)] mod_less_divisor[OF assms(2)])

lemma rderivs_replicate_diff: "\<lbrakk>\<guillemotleft>rderivs (replicate i as) r\<guillemotright> = \<guillemotleft>rderivs (replicate j as) r\<guillemotright>; i > j\<rbrakk> \<Longrightarrow>
  \<guillemotleft>rderivs (replicate (i - j) as) (rderivs (replicate j as) r)\<guillemotright> = \<guillemotleft>rderivs (replicate j as) r\<guillemotright>"
  unfolding rderivs_append[symmetric] replicate_add[symmetric] by auto

lemma samequot_wf:
  assumes "wf n r" "while_option fst (rderiv_and_add as) (True, [\<guillemotleft>r\<guillemotright>]) = Some (b, rs)"
  shows "wf n (PLUS rs)"
proof -
  have "\<not> b" using while_option_stop[OF assms(2)] by simp
  from while_option_rule[where P="invar_rderiv_and_add as r",
    OF invar_rderiv_and_add_step assms(2) invar_rderiv_and_add_init]
    have *: "invar_rderiv_and_add as r (b, rs)" by simp
  thus "wf n (PLUS rs)" unfolding invar_rderiv_and_add_def wf_PLUS
    by (auto simp: in_set_conv_nth wf_rderivs[OF assms(1)])
qed

lemma samequot_soundness:
  assumes "while_option fst (rderiv_and_add as) (True, [\<guillemotleft>r\<guillemotright>]) = Some (b, rs)"
  shows "lang n (PLUS rs) = UNION {\<guillemotleft>rderivs (replicate m as) r\<guillemotright> |m. True} (lang n)"
proof -
  have "\<not> b" using while_option_stop[OF assms] by simp
  moreover
  from while_option_rule[where P="invar_rderiv_and_add as r",
    OF invar_rderiv_and_add_step assms invar_rderiv_and_add_init]
    have *: "invar_rderiv_and_add as r (b, rs)" by simp
  ultimately obtain i where i: "i < length rs" and "\<guillemotleft>rderivs (replicate (length rs - Suc i) as) r\<guillemotright> =
       \<guillemotleft>rderivs (replicate (Suc (length rs - Suc 0)) as) r\<guillemotright>" (is "\<guillemotleft>rderivs ?x r\<guillemotright> = _")
    unfolding invar_rderiv_and_add_def by (auto simp: in_set_conv_nth hd_conv_nth ACI_norm_rderiv
      rderivs_snoc[symmetric] replicate_append_same)
  with * have "\<guillemotleft>rderivs ?x r\<guillemotright> = \<guillemotleft>rderivs (replicate (length rs) as) r\<guillemotright>"
    by (auto simp: invar_rderiv_and_add_def)
  with i have cyc: "\<guillemotleft>rderivs (replicate (Suc i) as) (rderivs ?x r)\<guillemotright> = \<guillemotleft>rderivs ?x r\<guillemotright>"
    by (fastforce dest: rderivs_replicate_diff[OF sym])
  { fix m
    have "\<exists>i<length rs. rs ! i = \<guillemotleft>rderivs (replicate m as) r\<guillemotright>"
    proof (cases "m > length rs - Suc i")
      case True
      with i obtain m' where m: "m = m' + length rs - Suc i"
        by atomize_elim (auto intro: exI[of _ "m - (length rs - Suc i)"])
      with i have "\<guillemotleft>rderivs (replicate m as) r\<guillemotright> = \<guillemotleft>rderivs (replicate m' as) (rderivs ?x r)\<guillemotright>"
       unfolding replicate_add[symmetric] rderivs_append[symmetric] by (simp add: add.commute)
      also from cyc have "\<dots> = \<guillemotleft>rderivs (replicate (m' mod (Suc i)) as) (rderivs ?x r)\<guillemotright>"
        by (elim rderivs_replicate_mod) simp
      also from i have "\<dots> = \<guillemotleft>rderivs (replicate (m' mod (Suc i) + length rs - Suc i) as) r\<guillemotright>"
        unfolding rderivs_append[symmetric] replicate_add[symmetric] by (simp add: add.commute)
      also from m i have "\<dots> = \<guillemotleft>rderivs (replicate ((m - (length rs - Suc i)) mod (Suc i) + length rs - Suc i) as) r\<guillemotright>"
        by simp
      also have "\<dots> = \<guillemotleft>rderivs (replicate (length rs - Suc (i - (m - (length rs - Suc i)) mod (Suc i))) as) r\<guillemotright>"
        by (subst Suc_diff_le[symmetric])
          (metis less_Suc_eq_le mod_less_divisor zero_less_Suc, simp add: add.commute)
      finally have "\<exists>j < length rs. \<guillemotleft>rderivs (replicate m as) r\<guillemotright> = \<guillemotleft>rderivs (replicate (length rs - Suc j) as) r\<guillemotright>"
        using i by (metis less_imp_diff_less)
      with * show ?thesis unfolding invar_rderiv_and_add_def by auto
    next
      case False
      with i have "\<exists>j < length rs. m = length rs - Suc j"
        by (induct m)
          (metis diff_self_eq_0 gr_implies_not0 lessI nat.exhaust,
           metis (no_types) One_nat_def Suc_diff_Suc diff_Suc_1 gr0_conv_Suc less_imp_diff_less
             not_less_eq not_less_iff_gr_or_eq)
      with * show ?thesis unfolding invar_rderiv_and_add_def by auto
    qed
  }
  hence "UNION {\<guillemotleft>rderivs (replicate m as) r\<guillemotright> |m. True} (lang n) \<subseteq> lang n (PLUS rs)"
    by (fastforce simp: in_set_conv_nth intro!: bexI[rotated])
  moreover from * have "lang n (PLUS rs) \<subseteq> UNION {\<guillemotleft>rderivs (replicate m as) r\<guillemotright> |m. True} (lang n)"
    unfolding invar_rderiv_and_add_def by (fastforce simp: in_set_conv_nth)
  ultimately show "lang n (PLUS rs) = UNION {\<guillemotleft>rderivs (replicate m as) r\<guillemotright> |m. True} (lang n)" by blast
qed

lemma length_subset_card: "\<lbrakk>finite X; distinct (x # xs); set (x # xs) \<subseteq> X\<rbrakk> \<Longrightarrow> length xs < card X"
  by (metis card_mono distinct_card impossible_Cons not_leE order_trans)

lemma samequot_termination:
  assumes "while_option fst (rderiv_and_add as) (True, [\<guillemotleft>r\<guillemotright>]) = None" (is "?cl = None")
  shows "False"
proof -
  let ?D =  "{\<guillemotleft>rderivs (replicate m as) r\<guillemotright> | m . True}"
  let ?f = "\<lambda>(b, rs). card ?D + 1 - length rs + (if b then 1 else 0)"
  have "\<exists>st. ?cl = Some st"
    apply (rule measure_while_option_Some[of "invar_rderiv_and_add as r" _ _ ?f])
     apply (auto simp: invar_rderiv_and_add_init invar_rderiv_and_add_step)
    apply (auto simp: invar_rderiv_and_add_def Let_def neq_Nil_conv in_set_conv_nth
       intro!: diff_less_mono2 length_subset_card[OF finite_rderivs_same, simplified])
      apply auto []
     apply fastforce
    apply (metis Suc_less_eq nth_Cons_Suc)
    done
  with assms show False by auto
qed

definition "samequot_exec a r =
  Times (PLUS (snd (the (while_option fst (rderiv_and_add a) (True, [\<guillemotleft>r\<guillemotright>]))))) (Star (Atom (singleton a)))"

lemma wf_samequot_exec: "\<lbrakk>wf n r; as \<in> \<Sigma> n\<rbrakk> \<Longrightarrow> wf n (samequot_exec as r)"
  unfolding samequot_exec_def
  by (cases "while_option fst (rderiv_and_add as) (True, [\<guillemotleft>r\<guillemotright>])")
    (auto dest: samequot_termination samequot_wf)

lemma samequot_exec_samequot: "lang n (samequot_exec as r) = lang n (samequot as r)"
  unfolding samequot_exec_def samequot_def lang.simps lang_flatten_PLUS[OF finite_rderivs_same]
  by (cases "while_option fst (rderiv_and_add as) (True, [\<guillemotleft>r\<guillemotright>])")
    (auto dest: samequot_termination dest!: samequot_soundness[of _ _ _ _ n] simp del: ACI_norm_lang)

lemma lang_samequot_exec:
  "\<lbrakk>wf n r; as \<in> \<Sigma> n\<rbrakk> \<Longrightarrow> lang n (samequot_exec as r) = SAMEQUOT as (lang n r)"
unfolding samequot_exec_samequot by (rule lang_samequot)

end

subsection {* Suffix and Prefix Languages *}

definition Suffix :: "'a lang \<Rightarrow> 'a lang" where
  "Suffix L = {w. \<exists>u. u @ w \<in> L}"

definition Prefix :: "'a lang \<Rightarrow> 'a lang" where
  "Prefix L = {w. \<exists>u. w @ u \<in> L}"

lemma Prefix_Suffix: "Prefix L = rev ` Suffix (rev ` L)"
  unfolding Prefix_def Suffix_def
  by (auto simp: rev_append_invert
  intro: image_eqI[of _ rev, OF rev_rev_ident[symmetric]]
         image_eqI[of _ rev, OF rev_append[symmetric]])

definition Root :: "'a lang \<Rightarrow> 'a lang" where
  "Root L = {x . \<exists>n > 0. x ^^ n \<in> L}"

definition Cycle :: "'a lang \<Rightarrow> 'a lang" where
  "Cycle L = {u @ w | u w. w @ u \<in> L}"

context embed
begin

context
fixes n :: nat
begin

definition SUFFIX :: "'b rexp \<Rightarrow> 'b rexp" where
  "SUFFIX r = flatten PLUS {\<guillemotleft>lderivs w r\<guillemotright>| w. wf_word n w}"

lemma finite_lderivs_wf: "finite {\<guillemotleft>lderivs w r\<guillemotright>| w. wf_word n w}"
  by (auto intro: finite_subset[OF _ finite_lderivs])

definition PREFIX :: "'b rexp \<Rightarrow> 'b rexp" where
  "PREFIX r = REV (SUFFIX (REV r))"

lemma wf_SUFFIX[simp]: "wf n r \<Longrightarrow> wf n (SUFFIX r)"
  unfolding SUFFIX_def by (intro iffD2[OF wf_flatten_PLUS[OF finite_lderivs_wf]]) auto

lemma lang_SUFFIX[simp]: "wf n r \<Longrightarrow> lang n (SUFFIX r) = Suffix (lang n r)"
  unfolding SUFFIX_def Suffix_def
  using lang_flatten_PLUS[OF finite_lderivs_wf] lang_lderivs wf_lang_wf_word
  by fastforce

lemma wf_PREFIX[simp]: "wf n r \<Longrightarrow> wf n (PREFIX r)"
  unfolding PREFIX_def by auto

lemma lang_PREFIX[simp]: "wf n r \<Longrightarrow> lang n (PREFIX r) = Prefix (lang n r)"
  unfolding PREFIX_def by (auto simp: Prefix_Suffix)

end

lemma take_drop_CycleI[intro!]: "x \<in> L \<Longrightarrow> drop i x @ take i x \<in> Cycle L"
  unfolding Cycle_def by fastforce

lemma take_drop_CycleI'[intro!]: "drop i x @ take i x \<in> L \<Longrightarrow> x \<in> Cycle L"
  by (drule take_drop_CycleI[of _ _ "length x - i"]) auto

end

(*<*)
end
(*>*)


theory LtakeWhile_K_True
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer

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

primcorec ltakeWhile :: "('a \<Rightarrow> bool) \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist"
where
  "lnull xs \<or> \<not> P (lhd xs) \<Longrightarrow> lnull (ltakeWhile P xs)"
| "lhd (ltakeWhile P xs) = lhd xs"
| "ltl (ltakeWhile P xs) = ltakeWhile P (ltl xs)"
(*hipster ltakeWhile *)
lemma lemma_a [thy_expl]: "ltakeWhile y (ltakeWhile y z) = ltakeWhile y z"
apply (coinduction  arbitrary: y z rule: LtakeWhile_K_True.Llist.coinduct_strong)
  apply simp
by fastforce

lemma lemma_aa [thy_expl]: "ltakeWhile z (ltakeWhile y x2) = ltakeWhile y (ltakeWhile z x2)"
apply (coinduction  arbitrary: x2 y z rule: LtakeWhile_K_True.Llist.coinduct_strong)
apply simp
by fastforce

lemma lemma_ab [thy_expl]: "ltakeWhile y (ltl (ltakeWhile y z)) = ltl (ltakeWhile y z)"
apply (coinduction  arbitrary: y z rule: LtakeWhile_K_True.Llist.coinduct_strong)
apply simp
by (metis (mono_tags, lifting) Llist.sel(2) lemma_a lnull_def ltakeWhile.ctr(1) ltakeWhile.simps(4))

lemma lemma_ac [thy_expl]: "ltakeWhile y (LCons z (ltakeWhile y x2)) = ltakeWhile y (LCons z x2)"
apply (coinduction  arbitrary: x2 y z rule: LtakeWhile_K_True.Llist.coinduct_strong)
apply simp
by (auto lemma_a)

lemma unknown [thy_expl]: "ltl (ltl (ltl y)) = LNil"
oops
theorem ltakeWhile_K_True: "ltakeWhile (\<lambda>_. True) xs = xs"
  by hipster_coinduct_sledgehammer
end


(*******************************************************************************

  Project: IsaNet

  Author:  Tobias Klenze, ETH Zurich <tobias.klenze@inf.ethz.ch>
  Version: JCSPaper.1.0
  Isabelle Version: Isabelle2021-1

  Copyright (c) 2022 Tobias Klenze
  Licence: Mozilla Public License 2.0 (MPL) / BSD-3-Clause (dual license)

*******************************************************************************)

section\<open>Tools\<close>
theory Tools imports Main "HOL-Library.Sublist"
begin

(******************************************************************************)
subsection \<open> Prefixes, suffixes, and fragments \<close>
(******************************************************************************)

thm Cons_eq_appendI (*similar to*)
lemma prefix_cons: "\<lbrakk>prefix xs ys; zs = x # ys; prefix xs' (x # xs)\<rbrakk> \<Longrightarrow> prefix xs' zs"
  by (auto simp add: prefix_def Cons_eq_appendI)

lemma suffix_nonempty_extendable:
  "\<lbrakk>suffix xs l; xs \<noteq> l\<rbrakk> \<Longrightarrow> \<exists> x . suffix (x#xs) l"
apply (auto simp add: suffix_def)
  by (metis append_butlast_last_id)

lemma set_suffix:
  "\<lbrakk>x \<in> set l'; suffix l' l\<rbrakk> \<Longrightarrow> x \<in> set l"
by (auto simp add: suffix_def)

lemma set_prefix:
  "\<lbrakk>x \<in> set l'; prefix l' l\<rbrakk> \<Longrightarrow> x \<in> set l"
by (auto simp add: prefix_def)

lemma set_suffix_elem: "suffix (x#xs) p \<Longrightarrow> x \<in> set p"
  by (meson list.set_intros(1) set_suffix)

lemma set_prefix_elem: "prefix (x#xs) p \<Longrightarrow> x \<in> set p"
  by (meson list.set_intros(1) set_prefix)

lemma Cons_suffix_set: "x \<in> set y \<Longrightarrow> \<exists> xs . suffix (x#xs) y"
  using suffix_def  by (metis split_list)

(******************************************************************************)
subsection \<open> Fragments \<close>
(******************************************************************************)

definition fragment :: "'a list \<Rightarrow> 'a list set \<Rightarrow> bool"
  where "fragment xs St \<longleftrightarrow> (\<exists>zs1 zs2. zs1 @ xs @ zs2 \<in> St)"

lemma fragmentI: "\<lbrakk> zs1 @ xs @ zs2 \<in> St \<rbrakk> \<Longrightarrow> fragment xs St"
by (auto simp add: fragment_def)

lemma fragmentE [elim]: "\<lbrakk>fragment xs St; \<And>zs1 zs2. \<lbrakk> zs1 @ xs @ zs2 \<in> St \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
by (auto simp add: fragment_def)

lemma fragment_Nil [simp]: "fragment [] St \<longleftrightarrow> St \<noteq> {}"
by (force simp add: fragment_def dest: spec [where x="[]"])

lemma fragment_subset: "\<lbrakk>St \<subseteq> St'; fragment l St\<rbrakk> \<Longrightarrow> fragment l St'"
by(auto simp add: fragment_def)

lemma fragment_prefix: "\<lbrakk>prefix l' l; fragment l St\<rbrakk> \<Longrightarrow> fragment l' St"
by(auto simp add: fragment_def prefix_def) blast

lemma fragment_suffix: "\<lbrakk>suffix l' l; fragment l St\<rbrakk> \<Longrightarrow> fragment l' St"
by(auto simp add: fragment_def suffix_def)
  (metis append.assoc)

lemma fragment_self [simp, intro]: "\<lbrakk>l \<in> St\<rbrakk> \<Longrightarrow> fragment l St"
by(auto simp add: fragment_def intro!: exI [where x="[]"])

lemma fragment_prefix_self [simp, intro]:
  "\<lbrakk>l \<in> St; prefix l' l\<rbrakk> \<Longrightarrow> fragment l' St"
using fragment_prefix fragment_self by blast

lemma fragment_suffix_self [simp, intro]:
  "\<lbrakk>l \<in> St; suffix l' l\<rbrakk> \<Longrightarrow> fragment l' St"
using fragment_suffix fragment_self by metis

lemma fragment_is_prefix_suffix:
  "fragment l St \<Longrightarrow> \<exists>pre suff . prefix l pre \<and> suffix pre suff \<and> suff \<in> St"
  by (meson fragment_def prefixI suffixI)

(******************************************************************************)
subsection \<open> Pair Fragments \<close>
(******************************************************************************)

definition pfragment :: "'a \<Rightarrow> ('b list) \<Rightarrow> ('a \<times> ('b list)) set \<Rightarrow> bool"
  where "pfragment a xs St \<longleftrightarrow> (\<exists>zs1 zs2. (a, zs1 @ xs @ zs2) \<in> St)"

lemma pfragmentI: "\<lbrakk> (ainf, zs1 @ xs @ zs2) \<in> St \<rbrakk> \<Longrightarrow> pfragment ainf xs St"
by (auto simp add: pfragment_def)

lemma pfragmentE [elim]: "\<lbrakk>pfragment ainf xs St; \<And>zs1 zs2. \<lbrakk> (ainf, zs1 @ xs @ zs2) \<in> St \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
by (auto simp add: pfragment_def)

lemma pfragment_prefix:
  "pfragment ainf (xs @ ys) St \<Longrightarrow> pfragment ainf xs St"
  by(auto simp add: pfragment_def)

lemma pfragment_prefix':
  "\<lbrakk>pfragment ainf ys St; prefix xs ys\<rbrakk> \<Longrightarrow> pfragment ainf xs St"
  by(auto 3 4 simp add: pfragment_def prefix_def)

lemma pfragment_suffix: "\<lbrakk>suffix l' l; pfragment ainf l St\<rbrakk> \<Longrightarrow> pfragment ainf l' St"
  by(auto simp add: pfragment_def suffix_def)
  (metis append.assoc)

lemma pfragment_self [simp, intro]: "\<lbrakk>(ainf, l) \<in> St\<rbrakk> \<Longrightarrow> pfragment ainf l St"
by(auto simp add: pfragment_def intro!: exI [where x="[]"])

lemma pfragment_suffix_self [simp, intro]:
  "\<lbrakk>(ainf, l) \<in> St; suffix l' l\<rbrakk> \<Longrightarrow> pfragment ainf l' St"
using pfragment_suffix pfragment_self by metis

lemma pfragment_self_eq:
"\<lbrakk>pfragment ainf l S; \<And>zs1 zs2 . (ainf, zs1@l@zs2) \<in> S \<Longrightarrow> (ainf, zs1@l'@zs2) \<in> S\<rbrakk> \<Longrightarrow> pfragment ainf l' S"
  by(auto simp add: pfragment_def)

lemma pfragment_self_eq_nil:
"\<lbrakk>pfragment ainf l S; \<And>zs1 zs2 . (ainf, zs1@l@zs2) \<in> S \<Longrightarrow> (ainf, l'@zs2) \<in> S\<rbrakk> \<Longrightarrow> pfragment ainf l' S"
  apply(auto simp add: pfragment_def)
  apply(rule exI[of _ "[]"])
  by auto

lemma pfragment_cons: "pfragment ainfo (x # fut) S \<Longrightarrow> pfragment ainfo fut S"
  apply(auto 3 4 simp add: pfragment_def)
  subgoal for zs1 zs2
  apply(rule exI[of _ "zs1@[x]"])
    by auto
  done

(******************************************************************************)
subsection \<open> Head and Tails \<close>
(******************************************************************************)

fun head where "head [] = None" | "head (x#xs) = Some x"
fun ifhead where "ifhead [] n = n" | "ifhead (x#xs) _ = Some x"
fun tail where "tail [] = None" | "tail xs = Some (last xs)"

lemma head_cons: "xs \<noteq> [] \<Longrightarrow> head xs = Some (hd xs)" by(cases xs, auto)
lemma tail_cons: "xs \<noteq> [] \<Longrightarrow> tail xs = Some (last xs)" by(cases xs, auto)
lemma tail_snoc: "tail (xs @ [x]) = Some x" by(cases xs, auto)
lemma "\<forall>y ys . l \<noteq> ys @ [y] \<Longrightarrow> l = []"
  using rev_exhaust by blast

lemma tl_append2: "tl (pref @ [a, b]) = tl (pref @ [a])@[b]"
  by(induction pref, auto)

end


theory CallTree
imports PathRel
begin

datatype tree = Leaf | Tree tree "tree list"

fun expand :: "tree \<Rightarrow> nat list" where
"expand Leaf = [0]"
| "expand (Tree t lst) =
   [0] @ map Suc (expand t @ concat (map (tl \<circ> expand) lst)) @ [0]"

value "expand (Tree Leaf [Leaf, Tree Leaf [],
  Tree Leaf [], Leaf])"
value "expand (Tree (Tree Leaf []) [Leaf])"

lemma expand_size : "length (expand t) > 0"
by (cases t; auto)

lemma expand_hd_last : "hd (expand t) = last (expand t)"
by (cases t; auto)

lemma app_nth :
   "i < length a \<Longrightarrow> (a@b)!i = a!i"
  by (simp add: nth_append)

lemma expand_inside_large :
   "0 < i \<Longrightarrow> i < length (expand t) - 1 \<Longrightarrow>
    expand t ! i > 0"
by (cases t; auto simp add:nth_append)

lemma path_app :
   "pathR r a \<Longrightarrow> pathR r b \<Longrightarrow>
    length a > 0 \<Longrightarrow> length b > 0 \<Longrightarrow>
    (last a, hd b) \<in> r \<Longrightarrow>
    pathR r (a@b)"
apply (auto simp add:path_defs path_def nth_append)
  apply (metis Suc_lessI diff_Suc_1 hd_conv_nth last_conv_nth)
apply (subgoal_tac "(Suc i - length a) = Suc (i - length a)"; auto)
done

lemma tree_inc_dec : "inc_decL (expand t)"
apply (induction t)
apply (simp add:inc_decL_def pathR.simps inc_dec_def)
apply auto

oops

lemma tree_call :
   "ncall lst \<Longrightarrow> \<exists>t x. map (%y. y+x) (expand t) = lst"
using ncall_def decompose_call

oops

end


theory Iterative
imports "Env-HOLCF"
begin

text \<open>
A setup for defining a fixed point of mutual recursive environments iteratively
\<close>

locale iterative =
  fixes \<rho> :: "'a::type \<Rightarrow> 'b::pcpo"
   and e1 :: "('a \<Rightarrow> 'b) \<rightarrow> ('a \<Rightarrow> 'b)"
   and e2 :: "('a \<Rightarrow> 'b) \<rightarrow> 'b"
   and S :: "'a set" and x :: 'a
  assumes ne:"x \<notin> S"
begin
  abbreviation "L == (\<Lambda> \<rho>'. (\<rho> ++\<^bsub>S\<^esub> e1 \<cdot> \<rho>')(x := e2 \<cdot> \<rho>'))"
  abbreviation "H == (\<lambda> \<rho>'. \<Lambda> \<rho>''. \<rho>' ++\<^bsub>S\<^esub> e1 \<cdot> \<rho>'')"
  abbreviation "R == (\<Lambda> \<rho>'. (\<rho> ++\<^bsub>S\<^esub> (fix \<cdot> (H \<rho>')))(x := e2 \<cdot> \<rho>'))"
  abbreviation "R' == (\<Lambda> \<rho>'. (\<rho> ++\<^bsub>S\<^esub> (fix \<cdot> (H \<rho>')))(x := e2 \<cdot> (fix \<cdot> (H \<rho>'))))"

  lemma split_x:
    fixes y
    obtains "y = x" and "y \<notin> S" | "y \<in> S" and "y \<noteq> x" | "y \<notin> S" and "y \<noteq> x" using ne by blast
  lemmas below = fun_belowI[OF split_x, where y1 = "\<lambda>x. x"]
  lemmas eq = ext[OF split_x, where y1 = "\<lambda>x. x"]

  lemma lookup_fix[simp]:
    fixes y and F :: "('a \<Rightarrow> 'b) \<rightarrow> ('a \<Rightarrow> 'b)"
    shows "(fix \<cdot> F) y = (F \<cdot> (fix \<cdot> F)) y"
    by (subst fix_eq, rule)

  lemma R_S: "\<And> y. y \<in> S \<Longrightarrow> (fix \<cdot> R) y = (e1 \<cdot> (fix \<cdot> (H (fix \<cdot> R)))) y"
    by (case_tac y rule: split_x) simp_all

  lemma R'_S: "\<And> y. y \<in> S \<Longrightarrow> (fix \<cdot> R') y = (e1 \<cdot> (fix \<cdot> (H (fix \<cdot> R')))) y"
    by (case_tac y rule: split_x) simp_all

  lemma HR_is_R[simp]: "fix\<cdot>(H (fix \<cdot> R)) = fix \<cdot> R"
    by (rule eq) simp_all

  lemma HR'_is_R'[simp]: "fix \<cdot> (H (fix \<cdot> R')) = fix \<cdot> R'"
    by (rule eq) simp_all

  lemma H_noop:
    fixes \<rho>' \<rho>''
    assumes "\<And> y. y \<in> S \<Longrightarrow> y \<noteq> x \<Longrightarrow> (e1 \<cdot> \<rho>'') y \<sqsubseteq> \<rho>' y"
    shows "H \<rho>' \<cdot> \<rho>'' \<sqsubseteq> \<rho>'"
      using assms
      by -(rule below, simp_all)

  lemma HL_is_L[simp]: "fix \<cdot> (H (fix \<cdot> L)) = fix \<cdot> L"
  proof (rule below_antisym)
    show "fix \<cdot> (H (fix \<cdot> L)) \<sqsubseteq> fix \<cdot> L"
      by (rule fix_least_below[OF H_noop]) simp
    hence *: "e2 \<cdot> (fix \<cdot> (H (fix \<cdot> L))) \<sqsubseteq> e2 \<cdot> (fix \<cdot> L)" by (rule monofun_cfun_arg)

    show "fix \<cdot> L \<sqsubseteq> fix \<cdot> (H (fix \<cdot> L))"
      by (rule fix_least_below[OF below]) (simp_all add: ne *)
  qed

  lemma iterative_override_on:
    shows "fix \<cdot> L = fix \<cdot> R"
  proof(rule below_antisym)
    show "fix \<cdot> R \<sqsubseteq> fix \<cdot> L"
      by (rule fix_least_below[OF below]) simp_all

    show "fix \<cdot> L \<sqsubseteq> fix \<cdot> R"
      apply (rule fix_least_below[OF below])
      apply simp
      apply (simp del: lookup_fix add: R_S)
      apply simp
      done
  qed

  lemma iterative_override_on':
    shows "fix \<cdot> L = fix \<cdot>  R'"
  proof(rule below_antisym)
    show "fix \<cdot> R' \<sqsubseteq> fix \<cdot> L"
      by (rule fix_least_below[OF below]) simp_all

    show "fix \<cdot> L \<sqsubseteq> fix \<cdot> R'"
      apply (rule fix_least_below[OF below])
      apply simp
      apply (simp del: lookup_fix add: R'_S)
      apply simp
      done
  qed
end

end


theory Example_Finite_Vars
  imports LValues_Typed "HOL-Library.Word"
begin

typedef mem = \<open>{f. \<forall>(n::string) (i::nat). f(n,i) \<in> {..i}}\<close>
  apply (rule exI[of _ \<open>\<lambda>_. 0\<close>]) by auto
setup_lifting type_definition_mem

definition idx_set where "idx_set (_::'a itself) = {..<CARD('a)}"
definition some_f where "some_f = (SOME f. bij_betw f (idx_set TYPE('val)) (UNIV::'val::finite set))"
definition some_f' :: "'val::finite\<Rightarrow>nat" where "some_f' = inv_into (idx_set TYPE('val)) some_f"

lemma bij_some_f: "bij_betw some_f (idx_set TYPE('val)) (UNIV::'val::finite set)"
  unfolding some_f_def
  apply (rule someI_ex[where P=\<open>\<lambda>f. bij_betw f (idx_set TYPE('val)) (UNIV::'val set)\<close>])
  unfolding idx_set_def
  by (simp add: finite_same_card_bij)

lemma bij_some_f': "bij_betw some_f' (UNIV::'val set) (idx_set TYPE('val::finite))"
  by (simp add: bij_betw_inv_into bij_some_f some_f'_def)

lemma some_f_some_f'[simp]: "some_f (some_f' x) = x"
  by (metis UNIV_I bij_betw_inv_into_right bij_some_f some_f'_def)

lemma some_f'_some_f[simp]: "x \<in> idx_set TYPE('val::finite) \<Longrightarrow> some_f' (some_f x :: 'val) = x"
  unfolding some_f'_def
  by (meson bij_betw_inv_into_left bij_some_f)

lemma some_f'_leq: "some_f' (a::'a::finite) < CARD('a)"
proof -
  have "some_f' a \<in> idx_set TYPE('a)"
    by (meson bij_betw_apply bij_some_f' iso_tuple_UNIV_I)
  then show ?thesis
    unfolding idx_set_def by auto
qed

lift_definition var_getter :: "string \<Rightarrow> mem \<Rightarrow> 'a::finite" is
  "\<lambda>name mem. some_f (mem (name, card (UNIV::'a set)-1))".

lift_definition var_setter :: "string \<Rightarrow> 'a::finite \<Rightarrow> mem \<Rightarrow> mem" is
  "\<lambda>name v mem. mem ((name, card (UNIV::'a set)-1) := some_f' v)"
  using some_f'_leq less_Suc_eq_le by fastforce

definition var :: "string \<Rightarrow> (mem,'a::finite) lvalue" where
  "var name = mk_lvalue (var_getter name) (var_setter name)"

lemma valid_var[simp]: "valid_lvalue (var name :: (_,'val::finite) lvalue)"
  unfolding var_def
proof (rule mk_lvalue_valid)
  fix m and a b :: 'val
  show "var_getter name (var_setter name a m) = a"
    apply transfer by auto
  show "var_setter name (var_getter name m) m = m"
    apply transfer
    apply (subst some_f'_some_f)
    unfolding idx_set_def apply auto
    by (metis Suc_le_lessD Suc_le_mono Suc_pred zero_less_card_finite)

  show "var_setter name a (var_setter name b m) = var_setter name a m"
    apply transfer by auto
qed

lemma var_setter_swap:
  assumes "name \<noteq> name'"
  shows "var_setter name a (var_setter name' b m) = var_setter name' b (var_setter name a m)"
  apply (transfer fixing: name name')
  apply auto
  using assms by auto

lemma compatible_var:
  "n \<noteq> m \<Longrightarrow> compatible_lvalues (var n) (var m)"
  unfolding var_def
  apply (rule mk_lvalue_compat)
  using valid_var unfolding var_def
  apply auto
  apply (subst var_setter_swap)
  by auto

definition x::"(mem,bool)lvalue" where "x = var ''x''"
definition y::"(mem,32 word)lvalue" where "y = var ''y''"

lemma valid_x[simp]: "valid_lvalue x"
  by (simp add: x_def)

lemma valid_y[simp]: "valid_lvalue y"
  by (simp add: y_def)

lemma compat_xy[simp]: "compatible_lvalues x y"
  by (simp add: compatible_var x_def y_def)

lemma compat_yx[simp]: "compatible_lvalues y x"
  by (simp add: compatible_var x_def y_def)

lemma test:
  "getter (lvalue_pair x y) (setter x True (setter y 99 m))
      = (True, 99)"

  by simp

end


section \<open>Definedness\<close>

theory Definedness
  imports
    Data_List
begin

text \<open>
  This is an attempt for a setup for better handling bottom, by a better
  simp setup, and less breaking the abstractions.
\<close>

definition defined :: "'a :: pcpo \<Rightarrow> bool" where
  "defined x = (x \<noteq> \<bottom>)"

lemma defined_bottom [simp]: "\<not> defined \<bottom>"
  by (simp add: defined_def)

lemma defined_seq [simp]: "defined x \<Longrightarrow> seq\<cdot>x\<cdot>y = y"
  by (simp add: defined_def)

consts val :: "'a::type \<Rightarrow> 'b::type" ("\<lbrakk>_\<rbrakk>")

text \<open>val for booleans\<close>

definition val_Bool :: "tr \<Rightarrow> bool" where
  "val_Bool i = (THE j. i = Def j)"

adhoc_overloading
  val val_Bool

lemma defined_Bool_simps [simp]:
  "defined (Def i)"
  "defined TT"
  "defined FF"
  by (simp_all add: defined_def)

lemma val_Bool_simp1 [simp]:
  "\<lbrakk>Def i\<rbrakk> = i"
  by (simp_all add: val_Bool_def TT_def FF_def)

lemma val_Bool_simp2 [simp]:
  "\<lbrakk>TT\<rbrakk> = True"
  "\<lbrakk>FF\<rbrakk> = False"
  by (simp_all add: TT_def FF_def)

lemma IF_simps [simp]:
  "defined b \<Longrightarrow> \<lbrakk> b \<rbrakk> \<Longrightarrow> (If b then x else y) = x"
  "defined b \<Longrightarrow> \<lbrakk> b \<rbrakk> = False \<Longrightarrow> (If b then x else y) = y"
  by (cases b, simp_all)+

lemma defined_neg [simp]: "defined (neg\<cdot>b) \<longleftrightarrow> defined b"
  by (cases b, auto)

lemma val_Bool_neg [simp]: "defined b \<Longrightarrow> \<lbrakk> neg \<cdot> b \<rbrakk> = (\<not> \<lbrakk> b \<rbrakk>)"
  by (cases b, auto)

text \<open>val for integers\<close>

definition val_Integer :: "Integer \<Rightarrow> int" where
  "val_Integer i = (THE j. i = MkI\<cdot>j)"

adhoc_overloading
  val val_Integer

lemma defined_Integer_simps [simp]:
  "defined (MkI\<cdot>i)"
  "defined (0::Integer)"
  "defined (1::Integer)"
  by (simp_all add: defined_def)

lemma defined_numeral [simp]: "defined (numeral x :: Integer)"
  by (simp add: defined_def)

lemma val_Integer_simps [simp]:
  "\<lbrakk>MkI\<cdot>i\<rbrakk> = i"
  "\<lbrakk>0\<rbrakk> = 0"
  "\<lbrakk>1\<rbrakk> = 1"
  by (simp_all add: val_Integer_def)

lemma val_Integer_numeral [simp]: "\<lbrakk> numeral x :: Integer \<rbrakk> = numeral x"
  by (simp_all add: val_Integer_def)

lemma val_Integer_to_MkI:
  "defined i \<Longrightarrow> i = (MkI \<cdot> \<lbrakk> i \<rbrakk>)"
  apply (cases i)
   apply (auto simp add: val_Integer_def defined_def)
  done

lemma defined_Integer_minus [simp]: "defined i \<Longrightarrow> defined j \<Longrightarrow> defined (i - (j::Integer))"
  apply (cases i, auto)
  apply (cases j, auto)
  done

lemma val_Integer_minus [simp]: "defined i \<Longrightarrow> defined j \<Longrightarrow> \<lbrakk> i - j \<rbrakk> = \<lbrakk> i \<rbrakk> - \<lbrakk> j \<rbrakk>"
  apply (cases i, auto)
  apply (cases j, auto)
  done

lemma defined_Integer_plus [simp]: "defined i \<Longrightarrow> defined j \<Longrightarrow> defined (i + (j::Integer))"
  apply (cases i, auto)
  apply (cases j, auto)
  done

lemma val_Integer_plus [simp]: "defined i \<Longrightarrow> defined j \<Longrightarrow> \<lbrakk> i + j \<rbrakk> = \<lbrakk> i \<rbrakk> + \<lbrakk> j \<rbrakk>"
  apply (cases i, auto)
  apply (cases j, auto)
  done

lemma defined_Integer_eq [simp]: "defined (eq\<cdot>a\<cdot>b) \<longleftrightarrow> defined a \<and> defined (b::Integer)"
  apply (cases a, simp)
  apply (cases b, simp)
  apply simp
  done

lemma val_Integer_eq [simp]: "defined a \<Longrightarrow> defined b \<Longrightarrow> \<lbrakk> eq\<cdot>a\<cdot>b \<rbrakk> = (\<lbrakk> a \<rbrakk> = (\<lbrakk> b \<rbrakk> :: int))"
  apply (cases a, simp)
  apply (cases b, simp)
  apply simp
  done

text \<open>Full induction for non-negative integers\<close>

lemma nonneg_full_Int_induct [consumes 1, case_names neg Suc]:
  assumes defined: "defined i"
  assumes neg: "\<And> i. defined i \<Longrightarrow> \<lbrakk>i\<rbrakk> < 0 \<Longrightarrow> P i"
  assumes step: "\<And> i. defined i \<Longrightarrow> 0 \<le> \<lbrakk>i\<rbrakk> \<Longrightarrow> (\<And> j. defined j \<Longrightarrow> \<lbrakk> j \<rbrakk> < \<lbrakk> i \<rbrakk> \<Longrightarrow> P j) \<Longrightarrow> P i"
  shows "P (i::Integer)"
proof (cases i)
  case bottom
  then have False using defined by simp
  then show ?thesis ..
next
  case (MkI integer)
  show ?thesis
  proof (cases integer)
    case neg
    then show ?thesis using assms(2) MkI by simp
  next
    case (nonneg nat)
    have "P (MkI\<cdot>(int nat))"
    proof(induction nat rule:full_nat_induct)
      case (1 nat)
      have "defined (MkI\<cdot>(int nat))" by simp
      moreover
      have "0 \<le> \<lbrakk> MkI\<cdot>(int nat) \<rbrakk>"  by simp
      moreover
      { fix j::Integer
        assume "defined j" and le: "\<lbrakk> j \<rbrakk> < \<lbrakk> MkI\<cdot>(int nat) \<rbrakk>"
        have "P j"
        proof(cases j)
          case bottom with \<open>defined j\<close> show ?thesis by simp
        next
          case (MkI integer)
          show ?thesis
          proof(cases integer)
            case (neg nat)
            have "\<lbrakk>j\<rbrakk> < 0" using neg MkI by simp
            with \<open>defined j\<close>
            show ?thesis by (rule assms(2))
          next
            case (nonneg m)
            have "Suc m \<le> nat" using le nonneg MkI by simp
            then have "P (MkI\<cdot>(int m))" by (metis "1.IH")
            then show ?thesis using nonneg MkI by simp
          qed
        qed
      }
      ultimately
      show ?case
        by (rule step)
    qed
    then show ?thesis using nonneg MkI by simp
  qed
qed

text \<open>Some list lemmas re-done with the new setup.\<close>

lemma nth_tail: (* TODO: move *)
  "defined n \<Longrightarrow> \<lbrakk> n \<rbrakk> \<ge> 0  \<Longrightarrow> tail\<cdot>xs !! n = xs !! (1 + n)"
  apply (cases xs, simp_all)
  apply (cases n, simp)
  apply (simp add: one_Integer_def zero_Integer_def)
  done

lemma nth_zipWith: (* TODO: move *)
  assumes f1 [simp]: "\<And>y. f\<cdot>\<bottom>\<cdot>y = \<bottom>"
  assumes f2 [simp]: "\<And>x. f\<cdot>x\<cdot>\<bottom> = \<bottom>"
  shows "zipWith\<cdot>f\<cdot>xs\<cdot>ys !! n = f\<cdot>(xs !! n)\<cdot>(ys !! n)"
proof (induct xs arbitrary: ys n)
  case (Cons x xs ys n) then show ?case
    by (cases ys, simp_all split:nth_Cons_split)
qed simp_all

lemma nth_neg [simp]: "defined n \<Longrightarrow> \<lbrakk> n \<rbrakk> < 0 \<Longrightarrow> nth\<cdot>xs\<cdot>n = \<bottom>"
proof (induction xs arbitrary: n)
  have [simp]: "eq\<cdot>n\<cdot>0 = TT \<longleftrightarrow> (n::Integer) = 0" for n
    by (cases n, auto simp add: zero_Integer_def)
  case (Cons a xs n)
  have "eq\<cdot>n\<cdot>0 = FF"
    using Cons.prems
    by (cases "eq\<cdot>n\<cdot>0") auto
  then show ?case
    using Cons.prems
    by (auto intro: Cons.IH)
qed simp_all

lemma nth_Cons_simp [simp]:
  "defined n \<Longrightarrow> \<lbrakk> n \<rbrakk> = 0 \<Longrightarrow> nth\<cdot>(x : xs)\<cdot>n = x"
  "defined n \<Longrightarrow> \<lbrakk> n \<rbrakk> > 0 \<Longrightarrow> nth\<cdot>(x : xs)\<cdot>n = nth\<cdot>xs\<cdot>(n - 1)"
proof -
  assume "defined n" and "\<lbrakk> n \<rbrakk> = 0"
  then have "n = 0"  by (cases n) auto
  then show "nth\<cdot>(x : xs)\<cdot>n = x" by simp
next
  assume "defined n" and "\<lbrakk> n \<rbrakk> > 0"
  then have "eq\<cdot>n\<cdot>0 = FF" by (cases "eq\<cdot>n\<cdot>0") auto
  then show "nth\<cdot>(x : xs)\<cdot>n = nth\<cdot>xs\<cdot>(n - 1)" by simp
qed

end


(*  Title:      HOL/HOLCF/ex/Hoare.thy
    Author:     Franz Regensburger

Theory for an example by C.A.R. Hoare

p x = if b1 x
         then p (g x)
         else x fi

q x = if b1 x orelse b2 x
         then q (g x)
         else x fi

Prove: for all b1 b2 g .
            q o p  = q

In order to get a nice notation we fix the functions b1,b2 and g in the
signature of this example

*)

theory Hoare
imports HOLCF
begin

axiomatization
  b1 :: "'a -> tr" and
  b2 :: "'a -> tr" and
  g :: "'a -> 'a"

definition
  p :: "'a -> 'a" where
  "p = fix$(LAM f. LAM x. If b1$x then f$(g$x) else x)"

definition
  q :: "'a -> 'a" where
  "q = fix$(LAM f. LAM x. If b1$x orelse b2$x then f$(g$x) else x)"

(* --------- pure HOLCF logic, some little lemmas ------ *)

lemma hoare_lemma2: "b~=TT ==> b=FF | b=UU"
apply (rule Exh_tr [THEN disjE])
apply blast+
done

lemma hoare_lemma3: " (ALL k. b1$(iterate k$g$x) = TT) | (EX k. b1$(iterate k$g$x)~=TT)"
apply blast
done

lemma hoare_lemma4: "(EX k. b1$(iterate k$g$x) ~= TT) ==>
  EX k. b1$(iterate k$g$x) = FF | b1$(iterate k$g$x) = UU"
apply (erule exE)
apply (rule exI)
apply (rule hoare_lemma2)
apply assumption
done

lemma hoare_lemma5: "[|(EX k. b1$(iterate k$g$x) ~= TT);
    k=Least(%n. b1$(iterate n$g$x) ~= TT)|] ==>
  b1$(iterate k$g$x)=FF | b1$(iterate k$g$x)=UU"
apply hypsubst
apply (rule hoare_lemma2)
apply (erule exE)
apply (erule LeastI)
done

lemma hoare_lemma6: "b=UU ==> b~=TT"
apply hypsubst
apply (rule dist_eq_tr)
done

lemma hoare_lemma7: "b=FF ==> b~=TT"
apply hypsubst
apply (rule dist_eq_tr)
done

lemma hoare_lemma8: "[|(EX k. b1$(iterate k$g$x) ~= TT);
    k=Least(%n. b1$(iterate n$g$x) ~= TT)|] ==>
  ALL m. m < k --> b1$(iterate m$g$x)=TT"
apply hypsubst
apply (erule exE)
apply (intro strip)
apply (rule_tac p = "b1$ (iterate m$g$x) " in trE)
prefer 2 apply (assumption)
apply (rule le_less_trans [THEN less_irrefl [THEN notE]])
prefer 2 apply (assumption)
apply (rule Least_le)
apply (erule hoare_lemma6)
apply (rule le_less_trans [THEN less_irrefl [THEN notE]])
prefer 2 apply (assumption)
apply (rule Least_le)
apply (erule hoare_lemma7)
done

lemma hoare_lemma28: "f$(y::'a)=(UU::tr) ==> f$UU = UU"
by (rule strictI)

(* ----- access to definitions ----- *)

lemma p_def3: "p$x = If b1$x then p$(g$x) else x"
apply (rule trans)
apply (rule p_def [THEN eq_reflection, THEN fix_eq3])
apply simp
done

lemma q_def3: "q$x = If b1$x orelse b2$x then q$(g$x) else x"
apply (rule trans)
apply (rule q_def [THEN eq_reflection, THEN fix_eq3])
apply simp
done

(** --------- proofs about iterations of p and q ---------- **)

lemma hoare_lemma9: "(ALL m. m< Suc k --> b1$(iterate m$g$x)=TT) -->
   p$(iterate k$g$x)=p$x"
apply (induct_tac k)
apply (simp (no_asm))
apply (simp (no_asm))
apply (intro strip)
apply (rule_tac s = "p$ (iterate n$g$x) " in trans)
apply (rule trans)
apply (rule_tac [2] p_def3 [symmetric])
apply (rule_tac s = "TT" and t = "b1$ (iterate n$g$x) " in ssubst)
apply (rule mp)
apply (erule spec)
apply (simp (no_asm) add: less_Suc_eq)
apply simp
apply (erule mp)
apply (intro strip)
apply (rule mp)
apply (erule spec)
apply (erule less_trans)
apply simp
done

lemma hoare_lemma24: "(ALL m. m< Suc k --> b1$(iterate m$g$x)=TT) -->
  q$(iterate k$g$x)=q$x"
apply (induct_tac k)
apply (simp (no_asm))
apply (simp (no_asm) add: less_Suc_eq)
apply (intro strip)
apply (rule_tac s = "q$ (iterate n$g$x) " in trans)
apply (rule trans)
apply (rule_tac [2] q_def3 [symmetric])
apply (rule_tac s = "TT" and t = "b1$ (iterate n$g$x) " in ssubst)
apply blast
apply simp
apply (erule mp)
apply (intro strip)
apply (fast dest!: less_Suc_eq [THEN iffD1])
done

(* -------- results about p for case (EX k. b1$(iterate k$g$x)~=TT) ------- *)

lemma hoare_lemma10:
  "EX k. b1$(iterate k$g$x) ~= TT
    ==> Suc k = (LEAST n. b1$(iterate n$g$x) ~= TT) ==> p$(iterate k$g$x) = p$x"
  by (rule hoare_lemma8 [THEN hoare_lemma9 [THEN mp]])

lemma hoare_lemma11: "(EX n. b1$(iterate n$g$x) ~= TT) ==>
  k=(LEAST n. b1$(iterate n$g$x) ~= TT) & b1$(iterate k$g$x)=FF
  --> p$x = iterate k$g$x"
apply (case_tac "k")
apply hypsubst
apply (simp (no_asm))
apply (intro strip)
apply (erule conjE)
apply (rule trans)
apply (rule p_def3)
apply simp
apply hypsubst
apply (intro strip)
apply (erule conjE)
apply (rule trans)
apply (erule hoare_lemma10 [symmetric])
apply assumption
apply (rule trans)
apply (rule p_def3)
apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
apply (rule hoare_lemma8 [THEN spec, THEN mp])
apply assumption
apply assumption
apply (simp (no_asm))
apply (simp (no_asm))
apply (rule trans)
apply (rule p_def3)
apply (simp (no_asm) del: iterate_Suc add: iterate_Suc [symmetric])
apply (erule_tac s = "FF" in ssubst)
apply simp
done

lemma hoare_lemma12: "(EX n. b1$(iterate n$g$x) ~= TT) ==>
  k=Least(%n. b1$(iterate n$g$x)~=TT) & b1$(iterate k$g$x)=UU
  --> p$x = UU"
apply (case_tac "k")
apply hypsubst
apply (simp (no_asm))
apply (intro strip)
apply (erule conjE)
apply (rule trans)
apply (rule p_def3)
apply simp
apply hypsubst
apply (simp (no_asm))
apply (intro strip)
apply (erule conjE)
apply (rule trans)
apply (rule hoare_lemma10 [symmetric])
apply assumption
apply assumption
apply (rule trans)
apply (rule p_def3)
apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
apply (rule hoare_lemma8 [THEN spec, THEN mp])
apply assumption
apply assumption
apply (simp (no_asm))
apply (simp)
apply (rule trans)
apply (rule p_def3)
apply simp
done

(* -------- results about p for case  (ALL k. b1$(iterate k$g$x)=TT) ------- *)

lemma fernpass_lemma: "(ALL k. b1$(iterate k$g$x)=TT) ==> ALL k. p$(iterate k$g$x) = UU"
apply (rule p_def [THEN eq_reflection, THEN def_fix_ind])
apply simp
apply simp
apply (simp (no_asm))
apply (rule allI)
apply (rule_tac s = "TT" and t = "b1$ (iterate k$g$x) " in ssubst)
apply (erule spec)
apply (simp)
apply (rule iterate_Suc [THEN subst])
apply (erule spec)
done

lemma hoare_lemma16: "(ALL k. b1$(iterate k$g$x)=TT) ==> p$x = UU"
apply (rule_tac F1 = "g" and t = "x" in iterate_0 [THEN subst])
apply (erule fernpass_lemma [THEN spec])
done

(* -------- results about q for case  (ALL k. b1$(iterate k$g$x)=TT) ------- *)

lemma hoare_lemma17: "(ALL k. b1$(iterate k$g$x)=TT) ==> ALL k. q$(iterate k$g$x) = UU"
apply (rule q_def [THEN eq_reflection, THEN def_fix_ind])
apply simp
apply simp
apply (rule allI)
apply (simp (no_asm))
apply (rule_tac s = "TT" and t = "b1$ (iterate k$g$x) " in ssubst)
apply (erule spec)
apply (simp)
apply (rule iterate_Suc [THEN subst])
apply (erule spec)
done

lemma hoare_lemma18: "(ALL k. b1$(iterate k$g$x)=TT) ==> q$x = UU"
apply (rule_tac F1 = "g" and t = "x" in iterate_0 [THEN subst])
apply (erule hoare_lemma17 [THEN spec])
done

lemma hoare_lemma19:
  "(ALL k. (b1::'a->tr)$(iterate k$g$x)=TT) ==> b1$(UU::'a) = UU | (ALL y. b1$(y::'a)=TT)"
apply (rule flat_codom)
apply (rule_tac t = "x" in iterate_0 [THEN subst])
apply (erule spec)
done

lemma hoare_lemma20: "(ALL y. b1$(y::'a)=TT) ==> ALL k. q$(iterate k$g$(x::'a)) = UU"
apply (rule q_def [THEN eq_reflection, THEN def_fix_ind])
apply simp
apply simp
apply (rule allI)
apply (simp (no_asm))
apply (rule_tac s = "TT" and t = "b1$ (iterate k$g$ (x::'a))" in ssubst)
apply (erule spec)
apply (simp)
apply (rule iterate_Suc [THEN subst])
apply (erule spec)
done

lemma hoare_lemma21: "(ALL y. b1$(y::'a)=TT) ==> q$(x::'a) = UU"
apply (rule_tac F1 = "g" and t = "x" in iterate_0 [THEN subst])
apply (erule hoare_lemma20 [THEN spec])
done

lemma hoare_lemma22: "b1$(UU::'a)=UU ==> q$(UU::'a) = UU"
apply (subst q_def3)
apply simp
done

(* -------- results about q for case (EX k. b1$(iterate k$g$x) ~= TT) ------- *)

lemma hoare_lemma25: "EX k. b1$(iterate k$g$x) ~= TT
  ==> Suc k = (LEAST n. b1$(iterate n$g$x) ~= TT) ==> q$(iterate k$g$x) = q$x"
  by (rule hoare_lemma8 [THEN hoare_lemma24 [THEN mp]])

lemma hoare_lemma26: "(EX n. b1$(iterate n$g$x)~=TT) ==>
  k=Least(%n. b1$(iterate n$g$x) ~= TT) & b1$(iterate k$g$x) =FF
  --> q$x = q$(iterate k$g$x)"
apply (case_tac "k")
apply hypsubst
apply (intro strip)
apply (simp (no_asm))
apply hypsubst
apply (intro strip)
apply (erule conjE)
apply (rule trans)
apply (rule hoare_lemma25 [symmetric])
apply assumption
apply assumption
apply (rule trans)
apply (rule q_def3)
apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
apply (rule hoare_lemma8 [THEN spec, THEN mp])
apply assumption
apply assumption
apply (simp (no_asm))
apply (simp (no_asm))
done

lemma hoare_lemma27: "(EX n. b1$(iterate n$g$x) ~= TT) ==>
  k=Least(%n. b1$(iterate n$g$x)~=TT) & b1$(iterate k$g$x)=UU
  --> q$x = UU"
apply (case_tac "k")
apply hypsubst
apply (simp (no_asm))
apply (intro strip)
apply (erule conjE)
apply (subst q_def3)
apply (simp)
apply hypsubst
apply (simp (no_asm))
apply (intro strip)
apply (erule conjE)
apply (rule trans)
apply (rule hoare_lemma25 [symmetric])
apply assumption
apply assumption
apply (rule trans)
apply (rule q_def3)
apply (rule_tac s = "TT" and t = "b1$ (iterate nat$g$x) " in ssubst)
apply (rule hoare_lemma8 [THEN spec, THEN mp])
apply assumption
apply assumption
apply (simp (no_asm))
apply (simp)
apply (rule trans)
apply (rule q_def3)
apply (simp)
done

(* ------- (ALL k. b1$(iterate k$g$x)=TT) ==> q o p = q   ----- *)

lemma hoare_lemma23: "(ALL k. b1$(iterate k$g$x)=TT) ==> q$(p$x) = q$x"
apply (subst hoare_lemma16)
apply assumption
apply (rule hoare_lemma19 [THEN disjE])
apply assumption
apply (simplesubst hoare_lemma18)
apply assumption
apply (simplesubst hoare_lemma22)
apply assumption
apply (rule refl)
apply (simplesubst hoare_lemma21)
apply assumption
apply (simplesubst hoare_lemma21)
apply assumption
apply (rule refl)
done

(* ------------  EX k. b1~(iterate k$g$x) ~= TT ==> q o p = q   ----- *)

lemma hoare_lemma29: "EX k. b1$(iterate k$g$x) ~= TT ==> q$(p$x) = q$x"
apply (rule hoare_lemma5 [THEN disjE])
apply assumption
apply (rule refl)
apply (subst hoare_lemma11 [THEN mp])
apply assumption
apply (rule conjI)
apply (rule refl)
apply assumption
apply (rule hoare_lemma26 [THEN mp, THEN subst])
apply assumption
apply (rule conjI)
apply (rule refl)
apply assumption
apply (rule refl)
apply (subst hoare_lemma12 [THEN mp])
apply assumption
apply (rule conjI)
apply (rule refl)
apply assumption
apply (subst hoare_lemma22)
apply (subst hoare_lemma28)
apply assumption
apply (rule refl)
apply (rule sym)
apply (subst hoare_lemma27 [THEN mp])
apply assumption
apply (rule conjI)
apply (rule refl)
apply assumption
apply (rule refl)
done

(* ------ the main proof q o p = q ------ *)

theorem hoare_main: "q oo p = q"
apply (rule cfun_eqI)
apply (subst cfcomp2)
apply (rule hoare_lemma3 [THEN disjE])
apply (erule hoare_lemma23)
apply (erule hoare_lemma29)
done

end